00001  IDENTIFICATION DIVISION.                                         07/30/98
00002  PROGRAM-ID.             MACCU351.                                DTSCU351
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV001
00004  DATE-WRITTEN.           DECEMBER 1991.                           DTSCU351
00005  DATE-COMPILED.                                                   DTSCU351
00006                                                                   DTSCU351
00007 *****                                                             DTSCU351
00008 *                                                                 DTSCU351
00009 *    FUNCTION:  FIELD ASSIGNMENT MEMORANDUM PRINT.                DTSCU351
00010 *                                                                 DTSCU351
00011 *                                                                 DTSCU351
00012 *    MODIFICATION LOG:                                            DTSCU351
00013 *                                                                 DTSCU351
00014 *    12/08/91  INITIAL DEVELOPMENT.                               DTSCU351
00015 *              WORK ORDER:                      PROGRAMMER: TCL   DTSCU351
00016 *                                                                 DTSCU351
00017 *    11/07/97  MODIFICATIONS TO REFLECT TRANSFER OF UI TAX        DTSCU351
00018 *              FUNCTIONS FROM DLI TO DOR.                         DTSCU351
00019 *              WORK ORDER: TCL 208              PROGRAMMER: EHH   DTSCU351
00020 *                                                                 DTSCU351
00021 *    03/24/92                                                     DTSCU351
00022 *              WORK ORDER:                      PROGRAMMER: JME   DTSCU351
00023 *                                                                 DTSCU351
00024 *                                                                 DTSCU351
00025 *  DESCRIPTION:                                                   DTSCU351
00026 *                                                                 DTSCU351
00027 *    MACCU351 IS PASSED L351-EMP-NO, L351-ASSGN-NO,               DTSCU351
00028 *    L351-PRINTER-ID, L351-COPY-CNT, L351-TASK-START-DISP-DATE,   DTSCU351
00029 *    AND L351-TASK-START-DISP-TIME.                               DTSCU351
00030 *                                                                 DTSCU351
00031 *    SEE \RAP\RPT\601R1 FOR FIELD ASSIGNMENT MEMORANDUM DESCRIPTIODTSCU351
00032 *    DESCRIPTION AND FORMAT.                                      DTSCU351
00033 *                                                                 DTSCU351
00034 *    USE TS Q 'P' TO COMMUNICATE PRINT LINES TO MACIL357.         DTSCU351
00035 *                                                                 DTSCU351
00036 *                                                                 DTSCU351
00037 *    RECORDS READ:                                                DTSCU351
00038 *                                                                 DTSCU351
00039 *      MASTER:                                                    DTSCU351
00040 *                                                                 DTSCU351
00041 *        MPRF                                                     DTSCU351
00042 *        MFAS                                                     DTSCU351
00043 *        MTAD                                                     DTSCU351
00044 *        MOPO                                                     DTSCU351
00045 *                                                                 DTSCU351
00046 *                                                                 DTSCU351
00047 *    MODULES LINKED TO:                                           DTSCU351
00048 *                                                                 DTSCU351
00049 *      MACCU036  FIELD SUPPORT CODES EDIT/DESCRIPTION.            DTSCU351
00050 *      MACCU062  FIELD REP ID EDIT/DESCRIPTION.                   DTSCU351
00051 *      MACCU063  FIELD ASSIGNMENT TYPE EDIT/DESCRIPTION.          DTSCU351
00052 *      MACCU071  NAME EDIT/CONVERSION.                            DTSCU351
00053 *      MACCU112  FORMAT ADDRESS FOR MAILING.                      DTSCU351
00054 *      MACCU119  AGENCY FACTS.                                    DTSCU351
00055 *      MACCU357  ON-LINE PRINTING.                                DTSCU351
00056 *      MACCU810  MASTER FILE INPUT/OUTPUT.                        DTSCU351
00057 *      MACCU829  TEMPORARY STORAGE INPUT/OUTPUT.                  DTSCU351
00058 *                                                                 DTSCU351
00059 *                                                                 DTSCU351
00060 *    VERMONT REFERENCE:                                           DTSCU351
00061 *                                                                 DTSCU351
00062 *      TXCU351.                                                   DTSCU351
00063 *                                                                 DTSCU351
00064 *                                                                 DTSCU351
00065 *    NOTES TO JEFF:                                               DTSCU351
00066 *                                                                 DTSCU351
00067 *    .  SEE RPT601R1.* IN RPT.ZIP FOR DEFINITIONS AND LAYOUT OF   DTSCU351
00068 *       THE REPORT.                                               DTSCU351
00069 *                                                                 DTSCU351
00070 *    .  DON'T GET TOO CUTE FLOATING PRINT LINES UP AND DOWN THE   DTSCU351
00071 *       PAGE.  JUST SO THE PRINT LOOKS REASONABLE.                DTSCU351
00072 *                                                                 DTSCU351
00073 *    .  YOU WON'T BE ABLE TO TEST THE MOPO RELATED LOGIC UNTIL    DTSCU351
00074 *       WE GET MACCS15 WRITTEN.  I WILL SEND YOU MACCS15 IN A     DTSCU351
00075 *       WEEK OR TWO.                                              DTSCU351
00076 *                                                                 DTSCU351
00077 *                                                                 DTSCU351
00078 *****                                                             DTSCU351
00079                                                                   DTSCU351
00080  ENVIRONMENT DIVISION.                                            DTSCU351
00081                                                                   DTSCU351
00082  DATA DIVISION.                                                   DTSCU351
00083                                                                   DTSCU351
00084  WORKING-STORAGE SECTION.                                         DTSCU351
000845 77  PAN-VALET PICTURE X(24) VALUE '001DTSCU351  07/30/98'.       DTSCU351
00085                                                                   DTSCU351
00086  01  WRK-AREA.                                                    DTSCU351
00087      05  WRK-ABEND-CODE              PIC  X(04)  VALUE 'U351'.    DTSCU351
00088                                                                   DTSCU351
00089      05  LINE-CNT                    PIC S9(04)  COMP.            DTSCU351
00090                                                                   DTSCU351
00091      05  WRK-OCC                     PIC S9(04)  COMP.            DTSCU351
00092                                                                   DTSCU351
00093      05  WRK-OCC1                    PIC S9(04)  COMP.            DTSCU351
00094                                                                   DTSCU351
00095      05  WRK-OCC2                    PIC S9(04)  COMP.            DTSCU351
00096                                                                   DTSCU351
00097      05  WRK-COPY-CNT                PIC S9(01)  COMP-3.          DTSCU351
00098                                                                   DTSCU351
00099      05  WRK-BLANK-LINE-IND   PIC X(01).                          DTSCU351
00100          88  WRK-BLANK-LINE-YES-88    VALUE 'Y'.                  DTSCU351
00101          88  WRK-BLANK-LINE-NO-88    VALUE 'N'.                   DTSCU351
00102                                                                   DTSCU351
00103      05  WRK-CC               PIC  X(01).                         DTSCU351
00104          88  WRK-CC-NONE             VALUE ' '.                   DTSCU351
00105          88  WRK-CC-SKIP-LINE        VALUE '0'.                   DTSCU351
00106                                                                   DTSCU351
00107  01  WRK-ASSIGN-DESC.                                             DTSCU351
00108      05  WRK-ASSIGN-DESC1            PIC X(20).                   DTSCU351
00109      05  WRK-ASSIGN-DESC2            PIC X(20).                   DTSCU351
00110                                                                   DTSCU351
00111  01  TS-AREA.                                                     DTSCU351
00112      05  TS-LINE-CNT                 PIC S9(04)  COMP.            DTSCU351
00113      05  TS-LINE OCCURS 66 TIMES                                  DTSCU351
00114                  INDEXED BY TS-LINE-IDX.                          DTSCU351
00115          10  TS-CC                       PIC  X(01).              DTSCU351
00116              88  TS-CC-NEW-PAGE       VALUE '1'.                  DTSCU351
00117              88  TS-CC-SKIP-LINE      VALUE '0'.                  DTSCU351
00118              88  TS-CC-NONE           VALUE ' '.                  DTSCU351
00119          10  TS-TEXT                     PIC  X(78).              DTSCU351
00120                                                                   DTSCU351
00121  01  WRK-ADDRESSES.                                               DTSCU351
00122      05  WRK-ADDRESS OCCURS 6 TIMES.                              DTSCU351
00123          10  WRK-MAILING-LINE OCCURS 6 TIMES PIC  X(40).          DTSCU351
00124                                                                   DTSCU351
00125  01  WRK-TELEPHONES.                                              DTSCU351
00126 *    05  WRK-PHONES OCCURS 6 TIMES.                               DTSCU351
00127          10  WRK-TELEPHONE.                                       DTSCU351
00128              15  WRK-TELEPHONE-LEFT     PIC X(01).                DTSCU351
00129              15  WRK-TELEPHONE-AREA-CD  PIC X(03).                DTSCU351
00130              15  WRK-TELEPHONE-RIGHT    PIC X(02).                DTSCU351
00131              15  WRK-TELEPHONE-PREFIX   PIC X(03).                DTSCU351
00132              15  WRK-TELPHONE-DASH      PIC X(01).                DTSCU351
00133              15  WRK-TELEPHONE-SUFFIX   PIC X(04).                DTSCU351
00134              15  WRK-TELEPHONE-EXT-LBL  PIC X(06).                DTSCU351
00135              15  WRK-TELEPHONE-EXT      PIC X(04).                DTSCU351
00136                                                                   DTSCU351
00137  01  WRK-HEADING-1.                                               DTSCU351
00138      05  WRK-PROGRAM           PIC  X(05)  VALUE '601R1'.         DTSCU351
00139      05  FILLER                PIC  X(19)  VALUE SPACES.          DTSCU351
00140      05  WRK-AGY-NAMEA-CNTR    PIC  X(40).                        DTSCU351
00141      05  FILLER                PIC  X(06)  VALUE SPACES.          DTSCU351
00142      05  WRK-SYS-DATE          PIC  X(08).                        DTSCU351
00143                                                                   DTSCU351
00144  01  WRK-HEADING-2.                                               DTSCU351
00145      05  FILLER                PIC  X(25)  VALUE SPACES.          DTSCU351
00146      05  FILLER                PIC  X(27)  VALUE                  DTSCU351
00147         'FIELD ASSIGNMENT MEMORANDUM'.                            DTSCU351
00148      05  FILLER                PIC  X(18)  VALUE SPACES.          DTSCU351
00149      05  WRK-SYS-TIME          PIC  X(08).                        DTSCU351
00150                                                                   DTSCU351
00151  01  WRK-LINE-TO.                                                 DTSCU351
00152      05  FILLER                PIC  X(13)  VALUE '         TO: '. DTSCU351
00153      05  WRK-FIELD-REP-NAME    PIC  X(32).                        DTSCU351
00154      05  FILLER                PIC  X(13)  VALUE '  ASSIGN NO: '. DTSCU351
00155      05  WRK-ASSIGN-NO         PIC  99B99999.                     DTSCU351
00156                                                                   DTSCU351
00157  01  WRK-LINE-FROM.                                               DTSCU351
00158      05  FILLER                PIC  X(13)                         DTSCU351
00159            VALUE '       FROM: '.                                 DTSCU351
00160      05  WRK-ORIGINATOR        PIC  X(32).                        DTSCU351
00161      05  FILLER                PIC  X(13)  VALUE '   DUE DATE: '. DTSCU351
00162      05  WRK-DUE-DATE          PIC  X(08).                        DTSCU351
00163                                                                   DTSCU351
00164  01  WRK-LINE-EMP-NO.                                             DTSCU351
00165      05  FILLER                PIC  X(13)  VALUE '     EMP NO: '. DTSCU351
00166      05  WRK-EMP-NO            PIC  999B999.                      DTSCU351
00167      05  FILLER                PIC  X(25)  VALUE SPACES.          DTSCU351
00168      05  FILLER                PIC  X(13)  VALUE 'ASSIGN TYPE: '. DTSCU351
00169      05  WRK-ASSIGN-TYPE       PIC  X(02).                        DTSCU351
00170                                                                   DTSCU351
00171  01  WRK-LINE-ASSIGN-1.                                           DTSCU351
00172      05  FILLER                PIC  X(58)  VALUE SPACES.          DTSCU351
00173      05  WRK-ASSIGN-TYPE-DESC1 PIC  X(20).                        DTSCU351
00174                                                                   DTSCU351
00175  01  WRK-LINE-ASSIGN-2.                                           DTSCU351
00176      05  FILLER                PIC  X(13)  VALUE '        SIC: '. DTSCU351
00177      05  WRK-SIC-CD            PIC  X(07).                        DTSCU351
00178      05  FILLER                PIC  X(01)  VALUE SPACES.          DTSCU351
00179      05  WRK-OWN-CD            PIC  X(02).                        DTSCU351
00180      05  FILLER                PIC  X(35)  VALUE SPACES.          DTSCU351
00181      05  WRK-ASSIGN-TYPE-DESC2 PIC  X(20).                        DTSCU351
00182                                                                   DTSCU351
00183  01  WRK-LINE-FEIN.                                               DTSCU351
00184      05  FILLER                PIC  X(13)  VALUE '       FEIN: '. DTSCU351
00185      05  WRK-FEIN-X            PIC  X(11).                        DTSCU351
00186      05  WRK-FEIN REDEFINES WRK-FEIN-X                            DTSCU351
00187                                PIC  99B9999999B.                  DTSCU351
00188      05  FILLER                PIC  X(20) VALUE SPACES.           DTSCU351
00189      05  FILLER                PIC  X(14) VALUE 'AUDIT PERIOD: '. DTSCU351
00190      05  WRK-AUDIT-YRQ-START   PIC  X(04).                        DTSCU351
00191      05  FILLER                PIC  X(03) VALUE ' - '.            DTSCU351
00192      05  WRK-AUDIT-YRQ-END     PIC  X(04).                        DTSCU351
00193                                                                   DTSCU351
00194  01  WRK-EMP-SIZE-LINE.                                           DTSCU351
00195      05  FILLER                PIC  X(43) VALUE SPACES.           DTSCU351
00196      05  FILLER                PIC  X(15) VALUE 'EMPLOYER SIZE: '.DTSCU351
00197      05  WRK-EMP-SIZE          PIC  X(05).                        DTSCU351
00198                                                                   DTSCU351
00199  01  WRK-LINE-ADDRESS.                                            DTSCU351
00200      05  WRK-TAD-ADDRESS       PIC  X(40).                        DTSCU351
00201      05  FILLER                PIC  X(01)  VALUE SPACES.          DTSCU351
00202      05  WRK-OPO-ADDRESS       PIC  X(37).                        DTSCU351
00203                                                                   DTSCU351
00204  01  WRK-LINE-RE.                                                 DTSCU351
00205      05  FILLER                PIC  X(13)  VALUE 'RE CLAIMANT: '. DTSCU351
00206      05  WRK-CLAIMANT-SSN      PIC  999B99B9999.                  DTSCU351
00207      05  FILLER                PIC  X(04)  VALUE SPACES.          DTSCU351
00208      05  WRK-CLAIMANT-NAME     PIC  X(32).                        DTSCU351
00209                                                                   DTSCU351
00210  01  WRK-LINE-RELATED-EMP.                                        DTSCU351
00211      05  FILLER                PIC  X(13)  VALUE 'RELATED EMP: '. DTSCU351
00212      05  WRK-RELATED-EMP-NO    PIC  999B999.                      DTSCU351
00213      05  FILLER                PIC  X(04)  VALUE SPACES.          DTSCU351
00214      05  WRK-RELATED-EMP-NAME  PIC  X(40).                        DTSCU351
00215                                                                   DTSCU351
00216  01  WRK-LINE-TEXT.                                               DTSCU351
00217      05  WRK-TEXT              PIC  X(72)  VALUE SPACES.          DTSCU351
00218                                                                   DTSCU351
00219  01  WRK-LINE-COPY.                                               DTSCU351
00220      05  FILLER                PIC  X(25)  VALUE SPACES.          DTSCU351
00221      05  WRK-COPY-LIT          PIC  X(20).                        DTSCU351
00222      EJECT                                                        DTSCU351
00223  01  L001-COMM-AREA.                                              DTSCU351
00224      COPY MACIL001.                                               DTSCU351
00225      EJECT                                                        DTSCU351
00226  01  L004-COMM-AREA.                                              DTSCU351
00227      COPY MACIL004.                                               DTSCU351
00228      EJECT                                                        DTSCU351
00229  01  L056-COMM-AREA.                                              DTSCU351
00230      COPY MACIL056.                                               DTSCU351
00231      EJECT                                                        DTSCU351
00232  01  L062-COMM-AREA.                                              DTSCU351
00233      COPY MACIL062.                                               DTSCU351
00234      EJECT                                                        DTSCU351
00235  01  L063-COMM-AREA.                                              DTSCU351
00236      COPY MACIL063.                                               DTSCU351
00237      EJECT                                                        DTSCU351
00238  01  L071-COMM-AREA.                                              DTSCU351
00239      COPY MACIL071.                                               DTSCU351
00240      EJECT                                                        DTSCU351
00241  01  L082-COMM-AREA.                                              DTSCU351
00242      COPY MACIL082.                                               DTSCU351
00243      EJECT                                                        DTSCU351
00244  01  L112-COMM-AREA.                                              DTSCU351
00245      COPY MACIL112.                                               DTSCU351
00246      EJECT                                                        DTSCU351
00247  01  L119-COMM-AREA.                                              DTSCU351
00248      COPY MACIL119.                                               DTSCU351
00249      EJECT                                                        DTSCU351
00250  01  L357-COMM-AREA.                                              DTSCU351
00251      COPY MACIL357.                                               DTSCU351
00252      EJECT                                                        DTSCU351
00253  01  L829-COMM-AREA.                                              DTSCU351
00254      05  L829-CONTROL-BLOCK.                                      DTSCU351
00255          COPY MACIL829.                                           DTSCU351
00256                                                                   DTSCU351
00257      05  L829-REC.                                                DTSCU351
00258          COPY MACIXPTS.                                           DTSCU351
00259      EJECT                                                        DTSCU351
00260  01  L810-COMM-AREA.                                              DTSCU351
00261      05  L810-CONTROL-BLOCK.                                      DTSCU351
00262          COPY  MACIL810.                                          DTSCU351
00263                                                                   DTSCU351
00264      05  MSKL-REC.                                                DTSCU351
00265          COPY MACIMSKL.                                           DTSCU351
00266      EJECT                                                        DTSCU351
00267  01  MPRF-REC.                                                    DTSCU351
00268      COPY MACIMPRF.                                               DTSCU351
00269      EJECT                                                        DTSCU351
00270  01  MTAD-REC.                                                    DTSCU351
00271      COPY MACIMTAD.                                               DTSCU351
00272      EJECT                                                        DTSCU351
00273  01  MFAS-REC.                                                    DTSCU351
00274      COPY MACIMFAS.                                               DTSCU351
00275      EJECT                                                        DTSCU351
00276  01  MOPO-REC.                                                    DTSCU351
00277      COPY MACIMOPO.                                               DTSCU351
00278      EJECT                                                        DTSCU351
00279  LINKAGE SECTION.                                                 DTSCU351
00280                                                                   DTSCU351
00281  01  DFHCOMMAREA.                                                 DTSCU351
00282      COPY  MACIL351.                                              DTSCU351
00283                                                                   DTSCU351
00284 /*****************************************************************DTSCU351
00285 *                                                                 DTSCU351
00286 ******************************************************************DTSCU351
00287  PROCEDURE DIVISION.                                              DTSCU351
00288 *-----------------------------------------------------------------DTSCU351
00289 * CLEAN UP AND INITIALIZE TS QUEUE AREA.                          DTSCU351
00290 *-----------------------------------------------------------------DTSCU351
00291      MOVE 0                           TO L829-ITEM-NO.            DTSCU351
00292                                                                   DTSCU351
00293      MOVE XPTS-LENGTH                 TO L829-REC-LENGTH.         DTSCU351
00294                                                                   DTSCU351
00295      SET L829-DEFAULT-STORAGE-88      TO TRUE.                    DTSCU351
00296                                                                   DTSCU351
00297      MOVE L351-TS-NAME-PREFIX         TO L829-QUEUE-NAME-PREFIX.  DTSCU351
00298                                                                   DTSCU351
00299      MOVE 'P'                         TO L829-QUEUE-NAME-SUFFIX.  DTSCU351
00300                                                                   DTSCU351
00301      COMPUTE L829-COMM-AREA-LENGTH                                DTSCU351
00302        = L829-CONTROL-BLOCK-LENGTH + L829-REC-LENGTH.             DTSCU351
00303                                                                   DTSCU351
00304      PERFORM S829-DELETE-QUEUE        THRU S829-EXIT.             DTSCU351
00305                                                                   DTSCU351
00306      MOVE L351-PRINTER-ID      TO L357-PRINTER-ID.                DTSCU351
00307                                                                   DTSCU351
00308      MOVE L829-QUEUE-NAME      TO L357-QUEUE-NAME                 DTSCU351
00309                                                                   DTSCU351
00310                                                                   DTSCU351
00311 *-----------------------------------------------------------------DTSCU351
00312 * SET RESULT TO OK AND AND START PROCESS                          DTSCU351
00313 *-----------------------------------------------------------------DTSCU351
00314      SET L351-PRINT-OK TO TRUE.                                   DTSCU351
00315                                                                   DTSCU351
00316      IF L351-COPY-CNT = 0                                         DTSCU351
00317         SET L351-PRINT-FAILED TO TRUE                             DTSCU351
00318      ELSE                                                         DTSCU351
00319         PERFORM P1000-PROCESS     THRU P1000-EXIT                 DTSCU351
00320         IF L351-PRINT-FAILED                                      DTSCU351
00321             PERFORM S829-DELETE-QUEUE THRU S829-EXIT              DTSCU351
00322         ELSE                                                      DTSCU351
00323             PERFORM S357-LINK-PRINT   THRU S357-EXIT              DTSCU351
00324             IF L357-FAILED-88                                     DTSCU351
00325                 SET L351-PRINT-FAILED TO TRUE                     DTSCU351
00326      END-IF.                                                      DTSCU351
00327                                                                   DTSCU351
00328      EXEC CICS                                                    DTSCU351
00329          RETURN                                                   DTSCU351
00330      END-EXEC.                                                    DTSCU351
00331                                                                   DTSCU351
00332      GOBACK.                                                      DTSCU351
00333 /*****************************************************************DTSCU351
00334 *                                                                 DTSCU351
00335 ******************************************************************DTSCU351
00336  P1000-PROCESS.                                                   DTSCU351
00337      PERFORM P1010-READ-PRF     THRU P1010-EXIT                   DTSCU351
00338      IF L351-PRINT-FAILED                                         DTSCU351
00339         GO TO P1000-EXIT                                          DTSCU351
00340      END-IF.                                                      DTSCU351
00341                                                                   DTSCU351
00342      PERFORM P1020-READ-FAS     THRU P1020-EXIT.                  DTSCU351
00343      IF L351-PRINT-FAILED                                         DTSCU351
00344         GO TO P1000-EXIT                                          DTSCU351
00345      END-IF.                                                      DTSCU351
00346                                                                   DTSCU351
00347      PERFORM P1100-HEADING      THRU P1100-EXIT.                  DTSCU351
00348                                                                   DTSCU351
00349      PERFORM P1200-FAS-AREA     THRU P1200-EXIT.                  DTSCU351
00350                                                                   DTSCU351
00351      PERFORM P1300-ADDRESSES    THRU P1300-EXIT.                  DTSCU351
00352                                                                   DTSCU351
00353      PERFORM P1400-CLAIMANT     THRU P1400-EXIT.                  DTSCU351
00354                                                                   DTSCU351
00355      PERFORM P1500-REL-EMP      THRU P1500-EXIT.                  DTSCU351
00356                                                                   DTSCU351
00357      ADD +1                     TO TS-LINE-CNT                    DTSCU351
00358      MOVE ' '                   TO TS-CC(TS-LINE-CNT)             DTSCU351
00359      MOVE SPACES                TO TS-TEXT(TS-LINE-CNT).          DTSCU351
00360      ADD +1                     TO LINE-CNT.                      DTSCU351
00361                                                                   DTSCU351
00362      IF MFAS-TEXT-CNT NOT EQUAL 0                                 DTSCU351
00363         PERFORM P1600-FAS-TEXT THRU P1600-EXIT                    DTSCU351
00364            VARYING MFAS-TEXT-IDX                                  DTSCU351
00365               FROM 1 BY 1                                         DTSCU351
00366              UNTIL MFAS-TEXT-IDX > MFAS-TEXT-CNT.                 DTSCU351
00367                                                                   DTSCU351
00368      PERFORM P7000-COPY-LINE THRU P7000-EXIT.                     DTSCU351
00369                                                                   DTSCU351
00370      MOVE '(FIELD REP COPY)'  TO WRK-COPY-LIT.                    DTSCU351
00371      PERFORM P8000-TS-WRITE  THRU P8000-EXIT.                     DTSCU351
00372                                                                   DTSCU351
00373      IF L351-PRINT-FAILED                                         DTSCU351
00374         GO TO P1000-EXIT                                          DTSCU351
00375      END-IF.                                                      DTSCU351
00376                                                                   DTSCU351
00377      MOVE +0                   TO WRK-COPY-CNT.                   DTSCU351
00378      PERFORM P2000-COPY-IND  THRU P2000-EXIT.                     DTSCU351
00379                                                                   DTSCU351
00380      IF L351-COPY-CNT > 1                                         DTSCU351
00381         MOVE '(EMPLOYER FILE COPY)'  TO WRK-COPY-LIT              DTSCU351
00382         PERFORM P8000-TS-WRITE  THRU P8000-EXIT                   DTSCU351
00383         PERFORM P2000-COPY-IND  THRU P2000-EXIT                   DTSCU351
00384      END-IF.                                                      DTSCU351
00385                                                                   DTSCU351
00386      IF L351-PRINT-FAILED                                         DTSCU351
00387         GO TO P1000-EXIT                                          DTSCU351
00388      END-IF.                                                      DTSCU351
00389                                                                   DTSCU351
00390      IF L351-COPY-CNT > 2                                         DTSCU351
00391         MOVE SPACES  TO WRK-COPY-LIT                              DTSCU351
00392         PERFORM P8000-TS-WRITE  THRU P8000-EXIT                   DTSCU351
00393         PERFORM P2000-COPY-IND  THRU P2000-EXIT                   DTSCU351
00394      END-IF.                                                      DTSCU351
00395                                                                   DTSCU351
00396      IF L351-PRINT-FAILED                                         DTSCU351
00397         GO TO P1000-EXIT                                          DTSCU351
00398      END-IF.                                                      DTSCU351
00399                                                                   DTSCU351
00400      IF L351-COPY-CNT > 3                                         DTSCU351
00401         IF MFAS-RELATED-EMP-NO NOT = 0                            DTSCU351
00402             MOVE SPACES TO WRK-COPY-LIT                           DTSCU351
00403         ELSE                                                      DTSCU351
00404             MOVE SPACES TO WRK-COPY-LIT                           DTSCU351
00405         END-IF                                                    DTSCU351
00406         PERFORM P8000-TS-WRITE THRU P8000-EXIT                    DTSCU351
00407         PERFORM P2000-COPY-IND THRU P2000-EXIT                    DTSCU351
00408      END-IF                                                       DTSCU351
00409                                                                   DTSCU351
00410      IF L351-PRINT-FAILED                                         DTSCU351
00411         GO TO P1000-EXIT.                                         DTSCU351
00412                                                                   DTSCU351
00413      PERFORM P1001-ADDL-COPIES THRU P1001-EXIT                    DTSCU351
00414          UNTIL (WRK-COPY-CNT NOT < L351-COPY-CNT)                 DTSCU351
00415                      OR                                           DTSCU351
00416                (L351-PRINT-FAILED).                               DTSCU351
00417                                                                   DTSCU351
00418  P1000-EXIT.                                                      DTSCU351
00419      EXIT.                                                        DTSCU351
00420                                                                   DTSCU351
00421  P1001-ADDL-COPIES.                                               DTSCU351
00422      MOVE SPACES TO WRK-COPY-LIT.                                 DTSCU351
00423      PERFORM P8000-TS-WRITE THRU P8000-EXIT.                      DTSCU351
00424      PERFORM P2000-COPY-IND THRU P2000-EXIT.                      DTSCU351
00425  P1001-EXIT.                                                      DTSCU351
00426      EXIT.                                                        DTSCU351
00427 /*****************************************************************DTSCU351
00428 * READ EMPLOYER PROFILE                                           DTSCU351
00429 ******************************************************************DTSCU351
00430  P1010-READ-PRF.                                                  DTSCU351
00431      MOVE LOW-VALUES         TO MPRF-KEY-AREA.                    DTSCU351
00432      MOVE L351-EMP-NO        TO MPRF-EMP-NO.                      DTSCU351
00433      SET MPRF-PRF-88         TO TRUE.                             DTSCU351
00434      MOVE MPRF-KEY-AREA      TO MSKL-KEY-AREA.                    DTSCU351
00435      PERFORM S810-READ       THRU S810-EXIT.                      DTSCU351
00436      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00437         SET L351-PRINT-FAILED TO TRUE                             DTSCU351
00438      ELSE                                                         DTSCU351
00439         MOVE MSKL-REC         TO MPRF-REC                         DTSCU351
00440      END-IF.                                                      DTSCU351
00441  P1010-EXIT.                                                      DTSCU351
00442      EXIT.                                                        DTSCU351
00443                                                                   DTSCU351
00444 /*****************************************************************DTSCU351
00445 * READ FIELD ASSIGNMENT                                           DTSCU351
00446 ******************************************************************DTSCU351
00447  P1020-READ-FAS.                                                  DTSCU351
00448      MOVE LOW-VALUES        TO MFAS-KEY-AREA.                     DTSCU351
00449      MOVE L351-EMP-NO       TO MFAS-EMP-NO.                       DTSCU351
00450      MOVE L351-ASSIGN-NO    TO MFAS-ASSIGN-NO.                    DTSCU351
00451      SET MFAS-FAS-88        TO TRUE.                              DTSCU351
00452      MOVE MFAS-KEY-AREA     TO MSKL-KEY-AREA.                     DTSCU351
00453      PERFORM S810-READ  THRU S810-EXIT.                           DTSCU351
00454      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00455         SET L351-PRINT-FAILED TO TRUE                             DTSCU351
00456      ELSE                                                         DTSCU351
00457         MOVE MSKL-REC         TO MFAS-REC                         DTSCU351
00458      END-IF.                                                      DTSCU351
00459  P1020-EXIT.                                                      DTSCU351
00460      EXIT.                                                        DTSCU351
00461                                                                   DTSCU351
00462 /*****************************************************************DTSCU351
00463 * BUILD FIELD ASSIGNMENT MEMO HEADING (FIRST 3 LINES)             DTSCU351
00464 ******************************************************************DTSCU351
00465  P1100-HEADING.                                                   DTSCU351
00466      MOVE L351-TASK-START-DISP-DATE TO WRK-SYS-DATE.              DTSCU351
00467      MOVE L351-TASK-START-DISP-TIME TO WRK-SYS-TIME.              DTSCU351
00468                                                                   DTSCU351
00469      PERFORM S119-AGENCY-FACTS  THRU S119-EXIT.                   DTSCU351
00470                                                                   DTSCU351
00471      MOVE L119-AGY-NAMEA        TO WRK-AGY-NAMEA-CNTR.            DTSCU351
00472      SET TS-CC-NEW-PAGE(1)      TO TRUE.                          DTSCU351
00473      MOVE WRK-HEADING-1         TO TS-TEXT(1).                    DTSCU351
00474      SET TS-CC-NONE(2)          TO TRUE.                          DTSCU351
00475      MOVE WRK-HEADING-2         TO TS-TEXT(2).                    DTSCU351
00476      MOVE +02                   TO TS-LINE-CNT.                   DTSCU351
00477      MOVE +02                   TO LINE-CNT.                      DTSCU351
00478  P1100-EXIT. EXIT.                                                DTSCU351
00479                                                                   DTSCU351
00480 /*****************************************************************DTSCU351
00481 * BUILD FIELD ASSIGNMENT SPECIFIC INFORMATION                     DTSCU351
00482 ******************************************************************DTSCU351
00483  P1200-FAS-AREA.                                                  DTSCU351
00484      SET TS-CC-SKIP-LINE(3)     TO TRUE.                          DTSCU351
00485      MOVE MFAS-FLD-REP-ID       TO L062-FLD-REP-ID.               DTSCU351
00486      PERFORM S062-AUDIT-EDIT    THRU S062-EXIT.                   DTSCU351
00487      MOVE L062-NAME             TO WRK-FIELD-REP-NAME.            DTSCU351
00488      MOVE MFAS-ASSIGN-NO        TO WRK-ASSIGN-NO.                 DTSCU351
00489      MOVE WRK-LINE-TO           TO TS-TEXT(3).                    DTSCU351
00490                                                                   DTSCU351
00491      SET TS-CC-SKIP-LINE(4)     TO TRUE.                          DTSCU351
00492      MOVE MFAS-SOURCE-OP-ID      TO L082-OP-ID.                   DTSCU351
00493      PERFORM S082-OP-ID         THRU S082-EXIT.                   DTSCU351
00494      MOVE L082-NAME             TO WRK-ORIGINATOR.                DTSCU351
00495      MOVE MFAS-DUE-DATE         TO L001-FED-8-DATE-9.             DTSCU351
00496      PERFORM S001-FROM-FED-8    THRU S001-EXIT.                   DTSCU351
00497      MOVE L001-SLASH-DATE       TO WRK-DUE-DATE.                  DTSCU351
00498      MOVE WRK-LINE-FROM         TO TS-TEXT(4).                    DTSCU351
00499                                                                   DTSCU351
00500      SET TS-CC-SKIP-LINE(5)     TO TRUE.                          DTSCU351
00501      MOVE MFAS-ASSIGN-TYPE      TO L063-TYPE.                     DTSCU351
00502      PERFORM S063-ASSIGN-TYPE   THRU S063-EXIT.                   DTSCU351
00503      MOVE L063-TYPE             TO WRK-ASSIGN-TYPE.               DTSCU351
00504      MOVE MFAS-EMP-NO           TO WRK-EMP-NO.                    DTSCU351
00505      MOVE WRK-LINE-EMP-NO       TO TS-TEXT(5).                    DTSCU351
00506                                                                   DTSCU351
00507      SET TS-CC-NONE(6)          TO TRUE.                          DTSCU351
00508      MOVE L063-DESCRIPTION      TO WRK-ASSIGN-DESC.               DTSCU351
00509      MOVE WRK-ASSIGN-DESC1      TO WRK-ASSIGN-TYPE-DESC1.         DTSCU351
00510      MOVE WRK-LINE-ASSIGN-1     TO TS-TEXT(6).                    DTSCU351
00511                                                                   DTSCU351
00512      SET TS-CC-NONE(7)          TO TRUE.                          DTSCU351
00513      MOVE MFAS-SIC-CD TO WRK-SIC-CD.                              DTSCU351
00514      MOVE MFAS-OWN-CD TO WRK-OWN-CD.                              DTSCU351
00515                                                                   DTSCU351
00516      MOVE WRK-ASSIGN-DESC2      TO WRK-ASSIGN-TYPE-DESC2.         DTSCU351
00517      MOVE WRK-LINE-ASSIGN-2     TO TS-TEXT(7).                    DTSCU351
00518                                                                   DTSCU351
00519      SET TS-CC-NONE(8)          TO TRUE.                          DTSCU351
00520      IF MPRF-FEIN > 0                                             DTSCU351
00521         MOVE MPRF-FEIN          TO WRK-FEIN                       DTSCU351
00522      ELSE                                                         DTSCU351
00523         MOVE SPACES             TO WRK-FEIN-X                     DTSCU351
00524      END-IF.                                                      DTSCU351
00525                                                                   DTSCU351
00526      MOVE MFAS-AUDIT-START-YRQ  TO L004-QTR-5-9.                  DTSCU351
00527      PERFORM S004-FROM-5        THRU S004-EXIT.                   DTSCU351
00528      MOVE L004-SLASH-QTR        TO WRK-AUDIT-YRQ-START.           DTSCU351
00529      MOVE MFAS-AUDIT-END-YRQ    TO L004-QTR-5-9.                  DTSCU351
00530      PERFORM S004-FROM-5        THRU S004-EXIT.                   DTSCU351
00531      MOVE L004-SLASH-QTR        TO WRK-AUDIT-YRQ-END.             DTSCU351
00532      MOVE WRK-LINE-FEIN         TO TS-TEXT(8).                    DTSCU351
00533                                                                   DTSCU351
00534      SET TS-CC-NONE(9)          TO TRUE.                          DTSCU351
00535      IF MFAS-AUDIT-88                                             DTSCU351
00536         IF MFAS-EMP-LARGE-88                                      DTSCU351
00537            MOVE 'LARGE' TO WRK-EMP-SIZE                           DTSCU351
00538         ELSE                                                      DTSCU351
00539            MOVE 'SMALL' TO WRK-EMP-SIZE                           DTSCU351
00540         END-IF                                                    DTSCU351
00541      ELSE                                                         DTSCU351
00542         MOVE SPACES TO WRK-EMP-SIZE                               DTSCU351
00543      END-IF.                                                      DTSCU351
00544      MOVE WRK-EMP-SIZE-LINE     TO TS-TEXT(9).                    DTSCU351
00545                                                                   DTSCU351
00546      MOVE +09                   TO TS-LINE-CNT.                   DTSCU351
00547      MOVE +12                   TO LINE-CNT.                      DTSCU351
00548  P1200-EXIT.                                                      DTSCU351
00549      EXIT.                                                        DTSCU351
00550 /*****************************************************************DTSCU351
00551 * OBTAIN ADDRESS INFORMATION FROM FILE AND STORE IN TABLE         DTSCU351
00552 ******************************************************************DTSCU351
00553  P1300-ADDRESSES.                                                 DTSCU351
00554      MOVE SPACES TO WRK-ADDRESSES.                                DTSCU351
00555                                                                   DTSCU351
00556      PERFORM P1310-FORMAT-TAX-ADDR THRU P1310-EXIT.               DTSCU351
00557                                                                   DTSCU351
00558      PERFORM P1320-FORMAT-OPO-ADDR THRU P1320-EXIT.               DTSCU351
00559                                                                   DTSCU351
00560      MOVE SPACE TO WRK-TAD-ADDRESS.                               DTSCU351
00561                                                                   DTSCU351
00562      MOVE SPACE TO WRK-OPO-ADDRESS.                               DTSCU351
00563                                                                   DTSCU351
00564      PERFORM VARYING WRK-OCC FROM 1 BY 1                          DTSCU351
00565         UNTIL WRK-OCC > 3                                         DTSCU351
00566                                                                   DTSCU351
00567         SET WRK-CC-SKIP-LINE TO TRUE                              DTSCU351
00568                                                                   DTSCU351
00569         ADD 3 TO WRK-OCC GIVING WRK-OCC2                          DTSCU351
00570         PERFORM VARYING WRK-OCC1 FROM 1 BY 1                      DTSCU351
00571            UNTIL WRK-OCC1 > 6                                     DTSCU351
00572            IF WRK-MAILING-LINE (WRK-OCC, WRK-OCC1) = SPACES       DTSCU351
00573            AND WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1) = SPACES     DTSCU351
00574               CONTINUE                                            DTSCU351
00575            ELSE                                                   DTSCU351
00576               MOVE WRK-MAILING-LINE (WRK-OCC, WRK-OCC1)           DTSCU351
00577                 TO WRK-TAD-ADDRESS                                DTSCU351
00578               MOVE WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1)          DTSCU351
00579                 TO WRK-OPO-ADDRESS                                DTSCU351
00580               ADD 1 TO TS-LINE-CNT                                DTSCU351
00581               MOVE WRK-CC TO TS-CC (TS-LINE-CNT)                  DTSCU351
00582               SET WRK-CC-NONE TO TRUE                             DTSCU351
00583               MOVE WRK-LINE-ADDRESS TO TS-TEXT (TS-LINE-CNT)      DTSCU351
00584               PERFORM P1301-LINE-CNT THRU P1301-EXIT              DTSCU351
00585            END-IF                                                 DTSCU351
00586         END-PERFORM                                               DTSCU351
00587      END-PERFORM.                                                 DTSCU351
00588  P1300-EXIT. EXIT.                                                DTSCU351
00589                                                                   DTSCU351
00590  P1301-LINE-CNT.                                                  DTSCU351
00591      IF TS-CC-SKIP-LINE (TS-LINE-CNT)                             DTSCU351
00592          ADD +2 TO LINE-CNT                                       DTSCU351
00593      ELSE                                                         DTSCU351
00594          ADD +1 TO LINE-CNT.                                      DTSCU351
00595  P1301-EXIT.                                                      DTSCU351
00596      EXIT.                                                        DTSCU351
00597 /*****************************************************************DTSCU351
00598 * READ AND FORMAT FROM TAD (REPETITIVE CODE USED FOR READABLILITY)DTSCU351
00599 ******************************************************************DTSCU351
00600  P1310-FORMAT-TAX-ADDR.                                           DTSCU351
00601      MOVE LOW-VALUES              TO MTAD-KEY-AREA.               DTSCU351
00602      MOVE MPRF-EMP-NO             TO MTAD-EMP-NO.                 DTSCU351
00603      SET MTAD-TAD-88              TO TRUE.                        DTSCU351
00604      MOVE MTAD-KEY-AREA           TO MSKL-KEY-AREA.               DTSCU351
00605      PERFORM S810-START-BROWSE    THRU S810-EXIT.                 DTSCU351
00606      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00607         GO TO P1310-EXIT                                          DTSCU351
00608      END-IF.                                                      DTSCU351
00609      MOVE +0                      TO WRK-OCC.                     DTSCU351
00610      PERFORM P1315-FORMAT         THRU P1315-EXIT.                DTSCU351
00611                                                                   DTSCU351
00612      PERFORM S810-READ-NEXT       THRU S810-EXIT.                 DTSCU351
00613      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00614         GO TO P1310-EXIT                                          DTSCU351
00615      END-IF.                                                      DTSCU351
00616      PERFORM P1315-FORMAT         THRU P1315-EXIT.                DTSCU351
00617                                                                   DTSCU351
00618      PERFORM S810-READ-NEXT       THRU S810-EXIT.                 DTSCU351
00619      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00620         GO TO P1310-EXIT                                          DTSCU351
00621      END-IF.                                                      DTSCU351
00622      PERFORM P1315-FORMAT         THRU P1315-EXIT.                DTSCU351
00623                                                                   DTSCU351
00624      PERFORM S810-END-BROWSE      THRU S810-EXIT.                 DTSCU351
00625                                                                   DTSCU351
00626  P1310-EXIT.                                                      DTSCU351
00627      EXIT.                                                        DTSCU351
00628      EJECT                                                        DTSCU351
00629                                                                   DTSCU351
00630 /*****************************************************************DTSCU351
00631 *                                                                 DTSCU351
00632 ******************************************************************DTSCU351
00633  P1315-FORMAT.                                                    DTSCU351
00634      ADD +1                       TO WRK-OCC.                     DTSCU351
00635      MOVE MSKL-REC                TO MTAD-REC.                    DTSCU351
00636      PERFORM S112-FORMAT-TAD      THRU S112-EXIT.                 DTSCU351
00637                                                                   DTSCU351
00638      IF MTAD-VOICE = SPACES                                       DTSCU351
00639         MOVE SPACES TO WRK-TELEPHONE                              DTSCU351
00640      ELSE                                                         DTSCU351
00641         MOVE '('                  TO WRK-TELEPHONE-LEFT           DTSCU351
00642         MOVE MTAD-VOICE-AREA-CD   TO WRK-TELEPHONE-AREA-CD        DTSCU351
00643         MOVE ') '                 TO WRK-TELEPHONE-RIGHT          DTSCU351
00644         MOVE MTAD-VOICE-PREFIX    TO WRK-TELEPHONE-PREFIX         DTSCU351
00645         MOVE '-'                  TO WRK-TELPHONE-DASH            DTSCU351
00646         MOVE MTAD-VOICE-SUFFIX    TO WRK-TELEPHONE-SUFFIX         DTSCU351
00647         IF MTAD-VOICE-EXT NOT = SPACES                            DTSCU351
00648            MOVE ' EXT. '         TO WRK-TELEPHONE-EXT-LBL         DTSCU351
00649            MOVE MTAD-VOICE-EXT   TO WRK-TELEPHONE-EXT             DTSCU351
00650         ELSE                                                      DTSCU351
00651            MOVE SPACES       TO WRK-TELEPHONE-EXT-LBL             DTSCU351
00652            MOVE SPACES       TO WRK-TELEPHONE-EXT                 DTSCU351
00653         END-IF.                                                   DTSCU351
00654      MOVE L112-MAILING-ADDRESS    TO WRK-ADDRESS(WRK-OCC).        DTSCU351
00655      MOVE WRK-TELEPHONE           TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351
00656      PERFORM P1330-SCRUNCH        THRU P1330-EXIT.                DTSCU351
00657  P1315-EXIT.                                                      DTSCU351
00658      EXIT.                                                        DTSCU351
00659                                                                   DTSCU351
00660 /*****************************************************************DTSCU351
00661 * READ AND FORMAT FROM OPO (REPETITIVE CODE USED FOR READABLILITY)DTSCU351
00662 ******************************************************************DTSCU351
00663  P1320-FORMAT-OPO-ADDR.                                           DTSCU351
00664      MOVE LOW-VALUES              TO MOPO-KEY-AREA.               DTSCU351
00665      MOVE MPRF-EMP-NO             TO MOPO-EMP-NO.                 DTSCU351
00666      SET MOPO-OPO-88              TO TRUE.                        DTSCU351
00667      MOVE MOPO-KEY-AREA           TO MSKL-KEY-AREA.               DTSCU351
00668      PERFORM S810-START-BROWSE    THRU S810-EXIT.                 DTSCU351
00669      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00670         GO TO P1320-EXIT                                          DTSCU351
00671      END-IF.                                                      DTSCU351
00672                                                                   DTSCU351
00673      MOVE +3                      TO WRK-OCC.                     DTSCU351
00674      PERFORM P1325-FORMAT         THRU P1325-EXIT.                DTSCU351
00675                                                                   DTSCU351
00676      PERFORM S810-READ-NEXT       THRU S810-EXIT.                 DTSCU351
00677      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00678         GO TO P1320-EXIT                                          DTSCU351
00679      END-IF.                                                      DTSCU351
00680      PERFORM P1325-FORMAT         THRU P1325-EXIT.                DTSCU351
00681                                                                   DTSCU351
00682      PERFORM S810-READ-NEXT       THRU S810-EXIT.                 DTSCU351
00683      IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                     DTSCU351
00684         GO TO P1320-EXIT                                          DTSCU351
00685      END-IF.                                                      DTSCU351
00686      PERFORM P1325-FORMAT         THRU P1325-EXIT.                DTSCU351
00687                                                                   DTSCU351
00688      PERFORM S810-END-BROWSE      THRU S810-EXIT.                 DTSCU351
00689                                                                   DTSCU351
00690  P1320-EXIT.                                                      DTSCU351
00691      EXIT.                                                        DTSCU351
00692      EJECT                                                        DTSCU351
00693 /*****************************************************************DTSCU351
00694 *                                                                 DTSCU351
00695 ******************************************************************DTSCU351
00696  P1325-FORMAT.                                                    DTSCU351
00697      ADD +1                       TO WRK-OCC.                     DTSCU351
00698      MOVE MSKL-REC                TO MOPO-REC.                    DTSCU351
00699      IF MOPO-VOICE = SPACES                                       DTSCU351
00700         MOVE SPACES TO WRK-TELEPHONE                              DTSCU351
00701      ELSE                                                         DTSCU351
00702         MOVE '('                  TO WRK-TELEPHONE-LEFT           DTSCU351
00703         MOVE MOPO-VOICE-AREA-CD   TO WRK-TELEPHONE-AREA-CD        DTSCU351
00704         MOVE ') '                 TO WRK-TELEPHONE-RIGHT          DTSCU351
00705         MOVE MOPO-VOICE-PREFIX    TO WRK-TELEPHONE-PREFIX         DTSCU351
00706         MOVE '-'                  TO WRK-TELPHONE-DASH            DTSCU351
00707         MOVE MOPO-VOICE-SUFFIX    TO WRK-TELEPHONE-SUFFIX         DTSCU351
00708         IF MOPO-VOICE-EXT NOT = SPACES                            DTSCU351
00709            MOVE ' EXT. '         TO WRK-TELEPHONE-EXT-LBL         DTSCU351
00710            MOVE MOPO-VOICE-EXT   TO WRK-TELEPHONE-EXT             DTSCU351
00711         ELSE                                                      DTSCU351
00712            MOVE SPACES       TO WRK-TELEPHONE-EXT-LBL             DTSCU351
00713            MOVE SPACES       TO WRK-TELEPHONE-EXT                 DTSCU351
00714         END-IF.                                                   DTSCU351
00715                                                                   DTSCU351
00716      IF MOPO-ADDRESS = SPACES                                     DTSCU351
00717          MOVE MOPO-NAME TO L071-NAM                               DTSCU351
00718          PERFORM S071-FROM-LAST-NAME-FIRST THRU S071-EXIT         DTSCU351
00719          MOVE SPACE TO WRK-ADDRESS (WRK-OCC)                      DTSCU351
00720          IF MOPO-TITLE = SPACES                                   DTSCU351
00721              MOVE L071-NAM TO WRK-MAILING-LINE (WRK-OCC 1)        DTSCU351
00722          ELSE                                                     DTSCU351
00723              STRING L071-NAM                DELIMITED BY '  '     DTSCU351
00724                     ', '                    DELIMITED BY SIZE     DTSCU351
00725                     MOPO-TITLE              DELIMITED BY '  '     DTSCU351
00726                  INTO                                             DTSCU351
00727                     WRK-MAILING-LINE (WRK-OCC 1)                  DTSCU351
00728      ELSE                                                         DTSCU351
00729          PERFORM S112-FORMAT-OPO THRU S112-EXIT                   DTSCU351
00730          MOVE L112-MAILING-ADDRESS TO WRK-ADDRESS (WRK-OCC).      DTSCU351
00731                                                                   DTSCU351
00732      MOVE WRK-TELEPHONE           TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351
00733      PERFORM P1330-SCRUNCH        THRU P1330-EXIT.                DTSCU351
00734  P1325-EXIT.                                                      DTSCU351
00735      EXIT.                                                        DTSCU351
00736                                                                   DTSCU351
00737 /*****************************************************************DTSCU351
00738 * BUBBLE SORT THE BLANK LINES TO THE BOTTOM OF EACH GROUP         DTSCU351
00739 ******************************************************************DTSCU351
00740  P1330-SCRUNCH.                                                   DTSCU351
00741      SET WRK-BLANK-LINE-YES-88 TO TRUE.                           DTSCU351
00742                                                                   DTSCU351
00743      PERFORM                                                      DTSCU351
00744        UNTIL WRK-BLANK-LINE-NO-88                                 DTSCU351
00745        SET WRK-BLANK-LINE-NO-88 TO TRUE                           DTSCU351
00746                                                                   DTSCU351
00747        PERFORM VARYING WRK-OCC1 FROM 1 BY 1                       DTSCU351
00748           UNTIL WRK-OCC1 > 5                                      DTSCU351
00749                                                                   DTSCU351
00750           COMPUTE WRK-OCC2 = WRK-OCC1 + 1                         DTSCU351
00751                                                                   DTSCU351
00752           IF WRK-MAILING-LINE(WRK-OCC, WRK-OCC1) = SPACES         DTSCU351
00753           AND WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) NOT = SPACES    DTSCU351
00754              SET WRK-BLANK-LINE-YES-88 TO TRUE                    DTSCU351
00755              MOVE WRK-MAILING-LINE(WRK-OCC, WRK-OCC2)             DTSCU351
00756                TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC1)             DTSCU351
00757              MOVE SPACES TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC2)   DTSCU351
00758           END-IF                                                  DTSCU351
00759                                                                   DTSCU351
00760        END-PERFORM                                                DTSCU351
00761                                                                   DTSCU351
00762      END-PERFORM.                                                 DTSCU351
00763  P1330-EXIT.                                                      DTSCU351
00764      EXIT.                                                        DTSCU351
00765 /*****************************************************************DTSCU351
00766 *                                                                 DTSCU351
00767 ******************************************************************DTSCU351
00768  P1400-CLAIMANT.                                                  DTSCU351
00769      IF MFAS-CLAIMANT-SSN IS NOT EQUAL TO ZERO                    DTSCU351
00770         ADD +1                     TO TS-LINE-CNT                 DTSCU351
00771         SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE                  DTSCU351
00772         MOVE MFAS-CLAIMANT-SSN     TO WRK-CLAIMANT-SSN            DTSCU351
00773         MOVE MFAS-CLAIMANT-NAME    TO WRK-CLAIMANT-NAME           DTSCU351
00774         MOVE WRK-LINE-RE           TO TS-TEXT(TS-LINE-CNT)        DTSCU351
00775         ADD +2 TO LINE-CNT.                                       DTSCU351
00776  P1400-EXIT.                                                      DTSCU351
00777      EXIT.                                                        DTSCU351
00778 /*****************************************************************DTSCU351
00779 *                                                                 DTSCU351
00780 ******************************************************************DTSCU351
00781  P1500-REL-EMP.                                                   DTSCU351
00782      IF MFAS-RELATED-EMP-NO NOT EQUAL TO ZERO                     DTSCU351
00783         MOVE LOW-VALUES            TO MPRF-KEY-AREA               DTSCU351
00784         MOVE MFAS-RELATED-EMP-NO   TO MPRF-EMP-NO                 DTSCU351
00785         SET MPRF-PRF-88            TO TRUE                        DTSCU351
00786         MOVE MPRF-KEY-AREA         TO MSKL-KEY-AREA               DTSCU351
00787         PERFORM S810-READ          THRU S810-EXIT                 DTSCU351
00788         ADD +1                     TO TS-LINE-CNT                 DTSCU351
00789         SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE                  DTSCU351
00790         MOVE MFAS-RELATED-EMP-NO   TO WRK-RELATED-EMP-NO          DTSCU351
00791         IF L810-NO-REC-88 OR L810-FILE-CLOSED-88                  DTSCU351
00792            MOVE '--NAME NO LONGER ON FILE--'                      DTSCU351
00793              TO WRK-RELATED-EMP-NAME                              DTSCU351
00794         ELSE                                                      DTSCU351
00795            MOVE MSKL-REC TO MPRF-REC                              DTSCU351
00796            MOVE MPRF-BUSINESS-NAME TO WRK-RELATED-EMP-NAME        DTSCU351
00797         END-IF                                                    DTSCU351
00798         MOVE WRK-LINE-RELATED-EMP  TO TS-TEXT(TS-LINE-CNT)        DTSCU351
00799         ADD +2 TO LINE-CNT.                                       DTSCU351
00800  P1500-EXIT.                                                      DTSCU351
00801      EXIT.                                                        DTSCU351
00802 /*****************************************************************DTSCU351
00803 *                                                                 DTSCU351
00804 ******************************************************************DTSCU351
00805  P1600-FAS-TEXT.                                                  DTSCU351
00806                                                                   DTSCU351
00807      ADD +1                        TO TS-LINE-CNT.                DTSCU351
00808      MOVE ' '                      TO TS-CC(TS-LINE-CNT).         DTSCU351
00809      MOVE MFAS-TEXT(MFAS-TEXT-IDX) TO WRK-TEXT.                   DTSCU351
00810      MOVE WRK-LINE-TEXT            TO TS-TEXT(TS-LINE-CNT).       DTSCU351
00811      ADD +1                        TO LINE-CNT.                   DTSCU351
00812                                                                   DTSCU351
00813  P1600-EXIT.                                                      DTSCU351
00814      EXIT.                                                        DTSCU351
00815                                                                   DTSCU351
00816 /*****************************************************************DTSCU351
00817 *                                                                 DTSCU351
00818 ******************************************************************DTSCU351
00819  P2000-COPY-IND.                                                  DTSCU351
00820                                                                   DTSCU351
00821      ADD +1         TO WRK-COPY-CNT.                              DTSCU351
00822                                                                   DTSCU351
00823  P2000-EXIT.                                                      DTSCU351
00824      EXIT.                                                        DTSCU351
00825                                                                   DTSCU351
00826 /*****************************************************************DTSCU351
00827 * GETS THE POINTER TO THE END OF THE PAGE                         DTSCU351
00828 ******************************************************************DTSCU351
00829  P7000-COPY-LINE.                                                 DTSCU351
00830      PERFORM P7100-LOOP THRU P7100-EXIT                           DTSCU351
00831          UNTIL LINE-CNT >= 60.                                    DTSCU351
00832  P7000-EXIT.                                                      DTSCU351
00833      EXIT.                                                        DTSCU351
00834                                                                   DTSCU351
00835  P7100-LOOP.                                                      DTSCU351
00836      ADD +1 TO LINE-CNT.                                          DTSCU351
00837      ADD +1 TO TS-LINE-CNT.                                       DTSCU351
00838      MOVE SPACE TO TS-CC(TS-LINE-CNT)                             DTSCU351
00839                    TS-TEXT(TS-LINE-CNT).                          DTSCU351
00840  P7100-EXIT.                                                      DTSCU351
00841      EXIT.                                                        DTSCU351
00842                                                                   DTSCU351
00843  P8000-TS-WRITE.                                                  DTSCU351
00844      MOVE WRK-LINE-COPY TO TS-TEXT(TS-LINE-CNT).                  DTSCU351
00845      PERFORM P8100-TS-LOOP  THRU P8100-EXIT                       DTSCU351
00846           VARYING WRK-OCC FROM 1 BY 1                             DTSCU351
00847             UNTIL WRK-OCC > TS-LINE-CNT                           DTSCU351
00848                OR L351-PRINT-FAILED.                              DTSCU351
00849  P8000-EXIT.                                                      DTSCU351
00850      EXIT.                                                        DTSCU351
00851      EJECT                                                        DTSCU351
00852 /*****************************************************************DTSCU351
00853 *                                                                 DTSCU351
00854 ******************************************************************DTSCU351
00855  P8100-TS-LOOP.                                                   DTSCU351
00856      MOVE TS-CC(WRK-OCC) TO XPTS-CC.                              DTSCU351
00857      MOVE TS-TEXT(WRK-OCC) TO XPTS-DATA.                          DTSCU351
00858      MOVE WRK-OCC TO L829-ITEM-NO.                                DTSCU351
00859      PERFORM S829-WRITE-ITEM THRU S829-EXIT.                      DTSCU351
00860      IF NOT L829-OK-88                                            DTSCU351
00861          SET L351-PRINT-FAILED TO TRUE.                           DTSCU351
00862                                                                   DTSCU351
00863  P8100-EXIT.                                                      DTSCU351
00864      EXIT.                                                        DTSCU351
00865 /*****************************************************************DTSCU351
00866 * SERVICE UTILITIES                                               DTSCU351
00867 ******************************************************************DTSCU351
00868  S001-FROM-FED-8.                                                 DTSCU351
00869      SET L001-FROM-FED-8 TO TRUE.                                 DTSCU351
00870      GO TO S001-DATE-EDIT.                                        DTSCU351
00871                                                                   DTSCU351
00872  S001-DATE-EDIT.                                                  DTSCU351
00873      EXEC CICS                                                    DTSCU351
00874          LINK                                                     DTSCU351
00875              PROGRAM ('MACCU001')                                 DTSCU351
00876              COMMAREA (L001-COMM-AREA)                            DTSCU351
00877              LENGTH (L001-LENGTH)                                 DTSCU351
00878      END-EXEC.                                                    DTSCU351
00879  S001-EXIT.                                                       DTSCU351
00880      EXIT.                                                        DTSCU351
00881                                                                   DTSCU351
00882  S004-FROM-5.                                                     DTSCU351
00883      SET L004-FROM-5 TO TRUE.                                     DTSCU351
00884      GO TO S004-QTR-EDIT.                                         DTSCU351
00885                                                                   DTSCU351
00886  S004-QTR-EDIT.                                                   DTSCU351
00887      EXEC CICS                                                    DTSCU351
00888          LINK                                                     DTSCU351
00889              PROGRAM ('MACCU004')                                 DTSCU351
00890              COMMAREA (L004-COMM-AREA)                            DTSCU351
00891              LENGTH (L004-LENGTH)                                 DTSCU351
00892      END-EXEC.                                                    DTSCU351
00893  S004-EXIT.                                                       DTSCU351
00894      EXIT.                                                        DTSCU351
00895                                                                   DTSCU351
00896  S056-RATE.                                                       DTSCU351
00897      EXEC CICS                                                    DTSCU351
00898          LINK                                                     DTSCU351
00899              PROGRAM ('MACCU056')                                 DTSCU351
00900              COMMAREA (L056-COMM-AREA)                            DTSCU351
00901              LENGTH (L056-LENGTH)                                 DTSCU351
00902      END-EXEC.                                                    DTSCU351
00903  S056-EXIT.                                                       DTSCU351
00904      EXIT.                                                        DTSCU351
00905                                                                   DTSCU351
00906  S062-AUDIT-EDIT.                                                 DTSCU351
00907      EXEC CICS                                                    DTSCU351
00908          LINK                                                     DTSCU351
00909              PROGRAM ('MACCU062')                                 DTSCU351
00910              COMMAREA (L062-COMM-AREA)                            DTSCU351
00911              LENGTH (L062-LENGTH)                                 DTSCU351
00912      END-EXEC.                                                    DTSCU351
00913  S062-EXIT.                                                       DTSCU351
00914      EXIT.                                                        DTSCU351
00915                                                                   DTSCU351
00916  S063-ASSIGN-TYPE.                                                DTSCU351
00917      EXEC CICS                                                    DTSCU351
00918          LINK                                                     DTSCU351
00919              PROGRAM ('MACCU063')                                 DTSCU351
00920              COMMAREA (L063-COMM-AREA)                            DTSCU351
00921              LENGTH (L063-LENGTH)                                 DTSCU351
00922      END-EXEC.                                                    DTSCU351
00923  S063-EXIT.                                                       DTSCU351
00924      EXIT.                                                        DTSCU351
00925                                                                   DTSCU351
00926  S071-FROM-LAST-NAME-FIRST.                                       DTSCU351
00927      SET L071-FROM-LAST-NAME-FIRST TO TRUE.                       DTSCU351
00928      GO TO S071-FORMAT-NAME.                                      DTSCU351
00929                                                                   DTSCU351
00930  S071-FORMAT-NAME.                                                DTSCU351
00931      EXEC CICS                                                    DTSCU351
00932          LINK                                                     DTSCU351
00933              PROGRAM ('MACCU071')                                 DTSCU351
00934              COMMAREA (L071-COMM-AREA)                            DTSCU351
00935              LENGTH (L071-LENGTH)                                 DTSCU351
00936      END-EXEC.                                                    DTSCU351
00937  S071-EXIT.                                                       DTSCU351
00938      EXIT.                                                        DTSCU351
00939                                                                   DTSCU351
00940  S082-OP-ID.                                                      DTSCU351
00941      EXEC CICS                                                    DTSCU351
00942          LINK                                                     DTSCU351
00943              PROGRAM ('MACCU082')                                 DTSCU351
00944              COMMAREA (L082-COMM-AREA)                            DTSCU351
00945              LENGTH (L082-LENGTH)                                 DTSCU351
00946      END-EXEC.                                                    DTSCU351
00947  S082-EXIT.                                                       DTSCU351
00948      EXIT.                                                        DTSCU351
00949                                                                   DTSCU351
00950  S112-FORMAT-TAD.                                                 DTSCU351
00951      SET L112-TAD-ADDR-88 TO TRUE.                                DTSCU351
00952      SET L112-ANCHOR-FIRST-88 TO TRUE.                            DTSCU351
00953      IF MTAD-ID-NO = +1                                           DTSCU351
00954           MOVE MPRF-BUSINESS-NAME TO L112-BUSINESS-NAME           DTSCU351
00955      ELSE                                                         DTSCU351
00956          MOVE SPACES TO L112-BUSINESS-NAME.                       DTSCU351
00957      MOVE MTAD-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND.             DTSCU351
00958      MOVE SPACES TO L112-NAME                                     DTSCU351
00959                     L112-TITLE.                                   DTSCU351
00960      MOVE MTAD-ADDRESS TO L112-ADDRESS.                           DTSCU351
00961      GO TO S112-FORMAT-ADDRESS.                                   DTSCU351
00962                                                                   DTSCU351
00963  S112-FORMAT-OPO.                                                 DTSCU351
00964      SET L112-OPO-ADDR-88 TO TRUE.                                DTSCU351
00965      SET L112-ANCHOR-FIRST-88 TO TRUE.                            DTSCU351
00966      MOVE SPACES TO L112-BUSINESS-NAME.                           DTSCU351
00967      MOVE MOPO-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND.             DTSCU351
00968      MOVE MOPO-NAME TO L112-NAME.                                 DTSCU351
00969      MOVE MOPO-TITLE TO L112-TITLE.                               DTSCU351
00970      MOVE MOPO-ADDRESS TO L112-ADDRESS.                           DTSCU351
00971      GO TO S112-FORMAT-ADDRESS.                                   DTSCU351
00972                                                                   DTSCU351
00973  S112-FORMAT-ADDRESS.                                             DTSCU351
00974      EXEC CICS                                                    DTSCU351
00975          LINK                                                     DTSCU351
00976              PROGRAM ('MACCU112')                                 DTSCU351
00977              COMMAREA (L112-COMM-AREA)                            DTSCU351
00978              LENGTH (L112-LENGTH)                                 DTSCU351
00979      END-EXEC.                                                    DTSCU351
00980  S112-EXIT.                                                       DTSCU351
00981      EXIT.                                                        DTSCU351
00982                                                                   DTSCU351
00983  S119-AGENCY-FACTS.                                               DTSCU351
00984      SET L119-REQ-CAPS-88 TO TRUE.                                DTSCU351
00985      SET L119-REQ-NO-UNIT-88 TO TRUE.                             DTSCU351
00986      EXEC CICS                                                    DTSCU351
00987          LINK                                                     DTSCU351
00988              PROGRAM ('MACCU119')                                 DTSCU351
00989              COMMAREA (L119-COMM-AREA)                            DTSCU351
00990              LENGTH (L119-LENGTH)                                 DTSCU351
00991      END-EXEC.                                                    DTSCU351
00992  S119-EXIT.                                                       DTSCU351
00993      EXIT.                                                        DTSCU351
00994                                                                   DTSCU351
00995  S357-LINK-PRINT.                                                 DTSCU351
00996      SET L357-EJECT-PAGE-88 TO TRUE.                              DTSCU351
00997                                                                   DTSCU351
00998      EXEC CICS                                                    DTSCU351
00999          LINK                                                     DTSCU351
01000              PROGRAM ('MACCU357')                                 DTSCU351
01001              COMMAREA (L357-COMM-AREA)                            DTSCU351
01002              LENGTH (L357-LENGTH)                                 DTSCU351
01003      END-EXEC.                                                    DTSCU351
01004  S357-EXIT.                                                       DTSCU351
01005      EXIT.                                                        DTSCU351
01006                                                                   DTSCU351
01007  S810-START-BROWSE.                                               DTSCU351
01008      SET L810-START-BROWSE-88 TO TRUE                             DTSCU351
01009      GO TO S810-MSTR-IO.                                          DTSCU351
01010                                                                   DTSCU351
01011  S810-END-BROWSE.                                                 DTSCU351
01012      SET L810-END-BROWSE-88 TO TRUE                               DTSCU351
01013      GO TO S810-MSTR-IO.                                          DTSCU351
01014                                                                   DTSCU351
01015  S810-READ-NEXT.                                                  DTSCU351
01016      SET L810-READ-NEXT-88 TO TRUE                                DTSCU351
01017      GO TO S810-MSTR-IO.                                          DTSCU351
01018                                                                   DTSCU351
01019  S810-READ.                                                       DTSCU351
01020      SET L810-READ-88 TO TRUE                                     DTSCU351
01021      GO TO S810-MSTR-IO.                                          DTSCU351
01022                                                                   DTSCU351
01023  S810-MSTR-IO.                                                    DTSCU351
01024      EXEC CICS                                                    DTSCU351
01025          LINK                                                     DTSCU351
01026              PROGRAM ('MACCU810')                                 DTSCU351
01027              COMMAREA (L810-COMM-AREA)                            DTSCU351
01028              LENGTH (L810-LENGTH)                                 DTSCU351
01029      END-EXEC.                                                    DTSCU351
01030  S810-EXIT.                                                       DTSCU351
01031      EXIT.                                                        DTSCU351
01032                                                                   DTSCU351
01033  S829-DELETE-QUEUE.                                               DTSCU351
01034                                                                   DTSCU351
01035      SET L829-DELETE-QUEUE-88 TO TRUE.                            DTSCU351
01036      GO TO S829-TS-IO.                                            DTSCU351
01037                                                                   DTSCU351
01038  S829-WRITE-ITEM.                                                 DTSCU351
01039      SET L829-WRITE-88 TO TRUE.                                   DTSCU351
01040      GO TO S829-TS-IO.                                            DTSCU351
01041                                                                   DTSCU351
01042  S829-TS-IO.                                                      DTSCU351
01043      EXEC CICS                                                    DTSCU351
01044          LINK                                                     DTSCU351
01045              PROGRAM ('MACCU829')                                 DTSCU351
01046              COMMAREA (L829-COMM-AREA)                            DTSCU351
01047              LENGTH (L829-COMM-AREA-LENGTH)                       DTSCU351
01048      END-EXEC.                                                    DTSCU351
01049  S829-EXIT.                                                       DTSCU351
01050      EXIT.                                                        DTSCU351
01051                                                                   DTSCU351
01052  S899-ABEND.                                                      DTSCU351
01053      EXEC CICS                                                    DTSCU351
01054          ABEND                                                    DTSCU351
01055              ABCODE (WRK-ABEND-CODE)                              DTSCU351
01056      END-EXEC.                                                    DTSCU351
01057  S899-EXIT.                                                       DTSCU351
01058      EXIT.                                                        DTSCU351
