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