00001 IDENTIFICATION DIVISION. 02/05/15 00002 PROGRAM-ID. DTSBX438. DTSBX438 00003 AUTHOR. NGC. LV082 00004 DATE-WRITTEN. SEPT 2014. CL*29 00005 DATE-COMPILED. DTSBX438 00006 SKIP3 DTSBX438 00007 ***** DTSBX438 00008 * DTSBX438 00009 * FUNCTION: CREATE REPORT FOR ALL DAILY TDEC REPORT PAYMENTS CL*64 00010 * FILE. PAYMENT WILL BE ADDED TO DUTAS FOR ESSP. CL*28 00011 * MODIFICATION HISTORY: DTSBX438 00012 * DTSBX438 00013 * 09-20-2014 INITIAL DEVELOPMENT CL*19 00014 * REFERENCE RFP: WEB REGISTRATION ESSP ZL1 CL*19 00015 * CL*19 00016 * DTSBX438 00017 * 01-06-2015 MODIFIED PROGRAM TO PRODUCE REPORT OF ALL CL*49 00018 * TDEC CHECK DISPOSITION (PAID AND PENDING) ZL1 CL*49 00019 * CL*49 00020 ***** DTSBX438 00021 SKIP3 DTSBX438 00022 ENVIRONMENT DIVISION. DTSBX438 00023 CONFIGURATION SECTION. CL*51 00024 SPECIAL-NAMES. C01 IS TOP-OF-PAGE. CL*51 00025 CL*51 00026 INPUT-OUTPUT SECTION. DTSBX438 00027 DTSBX438 00028 FILE-CONTROL. DTSBX438 00029 DTSBX438 00030 CL*14 00031 SELECT TDEC-PAYT-FILE ASSIGN TO DTSFX145 CL*34 00032 FILE STATUS IS TDEC-PAYT-STATUS. CL*28 00033 CL*14 00034 CL*16 00035 SELECT TDEC-PEND-FILE ASSIGN TO DTSPX145 CL*34 00036 FILE STATUS IS BATCH-XREF-STATUS. CL*16 00037 CL*47 00038 SELECT REPT-PAID-FILE ASSIGN TO X438RPT1 CL*68 00039 FILE STATUS IS REPT-STATUS. CL*47 00040 CL*47 00041 SELECT REPT-PEND-FILE ASSIGN TO X438RPT2 CL*68 00042 FILE STATUS IS REPT-STATUS. CL*47 00043 CL*47 00044 DATA DIVISION. DTSBX438 00045 DTSBX438 00046 FILE SECTION. DTSBX438 00047 DTSBX438 00048 CL*14 00049 FD TDEC-PAYT-FILE CL*28 00050 RECORDING MODE IS F CL*14 00051 BLOCK CONTAINS 0 RECORDS CL*14 00052 LABEL RECORDS ARE OMITTED. CL*14 00053 CL*14 00054 01 TDEC-PAYT-REC. CL*30 00055 05 WEB-IMP-TYPE PIC X(03). CL*30 00056 88 WEB-IMP-TYPE-PRF-88 VALUE '102'. CL*30 00057 88 WEB-IMP-TYPE-DETERM-88 VALUE '104'. CL*30 00058 88 WEB-IMP-TYPE-NAME-88 VALUE '106'. CL*30 00059 88 WEB-IMP-TYPE-RATE-88 VALUE '108'. CL*30 00060 88 WEB-IMP-TYPE-ADDR-88 VALUE '110'. CL*30 00061 88 WEB-IMP-TYPE-OPO-88 VALUE '120'. CL*30 00062 88 WEB-IMP-TYPE-REL-88 VALUE '130'. CL*30 00063 *** 88 WEB-IMP-TYPE-IND-88 VALUE '132'. CL*30 00064 88 WEB-IMP-TYPE-RPT-88 VALUE '140'. CL*30 00065 88 WEB-IMP-TYPE-WAGE-88 VALUE '144'. CL*30 00066 88 WEB-IMP-TYPE-PAY-88 VALUE '145'. CL*30 00067 88 WEB-IMP-TYPE-BHDR-88 VALUE '149'. CL*30 00068 88 WEB-TYPE-REG-88 VALUE '102' '104' '106' CL*30 00069 '108' '130' '132'. CL*30 00070 88 WEB-TYPE-RPT-88 VALUE '140' '144'. CL*30 00071 88 WEB-TYPE-PAY-88 VALUE '145'. CL*30 00072 88 WEB-TYPE-PRF-88 VALUE '110' '120'. CL*30 00073 05 FILLER PIC X(01). CL*30 00074 05 WEB-IMP-EMP-NO PIC 9(06). CL*30 00075 05 FILLER PIC X(01). CL*30 00076 05 WEB-IMP-QTR PIC X(06). CL*30 00077 05 FILLER PIC X(495). CL*30 00078 CL*30 00079 CL*14 00080 CL*16 00081 FD TDEC-PEND-FILE CL*28 00082 RECORDING MODE IS F CL*16 00083 BLOCK CONTAINS 0 RECORDS CL*16 00084 LABEL RECORDS ARE OMITTED. CL*16 00085 CL*16 00086 01 TDEC-PEND-REC PIC X(512). CL*30 00087 CL*48 00088 FD REPT-PAID-FILE CL*47 00089 RECORDING MODE IS F CL*47 00090 BLOCK CONTAINS 0 RECORDS CL*47 00091 LABEL RECORDS ARE OMITTED. CL*47 00092 CL*47 00093 01 REPT-PAID-REC PIC X(133). CL*47 00094 CL*47 00095 CL*47 00096 FD REPT-PEND-FILE CL*47 00097 RECORDING MODE IS F CL*47 00098 BLOCK CONTAINS 0 RECORDS CL*47 00099 LABEL RECORDS ARE OMITTED. CL*47 00100 CL*47 00101 01 REPT-PEND-REC PIC X(133). CL*47 00102 CL*47 00103 CL*16 00104 WORKING-STORAGE SECTION. DTSBX438 001045 77 PAN-VALET PICTURE X(24) VALUE '082DTSBX438 02/05/15'. DTSBX438 00105 SKIP3 DTSBX438 00106 01 WRK-AREA. DTSBX438 00107 05 W-ABEND-CD PIC S9(04) COMP VALUE 428. CL*18 00108 05 W-MOD-NAME PIC X(08) VALUE 'DTSBX429'. CL*28 00109 DTSBX438 00110 05 W-PREV-REC-TYPE PIC X(03) VALUE SPACES. DTSBX438 00111 88 W-PREV-REC-NULL-88 VALUE 'XXX'. DTSBX438 00112 88 W-PREV-REC-PRF-88 VALUE '102'. DTSBX438 00113 88 W-PREV-REC-DETERM-88 VALUE '104'. DTSBX438 00114 88 W-PREV-REC-NAME-88 VALUE '106'. DTSBX438 00115 88 W-PREV-REC-RATE-88 VALUE '108'. DTSBX438 00116 88 W-PREV-REC-ADDR-88 VALUE '110'. DTSBX438 00117 88 W-PREV-REC-OPO-88 VALUE '120'. DTSBX438 00118 88 W-PREV-REC-REL-88 VALUE '130'. DTSBX438 00119 88 W-PREV-REC-IND-88 VALUE '132'. DTSBX438 00120 88 W-PREV-REC-RPT-88 VALUE '140'. DTSBX438 00121 88 W-PREV-REC-WAGE-88 VALUE '144'. DTSBX438 00122 88 W-PREV-REC-PAY-88 VALUE '145'. DTSBX438 00123 DTSBX438 00124 05 W-ERROR-IND PIC X(01) VALUE 'N'. DTSBX438 00125 88 W-ERROR-YES-88 VALUE 'Y'. DTSBX438 00126 88 W-ERROR-NO-88 VALUE 'N'. DTSBX438 00127 DTSBX438 00128 05 W-FATAL-ERROR-IND PIC X(01) VALUE 'N'. DTSBX438 00129 88 W-FATAL-ERROR-YES-88 VALUE 'Y'. DTSBX438 00130 88 W-FATAL-ERROR-NO-88 VALUE 'N'. DTSBX438 00131 DTSBX438 00132 05 BATCH-XREF-STATUS PIC X(02). DTSBX438 00133 88 BATCH-XREF-OK-88 VALUE '00'. DTSBX438 00134 DTSBX438 00135 05 W-EMP-FOUND-IND PIC X(01) VALUE 'N'. DTSBX438 00136 88 W-EMP-FOUND-YES-88 VALUE 'Y'. DTSBX438 00137 88 W-EMP-FOUND-NO-88 VALUE 'N'. DTSBX438 00138 DTSBX438 00139 05 W-QTR-FOUND-IND PIC X(01) VALUE 'N'. CL*21 00140 88 W-QTR-FOUND-YES-88 VALUE 'Y'. CL*21 00141 88 W-QTR-FOUND-NO-88 VALUE 'N'. CL*21 00142 CL*21 00143 05 TDEC-PAYT-STATUS PIC X(02) VALUE SPACES. CL*28 00144 88 W-TDEC-PAYT-EOF-88 VALUE '10'. CL*28 00145 88 W-TDEC-PAYT-OK-88 VALUE '00'. CL*28 00146 CL*21 00147 05 REPT-STATUS PIC X(02) VALUE SPACES. CL*50 00148 88 REPT-STATUS-EOF-88 VALUE '10'. CL*50 00149 88 REPT-STATUS-OK-88 VALUE '00'. CL*50 00150 CL*50 00151 05 W-APAY-MAX PIC S9(04) COMP VALUE +100. DTSBX438 00152 05 W-APAY-LAST PIC S9(04) COMP VALUE +0. DTSBX438 00153 05 PSUB PIC S9(04) COMP VALUE +0. DTSBX438 00154 05 W-APAY-TABLE. DTSBX438 00155 10 W-APAY-ENTRY OCCURS 100 TIMES PIC X(96). DTSBX438 00156 DTSBX438 00157 05 WRK-RETURN-CODE PIC S9(01) VALUE +0. CL*26 00158 05 W-EMP-NO PIC S9(07) COMP-3. CL*26 00159 05 W-REPORT-QTR PIC S9(05) COMP-3. DTSBX438 00160 05 W-REMITTANCE PIC S9(09)V99 VALUE 0. CL*59 00161 05 W-TOT-REMITTANCE PIC S9(09)V99 VALUE 0. CL*59 00162 05 W-TOT-PAID-REMITTANCE PIC S9(09)V99 VALUE 0. CL*59 00163 05 W-TOT-PEND-REMITTANCE PIC S9(09)V99 VALUE 0. CL*59 00164 05 W-RECEIVED-DATE PIC S9(09) COMP-3. DTSBX438 00165 05 W-DEPOSIT-DATE PIC S9(09) COMP-3. DTSBX438 00166 05 W-CHK-SCAN-DATE PIC S9(09) COMP-3. DTSBX438 00167 05 W-REMIT-AMT PIC S9(09)V99 COMP-3. DTSBX438 00168 05 W-X145-TOT-REMIT-AMT PIC S9(09)V99 VALUE 0. CL*51 00169 05 W-TRAN-CNT PIC S9(03) COMP-3. DTSBX438 00170 05 W-PEND-CNT PIC 9(05) VALUE 0. CL*37 00171 05 W-X145-TRACE-NO PIC X(13) VALUE SPACES. CL*81 00172 05 W-X145-TRACE-NO-N REDEFINES W-X145-TRACE-NO. CL*82 00173 10 W-X145-TRACE-NO-A PIC 9(08). CL*82 00174 10 W-X145-TRACE-NO-B PIC 9(05). CL*82 00175 05 W-MPRF-CNT PIC 9(05) VALUE 0. CL*37 00176 05 W-MQTR-CNT PIC 9(05) VALUE 0. CL*37 00177 05 W-ERRO-CNT PIC 9(05) VALUE 0. CL*37 00178 05 W-X145-ERR-CNT PIC 9(05) VALUE 0. CL*58 00179 05 WRK-SYS-ABSTIME PIC S9(15) COMP-3 VALUE 0. CL*16 00180 DTSBX438 00181 05 W-EARNINGS PIC S9(09)V99. DTSBX438 00182 05 W-INTEGER PIC S9(11) COMP-3. CL*33 00183 05 W-FRACTION PIC SV9(11) COMP-3. CL*33 00184 05 W-NUMBER PIC S9(11)V9(05) COMP-3. CL*33 00185 05 SUB PIC S9(4) COMP. CL*33 00186 CL*48 00187 05 WS-LINE-CNT PIC S9(02) COMP-3 VALUE 60. CL*48 00188 05 WS-LINE-CNT2 PIC S9(02) COMP-3 VALUE +0. CL*48 00189 05 WS-PAGE-CNT PIC S9(03) COMP-3 VALUE +0. CL*48 00190 CL*48 00191 DTSBX438 00192 05 W-PAY-TYPE PIC X(02). DTSBX438 00193 88 W-PA-PAY-88 VALUE 'PA'. DTSBX438 00194 88 W-OR-PAY-88 VALUE 'OR'. DTSBX438 00195 88 W-EA-PAY-88 VALUE 'EA'. DTSBX438 00196 88 W-AU-PAY-88 VALUE 'AU'. DTSBX438 00197 88 W-FS-PAY-88 VALUE 'FS'. DTSBX438 00198 88 W-AC-PAY-88 VALUE 'AC'. DTSBX438 00199 88 W-ES-PAY-88 VALUE 'ES'. DTSBX438 00200 88 W-WD-PAY-88 VALUE 'WD'. DTSBX438 00201 88 W-PAY-REV-88 VALUE 'PR'. DTSBX438 00202 88 W-REFUND-88 VALUE 'RF'. DTSBX438 00203 88 W-REF-REV-88 VALUE 'RR'. DTSBX438 00204 88 W-NG-CHECK-88 VALUE 'NG'. DTSBX438 00205 88 W-VALID-PAY-88 VALUE 'PA' 'OR' 'EA' 'AU' DTSBX438 00206 'FS' 'AC'. DTSBX438 00207 DTSBX438 00208 05 W-SEQ-NO PIC 9(07) VALUE 0. DTSBX438 00209 DTSBX438 00210 05 W-SLASH-DATE PIC X(10). DTSBX438 00211 05 FILLER REDEFINES W-SLASH-DATE. DTSBX438 00212 10 W-SLASH-DT-MM PIC X(02). DTSBX438 00213 10 FILLER PIC X(01). DTSBX438 00214 10 W-SLASH-DT-DD PIC X(02). DTSBX438 00215 10 FILLER PIC X(01). DTSBX438 00216 10 W-SLASH-DT-CCYY PIC X(04). DTSBX438 00217 DTSBX438 00218 05 W-SLASH-QTR PIC X(06). DTSBX438 00219 05 FILLER REDEFINES W-SLASH-QTR. DTSBX438 00220 10 W-SLASH-QTR-CCYY PIC X(04). DTSBX438 00221 10 FILLER PIC X(01). DTSBX438 00222 10 W-SLASH-QTR-Q PIC X(01). DTSBX438 00223 DTSBX438 00224 * PAYMENT DTSBX438 00225 05 W-X212-CNT PIC S9(07) COMP-3 VALUE +0. CL*16 00226 DTSBX438 00227 05 W-APAY-WRITE-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX438 00228 DTSBX438 00229 05 W-T025-WRITE-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX438 00230 * 05 WS-T025-WRITE-CNT PIC S9(07) COMP-3 VALUE +0. CL*57 00231 DTSBX438 00232 05 W-BX212-CNT PIC S9(07) COMP-3 VALUE +0. CL*16 00233 DTSBX438 00234 05 W-X212-LENGTH PIC S9(04) COMP. CL*16 00235 DTSBX438 00236 05 W-AMT-DISP1 PIC ----------9.99. DTSBX438 00237 05 W-AMT-DISP2 PIC ----------9.99. DTSBX438 00238 *RW1 DTSBX438 00239 05 WRK-R140-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX438 00240 05 DISPLAY-CNT PIC Z(06)9. DTSBX438 00241 05 WRK-MPRF-EMP-NO PIC 9(06). DTSBX438 00242 *RW2 DTSBX438 00243 DTSBX438 00244 01 MESSAGE-AREA. DTSBX438 00245 *** FATAL ERRORS MSG-A DTSBX438 00246 05 MSG-A1. DTSBX438 00247 10 FILLER PIC X(32) DTSBX438 00248 VALUE 'TYPE A REC NOT FIRST IN FILE: '. DTSBX438 00249 10 MSG-A1-PREV-REC-TYPE PIC X(01). DTSBX438 00250 DTSBX438 00251 01 HEADER-1. CL*47 00252 05 FILLER PIC X(01) VALUE SPACES. CL*47 00253 05 FILLER PIC X(49) VALUE '140R1'. CL*47 00254 05 FILLER PIC X(60) VALUE CL*47 00255 'DISTRICT OF COLUMBIA'. CL*47 00256 05 FILLER PIC X(06) VALUE 'DATE:'. CL*47 00257 05 HDR1-LRCM-SYS-DATE PIC X(10). CL*47 00258 01 HEADER-2. CL*47 00259 05 FILLER PIC X(54) VALUE SPACES. CL*47 00260 05 FILLER PIC X(56) VALUE CL*47 00261 'TAX DIVISION'. CL*47 00262 05 FILLER PIC X(06) VALUE 'TIME:'. CL*47 00263 05 HDR2-LRCM-SYS-TIME PIC X(08). CL*47 00264 CL*47 00265 01 HEADER-3. CL*47 00266 05 FILLER PIC X(01) VALUE SPACES. CL*47 00267 05 FILLER PIC X(38) VALUE CL*47 00268 'ROUTE TO: TAX ACCOUNTING STAFF'. CL*47 00269 05 HDR3-LITERAL PIC X(43) VALUE CL*47 00270 ' ESSP DAILY PROCESSED ACH PAYMENTS'. CL*66 00271 05 FILLER PIC X(28) VALUE SPACES. CL*47 00272 05 FILLER PIC X(06) VALUE 'PAGE:'. CL*47 00273 05 HDR3-PAGE PIC ZZ,ZZ9. CL*47 00274 CL*47 00275 01 HEADER-4. CL*47 00276 05 FILLER PIC X(01) VALUE SPACES. CL*47 00277 05 FILLER PIC X(132) VALUE SPACES. CL*47 00278 01 HEADER-5. CL*47 00279 05 FILLER PIC X(02) VALUE SPACES. CL*47 00280 05 FILLER PIC X(34) VALUE CL*47 00281 'EMP NO EMPLOYER NAME '. CL*53 00282 05 FILLER PIC X(04) VALUE SPACES. CL*53 00283 05 FILLER PIC X(34) VALUE CL*47 00284 'QTR RECV-DATE PAID-AMT'. CL*54 00285 05 FILLER PIC X(04) VALUE SPACES. CL*71 00286 05 FILLER PIC X(09) VALUE CL*71 00287 'TRACE NO '. CL*71 00288 05 FILLER PIC X(02) VALUE SPACES. CL*47 00289 05 HDR5-NAME PIC X(28) VALUE CL*47 00290 ' DISPOSITION OF PAYMTS'. CL*64 00291 CL*47 00292 01 HEADER-6. CL*47 00293 05 FILLER PIC X(01) VALUE SPACES. CL*47 00294 05 FILLER PIC X(132) VALUE SPACES. CL*47 00295 CL*48 00296 01 DETAIL-LINE-1. CL*47 00297 15 FILLER PIC X(02) VALUE SPACES. CL*47 00298 15 X434-EMP-NO PIC 999B999 BLANK WHEN ZERO. CL*47 00299 15 FILLER PIC X(02) VALUE SPACES. CL*47 00300 15 X434-NAME-CHECK PIC X(24) VALUE SPACES. CL*48 00301 15 FILLER PIC X(02) VALUE SPACES. CL*47 00302 15 X434-QTR PIC X(06). CL*47 00303 15 FILLER PIC X(02) VALUE SPACES. CL*47 00304 15 X434-RCVD-DATE PIC X(10). CL*47 00305 15 FILLER PIC X(05) VALUE SPACES. CL*48 00306 15 X434-X145-REMIT PIC -------9.99. CL*47 00307 15 FILLER PIC X(05) VALUE SPACES. CL*48 00308 15 X434-X145-TRACE PIC X(08) VALUE SPACES. CL*72 00309 15 FILLER PIC X(05) VALUE SPACES. CL*71 00310 15 X434-MESSAGE PIC X(20). CL*48 00311 CL*47 00312 01 DETAIL-PEND-1. CL*47 00313 15 FILLER PIC X(02) VALUE SPACES. CL*47 00314 15 P434-EMP-NO PIC 999B999 BLANK WHEN ZERO. CL*47 00315 15 FILLER PIC X(02) VALUE SPACES. CL*47 00316 15 P434-NAME-CHECK PIC X(24) VALUE SPACES. CL*48 00317 15 FILLER PIC X(02) VALUE SPACES. CL*47 00318 15 P434-QTR PIC X(06). CL*47 00319 15 FILLER PIC X(02) VALUE SPACES. CL*47 00320 15 P434-RCVD-DATE PIC X(10). CL*47 00321 15 FILLER PIC X(05) VALUE SPACES. CL*48 00322 15 P434-X145-REMIT PIC --------9.99. CL*47 00323 15 FILLER PIC X(05) VALUE SPACES. CL*71 00324 15 P434-X145-TRACE PIC X(08) VALUE SPACES. CL*71 00325 15 FILLER PIC X(05) VALUE SPACES. CL*48 00326 15 P434-MESSAGE PIC X(30). CL*47 00327 CL*47 00328 01 FOOTING-LINE-1 PIC X(133) VALUE SPACES. CL*47 00329 01 FOOTING-LINE-2 PIC X(133) VALUE SPACES. CL*47 00330 CL*47 00331 01 FOOTING-LINE-3. CL*47 00332 05 FILLER PIC X(25) VALUE SPACES. CL*47 00333 05 WS-FOOTING-CNT PIC ZZ,ZZ9. CL*47 00334 05 FILLER PIC X(02) VALUE SPACES. CL*47 00335 05 FILLER PIC X(45) VALUE CL*47 00336 ' TOTAL ACH PAYMENTS RECEIVED'. CL*66 00337 05 FILLER PIC X(32) VALUE SPACES. CL*47 00338 CL*47 00339 01 FOOTING-LINE-4. CL*47 00340 05 FILLER PIC X(25) VALUE SPACES. CL*47 00341 05 WS-X145-ERR-CNT PIC ZZ,ZZ9. CL*47 00342 05 FILLER PIC X(02) VALUE SPACES. CL*47 00343 05 FILLER PIC X(34) VALUE CL*47 00344 ' # OF ACH PAYMENTS HAD ERRORS '. CL*66 00345 05 FILLER PIC X(32) VALUE SPACES. CL*47 00346 CL*47 00347 01 FOOTING-LINE-5. CL*47 00348 05 FILLER PIC X(25) VALUE SPACES. CL*47 00349 05 WS-X145-PEN-CNT PIC ZZ,ZZ9. CL*47 00350 05 FILLER PIC X(02) VALUE SPACES. CL*47 00351 05 FILLER PIC X(40) VALUE CL*47 00352 ' # OF ACH PAYMTS WENT TO PENDING FILE '. CL*66 00353 05 FILLER PIC X(32) VALUE SPACES. CL*47 00354 01 FOOTING-LINE-6. CL*56 00355 05 FILLER PIC X(25) VALUE SPACES. CL*56 00356 05 WS-T025-WRITE-CNT PIC ZZ,ZZ9. CL*56 00357 05 FILLER PIC X(02) VALUE SPACES. CL*56 00358 05 FILLER PIC X(45) VALUE CL*67 00359 ' # OF ACH PAYMENTS WAITING FOR PROCESSING '. CL*66 00360 05 FILLER PIC X(32) VALUE SPACES. CL*56 00361 01 FOOTING-LINE-7. CL*56 00362 05 FILLER PIC X(19) VALUE SPACES. CL*47 00363 05 WS-TOT-REMIT PIC $$$$$$$$9.99. CL*47 00364 05 FILLER PIC X(02) VALUE SPACES. CL*47 00365 05 FILLER PIC X(45) VALUE CL*47 00366 ' TOTAL ACH PAYMENTS TO BE PROCESSED '. CL*66 00367 05 FILLER PIC X(32) VALUE SPACES. CL*47 00368 CL*47 00369 01 FOOTING-LINE-8. CL*56 00370 05 FILLER PIC X(19) VALUE SPACES. CL*56 00371 05 WS-TOTAL-REMIT PIC $$$$$$$$9.99. CL*56 00372 05 FILLER PIC X(02) VALUE SPACES. CL*56 00373 05 FILLER PIC X(45) VALUE CL*56 00374 'TOTAL ACH PAYMENTS RECEIVED FROM ESSP'. CL*66 00375 05 FILLER PIC X(32) VALUE SPACES. CL*56 00376 CL*56 00377 01 FOOTING-LINE-13. CL*47 00378 05 FILLER PIC X(25) VALUE SPACES. CL*47 00379 05 FILLER PIC X(67) VALUE CL*47 00380 '*** END ESSP/DUTAS DAILY ACH PAYMNT PROCESSING ***'. CL*66 00381 01 FOOTING-LINE-14 PIC X(133) VALUE SPACES. CL*47 00382 CL*47 00383 CL*47 00384 CL*47 00385 01 T025-REC. DTSBX438 00386 ++INCLUDE DTSIT025 DTSBX438 00387 DTSBX438 00388 * REPORT DTSBX438 00389 01 X140-REC. DTSBX438 00390 ++INCLUDE DTSIX140 DTSBX438 00391 DTSBX438 00392 * PAYMENT DTSBX438 00393 01 X145-REC. DTSBX438 00394 ++INCLUDE DTSIX145 DTSBX438 00395 DTSBX438 00396 * ICESA-REPT-FILE CL*16 00397 01 X212-REC. CL*16 00398 ++INCLUDE DTSIX212 CL*20 00399 CL*16 00400 * BATCH - PSEUDO-BATCH XREF DTSBX438 00401 01 X214-REC. DTSBX438 00402 ++INCLUDE DTSIX214 DTSBX438 00403 DTSBX438 00404 * ERRORS DTSBX438 00405 *01 X907-REC. DTSBX438 00406 ***INCLUDE DTSIX907 DTSBX438 00407 DTSBX438 00408 01 L001-LINK-AREA. DTSBX438 00409 ++INCLUDE DTSIL001 DTSBX438 00410 DTSBX438 00411 01 L003-LINK-AREA. DTSBX438 00412 ++INCLUDE DTSIL003 DTSBX438 00413 DTSBX438 00414 01 L004-LINK-AREA. DTSBX438 00415 ++INCLUDE DTSIL004 DTSBX438 00416 DTSBX438 00417 CL*16 00418 01 L005-LINK-AREA. CL*16 00419 ++INCLUDE DTSIL005 CL*16 00420 CL*31 00421 01 L205-LINK-AREA. CL*31 00422 ++INCLUDE DTSIL205 CL*31 00423 CL*16 00424 01 L910-LINK-AREA. DTSBX438 00425 ++INCLUDE DTSIL910 DTSBX438 00426 01 MSKL-REC. DTSBX438 00427 ++INCLUDE DTSIMSKL DTSBX438 00428 DTSBX438 00429 01 MHDR-REC. DTSBX438 00430 ++INCLUDE DTSIMHDR DTSBX438 00431 DTSBX438 00432 01 MQTR-REC. CL*17 00433 ++INCLUDE DTSIMQTR CL*17 00434 CL*17 00435 01 MPRF-REC. DTSBX438 00436 ++INCLUDE DTSIMPRF DTSBX438 00437 DTSBX438 00438 01 MPAY-REC. DTSBX438 00439 ++INCLUDE DTSIMPAY DTSBX438 00440 DTSBX438 00441 01 MNTE-REC. DTSBX438 00442 ++INCLUDE DTSIMNTE DTSBX438 00443 DTSBX438 00444 01 L921-LINK-AREA. DTSBX438 00445 ++INCLUDE DTSIL921 DTSBX438 00446 SKIP3 DTSBX438 00447 01 ISKL-REC. DTSBX438 00448 ++INCLUDE DTSIISKL DTSBX438 00449 SKIP3 DTSBX438 00450 01 IEIN-REC. DTSBX438 00451 ++INCLUDE DTSIIEIN DTSBX438 00452 DTSBX438 00453 01 L923-LINK-AREA. DTSBX438 00454 ++INCLUDE DTSIL923 DTSBX438 00455 EJECT DTSBX438 00456 01 ASKL-REC. DTSBX438 00457 ++INCLUDE DTSIASKL DTSBX438 00458 EJECT DTSBX438 00459 01 AHDR-REC. DTSBX438 00460 ++INCLUDE DTSIAHDR DTSBX438 00461 EJECT DTSBX438 00462 01 ARPT-REC. DTSBX438 00463 ++INCLUDE DTSIARPT DTSBX438 00464 EJECT DTSBX438 00465 01 APAY-REC. DTSBX438 00466 ++INCLUDE DTSIAPAY DTSBX438 00467 DTSBX438 00468 01 L927-LINK-AREA. DTSBX438 00469 ++INCLUDE DTSIL927 DTSBX438 00470 DTSBX438 00471 01 TSKL-REC. DTSBX438 00472 ++INCLUDE DTSITSKL DTSBX438 00473 DTSBX438 00474 01 L931-LINK-AREA. DTSBX438 00475 ++INCLUDE DTSIL931 DTSBX438 00476 DTSBX438 00477 01 FSKL-REC. DTSBX438 00478 ++INCLUDE DTSIFSKL DTSBX438 00479 DTSBX438 00480 01 R140-REC. DTSBX438 00481 ++INCLUDE DTSIR140 DTSBX438 00482 DTSBX438 00483 LINKAGE SECTION. DTSBX438 00484 DTSBX438 00485 *01 LX42-LINK-AREA. CL*14 00486 *++INCLUDE DTSILX42 CL*14 00487 DTSBX438 00488 PROCEDURE DIVISION. CL*14 00489 DTSBX438 00490 DTSBX423-MAIN. DTSBX438 00491 PERFORM I0000-INITIATE THRU I0000-EXIT. CL*27 00492 DTSBX438 00493 IF W-ERROR-YES-88 CL*27 00494 MOVE WRK-RETURN-CODE TO RETURN-CODE CL*40 00495 GO TO DTSBX423-MAIN-EXIT. CL*27 00496 CL*27 00497 PERFORM P0000-PROCESS THRU P0000-EXIT. CL*27 00498 DTSBX438 00499 PERFORM T0000-TERMINATE THRU T0000-EXIT. CL*27 00500 MOVE WRK-RETURN-CODE TO RETURN-CODE. CL*40 00501 DTSBX438 00502 DTSBX438 00503 DTSBX423-MAIN-EXIT. DTSBX438 00504 GOBACK. DTSBX438 00505 DTSBX438 00506 I0000-INITIATE. DTSBX438 00507 SET W-ERROR-NO-88 TO TRUE. DTSBX438 00508 SET W-FATAL-ERROR-NO-88 TO TRUE. DTSBX438 00509 MOVE +0 TO WRK-RETURN-CODE CL*25 00510 DTSBX438 00511 MOVE LENGTH OF R140-REC TO R140-LENGTH. DTSBX438 00512 MOVE '140' TO R140-REC-TYPE. DTSBX438 00513 DTSBX438 00514 PERFORM I2000-OPEN-FILES THRU I2000-EXIT. DTSBX438 00515 CL*16 00516 PERFORM S005-FROM-SYS THRU S005-EXIT. CL*16 00517 MOVE L005-ABSTIME TO WRK-SYS-ABSTIME. CL*16 00518 MOVE L005-SLASH-DATE TO W-SLASH-DATE. CL*49 00519 DISPLAY 'SYS DATE ' W-SLASH-DATE. CL*49 00520 MOVE W-SLASH-DATE TO HDR1-LRCM-SYS-DATE. CL*49 00521 CL*16 00522 PERFORM S910-OPEN-READ THRU S910-EXIT. CL*35 00523 PERFORM S927A-OPEN THRU S927A-EXIT. CL*42 00524 DTSBX438 00525 I0000-EXIT. DTSBX438 00526 EXIT. DTSBX438 00527 DTSBX438 00528 I2000-OPEN-FILES. DTSBX438 00529 DTSBX438 00530 OPEN INPUT TDEC-PAYT-FILE. CL*29 00531 IF W-TDEC-PAYT-EOF-88 CL*29 00532 DISPLAY 'NO TDEC PAYMENT FILES TO PROCESS ' CL*29 00533 MOVE +3 TO WRK-RETURN-CODE CL*27 00534 SET W-ERROR-YES-88 TO TRUE CL*27 00535 END-IF. CL*14 00536 CL*16 00537 OPEN OUTPUT TDEC-PEND-FILE. CL*29 00538 IF BATCH-XREF-OK-88 CL*16 00539 NEXT SENTENCE CL*16 00540 ELSE CL*16 00541 DISPLAY 'CANNOT OPEN TDEC PEND FILE ' CL*29 00542 BATCH-XREF-STATUS CL*16 00543 PERFORM S999-ABEND THRU S999-EXIT CL*16 00544 END-IF. CL*16 00545 OPEN OUTPUT REPT-PEND-FILE. CL*47 00546 IF REPT-STATUS-OK-88 CL*47 00547 NEXT SENTENCE CL*47 00548 ELSE CL*47 00549 DISPLAY 'CANNOT OPEN REPORT PENDING FILE ' CL*47 00550 REPT-STATUS CL*47 00551 PERFORM S999-ABEND THRU S999-EXIT CL*47 00552 END-IF. CL*47 00553 CL*47 00554 OPEN OUTPUT REPT-PAID-FILE. CL*47 00555 IF REPT-STATUS-OK-88 CL*47 00556 NEXT SENTENCE CL*47 00557 ELSE CL*47 00558 DISPLAY 'CANNOT OPEN REPORT PAID FILE ' CL*47 00559 REPT-STATUS CL*47 00560 PERFORM S999-ABEND THRU S999-EXIT CL*47 00561 END-IF. CL*47 00562 CL*16 00563 I2000-EXIT. DTSBX438 00564 EXIT. DTSBX438 00565 DTSBX438 00566 P0000-PROCESS. DTSBX438 00567 READ TDEC-PAYT-FILE CL*33 00568 CL*25 00569 IF W-TDEC-PAYT-EOF-88 CL*29 00570 DISPLAY 'TDEC INPUT FILE IS EMPTY ' CL*29 00571 MOVE +3 TO WRK-RETURN-CODE CL*25 00572 GO TO P0000-EXIT CL*25 00573 END-IF. CL*25 00574 CL*25 00575 PERFORM UNTIL W-TDEC-PAYT-EOF-88 CL*29 00576 PERFORM P1100-PARSE-TDEC-PAYT-REC THRU P1100-EXIT CL*30 00577 IF W-ERROR-NO-88 CL*31 00578 PERFORM P2100-PAYMENT THRU P2100-EXIT CL*25 00579 END-IF CL*31 00580 READ TDEC-PAYT-FILE CL*33 00581 END-PERFORM. CL*25 00582 CL*25 00583 DTSBX438 00584 P0000-EXIT. DTSBX438 00585 EXIT. DTSBX438 00586 P1100-PARSE-TDEC-PAYT-REC. CL*33 00587 SET W-ERROR-NO-88 TO TRUE. CL*36 00588 CL*30 00589 PERFORM CL*30 00590 VARYING SUB FROM +1 BY +1 CL*30 00591 UNTIL SUB > +100 CL*30 00592 MOVE +0 TO L205-FIELD-LENGTH (SUB) CL*30 00593 L205-INTEGER (SUB) CL*30 00594 L205-FRACTION (SUB) CL*30 00595 MOVE SPACES TO L205-TEXT (SUB) CL*30 00596 L205-DATE (SUB) CL*30 00597 SET L205-TYPE-TEXT-88 (SUB) TO TRUE CL*30 00598 END-PERFORM. CL*30 00599 CL*30 00600 IF WEB-IMP-TYPE-PAY-88 CL*30 00601 PERFORM P1100J-SET-205-FIELDS THRU P1100J-EXIT CL*31 00602 ELSE CL*30 00603 SET W-ERROR-YES-88 TO TRUE CL*30 00604 DISPLAY ' RECORD IS NOT PAY TYPE ' CL*30 00605 END-IF. CL*30 00606 DTSBX438 00607 CL*31 00608 * DISPLAY ' **** GOING TO 205 EDIT ESSP RECS ' CL*31 00609 * DISPLAY ' **** ' CL*31 00610 CL*31 00611 IF W-ERROR-NO-88 CL*31 00612 MOVE TDEC-PAYT-REC TO L205-INPUT-DATA CL*31 00613 CALL 'DTSBU205' USING L205-LINK-AREA CL*31 00614 PERFORM P1100K-BUILD-X145-REC THRU P1100K-EXIT. CL*31 00615 CL*31 00616 CL*31 00617 P1100-EXIT. CL*31 00618 EXIT. CL*31 00619 CL*31 00620 P1100J-SET-205-FIELDS. CL*31 00621 DISPLAY 'P1100J-PAY ' TDEC-PAYT-REC(1:84). CL*31 00622 INITIALIZE X145-REC. CL*31 00623 MOVE +12 TO L205-LAST-FIELD. CL*31 00624 MOVE +8 TO L205-LAST-FIELD-LEN. CL*31 00625 CL*31 00626 MOVE +3 TO L205-FIELD-LENGTH (1). CL*31 00627 SET L205-TYPE-TEXT-88 (1) TO TRUE. CL*31 00628 CL*31 00629 MOVE +6 TO L205-FIELD-LENGTH (2). CL*31 00630 SET L205-TYPE-TEXT-88 (2) TO TRUE. CL*31 00631 CL*31 00632 MOVE +6 TO L205-FIELD-LENGTH (3). CL*31 00633 SET L205-TYPE-TEXT-88 (3) TO TRUE. CL*31 00634 CL*31 00635 MOVE +6 TO L205-FIELD-LENGTH (4). CL*31 00636 SET L205-TYPE-TEXT-88 (4) TO TRUE. CL*31 00637 MOVE +3 TO L205-FIELD-LENGTH (5). CL*31 00638 SET L205-TYPE-TEXT-88 (5) TO TRUE. CL*31 00639 CL*31 00640 MOVE +2 TO L205-FIELD-LENGTH (6). CL*31 00641 SET L205-TYPE-TEXT-88 (6) TO TRUE. CL*31 00642 CL*31 00643 MOVE +2 TO L205-FIELD-LENGTH (7). CL*31 00644 SET L205-TYPE-TEXT-88 (7) TO TRUE. CL*31 00645 CL*31 00646 MOVE +2 TO L205-FIELD-LENGTH (8). CL*31 00647 SET L205-TYPE-TEXT-88 (8) TO TRUE. CL*31 00648 CL*31 00649 MOVE +14 TO L205-FIELD-LENGTH (9). CL*31 00650 SET L205-TYPE-NUMBER-88 (9) TO TRUE. CL*31 00651 MOVE +10 TO L205-FIELD-LENGTH (10). CL*31 00652 SET L205-TYPE-TEXT-88 (10) TO TRUE. CL*31 00653 CL*31 00654 MOVE +10 TO L205-FIELD-LENGTH (11). CL*31 00655 SET L205-TYPE-TEXT-88 (11) TO TRUE. CL*31 00656 CL*31 00657 MOVE +8 TO L205-FIELD-LENGTH (12). CL*31 00658 SET L205-TYPE-TEXT-88 (12) TO TRUE. CL*31 00659 CL*31 00660 CL*31 00661 P1100J-EXIT. CL*31 00662 EXIT. CL*31 00663 CL*31 00664 P1100K-BUILD-X145-REC. CL*31 00665 MOVE L205-TEXT (1) (1:03) TO X145-REC-TYPE. CL*31 00666 CL*31 00667 MOVE L205-TEXT (2) (1:06) TO X145-EMP-NO. CL*31 00668 CL*31 00669 MOVE '0' TO X145-SOURCE. CL*31 00670 CL*31 00671 MOVE L205-TEXT (3) (1:06) TO X145-QTR. CL*31 00672 * DISPLAY 'X145 QTR ' X145-QTR. CL*46 00673 CL*31 00674 MOVE L205-TEXT (8) (1:02) TO X145-PAY-TYPE. CL*31 00675 * DISPLAY 'X145 PAY TYPE ' X145-PAY-TYPE. CL*46 00676 CL*31 00677 MOVE L205-INTEGER (9) TO W-INTEGER. CL*31 00678 MOVE L205-FRACTION (9) TO W-FRACTION. CL*31 00679 COMPUTE W-NUMBER = W-INTEGER + W-FRACTION. CL*31 00680 MOVE W-NUMBER TO X145-REMITTANCE. CL*31 00681 * DISPLAY 'X145 PAY AMT ' X145-REMITTANCE. CL*46 00682 CL*31 00683 MOVE L205-TEXT (10) (1:10) TO X145-RCVD-DATE. CL*31 00684 * DISPLAY 'X145 PAY DATE ' X145-RCVD-DATE. CL*46 00685 CL*31 00686 MOVE L205-TEXT (12) TO X145-TRACE-NO CL*78 00687 W-X145-TRACE-NO. CL*78 00688 DISPLAY 'X145 PAY NO ' X145-TRACE-NO. CL*78 00689 DISPLAY 'W145 PAY NO ' W-X145-TRACE-NO. CL*78 00690 DISPLAY 'N145 PAY NO ' W-X145-TRACE-NO-N. CL*79 00691 DISPLAY 'A145 PAY NO ' W-X145-TRACE-NO-A. CL*82 00692 * MOVE X145-TRACE-NO TO W-X145-TRACE-NO CL*74 00693 CL*31 00694 CL*31 00695 MOVE ZEROS TO X145-PSEUDO-BATCH. CL*31 00696 CL*31 00697 MOVE ZEROS TO X145-PSEUDO-ITEM. CL*31 00698 CL*31 00699 MOVE SPACES TO X145-APPLIC-ACCT. CL*31 00700 CL*31 00701 MOVE SPACES TO X145-CHECK-SCAN-DT. CL*31 00702 CL*31 00703 MOVE ZEROS TO X145-CHECK-SEQ-NBR. CL*31 00704 CL*31 00705 MOVE 'N' TO X145-WAIVE-INTEREST. CL*31 00706 CL*31 00707 MOVE 'N' TO X145-WAIVE-PENALTY. CL*31 00708 CL*31 00709 MOVE 'VOL' TO X145-RESP-ACTIVITY. CL*31 00710 CL*31 00711 MOVE 'WEBESSP ' TO X145-RESP-OPID. CL*69 00712 CL*31 00713 P1100K-EXIT. CL*31 00714 EXIT. CL*31 00715 CL*31 00716 P2100-PAYMENT. DTSBX438 00717 MOVE X145-EMP-NO TO W-EMP-NO. CL*29 00718 * DISPLAY ' EMP NO ' W-EMP-NO. CL*46 00719 SET W-EMP-FOUND-YES-88 TO TRUE. CL*47 00720 DTSBX438 00721 SET W-QTR-FOUND-NO-88 TO TRUE. CL*17 00722 SET W-ERROR-NO-88 TO TRUE CL*17 00723 DTSBX438 00724 ADD +1 TO W-X212-CNT. CL*29 00725 CL*29 00726 PERFORM P2110-EDIT-PAYMENT THRU P2110-EXIT. CL*29 00727 CL*47 00728 IF W-EMP-FOUND-NO-88 OR CL*47 00729 W-ERROR-YES-88 CL*47 00730 ADD 1 TO W-PEND-CNT CL*48 00731 ADD 1 TO W-MPRF-CNT CL*48 00732 ADD 1 TO W-ERRO-CNT CL*48 00733 ADD 1 TO W-X145-ERR-CNT CL*57 00734 ADD W-REMITTANCE TO W-TOT-PEND-REMITTANCE CL*57 00735 WRITE TDEC-PEND-REC FROM TDEC-PAYT-REC CL*47 00736 MOVE R140-MESSAGE TO P434-MESSAGE CL*48 00737 PERFORM P3000-WRITE-PAID-RPT THRU P3000-EXIT CL*48 00738 GO TO P2100-EXIT. CL*47 00739 CL*47 00740 CL*29 00741 CL*48 00742 PERFORM P2120-SAVE-EXT-PAY THRU P2120-EXIT CL*47 00743 ADD W-REMITTANCE TO W-TOT-PAID-REMITTANCE CL*57 00744 MOVE 'RECEIVED ' TO P434-MESSAGE CL*65 00745 PERFORM P3000-WRITE-PAID-RPT THRU P3000-EXIT. CL*48 00746 DTSBX438 00747 P2100-EXIT. DTSBX438 00748 EXIT. DTSBX438 00749 DTSBX438 00750 P2110-EDIT-PAYMENT. DTSBX438 00751 MOVE X145-PAY-TYPE TO W-PAY-TYPE. CL*69 00752 IF W-VALID-PAY-88 CL*69 00753 NEXT SENTENCE CL*69 00754 ELSE CL*69 00755 SET W-ERROR-YES-88 TO TRUE CL*69 00756 MOVE SPACES TO R140-MESSAGE CL*69 00757 MOVE W-EMP-NO TO R140-EMP-NO CL*69 00758 STRING CL*69 00759 'INVALID PAYMENT TYPE ' CL*69 00760 X145-PAY-TYPE CL*69 00761 DELIMITED BY SIZE CL*69 00762 INTO R140-MESSAGE CL*69 00763 END-STRING CL*69 00764 PERFORM S946-WRITE-R140 THRU S946-EXIT CL*69 00765 DISPLAY R140-MESSAGE CL*69 00766 END-IF. CL*69 00767 DTSBX438 00768 MOVE SPACES TO W-SLASH-QTR. CL*24 00769 IF X145-QTR = SPACES CL*29 00770 MOVE ZEROS TO W-REPORT-QTR DTSBX438 00771 ELSE DTSBX438 00772 MOVE X145-QTR TO W-SLASH-QTR CL*29 00773 MOVE W-SLASH-QTR-CCYY TO L004-QTR-5-YR DTSBX438 00774 MOVE W-SLASH-QTR-Q TO L004-QTR-5-Q DTSBX438 00775 PERFORM S004-FROM-5 THRU S004-EXIT DTSBX438 00776 IF NOT L004-VALID-QTR DTSBX438 00777 SET W-ERROR-YES-88 TO TRUE DTSBX438 00778 MOVE SPACES TO R140-MESSAGE DTSBX438 00779 MOVE W-EMP-NO TO R140-EMP-NO DTSBX438 00780 STRING DTSBX438 00781 'PEND: INV PAY QUARTER ' W-SLASH-QTR CL*63 00782 DELIMITED BY SIZE DTSBX438 00783 INTO R140-MESSAGE DTSBX438 00784 END-STRING DTSBX438 00785 PERFORM S946-WRITE-R140 THRU S946-EXIT DTSBX438 00786 DISPLAY R140-MESSAGE DTSBX438 00787 MOVE +2 TO WRK-RETURN-CODE CL*25 00788 ELSE DTSBX438 00789 MOVE L004-QTR-5-9 TO W-REPORT-QTR DTSBX438 00790 END-IF DTSBX438 00791 END-IF. DTSBX438 00792 DTSBX438 00793 MOVE X145-REMITTANCE TO W-REMITTANCE. CL*29 00794 * DISPLAY 'WREMITTANCE ' W-REMITTANCE. CL*46 00795 * DISPLAY 'XREMITTANCE ' X145-REMITTANCE. CL*46 00796 CL*38 00797 ADD W-REMITTANCE TO W-TOT-REMITTANCE. CL*57 00798 IF W-REMITTANCE = ZEROS CL*39 00799 * SET W-ERROR-YES-88 TO TRUE CL*64 00800 MOVE SPACES TO R140-MESSAGE CL*38 00801 MOVE W-EMP-NO TO R140-EMP-NO CL*38 00802 STRING CL*38 00803 'INVALID REMITTANCE AMOUNT ' X145-REMITTANCE CL*38 00804 DELIMITED BY SIZE CL*38 00805 INTO R140-MESSAGE CL*38 00806 END-STRING CL*38 00807 PERFORM S946-WRITE-R140 THRU S946-EXIT CL*38 00808 DISPLAY R140-MESSAGE CL*38 00809 * MOVE +2 TO WRK-RETURN-CODE CL*64 00810 END-IF. CL*38 00811 CL*38 00812 DTSBX438 00813 MOVE X145-RCVD-DATE TO W-SLASH-DATE CL*30 00814 MOVE W-SLASH-DT-MM TO L001-FED-8-MO DTSBX438 00815 MOVE W-SLASH-DT-DD TO L001-FED-8-DA DTSBX438 00816 MOVE W-SLASH-DT-CCYY TO L001-FED-8-YR DTSBX438 00817 PERFORM S001-FROM-FED-8 THRU S001-EXIT DTSBX438 00818 IF NOT L001-VALID-DATE DTSBX438 00819 SET W-ERROR-YES-88 TO TRUE DTSBX438 00820 MOVE SPACES TO R140-MESSAGE DTSBX438 00821 MOVE W-EMP-NO TO R140-EMP-NO DTSBX438 00822 STRING DTSBX438 00823 'INVALID PAY RECEIVED DATE ' X145-RCVD-DATE CL*30 00824 DELIMITED BY SIZE DTSBX438 00825 INTO R140-MESSAGE DTSBX438 00826 END-STRING DTSBX438 00827 PERFORM S946-WRITE-R140 THRU S946-EXIT DTSBX438 00828 DISPLAY R140-MESSAGE DTSBX438 00829 MOVE +2 TO WRK-RETURN-CODE CL*25 00830 ELSE DTSBX438 00831 MOVE L001-FED-8-DATE-9 TO W-RECEIVED-DATE DTSBX438 00832 END-IF. DTSBX438 00833 DTSBX438 00834 * MOVE X212-DEPOSIT-DT TO W-SLASH-DATE CL*29 00835 * MOVE W-SLASH-DT-MM TO L001-FED-8-MO CL*29 00836 * MOVE W-SLASH-DT-DD TO L001-FED-8-DA CL*29 00837 * MOVE W-SLASH-DT-CCYY TO L001-FED-8-YR CL*29 00838 * PERFORM S001-FROM-FED-8 THRU S001-EXIT CL*29 00839 * IF NOT L001-VALID-DATE CL*29 00840 * SET W-ERROR-YES-88 TO TRUE CL*29 00841 * MOVE SPACES TO R140-MESSAGE CL*29 00842 * MOVE W-EMP-NO TO R140-EMP-NO CL*29 00843 * STRING CL*29 00844 * 'INVALID DEPOSIT DATE ' X212-DEPOSIT-DT CL*29 00845 * DELIMITED BY SIZE CL*29 00846 * INTO R140-MESSAGE CL*29 00847 * END-STRING CL*29 00848 * PERFORM S946-WRITE-R140 THRU S946-EXIT CL*29 00849 * DISPLAY R140-MESSAGE CL*11 00850 * MOVE +2 TO WRK-RETURN-CODE CL*29 00851 * ELSE CL*29 00852 * MOVE L001-FED-8-DATE-9 TO W-DEPOSIT-DATE CL*29 00853 * END-IF. CL*11 00854 DTSBX438 00855 PERFORM P2112-CHECK-DATABASE THRU P2112-EXIT. CL*17 00856 P2110-EXIT. DTSBX438 00857 EXIT. DTSBX438 00858 DTSBX438 00859 P2112-CHECK-DATABASE. DTSBX438 00860 MOVE LOW-VALUE TO MPRF-KEY-AREA. DTSBX438 00861 MOVE W-EMP-NO TO MPRF-EMP-NO. DTSBX438 00862 SET MPRF-PRF-88 TO TRUE. DTSBX438 00863 MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA. DTSBX438 00864 DTSBX438 00865 PERFORM S910-READ THRU S910-EXIT. DTSBX438 00866 IF L910-NO-REC-88 DTSBX438 00867 SET W-ERROR-YES-88 TO TRUE CL*25 00868 SET W-EMP-FOUND-NO-88 TO TRUE DTSBX438 00869 DISPLAY 'PAYMENT: EMPLOYER NOT ON FILE ' W-EMP-NO CL*45 00870 MOVE SPACES TO R140-MESSAGE CL*15 00871 MOVE W-EMP-NO TO R140-EMP-NO CL*15 00872 STRING CL*15 00873 'PEND: EMP NOT ON DUTAS' CL*62 00874 X145-EMP-NO CL*30 00875 DELIMITED BY SIZE CL*15 00876 INTO R140-MESSAGE CL*15 00877 END-STRING CL*15 00878 PERFORM S946-WRITE-R140 THRU S946-EXIT CL*15 00879 MOVE +2 TO WRK-RETURN-CODE CL*41 00880 * DISPLAY R140-MESSAGE CL*16 00881 ELSE DTSBX438 00882 MOVE MSKL-REC TO MPRF-REC DTSBX438 00883 SET W-EMP-FOUND-YES-88 TO TRUE DTSBX438 00884 END-IF. DTSBX438 00885 DTSBX438 00886 IF W-EMP-FOUND-NO-88 OR CL*62 00887 W-ERROR-YES-88 CL*62 00888 * WRITE TDEC-PEND-REC FROM TDEC-PAYT-REC CL*47 00889 * ADD 1 TO W-PEND-CNT CL*47 00890 * ADD 1 TO W-MPRF-CNT CL*47 00891 * ADD 1 TO W-ERRO-CNT CL*47 00892 GO TO P2112-EXIT. CL*62 00893 CL*16 00894 * IF EMPLOYER IS FOUND ON THE MPRF CHECK IF REPORT FOUND. CL*16 00895 * IF EITHER IS NOT FOUND WRITE T025 REC TO PENDING FILE. CL*16 00896 CL*16 00897 MOVE LOW-VALUE TO MQTR-KEY-AREA. CL*22 00898 MOVE W-EMP-NO TO MQTR-EMP-NO. CL*17 00899 MOVE W-REPORT-QTR TO MQTR-YRQ. CL*22 00900 SET MQTR-QTR-88 TO TRUE. CL*16 00901 MOVE MQTR-KEY-AREA TO MSKL-KEY-AREA. CL*16 00902 CL*16 00903 PERFORM S910-READ THRU S910-EXIT. CL*16 00904 IF L910-NO-REC-88 CL*16 00905 * SET W-ERROR-YES-88 TO TRUE CL*45 00906 SET W-QTR-FOUND-NO-88 TO TRUE CL*17 00907 DISPLAY 'PAYMENT: EMPL QTR NOT ON FILE ' W-EMP-NO CL*45 00908 MOVE SPACES TO R140-MESSAGE CL*16 00909 MOVE W-EMP-NO TO R140-EMP-NO CL*16 00910 STRING CL*16 00911 'REPT: QTR RPT NOT ON FILE ' CL*64 00912 X145-EMP-NO ' QTR' W-SLASH-QTR CL*30 00913 DELIMITED BY SIZE CL*16 00914 INTO R140-MESSAGE CL*16 00915 END-STRING CL*16 00916 PERFORM S946-WRITE-R140 THRU S946-EXIT CL*16 00917 * MOVE +2 TO WRK-RETURN-CODE CL*45 00918 * DISPLAY R140-MESSAGE CL*16 00919 ELSE CL*17 00920 SET W-QTR-FOUND-YES-88 TO TRUE CL*17 00921 END-IF. CL*16 00922 CL*16 00923 * IF W-QTR-FOUND-NO-88 OR CL*47 00924 * W-ERROR-YES-88 CL*47 00925 * WRITE TDEC-PEND-REC FROM TDEC-PAYT-REC CL*45 00926 * ADD 1 TO W-MQTR-CNT CL*47 00927 * ADD 1 TO W-ERRO-CNT CL*47 00928 * ADD 1 TO W-PEND-CNT. CL*47 00929 CL*16 00930 P2112-EXIT. DTSBX438 00931 EXIT. DTSBX438 00932 DTSBX438 00933 P2120-SAVE-EXT-PAY. DTSBX438 00934 DISPLAY 'PAYMENT OK ' X212-EMP-NBR. CL*69 00935 PERFORM S005-FROM-SYS THRU S005-EXIT. CL*69 00936 CL*69 00937 MOVE LENGTH OF T025-REC TO T025-LENGTH CL*69 00938 MOVE '025' TO T025-REC-TYPE. CL*69 00939 CL*69 00940 MOVE W-EMP-NO TO T025-EMP-NO. CL*69 00941 MOVE 'WEB PAY ' TO T025-ORIGIN. CL*69 00942 MOVE L005-DATE TO T025-SYS-DATE. CL*69 00943 MOVE L005-TIME TO T025-SYS-TIME. CL*69 00944 CL*69 00945 IF W-REPORT-QTR > ZERO CL*69 00946 MOVE W-REPORT-QTR TO T025-APPLIC-YRQ CL*69 00947 MOVE 'PA' TO T025-PAY-TYPE CL*69 00948 ELSE CL*69 00949 MOVE ZERO TO T025-APPLIC-YRQ CL*69 00950 MOVE 'PA' TO T025-PAY-TYPE CL*69 00951 END-IF. CL*69 00952 DTSBX438 00953 MOVE SPACES TO T025-APPLIC-IND. CL*69 00954 MOVE ZERO TO T025-APPLIC-BATCH-NO CL*69 00955 T025-APPLIC-ITEM-NO. CL*69 00956 DTSBX438 00957 IF W-EMP-FOUND-YES-88 CL*69 00958 MOVE MPRF-PRIMARY-NAME (1:4) CL*69 00959 TO T025-NAME-CHECK CL*69 00960 ELSE CL*69 00961 MOVE SPACES TO T025-NAME-CHECK CL*69 00962 END-IF. CL*69 00963 DTSBX438 00964 MOVE W-RECEIVED-DATE TO T025-RECEIVED-DATE CL*69 00965 T025-DEPOSIT-DATE. CL*69 00966 DTSBX438 00967 DTSBX438 00968 MOVE W-REMITTANCE TO T025-REMIT-AMT. CL*69 00969 DTSBX438 00970 * MOVE X145-TRACE-NO TO W-X145-TRACE-NO. CL*78 00971 CL*69 00972 IF X145-TRACE-NO > SPACES CL*75 00973 MOVE W-X145-TRACE-NO-A TO T025-TRACE-NO CL*82 00974 ELSE CL*69 00975 MOVE ZEROS TO T025-TRACE-NO. CL*69 00976 CL*69 00977 MOVE 'VOL' TO T025-RESPONSIBLE-ACTIVITY. CL*69 00978 MOVE 'WEBESSP ' TO T025-RESPONSIBLE-OP-ID. CL*69 00979 DTSBX438 00980 MOVE T025-REC TO TSKL-REC. CL*69 00981 PERFORM S927B-WRITE THRU S927B-EXIT. CL*69 00982 ADD +1 TO W-T025-WRITE-CNT. CL*69 00983 DTSBX438 00984 ** DISPLAY 'BX423 PAYMENT ' X145-EMP-NO. DTSBX438 00985 P2120-EXIT. DTSBX438 00986 EXIT. DTSBX438 00987 DTSBX438 00988 DTSBX438 00989 P3000-WRITE-PAID-RPT. CL*48 00990 MOVE X145-EMP-NO TO P434-EMP-NO CL*48 00991 MOVE X145-QTR TO P434-QTR CL*48 00992 IF W-EMP-FOUND-YES-88 CL*48 00993 MOVE MPRF-PRIMARY-NAME (1:24) CL*48 00994 TO P434-NAME-CHECK CL*48 00995 ELSE CL*48 00996 MOVE SPACES TO P434-NAME-CHECK CL*48 00997 END-IF. CL*48 00998 CL*48 00999 MOVE X145-RCVD-DATE TO P434-RCVD-DATE CL*48 01000 MOVE W-REMITTANCE TO P434-X145-REMIT CL*53 01001 MOVE X145-TRACE-NO TO P434-X145-TRACE CL*71 01002 * ADD W-REMITTANCE TO W-X145-TOT-REMIT-AMT. CL*54 01003 CL*48 01004 PERFORM P4100-PRINT-HEADER THRU P4100-EXIT. CL*48 01005 WRITE REPT-PAID-REC FROM DETAIL-PEND-1 AFTER 1. CL*48 01006 ADD 1 TO WS-LINE-CNT2. CL*48 01007 * ADD +1 TO WS-NUMBER-ONE. CL*50 01008 P3000-EXIT. CL*48 01009 EXIT. CL*48 01010 CL*48 01011 CL*48 01012 P4100-PRINT-HEADER. CL*48 01013 IF WS-LINE-CNT GREATER 58 OR CL*48 01014 WS-LINE-CNT2 GREATER 58 CL*48 01015 MOVE +0 TO WS-LINE-CNT CL*48 01016 MOVE +0 TO WS-LINE-CNT2 CL*48 01017 ADD +1 TO WS-PAGE-CNT CL*48 01018 MOVE WS-PAGE-CNT TO HDR3-PAGE CL*48 01019 * MOVE ' -/+ ----- MONTHLY COUNT' TO HDR5-NAME CL*50 01020 WRITE REPT-PAID-REC FROM HEADER-1 AFTER TOP-OF-PAGE CL*48 01021 WRITE REPT-PAID-REC FROM HEADER-2 AFTER 1 CL*48 01022 WRITE REPT-PAID-REC FROM HEADER-3 AFTER 1 CL*48 01023 WRITE REPT-PAID-REC FROM HEADER-4 AFTER 1 CL*48 01024 * WRITE REPT-PAID-REC FROM HEADER-42 AFTER 1 CL*50 01025 WRITE REPT-PAID-REC FROM HEADER-5 AFTER 1 CL*48 01026 WRITE REPT-PAID-REC FROM HEADER-6 AFTER 1 CL*48 01027 ADD +6 TO WS-LINE-CNT2. CL*48 01028 P4100-EXIT. CL*48 01029 EXIT. CL*48 01030 CL*48 01031 CL*48 01032 DTSBX438 01033 T0000-TERMINATE. DTSBX438 01034 IF WS-LINE-CNT2 > 52 CL*57 01035 PERFORM P4100-PRINT-HEADER THRU P4100-EXIT CL*55 01036 END-IF. CL*55 01037 MOVE W-X212-CNT TO WS-FOOTING-CNT. CL*56 01038 MOVE W-T025-WRITE-CNT TO WS-T025-WRITE-CNT. CL*56 01039 MOVE W-X145-ERR-CNT TO WS-X145-ERR-CNT. CL*61 01040 MOVE W-X145-ERR-CNT TO WS-X145-PEN-CNT. CL*61 01041 MOVE W-TOT-PAID-REMITTANCE TO WS-TOT-REMIT. CL*57 01042 * MOVE W-TOT-REMIT-AMT TO WS-TOTAL-REMIT. CL*56 01043 MOVE W-TOT-REMITTANCE TO WS-TOTAL-REMIT. CL*60 01044 WRITE REPT-PAID-REC FROM FOOTING-LINE-1 AFTER 1. CL*55 01045 WRITE REPT-PAID-REC FROM FOOTING-LINE-2 AFTER 1. CL*55 01046 WRITE REPT-PAID-REC FROM FOOTING-LINE-3 AFTER 1. CL*55 01047 WRITE REPT-PAID-REC FROM FOOTING-LINE-4 AFTER 1. CL*55 01048 WRITE REPT-PAID-REC FROM FOOTING-LINE-5 AFTER 1. CL*55 01049 * WRITE REPT-PAID-REC FROM FOOTING-LINE-6 AFTER 1. CL*65 01050 WRITE REPT-PAID-REC FROM FOOTING-LINE-7 AFTER 1. CL*55 01051 WRITE REPT-PAID-REC FROM FOOTING-LINE-8 AFTER 1. CL*56 01052 WRITE REPT-PAID-REC FROM FOOTING-LINE-13 AFTER 3. CL*60 01053 WRITE REPT-PAID-REC FROM FOOTING-LINE-14 AFTER 1. CL*55 01054 CL*55 01055 DISPLAY ' '. CL*55 01056 CL*55 01057 CL*55 01058 DTSBX438 01059 CLOSE TDEC-PAYT-FILE TDEC-PEND-FILE. CL*29 01060 DTSBX438 01061 PERFORM S910-CLOSE THRU S910-EXIT. CL*35 01062 PERFORM S927C-CLOSE THRU S927C-EXIT. CL*43 01063 DISPLAY ' '. DTSBX438 01064 DTSBX438 01065 DISPLAY '*** DTSBX437 TERMINATION STATISTICS ***'. CL*64 01066 DTSBX438 01067 DISPLAY ' '. DTSBX438 01068 DTSBX438 01069 DISPLAY '*** TDEC REPORT PAYMENTS FOR DOES *'. CL*64 01070 DTSBX438 01071 DISPLAY ' '. DTSBX438 01072 DTSBX438 01073 PERFORM T2000-DISPLAY-TOTALS THRU T2000-EXIT. DTSBX438 01074 DTSBX438 01075 DISPLAY '***************************************'. DTSBX438 01076 DTSBX438 01077 T0000-EXIT. DTSBX438 01078 EXIT. DTSBX438 01079 DTSBX438 01080 DTSBX438 01081 T2000-DISPLAY-TOTALS. DTSBX438 01082 DISPLAY 'TDEC PAYMENTS READ : ' CL*64 01083 W-X212-CNT. CL*17 01084 CL*17 01085 DISPLAY 'TOTAL PAYMENTS PROCESSD: ' CL*64 01086 W-T025-WRITE-CNT. DTSBX438 01087 DTSBX438 01088 DISPLAY 'TOTAL PAYMTN HAD ERRORS: ' CL*64 01089 W-ERRO-CNT. CL*17 01090 CL*17 01091 DISPLAY 'MPRF RECORDS NOT FOUND : ' CL*17 01092 W-MPRF-CNT. CL*17 01093 CL*17 01094 DISPLAY 'MQTR RECORDS NOT FOUND : ' CL*17 01095 W-MQTR-CNT. CL*17 01096 CL*17 01097 DISPLAY 'PENDING PAYMENT WRITTEN: ' CL*64 01098 W-PEND-CNT. CL*17 01099 CL*17 01100 DTSBX438 01101 DISPLAY ' '. DTSBX438 01102 DTSBX438 01103 T2000-EXIT. DTSBX438 01104 EXIT. DTSBX438 01105 DTSBX438 01106 S001-FROM-FED-8. DTSBX438 01107 SET L001-FROM-FED-8 TO TRUE. DTSBX438 01108 GO TO S001-DATE. DTSBX438 01109 DTSBX438 01110 S001-FROM-CAL-8. DTSBX438 01111 SET L001-FROM-CAL-8 TO TRUE. DTSBX438 01112 GO TO S001-DATE. DTSBX438 01113 DTSBX438 01114 S001-FROM-ABS-DAY. DTSBX438 01115 SET L001-FROM-ABS-DAY TO TRUE. DTSBX438 01116 GO TO S001-DATE. DTSBX438 01117 DTSBX438 01118 S001-DATE. DTSBX438 01119 CALL 'DTSBU001' USING L001-LINK-AREA. DTSBX438 01120 S001-EXIT. DTSBX438 01121 EXIT. DTSBX438 01122 DTSBX438 01123 S003-AGENCY-DAY. DTSBX438 01124 SET L003-AGENCY-DAY TO TRUE. DTSBX438 01125 GO TO S003-WORK-DAY. DTSBX438 01126 DTSBX438 01127 S003-WORK-DAY. DTSBX438 01128 CALL 'DTSBU003' USING L003-LINK-AREA. DTSBX438 01129 S003-EXIT. DTSBX438 01130 EXIT. DTSBX438 01131 DTSBX438 01132 S004-FROM-5. DTSBX438 01133 SET L004-FROM-5 TO TRUE. DTSBX438 01134 GO TO S004-YRQ. DTSBX438 01135 DTSBX438 01136 S004-FROM-DATE. DTSBX438 01137 SET L004-FROM-DATE TO TRUE. DTSBX438 01138 GO TO S004-YRQ. DTSBX438 01139 DTSBX438 01140 S004-FROM-ABS. DTSBX438 01141 SET L004-FROM-ABS TO TRUE. DTSBX438 01142 GO TO S004-YRQ. DTSBX438 01143 DTSBX438 01144 S004-YRQ. DTSBX438 01145 CALL 'DTSBU004' USING L004-LINK-AREA. DTSBX438 01146 DTSBX438 01147 S004-EXIT. DTSBX438 01148 EXIT. DTSBX438 01149 S005-FROM-SYS. CL*16 01150 SET L005-FROM-SYS TO TRUE. CL*16 01151 GO TO S005-ABSTIME. CL*16 01152 CL*16 01153 S005-FROM-ABSTIME. CL*16 01154 SET L005-FROM-ABSTIME TO TRUE. CL*16 01155 GO TO S005-ABSTIME. CL*16 01156 CL*16 01157 S005-ABSTIME. CL*16 01158 CALL 'DTSBU005' USING L005-LINK-AREA. CL*16 01159 S005-EXIT. CL*16 01160 EXIT. CL*16 01161 CL*32 01162 S205-WEB-EDITOR. CL*32 01163 CALL 'DTSBU205' USING L205-LINK-AREA. CL*32 01164 S205-EXIT. CL*32 01165 EXIT. CL*32 01166 DTSBX438 01167 S910-OPEN-READ. CL*35 01168 SET L910-OPEN-READ-88 TO TRUE. CL*35 01169 GO TO S910-MSTR-IO. CL*35 01170 CL*35 01171 S910-READ. DTSBX438 01172 SET L910-READ-88 TO TRUE. DTSBX438 01173 GO TO S910-MSTR-IO. DTSBX438 01174 DTSBX438 01175 S910-START-BROWSE. DTSBX438 01176 SET L910-START-BROWSE-88 TO TRUE. DTSBX438 01177 GO TO S910-MSTR-IO. DTSBX438 01178 DTSBX438 01179 S910-READ-NEXT. DTSBX438 01180 SET L910-READ-NEXT-88 TO TRUE. DTSBX438 01181 GO TO S910-MSTR-IO. DTSBX438 01182 DTSBX438 01183 S910-CLOSE. CL*35 01184 SET L910-CLOSE-88 TO TRUE. CL*35 01185 GO TO S910-MSTR-IO. CL*35 01186 DTSBX438 01187 S910-MSTR-IO. DTSBX438 01188 CALL 'DTSBU910' USING L910-LINK-AREA DTSBX438 01189 MSKL-REC. DTSBX438 01190 S910-EXIT. DTSBX438 01191 EXIT. DTSBX438 01192 DTSBX438 01193 *S921-OPEN-READ. DTSBX438 01194 * SET L921-OPEN-READ-88 TO TRUE. DTSBX438 01195 * GO TO S921-AIX-IO. DTSBX438 01196 DTSBX438 01197 S921-READ. DTSBX438 01198 SET L921-READ-88 TO TRUE. DTSBX438 01199 GO TO S921-AIX-IO. DTSBX438 01200 DTSBX438 01201 S921-START-BROWSE. DTSBX438 01202 SET L921-START-BROWSE-88 TO TRUE. DTSBX438 01203 GO TO S921-AIX-IO. DTSBX438 01204 DTSBX438 01205 S921-READ-NEXT. DTSBX438 01206 SET L921-READ-NEXT-88 TO TRUE. DTSBX438 01207 GO TO S921-AIX-IO. DTSBX438 01208 DTSBX438 01209 *S921-CLOSE. DTSBX438 01210 * SET L921-CLOSE-88 TO TRUE. DTSBX438 01211 * GO TO S921-AIX-IO. DTSBX438 01212 DTSBX438 01213 S921-AIX-IO. DTSBX438 01214 CALL 'DTSBU921' USING L921-LINK-AREA DTSBX438 01215 ISKL-REC. DTSBX438 01216 S921-EXIT. DTSBX438 01217 EXIT. DTSBX438 01218 DTSBX438 01219 S923-OPEN-UPDATE. DTSBX438 01220 SET L923-OPEN-UPDATE-88 TO TRUE. DTSBX438 01221 GO TO S923-ATC-CALL. DTSBX438 01222 DTSBX438 01223 S923-WRITE. DTSBX438 01224 SET L923-WRITE-88 TO TRUE. DTSBX438 01225 GO TO S923-ATC-CALL. DTSBX438 01226 DTSBX438 01227 S923-CLOSE. DTSBX438 01228 SET L923-CLOSE-88 TO TRUE. DTSBX438 01229 GO TO S923-ATC-CALL. DTSBX438 01230 DTSBX438 01231 S923-ATC-CALL. DTSBX438 01232 CALL 'DTSBU923' USING L923-LINK-AREA DTSBX438 01233 ASKL-REC. DTSBX438 01234 S923-EXIT. DTSBX438 01235 EXIT. DTSBX438 01236 DTSBX438 01237 S927A-OPEN. CL*42 01238 SET L927-OPEN-UPDATE-88 TO TRUE. CL*42 01239 PERFORM S927Z-IO THRU S927Z-EXIT. CL*42 01240 CL*42 01241 S927A-EXIT. CL*42 01242 EXIT. CL*42 01243 DTSBX438 01244 S927B-WRITE. DTSBX438 01245 SET L927-WRITE-88 TO TRUE. DTSBX438 01246 PERFORM S927Z-IO THRU S927Z-EXIT. DTSBX438 01247 DTSBX438 01248 S927B-EXIT. DTSBX438 01249 EXIT. DTSBX438 01250 DTSBX438 01251 S927C-CLOSE. CL*42 01252 SET L927-CLOSE-88 TO TRUE. CL*42 01253 PERFORM S927Z-IO THRU S927Z-EXIT. CL*42 01254 CL*42 01255 S927C-EXIT. CL*42 01256 EXIT. CL*42 01257 DTSBX438 01258 S927Z-IO. DTSBX438 01259 CALL 'DTSBU927' USING L927-LINK-AREA DTSBX438 01260 TSKL-REC. DTSBX438 01261 S927Z-EXIT. DTSBX438 01262 EXIT. DTSBX438 01263 DTSBX438 01264 S931-OPEN-READ. DTSBX438 01265 SET L931-OPEN-READ-88 TO TRUE. DTSBX438 01266 GO TO S931-REF-IO. DTSBX438 01267 DTSBX438 01268 S931-CLOSE. DTSBX438 01269 SET L931-CLOSE-88 TO TRUE. DTSBX438 01270 GO TO S931-REF-IO. DTSBX438 01271 DTSBX438 01272 S931-REF-IO. DTSBX438 01273 CALL 'DTSBU931' USING L931-LINK-AREA DTSBX438 01274 FSKL-REC. DTSBX438 01275 S931-EXIT. DTSBX438 01276 EXIT. DTSBX438 01277 DTSBX438 01278 S946-WRITE-R140. DTSBX438 01279 CALL 'DTSBU946' USING R140-REC. DTSBX438 01280 DTSBX438 01281 S946-EXIT. DTSBX438 01282 EXIT. DTSBX438 01283 DTSBX438 01284 S999-ABEND. DTSBX438 01285 CALL 'DTSBU999' USING W-ABEND-CD. DTSBX438 01286 S999-EXIT. DTSBX438 01287 EXIT. DTSBX438 01288 DTSBX438