00001  IDENTIFICATION DIVISION.                                         06/23/14
00002  PROGRAM-ID.             DTSBZ500.                                DTSBX500
00003  AUTHOR.                 NORTHROP GRUMMAN CORP.                      LV007
00004  DATE-WRITTEN.           AUGUST 2005.                             DTSBX500
00005  DATE-COMPILED.                                                   DTSBX500
00006                                                                   DTSBX500
00007 *****                                                             DTSBX500
00008 *                                                                 DTSBX500
00009 *    FUNCTION:  CREATE A WAGE AND EMPLOYER FILE FOR EACH QUATER   DTSBX500
00010 *               TO BE LOADED INTO THE SDDS SYSTEM. EVERY QUATER   DTSBX500
00011 *               OF WAGE RECORD DATA MUST HAVE A CORRESPONDING     DTSBX500
00012 *               QUATER OF EMPLOYER DATA. THIS SYSTEM REQUIRS A    DTSBX500
00013 *               MINIMUN OF THREE YEARS OF DATA TO BE LOADED INTO  DTSBX500
00014 *               THE SYSTEM.                                       DTSBX500
00015 *****                                                             DTSBX500
00016                                                                   DTSBX500
00017  ENVIRONMENT DIVISION.                                            DTSBX500
00018                                                                   DTSBX500
00019  CONFIGURATION SECTION.                                           DTSBX500
00020                                                                   DTSBX500
00021  INPUT-OUTPUT SECTION.                                            DTSBX500
00022                                                                   DTSBX500
00023  FILE-CONTROL.                                                    DTSBX500
00024      SELECT WAGE-FILE         ASSIGN TO DTSWAGE                   DTSBX500
00025             FILE STATUS IS WAGEFILE-STATUS.                       DTSBX500
00026                                                                   DTSBX500
00027      SELECT EMPL-FILE         ASSIGN TO DTSEMPL                   DTSBX500
00028             FILE STATUS IS EMPFILE-STATUS.                        DTSBX500
00029                                                                   DTSBX500
00030      SELECT TAX-FILE          ASSIGN TO DTSTAX                    DTSBX500
00031             FILE STATUS IS TAXFILE-STATUS.                        DTSBX500
00032                                                                   DTSBX500
00033      SELECT CONTACT-FILE      ASSIGN TO DTSCONT                   DTSBX500
00034             FILE STATUS IS CONTFILE-STATUS.                       DTSBX500
00035                                                                   DTSBX500
00036  DATA DIVISION.                                                   DTSBX500
00037                                                                   DTSBX500
00038  FILE SECTION.                                                    DTSBX500
00039                                                                   DTSBX500
00040  FD  WAGE-FILE                                                    DTSBX500
00041      RECORDING MODE IS F.                                         DTSBX500
00042  01  WAGE-RECORD              PIC X(086).                         DTSBX500
00043                                                                   DTSBX500
00044  FD  EMPL-FILE                                                    DTSBX500
00045      RECORDING MODE IS F.                                         DTSBX500
00046  01  EMPL-RECORD              PIC X(340).                         DTSBX500
00047                                                                   DTSBX500
00048  FD  TAX-FILE                                                     DTSBX500
00049      RECORDING MODE IS F.                                         DTSBX500
00050  01  TAX-RECORD               PIC X(72).                          DTSBX500
00051                                                                   DTSBX500
00052  FD  CONTACT-FILE                                                 DTSBX500
00053      RECORDING MODE IS F.                                         DTSBX500
00054  01  CONTACT-RECORD           PIC X(101).                         DTSBX500
00055      EJECT                                                        DTSBX500
00056                                                                   DTSBX500
00057  WORKING-STORAGE SECTION.                                         DTSBX500
000575 77  PAN-VALET PICTURE X(24) VALUE '007DTSBX500  06/23/14'.       DTSBX500
00058                                                                   DTSBX500
00059  01  WRK-AREA.                                                    DTSBX500
00060      05  WRK-ABEND-CD                PIC S9(04)  COMP  VALUE +500.DTSBX500
00061      05  WRK-ABEND-MSG               PIC  X(60)  VALUE SPACES.    DTSBX500
00062      05  WRK-TRACE-IND               PIC  X(01)  VALUE SPACES.    DTSBX500
00063      05  WRK-MOD-NAME                PIC  X(08)  VALUE 'DTSBZ500'.DTSBX500
00064                                                                   DTSBX500
00065      05  DISP-DATE                   PIC X(10).                   DTSBX500
00066      05  DISP-TIME                   PIC X(08).                   DTSBX500
00067      05  DISP-ABSTIME                PIC X(16).                   DTSBX500
00068                                                                   DTSBX500
00069      05  WRK-MPRF-READ-CNT           PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00070      05  WRK-MPRF-ZERO-FEIN-CNT      PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00071      05  WRK-MPRF-ACT-CNT            PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00072      05  WRK-MPRF-ACT-NO-CNT         PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00073      05  WRK-TAX-ADDR-CNT            PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00074      05  WRK-PHY-ADDR-CNT            PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00075      05  WRK-PHY-TAX-ADDR-SAME-CNT   PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00076      05  WRK-ADDR-SELECT-CNT         PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00077      05  WRK-ADDR-FOUND-NO-CNT       PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00078      05  WRK-WWGH-READ-CNT           PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00079      05  WRK-WWGH-EMP-NO-CNT         PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00080      05  WRK-WWGH-ACCT-INVALID       PIC S9(07)  COMP-3 VALUE 0.  DTSBX500
00081      05  WRK-WAGE-REC-WRITE-CNT      PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00082      05  WRK-EMPL-REC-WRITE-CNT      PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00083      05  WRK-TAX-REC-WRITE-CNT       PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00084      05  WRK-CONTACT-REC-WRITE-CNT   PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00085      05  WRK-MQTR-REC-NOT-FOUND-CNT  PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00086      05  WRK-LIABLE-REC-CNT          PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00087      05  WRK-NOT-LIABLE-REC-CNT      PIC S9(07)  COMP-3 VALUE +0. DTSBX500
00088      05  WRK-DISPLAY-CNT             PIC  9(06)  VALUE 0.         DTSBX500
00089                                                                   DTSBX500
00090      05  WRK-WWGH-EMP-NO             PIC S9(07)  VALUE +0.        DTSBX500
00091      05  WRK-MQTR-EMP-NO             PIC  9(06)  VALUE 0.         DTSBX500
00092      05  WRK-EMP-NO                  PIC  9(06)  VALUE 0.         DTSBX500
00093      05  WRK-YRQ                     PIC S9(05)  COMP-3 VALUE +0. DTSBX500
00094      05  WRK-YEAR-QTR                PIC 9(05).                   DTSBX500
00095      05  FILLER REDEFINES WRK-YEAR-QTR.                           DTSBX500
00096          10  WRK-YRQ-YEAR            PIC 9(4).                    DTSBX500
00097          10  WRK-YRQ-QTR             PIC 9(1).                    DTSBX500
00098      05  WRK-SSN                     PIC  9(09)  VALUE 0.         DTSBX500
00099      05  WRK-MOPO-SSN                PIC  9(09)  VALUE 0.         DTSBX500
00100      05  WRK-FEIN                    PIC  9(09)  VALUE 0.         DTSBX500
00101      05  WRK-EARNINGS                PIC  9(10)  VALUE 0.         DTSBX500
00102                                                                   DTSBX500
00103      05  WRK-QTR-PAID-AMT            PIC  ZZZZZ9.99.              DTSBX500
00104      05  WRK-QTR-TOT-WAGE            PIC  ZZZZZZZ9.99.            DTSBX500
00105      05  WRK-QTR-TAX-WAGE            PIC  ZZZZZZZ9.99.            DTSBX500
00106      05  WRK-QTR-UI-RATE             PIC  9.9999.                 DTSBX500
00107      05  WRK-QTR-MON1-EMP-CNT        PIC  9(06).                  DTSBX500
00108      05  WRK-QTR-MON2-EMP-CNT        PIC  9(06).                  DTSBX500
00109      05  WRK-QTR-MON3-EMP-CNT        PIC  9(06).                  DTSBX500
00110                                                                   DTSBX500
00111      05  WAGEFILE-STATUS             PIC  X(02).                  DTSBX500
00112          88  WAGEFILE-OK-88                    VALUE '00'.        DTSBX500
00113                                                                   DTSBX500
00114      05  EMPFILE-STATUS              PIC  X(02).                  DTSBX500
00115          88  EMPFILE-OK-88                     VALUE '00'.        DTSBX500
00116                                                                   DTSBX500
00117      05  TAXFILE-STATUS              PIC  X(02).                  DTSBX500
00118          88  TAXFILE-OK-88                     VALUE '00'.        DTSBX500
00119                                                                   DTSBX500
00120      05  CONTFILE-STATUS             PIC  X(02).                  DTSBX500
00121          88  CONTFILE-OK-88                    VALUE '00'.        DTSBX500
00122                                                                   DTSBX500
00123      05  WRK-ERROR-IND               PIC  X(01).                  DTSBX500
00124          88 WRK-ERROR-YES-88                VALUE 'Y'.            DTSBX500
00125          88 WRK-ERROR-NO-88                 VALUE 'N'.            DTSBX500
00126                                                                   DTSBX500
00127      05  WRK-SUBJECT-IND             PIC  X(01) VALUE 'N'.        DTSBX500
00128          88 WRK-SUBJECT-YES-88              VALUE 'Y'.            DTSBX500
00129          88 WRK-SUBJECT-NO-88               VALUE 'N'.            DTSBX500
00130                                                                   DTSBX500
00131      05  WRK-LIABLE-IND              PIC  X(01) VALUE 'N'.        DTSBX500
00132          88 WRK-LIABLE-YES-88               VALUE 'Y'.            DTSBX500
00133          88 WRK-LIABLE-NO-88                VALUE 'N'.            DTSBX500
00134                                                                   DTSBX500
00135      05  WRK-EMP-NO-IND              PIC  X(01)  VALUE SPACE.     DTSBX500
00136          88 WRK-EMP-NO-INVALID-88         VALUE 'N'.              DTSBX500
00137          88 WRK-EMP-NO-VALID-88           VALUE 'Y'.              DTSBX500
00138                                                                   DTSBX500
00139      05  WRK-EMP-SELECTED-IND        PIC  X(01).                  DTSBX500
00140          88  WRK-EMP-SELECTED-YES               VALUE 'Y'.        DTSBX500
00141          88  WRK-EMP-SELECTED-NO                VALUE 'N'.        DTSBX500
00142                                                                   DTSBX500
00143      05  WS-MAILING-ADDRESS-1        PIC X(35)  VALUE SPACES.     DTSBX500
00144      05  WS-MAILING-ADDRESS-2        PIC X(35)  VALUE SPACES.     DTSBX500
00145      05  WS-CITY-1                   PIC X(30)  VALUE SPACES.     DTSBX500
00146      05  WS-STATE-1                  PIC X(02)  VALUE SPACES.     DTSBX500
00147                                                                   DTSBX500
00148      05  WS-ZIP-1.                                                DTSBX500
00149          10  WS-ZIP-1-5              PIC X(05).                   DTSBX500
00150          10  FILLER                  PIC X(01) VALUE SPACE.       DTSBX500
00151          10  WS-ZIP-1-4              PIC X(04).                   DTSBX500
00152                                                                   DTSBX500
00153      05  WS-ZIP-2.                                                DTSBX500
00154          10  WS-ZIP-2-5              PIC X(05).                   DTSBX500
00155          10  FILLER                  PIC X(01) VALUE SPACE.       DTSBX500
00156          10  WS-ZIP-2-4              PIC X(04).                   DTSBX500
00157                                                                   DTSBX500
00158      05  WS-VOICE-1.                                              DTSBX500
00159          10  WS-VOICE-1-AREA-CD      PIC X(03).                   DTSBX500
00160          10  WS-VOICE-1-PREFIX       PIC X(03).                   DTSBX500
00161          10  WS-VOICE-1-SUFFIX       PIC X(04).                   DTSBX500
00162                                                                   DTSBX500
00163      05  WRK-VOICE-1.                                             DTSBX500
00164          10  WRK-VOICE-1-AREA-CD     PIC X(03).                   DTSBX500
00165          10  WRK-VOICE-1-PREFIX      PIC X(03).                   DTSBX500
00166          10  WRK-VOICE-1-SUFFIX      PIC X(04).                   DTSBX500
00167                                                                   DTSBX500
00168  01  WR-WAGE-RECORD.                                              DTSBX500
00169      05  WR-SSN                      PIC  X(09) VALUE SPACES.     DTSBX500
00170      05  WR-FIRST-NAME               PIC  X(15) VALUE SPACES.     DTSBX500
00171      05  WR-M-I                      PIC  X(01) VALUE SPACE.      DTSBX500
00172      05  WR-LAST-NAME                PIC  X(20) VALUE SPACES.     DTSBX500
00173      05  WR-STATE-CODE               PIC  X(02) VALUE '11'.       DTSBX500
00174      05  WR-UI-ACCT-NO.                                           DTSBX500
00175          10  WR-ACCT-NO-FIRST-4      PIC  X(04) VALUE '0000'.     DTSBX500
00176          10  WR-ACCT-NO-LAST-6       PIC  X(06) VALUE SPACES.     DTSBX500
00177      05  WR-RPT-UNIT-NO              PIC  X(05) VALUE '00000'.    DTSBX500
00178      05  WR-EIN                      PIC  X(09) VALUE SPACES.     DTSBX500
00179      05  WR-YEAR                     PIC  X(04) VALUE SPACES.     DTSBX500
00180      05  WR-QUARTER                  PIC  X(01) VALUE SPACE.      DTSBX500
00181      05  WR-WAGE                     PIC  X(10) VALUE SPACES.     DTSBX500
00182                                                                   DTSBX500
00183  01  ER-EMPL-RECORD.                                              DTSBX500
00184      05  ER-STATE-CODE               PIC  X(02) VALUE '11'.       DTSBX500
00185      05  ER-UI-ACCT-NO.                                           DTSBX500
00186          10  ER-ACCT-NO-FIRST-4      PIC  X(04) VALUE '0000'.     DTSBX500
00187          10  ER-ACCT-NO-LAST-6       PIC  X(06) VALUE SPACES.     DTSBX500
00188      05  ER-EIN                      PIC  X(09) VALUE SPACES.     DTSBX500
00189      05  ER-YEAR                     PIC  X(04) VALUE SPACES.     DTSBX500
00190      05  ER-QUARTER                  PIC  X(01) VALUE SPACE.      DTSBX500
00191      05  ER-EMP-PRIMARY-NAME         PIC  X(35) VALUE SPACES.     DTSBX500
00192      05  ER-EMP-ENTITY-NAME          PIC  X(35) VALUE SPACES.     DTSBX500
00193      05  ER-MAILING-ADDRESS-1        PIC  X(35) VALUE SPACES.     DTSBX500
00194      05  ER-MAILING-ADDRESS-2        PIC  X(35) VALUE SPACES.     DTSBX500
00195      05  ER-CITY-1                   PIC  X(30) VALUE SPACES.     DTSBX500
00196      05  ER-STATE-1                  PIC  X(02) VALUE SPACES.     DTSBX500
00197      05  ER-ZIP-1-5                  PIC  X(05) VALUE SPACES.     DTSBX500
00198      05  ER-ZIP-1-4                  PIC  X(04) VALUE SPACES.     DTSBX500
00199      05  ER-PHYSICAL-ADDRESS-1       PIC  X(35) VALUE SPACES.     DTSBX500
00200      05  ER-PHYSICAL-ADDRESS-2       PIC  X(35) VALUE SPACES.     DTSBX500
00201      05  ER-CITY-2                   PIC  X(30) VALUE SPACES.     DTSBX500
00202      05  ER-STATE-2                  PIC  X(02) VALUE SPACES.     DTSBX500
00203      05  ER-ZIP-2-5                  PIC  X(05) VALUE SPACES.     DTSBX500
00204      05  ER-ZIP-2-4                  PIC  X(04) VALUE SPACES.     DTSBX500
00205      05  ER-PHONE                    PIC  X(10) VALUE SPACES.     DTSBX500
00206      05  ER-OWNERSHIP-CODE           PIC  X(02) VALUE SPACES.     DTSBX500
00207      05  ER-SIC-CODE                 PIC  X(04) VALUE SPACES.     DTSBX500
00208      05  ER-NAICS-CODE               PIC  X(06) VALUE SPACES.     DTSBX500
00209                                                                   DTSBX500
00210  01  TX-TAX-RECORD.                                               DTSBX500
00211      05  TX-STATE-CODE               PIC  X(02) VALUE '11'.       DTSBX500
00212      05  TX-UI-ACCT-NO.                                           DTSBX500
00213          10  TX-ACCT-NO-FIRST-4      PIC  X(04) VALUE '0000'.     DTSBX500
00214          10  TX-ACCT-NO-LAST-6       PIC  X(06) VALUE SPACES.     DTSBX500
00215      05  TX-YEAR                     PIC  X(04) VALUE SPACES.     DTSBX500
00216      05  TX-QUARTER                  PIC  X(01) VALUE SPACE.      DTSBX500
00217      05  TX-TAX-PAID                 PIC  X(09) VALUE SPACES.     DTSBX500
00218      05  TX-TOT-WAGE                 PIC  X(11) VALUE SPACES.     DTSBX500
00219      05  TX-TAX-WAGE                 PIC  X(11) VALUE SPACES.     DTSBX500
00220      05  TX-UI-RATE                  PIC  X(06) VALUE SPACES.     DTSBX500
00221      05  TX-MON1-EMP-CNT             PIC  X(06) VALUE SPACES.     DTSBX500
00222      05  TX-MON2-EMP-CNT             PIC  X(06) VALUE SPACES.     DTSBX500
00223      05  TX-MON3-EMP-CNT             PIC  X(06) VALUE SPACES.     DTSBX500
00224                                                                   DTSBX500
00225  01  CT-CONTACT-RECORD.                                           DTSBX500
00226      05  CT-STATE-CODE               PIC  X(02) VALUE '11'.       DTSBX500
00227      05  CT-UI-ACCT-NO.                                           DTSBX500
00228          10  CT-ACCT-NO-FIRST-4      PIC  X(04) VALUE '0000'.     DTSBX500
00229          10  CT-ACCT-NO-LAST-6       PIC  X(06) VALUE SPACES.     DTSBX500
00230      05  CT-YEAR                     PIC  X(04) VALUE SPACES.     DTSBX500
00231      05  CT-QUARTER                  PIC  X(01) VALUE SPACE.      DTSBX500
00232      05  CT-CONTACT-NAME             PIC  X(35) VALUE SPACES.     DTSBX500
00233      05  CT-PHONE                    PIC  X(10) VALUE SPACES.     DTSBX500
00234      05  CT-SSN                      PIC  X(09) VALUE SPACES.     DTSBX500
00235      05  CT-CONTACT-TITLE            PIC  X(30) VALUE SPACES.     DTSBX500
00236                                                                   DTSBX500
00237      EJECT                                                        DTSBX500
00238  01  L005-COMM-AREA.                                              DTSBX500
00239  ++INCLUDE DTSIL005                                               DTSBX500
00240      EJECT                                                        DTSBX500
00241  01  L071-LINK-AREA.                                              DTSBX500
00242  ++INCLUDE DTSIL071                                               DTSBX500
00243      EJECT                                                        DTSBX500
00244  01  L910-LINK-AREA.                                              DTSBX500
00245  ++INCLUDE DTSIL910                                               DTSBX500
00246      EJECT                                                        DTSBX500
00247  01  L921-LINK-AREA.                                              DTSBX500
00248  ++INCLUDE DTSIL921                                               DTSBX500
00249      EJECT                                                        DTSBX500
00250  01  ISKL-REC.                                                    DTSBX500
00251  ++INCLUDE DTSIISKL                                               DTSBX500
00252      EJECT                                                        DTSBX500
00253  01  IEIN-REC.                                                    DTSBX500
00254  ++INCLUDE DTSIIEIN                                               DTSBX500
00255      EJECT                                                        DTSBX500
00256  01  MSKL-REC.                                                    DTSBX500
00257  ++INCLUDE DTSIMSKL                                               DTSBX500
00258      EJECT                                                        DTSBX500
00259  01  MPRF-REC.                                                    DTSBX500
00260  ++INCLUDE DTSIMPRF                                               DTSBX500
00261      EJECT                                                        DTSBX500
00262  01  MTAD-REC.                                                    DTSBX500
00263  ++INCLUDE DTSIMTAD                                               DTSBX500
00264      EJECT                                                        DTSBX500
00265  01  MQTR-REC.                                                    DTSBX500
00266  ++INCLUDE DTSIMQTR                                               DTSBX500
00267      EJECT                                                        DTSBX500
00268  01  MOPO-REC.                                                    DTSBX500
00269  ++INCLUDE DTSIMOPO                                               DTSBX500
00270      EJECT                                                        DTSBX500
00271 **                                                                DTSBX500
00272  01  L981-LINK-AREA.                                              DTSBX500
00273  ++INCLUDE DTSIL981                                               DTSBX500
00274      SKIP3                                                        DTSBX500
00275  01  WWGH-REC.                                                    DTSBX500
00276  ++INCLUDE DTSIWWGH                                               DTSBX500
00277      EJECT                                                        DTSBX500
00278  01  L982-LINK-AREA.                                              DTSBX500
00279  ++INCLUDE DTSIL982                                               DTSBX500
00280      SKIP3                                                        DTSBX500
00281  01  WNAM-REC.                                                    DTSBX500
00282  ++INCLUDE DTSIWNAM                                               DTSBX500
00283      EJECT                                                        DTSBX500
00284 **                                                                DTSBX500
00285   LINKAGE SECTION.                                                DTSBX500
00286                                                                   DTSBX500
00287   01  PARM-AREA.                                                  DTSBX500
00288       05  PARM-LENGTH                PIC S9(04)  COMP.            DTSBX500
00289       05  PARM-DATA.                                              DTSBX500
00290           10  PARM-YEAR-QTR          PIC  9(05).                  DTSBX500
00291           10  PARM-YEAR-QTR-X REDEFINES PARM-YEAR-QTR             DTSBX500
00292                                      PIC  X(05).                  DTSBX500
00293      EJECT                                                        DTSBX500
00294  PROCEDURE DIVISION USING PARM-AREA.                              DTSBX500
00295                                                                   DTSBX500
00296      PERFORM I0000-INITIATE THRU I0000-EXIT.                      DTSBX500
00297                                                                   DTSBX500
00298      PERFORM P0000-PROCESS THRU P0000-EXIT.                       DTSBX500
00299                                                                   DTSBX500
00300      PERFORM T0000-TERMINATE THRU T0000-EXIT.                     DTSBX500
00301                                                                   DTSBX500
00302      GOBACK.                                                      DTSBX500
00303      EJECT                                                        DTSBX500
00304  I0000-INITIATE.                                                  DTSBX500
00305                                                                   DTSBX500
00306      MOVE 'N' TO WRK-TRACE-IND.                                   DTSBX500
00307      PERFORM I1000-PROCESS-PARMS THRU I1000-EXIT.                 DTSBX500
00308      PERFORM I2000-SYS-DATE      THRU I2000-EXIT.                 DTSBX500
00309      PERFORM I3000-OPEN-FILES    THRU I3000-EXIT.                 DTSBX500
00310                                                                   DTSBX500
00311  I0000-EXIT.                                                      DTSBX500
00312      EXIT.                                                        DTSBX500
00313                                                                   DTSBX500
00314  I1000-PROCESS-PARMS.                                             DTSBX500
00315                                                                   DTSBX500
00316      DISPLAY '*** '                                               DTSBX500
00317              WRK-MOD-NAME                                         DTSBX500
00318              ' PARAMETERS: '                                      DTSBX500
00319              PARM-DATA.                                           DTSBX500
00320                                                                   DTSBX500
00321      IF PARM-LENGTH = +5                                          DTSBX500
00322          NEXT SENTENCE                                            DTSBX500
00323      ELSE                                                         DTSBX500
00324          MOVE 'PARM-LENGTH NOT EQUAL TO 5'                        DTSBX500
00325            TO WRK-ABEND-MSG                                       DTSBX500
00326          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBX500
00327                                                                   DTSBX500
00328      IF PARM-YEAR-QTR = ZEROS OR PARM-YEAR-QTR-X = SPACES         DTSBX500
00329          MOVE 'PARM-YEAR-QTR NOT VALID' TO WRK-ABEND-MSG          DTSBX500
00330          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBX500
00331                                                                   DTSBX500
00332      MOVE PARM-YEAR-QTR         TO  WRK-YRQ  WRK-YEAR-QTR.        DTSBX500
00333                                                                   DTSBX500
00334  I1000-EXIT.                                                      DTSBX500
00335      EXIT.                                                        DTSBX500
00336                                                                   DTSBX500
00337  I2000-SYS-DATE.                                                  DTSBX500
00338      SET L005-FROM-SYS            TO TRUE.                        DTSBX500
00339      PERFORM S005-SYS-DATE        THRU S005-EXIT.                 DTSBX500
00340      MOVE L005-DATE               TO DISP-DATE.                   DTSBX500
00341      MOVE L005-TIME               TO DISP-TIME.                   DTSBX500
00342      MOVE L005-ABSTIME            TO DISP-ABSTIME.                DTSBX500
00343                                                                   DTSBX500
00344      DISPLAY '    '.                                              DTSBX500
00345      DISPLAY 'L005-DATE ' DISP-DATE  ' L005-TIME ' DISP-TIME      DTSBX500
00346         '  L005-ABSTIME ' DISP-ABSTIME.                           DTSBX500
00347                                                                   DTSBX500
00348  I2000-EXIT.                                                      DTSBX500
00349      EXIT.                                                        DTSBX500
00350                                                                   DTSBX500
00351  I3000-OPEN-FILES.                                                DTSBX500
00352      MOVE WRK-TRACE-IND           TO L910-TRACE-IND.              DTSBX500
00353                                                                   DTSBX500
00354      MOVE WRK-MOD-NAME            TO L910-MOD-NAME.               DTSBX500
00355      MOVE WRK-MOD-NAME            TO L981-MOD-NAME.               DTSBX500
00356      MOVE WRK-MOD-NAME            TO L982-MOD-NAME.               DTSBX500
00357                                                                   DTSBX500
00358      PERFORM S910-OPEN-READ       THRU S910-EXIT.                 DTSBX500
00359 *    PERFORM S921-OPEN-READ       THRU S921-EXIT.                 DTSBX500
00360      PERFORM S981A-OPEN-READ      THRU S981A-EXIT.                DTSBX500
00361      PERFORM S982E-OPEN-READ      THRU S982E-EXIT.                DTSBX500
00362                                                                   DTSBX500
00363      OPEN OUTPUT WAGE-FILE.                                       DTSBX500
00364      IF NOT WAGEFILE-OK-88                                        DTSBX500
00365         DISPLAY 'CANNOT OPEN WAGE FILE ' WAGEFILE-STATUS          DTSBX500
00366         MOVE 'CANNOT OPEN WAGE REC FILE ' TO WRK-ABEND-MSG        DTSBX500
00367         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00368      END-IF.                                                      DTSBX500
00369                                                                   DTSBX500
00370      OPEN OUTPUT EMPL-FILE.                                       DTSBX500
00371      IF NOT EMPFILE-OK-88                                         DTSBX500
00372         DISPLAY 'CANNOT OPEN EMP FILE ' EMPFILE-STATUS            DTSBX500
00373         MOVE 'CANNOT OPEN EMPLOYER FILE ' TO WRK-ABEND-MSG        DTSBX500
00374         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00375      END-IF.                                                      DTSBX500
00376                                                                   DTSBX500
00377      OPEN OUTPUT TAX-FILE.                                        DTSBX500
00378      IF NOT TAXFILE-OK-88                                         DTSBX500
00379         DISPLAY 'CANNOT OPEN TAX FILE ' TAXFILE-STATUS            DTSBX500
00380         MOVE 'CANNOT OPEN TAX OUTPUT FILE ' TO WRK-ABEND-MSG      DTSBX500
00381         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00382      END-IF.                                                      DTSBX500
00383                                                                   DTSBX500
00384      OPEN OUTPUT CONTACT-FILE.                                    DTSBX500
00385      IF NOT CONTFILE-OK-88                                        DTSBX500
00386         DISPLAY 'CANNOT OPEN CONTACT FILE ' CONTFILE-STATUS       DTSBX500
00387         MOVE 'CANNOT OPEN CONTACT OUTPUT FILE ' TO WRK-ABEND-MSG  DTSBX500
00388         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00389      END-IF.                                                      DTSBX500
00390                                                                   DTSBX500
00391  I3000-EXIT.                                                      DTSBX500
00392      EXIT.                                                        DTSBX500
00393      EJECT                                                        DTSBX500
00394                                                                   DTSBX500
00395  P0000-PROCESS.                                                   DTSBX500
00396                                                                   DTSBX500
00397      SET WRK-LIABLE-NO-88       TO  TRUE.                         DTSBX500
00398      MOVE LOW-VALUES            TO  WWGH-REC.                     DTSBX500
00399      MOVE ZERO                  TO  WWGH-EMP-NO                   DTSBX500
00400                                     WWGH-YRQ                      DTSBX500
00401                                     WWGH-SSN.                     DTSBX500
00402                                                                   DTSBX500
00403      PERFORM S981D-START-BROWSE  THRU S981D-EXIT.                 DTSBX500
00404      IF L981-NO-REC-88                                            DTSBX500
00405          MOVE '1ST BROWSE WWGH FIND NO REC ' TO WRK-ABEND-MSG     DTSBX500
00406          PERFORM S999-ABEND THRU S999-EXIT                        DTSBX500
00407          GO TO P0000-EXIT                                         DTSBX500
00408      ELSE                                                         DTSBX500
00409         PERFORM P1000-SCAN-WAGES THRU P1000-EXIT                  DTSBX500
00410            UNTIL L981-NO-REC-88.                                  DTSBX500
00411                                                                   DTSBX500
00412  P0000-EXIT.                                                      DTSBX500
00413      EXIT.                                                        DTSBX500
00414                                                                   DTSBX500
00415 **************************************************************    DTSBX500
00416 *  SELECT VSAM-WGH RECORDS FROM YRQ INPUT PARAMETER AND      *    DTSBX500
00417 *  OUTPUT THE WAGE RECORD FILE.                              *    DTSBX500
00418 **************************************************************    DTSBX500
00419                                                                   DTSBX500
00420  P1000-SCAN-WAGES.                                                DTSBX500
00421                                                                   DTSBX500
00422      ADD +1                        TO WRK-WWGH-READ-CNT.          DTSBX500
00423                                                                   DTSBX500
00424      IF WWGH-EMP-NO = ZERO                                        DTSBX500
00425 *       NEXT SENTENCE                                             DTSBX500
00426         ADD +1                     TO WRK-WWGH-ACCT-INVALID       DTSBX500
00427      ELSE                                                         DTSBX500
00428         PERFORM P2000-CHECK-YEAR-QTR THRU P2000-EXIT              DTSBX500
00429      END-IF.                                                      DTSBX500
00430                                                                   DTSBX500
00431      PERFORM S981E-READ-NEXT       THRU S981E-EXIT.               DTSBX500
00432                                                                   DTSBX500
00433  P1000-EXIT.                                                      DTSBX500
00434      EXIT.                                                        DTSBX500
00435                                                                   DTSBX500
00436 **************************************************************    DTSBX500
00437 *  CREATE WAGE OUTPUT RECORDS, BASED ON YEAR-QUARTER         *    DTSBX500
00438 **************************************************************    DTSBX500
00439                                                                   DTSBX500
00440  P2000-CHECK-YEAR-QTR.                                            DTSBX500
00441 *                                                                 DTSBX500
00442      IF WWGH-YRQ = WRK-YRQ                                        DTSBX500
00443 *RW     IF WWGH-EMP-NO NOT = WRK-WWGH-EMP-NO                      DTSBX500
00444         IF WWGH-EMP-NO NOT = WRK-EMP-NO                           DTSBX500
00445            PERFORM P4000-READ-MQTR            THRU P4000-EXIT     DTSBX500
00446            IF WRK-LIABLE-YES-88                                   DTSBX500
00447               PERFORM P2100-READ-MPRF         THRU P2100-EXIT     DTSBX500
00448 **            IF WRK-SUBJECT-YES-88                               DTSBX500
00449 *RW1                                                              DTSBX500
00450               ADD +1  TO WRK-WWGH-EMP-NO-CNT                      DTSBX500
00451 *RW2                                                              DTSBX500
00452               PERFORM P2300-WRITE-EMPL-RECORD THRU P2300-EXIT     DTSBX500
00453 **            PERFORM P4000-READ-MQTR         THRU P4000-EXIT     DTSBX500
00454               PERFORM P5000-READ-MOPO         THRU P5000-EXIT     DTSBX500
00455            END-IF                                                 DTSBX500
00456         END-IF                                                    DTSBX500
00457      ELSE                                                         DTSBX500
00458         GO TO P2000-EXIT.                                         DTSBX500
00459                                                                   DTSBX500
00460 **   IF WRK-SUBJECT-YES-88                                        DTSBX500
00461      IF WRK-LIABLE-YES-88                                         DTSBX500
00462         PERFORM P2200-WRITE-WAGE-RECORD       THRU P2200-EXIT     DTSBX500
00463      END-IF.                                                      DTSBX500
00464                                                                   DTSBX500
00465  P2000-EXIT.                                                      DTSBX500
00466      EXIT.                                                        DTSBX500
00467                                                                   DTSBX500
00468  P2100-READ-MPRF.                                                 DTSBX500
00469 **   SET WRK-SUBJECT-NO-88         TO TRUE.                       DTSBX500
00470      MOVE LOW-VALUES               TO MSKL-KEY-AREA.              DTSBX500
00471      MOVE WWGH-EMP-NO              TO MSKL-EMP-NO.                DTSBX500
00472      SET MSKL-PRF-88               TO TRUE.                       DTSBX500
00473                                                                   DTSBX500
00474      PERFORM S910-READ             THRU S910-EXIT.                DTSBX500
00475      IF L910-OK-88                                                DTSBX500
00476         MOVE MSKL-REC              TO MPRF-REC                    DTSBX500
00477         IF MPRF-STATUS-SUB-88                                     DTSBX500
00478            ADD +1                  TO WRK-MPRF-READ-CNT           DTSBX500
00479            IF MPRF-STATUS-ACT-88                                  DTSBX500
00480 **            MOVE MPRF-EMP-NO        TO WRK-EMP-NO               DTSBX500
00481 *RW                                      WRK-WWGH-EMP-NO          DTSBX500
00482 **            SET WRK-SUBJECT-YES-88  TO TRUE                     DTSBX500
00483               ADD +1                  TO WRK-MPRF-ACT-CNT         DTSBX500
00484            ELSE                                                   DTSBX500
00485 **            MOVE MPRF-EMP-NO        TO WRK-EMP-NO               DTSBX500
00486 *RW                                      WRK-WWGH-EMP-NO          DTSBX500
00487 **            SET WRK-SUBJECT-YES-88  TO TRUE                     DTSBX500
00488               ADD +1                  TO WRK-MPRF-ACT-NO-CNT      DTSBX500
00489 *             DISPLAY 'INACTIVE MPRF-EMP-NO = ' MPRF-EMP-NO '  '  DTSBX500
00490 *                       'WWGH-EMP-NO = '  WWGH-EMP-NO             DTSBX500
00491            END-IF                                                 DTSBX500
00492         END-IF                                                    DTSBX500
00493      ELSE                                                         DTSBX500
00494         DISPLAY 'WAGE FILE EMP-NO INVALID ' WWGH-EMP-NO           DTSBX500
00495         ADD +1                     TO WRK-WWGH-ACCT-INVALID       DTSBX500
00496      END-IF.                                                      DTSBX500
00497                                                                   DTSBX500
00498  P2100-EXIT.                                                      DTSBX500
00499      EXIT.                                                        DTSBX500
00500                                                                   DTSBX500
00501  P2200-WRITE-WAGE-RECORD.                                         DTSBX500
00502                                                                   DTSBX500
00503      SET WRK-ERROR-NO-88               TO TRUE.                   DTSBX500
00504      MOVE LOW-VALUE                    TO WNAM-REC.               DTSBX500
00505      MOVE WWGH-SSN                     TO WNAM-SSN.               DTSBX500
00506                                                                   DTSBX500
00507      PERFORM S982A-START-BROWSE       THRU S982A-EXIT.            DTSBX500
00508                                                                   DTSBX500
00509      IF L982-OK-88                                                DTSBX500
00510         IF NOT WNAM-TYPE-3CHAR-88                                 DTSBX500
00511            MOVE WNAM-FIRST-NAME       TO WR-FIRST-NAME            DTSBX500
00512            MOVE WNAM-MID-INIT         TO WR-M-I                   DTSBX500
00513            MOVE WNAM-LAST-NAME        TO WR-LAST-NAME             DTSBX500
00514         ELSE                                                      DTSBX500
00515            MOVE SPACES                TO WR-FIRST-NAME            DTSBX500
00516            MOVE SPACES                TO WR-M-I                      CL**5
00517            MOVE SPACES                TO WR-LAST-NAME             DTSBX500
00518         END-IF                                                    DTSBX500
00519      ELSE                                                         DTSBX500
00520         MOVE SPACES                   TO WR-FIRST-NAME            DTSBX500
00521         MOVE SPACES                   TO WR-M-I                      CL**5
00522         MOVE SPACES                   TO WR-LAST-NAME             DTSBX500
00523      END-IF.                                                         CL**7
00524                                                                      CL**7
00525      IF WR-M-I = LOW-VALUES                                          CL**7
00526         MOVE SPACES TO WR-M-I                                        CL**7
00527      END-IF.                                                         CL**7
00528                                                                      CL**7
00529      MOVE WWGH-SSN                    TO WRK-SSN.                 DTSBX500
00530      MOVE WRK-SSN                     TO WR-SSN.                  DTSBX500
00531                                                                   DTSBX500
00532      MOVE WRK-EMP-NO                  TO WR-ACCT-NO-LAST-6.       DTSBX500
00533                                                                   DTSBX500
00534      MOVE MPRF-FEIN                   TO WRK-FEIN.                DTSBX500
00535      MOVE WRK-FEIN                    TO WR-EIN.                  DTSBX500
00536                                                                   DTSBX500
00537      MOVE WRK-YRQ-YEAR                TO WR-YEAR.                 DTSBX500
00538      MOVE WRK-YRQ-QTR                 TO WR-QUARTER.              DTSBX500
00539                                                                   DTSBX500
00540      MOVE WWGH-EARNINGS               TO WRK-EARNINGS.            DTSBX500
00541      MOVE WRK-EARNINGS                TO WR-WAGE.                 DTSBX500
00542                                                                   DTSBX500
00543      WRITE WAGE-RECORD  FROM WR-WAGE-RECORD.                      DTSBX500
00544      IF WAGEFILE-OK-88                                            DTSBX500
00545         ADD +1    TO  WRK-WAGE-REC-WRITE-CNT                      DTSBX500
00546 *RW1                                                              DTSBX500
00547 *       IF WRK-WAGE-REC-WRITE-CNT < 2000                          DTSBX500
00548 *          DISPLAY ' WWGH-EMP-NO = ' WRK-EMP-NO '  ' WRK-SSN      DTSBX500
00549 *       END-IF                                                    DTSBX500
00550 *RW2                                                              DTSBX500
00551      ELSE                                                         DTSBX500
00552         DISPLAY 'CANNOT WRITE WAGE REC, WWGH-EMP-NO = ' WRK-EMP-NODTSBX500
00553         DISPLAY 'THE WAGE FILE STATUS = ' WAGEFILE-STATUS         DTSBX500
00554         DISPLAY '    '                                            DTSBX500
00555         SET WRK-ERROR-YES-88 TO TRUE                              DTSBX500
00556         MOVE 'CANNOT WRITE WAGE FILE RECS ' TO WRK-ABEND-MSG      DTSBX500
00557         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00558      END-IF.                                                      DTSBX500
00559                                                                   DTSBX500
00560  P2200-EXIT.                                                      DTSBX500
00561      EXIT.                                                        DTSBX500
00562                                                                   DTSBX500
00563  P2300-WRITE-EMPL-RECORD.                                         DTSBX500
00564                                                                   DTSBX500
00565      MOVE WRK-EMP-NO                  TO ER-ACCT-NO-LAST-6.       DTSBX500
00566      MOVE WRK-FEIN                    TO ER-EIN.                  DTSBX500
00567                                                                   DTSBX500
00568      MOVE WRK-YRQ-YEAR                TO ER-YEAR.                 DTSBX500
00569      MOVE WRK-YRQ-QTR                 TO ER-QUARTER.              DTSBX500
00570                                                                   DTSBX500
00571      MOVE MPRF-OWN-CD                 TO ER-OWNERSHIP-CODE.       DTSBX500
00572      MOVE MPRF-SIC-CD                 TO ER-SIC-CODE.             DTSBX500
00573      MOVE MPRF-NAICS-CD               TO ER-NAICS-CODE.           DTSBX500
00574                                                                   DTSBX500
00575      IF MPRF-PRIMARY-IS-ENTITY-88                                 DTSBX500
00576         MOVE MPRF-PRIMARY-NAME        TO ER-EMP-PRIMARY-NAME      DTSBX500
00577         MOVE MPRF-PRIMARY-NAME        TO ER-EMP-ENTITY-NAME       DTSBX500
00578      ELSE                                                         DTSBX500
00579         MOVE MPRF-PRIMARY-NAME        TO ER-EMP-PRIMARY-NAME      DTSBX500
00580         IF MPRF-ENTITY-NAME = LOW-VALUES                             CL**2
00581            MOVE SPACES                TO ER-EMP-ENTITY-NAME          CL**2
00582            DISPLAY 'P2300 - LOW-VALUES IN ENTITY ' MPRF-EMP-NO       CL**3
00583         ELSE                                                         CL**2
00584            MOVE MPRF-ENTITY-NAME      TO ER-EMP-ENTITY-NAME          CL**2
00585         END-IF                                                       CL**2
00586      END-IF.                                                         CL**2
00587                                                                   DTSBX500
00588      PERFORM P3000-FIND-ADDRESS     THRU P3000-EXIT               DTSBX500
00589                                                                   DTSBX500
00590      WRITE EMPL-RECORD  FROM ER-EMPL-RECORD.                      DTSBX500
00591      IF EMPFILE-OK-88                                             DTSBX500
00592         ADD +1    TO  WRK-EMPL-REC-WRITE-CNT                      DTSBX500
00593      ELSE                                                         DTSBX500
00594         DISPLAY 'CANNOT WRITE EMPL REC, MPRF-EMP-NO = ' WRK-EMP-NODTSBX500
00595         DISPLAY 'THE EMPL FILE STATUS = ' EMPFILE-STATUS          DTSBX500
00596         DISPLAY '    '                                            DTSBX500
00597         MOVE 'CANNOT WRITE EMPLOYER FILE RECS ' TO WRK-ABEND-MSG  DTSBX500
00598         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00599      END-IF.                                                      DTSBX500
00600                                                                   DTSBX500
00601  P2300-EXIT.                                                      DTSBX500
00602      EXIT.                                                        DTSBX500
00603                                                                   DTSBX500
00604  P3000-FIND-ADDRESS.                                              DTSBX500
00605                                                                   DTSBX500
00606      MOVE LOW-VALUE              TO MTAD-REC.                     DTSBX500
00607      MOVE MPRF-EMP-NO            TO MTAD-EMP-NO.                  DTSBX500
00608      SET MTAD-TAD-88 TO TRUE.                                     DTSBX500
00609      SET MTAD-ID-TAX-MAILING-ADDR-88 TO TRUE.                     DTSBX500
00610      PERFORM P3100-GET-MAILING-DATA THRU P3100-EXIT.              DTSBX500
00611                                                                   DTSBX500
00612      MOVE LOW-VALUE              TO MTAD-REC.                     DTSBX500
00613      MOVE MPRF-EMP-NO            TO MTAD-EMP-NO.                  DTSBX500
00614      SET MTAD-TAD-88 TO TRUE.                                     DTSBX500
00615      SET MTAD-ID-TAX-RECORDS-ADDR-88 TO TRUE.                     DTSBX500
00616      PERFORM P3200-GET-PHYSICAL-DATA THRU P3200-EXIT.             DTSBX500
00617                                                                   DTSBX500
00618      SET WRK-EMP-SELECTED-YES    TO TRUE.                         DTSBX500
00619      ADD +1                      TO WRK-ADDR-SELECT-CNT.          DTSBX500
00620                                                                   DTSBX500
00621  P3000-EXIT.                                                      DTSBX500
00622      EXIT.                                                        DTSBX500
00623                                                                   DTSBX500
00624  P3100-GET-MAILING-DATA.                                          DTSBX500
00625                                                                   DTSBX500
00626      MOVE MTAD-KEY-AREA TO MSKL-KEY-AREA.                         DTSBX500
00627      PERFORM S910-READ          THRU S910-EXIT.                   DTSBX500
00628      IF L910-NO-REC-88                                            DTSBX500
00629         ADD +1                  TO WRK-ADDR-FOUND-NO-CNT          DTSBX500
00630         GO TO P3100-EXIT.                                         DTSBX500
00631                                                                   DTSBX500
00632      MOVE MSKL-REC               TO MTAD-REC.                     DTSBX500
00633                                                                   DTSBX500
00634      ADD +1                      TO WRK-TAX-ADDR-CNT.             DTSBX500
00635      MOVE MTAD-DELIV-LINE-2      TO ER-MAILING-ADDRESS-1          DTSBX500
00636                                     WS-MAILING-ADDRESS-1.         DTSBX500
00637      MOVE MTAD-DELIV-LINE-1      TO ER-MAILING-ADDRESS-2          DTSBX500
00638                                     WS-MAILING-ADDRESS-2.         DTSBX500
00639      MOVE MTAD-CITY              TO ER-CITY-1                     DTSBX500
00640                                     WS-CITY-1.                    DTSBX500
00641      MOVE MTAD-ST                TO ER-STATE-1                    DTSBX500
00642                                     WS-STATE-1.                   DTSBX500
00643      MOVE MTAD-ZIP               TO WS-ZIP-1.                     DTSBX500
00644      MOVE WS-ZIP-1-5             TO ER-ZIP-1-5.                   DTSBX500
00645      MOVE WS-ZIP-1-4             TO ER-ZIP-1-4.                   DTSBX500
00646      MOVE MTAD-VOICE-1-AREA-CD   TO WS-VOICE-1-AREA-CD.           DTSBX500
00647      MOVE MTAD-VOICE-1-PREFIX    TO WS-VOICE-1-PREFIX.            DTSBX500
00648      MOVE MTAD-VOICE-1-SUFFIX    TO WS-VOICE-1-SUFFIX.            DTSBX500
00649      MOVE WS-VOICE-1             TO ER-PHONE.                     DTSBX500
00650                                                                   DTSBX500
00651  P3100-EXIT.                                                      DTSBX500
00652      EXIT.                                                        DTSBX500
00653                                                                   DTSBX500
00654  P3200-GET-PHYSICAL-DATA.                                         DTSBX500
00655                                                                   DTSBX500
00656      MOVE MTAD-KEY-AREA TO MSKL-KEY-AREA.                         DTSBX500
00657      PERFORM S910-READ          THRU S910-EXIT.                   DTSBX500
00658      IF L910-NO-REC-88                                            DTSBX500
00659         ADD +1                     TO WRK-PHY-TAX-ADDR-SAME-CNT   DTSBX500
00660         MOVE WS-MAILING-ADDRESS-1  TO ER-PHYSICAL-ADDRESS-1       DTSBX500
00661         MOVE WS-MAILING-ADDRESS-2  TO ER-PHYSICAL-ADDRESS-2       DTSBX500
00662         MOVE WS-CITY-1             TO ER-CITY-2                   DTSBX500
00663         MOVE WS-STATE-1            TO ER-STATE-2                  DTSBX500
00664         MOVE WS-ZIP-1-5            TO ER-ZIP-2-5                  DTSBX500
00665         MOVE WS-ZIP-1-4            TO ER-ZIP-2-4                  DTSBX500
00666         GO TO P3200-EXIT.                                         DTSBX500
00667                                                                   DTSBX500
00668      MOVE MSKL-REC                 TO MTAD-REC.                   DTSBX500
00669                                                                   DTSBX500
00670      ADD +1                        TO WRK-PHY-ADDR-CNT.           DTSBX500
00671      MOVE MTAD-DELIV-LINE-2        TO ER-PHYSICAL-ADDRESS-1.      DTSBX500
00672      MOVE MTAD-DELIV-LINE-1        TO ER-PHYSICAL-ADDRESS-2.      DTSBX500
00673      MOVE MTAD-CITY                TO ER-CITY-2.                  DTSBX500
00674      MOVE MTAD-ST                  TO ER-STATE-2.                 DTSBX500
00675      MOVE MTAD-ZIP                 TO WS-ZIP-2.                   DTSBX500
00676      MOVE WS-ZIP-2-5               TO ER-ZIP-2-5.                 DTSBX500
00677      MOVE WS-ZIP-2-4               TO ER-ZIP-2-4.                 DTSBX500
00678                                                                   DTSBX500
00679  P3200-EXIT.                                                      DTSBX500
00680      EXIT.                                                        DTSBX500
00681                                                                   DTSBX500
00682  P4000-READ-MQTR.                                                 DTSBX500
00683                                                                   DTSBX500
00684      SET WRK-LIABLE-NO-88            TO TRUE.                     DTSBX500
00685      MOVE LOW-VALUE                  TO MQTR-KEY-AREA.            DTSBX500
00686 **   MOVE MPRF-EMP-NO                TO MQTR-EMP-NO.              DTSBX500
00687      MOVE WWGH-EMP-NO                TO MQTR-EMP-NO.              DTSBX500
00688      SET MQTR-QTR-88                 TO TRUE.                     DTSBX500
00689      MOVE WRK-YRQ                    TO MQTR-YRQ.                 DTSBX500
00690      MOVE MQTR-KEY-AREA              TO MSKL-KEY-AREA.            DTSBX500
00691      PERFORM S910-READ               THRU S910-EXIT.              DTSBX500
00692                                                                   DTSBX500
00693      IF L910-OK-88                                                DTSBX500
00694         MOVE MSKL-REC                  TO MQTR-REC                DTSBX500
00695 *RW3                                                              DTSBX500
00696         IF MQTR-CURR-NOT-LIABLE-88                                DTSBX500
00697            ADD +1 TO  WRK-NOT-LIABLE-REC-CNT                      DTSBX500
00698 **         GO TO P4000-EXIT                                       DTSBX500
00699         ELSE                                                      DTSBX500
00700            SET WRK-LIABLE-YES-88 TO TRUE                          DTSBX500
00701            ADD +1 TO  WRK-LIABLE-REC-CNT                          DTSBX500
00702 *RW4                                                              DTSBX500
00703            PERFORM P4100-WRITE-TAX-RECORD THRU P4100-EXIT         DTSBX500
00704      ELSE                                                         DTSBX500
00705         ADD +1    TO  WRK-MQTR-REC-NOT-FOUND-CNT                  DTSBX500
00706         DISPLAY 'MQTR REC NOT FOUND - WWGH-EMP-NO = '             DTSBX500
00707                    WWGH-EMP-NO                                    DTSBX500
00708      END-IF.                                                      DTSBX500
00709                                                                   DTSBX500
00710      MOVE WWGH-EMP-NO TO WRK-EMP-NO.                              DTSBX500
00711                                                                   DTSBX500
00712  P4000-EXIT.                                                      DTSBX500
00713      EXIT.                                                        DTSBX500
00714                                                                   DTSBX500
00715  P4100-WRITE-TAX-RECORD.                                          DTSBX500
00716                                                                   DTSBX500
00717      MOVE ZEROS                       TO WRK-QTR-PAID-AMT         DTSBX500
00718                                          WRK-QTR-TOT-WAGE         DTSBX500
00719                                          WRK-QTR-TAX-WAGE.        DTSBX500
00720                                                                   DTSBX500
00721 **   MOVE WRK-EMP-NO                  TO TX-ACCT-NO-LAST-6.       DTSBX500
00722      MOVE MQTR-EMP-NO                 TO WRK-MQTR-EMP-NO.         DTSBX500
00723      MOVE WRK-MQTR-EMP-NO             TO TX-ACCT-NO-LAST-6.       DTSBX500
00724                                                                   DTSBX500
00725      MOVE WRK-YRQ-YEAR                TO TX-YEAR.                 DTSBX500
00726      MOVE WRK-YRQ-QTR                 TO TX-QUARTER.              DTSBX500
00727                                                                   DTSBX500
00728      PERFORM                                                      DTSBX500
00729        VARYING MQTR-ACCT-IDX  FROM 1 BY 1                         DTSBX500
00730          UNTIL MQTR-ACCT-IDX  GREATER THAN  MQTR-ACCT-CNT         DTSBX500
00731                                                                   DTSBX500
00732        IF MQTR-ACCT-UI-88 (MQTR-ACCT-IDX)                         DTSBX500
00733             MOVE MQTR-PAID-AMT (MQTR-ACCT-IDX) TO WRK-QTR-PAID-AMTDTSBX500
00734 *           SET MQTR-ACCT-IDX  TO MQTR-ACT-CNT                    DTSBX500
00735        END-IF                                                     DTSBX500
00736      END-PERFORM.                                                 DTSBX500
00737                                                                   DTSBX500
00738      MOVE WRK-QTR-PAID-AMT            TO TX-TAX-PAID.             DTSBX500
00739                                                                   DTSBX500
00740      MOVE MQTR-TOT-WAGE               TO WRK-QTR-TOT-WAGE.        DTSBX500
00741      MOVE WRK-QTR-TOT-WAGE            TO TX-TOT-WAGE.             DTSBX500
00742                                                                   DTSBX500
00743      MOVE MQTR-TAX-WAGE               TO WRK-QTR-TAX-WAGE.        DTSBX500
00744      MOVE WRK-QTR-TAX-WAGE            TO TX-TAX-WAGE.             DTSBX500
00745                                                                   DTSBX500
00746      IF MQTR-UI-RATE = -9.9999                                    DTSBX500
00747         MOVE SPACE           TO TX-UI-RATE                        DTSBX500
00748      ELSE                                                         DTSBX500
00749         MOVE MQTR-UI-RATE    TO WRK-QTR-UI-RATE                   DTSBX500
00750         MOVE WRK-QTR-UI-RATE TO TX-UI-RATE                        DTSBX500
00751      END-IF.                                                      DTSBX500
00752                                                                   DTSBX500
00753      IF MQTR-1ST-MTH-EMPL-CNT = +9999999                          DTSBX500
00754         MOVE '000000'     TO TX-MON1-EMP-CNT                      DTSBX500
00755      ELSE                                                         DTSBX500
00756         MOVE MQTR-1ST-MTH-EMPL-CNT TO WRK-QTR-MON1-EMP-CNT        DTSBX500
00757         MOVE WRK-QTR-MON1-EMP-CNT  TO TX-MON1-EMP-CNT             DTSBX500
00758      END-IF.                                                      DTSBX500
00759                                                                   DTSBX500
00760      IF MQTR-2ND-MTH-EMPL-CNT = +9999999                          DTSBX500
00761         MOVE '000000'     TO TX-MON2-EMP-CNT                      DTSBX500
00762      ELSE                                                         DTSBX500
00763         MOVE MQTR-2ND-MTH-EMPL-CNT TO WRK-QTR-MON2-EMP-CNT        DTSBX500
00764         MOVE WRK-QTR-MON2-EMP-CNT  TO TX-MON2-EMP-CNT             DTSBX500
00765      END-IF.                                                      DTSBX500
00766                                                                   DTSBX500
00767      IF MQTR-3RD-MTH-EMPL-CNT = +9999999                          DTSBX500
00768         MOVE '000000'     TO TX-MON3-EMP-CNT                      DTSBX500
00769      ELSE                                                         DTSBX500
00770         MOVE MQTR-3RD-MTH-EMPL-CNT TO WRK-QTR-MON3-EMP-CNT        DTSBX500
00771         MOVE WRK-QTR-MON3-EMP-CNT  TO TX-MON3-EMP-CNT             DTSBX500
00772      END-IF.                                                      DTSBX500
00773                                                                   DTSBX500
00774      WRITE TAX-RECORD  FROM TX-TAX-RECORD.                        DTSBX500
00775      IF TAXFILE-OK-88                                             DTSBX500
00776         ADD +1    TO  WRK-TAX-REC-WRITE-CNT                       DTSBX500
00777      ELSE                                                         DTSBX500
00778         DISPLAY 'CANNOT WRITE TAX REC, MPRF-EMP-NO = ' WRK-EMP-NO DTSBX500
00779         DISPLAY 'THE TAX FILE STATUS = ' TAXFILE-STATUS           DTSBX500
00780         DISPLAY '    '                                            DTSBX500
00781         MOVE 'CANNOT WRITE TAX FILE RECS ' TO WRK-ABEND-MSG       DTSBX500
00782         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00783      END-IF.                                                      DTSBX500
00784                                                                   DTSBX500
00785  P4100-EXIT.                                                      DTSBX500
00786      EXIT.                                                        DTSBX500
00787                                                                   DTSBX500
00788  P5000-READ-MOPO.                                                 DTSBX500
00789                                                                   DTSBX500
00790      MOVE LOW-VALUE                  TO MOPO-KEY-AREA.            DTSBX500
00791      MOVE MPRF-EMP-NO                TO MOPO-EMP-NO.              DTSBX500
00792      SET MOPO-OPO-88                 TO TRUE.                     DTSBX500
00793      MOVE MOPO-KEY-AREA              TO MSKL-KEY-AREA.            DTSBX500
00794      PERFORM S910-START-BROWSE THRU S910-EXIT.                    DTSBX500
00795      IF L910-NO-REC-88                                            DTSBX500
00796         NEXT SENTENCE                                             DTSBX500
00797      ELSE                                                         DTSBX500
00798         PERFORM                                                   DTSBX500
00799           UNTIL L910-NO-REC-88                                    DTSBX500
00800              MOVE MSKL-REC             TO MOPO-REC                DTSBX500
00801              IF MOPO-TYPE-OPO-88                                  DTSBX500
00802 *               DISPLAY 'MOPO-EMP-NO = ' MOPO-EMP-NO              DTSBX500
00803 *               DISPLAY 'CONTACT - MOPO NAME FOUND ' MOPO-NAME    DTSBX500
00804                 PERFORM P5100-WRITE-CONTACT-RECORD                DTSBX500
00805                           THRU P5100-EXIT                         DTSBX500
00806                 PERFORM S910-READ-NEXT   THRU S910-EXIT           DTSBX500
00807              ELSE                                                 DTSBX500
00808                 PERFORM S910-READ-NEXT   THRU S910-EXIT           DTSBX500
00809              END-IF                                               DTSBX500
00810         END-PERFORM                                               DTSBX500
00811      END-IF.                                                      DTSBX500
00812                                                                   DTSBX500
00813  P5000-EXIT.                                                      DTSBX500
00814      EXIT.                                                        DTSBX500
00815                                                                   DTSBX500
00816  P5100-WRITE-CONTACT-RECORD.                                      DTSBX500
00817      MOVE SPACES                      TO WRK-VOICE-1.             DTSBX500
00818      MOVE ZEROS                       TO WRK-MOPO-SSN.            DTSBX500
00819                                                                   DTSBX500
00820      MOVE WRK-EMP-NO                  TO CT-ACCT-NO-LAST-6.       DTSBX500
00821                                                                   DTSBX500
00822      MOVE WRK-YRQ-YEAR                TO CT-YEAR.                 DTSBX500
00823      MOVE WRK-YRQ-QTR                 TO CT-QUARTER.              DTSBX500
00824                                                                   DTSBX500
00825      INSPECT MOPO-NAME REPLACING ALL LOW-VALUE BY SPACE.          DTSBX500
00826      MOVE MOPO-NAME                   TO L071-NAM.                DTSBX500
00827      SET L071-FROM-LAST-NAME-FIRST    TO TRUE.                    DTSBX500
00828      PERFORM S071-DESLASH-NAME THRU   S071-EXIT.                  DTSBX500
00829      MOVE L071-NAM                    TO CT-CONTACT-NAME.         DTSBX500
00830 *    DISPLAY 'MOPO-EMP-NO = ' MOPO-EMP-NO.                        DTSBX500
00831 *    DISPLAY 'CONTACT - MOPO NAME FOUND ' L071-NAM.               DTSBX500
00832                                                                   DTSBX500
00833      MOVE MOPO-VOICE-1-AREA-CD        TO WRK-VOICE-1-AREA-CD.     DTSBX500
00834      MOVE MOPO-VOICE-1-PREFIX         TO WRK-VOICE-1-PREFIX.      DTSBX500
00835      MOVE MOPO-VOICE-1-SUFFIX         TO WRK-VOICE-1-SUFFIX.      DTSBX500
00836      MOVE WRK-VOICE-1                 TO CT-PHONE.                DTSBX500
00837                                                                   DTSBX500
00838      MOVE MOPO-SSN                    TO WRK-MOPO-SSN.            DTSBX500
00839      MOVE WRK-MOPO-SSN                TO CT-SSN.                  DTSBX500
00840                                                                   DTSBX500
00841      MOVE MOPO-TITLE                  TO CT-CONTACT-TITLE         DTSBX500
00842                                                                   DTSBX500
00843      WRITE CONTACT-RECORD  FROM CT-CONTACT-RECORD.                DTSBX500
00844      IF CONTFILE-OK-88                                            DTSBX500
00845         ADD +1    TO  WRK-CONTACT-REC-WRITE-CNT                   DTSBX500
00846      ELSE                                                         DTSBX500
00847         DISPLAY 'CANNOT WRITE CONTACT REC, MPRF-EMP-NO = '        DTSBX500
00848                    WRK-EMP-NO                                     DTSBX500
00849         DISPLAY 'THE CONTACT FILE STATUS = ' CONTFILE-STATUS      DTSBX500
00850         DISPLAY '    '                                            DTSBX500
00851         MOVE 'CANNOT WRITE CONTACT FILE RECS ' TO WRK-ABEND-MSG   DTSBX500
00852         PERFORM S999-ABEND THRU S999-EXIT                         DTSBX500
00853      END-IF.                                                      DTSBX500
00854                                                                   DTSBX500
00855  P5100-EXIT.                                                      DTSBX500
00856      EXIT.                                                        DTSBX500
00857                                                                   DTSBX500
00858  T0000-TERMINATE.                                                 DTSBX500
00859                                                                   DTSBX500
00860      DISPLAY ' '.                                                 DTSBX500
00861                                                                   DTSBX500
00862      DISPLAY '*** DTSBZ500 TERMINATION STATISTICS ***'.           DTSBX500
00863                                                                   DTSBX500
00864      DISPLAY ' '.                                                 DTSBX500
00865                                                                   DTSBX500
00866      DISPLAY 'VSAM WAGE FILE INPUT REC READ COUNT            : '  DTSBX500
00867              WRK-WWGH-READ-CNT.                                   DTSBX500
00868                                                                   DTSBX500
00869      DISPLAY 'VSAM WAGE FILE ACCOUNT INVALID COUNT           : '  DTSBX500
00870              WRK-WWGH-ACCT-INVALID.                               DTSBX500
00871                                                                   DTSBX500
00872      DISPLAY ' '.                                                 DTSBX500
00873                                                                   DTSBX500
00874      DISPLAY 'MPRF MASTER FILE SUBJ STATUS ACCT RECS READ    : '  DTSBX500
00875              WRK-MPRF-READ-CNT.                                   DTSBX500
00876                                                                   DTSBX500
00877      DISPLAY ' MPRF MASTER FILE ACT STATUS ACCT RECS READ    : '  DTSBX500
00878              WRK-MPRF-ACT-CNT.                                    DTSBX500
00879                                                                   DTSBX500
00880      DISPLAY ' MPRF MASTER FILE INACTIVE STATUS ACCT READ    : '  DTSBX500
00881              WRK-MPRF-ACT-NO-CNT.                                 DTSBX500
00882                                                                   DTSBX500
00883      DISPLAY ' '.                                                 DTSBX500
00884                                                                   DTSBX500
00885      DISPLAY 'NUMBER OF TAX MAILING ADDRESSES FOUND COUNT    : '  DTSBX500
00886              WRK-TAX-ADDR-CNT.                                    DTSBX500
00887                                                                   DTSBX500
00888      DISPLAY 'NUMBER OF PHYSICAL ADDRESSES FOUND COUNT       : '  DTSBX500
00889              WRK-PHY-ADDR-CNT.                                    DTSBX500
00890                                                                   DTSBX500
00891      DISPLAY 'NUMBER OF PHYSICAL AND MAILING ADDR SAME CNT   : '  DTSBX500
00892              WRK-PHY-TAX-ADDR-SAME-CNT                            DTSBX500
00893                                                                   DTSBX500
00894      DISPLAY ' '.                                                 DTSBX500
00895                                                                   DTSBX500
00896      DISPLAY 'NUMBER OF EMPLOYERS WAGES ACCOUNT COUNT        : '  DTSBX500
00897              WRK-WWGH-EMP-NO-CNT.                                 DTSBX500
00898                                                                   DTSBX500
00899      DISPLAY 'NUMBER OF SS WAGE RECORDS WRITTEN COUNT        : '  DTSBX500
00900              WRK-WAGE-REC-WRITE-CNT.                              DTSBX500
00901                                                                   DTSBX500
00902      DISPLAY ' '.                                                 DTSBX500
00903                                                                   DTSBX500
00904      DISPLAY 'NUMBER OF EMPL RECORDS WRITTEN COUNT           : '  DTSBX500
00905              WRK-EMPL-REC-WRITE-CNT.                              DTSBX500
00906                                                                   DTSBX500
00907      DISPLAY ' '.                                                 DTSBX500
00908                                                                   DTSBX500
00909      DISPLAY ' NUMBER OF TAX RECORDS WRITTEN COUNT           : '  DTSBX500
00910              WRK-TAX-REC-WRITE-CNT.                               DTSBX500
00911                                                                   DTSBX500
00912      DISPLAY 'NUMBER OF YEAR-QTR MQTR REC NOT FOUND          : '  DTSBX500
00913              WRK-MQTR-REC-NOT-FOUND-CNT.                          DTSBX500
00914                                                                   DTSBX500
00915      DISPLAY ' '.                                                 DTSBX500
00916                                                                   DTSBX500
00917      DISPLAY ' NUMBER OF CONTACT REC WRITTEN COUNT           : '  DTSBX500
00918              WRK-CONTACT-REC-WRITE-CNT.                           DTSBX500
00919                                                                   DTSBX500
00920      DISPLAY ' '.                                                 DTSBX500
00921                                                                   DTSBX500
00922      DISPLAY ' NUMBER OF LIABLE RECORDS COUNT                : '  DTSBX500
00923              WRK-LIABLE-REC-CNT.                                  DTSBX500
00924                                                                   DTSBX500
00925      DISPLAY ' NUMBER OF NOT-LIABLE RECORDS COUNT            : '  DTSBX500
00926              WRK-NOT-LIABLE-REC-CNT.                              DTSBX500
00927                                                                   DTSBX500
00928      DISPLAY ' '.                                                 DTSBX500
00929                                                                   DTSBX500
00930      PERFORM S910-CLOSE             THRU S910-EXIT.               DTSBX500
00931      PERFORM S981C-CLOSE            THRU S981C-EXIT.              DTSBX500
00932      PERFORM S982F-CLOSE            THRU S982F-EXIT.              DTSBX500
00933                                                                   DTSBX500
00934      CLOSE WAGE-FILE TAX-FILE CONTACT-FILE EMPL-FILE.             DTSBX500
00935                                                                   DTSBX500
00936  T0000-EXIT.                                                      DTSBX500
00937      EXIT.                                                        DTSBX500
00938      EJECT                                                        DTSBX500
00939                                                                   DTSBX500
00940  S005-SYS-DATE.                                                   DTSBX500
00941      CALL 'DTSBU005' USING L005-COMM-AREA.                        DTSBX500
00942                                                                   DTSBX500
00943  S005-EXIT.                                                       DTSBX500
00944      EXIT.                                                        DTSBX500
00945                                                                   DTSBX500
00946  S071-DESLASH-NAME.                                               DTSBX500
00947      CALL 'DTSBU071' USING L071-LINK-AREA.                        DTSBX500
00948  S071-EXIT.                                                       DTSBX500
00949      EXIT.                                                        DTSBX500
00950      EJECT                                                        DTSBX500
00951                                                                   DTSBX500
00952  S910-OPEN-READ.                                                  DTSBX500
00953      SET L910-OPEN-READ-88 TO TRUE.                               DTSBX500
00954      GO TO S910-MSTR-IO.                                          DTSBX500
00955                                                                   DTSBX500
00956  S910-OPEN-UPDATE-NO-AIX.                                         DTSBX500
00957      SET L910-OPEN-UPDATE-NO-AIX-88 TO TRUE.                      DTSBX500
00958      GO TO S910-MSTR-IO.                                          DTSBX500
00959                                                                   DTSBX500
00960  S910-READ.                                                       DTSBX500
00961      SET L910-READ-88 TO TRUE.                                    DTSBX500
00962      GO TO S910-MSTR-IO.                                          DTSBX500
00963                                                                   DTSBX500
00964  S910-START-BROWSE.                                               DTSBX500
00965      SET L910-START-BROWSE-88 TO TRUE.                            DTSBX500
00966      GO TO S910-MSTR-IO.                                          DTSBX500
00967                                                                   DTSBX500
00968  S910-READ-NEXT.                                                  DTSBX500
00969      SET L910-READ-NEXT-88 TO TRUE.                               DTSBX500
00970      GO TO S910-MSTR-IO.                                          DTSBX500
00971                                                                   DTSBX500
00972  S910-COUNT.                                                      DTSBX500
00973      SET L910-COUNT-88 TO TRUE.                                   DTSBX500
00974      GO TO S910-MSTR-IO.                                          DTSBX500
00975                                                                   DTSBX500
00976  S910-WRITE.                                                      DTSBX500
00977      SET L910-WRITE-88 TO TRUE.                                   DTSBX500
00978      GO TO S910-MSTR-IO.                                          DTSBX500
00979                                                                   DTSBX500
00980  S910-REWRITE.                                                    DTSBX500
00981      SET L910-REWRITE-88 TO TRUE.                                 DTSBX500
00982      GO TO S910-MSTR-IO.                                          DTSBX500
00983                                                                   DTSBX500
00984  S910-CLOSE.                                                      DTSBX500
00985      SET L910-CLOSE-88     TO TRUE.                               DTSBX500
00986      GO TO S910-MSTR-IO.                                          DTSBX500
00987                                                                   DTSBX500
00988  S910-MSTR-IO.                                                    DTSBX500
00989      CALL 'DTSBU910' USING L910-LINK-AREA                         DTSBX500
00990                            MSKL-REC.                              DTSBX500
00991  S910-EXIT.                                                       DTSBX500
00992      EXIT.                                                        DTSBX500
00993                                                                   DTSBX500
00994  S921-OPEN-READ.                                                  DTSBX500
00995      SET L921-OPEN-READ-88 TO TRUE.                               DTSBX500
00996      GO TO S921-AIX-IO.                                           DTSBX500
00997                                                                   DTSBX500
00998  S921-OPEN-UPDATE.                                                DTSBX500
00999      SET L921-OPEN-UPDATE-88 TO TRUE.                             DTSBX500
01000      GO TO S921-AIX-IO.                                           DTSBX500
01001                                                                   DTSBX500
01002  S921-READ.                                                       DTSBX500
01003      SET L921-READ-88 TO TRUE.                                    DTSBX500
01004      GO TO S921-AIX-IO.                                           DTSBX500
01005                                                                   DTSBX500
01006  S921-START-BROWSE.                                               DTSBX500
01007      SET L921-START-BROWSE-88 TO TRUE.                            DTSBX500
01008      GO TO S921-AIX-IO.                                           DTSBX500
01009                                                                   DTSBX500
01010  S921-READ-NEXT.                                                  DTSBX500
01011      SET L921-READ-NEXT-88 TO TRUE.                               DTSBX500
01012      GO TO S921-AIX-IO.                                           DTSBX500
01013                                                                   DTSBX500
01014  S921-CLOSE.                                                      DTSBX500
01015      SET L921-CLOSE-88 TO TRUE.                                   DTSBX500
01016      GO TO S921-AIX-IO.                                           DTSBX500
01017                                                                   DTSBX500
01018  S921-AIX-IO.                                                     DTSBX500
01019      CALL 'DTSBU921' USING L921-LINK-AREA                         DTSBX500
01020                            ISKL-REC.                              DTSBX500
01021  S921-EXIT.                                                       DTSBX500
01022      EXIT.                                                        DTSBX500
01023 **                                                                DTSBX500
01024  S981A-OPEN-READ.                                                 DTSBX500
01025      SET L981-OPEN-READ-88 TO TRUE.                               DTSBX500
01026      PERFORM S981Z-WAGE-I  THRU S981Z-EXIT.                       DTSBX500
01027                                                                   DTSBX500
01028  S981A-EXIT.                                                      DTSBX500
01029      EXIT.                                                        DTSBX500
01030                                                                   DTSBX500
01031  S981C-CLOSE.                                                     DTSBX500
01032      SET L981-CLOSE-88 TO TRUE.                                   DTSBX500
01033      PERFORM S981Z-WAGE-I  THRU S981Z-EXIT.                       DTSBX500
01034                                                                   DTSBX500
01035  S981C-EXIT.                                                      DTSBX500
01036      EXIT.                                                        DTSBX500
01037                                                                   DTSBX500
01038  S981D-START-BROWSE.                                              DTSBX500
01039      SET L981-START-BROWSE-88 TO TRUE.                            DTSBX500
01040      PERFORM S981Z-WAGE-I  THRU S981Z-EXIT.                       DTSBX500
01041                                                                   DTSBX500
01042  S981D-EXIT.                                                      DTSBX500
01043      EXIT.                                                        DTSBX500
01044                                                                   DTSBX500
01045  S981E-READ-NEXT.                                                 DTSBX500
01046      SET L981-READ-NEXT-88 TO TRUE.                               DTSBX500
01047      PERFORM S981Z-WAGE-I  THRU S981Z-EXIT.                       DTSBX500
01048                                                                   DTSBX500
01049  S981E-EXIT.                                                      DTSBX500
01050      EXIT.                                                        DTSBX500
01051                                                                   DTSBX500
01052  S981Z-WAGE-I.                                                    DTSBX500
01053      CALL 'DTSBU981' USING L981-LINK-AREA                         DTSBX500
01054                            WWGH-REC.                              DTSBX500
01055  S981Z-EXIT.                                                      DTSBX500
01056      EXIT.                                                        DTSBX500
01057 **                                                                DTSBX500
01058                                                                   DTSBX500
01059  S982A-START-BROWSE.                                              DTSBX500
01060      SET L982-START-BROWSE-88 TO TRUE.                            DTSBX500
01061      PERFORM S982Z-WNAM-IO    THRU S982Z-EXIT.                    DTSBX500
01062                                                                   DTSBX500
01063  S982A-EXIT.                                                      DTSBX500
01064      EXIT.                                                        DTSBX500
01065                                                                   DTSBX500
01066  S982B-READ-NEXT.                                                 DTSBX500
01067      SET L982-READ-NEXT-88    TO TRUE.                            DTSBX500
01068      PERFORM S982Z-WNAM-IO    THRU S982Z-EXIT.                    DTSBX500
01069                                                                   DTSBX500
01070  S982B-EXIT.                                                      DTSBX500
01071      EXIT.                                                        DTSBX500
01072                                                                   DTSBX500
01073  S982C-WRITE.                                                     DTSBX500
01074      SET L982-WRITE-88        TO TRUE.                            DTSBX500
01075      PERFORM S982Z-WNAM-IO    THRU S982Z-EXIT.                    DTSBX500
01076                                                                   DTSBX500
01077  S982C-EXIT.                                                      DTSBX500
01078      EXIT.                                                        DTSBX500
01079                                                                   DTSBX500
01080  S982D-REWRITE.                                                   DTSBX500
01081      SET L982-REWRITE-88        TO TRUE.                          DTSBX500
01082      PERFORM S982Z-WNAM-IO    THRU S982Z-EXIT.                    DTSBX500
01083                                                                   DTSBX500
01084  S982D-EXIT.                                                      DTSBX500
01085      EXIT.                                                        DTSBX500
01086                                                                   DTSBX500
01087  S982E-OPEN-READ.                                                 DTSBX500
01088      SET L982-OPEN-READ-88 TO TRUE.                               DTSBX500
01089      PERFORM S982Z-WNAM-IO THRU S982Z-EXIT.                       DTSBX500
01090                                                                   DTSBX500
01091  S982E-EXIT.                                                      DTSBX500
01092      EXIT.                                                        DTSBX500
01093                                                                   DTSBX500
01094  S982F-CLOSE.                                                     DTSBX500
01095      SET L982-CLOSE-88        TO TRUE.                            DTSBX500
01096      PERFORM S982Z-WNAM-IO    THRU S982Z-EXIT.                    DTSBX500
01097                                                                   DTSBX500
01098  S982F-EXIT.                                                      DTSBX500
01099      EXIT.                                                        DTSBX500
01100                                                                   DTSBX500
01101  S982Z-WNAM-IO.                                                   DTSBX500
01102      CALL 'DTSBU982' USING L982-LINK-AREA                         DTSBX500
01103                            WNAM-REC.                              DTSBX500
01104  S982Z-EXIT.                                                      DTSBX500
01105      EXIT.                                                        DTSBX500
01106 **                                                                DTSBX500
01107                                                                   DTSBX500
01108  S999-ABEND.                                                      DTSBX500
01109                                                                   DTSBX500
01110      DISPLAY '****  DTSBZ500 ABENDING '                           DTSBX500
01111         WRK-ABEND-MSG.                                            DTSBX500
01112      CALL 'DTSBU999' USING WRK-ABEND-CD.                          DTSBX500
01113                                                                   DTSBX500
01114  S999-EXIT.                                                       DTSBX500
01115      EXIT.                                                        DTSBX500
01116                                                                   DTSBX500
