00001  IDENTIFICATION DIVISION.                                         08/28/02
00002  PROGRAM-ID.             DESBD800.                                DESBD800
00003  AUTHOR.                 MT DEPT OF LABOR/UI PROGRAMMING SECTION     LV003
00004  DATE-WRITTEN.           JULY 1994.                               DESBD800
00005  DATE-COMPILED.                                                   DESBD800
00006                                                                   DESBD800
00007 *****                                                             DESBD800
00008 *                                                                 DESBD800
00009 *    FUNCTION:  REPORT DRIVER MODULE.                             DESBD800
00010 *                                                                 DESBD800
00011 *                                                                 DESBD800
00012 *    MODIFICATION HISTORY:                                        DESBD800
00013 *                                                                 DESBD800
00014 * 03/07/2000  ENLARGE TO HANDLE DTSBR980.                         DESBD800
00015 *             REFERENCE: NEEDED FOR OPS BY CLIENT         : JHP   DESBD800
00016 *                                                                 DESBD800
00017 * 07-18-94 INITIAL DEVELOPMENT                                    DESBD800
00018 *          REFERENCE RFP #RAP             AUTHOR OF CHANGE - SFW  DESBD800
00019 *                                                                 DESBD800
00020 * 11-05-97 MODIFY LITERAL PLACED IN LRCM-AGY-NAME-LINE2 TO        DESBD800
00021 *          REFLECT MOVE OF UI TAX SYSTEM FROM DLI TO DOR.         DESBD800
00022 *          REFERENCE RFP #TCL 208         AUTHOR OF CHANGE - EHH  DESBD800
00023 *                                                                 DESBD800
00024 * 10/06/1998  REVIEWED AND MODIFIED FOR DC.                       DESBD800
00025 *             REFERENCE: DC DEVELOPMENT         PROGRAMMER: EHH   DESBD800
00026 *                                                                 DESBD800
00027 * 07/14/1999  INITIALIZE LRCM-PICKUP-DIR.                         DESBD800
00028 *             REFERENCE: PICKUP DIR             PROGRAMMER: DVS   DESBD800
00029 *                                                                 DESBD800
00030 * 03/20/2001  CLONED FROM DTSBD800 FOR ELECTRONIC MEDIA SYSTEM.   DESBD800
00031 *             REFERENCE:                        PROGRAMMER: GD    DESBD800
00032 *                                                                 DESBD800
00033 * MM/DD/YYYY  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DESBD800
00034 *             XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DESBD800
00035 *             REFERENCE: XXXXXXXXXXXXXXX        PROGRAMMER: XXX   DESBD800
00036 *                                                                 DESBD800
00037 *                                                                 DESBD800
00038 *  DESCRIPTION:                                                   DESBD800
00039 *                                                                 DESBD800
00040 *      THE FUNCTION OF DESBD800 IS TO READ THE SORTED INCOMING    DESBD800
00041 *      REPORT RECORD FILE AND CALL THE APPROPRIATE MODULE TO      DESBD800
00042 *      PROCESS EACH REPORT RECORD. THE RECORD TYPE IS APPENDED    DESBD800
00043 *      TO THE CONSTANT 'DESBR' TO FORM THE LOAD MODULE NAME       DESBD800
00044 *      ASSOCIATED WITH THE RECORD.                                DESBD800
00045 *                                                                 DESBD800
00046 *      TWO TYPES OF PARAMETER FILES ARE INPUT:                    DESBD800
00047 *                                                                 DESBD800
00048 *   -  ONE PARAMETER FILE (CALLED PARM-FILE) SPECIFIES WHICH OF   DESBD800
00049 *      THE INCOMING REPORT RECORD TYPES ARE TO BE PROCESSED, THIS DESBD800
00050 *      IS DONE BY EITHER SPECIFYING:                              DESBD800
00051 *         A: REPORT RECORD TYPES TO BE INCLUDED (PROCESSED)       DESBD800
00052 *                    OR                                           DESBD800
00053 *         B: REPORT RECORD TYPES TO BE EXCLUDED (NOT PROCESSED).  DESBD800
00054 *                                                                 DESBD800
00055 *   -  THE OTHER PARAMETER FILE (CALLED ATLEAST-ONCE-FILE)        DESBD800
00056 *      SPECIFIES THE REPORT RECORD TYPES CORRESPONDING TO ALL     DESBD800
00057 *      REPORT MODULES WHICH MUST BE EXECUTED AT LEAST ONCE.       DESBD800
00058 *                                                                 DESBD800
00059 *                                                                 DESBD800
00060 *   -  THE TABLE INTRODUCED FOR DTSBR980 IS 999 ENTRIES LONG      DESBD800
00061 *      TO HANDLE EVERY POSSIBLE REPORT PROGRAM                    DESBD800
00062 *      (DTSBR001 TO DTSBR999).                                    DESBD800
00063 *                                                                 DESBD800
00064 *                                                                 DESBD800
00065 *    MODULES CALLED:                                              DESBD800
00066 *                                                                 DESBD800
00067 *        DTSBR980  REPORT CONTROL LIST                            DESBD800
00068 *        DTSBU001  DATE MODULE                                    DESBD800
00069 *        DTSBU119  AGENCY FACTS MODULE                            DESBD800
00070 *        DTSBU931  REFERENCE FILE I-O MODULE                      DESBD800
00071 *        DTSBU941  REPORT FILE SEQUENTIAL INPUT MODULE            DESBD800
00072 *        DTSBU999  ABEND MODULE                                   DESBD800
00073 *                                                                 DESBD800
00074 *****                                                             DESBD800
00075      EJECT                                                        DESBD800
00076  ENVIRONMENT DIVISION.                                            DESBD800
00077                                                                   DESBD800
00078  INPUT-OUTPUT SECTION.                                            DESBD800
00079                                                                   DESBD800
00080  FILE-CONTROL.                                                    DESBD800
00081      SELECT PARM-FILE ASSIGN TO PARMIN.                           DESBD800
00082      SELECT ATLEAST-ONCE-FILE ASSIGN TO ATLSTIN.                  DESBD800
00083                                                                   DESBD800
00084  DATA DIVISION.                                                   DESBD800
00085                                                                   DESBD800
00086  FILE SECTION.                                                    DESBD800
00087                                                                   DESBD800
00088  FD  PARM-FILE                                                    DESBD800
00089      LABEL RECORDS ARE STANDARD.                                  DESBD800
00090                                                                   DESBD800
00091  01  PARM-REC.                                                    DESBD800
00092      05  PARM-MOD-NAME               PIC  X(08).                  DESBD800
00093      05  FILLER                      PIC  X(01).                  DESBD800
00094      05  PARM-CONTROL-TYPE           PIC  X(03).                  DESBD800
00095      05  PARM-RPT-TYPE-AREA OCCURS 15 TIMES                       DESBD800
00096                             INDEXED BY PARM-RPT-IDX.              DESBD800
00097          10  FILLER                  PIC  X(01).                  DESBD800
00098          10  PARM-RPT-TYPE           PIC  X(03).                  DESBD800
00099      05  FILLER                      PIC  X(08).                  DESBD800
00100                                                                   DESBD800
00101                                                                   DESBD800
00102                                                                   DESBD800
00103  FD  ATLEAST-ONCE-FILE                                            DESBD800
00104      LABEL RECORDS ARE STANDARD.                                  DESBD800
00105                                                                   DESBD800
00106  01  ATLEAST-ONCE-REC.                                            DESBD800
00107      05  ATLEAST-ONCE-MOD-NAME       PIC  X(08).                  DESBD800
00108      05  ATLEAST-ONCE-RPT-TYPE-AREA OCCURS 15 TIMES               DESBD800
00109                             INDEXED BY ATLEAST-ONCE-RPT-IDX.      DESBD800
00110          10  FILLER                  PIC  X(01).                  DESBD800
00111          10  ATLEAST-ONCE-RPT-TYPE   PIC  X(03).                  DESBD800
00112      05  FILLER                      PIC  X(12).                  DESBD800
00113      EJECT                                                        DESBD800
00114  WORKING-STORAGE SECTION.                                         DESBD800
001145 77  PAN-VALET PICTURE X(24) VALUE '003DESBD800  08/28/02'.       DESBD800
00115                                                                   DESBD800
00116  01  WRK-AREA.                                                    DESBD800
00117      05  WRK-ABEND-CD                PIC S9(04)  COMP  VALUE +800.DESBD800
00118                                                                   DESBD800
00119      05  ABEND-MSG                   PIC  X(50).                  DESBD800
00120                                                                   DESBD800
00121      05  INCLUDE-REC-CNT             PIC S9(07)  COMP-3.          DESBD800
00122                                                                   DESBD800
00123      05  EXCLUDE-REC-CNT             PIC S9(07)  COMP-3.          DESBD800
00124                                                                   DESBD800
00125      05  PARM-REC-CNT                PIC S9(04)  COMP.            DESBD800
00126                                                                   DESBD800
00127      05  PARM-EOF-IND                PIC  X(01).                  DESBD800
00128                                                                   DESBD800
00129      05  ATLEAST-ONCE-REC-CNT        PIC S9(04)  COMP.            DESBD800
00130                                                                   DESBD800
00131      05  ATLEAST-ONCE-EOF-IND        PIC  X(01).                  DESBD800
00132                                                                   DESBD800
00133      05  NDX-1                       PIC S9(04)  COMP.            DESBD800
00134                                                                   DESBD800
00135      05  SYS-TIME.                                                DESBD800
00136          10  SYS-H                   PIC  X(02).                  DESBD800
00137          10  SYS-M                   PIC  X(02).                  DESBD800
00138          10  SYS-S                   PIC  X(02).                  DESBD800
00139          10  FILLER                  PIC  X(02).                  DESBD800
00140                                                                   DESBD800
00141      05  DISP-TIME.                                               DESBD800
00142          10  DISP-H                  PIC  X(02).                  DESBD800
00143          10  FILLER                  PIC  X(01)  VALUE '.'.       DESBD800
00144          10  DISP-M                  PIC  X(02).                  DESBD800
00145          10  FILLER                  PIC  X(01)  VALUE '.'.       DESBD800
00146          10  DISP-S                  PIC  X(02).                  DESBD800
00147      EJECT                                                        DESBD800
00148      05  WRK-CONTROL-CNT             PIC S9(04)  COMP.            DESBD800
00149                                                                   DESBD800
00150      05  WRK-CONTROL-TYPE            PIC  X(03).                  DESBD800
00151          88  WRK-INCLUDE-88                      VALUE 'INC'.     DESBD800
00152          88  WRK-EXCLUDE-88                      VALUE 'EXC'.     DESBD800
00153                                                                   DESBD800
00154      05  WRK-CONTROL-REC-TYPE OCCURS 15 TIMES                     DESBD800
00155                           INDEXED BY WRK-CONTROL-REC-IDX          DESBD800
00156                                      PIC  X(03).                  DESBD800
00157                                                                   DESBD800
00158                                                                   DESBD800
00159                                                                   DESBD800
00160      05  WRK-SELECT-IND              PIC  X(01).                  DESBD800
00161                                                                   DESBD800
00162                                                                   DESBD800
00163                                                                   DESBD800
00164      05  WRK-ATLEAST-ONCE-CNT        PIC S9(04)  COMP.            DESBD800
00165                                                                   DESBD800
00166      05  WRK-ATLEAST-ONCE-OCCURS OCCURS 15 TIMES                  DESBD800
00167                           INDEXED BY WRK-ATLEAST-ONCE-IDX.        DESBD800
00168          10  WRK-ATLEAST-ONCE-REC-TYPE                            DESBD800
00169                                      PIC  X(03).                  DESBD800
00170          10  WRK-ATLEAST-ONCE-CALLED-IND                          DESBD800
00171                                      PIC  X(01).                  DESBD800
00172              88  WRK-ATLEAST-ONCE-CALLED-88      VALUE 'Y'.       DESBD800
00173                                                                   DESBD800
00174                                                                   DESBD800
00175                                                                   DESBD800
00176      05  HOLD-REC-TYPE               PIC  X(03)  VALUE ZEROES.    DESBD800
00177      05  HOLD-REC-TYPE-9   REDEFINES   HOLD-REC-TYPE              DESBD800
00178                                      PIC  9(03).                  DESBD800
00179                                                                   DESBD800
00180      05  HOLD-REC-CNT                PIC S9(07)  COMP-3.          DESBD800
00181                                                                   DESBD800
00182      05  PRINT-MODULE.                                            DESBD800
00183          10  FILLER                  PIC  X(05)  VALUE 'DESBR'.   DESBD800
00184          10  PRINT-TYPE              PIC  X(03)  VALUE SPACES.    DESBD800
00185      EJECT                                                        DESBD800
00186  01  L001-LINK-AREA.                                              DESBD800
00187  ++INCLUDE DTSIL001                                               DESBD800
00188      EJECT                                                        DESBD800
00189  01  L119-LINK-AREA.                                              DESBD800
00190  ++INCLUDE DTSIL119                                               DESBD800
00191      EJECT                                                        DESBD800
00192  01  L931-LINK-AREA.                                              DESBD800
00193  ++INCLUDE DTSIL931                                               DESBD800
00194      EJECT                                                        DESBD800
00195  01  L941-LINK-AREA.                                              DESBD800
00196  ++INCLUDE DTSIL941                                               DESBD800
00197      EJECT                                                        DESBD800
00198  01  L980-LINK-AREA.                                              DESBD800
00199  ++INCLUDE DTSIL980                                               DESBD800
00200      EJECT                                                        DESBD800
00201  01  RSK3-REC.                                                    DESBD800
00202  ++INCLUDE DTSIRSK3                                               DESBD800
00203      EJECT                                                        DESBD800
00204  01  LRCM-LINK-AREA.                                              DESBD800
00205  ++INCLUDE DTSILRCM                                               DESBD800
00206      EJECT                                                        DESBD800
00207  01  FSKL-REC.                                                    DESBD800
00208  ++INCLUDE DTSIFSKL                                               DESBD800
00209      EJECT                                                        DESBD800
00210  PROCEDURE DIVISION.                                              DESBD800
00211                                                                   DESBD800
00212      PERFORM I0000-INITIATE THRU I0000-EXIT.                      DESBD800
00213                                                                   DESBD800
00214      PERFORM P0000-PROCESS THRU P0000-EXIT.                       DESBD800
00215                                                                   DESBD800
00216      PERFORM T0000-TERMINATE THRU T0000-EXIT.                     DESBD800
00217                                                                   DESBD800
00218      GOBACK.                                                      DESBD800
00219      EJECT                                                        DESBD800
00220  I0000-INITIATE.                                                  DESBD800
00221      PERFORM I1000-OPEN-FILES THRU I1000-EXIT.                    DESBD800
00222                                                                   DESBD800
00223      PERFORM I2000-PARM THRU I2000-EXIT.                          DESBD800
00224                                                                   DESBD800
00225      PERFORM I3000-ATLEAST-ONCE THRU I3000-EXIT.                  DESBD800
00226                                                                   DESBD800
00227      PERFORM I4000-INIT-LRCM THRU I4000-EXIT.                     DESBD800
00228  I0000-EXIT.                                                      DESBD800
00229      EXIT.                                                        DESBD800
00230                                                                   DESBD800
00231                                                                   DESBD800
00232                                                                   DESBD800
00233  I1000-OPEN-FILES.                                                DESBD800
00234      SET L931-OPEN-READ-88 TO TRUE.                               DESBD800
00235                                                                   DESBD800
00236      PERFORM S931-REF-IO THRU S931-EXIT.                          DESBD800
00237                                                                   DESBD800
00238      SET L941-OPEN-READ-88 TO TRUE.                               DESBD800
00239                                                                   DESBD800
00240      PERFORM S941-RPT-I THRU S941-EXIT.                           DESBD800
00241  I1000-EXIT.                                                      DESBD800
00242      EXIT.                                                        DESBD800
00243                                                                   DESBD800
00244                                                                   DESBD800
00245                                                                   DESBD800
00246  I2000-PARM.                                                      DESBD800
00247      OPEN INPUT PARM-FILE.                                        DESBD800
00248                                                                   DESBD800
00249      MOVE 'N' TO PARM-EOF-IND.                                    DESBD800
00250                                                                   DESBD800
00251      MOVE +0 TO PARM-REC-CNT.                                     DESBD800
00252                                                                   DESBD800
00253      DISPLAY ' '.                                                 DESBD800
00254                                                                   DESBD800
00255      DISPLAY '*** DESBD800 PARAMETERS'.                           DESBD800
00256                                                                   DESBD800
00257      PERFORM I2100-READ-PARM THRU I2100-EXIT                      DESBD800
00258         UNTIL PARM-EOF-IND = 'Y'.                                 DESBD800
00259                                                                   DESBD800
00260      IF PARM-REC-CNT = +0                                         DESBD800
00261          SET WRK-EXCLUDE-88 TO TRUE                               DESBD800
00262          MOVE +0 TO WRK-CONTROL-CNT                               DESBD800
00263          DISPLAY '            (NONE)'                             DESBD800
00264      ELSE                                                         DESBD800
00265      IF PARM-REC-CNT > +1                                         DESBD800
00266          MOVE 'NO MORE THAN ONE PARM RECORD ALLOWED'              DESBD800
00267             TO ABEND-MSG                                          DESBD800
00268          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00269                                                                   DESBD800
00270      DISPLAY ' '.                                                 DESBD800
00271                                                                   DESBD800
00272      CLOSE PARM-FILE.                                             DESBD800
00273  I2000-EXIT.                                                      DESBD800
00274      EXIT.                                                        DESBD800
00275                                                                   DESBD800
00276                                                                   DESBD800
00277                                                                   DESBD800
00278  I2100-READ-PARM.                                                 DESBD800
00279      READ PARM-FILE                                               DESBD800
00280         AT END                                                    DESBD800
00281             MOVE 'Y' TO PARM-EOF-IND                              DESBD800
00282             GO TO I2100-EXIT.                                     DESBD800
00283                                                                   DESBD800
00284      DISPLAY '*** ' PARM-REC.                                     DESBD800
00285                                                                   DESBD800
00286      ADD +1 TO PARM-REC-CNT.                                      DESBD800
00287                                                                   DESBD800
00288      IF PARM-MOD-NAME NOT = 'DESBD800'                            DESBD800
00289          MOVE 'INVALID PARM MODULE NAME' TO ABEND-MSG             DESBD800
00290          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00291                                                                   DESBD800
00292      MOVE PARM-CONTROL-TYPE TO WRK-CONTROL-TYPE.                  DESBD800
00293                                                                   DESBD800
00294      IF WRK-INCLUDE-88 OR WRK-EXCLUDE-88                          DESBD800
00295          NEXT SENTENCE                                            DESBD800
00296      ELSE                                                         DESBD800
00297          MOVE 'INVALID PARM CONTROL TYPE' TO ABEND-MSG            DESBD800
00298          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00299                                                                   DESBD800
00300      MOVE +0 TO WRK-CONTROL-CNT.                                  DESBD800
00301                                                                   DESBD800
00302      PERFORM I2110-RPT-TYPE-LOOP THRU I2110-EXIT                  DESBD800
00303         VARYING PARM-RPT-IDX FROM 1 BY 1                          DESBD800
00304         UNTIL PARM-RPT-IDX > 15.                                  DESBD800
00305                                                                   DESBD800
00306      IF (WRK-INCLUDE-88) AND (WRK-CONTROL-CNT = +0)               DESBD800
00307          MOVE 'AT LEAST ONE PARM REC TYPE REQUIRED FOR INCLUDING' DESBD800
00308             TO ABEND-MSG                                          DESBD800
00309          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00310  I2100-EXIT.                                                      DESBD800
00311      EXIT.                                                        DESBD800
00312                                                                   DESBD800
00313                                                                   DESBD800
00314                                                                   DESBD800
00315  I2110-RPT-TYPE-LOOP.                                             DESBD800
00316      IF PARM-RPT-TYPE (PARM-RPT-IDX) = SPACES                     DESBD800
00317          NEXT SENTENCE                                            DESBD800
00318      ELSE                                                         DESBD800
00319          ADD +1 TO WRK-CONTROL-CNT                                DESBD800
00320          MOVE PARM-RPT-TYPE (PARM-RPT-IDX)                        DESBD800
00321             TO WRK-CONTROL-REC-TYPE (WRK-CONTROL-CNT).            DESBD800
00322  I2110-EXIT.                                                      DESBD800
00323      EXIT.                                                        DESBD800
00324      EJECT                                                        DESBD800
00325  I3000-ATLEAST-ONCE.                                              DESBD800
00326      OPEN INPUT ATLEAST-ONCE-FILE.                                DESBD800
00327                                                                   DESBD800
00328      MOVE 'N' TO ATLEAST-ONCE-EOF-IND.                            DESBD800
00329                                                                   DESBD800
00330      MOVE +0 TO ATLEAST-ONCE-REC-CNT.                             DESBD800
00331                                                                   DESBD800
00332      DISPLAY ' '.                                                 DESBD800
00333                                                                   DESBD800
00334      DISPLAY '*** DESBD800 AT LEAST ONCE PARAMETERS'.             DESBD800
00335                                                                   DESBD800
00336      PERFORM I3100-READ-ATLEAST-ONCE-FILE THRU I3100-EXIT         DESBD800
00337         UNTIL ATLEAST-ONCE-EOF-IND = 'Y'.                         DESBD800
00338                                                                   DESBD800
00339      IF ATLEAST-ONCE-REC-CNT = +0                                 DESBD800
00340          MOVE +0 TO WRK-ATLEAST-ONCE-CNT                          DESBD800
00341          DISPLAY '            (NONE)'                             DESBD800
00342      ELSE                                                         DESBD800
00343      IF ATLEAST-ONCE-REC-CNT > +1                                 DESBD800
00344          MOVE 'NO MORE THAN ONE AT LEAST ONCE RECORD ALLOWED'     DESBD800
00345             TO ABEND-MSG                                          DESBD800
00346          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00347                                                                   DESBD800
00348      DISPLAY ' '.                                                 DESBD800
00349                                                                   DESBD800
00350      CLOSE ATLEAST-ONCE-FILE.                                     DESBD800
00351  I3000-EXIT.                                                      DESBD800
00352      EXIT.                                                        DESBD800
00353                                                                   DESBD800
00354                                                                   DESBD800
00355                                                                   DESBD800
00356  I3100-READ-ATLEAST-ONCE-FILE.                                    DESBD800
00357      READ ATLEAST-ONCE-FILE                                       DESBD800
00358         AT END                                                    DESBD800
00359             MOVE 'Y' TO ATLEAST-ONCE-EOF-IND                      DESBD800
00360             GO TO I3100-EXIT.                                     DESBD800
00361                                                                   DESBD800
00362      DISPLAY '*** ' ATLEAST-ONCE-REC.                             DESBD800
00363                                                                   DESBD800
00364      ADD +1 TO ATLEAST-ONCE-REC-CNT.                              DESBD800
00365                                                                   DESBD800
00366      IF ATLEAST-ONCE-MOD-NAME NOT = 'DESBD800'                    DESBD800
00367          MOVE 'INVALID AT LEAST ONCE MODULE NAME' TO ABEND-MSG    DESBD800
00368          PERFORM S999-ABEND THRU S999-EXIT.                       DESBD800
00369                                                                   DESBD800
00370      MOVE +0 TO WRK-ATLEAST-ONCE-CNT.                             DESBD800
00371                                                                   DESBD800
00372      PERFORM I3110-RPT-TYPE-LOOP                                  DESBD800
00373         THRU I3110-EXIT                                           DESBD800
00374           VARYING ATLEAST-ONCE-RPT-IDX FROM 1 BY 1                DESBD800
00375             UNTIL ATLEAST-ONCE-RPT-IDX > 15.                      DESBD800
00376  I3100-EXIT.                                                      DESBD800
00377      EXIT.                                                        DESBD800
00378                                                                   DESBD800
00379                                                                   DESBD800
00380                                                                   DESBD800
00381  I3110-RPT-TYPE-LOOP.                                             DESBD800
00382      IF ATLEAST-ONCE-RPT-TYPE (ATLEAST-ONCE-RPT-IDX) NOT = SPACES DESBD800
00383          ADD +1 TO WRK-ATLEAST-ONCE-CNT                           DESBD800
00384          MOVE ATLEAST-ONCE-RPT-TYPE (ATLEAST-ONCE-RPT-IDX)        DESBD800
00385            TO WRK-ATLEAST-ONCE-REC-TYPE (WRK-ATLEAST-ONCE-CNT)    DESBD800
00386          MOVE 'N'                                                 DESBD800
00387            TO WRK-ATLEAST-ONCE-CALLED-IND (WRK-ATLEAST-ONCE-CNT). DESBD800
00388  I3110-EXIT.                                                      DESBD800
00389      EXIT.                                                        DESBD800
00390      EJECT                                                        DESBD800
00391  I4000-INIT-LRCM.                                                 DESBD800
00392      MOVE SPACES TO LRCM-LINK-AREA.                               DESBD800
00393                                                                   DESBD800
00394      PERFORM I4010-INIT-L980 THRU I4010-EXIT                      DESBD800
00395          VARYING NDX-1 FROM 1 BY 1                                DESBD800
00396              UNTIL NDX-1 > 999.                                   DESBD800
00397                                                                   DESBD800
00398      SET L001-FROM-FED-6 TO TRUE.                                 DESBD800
00399                                                                   DESBD800
00400      ACCEPT L001-FED-6-DATE-9 FROM DATE.                          DESBD800
00401                                                                   DESBD800
00402      PERFORM S001-CONVERT-DATE THRU S001-EXIT.                    DESBD800
00403                                                                   DESBD800
00404      MOVE L001-SLASH-DATE TO LRCM-SYS-DATE.                       DESBD800
00405                                                                   DESBD800
00406      MOVE L001-SLASH-8-DATE TO LRCM-SYS-8-DATE.                   DESBD800
00407                                                                   DESBD800
00408                                                                   DESBD800
00409      SET L119-REQ-MIXED-88 TO TRUE.                               DESBD800
00410                                                                   DESBD800
00411      SET L119-REQ-NO-UNIT-88 TO TRUE.                             DESBD800
00412                                                                   DESBD800
00413      PERFORM S119-AGENCY-FACTS THRU S119-EXIT.                    DESBD800
00414                                                                   DESBD800
00415      MOVE L119-UC-OFFICE-NAME TO LRCM-DEFAULT-NAME.               DESBD800
00416                                                                   DESBD800
00417      MOVE L119-UC-OFFICE-VOICE TO LRCM-DEFAULT-VOICE.             DESBD800
00418                                                                   DESBD800
00419                                                                   DESBD800
00420      ACCEPT SYS-TIME FROM TIME.                                   DESBD800
00421                                                                   DESBD800
00422      MOVE SYS-H TO DISP-H.                                        DESBD800
00423                                                                   DESBD800
00424      MOVE SYS-M TO DISP-M.                                        DESBD800
00425                                                                   DESBD800
00426      MOVE SYS-S TO DISP-S.                                        DESBD800
00427                                                                   DESBD800
00428      MOVE DISP-TIME TO LRCM-SYS-TIME.                             DESBD800
00429                                                                   DESBD800
00430      MOVE +19924 TO LRCM-PICKUP-YRQ.                              DESBD800
00431                                                                   DESBD800
00432                                                                   DESBD800
00433      MOVE '               DISTRICT OF COLUMBIA               '    DESBD800
00434         TO LRCM-AGY-NAME-LINE1.                                   DESBD800
00435                                                                   DESBD800
00436      MOVE '                   TAX DIVISION                   '    DESBD800
00437         TO LRCM-AGY-NAME-LINE2.                                   DESBD800
00438  I4000-EXIT.                                                      DESBD800
00439      EXIT.                                                        DESBD800
00440  I4010-INIT-L980.                                                 DESBD800
00441      MOVE ZERO TO L980-REC-CNT (NDX-1).                           DESBD800
00442  I4010-EXIT.                                                      DESBD800
00443      EXIT.                                                        DESBD800
00444      EJECT                                                        DESBD800
00445  P0000-PROCESS.                                                   DESBD800
00446      MOVE +0 TO INCLUDE-REC-CNT                                   DESBD800
00447                 EXCLUDE-REC-CNT.                                  DESBD800
00448                                                                   DESBD800
00449      DISPLAY ' '.                                                 DESBD800
00450                                                                   DESBD800
00451      DISPLAY '*** DESBD800 STATISTICS'.                           DESBD800
00452                                                                   DESBD800
00453      SET L941-READ-NEXT-88 TO TRUE.                               DESBD800
00454                                                                   DESBD800
00455      PERFORM S941-RPT-I THRU S941-EXIT.                           DESBD800
00456                                                                   DESBD800
00457      IF L941-NO-REC-88                                            DESBD800
00458          GO TO P0000-EXIT.                                        DESBD800
00459                                                                   DESBD800
00460                                                                   DESBD800
00461      PERFORM P1000-PROCESS-RETURN THRU P1000-EXIT                 DESBD800
00462         UNTIL L941-NO-REC-88.                                     DESBD800
00463                                                                   DESBD800
00464                                                                   DESBD800
00465      IF WRK-SELECT-IND = 'I'                                      DESBD800
00466          PERFORM P1500-TERM-REC-TYPE THRU P1500-EXIT.             DESBD800
00467  P0000-EXIT.                                                      DESBD800
00468      EXIT.                                                        DESBD800
00469                                                                   DESBD800
00470                                                                   DESBD800
00471                                                                   DESBD800
00472  P1000-PROCESS-RETURN.                                            DESBD800
00473      IF RSK3-REC-TYPE NOT = HOLD-REC-TYPE                         DESBD800
00474          IF HOLD-REC-TYPE = SPACES                                DESBD800
00475              PERFORM P1100-INIT-REC-TYPE THRU P1100-EXIT          DESBD800
00476          ELSE                                                     DESBD800
00477              IF WRK-SELECT-IND = 'I'                              DESBD800
00478                  PERFORM P1500-TERM-REC-TYPE THRU P1500-EXIT      DESBD800
00479              ELSE                                                 DESBD800
00480                  CONTINUE                                         DESBD800
00481              END-IF                                               DESBD800
00482              PERFORM P1100-INIT-REC-TYPE THRU P1100-EXIT.         DESBD800
00483                                                                   DESBD800
00484      IF WRK-SELECT-IND = 'I'                                      DESBD800
00485          ADD +1 TO INCLUDE-REC-CNT                                DESBD800
00486                    HOLD-REC-CNT                                   DESBD800
00487          PERFORM S1000-CALL-R-MOD THRU S1000-EXIT                 DESBD800
00488      ELSE                                                         DESBD800
00489          ADD +1 TO EXCLUDE-REC-CNT.                               DESBD800
00490                                                                   DESBD800
00491      SET L941-READ-NEXT-88 TO TRUE.                               DESBD800
00492                                                                   DESBD800
00493      PERFORM S941-RPT-I THRU S941-EXIT.                           DESBD800
00494  P1000-EXIT.                                                      DESBD800
00495      EXIT.                                                        DESBD800
00496      EJECT                                                        DESBD800
00497  P1100-INIT-REC-TYPE.                                             DESBD800
00498      MOVE RSK3-REC-TYPE TO HOLD-REC-TYPE.                         DESBD800
00499                                                                   DESBD800
00500      IF WRK-EXCLUDE-88                                            DESBD800
00501          IF WRK-CONTROL-CNT = +0                                  DESBD800
00502              MOVE 'I' TO WRK-SELECT-IND                           DESBD800
00503          ELSE                                                     DESBD800
00504              MOVE 'I' TO WRK-SELECT-IND                           DESBD800
00505              PERFORM P1110-EXCLUDE THRU P1110-EXIT                DESBD800
00506                 VARYING WRK-CONTROL-REC-IDX FROM 1 BY 1           DESBD800
00507                 UNTIL (WRK-CONTROL-REC-IDX > WRK-CONTROL-CNT)     DESBD800
00508                            OR                                     DESBD800
00509                       (WRK-SELECT-IND = 'E')                      DESBD800
00510      ELSE                                                         DESBD800
00511          MOVE 'E' TO WRK-SELECT-IND                               DESBD800
00512          PERFORM P1120-INCLUDE THRU P1120-EXIT                    DESBD800
00513             VARYING WRK-CONTROL-REC-IDX FROM 1 BY 1               DESBD800
00514             UNTIL (WRK-CONTROL-REC-IDX > WRK-CONTROL-CNT)         DESBD800
00515                          OR                                       DESBD800
00516                   (WRK-SELECT-IND = 'I').                         DESBD800
00517                                                                   DESBD800
00518      IF WRK-SELECT-IND = 'E'                                      DESBD800
00519          GO TO P1100-EXIT.                                        DESBD800
00520                                                                   DESBD800
00521      IF WRK-ATLEAST-ONCE-CNT = +0                                 DESBD800
00522          NEXT SENTENCE                                            DESBD800
00523      ELSE                                                         DESBD800
00524          PERFORM P1130-UPDT-ATLEAST-ONCE-CALLED THRU P1130-EXIT   DESBD800
00525             VARYING WRK-ATLEAST-ONCE-IDX FROM 1 BY 1              DESBD800
00526             UNTIL (WRK-ATLEAST-ONCE-IDX > WRK-ATLEAST-ONCE-CNT).  DESBD800
00527                                                                   DESBD800
00528      MOVE HOLD-REC-TYPE TO PRINT-TYPE.                            DESBD800
00529                                                                   DESBD800
00530      MOVE +0 TO HOLD-REC-CNT.                                     DESBD800
00531                                                                   DESBD800
00532      MOVE 'N' TO LRCM-EOR-IND.                                    DESBD800
00533  P1100-EXIT.                                                      DESBD800
00534      EXIT.                                                        DESBD800
00535                                                                   DESBD800
00536                                                                   DESBD800
00537                                                                   DESBD800
00538  P1110-EXCLUDE.                                                   DESBD800
00539      IF RSK3-REC-TYPE = WRK-CONTROL-REC-TYPE (WRK-CONTROL-REC-IDX)DESBD800
00540          MOVE 'E' TO WRK-SELECT-IND.                              DESBD800
00541  P1110-EXIT.                                                      DESBD800
00542      EXIT.                                                        DESBD800
00543                                                                   DESBD800
00544                                                                   DESBD800
00545                                                                   DESBD800
00546  P1120-INCLUDE.                                                   DESBD800
00547      IF RSK3-REC-TYPE = WRK-CONTROL-REC-TYPE (WRK-CONTROL-REC-IDX)DESBD800
00548          MOVE 'I' TO WRK-SELECT-IND.                              DESBD800
00549  P1120-EXIT.                                                      DESBD800
00550      EXIT.                                                        DESBD800
00551                                                                   DESBD800
00552                                                                   DESBD800
00553                                                                   DESBD800
00554  P1130-UPDT-ATLEAST-ONCE-CALLED.                                  DESBD800
00555      IF RSK3-REC-TYPE                                             DESBD800
00556             = WRK-ATLEAST-ONCE-REC-TYPE (WRK-ATLEAST-ONCE-IDX)    DESBD800
00557          MOVE 'Y'                                                 DESBD800
00558             TO WRK-ATLEAST-ONCE-CALLED-IND (WRK-ATLEAST-ONCE-IDX) DESBD800
00559          SET WRK-ATLEAST-ONCE-IDX TO WRK-ATLEAST-ONCE-CNT.        DESBD800
00560  P1130-EXIT.                                                      DESBD800
00561      EXIT.                                                        DESBD800
00562      EJECT                                                        DESBD800
00563  P1500-TERM-REC-TYPE.                                             DESBD800
00564      MOVE 'Y' TO LRCM-EOR-IND.                                    DESBD800
00565                                                                   DESBD800
00566      PERFORM S1000-CALL-R-MOD THRU S1000-EXIT.                    DESBD800
00567                                                                   DESBD800
00568      DISPLAY HOLD-REC-CNT                                         DESBD800
00569              ' RECORD TYPE '                                      DESBD800
00570              HOLD-REC-TYPE                                        DESBD800
00571              ' RECORDS PROCESSED'.                                DESBD800
00572                                                                   DESBD800
00573      MOVE HOLD-REC-CNT TO L980-REC-CNT (HOLD-REC-TYPE-9).         DESBD800
00574                                                                   DESBD800
00575      CANCEL PRINT-MODULE.                                         DESBD800
00576  P1500-EXIT.                                                      DESBD800
00577      EXIT.                                                        DESBD800
00578      EJECT                                                        DESBD800
00579  T0000-TERMINATE.                                                 DESBD800
00580      DISPLAY ' '.                                                 DESBD800
00581                                                                   DESBD800
00582      DISPLAY '*** DESBD800 TERMINATION STATISTICS'.               DESBD800
00583                                                                   DESBD800
00584      DISPLAY INCLUDE-REC-CNT                                      DESBD800
00585              ' RECORDS INCLUDED'.                                 DESBD800
00586                                                                   DESBD800
00587      DISPLAY EXCLUDE-REC-CNT                                      DESBD800
00588              ' RECORDS EXCLUDED'.                                 DESBD800
00589                                                                   DESBD800
00590                                                                   DESBD800
00591      IF WRK-ATLEAST-ONCE-CNT = +0                                 DESBD800
00592          NEXT SENTENCE                                            DESBD800
00593      ELSE                                                         DESBD800
00594          PERFORM T1000-CHK-ATLEAST-ONCE-CALLED THRU T1000-EXIT    DESBD800
00595             VARYING WRK-ATLEAST-ONCE-IDX FROM 1 BY 1              DESBD800
00596             UNTIL (WRK-ATLEAST-ONCE-IDX > WRK-ATLEAST-ONCE-CNT).  DESBD800
00597                                                                   DESBD800
00598                                                                   DESBD800
00599      SET L931-CLOSE-88 TO TRUE.                                   DESBD800
00600                                                                   DESBD800
00601      PERFORM S931-REF-IO THRU S931-EXIT.                          DESBD800
00602                                                                   DESBD800
00603      SET L941-CLOSE-88 TO TRUE.                                   DESBD800
00604                                                                   DESBD800
00605      PERFORM S941-RPT-I THRU S941-EXIT.                           DESBD800
00606                                                                   DESBD800
00607      PERFORM S980-CTRL-RPT-O THRU S980-EXIT.                      DESBD800
00608  T0000-EXIT.                                                      DESBD800
00609      EXIT.                                                        DESBD800
00610                                                                   DESBD800
00611                                                                   DESBD800
00612  T1000-CHK-ATLEAST-ONCE-CALLED.                                   DESBD800
00613      IF WRK-ATLEAST-ONCE-CALLED-88 (WRK-ATLEAST-ONCE-IDX)         DESBD800
00614          NEXT SENTENCE                                            DESBD800
00615      ELSE                                                         DESBD800
00616          MOVE WRK-ATLEAST-ONCE-REC-TYPE (WRK-ATLEAST-ONCE-IDX)    DESBD800
00617             TO PRINT-TYPE                                         DESBD800
00618          MOVE 'Y' TO LRCM-EOR-IND                                 DESBD800
00619          PERFORM S1000-CALL-R-MOD THRU S1000-EXIT                 DESBD800
00620          CANCEL PRINT-MODULE.                                     DESBD800
00621  T1000-EXIT.                                                      DESBD800
00622      EXIT.                                                        DESBD800
00623      EJECT                                                        DESBD800
00624  S1000-CALL-R-MOD.                                                DESBD800
00625      CALL PRINT-MODULE USING LRCM-LINK-AREA                       DESBD800
00626                              RSK3-REC.                            DESBD800
00627  S1000-EXIT.                                                      DESBD800
00628      EXIT.                                                        DESBD800
00629      EJECT                                                        DESBD800
00630  S001-CONVERT-DATE.                                               DESBD800
00631      CALL 'DTSBU001' USING L001-LINK-AREA.                        DESBD800
00632  S001-EXIT.                                                       DESBD800
00633      EXIT.                                                        DESBD800
00634                                                                   DESBD800
00635                                                                   DESBD800
00636  S119-AGENCY-FACTS.                                               DESBD800
00637      CALL 'DTSBU119' USING L119-LINK-AREA.                        DESBD800
00638  S119-EXIT.                                                       DESBD800
00639      EXIT.                                                        DESBD800
00640                                                                   DESBD800
00641                                                                   DESBD800
00642  S931-REF-IO.                                                     DESBD800
00643      CALL 'DTSBU931' USING L931-LINK-AREA                         DESBD800
00644                            FSKL-REC.                              DESBD800
00645  S931-EXIT.                                                       DESBD800
00646      EXIT.                                                        DESBD800
00647                                                                   DESBD800
00648                                                                   DESBD800
00649  S941-RPT-I.                                                      DESBD800
00650      CALL 'DTSBU941' USING L941-LINK-AREA                         DESBD800
00651                            RSK3-REC.                              DESBD800
00652  S941-EXIT.                                                       DESBD800
00653      EXIT.                                                        DESBD800
00654                                                                   DESBD800
00655                                                                   DESBD800
00656  S980-CTRL-RPT-O.                                                 DESBD800
00657      CALL 'DESBR980' USING LRCM-LINK-AREA,                        DESBD800
00658                            L980-LINK-AREA.                        DESBD800
00659  S980-EXIT.                                                       DESBD800
00660      EXIT.                                                        DESBD800
00661                                                                   DESBD800
00662                                                                   DESBD800
00663  S999-ABEND.                                                      DESBD800
00664      DISPLAY '*** DESBD800 ABENDING - ' ABEND-MSG.                DESBD800
00665                                                                   DESBD800
00666      CALL 'DTSBU999' USING WRK-ABEND-CD.                          DESBD800
00667  S999-EXIT.                                                       DESBD800
00668      EXIT.                                                        DESBD800
