666 lines
53 KiB
COBOL
666 lines
53 KiB
COBOL
00001 IDENTIFICATION DIVISION. 01/18/99
|
|
00002 PROGRAM-ID. DTSBE408. DTSBE408
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD LV004
|
|
00004 MODIFIED BY TRW S&ITG. CL**2
|
|
00005 DATE-WRITTEN. AUGUST 1994. DTSBE408
|
|
00006 DATE-COMPILED. DTSBE408
|
|
00007 SKIP3 DTSBE408
|
|
00008 ***** DTSBE408
|
|
00009 * DTSBE408
|
|
00010 * CALLING SEQUENCE: DTSBE408 CREATES DTSIR408 RECORDS. CL**2
|
|
00011 * DTSBD800 CALLS DTSBR408 CL**2
|
|
00012 * WHICH PRODUCES THE EXTRACT. CL**2
|
|
00013 * CL**4
|
|
00014 * FUNCTION: PAYMENT PLANS SATISFIED LIST EXTRACT. DTSBE408
|
|
00015 * DTSBE408
|
|
00016 * DTSBE408
|
|
00017 * MODIFICATION LOG: DTSBE408
|
|
00018 * DTSBE408
|
|
00019 * XX/XX/XX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBE408
|
|
00020 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBE408
|
|
00021 * WORK ORDER: PROGRAMMER: XXX DTSBE408
|
|
00022 * DTSBE408
|
|
00023 * DTSBE408
|
|
00024 * DESCRIPTION: DTSBE408
|
|
00025 * DTSBE408
|
|
00026 * DTSBE408
|
|
00027 * INITIATION: DTSBE408
|
|
00028 * DTSBE408
|
|
00029 * SET LECM-MST-OPEN-UPDATE-88 TO TRUE. DTSBE408
|
|
00030 * SET LECM-REF-OPEN-READ-88 TO TRUE. DTSBE408
|
|
00031 * DTSBE408
|
|
00032 * EDIT AND DEFAULT PARAMETERS. SEE PRINTED OUTPUTS DTSBE408
|
|
00033 * DESCRIPTIONS AND LAYOUTS (408R1). DTSBE408
|
|
00034 * DTSBE408
|
|
00035 * DETERMINE WRK-PAYMENT-CUTOFF-DATE. DTSBE408
|
|
00036 * DTSBE408
|
|
00037 * DTSBE408
|
|
00038 * PROCESSING: DTSBE408
|
|
00039 * DTSBE408
|
|
00040 * SEE PRINTED OUTPUTS DESCRIPTION AND LAYOUTS (408R1). DTSBE408
|
|
00041 * DTSBE408
|
|
00042 * TO DETERMINE THE AGE OF PAYMENTS DISTRIBUTED TO A DTSBE408
|
|
00043 * SPECIFIED QUARTER, USE THE SAME LOGIC AS FOUND IN DTSBE408
|
|
00044 * DTSBE405. CL**2
|
|
00045 * DTSBE408
|
|
00046 * DTSBE408
|
|
00047 * TERMINATION: DTSBE408
|
|
00048 * DTSBE408
|
|
00049 * NONE. DTSBE408
|
|
00050 * DTSBE408
|
|
00051 * DTSBE408
|
|
00052 * RECORDS READ: DTSBE408
|
|
00053 * DTSBE408
|
|
00054 * MASTER: DTSBE408
|
|
00055 * DTSBE408
|
|
00056 * MDPC DTSBE408
|
|
00057 * MQTR DTSBE408
|
|
00058 * MDST DTSBE408
|
|
00059 * DTSBE408
|
|
00060 * DTSBE408
|
|
00061 * ALTERNATE INDEX: DTSBE408
|
|
00062 * DTSBE408
|
|
00063 * NONE. DTSBE408
|
|
00064 * DTSBE408
|
|
00065 * DTSBE408
|
|
00066 * REFERENCE: DTSBE408
|
|
00067 * DTSBE408
|
|
00068 * NONE. DTSBE408
|
|
00069 * DTSBE408
|
|
00070 * DTSBE408
|
|
00071 * RECORDS UPDATED: DTSBE408
|
|
00072 * DTSBE408
|
|
00073 * MDPC DTSBE408
|
|
00074 * MEVL DTSBE408
|
|
00075 * DTSBE408
|
|
00076 * DTSBE408
|
|
00077 * REPORT RECORDS WRITTEN: DTSBE408
|
|
00078 * DTSBE408
|
|
00079 * R408 PAYMENT PLANS SATISFIED LIST. DTSBE408
|
|
00080 * DTSBE408
|
|
00081 * DTSBE408
|
|
00082 * BATCH TRANSACTION COLLECTION RECORDS WRITTEN: DTSBE408
|
|
00083 * DTSBE408
|
|
00084 * NONE. DTSBE408
|
|
00085 * DTSBE408
|
|
00086 * DTSBE408
|
|
00087 * MODULES CALLED: DTSBE408
|
|
00088 * DTSBE408
|
|
00089 * DTSBU001 DATE CONVERSION/EDIT. CL**2
|
|
00090 * DTSBU004 QUARTER CONVERSION/EDIT. CL**2
|
|
00091 * DTSBU910 MASTER FILE I/O. CL**2
|
|
00092 * DTSBU946 VARIABLE LENGTH RECORDS SEQUENTIAL OUTPUT 1. CL**2
|
|
00093 * DTSBE408
|
|
00094 * DTSBE408
|
|
00095 * VERMONT REFERENCE: DTSBE408
|
|
00096 * DTSBE408
|
|
00097 * TXBE348 DTSBE408
|
|
00098 * DTSBE408
|
|
00099 ***** DTSBE408
|
|
00100 SKIP3 DTSBE408
|
|
00101 ENVIRONMENT DIVISION. DTSBE408
|
|
00102 SKIP3 DTSBE408
|
|
00103 DATA DIVISION. DTSBE408
|
|
00104 SKIP3 DTSBE408
|
|
00105 WORKING-STORAGE SECTION. DTSBE408
|
|
001055 77 PAN-VALET PICTURE X(24) VALUE '004DTSBE408 01/18/99'. DTSBE408
|
|
00106 SKIP3 DTSBE408
|
|
00107 01 WRK-AREA. DTSBE408
|
|
00108 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +408.DTSBE408
|
|
00109 SKIP1 DTSBE408
|
|
00110 05 WRK-MOD-NAME PIC X(08) VALUE 'DTSBE408'. CL**2
|
|
00111 SKIP3 DTSBE408
|
|
00112 05 ABEND-MSG PIC X(60). DTSBE408
|
|
00113 SKIP3 DTSBE408
|
|
00114 05 WRK-PARM-PERIOD-START-DATE PIC S9(09) COMP-3. DTSBE408
|
|
00115 SKIP1 DTSBE408
|
|
00116 05 WRK-PARM-PERIOD-END-DATE PIC S9(09) COMP-3. DTSBE408
|
|
00117 SKIP1 DTSBE408
|
|
00118 05 WRK-PAYMENT-CUTOFF-DATE PIC S9(09) COMP-3. DTSBE408
|
|
00119 SKIP1 DTSBE408
|
|
00120 05 WRK-SUB PIC S9(04) COMP. DTSBE408
|
|
00121 SKIP1 DTSBE408
|
|
00122 05 WRK-PLAN-SATISFIED-IND PIC X(01). DTSBE408
|
|
00123 88 WRK-PLAN-SATISFIED-88 VALUE 'Y'. DTSBE408
|
|
00124 88 WRK-PLAN-NOT-SATISFIED-88 VALUE 'N'. DTSBE408
|
|
00125 DTSBE408
|
|
00126 05 EVL-TEXT. DTSBE408
|
|
00127 10 FILLER PIC X(46) VALUE DTSBE408
|
|
00128 'PAYMENT PLAN HAS BEEN AUTOMATICALLY SATISFIED.'. DTSBE408
|
|
00129 EJECT DTSBE408
|
|
00130 01 L001-LINK-AREA. DTSBE408
|
|
00131 ++INCLUDE DTSIL001 CL**2
|
|
00132 EJECT DTSBE408
|
|
00133 01 L004-LINK-AREA. DTSBE408
|
|
00134 ++INCLUDE DTSIL004 CL**2
|
|
00135 EJECT DTSBE408
|
|
00136 01 L005-LINK-AREA. DTSBE408
|
|
00137 ++INCLUDE DTSIL005 CL**2
|
|
00138 EJECT DTSBE408
|
|
00139 01 L910-LINK-AREA. DTSBE408
|
|
00140 ++INCLUDE DTSIL910 CL**2
|
|
00141 SKIP3 DTSBE408
|
|
00142 01 MSKL-REC. DTSBE408
|
|
00143 ++INCLUDE DTSIMSKL CL**2
|
|
00144 SKIP3 DTSBE408
|
|
00145 01 MDPC-REC. DTSBE408
|
|
00146 ++INCLUDE DTSIMDPC CL**2
|
|
00147 SKIP3 DTSBE408
|
|
00148 01 MQTR-REC. DTSBE408
|
|
00149 ++INCLUDE DTSIMQTR CL**2
|
|
00150 SKIP3 DTSBE408
|
|
00151 01 MDST-REC. DTSBE408
|
|
00152 ++INCLUDE DTSIMDST CL**2
|
|
00153 SKIP3 DTSBE408
|
|
00154 01 MEVL-REC. DTSBE408
|
|
00155 ++INCLUDE DTSIMEVL CL**2
|
|
00156 EJECT DTSBE408
|
|
00157 01 R408-REC. DTSBE408
|
|
00158 ++INCLUDE DTSIR408 CL**2
|
|
00159 EJECT DTSBE408
|
|
00160 LINKAGE SECTION. DTSBE408
|
|
00161 SKIP3 DTSBE408
|
|
00162 01 LECM-LINK-AREA. DTSBE408
|
|
00163 ++INCLUDE DTSILECM CL**2
|
|
00164 SKIP3 DTSBE408
|
|
00165 10 LECM-PARM-AREA REDEFINES LECM-EXTRACT-PARMS. DTSBE408
|
|
00166 15 LECM-PARM-PERIOD-START-DATE PIC X(06). DTSBE408
|
|
00167 15 FILLER PIC X(01). DTSBE408
|
|
00168 15 LECM-PARM-PERIOD-END-DATE PIC X(06). DTSBE408
|
|
00169 15 FILLER PIC X(55). DTSBE408
|
|
00170 EJECT DTSBE408
|
|
00171 01 MPRF-LINK-REC. DTSBE408
|
|
00172 ++INCLUDE DTSIMPRF CL**2
|
|
00173 EJECT DTSBE408
|
|
00174 ************************************************************** DTSBE408
|
|
00175 * PROCEDURE DIVISION FOR DTSBE408 - PAYMENT PLANS SATISFIED CL**2
|
|
00176 * LIST STARTS HERE. DTSBE408
|
|
00177 ************************************************************** DTSBE408
|
|
00178 DTSBE408
|
|
00179 PROCEDURE DIVISION USING LECM-LINK-AREA DTSBE408
|
|
00180 MPRF-LINK-REC. DTSBE408
|
|
00181 SKIP2 DTSBE408
|
|
00182 IF LECM-PROCESS-88 DTSBE408
|
|
00183 PERFORM P0000-PROCESS THRU P0000-EXIT DTSBE408
|
|
00184 ELSE DTSBE408
|
|
00185 IF LECM-INITIALIZE-88 DTSBE408
|
|
00186 PERFORM I0000-INITIALIZE THRU I0000-EXIT DTSBE408
|
|
00187 ELSE DTSBE408
|
|
00188 IF LECM-TERMINATE-88 DTSBE408
|
|
00189 PERFORM T0000-TERMINATE THRU T0000-EXIT DTSBE408
|
|
00190 ELSE DTSBE408
|
|
00191 MOVE 'INVALID LECM-CALL-TYPE-IND ENCOUNTERED' DTSBE408
|
|
00192 TO ABEND-MSG DTSBE408
|
|
00193 PERFORM S999-ABEND THRU S999-EXIT. DTSBE408
|
|
00194 SKIP2 DTSBE408
|
|
00195 GOBACK. DTSBE408
|
|
00196 EJECT DTSBE408
|
|
00197 ************************************************************** DTSBE408
|
|
00198 * THIS PARAGRAPH CONTROLS THE INITIALIZATION PROCESS FOR DTSBE408
|
|
00199 * DTSBE408. CL**2
|
|
00200 ************************************************************** DTSBE408
|
|
00201 DTSBE408
|
|
00202 I0000-INITIALIZE. DTSBE408
|
|
00203 SKIP2 DTSBE408
|
|
00204 MOVE LENGTH OF R408-REC TO R408-LENGTH. CL**2
|
|
00205 MOVE '408' TO R408-REC-TYPE. CL**2
|
|
00206 MOVE LECM-TRACE-IND TO L910-TRACE-IND. DTSBE408
|
|
00207 MOVE WRK-MOD-NAME TO L910-MOD-NAME. DTSBE408
|
|
00208 DTSBE408
|
|
00209 PERFORM I1000-EDIT-AND-DEFAULT-PARMS THRU I1000-EXIT. DTSBE408
|
|
00210 SKIP1 DTSBE408
|
|
00211 SET LECM-MST-OPEN-UPDATE-88 TO TRUE. DTSBE408
|
|
00212 SET LECM-REF-OPEN-READ-88 TO TRUE. DTSBE408
|
|
00213 SKIP2 DTSBE408
|
|
00214 I0000-EXIT. DTSBE408
|
|
00215 EXIT. DTSBE408
|
|
00216 SKIP3 DTSBE408
|
|
00217 ************************************************************** DTSBE408
|
|
00218 * THIS PARAGRAPH EDITS AND DEFAULTS THE PARMS. DTSBE408
|
|
00219 ************************************************************** DTSBE408
|
|
00220 DTSBE408
|
|
00221 I1000-EDIT-AND-DEFAULT-PARMS. DTSBE408
|
|
00222 PERFORM I1100-PERIOD-START-DATE THRU I1100-EXIT. DTSBE408
|
|
00223 DTSBE408
|
|
00224 PERFORM I1200-PERIOD-END-DATE THRU I1200-EXIT. DTSBE408
|
|
00225 DTSBE408
|
|
00226 MOVE LECM-CURR-RUN-DATE TO L001-FED-8-DATE-9. DTSBE408
|
|
00227 PERFORM S001-FROM-FED-8 THRU S001-EXIT. DTSBE408
|
|
00228 SUBTRACT 14 FROM L001-JUL-ABS-DAY. DTSBE408
|
|
00229 PERFORM S001-FROM-ABS-DAY THRU S001-EXIT. DTSBE408
|
|
00230 MOVE L001-FED-8-DATE-9 TO WRK-PAYMENT-CUTOFF-DATE. DTSBE408
|
|
00231 I1000-EXIT. DTSBE408
|
|
00232 EXIT. DTSBE408
|
|
00233 EJECT DTSBE408
|
|
00234 ************************************************************** DTSBE408
|
|
00235 * THIS PARAGRAPH EDITS THE PERIOD START DATE. DTSBE408
|
|
00236 ************************************************************** DTSBE408
|
|
00237 DTSBE408
|
|
00238 I1100-PERIOD-START-DATE. DTSBE408
|
|
00239 DTSBE408
|
|
00240 IF LECM-PARM-PERIOD-START-DATE = SPACES DTSBE408
|
|
00241 IF LECM-PERIOD-START-DATE > +0 DTSBE408
|
|
00242 MOVE LECM-PERIOD-START-DATE DTSBE408
|
|
00243 TO WRK-PARM-PERIOD-START-DATE DTSBE408
|
|
00244 ELSE DTSBE408
|
|
00245 MOVE 'PERIOD-START-DATE MISSING' DTSBE408
|
|
00246 TO ABEND-MSG DTSBE408
|
|
00247 PERFORM S999-ABEND THRU S999-EXIT DTSBE408
|
|
00248 ELSE DTSBE408
|
|
00249 MOVE LECM-PARM-PERIOD-START-DATE TO L001-CAL-6-DATE-X DTSBE408
|
|
00250 PERFORM S001-FROM-CAL-6 THRU S001-EXIT DTSBE408
|
|
00251 IF L001-VALID-DATE DTSBE408
|
|
00252 MOVE L001-FED-8-DATE-9 TO WRK-PARM-PERIOD-START-DATE DTSBE408
|
|
00253 ELSE DTSBE408
|
|
00254 MOVE 'PERIOD-START-DATE NOT VALID' DTSBE408
|
|
00255 TO ABEND-MSG DTSBE408
|
|
00256 PERFORM S999-ABEND THRU S999-EXIT. DTSBE408
|
|
00257 I1100-EXIT. DTSBE408
|
|
00258 EXIT. DTSBE408
|
|
00259 EJECT DTSBE408
|
|
00260 ************************************************************** DTSBE408
|
|
00261 * THIS PARAGRAPH EDITS THE PERIOD END DATE. DTSBE408
|
|
00262 ************************************************************** DTSBE408
|
|
00263 DTSBE408
|
|
00264 I1200-PERIOD-END-DATE. DTSBE408
|
|
00265 DTSBE408
|
|
00266 IF LECM-PARM-PERIOD-END-DATE = SPACES DTSBE408
|
|
00267 IF LECM-PERIOD-END-DATE > +0 DTSBE408
|
|
00268 MOVE LECM-PERIOD-END-DATE DTSBE408
|
|
00269 TO WRK-PARM-PERIOD-END-DATE DTSBE408
|
|
00270 ELSE DTSBE408
|
|
00271 MOVE 'PERIOD-END-DATE MISSING' DTSBE408
|
|
00272 TO ABEND-MSG DTSBE408
|
|
00273 PERFORM S999-ABEND THRU S999-EXIT DTSBE408
|
|
00274 ELSE DTSBE408
|
|
00275 MOVE LECM-PARM-PERIOD-END-DATE TO L001-CAL-6-DATE-X DTSBE408
|
|
00276 PERFORM S001-FROM-CAL-6 THRU S001-EXIT DTSBE408
|
|
00277 IF L001-VALID-DATE DTSBE408
|
|
00278 MOVE L001-FED-8-DATE-9 TO WRK-PARM-PERIOD-END-DATE DTSBE408
|
|
00279 ELSE DTSBE408
|
|
00280 MOVE 'PERIOD-END-DATE NOT VALID' DTSBE408
|
|
00281 TO ABEND-MSG DTSBE408
|
|
00282 PERFORM S999-ABEND THRU S999-EXIT. DTSBE408
|
|
00283 DTSBE408
|
|
00284 IF WRK-PARM-PERIOD-START-DATE > WRK-PARM-PERIOD-END-DATE DTSBE408
|
|
00285 MOVE 'PERIOD START DATE IS GREATER THAN PERIOD END DATE' DTSBE408
|
|
00286 TO ABEND-MSG DTSBE408
|
|
00287 PERFORM S999-ABEND THRU S999-EXIT. DTSBE408
|
|
00288 I1200-EXIT. DTSBE408
|
|
00289 EXIT. DTSBE408
|
|
00290 EJECT DTSBE408
|
|
00291 ************************************************************** DTSBE408
|
|
00292 * THIS IS THE PROCESS PARAGRAPH FOR DTSBE408. CL**2
|
|
00293 ************************************************************** DTSBE408
|
|
00294 DTSBE408
|
|
00295 P0000-PROCESS. DTSBE408
|
|
00296 DTSBE408
|
|
00297 IF MPRF-NO-MDPC-88 DTSBE408
|
|
00298 GO TO P0000-EXIT. DTSBE408
|
|
00299 DTSBE408
|
|
00300 MOVE LOW-VALUES TO MDPC-KEY-AREA. DTSBE408
|
|
00301 MOVE MPRF-EMP-NO TO MDPC-EMP-NO. DTSBE408
|
|
00302 SET MDPC-DPC-88 TO TRUE. DTSBE408
|
|
00303 MOVE MDPC-KEY-AREA TO MSKL-KEY-AREA. DTSBE408
|
|
00304 DTSBE408
|
|
00305 PERFORM S910-START-BROWSE THRU S910-EXIT. DTSBE408
|
|
00306 DTSBE408
|
|
00307 PERFORM P1000-MDPC-SCAN THRU P1000-EXIT DTSBE408
|
|
00308 UNTIL L910-NO-REC-88. DTSBE408
|
|
00309 DTSBE408
|
|
00310 P0000-EXIT. DTSBE408
|
|
00311 EXIT. DTSBE408
|
|
00312 SKIP3 DTSBE408
|
|
00313 ************************************************************** DTSBE408
|
|
00314 * THIS PARAGRAPH SCANS ALL MDPC RECORDS FOR THE EMPLOYER. DTSBE408
|
|
00315 ************************************************************** DTSBE408
|
|
00316 DTSBE408
|
|
00317 P1000-MDPC-SCAN. DTSBE408
|
|
00318 DTSBE408
|
|
00319 MOVE MSKL-REC TO MDPC-REC. DTSBE408
|
|
00320 DTSBE408
|
|
00321 IF MDPC-STATUS-SATISFIED-88 DTSBE408
|
|
00322 PERFORM P1100-SATISFIED-MDPC THRU P1100-EXIT DTSBE408
|
|
00323 ELSE DTSBE408
|
|
00324 IF MDPC-STATUS-OPEN-88 DTSBE408
|
|
00325 PERFORM P1200-OPEN-MDPC THRU P1200-EXIT DTSBE408
|
|
00326 MOVE MDPC-KEY-AREA TO MSKL-KEY-AREA DTSBE408
|
|
00327 PERFORM S910-READ THRU S910-EXIT DTSBE408
|
|
00328 IF L910-NO-REC-88 DTSBE408
|
|
00329 MOVE 'LOGIC ERROR IN P1000' TO ABEND-MSG DTSBE408
|
|
00330 PERFORM S999-ABEND THRU S999-EXIT. DTSBE408
|
|
00331 DTSBE408
|
|
00332 PERFORM S910-READ-NEXT THRU S910-EXIT. DTSBE408
|
|
00333 DTSBE408
|
|
00334 P1000-EXIT. DTSBE408
|
|
00335 EXIT. DTSBE408
|
|
00336 EJECT DTSBE408
|
|
00337 ************************************************************** DTSBE408
|
|
00338 * THIS PARAGRAPH PROCESSES ALL SATSIFIED MDPC RECORDS. DTSBE408
|
|
00339 ************************************************************** DTSBE408
|
|
00340 DTSBE408
|
|
00341 P1100-SATISFIED-MDPC. DTSBE408
|
|
00342 DTSBE408
|
|
00343 IF MDPC-STATUS-SYSTEM-88 DTSBE408
|
|
00344 GO TO P1100-EXIT. DTSBE408
|
|
00345 DTSBE408
|
|
00346 IF (MDPC-STATUS-DATE < WRK-PARM-PERIOD-START-DATE) DTSBE408
|
|
00347 OR DTSBE408
|
|
00348 (MDPC-STATUS-DATE > WRK-PARM-PERIOD-END-DATE) DTSBE408
|
|
00349 NEXT SENTENCE DTSBE408
|
|
00350 ELSE DTSBE408
|
|
00351 PERFORM P1110-GENERATE-R408 THRU P1110-EXIT. DTSBE408
|
|
00352 DTSBE408
|
|
00353 P1100-EXIT. DTSBE408
|
|
00354 EXIT. DTSBE408
|
|
00355 EJECT DTSBE408
|
|
00356 ************************************************************** DTSBE408
|
|
00357 * THIS PARAGRAPH SETS UP THE R408 REPORT EXTRACT RECORD AND DTSBE408
|
|
00358 * CAUSES IT TO BE WRITTEN. DTSBE408
|
|
00359 ************************************************************** DTSBE408
|
|
00360 DTSBE408
|
|
00361 P1110-GENERATE-R408. DTSBE408
|
|
00362 DTSBE408
|
|
00363 MOVE MDPC-RESPONSIBLE-OP-ID TO R408-OP-ID. DTSBE408
|
|
00364 MOVE MPRF-EMP-NO TO R408-EMP-NO. DTSBE408
|
|
00365 MOVE MPRF-PRIMARY-NAME TO R408-PRIMARY-NAME. CL**2
|
|
00366 MOVE WRK-PARM-PERIOD-START-DATE DTSBE408
|
|
00367 TO R408-PERIOD-START-DATE. DTSBE408
|
|
00368 MOVE WRK-PARM-PERIOD-END-DATE DTSBE408
|
|
00369 TO R408-PERIOD-END-DATE. DTSBE408
|
|
00370 MOVE MDPC-COV-CNT TO R408-COVERED-YRQ-CNT. DTSBE408
|
|
00371 DTSBE408
|
|
00372 PERFORM P1112-MOVE-YRQ-TABLE THRU P1112-EXIT DTSBE408
|
|
00373 VARYING MDPC-COV-IDX FROM 1 BY 1 DTSBE408
|
|
00374 UNTIL MDPC-COV-IDX GREATER THAN MDPC-COV-CNT. DTSBE408
|
|
00375 DTSBE408
|
|
00376 PERFORM S946-WRITE-R408 THRU S946-EXIT. DTSBE408
|
|
00377 DTSBE408
|
|
00378 PERFORM P1111-INITIALIZE-TABLE THRU P1111-EXIT DTSBE408
|
|
00379 VARYING WRK-SUB FROM 1 BY 1 DTSBE408
|
|
00380 UNTIL WRK-SUB GREATER THAN R408-COVERED-YRQ-CNT. DTSBE408
|
|
00381 DTSBE408
|
|
00382 P1110-EXIT. DTSBE408
|
|
00383 EXIT. DTSBE408
|
|
00384 EJECT DTSBE408
|
|
00385 ************************************************************** DTSBE408
|
|
00386 * THIS PARAGRAPH MOVES THE QUARTERS COVERED TABLE IN THE MDPC DTSBE408
|
|
00387 * RECORD TO THE R408 EXTRACT RECORD TABLE. DTSBE408
|
|
00388 ************************************************************** DTSBE408
|
|
00389 DTSBE408
|
|
00390 P1111-INITIALIZE-TABLE. DTSBE408
|
|
00391 DTSBE408
|
|
00392 MOVE ZEROS TO R408-COVERED-YRQ (WRK-SUB). DTSBE408
|
|
00393 DTSBE408
|
|
00394 P1111-EXIT. DTSBE408
|
|
00395 EXIT. DTSBE408
|
|
00396 EJECT DTSBE408
|
|
00397 ************************************************************** DTSBE408
|
|
00398 * THIS PARAGRAPH MOVES THE QUARTERS COVERED TABLE IN THE MDPC DTSBE408
|
|
00399 * RECORD TO THE R408 EXTRACT RECORD TABLE. DTSBE408
|
|
00400 ************************************************************** DTSBE408
|
|
00401 DTSBE408
|
|
00402 P1112-MOVE-YRQ-TABLE. DTSBE408
|
|
00403 DTSBE408
|
|
00404 SET R408-YRQ-IDX TO MDPC-COV-IDX. DTSBE408
|
|
00405 DTSBE408
|
|
00406 MOVE MDPC-COVERED-YRQ (MDPC-COV-IDX) DTSBE408
|
|
00407 TO R408-COVERED-YRQ (R408-YRQ-IDX). DTSBE408
|
|
00408 DTSBE408
|
|
00409 P1112-EXIT. DTSBE408
|
|
00410 EXIT. DTSBE408
|
|
00411 EJECT DTSBE408
|
|
00412 ************************************************************** DTSBE408
|
|
00413 * THIS PARAGRAPH DETERMINES WHETHER AN OPEN MDPC RECORD DTSBE408
|
|
00414 * SHOULD BE AUTOMATICALLY SATISFIED. IF IT SHOULD BE DTSBE408
|
|
00415 * SATISFIED MODIFY AND REWRITE THE MDPC RECORD, AND WRITE DTSBE408
|
|
00416 * AN MEVL RECORD COMMEMORATING THE EVENT. DTSBE408
|
|
00417 ************************************************************** DTSBE408
|
|
00418 DTSBE408
|
|
00419 P1200-OPEN-MDPC. DTSBE408
|
|
00420 DTSBE408
|
|
00421 SET WRK-PLAN-SATISFIED-88 TO TRUE. DTSBE408
|
|
00422 DTSBE408
|
|
00423 PERFORM P1210-PROCESS-QTRS THRU P1210-EXIT DTSBE408
|
|
00424 VARYING MDPC-COV-IDX FROM 1 BY 1 DTSBE408
|
|
00425 UNTIL WRK-PLAN-NOT-SATISFIED-88 OR DTSBE408
|
|
00426 MDPC-COV-IDX GREATER THAN MDPC-COV-CNT. DTSBE408
|
|
00427 DTSBE408
|
|
00428 IF WRK-PLAN-SATISFIED-88 DTSBE408
|
|
00429 PERFORM P1110-GENERATE-R408 THRU P1110-EXIT DTSBE408
|
|
00430 PERFORM P1220-REWRITE-MDPC THRU P1220-EXIT DTSBE408
|
|
00431 PERFORM P1230-WRITE-MEVL THRU P1230-EXIT. DTSBE408
|
|
00432 DTSBE408
|
|
00433 P1200-EXIT. DTSBE408
|
|
00434 EXIT. DTSBE408
|
|
00435 EJECT DTSBE408
|
|
00436 ************************************************************** DTSBE408
|
|
00437 * THIS PARAGRAPH READS THE MQTR RECORDS COVERED BY THE MDPC DTSBE408
|
|
00438 * RECORD TO DETERMINE IF THER ARE BALANCES DUE. IF THERE DTSBE408
|
|
00439 * ARE NOT THE PAYMENTS ARE CHECKED TO SEE IF THEY ARE OVER DTSBE408
|
|
00440 * TWO WEEKS OLD. DTSBE408
|
|
00441 ************************************************************** DTSBE408
|
|
00442 DTSBE408
|
|
00443 P1210-PROCESS-QTRS. DTSBE408
|
|
00444 DTSBE408
|
|
00445 MOVE LOW-VALUES TO MQTR-KEY-AREA. DTSBE408
|
|
00446 MOVE MPRF-EMP-NO TO MQTR-EMP-NO. DTSBE408
|
|
00447 SET MQTR-QTR-88 TO TRUE. DTSBE408
|
|
00448 MOVE MDPC-COVERED-YRQ (MDPC-COV-IDX) TO MQTR-YRQ. DTSBE408
|
|
00449 MOVE MQTR-KEY-AREA TO MSKL-KEY-AREA. DTSBE408
|
|
00450 DTSBE408
|
|
00451 PERFORM S910-READ THRU S910-EXIT. DTSBE408
|
|
00452 DTSBE408
|
|
00453 IF L910-OK-88 DTSBE408
|
|
00454 NEXT SENTENCE DTSBE408
|
|
00455 ELSE DTSBE408
|
|
00456 GO TO P1210-EXIT. DTSBE408
|
|
00457 DTSBE408
|
|
00458 MOVE MSKL-REC TO MQTR-REC. DTSBE408
|
|
00459 DTSBE408
|
|
00460 PERFORM P1211-PROCESS-ACCT-AREA THRU P1211-EXIT DTSBE408
|
|
00461 VARYING MQTR-ACCT-IDX FROM 1 BY 1 DTSBE408
|
|
00462 UNTIL WRK-PLAN-NOT-SATISFIED-88 OR DTSBE408
|
|
00463 MQTR-ACCT-IDX GREATER THAN MQTR-ACCT-CNT. DTSBE408
|
|
00464 DTSBE408
|
|
00465 IF MQTR-RPT-IS-PURSUED-88 DTSBE408
|
|
00466 SET WRK-PLAN-NOT-SATISFIED-88 TO TRUE. DTSBE408
|
|
00467 DTSBE408
|
|
00468 IF WRK-PLAN-NOT-SATISFIED-88 DTSBE408
|
|
00469 GO TO P1210-EXIT. DTSBE408
|
|
00470 DTSBE408
|
|
00471 MOVE LOW-VALUES TO MDST-KEY-AREA. DTSBE408
|
|
00472 MOVE MPRF-EMP-NO TO MDST-EMP-NO. DTSBE408
|
|
00473 MOVE MQTR-YRQ TO MDST-YRQ. DTSBE408
|
|
00474 SET MDST-DST-88 TO TRUE. DTSBE408
|
|
00475 MOVE MDST-KEY-AREA TO MSKL-KEY-AREA. DTSBE408
|
|
00476 DTSBE408
|
|
00477 PERFORM S910-START-BROWSE THRU S910-EXIT. DTSBE408
|
|
00478 DTSBE408
|
|
00479 IF L910-OK-88 DTSBE408
|
|
00480 PERFORM P1212-CHECK-DATE THRU P1212-EXIT DTSBE408
|
|
00481 UNTIL L910-NO-REC-88 OR DTSBE408
|
|
00482 WRK-PLAN-NOT-SATISFIED-88. DTSBE408
|
|
00483 DTSBE408
|
|
00484 P1210-EXIT. DTSBE408
|
|
00485 EXIT. DTSBE408
|
|
00486 EJECT DTSBE408
|
|
00487 ************************************************************** DTSBE408
|
|
00488 * THIS PARAGRAPH CHECKS THE BALANCE DUE IN THE MQTR RECORDS. DTSBE408
|
|
00489 ************************************************************** DTSBE408
|
|
00490 DTSBE408
|
|
00491 P1211-PROCESS-ACCT-AREA. DTSBE408
|
|
00492 DTSBE408
|
|
00493 IF MQTR-BALANCE-AMT (MQTR-ACCT-IDX) GREATER THAN ZERO DTSBE408
|
|
00494 SET WRK-PLAN-NOT-SATISFIED-88 TO TRUE. DTSBE408
|
|
00495 DTSBE408
|
|
00496 P1211-EXIT. DTSBE408
|
|
00497 EXIT. DTSBE408
|
|
00498 EJECT DTSBE408
|
|
00499 ************************************************************** DTSBE408
|
|
00500 * THIS PARAGRAPH CHECKS THE PAYMENT DATES ON ALL MDST DTSBE408
|
|
00501 * RECORDS FOR THE QUARTER TO DETERMINE IF THE PAYMENTS HAVE DTSBE408
|
|
00502 * AGED. DTSBE408
|
|
00503 ************************************************************** DTSBE408
|
|
00504 DTSBE408
|
|
00505 P1212-CHECK-DATE. DTSBE408
|
|
00506 DTSBE408
|
|
00507 MOVE MSKL-REC TO MDST-REC. DTSBE408
|
|
00508 DTSBE408
|
|
00509 IF MDST-YRQ EQUAL MQTR-YRQ DTSBE408
|
|
00510 NEXT SENTENCE DTSBE408
|
|
00511 ELSE DTSBE408
|
|
00512 SET L910-NO-REC-88 TO TRUE DTSBE408
|
|
00513 GO TO P1212-EXIT. DTSBE408
|
|
00514 DTSBE408
|
|
00515 IF MDST-RECEIVED-DATE LESS THAN WRK-PAYMENT-CUTOFF-DATE DTSBE408
|
|
00516 NEXT SENTENCE DTSBE408
|
|
00517 ELSE DTSBE408
|
|
00518 SET WRK-PLAN-NOT-SATISFIED-88 TO TRUE. DTSBE408
|
|
00519 DTSBE408
|
|
00520 PERFORM S910-READ-NEXT THRU S910-EXIT. DTSBE408
|
|
00521 DTSBE408
|
|
00522 P1212-EXIT. DTSBE408
|
|
00523 EXIT. DTSBE408
|
|
00524 EJECT DTSBE408
|
|
00525 ************************************************************** DTSBE408
|
|
00526 * THIS PARAGRAPH REWRITES THE MDPC RECORD IF IT HAS BEEN DTSBE408
|
|
00527 * DETERMINED THAT IT SHOULD BE AUTOMATICALLY SATISFIED. DTSBE408
|
|
00528 ************************************************************** DTSBE408
|
|
00529 DTSBE408
|
|
00530 P1220-REWRITE-MDPC. DTSBE408
|
|
00531 DTSBE408
|
|
00532 SET MDPC-STATUS-SATISFIED-88 TO TRUE. DTSBE408
|
|
00533 SET MDPC-STATUS-SYSTEM-88 TO TRUE. DTSBE408
|
|
00534 DTSBE408
|
|
00535 MOVE LECM-CURR-RUN-DATE TO MDPC-STATUS-DATE DTSBE408
|
|
00536 MDPC-CHNG-DATE. DTSBE408
|
|
00537 MOVE MDPC-REC TO MSKL-REC. DTSBE408
|
|
00538 DTSBE408
|
|
00539 PERFORM S910-REWRITE THRU S910-EXIT. DTSBE408
|
|
00540 DTSBE408
|
|
00541 P1220-EXIT. DTSBE408
|
|
00542 EXIT. DTSBE408
|
|
00543 EJECT DTSBE408
|
|
00544 ************************************************************** DTSBE408
|
|
00545 * THIS PARAGRAPH WRITES AN MEVL RECORD WHEN AN MDST RECORD DTSBE408
|
|
00546 * HAS BEEN AUTOMATICALLY SATISFIED. DTSBE408
|
|
00547 ************************************************************** DTSBE408
|
|
00548 DTSBE408
|
|
00549 P1230-WRITE-MEVL. DTSBE408
|
|
00550 DTSBE408
|
|
00551 MOVE LOW-VALUES TO MEVL-REC. DTSBE408
|
|
00552 MOVE MPRF-EMP-NO TO MEVL-EMP-NO. DTSBE408
|
|
00553 SET MEVL-EVL-88 TO TRUE. DTSBE408
|
|
00554 ADD +1000 TO LECM-EMP-ABSTIME. DTSBE408
|
|
00555 MOVE LECM-EMP-ABSTIME TO L005-ABSTIME. DTSBE408
|
|
00556 DTSBE408
|
|
00557 PERFORM S005-FROM-ABSTIME THRU S005-EXIT. DTSBE408
|
|
00558 DTSBE408
|
|
00559 MOVE L005-DATE TO MEVL-DATE. DTSBE408
|
|
00560 MOVE L005-TIME TO MEVL-TIME. DTSBE408
|
|
00561 MOVE ZEROS TO MEVL-PURGE-DATE. DTSBE408
|
|
00562 MOVE EVL-TEXT TO MEVL-TEXT. DTSBE408
|
|
00563 DTSBE408
|
|
00564 SET MEVL-SOURCE-SYSTEM-88 TO TRUE. DTSBE408
|
|
00565 SET MEVL-NOT-CONVERTED-88 TO TRUE. DTSBE408
|
|
00566 DTSBE408
|
|
00567 MOVE LECM-CURR-RUN-DATE TO MEVL-ESTB-DATE DTSBE408
|
|
00568 MEVL-CHNG-DATE. DTSBE408
|
|
00569 MOVE MEVL-REC TO MSKL-REC. DTSBE408
|
|
00570 DTSBE408
|
|
00571 PERFORM S910-WRITE THRU S910-EXIT. DTSBE408
|
|
00572 DTSBE408
|
|
00573 P1230-EXIT. DTSBE408
|
|
00574 EXIT. DTSBE408
|
|
00575 EJECT DTSBE408
|
|
00576 T0000-TERMINATE. DTSBE408
|
|
00577 SKIP2 DTSBE408
|
|
00578 SKIP2 DTSBE408
|
|
00579 T0000-EXIT. DTSBE408
|
|
00580 EXIT. DTSBE408
|
|
00581 EJECT DTSBE408
|
|
00582 S001-FROM-FED-8. DTSBE408
|
|
00583 SET L001-FROM-FED-8 TO TRUE. DTSBE408
|
|
00584 GO TO S001-DATE. DTSBE408
|
|
00585 SKIP1 DTSBE408
|
|
00586 S001-FROM-CAL-6. DTSBE408
|
|
00587 SET L001-FROM-CAL-6 TO TRUE. DTSBE408
|
|
00588 GO TO S001-DATE. DTSBE408
|
|
00589 SKIP1 DTSBE408
|
|
00590 S001-FROM-ABS-DAY. DTSBE408
|
|
00591 SET L001-FROM-ABS-DAY TO TRUE. DTSBE408
|
|
00592 GO TO S001-DATE. DTSBE408
|
|
00593 SKIP1 DTSBE408
|
|
00594 S001-DATE. DTSBE408
|
|
00595 CALL 'DTSBU001' USING L001-LINK-AREA. CL**2
|
|
00596 S001-EXIT. DTSBE408
|
|
00597 EXIT. DTSBE408
|
|
00598 SKIP3 DTSBE408
|
|
00599 S004-FROM-ABS. DTSBE408
|
|
00600 SET L004-FROM-ABS TO TRUE. DTSBE408
|
|
00601 GO TO S004-QTR. DTSBE408
|
|
00602 SKIP1 DTSBE408
|
|
00603 S004-FROM-3. DTSBE408
|
|
00604 SET L004-FROM-3 TO TRUE. DTSBE408
|
|
00605 GO TO S004-QTR. DTSBE408
|
|
00606 SKIP1 DTSBE408
|
|
00607 S004-QTR. DTSBE408
|
|
00608 SKIP1 DTSBE408
|
|
00609 CALL 'DTSBU004' USING L004-LINK-AREA. CL**2
|
|
00610 SKIP1 DTSBE408
|
|
00611 S004-EXIT. DTSBE408
|
|
00612 EXIT. DTSBE408
|
|
00613 SKIP3 DTSBE408
|
|
00614 S005-FROM-ABSTIME. DTSBE408
|
|
00615 SET L005-FROM-ABSTIME TO TRUE. DTSBE408
|
|
00616 GO TO S005-ABSTIME. DTSBE408
|
|
00617 DTSBE408
|
|
00618 S005-ABSTIME. DTSBE408
|
|
00619 CALL 'DTSBU005' USING L005-LINK-AREA. CL**2
|
|
00620 S005-EXIT. DTSBE408
|
|
00621 EXIT. DTSBE408
|
|
00622 SKIP3 DTSBE408
|
|
00623 S910-READ. DTSBE408
|
|
00624 SET L910-READ-88 TO TRUE. DTSBE408
|
|
00625 GO TO S910-MSTR-IO. DTSBE408
|
|
00626 SKIP1 DTSBE408
|
|
00627 S910-START-BROWSE. DTSBE408
|
|
00628 SET L910-START-BROWSE-88 TO TRUE. DTSBE408
|
|
00629 GO TO S910-MSTR-IO. DTSBE408
|
|
00630 SKIP1 DTSBE408
|
|
00631 S910-READ-NEXT. DTSBE408
|
|
00632 SET L910-READ-NEXT-88 TO TRUE. DTSBE408
|
|
00633 GO TO S910-MSTR-IO. DTSBE408
|
|
00634 SKIP1 DTSBE408
|
|
00635 S910-WRITE. DTSBE408
|
|
00636 SET L910-WRITE-88 TO TRUE. DTSBE408
|
|
00637 SET LECM-EMP-UPDATED-YES-88 TO TRUE. DTSBE408
|
|
00638 GO TO S910-MSTR-IO. DTSBE408
|
|
00639 SKIP1 DTSBE408
|
|
00640 S910-REWRITE. DTSBE408
|
|
00641 SET L910-REWRITE-88 TO TRUE. DTSBE408
|
|
00642 SET LECM-EMP-UPDATED-YES-88 TO TRUE. DTSBE408
|
|
00643 GO TO S910-MSTR-IO. DTSBE408
|
|
00644 SKIP1 DTSBE408
|
|
00645 S910-MSTR-IO. DTSBE408
|
|
00646 CALL 'DTSBU910' USING L910-LINK-AREA CL**2
|
|
00647 MSKL-REC. DTSBE408
|
|
00648 S910-EXIT. DTSBE408
|
|
00649 EXIT. DTSBE408
|
|
00650 SKIP3 DTSBE408
|
|
00651 S946-WRITE-R408. DTSBE408
|
|
00652 CALL 'DTSBU946' USING R408-REC. CL**2
|
|
00653 GO TO S946-EXIT. DTSBE408
|
|
00654 SKIP1 DTSBE408
|
|
00655 S946-EXIT. DTSBE408
|
|
00656 EXIT. DTSBE408
|
|
00657 SKIP3 DTSBE408
|
|
00658 S999-ABEND. DTSBE408
|
|
00659 DISPLAY '*** DTSBE408 ABENDING. ' CL**2
|
|
00660 ABEND-MSG. DTSBE408
|
|
00661 SKIP1 DTSBE408
|
|
00662 CALL 'DTSBU999' USING WRK-ABEND-CD. CL**2
|
|
00663 S999-EXIT. DTSBE408
|
|
00664 EXIT. DTSBE408
|