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