00001 IDENTIFICATION DIVISION. 03/18/24 00002 PROGRAM-ID. CHGBD100. CHGBD100 00003 *AUTHOR. TRW. LV076 00004 *DATE-WRITTEN. APRIL 2001. CHGBD100 00005 DATE-COMPILED. CHGBD100 00006 SKIP3 CHGBD100 00007 ***** CHGBD100 00008 * CHGBD100 00009 * FUNCTION: /** NEW VERSION USED DAILY IN DTSCHRGD ** CHGBD100 00010 * CHGBD100 00011 * DAILY BENEFIT CHARGE REPORTING PROCESS STEP 1 CHGBD100 00012 * (1) READ CHARGE RECORDS FROM DAILY BENEFITS FILE CHGBD100 00013 * (UI.ESP930F1.CHRG) CHGBD100 00014 * (2) PERFORM PRELIMINARY EDITS AND CREATE CHGIM001 CHGBD100 00015 * OUTPUT RECORD. CHGBD100 00016 * CHGBD100 00017 ***** CHGBD100 00018 * *** NOTE NOTE NOTE NOTE NOTE NOTE NOTE *** CHGBD100 00019 * *** *** CHGBD100 00020 * *** IF THE BENEFITS SYSTEM BEGINS PRODUCING *** CHGBD100 00021 * *** CHARGE RECORDS FOR A NEW BENEFIT PROGRAM *** CHGBD100 00022 * *** MODIFY THE FOLLOWING CHARGE SYSTEM *** CHGBD100 00023 * *** COMPONENTS: *** CHGBD100 00024 * *** *** CHGBD100 00025 * *** ADD NEW LEVEL-88S TO: *** CHGBD100 00026 * *** CHG1-CHARGE-PROGRAM IN CHGIM001 *** CHGBD100 00027 * *** WRK-PROGRAM IN CHGBD100 *** CHGBD100 00028 * *** CHG2-PROGRAM IN CHGIM002 *** CHGBD100 00029 * *** CHG4-PROGRAM IN CHGIM004 *** CHGBD100 00030 * *** CHG30-PROGRAM IN CHGIM030 *** CHGBD100 00031 * *** *** CHGBD100 00032 * *** MODIFY P1500 IN CHGBD100 *** CHGBD100 00033 * *** *** CHGBD100 00034 ***** CHGBD100 00035 * CHGBD100 00036 * INPUT: CHGBD100 00037 * CHGBD100 00038 * CHGFILE - CHARGE RECORDS GENERATED BY CHGBD100 00039 * BENEFITS SYSTEM. CHGBD100 00040 * OUTPUT: CHGBD100 00041 * CHGBD100 00042 * BD100CHG - REFORMATTED CHARGE RECORD WITHIN CHGBD100 00043 * REPORTING PERIOD READY FOR SORT. CHGBD100 00044 ***** CHGBD100 00045 CHGBD100 00046 ******************************************************************CHGBD100 00047 * MODIFICATION HISTORY: *CHGBD100 00048 * *CHGBD100 00049 * 02-02-1999 MODIFIED FROM MT CHG100D *CHGBD100 00050 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00051 * *CHGBD100 00052 * 04-09-2001 ELIMINATED THE CURRENT PARAMETER FILE BY USING THE *CHGBD100 00053 * LINKAGE SECTION TO RECEIVE THE START AND END DATES *CHGBD100 00054 * FROM JCL PARM. *CHGBD100 00055 * REFERENCE RFP # AUTHOR OF CHANGE - RW1 *CHGBD100 00056 * *CHGBD100 00057 * 03-22-2002 ADDED A NEW VALUE TEUC (THE NEW FEDERAL EXTENDED *CHGBD100 00058 * BENEFITS PROGRAM) TO THE PROGRAM CODE DATA ELEMENT *CHGBD100 00059 * IN THE CHARGE SYSTEM DISTINGUISHED BENEFIT PROGRAM. *CHGBD100 00060 * IT NOW CONTAINS VALUES ONLY FOR UI AND EB. *CHGBD100 00061 * REFERENCE RFP # AUTHOR OF CHANGE - RW1 *CHGBD100 00062 * *CHGBD100 00063 * 06-29-2004 ADDED A NEW EMPLOYER TYPE (17) FOR DOMESTIC *CHGBD100 00064 * VIOLENCE. *CHGBD100 00065 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00066 * *CHGBD100 00067 * 03-05-2009 MODIFIED FOR NEW FORMAT OF PROGRAM CODE - CHANGED *CHGBD100 00068 * FROM NUMERIC TO CHARACTER. *CHGBD100 00069 * UPDATED EMPLOYER TYPES. *CHGBD100 00070 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00071 * *CHGBD100 00072 * 08-05-2009 ADDED NEW PROGRAM CODES TO P1500: ADDITIONAL *CHGBD100 00073 * BENEFITS, TRAINING, DEPENDENT ALLOWANCE. *CHGBD100 00074 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00075 * *CHGBD100 00076 * 11-17-2009 ADDED NEW PROGRAM CODES TO P1500: *CHGBD100 00077 * EUC 2008 TIERS 3 AND 4. *CHGBD100 00078 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00079 * *CHGBD100 00080 * 12-16-2009 CORRECTED INCONSISTENCY BETWEEN CHGIM001 PROG *CHGBD100 00081 * CODES AND CHGIM002. *CHGBD100 00082 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00083 * *CHGBD100 00084 * 03-31-2010 ADDED NEW PROGRAM CODE TO P1500: *CHGBD100 00085 * SPECIAL PAYMENTS. *CHGBD100 00086 * REFERENCE RFP # AUTHOR OF CHANGE - GD *CHGBD100 00087 * *CHGBD100 00088 * 09-26-2014 ADDED NEW PROGRAM CODE TO P1500: U-UCPIA *CHGBD100 00089 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE *CHGBD100 00090 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 *CHGBD100 00091 * *CHGBD100 00092 * 04-12-2020 ADDED NEW PROGRAM CODE TO P1500: PUA, FPUC, AND FRUR* CL**2 00093 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL**2 00094 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL**2 00095 * * CL**2 00096 * 04-24-2020 ADDED NEW PROGRAM CODE TO P1500: PEUC * CL*10 00097 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL*10 00098 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL*10 00099 * * CL*10 00100 * * CL*18 00101 * 06-24-2020 ADDED NEW PROGRAM CODE TO P1500: REUR * CL*18 00102 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL*18 00103 * CODE FROM DOCS IS COMING AS A '1' WHICH IS CAUSING * CL*18 00104 * CHARGES BY SSN TO BE DOUBLED AS A RESUULT OF MOVING * CL*18 00105 * CHARGES FROM EMPLOYER ACCOUNT TO 5032 ACCOUNT. * CL*18 00106 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL*18 00107 * * CL*18 00108 * 09-18-2020 ADDED NEW PROGRAM CODE TO P1500: LWA * CL*22 00109 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL*22 00110 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL*22 00111 * * CL*22 00112 * 12-08-2020 ADDED NEW PROGRAM CODE TO P1500: PUA STIMULUS * CL*24 00113 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL*24 00114 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL*24 00115 * 12-16-2021 ADDED NEW PROGRAM CODE TO P1500: DUC * CL*29 00116 * UPDATED WRK PROGRAM CODE IN WORKING STORAGE * CL*29 00117 * REFERENCE RFP # AUTHOR OF CHANGE - ZL1 * CL*29 00118 * MM-DD-YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *CHGBD100 00119 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *CHGBD100 00120 * REFERENCE RFP #**** AUTHOR OF CHANGE - *** *CHGBD100 00121 * *CHGBD100 00122 ******************************************************************CHGBD100 00123 CHGBD100 00124 SKIP3 CHGBD100 00125 ENVIRONMENT DIVISION. CHGBD100 00126 SKIP3 CHGBD100 00127 INPUT-OUTPUT SECTION. CHGBD100 00128 SKIP3 CHGBD100 00129 FILE-CONTROL. CHGBD100 00130 CHGBD100 00131 SELECT CHARGE-IN-FILE ASSIGN TO CHGFILE CHGBD100 00132 FILE STATUS IS CHARGE-IN-STATUS. CHGBD100 00133 CHGBD100 00134 SELECT BD100-CHG-FILE ASSIGN TO BD100CHG CHGBD100 00135 FILE STATUS IS BD100-CHG-STATUS. CHGBD100 00136 EJECT CHGBD100 00137 DATA DIVISION. CHGBD100 00138 CHGBD100 00139 FILE SECTION. CHGBD100 00140 CHGBD100 00141 FD CHARGE-IN-FILE CHGBD100 00142 LABEL RECORDS ARE STANDARD CL*32 00143 BLOCK CONTAINS 0 CHARACTERS. CL*32 00144 CHGBD100 00145 01 CHARGE-IN-REC PIC X(200). CL*37 00146 CHGBD100 00147 FD BD100-CHG-FILE CHGBD100 00148 LABEL RECORDS ARE STANDARD CHGBD100 00149 BLOCK CONTAINS 0 CHARACTERS. CHGBD100 00150 CHGBD100 00151 01 SORT-CHG-REC PIC X(104). CL*62 00152 CHGBD100 00153 EJECT CHGBD100 00154 WORKING-STORAGE SECTION. CHGBD100 001545 77 PAN-VALET PICTURE X(24) VALUE '076CHGBD100 03/18/24'. CHGBD100 00155 77 PAN-VALET PICTURE X(24) VALUE '141CHGBD100 10/01/14'. CHGBD100 00156 77 PAN-VALET PICTURE X(24) VALUE '004CHGBD100 09/26/14'. CHGBD100 00157 77 PAN-VALET PICTURE X(24) VALUE '139CHGBD100 04/01/10'. CHGBD100 00158 CHGBD100 00159 01 WRK-AREA. CHGBD100 00160 05 AMT-DISP PIC Z(06)9.99-. CHGBD100 00161 05 ABEND-CODE PIC S9(04) COMP CHGBD100 00162 VALUE +100. CHGBD100 00163 05 ABEND-MSG PIC X(60). CHGBD100 00164 05 ABEND-MOD PIC X(08) VALUE 'DTSBU999'. CHGBD100 00165 CHGBD100 00166 05 CHARGE-IN-STATUS PIC X(02) VALUE SPACES. CHGBD100 00167 88 CHARGE-FILE-OK-88 VALUE ZERO. CHGBD100 00168 88 CHARGE-FILE-EOF-88 VALUE '10'. CHGBD100 00169 05 BD100-CHG-STATUS PIC X(02) VALUE SPACES. CHGBD100 00170 88 BD100-FILE-OK-88 VALUE ZERO. CHGBD100 00171 CHGBD100 00172 05 WRK-CHG-LENGTH PIC S9(05) COMP. CHGBD100 00173 CHGBD100 00174 05 WRK-ERROR-IND PIC X(01). CHGBD100 00175 88 WRK-ERROR-YES-88 VALUE 'Y'. CHGBD100 00176 88 WRK-ERROR-NO-88 VALUE 'N'. CHGBD100 00177 CHGBD100 00178 05 WRK-EDIT-ERROR-IND PIC X(01). CHGBD100 00179 88 WRK-EDIT-ERROR-YES-88 VALUE 'Y'. CHGBD100 00180 88 WRK-EDIT-ERROR-NO-88 VALUE 'N'. CHGBD100 00181 CHGBD100 00182 05 WRK-CURR-SYS-DATE PIC S9(09) COMP-3 VALUE +0. CL*73 00183 05 WRK-CHARGE-PRIOR-DATE PIC S9(09) COMP-3 VALUE +0. CL*73 00184 05 WRK-CHARGE-DATE PIC S9(09) COMP-3 VALUE +0. CL*68 00185 05 WRK-BYE PIC S9(09) COMP-3 VALUE +0. CHGBD100 00186 05 WRK-KEY-X PIC X(10). CHGBD100 00187 05 WRK-KEY-N REDEFINES WRK-KEY-X CHGBD100 00188 PIC 9(10). CHGBD100 00189 * CHGBD100 00190 05 WRK-CHG-CURR-AMT PIC S9(09)V99 VALUE +0. CL*41 00191 05 WRK-CHG-TOT-AMT PIC S9(09)V99 VALUE +0. CL*63 00192 05 TOT-CHARGE-UI-AMT PIC S9(09)V99 VALUE +0. CL*63 00193 05 TOT-CHARGE-UI4-AMT PIC S9(09)V99 VALUE +0. CL*51 00194 05 TOT-CHARGE-UI3-AMT PIC S9(09)V99 VALUE +0. CL*51 00195 05 TOT-CHARGE-UCX-AMT PIC S9(09)V99 VALUE +0. CL*46 00196 05 TOT-CHARGE-UCFE-AMT PIC S9(09)V99 VALUE +0. CL*46 00197 05 TOT-CHARGE-SPEC-AMT PIC S9(09)V99 VALUE +0. CL*46 00198 05 TOT-CHARGE-CWC-AMT PIC S9(09)V99 VALUE +0. CL*46 00199 05 TOT-CHARGE-OTH-AMT PIC S9(09)V99 VALUE +0. CL*50 00200 05 TOT-CHARGE-RAT-AMT PIC S9(09)V99 VALUE +0. CL*53 00201 05 TOT-CHARGE-REM-AMT PIC S9(09)V99 VALUE +0. CL*53 00202 05 TOT-CHARGE-DCG-AMT PIC S9(09)V99 VALUE +0. CL*53 00203 05 TOT-CHARGE-CURR-AMT PIC S9(09)V99 VALUE +0. CL*46 00204 05 TOT-CHARGE-CURR-AMT-DISP PIC ZZZ,ZZZ,ZZ9.99. CHGBD100 00205 05 INV-EMP-NO-CURR-AMT PIC S9(09)V99 VALUE +0. CHGBD100 00206 05 DIS-INV-EMP-NO-CURR-AMT PIC ZZZ,ZZZ,ZZ9.99. CHGBD100 00207 * CHGBD100 00208 ************************************************************* CHGBD100 00209 * WRK-PROGRAM DEFINES VALUES FOR VALID BENEFIT PROGRAMS. CHGBD100 00210 * IT IS SET BASED ON CHARGE-PROG-X IN THE DUCAS ESPRPT04 CHGBD100 00211 * RECORD. IF AN NEW BENEFIT PROGRAM IS ESTABLISHED, ADD CHGBD100 00212 * AN ADDITIONAL LEVEL-88 AND MODIFY THE CODE IN P1500. CHGBD100 00213 ************************************************************* CHGBD100 00214 05 WRK-PROGRAM PIC X(01). CHGBD100 00215 88 WRK-PROG-UI-88 VALUE '1'. CHGBD100 00216 88 WRK-PROG-EB-88 VALUE '2'. CHGBD100 00217 88 WRK-PROG-TEUC-88 VALUE '3'. CHGBD100 00218 88 WRK-PROG-TEUCA-88 VALUE '4'. CHGBD100 00219 88 WRK-PROG-FAC-88 VALUE '5'. CHGBD100 00220 88 WRK-PROG-FSB-88 VALUE '6'. CHGBD100 00221 88 WRK-PROG-FSC-88 VALUE '7'. CHGBD100 00222 88 WRK-PROG-DUA-88 VALUE '8'. CHGBD100 00223 88 WRK-PROG-TR2-88 VALUE '9'. CHGBD100 00224 88 WRK-PROG-TRA-88 VALUE '0'. CHGBD100 00225 88 WRK-PROG-STEPLDR-88 VALUE 'A'. CHGBD100 00226 88 WRK-PROG-AB-88 VALUE 'B'. CHGBD100 00227 88 WRK-PROG-TRAINING-88 VALUE 'C'. CL*19 00228 88 WRK-PROG-DEPENDENTS-88 VALUE 'D'. CHGBD100 00229 88 WRK-PROG-EUC08-2PLUS-88 VALUE 'E'. CHGBD100 00230 88 WRK-PROG-EUC08-TIER3-88 VALUE 'F'. CHGBD100 00231 88 WRK-PROG-EUC08-TIER4-88 VALUE 'G'. CHGBD100 00232 88 WRK-PROG-SPECIAL-PAY-88 VALUE 'H'. CHGBD100 00233 88 WRK-PROG-UCPIA-88 VALUE 'I'. CHGBD100 00234 88 WRK-PROG-GPA-88 VALUE 'J'. CL**2 00235 88 WRK-PROG-PUA-88 VALUE 'U'. CL*13 00236 88 WRK-PROG-FPUC-88 VALUE 'L'. CL**2 00237 88 WRK-PROG-FRUR-88 VALUE 'M'. CL**2 00238 88 WRK-PROG-PEUC-88 VALUE 'N'. CL*19 00239 88 WRK-PROG-REUR-88 VALUE 'Y'. CL*18 00240 88 WRK-PROG-LWA-88 VALUE 'X'. CL*23 00241 88 WRK-PROG-PUA-STIM-88 VALUE 'R'. CL*25 00242 88 WRK-PROG-DUC-88 VALUE 'U'. CL*31 00243 CHGBD100 00244 ************************************************************* CHGBD100 00245 * WRK-BEN-PROG-CODE DEFINES THE VALUES FOR THE BENEFIT CHGBD100 00246 * PROGRAM CODE AS USED IN THE BENEFITS SYSTEM. CHGBD100 00247 ************************************************************* CHGBD100 00248 05 WRK-BEN-PROG-CODE PIC X(02). CHGBD100 00249 05 FILLER REDEFINES WRK-BEN-PROG-CODE. CHGBD100 00250 10 WRK-BEN-PROG-CODE-PFX PIC X(01). CHGBD100 00251 88 BEN-PROG-UI-88 VALUE '0'. CHGBD100 00252 88 BEN-PROG-EB-88 VALUE '1'. CHGBD100 00253 88 BEN-PROG-FSB-88 VALUE '2'. CHGBD100 00254 88 BEN-PROG-FSC-88 VALUE '3'. CHGBD100 00255 88 BEN-PROG-DUA-88 VALUE '4'. CHGBD100 00256 88 BEN-PROG-TR2-88 VALUE '5'. CHGBD100 00257 88 BEN-PROG-TRA-88 VALUE '6'. CHGBD100 00258 88 BEN-PROG-TEUC-88 VALUE '7'. CHGBD100 00259 88 BEN-PROG-TEUCA-88 VALUE '8'. CHGBD100 00260 88 BEN-PROG-STEPLDR-88 VALUE '9'. CHGBD100 00261 88 BEN-PROG-FAC-88 VALUE 'F'. CHGBD100 00262 88 BEN-PROG-AB-88 VALUE 'A'. CHGBD100 00263 88 BEN-PROG-TRAINING-88 VALUE 'T'. CHGBD100 00264 88 BEN-PROG-DEPENDENTS-88 VALUE 'D'. CHGBD100 00265 88 BEN-PROG-EUC08-2PLUS-88 VALUE 'P'. CHGBD100 00266 88 BEN-PROG-EUC08-TIER3-88 VALUE 'E'. CHGBD100 00267 88 BEN-PROG-EUC08-TIER4-88 VALUE 'Z'. CHGBD100 00268 88 BEN-PROG-SPECIAL-PAY-88 VALUE 'S'. CHGBD100 00269 * 88 BEN-PROG-UCPIA-88 VALUE 'U'. CL*13 00270 88 BEN-PROG-PUA-88 VALUE 'U'. CL*13 00271 88 BEN-PROG-FPUC-88 VALUE 'V'. CL**2 00272 88 BEN-PROG-FRUR-88 VALUE 'W'. CL**2 00273 88 BEN-PROG-PEUC-88 VALUE 'C'. CL*14 00274 88 BEN-PROG-REUR-88 VALUE 'Y'. CL*18 00275 88 BEN-PROG-LWA-88 VALUE 'X'. CL*23 00276 88 BEN-PROG-PUA-STIM-88 VALUE 'R'. CL*25 00277 88 BEN-PROG-DUC-88 VALUE 'R'. CL*29 00278 10 WRK-BEN-PROG-CODE-SFX PIC X(01). CHGBD100 00279 CHGBD100 00280 05 WRK-CHARGE-IN-READ PIC 9(07) COMP-3. CHGBD100 00281 05 WRK-SORT-CHG-WRITTEN PIC 9(07) COMP-3. CHGBD100 00282 CHGBD100 00283 05 WRK-CHG-DT-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00284 05 WRK-BYE-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00285 05 WRK-EMP-TYPE-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00286 05 WRK-CHG-AMT-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00287 05 WRK-SUPP-CD-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00288 05 WRK-EMP-NO-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00289 05 WRK-SSN-ERR-CNT PIC 9(07) COMP-3. CHGBD100 00290 CHGBD100 00291 05 WRK-EMP-ACCT PIC 9(06). CHGBD100 00292 88 WRK-EMP-ACCT-FED-88 VALUE 000001 THRU 001999. CHGBD100 00293 88 WRK-EMP-ACCT-CWC-88 VALUE 110000 THRU 119999. CHGBD100 00294 CHGBD100 00295 05 WRK-EMP-TYPE PIC 9(02). CHGBD100 00296 88 WRK-EMP-TYPE-RATED-88 VALUE 00. CHGBD100 00297 88 WRK-EMP-TYPE-SELF-INS-88 VALUE 08. CHGBD100 00298 88 WRK-EMP-TYPE-CWC-88 VALUE 04. CHGBD100 00299 88 WRK-EMP-TYPE-FED-88 VALUE 01, 02. CHGBD100 00300 88 WRK-EMP-TYPE-VALID-88 VALUE 00, 01, 02, 03 CHGBD100 00301 04, 05, 06 CHGBD100 00302 07, 08, 09 CHGBD100 00303 10, 11, 12 CHGBD100 00304 13, 15, 16, 17 CHGBD100 00305 18, 19, 20, 21 CHGBD100 00306 22, 23, 24, 25 CHGBD100 00307 26, 27, 28, 29 CL**3 00308 31, 32, 33, 34 CL*16 00309 35, 36, 37, 38, 39. CL*29 00310 ** ADD ERROR MSG TABLE SET UP CHGBD100 00311 01 MSG-TABLE. CHGBD100 00312 05 MSG1-EMP-TYPE-ERR. CHGBD100 00313 10 MSG1-ID. CHGBD100 00314 15 MSG1-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00315 15 MSG1-ID2 PIC X(03) VALUE '100'. CHGBD100 00316 10 MSG1-SHORT-TEXT PIC X(20) CHGBD100 00317 VALUE 'INVALID EMP TYPE : '. CHGBD100 00318 10 MSG1-LONG-TEXT. CHGBD100 00319 15 FILLER PIC X(29) CHGBD100 00320 VALUE 'INVALID EMPLOYER TYPE '. CHGBD100 00321 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00322 15 TBL-SSN PIC 9(10). CHGBD100 00323 15 FILLER PIC X(13) VALUE ' EMP TYPE = '. CHGBD100 00324 15 TBL-EMP-TYPE PIC 9(02). CHGBD100 00325 CHGBD100 00326 05 MSG2-BYE-DATE-ERR. CHGBD100 00327 10 MSG2-ID. CHGBD100 00328 15 MSG2-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00329 15 MSG2-ID2 PIC X(03) VALUE '100'. CHGBD100 00330 10 MSG2-SHORT-TEXT PIC X(20) CHGBD100 00331 VALUE 'INVALID BYE DATE : '. CHGBD100 00332 10 MSG2-LONG-TEXT. CHGBD100 00333 15 FILLER PIC X(29) CHGBD100 00334 VALUE 'INVALID BYE DATE ACCEPTED '. CHGBD100 00335 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00336 15 TBL-SSN2 PIC 9(11). CHGBD100 00337 15 FILLER PIC X(13) VALUE ' BYE DATE = '. CHGBD100 00338 15 TBL-BYE-DATE2 PIC 9(08). CHGBD100 00339 CHGBD100 00340 05 MSG3-CHARGE-DATE-ERR. CHGBD100 00341 10 MSG3-ID. CHGBD100 00342 15 MSG3-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00343 15 MSG3-ID2 PIC X(03) VALUE '100'. CHGBD100 00344 10 MSG3-SHORT-TEXT PIC X(20) CHGBD100 00345 VALUE 'INVALID CHG DATE : '. CHGBD100 00346 10 MSG3-LONG-TEXT. CHGBD100 00347 15 FILLER PIC X(29) CHGBD100 00348 VALUE 'INVALID CHARGE DATE '. CHGBD100 00349 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00350 15 TBL-SSN3 PIC 9(10). CHGBD100 00351 15 FILLER PIC X(13) VALUE ' CHG DATE = '. CHGBD100 00352 15 TBL-CHG-DATE PIC 9(08). CHGBD100 00353 CHGBD100 00354 05 MSG4-CHARGE-AMT-ERR. CHGBD100 00355 10 MSG4-ID. CHGBD100 00356 15 MSG4-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00357 15 MSG4-ID2 PIC X(03) VALUE '100'. CHGBD100 00358 10 MSG4-SHORT-TEXT PIC X(20) CHGBD100 00359 VALUE 'INVALID CHG AMOUNT :'. CHGBD100 00360 10 MSG4-LONG-TEXT. CHGBD100 00361 15 FILLER PIC X(29) CHGBD100 00362 VALUE 'INVALID CHARGE AMOUNT '. CHGBD100 00363 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00364 15 TBL-SSN4 PIC 9(10). CHGBD100 00365 15 FILLER PIC X(15) VALUE ' CHG AMOUNT = '.CHGBD100 00366 15 TBL-CURR-AMT PIC S9(08)V99. CHGBD100 00367 CHGBD100 00368 05 MSG5-SUPP-CODE-ERR. CHGBD100 00369 10 MSG5-ID. CHGBD100 00370 15 MSG5-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00371 15 MSG5-ID2 PIC X(03) VALUE '100'. CHGBD100 00372 10 MSG5-SHORT-TEXT PIC X(20) CHGBD100 00373 VALUE 'INVALID SUPP CODE :'. CHGBD100 00374 10 MSG5-LONG-TEXT. CHGBD100 00375 15 FILLER PIC X(29) CHGBD100 00376 VALUE 'INVALID SUPP CODE '. CHGBD100 00377 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00378 15 TBL-SSN5 PIC 9(10). CHGBD100 00379 15 FILLER PIC X(14) VALUE ' SUPP CODE = '. CHGBD100 00380 15 TBL-SUPP-CODE PIC X(01). CHGBD100 00381 CHGBD100 00382 05 MSG6-EMP-NO-ERR. CHGBD100 00383 10 MSG6-ID. CHGBD100 00384 15 MSG6-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00385 15 MSG6-ID2 PIC X(03) VALUE '100'. CHGBD100 00386 10 MSG6-SHORT-TEXT PIC X(20) CHGBD100 00387 VALUE 'EMPLOYER NO = ZERO :'. CHGBD100 00388 10 MSG6-LONG-TEXT. CHGBD100 00389 15 FILLER PIC X(29) CHGBD100 00390 VALUE 'EMPLOYER NUMBER = ZERO '. CHGBD100 00391 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00392 15 MSG6-SSN PIC 9(10). CHGBD100 00393 15 FILLER PIC X(15) VALUE SPACES. CHGBD100 00394 CHGBD100 00395 05 MSG7-SSN-ERR. CHGBD100 00396 10 MSG7-ID. CHGBD100 00397 15 MSG7-ID1 PIC X(08) VALUE 'CHGBD100'. CHGBD100 00398 15 MSG7-ID2 PIC X(03) VALUE '100'. CHGBD100 00399 10 MSG7-SHORT-TEXT PIC X(20) CHGBD100 00400 VALUE 'SSN = ZERO :'. CHGBD100 00401 10 MSG7-LONG-TEXT. CHGBD100 00402 15 FILLER PIC X(29) CHGBD100 00403 VALUE 'SSN = ZERO '. CHGBD100 00404 15 FILLER PIC X(08) VALUE ' SSN = '. CHGBD100 00405 15 MSG7-SSN PIC 9(10). CHGBD100 00406 15 FILLER PIC X(15) VALUE SPACES. CHGBD100 00407 CHGBD100 00408 01 WRK-CHG-REC. CL*62 00409 ++INCLUDE CHGIM001 CL*62 00410 CL*62 00411 ** ADD ERROR MSG OUTPUT RECORD. CHGBD100 00412 01 R907-REC. CHGBD100 00413 ++INCLUDE DTSIR907 CHGBD100 00414 CHGBD100 00415 *** BENEFITS CHARGE RECORD *** CHGBD100 00416 ++INCLUDE ESPRPT04 CL*33 00417 CHGBD100 00418 01 FILLER REDEFINES CHARGE-REC. CHGBD100 00419 05 WRK-CHARGE-REC PIC X(200). CL*32 00420 CHGBD100 00421 01 L001-LINK-AREA. CHGBD100 00422 ++INCLUDE DTSIL001 CHGBD100 00423 CHGBD100 00424 01 L004-LINK-AREA. CHGBD100 00425 ++INCLUDE DTSIL004 CHGBD100 00426 CL*34 00427 01 L005-LINK-AREA. CL*73 00428 ++INCLUDE DTSIL005 CL*73 00429 CL*73 00430 01 L910-LINK-AREA. CL*34 00431 ++INCLUDE DTSIL910 CL*34 00432 CL*34 00433 01 MSKL-REC. CL*34 00434 ++INCLUDE DTSIMSKL CL*34 00435 CL*34 00436 01 MPRF-REC. CL*34 00437 ++INCLUDE DTSIMPRF CL*34 00438 CL*34 00439 01 L921-LINK-AREA. CL*34 00440 ++INCLUDE DTSIL921 CL*34 00441 CL*34 00442 01 ISKL-REC. CL*34 00443 ++INCLUDE DTSIISKL CL*34 00444 CHGBD100 00445 PROCEDURE DIVISION. CHGBD100 00446 SKIP2 CHGBD100 00447 CHGBD100-MAIN. CHGBD100 00448 MOVE ZERO TO WRK-CHARGE-IN-READ CHGBD100 00449 WRK-SORT-CHG-WRITTEN CHGBD100 00450 WRK-CHG-DT-ERR-CNT CHGBD100 00451 WRK-BYE-ERR-CNT CHGBD100 00452 WRK-EMP-TYPE-ERR-CNT CHGBD100 00453 WRK-CHG-AMT-ERR-CNT CHGBD100 00454 WRK-SUPP-CD-ERR-CNT CHGBD100 00455 WRK-EMP-NO-ERR-CNT CHGBD100 00456 WRK-SSN-ERR-CNT. CHGBD100 00457 CHGBD100 00458 SET WRK-ERROR-NO-88 TO TRUE. CHGBD100 00459 CHGBD100 00460 PERFORM I0000-INITIATE THRU I0000-EXIT. CHGBD100 00461 IF WRK-ERROR-YES-88 CHGBD100 00462 GO TO CHGBD100-EXIT. CHGBD100 00463 CHGBD100 00464 PERFORM P0000-PROCESS THRU P0000-EXIT. CHGBD100 00465 CHGBD100 00466 IF RETURN-CODE NOT EQUAL 0 CL*66 00467 DISPLAY ' RETURM CODE NOT EQ 0-= ' RETURN-CODE CL*66 00468 STOP RUN. CL*66 00469 PERFORM T0000-TERMINATE THRU T0000-EXIT. CHGBD100 00470 CHGBD100 00471 DISPLAY ' RC --= ' RETURN-CODE. CL*64 00472 CL*60 00473 * IF WRK-EDIT-ERROR-YES-88 CL*67 00474 * MOVE +05 TO RETURN-CODE. CL*67 00475 CHGBD100 00476 CHGBD100-EXIT. CHGBD100 00477 STOP RUN. CHGBD100 00478 EJECT CHGBD100 00479 I0000-INITIATE. CHGBD100 00480 MOVE MSG1-ID1 TO R907-MODULE-NAME. CHGBD100 00481 MOVE LENGTH OF R907-REC TO R907-LENGTH. CHGBD100 00482 CHGBD100 00483 PERFORM S005-FROM-SYS THRU S005-EXIT CL*73 00484 MOVE L005-DATE TO WRK-CURR-SYS-DATE CL*73 00485 DISPLAY 'TODAYS SYSTEM DATE ' WRK-CURR-SYS-DATE. CL*73 00486 CL*73 00487 PERFORM I2000-OPEN-FILES THRU I2000-EXIT. CHGBD100 00488 PERFORM I3000-VALIDATE-CHARGES THRU I3000-EXIT. CL*76 00489 CHGBD100 00490 I0000-EXIT. CHGBD100 00491 EXIT. CHGBD100 00492 CHGBD100 00493 I2000-OPEN-FILES. CHGBD100 00494 OPEN INPUT CHARGE-IN-FILE. CHGBD100 00495 IF NOT CHARGE-FILE-OK-88 CHGBD100 00496 DISPLAY 'CHARGE FILE OPEN ERROR: ' CHARGE-IN-STATUS CHGBD100 00497 SET WRK-ERROR-YES-88 TO TRUE CHGBD100 00498 GO TO I2000-EXIT. CHGBD100 00499 CHGBD100 00500 OPEN OUTPUT BD100-CHG-FILE. CHGBD100 00501 IF NOT BD100-FILE-OK-88 CHGBD100 00502 DISPLAY 'SORT FILE OPEN ERROR: ' BD100-CHG-STATUS CHGBD100 00503 SET WRK-ERROR-YES-88 TO TRUE CHGBD100 00504 GO TO I2000-EXIT. CHGBD100 00505 CL*34 00506 PERFORM S910-OPEN-READ THRU S910-EXIT. CL*34 00507 PERFORM S921-OPEN-READ THRU S921-EXIT. CL*34 00508 CL*34 00509 CHGBD100 00510 I2000-EXIT. CHGBD100 00511 EXIT. CHGBD100 00512 CHGBD100 00513 I3000-VALIDATE-CHARGES. CL*68 00514 READ CHARGE-IN-FILE INTO WRK-CHARGE-REC CL*68 00515 IF NOT CHARGE-FILE-OK-88 CL*68 00516 DISPLAY 'CHARGE FILE EMPTY: ' CHARGE-IN-STATUS CL*68 00517 SET WRK-ERROR-YES-88 TO TRUE CL*68 00518 MOVE +03 TO RETURN-CODE CL*68 00519 DISPLAY 'P0000 EMPTY: ' RETURN-CODE CL*68 00520 GO TO I3000-EXIT. CL*68 00521 CL*70 00522 DISPLAY 'DAILY FILE CHARGE EAN ' CHARGE-EMPL-ACCT CL*74 00523 DISPLAY 'DAILY FILE CHARGE EAN ' CHARGE-SSN CL*74 00524 DISPLAY 'DAILY FILE CHARGE EAN ' CHARGE-BYE-DATE CL*74 00525 DISPLAY 'DAILY FILE CHARGE DATE ' CHARGE-DATE. CL*74 00526 MOVE CHARGE-DATE TO L001-FED-8-DATE-X. CL*68 00527 PERFORM S001-FROM-FED-8 THRU S001-EXIT. CL*68 00528 IF L001-VALID-DATE CL*68 00529 MOVE L001-FED-8-DATE-9 TO WRK-CHARGE-DATE CL*68 00530 DISPLAY 'FED-8 FILE CHARGE DATE ' WRK-CHARGE-DATE CL*72 00531 ELSE CL*68 00532 SET WRK-ERROR-YES-88 TO TRUE CL*68 00533 MOVE +03 TO RETURN-CODE CL*68 00534 DISPLAY 'INVALID CHARGE DATE: ' CHARGE-DATE CL*68 00535 GO TO I3000-EXIT. CL*68 00536 CL*69 00537 MOVE WRK-CURR-SYS-DATE TO L001-FED-8-DATE-9 CL*73 00538 PERFORM S001-FROM-FED-8 THRU S001-EXIT CL*68 00539 SUBTRACT 1 FROM L001-JUL-ABS-DAY CL*68 00540 PERFORM S001-FROM-ABS-DAY THRU S001-EXIT CL*68 00541 MOVE L001-FED-8-DATE-9 TO WRK-CHARGE-PRIOR-DATE. CL*68 00542 DISPLAY '************************* ' CL*71 00543 DISPLAY '>>>>>>>>>>PRIOR WORK DATE ' WRK-CHARGE-PRIOR-DATE. CL*71 00544 DISPLAY '>>>DAILY FILE CHARGE DATE ' WRK-CHARGE-DATE CL*71 00545 DISPLAY '************************* ' CL*71 00546 CL*68 00547 IF WRK-CHARGE-DATE NOT = WRK-CHARGE-PRIOR-DATE CL*69 00548 SET WRK-ERROR-YES-88 TO TRUE CL*68 00549 MOVE +09 TO RETURN-CODE CL*68 00550 DISPLAY 'INVALID CHARGE DATE: ' CHARGE-DATE CL*69 00551 GO TO I3000-EXIT. CL*69 00552 CL*68 00553 CLOSE CHARGE-IN-FILE. CL*68 00554 OPEN INPUT CHARGE-IN-FILE. CL*68 00555 IF NOT CHARGE-FILE-OK-88 CL*68 00556 DISPLAY 'CHARGE FILE OPEN ERROR: ' CHARGE-IN-STATUS CL*68 00557 SET WRK-ERROR-YES-88 TO TRUE. CL*68 00558 CL*68 00559 I3000-EXIT. CL*68 00560 EXIT. CL*68 00561 CL*68 00562 CHGBD100 00563 P0000-PROCESS. CHGBD100 00564 READ CHARGE-IN-FILE INTO WRK-CHARGE-REC CHGBD100 00565 IF NOT CHARGE-FILE-OK-88 CHGBD100 00566 DISPLAY 'CHARGE FILE EMPTY: ' CHARGE-IN-STATUS CHGBD100 00567 SET WRK-ERROR-YES-88 TO TRUE CHGBD100 00568 MOVE +03 TO RETURN-CODE CL*65 00569 DISPLAY 'P0000 EMPTY: ' RETURN-CODE CL*66 00570 GO TO P0000-EXIT CHGBD100 00571 ELSE CHGBD100 00572 ADD 1 TO WRK-CHARGE-IN-READ. CHGBD100 00573 CHGBD100 00574 PERFORM P1000-SELECT-CHARGES THRU P1000-EXIT CHGBD100 00575 UNTIL CHARGE-FILE-EOF-88. CHGBD100 00576 CHGBD100 00577 P0000-EXIT. CHGBD100 00578 EXIT. CHGBD100 00579 CHGBD100 00580 P1000-SELECT-CHARGES. CHGBD100 00581 SET WRK-EDIT-ERROR-NO-88 TO TRUE. CHGBD100 00582 PERFORM P1100-EDIT-CHARGE-DATE THRU P1100-EXIT. CHGBD100 00583 CHGBD100 00584 PERFORM P1200-EDIT-CWC THRU P1200-EXIT. CHGBD100 00585 CHGBD100 00586 PERFORM P1300-EDIT-BYE-DATE THRU P1300-EXIT. CHGBD100 00587 CHGBD100 00588 PERFORM P1400-EDIT-CHG-AMT THRU P1400-EXIT. CHGBD100 00589 CHGBD100 00590 PERFORM P1500-EDIT-SUPP-CODE THRU P1500-EXIT. CHGBD100 00591 CHGBD100 00592 PERFORM P1600-EDIT-EMP-NO THRU P1600-EXIT. CHGBD100 00593 CHGBD100 00594 PERFORM P1700-EDIT-SSN THRU P1700-EXIT. CHGBD100 00595 CHGBD100 00596 IF WRK-EDIT-ERROR-YES-88 CHGBD100 00597 DISPLAY 'CHARGE FILE DATA ERROR: ' CHARGE-IN-STATUS CL*32 00598 SET WRK-ERROR-YES-88 TO TRUE CL*32 00599 SET CHARGE-FILE-EOF-88 TO TRUE CL*32 00600 GO TO P1000-EXIT. CL*32 00601 CHGBD100 00602 PERFORM P2000-WRITE-SORT-REC THRU P2000-EXIT. CHGBD100 00603 CHGBD100 00604 P1000-READ-NEXT. CHGBD100 00605 READ CHARGE-IN-FILE INTO WRK-CHARGE-REC. CHGBD100 00606 IF CHARGE-FILE-OK-88 CHGBD100 00607 ADD 1 TO WRK-CHARGE-IN-READ CHGBD100 00608 ELSE CHGBD100 00609 IF CHARGE-FILE-EOF-88 CHGBD100 00610 NEXT SENTENCE CHGBD100 00611 ELSE CHGBD100 00612 DISPLAY 'CHARGE FILE READ ERROR: ' CHARGE-IN-STATUS CHGBD100 00613 SET WRK-ERROR-YES-88 TO TRUE CHGBD100 00614 SET CHARGE-FILE-EOF-88 TO TRUE. CHGBD100 00615 CHGBD100 00616 P1000-EXIT. CHGBD100 00617 EXIT. CHGBD100 00618 CHGBD100 00619 P1100-EDIT-CHARGE-DATE. CHGBD100 00620 MOVE CHARGE-DATE TO L001-FED-8-DATE-X. CHGBD100 00621 PERFORM S001-FROM-FED-8 THRU S001-EXIT. CHGBD100 00622 IF L001-VALID-DATE CHGBD100 00623 MOVE L001-FED-8-DATE-9 TO WRK-CHARGE-DATE CHGBD100 00624 ELSE CHGBD100 00625 SET WRK-EDIT-ERROR-YES-88 TO TRUE CHGBD100 00626 DISPLAY 'CHARGE DATE ERROR: ' CHARGE-DATE CL*40 00627 ADD +1 TO WRK-CHG-DT-ERR-CNT CHGBD100 00628 MOVE MSG3-ID2 TO R907-MSG-ID CHGBD100 00629 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CHGBD100 00630 MOVE CHARGE-SSN TO TBL-SSN3 CHGBD100 00631 MOVE CHARGE-DATE TO TBL-CHG-DATE CHGBD100 00632 MOVE MSG3-LONG-TEXT TO R907-MSG-TEXT CHGBD100 00633 PERFORM S946-R907-WRITE THRU S946-EXIT. CHGBD100 00634 CHGBD100 00635 P1100-EXIT. CHGBD100 00636 EXIT. CHGBD100 00637 CHGBD100 00638 P1200-EDIT-CWC. CHGBD100 00639 MOVE CHARGE-EMPL-ACCT TO WRK-EMP-ACCT. CHGBD100 00640 MOVE CHARGE-EMPLOYER-TYPE TO WRK-EMP-TYPE. CHGBD100 00641 CHGBD100 00642 ************************************************************ CHGBD100 00643 * EMPLOYER TYPE NOT SET IN CHARGE RECORDS FOR CWC ACCOUNTS. CHGBD100 00644 * THE FOLLOWING CODE CORRECTS THE EMPLOYER TYPE ON THE CHGBD100 00645 * INPUT RECORDS. CHGBD100 00646 ************************************************************ CHGBD100 00647 MOVE LOW-VALUES TO MSKL-KEY-AREA. CL*35 00648 CL*35 00649 MOVE WRK-EMP-ACCT TO MSKL-EMP-NO. CL*54 00650 CL*35 00651 SET MSKL-PRF-88 TO TRUE. CL*35 00652 CL*35 00653 PERFORM S910-READ THRU S910-EXIT. CL*35 00654 IF L910-OK-88 CL*35 00655 MOVE MSKL-REC TO MPRF-REC CL*35 00656 MOVE MPRF-ELIGIBLE-CD TO WRK-EMP-TYPE CL*56 00657 ELSE CL*35 00658 DISPLAY 'MPRF NOT FOUND ' WRK-EMP-ACCT CL*35 00659 MOVE 'MPRF NOT FOUND ' TO MSG2-ID2 CL*35 00660 SET WRK-EDIT-ERROR-YES-88 TO TRUE CL*35 00661 ADD +1 TO WRK-BYE-ERR-CNT CL*35 00662 DISPLAY 'CHARGE EMP NO FOUND ERROR: ' WRK-EMP-ACCT CL*40 00663 MOVE MSG2-ID2 TO R907-MSG-ID CL*35 00664 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CL*35 00665 MOVE CHARGE-SSN TO TBL-SSN2 CL*35 00666 MOVE CHARGE-BYE-DATE TO TBL-BYE-DATE2 CL*35 00667 MOVE MSG2-LONG-TEXT TO R907-MSG-TEXT CL*35 00668 PERFORM S946-R907-WRITE THRU S946-EXIT CL*35 00669 MOVE ZERO TO WRK-BYE. CL*35 00670 CL*35 00671 IF WRK-EMP-ACCT-CWC-88 CL*54 00672 IF NOT WRK-EMP-TYPE-CWC-88 CL*54 00673 SET WRK-EMP-TYPE-CWC-88 TO TRUE CL*54 00674 MOVE WRK-EMP-TYPE TO CHARGE-EMPLOYER-TYPE. CL*54 00675 CL*35 00676 * DISPLAY 'EMP TYPE ' WRK-EMP-ACCT ' ' WRK-EMP-TYPE CL*58 00677 * ' ' MPRF-ELIGIBLE-CD. CL*58 00678 CHGBD100 00679 MOVE WRK-EMP-TYPE TO CHARGE-EMPLOYER-TYPE. CL*56 00680 * DISPLAY ' NEW TYPE ' CHARGE-EMPLOYER-TYPE. CL*58 00681 P1200-EXIT. CHGBD100 00682 EXIT. CHGBD100 00683 CHGBD100 00684 P1300-EDIT-BYE-DATE. CHGBD100 00685 MOVE CHARGE-BYE-DATE TO L001-FED-8-DATE-X. CHGBD100 00686 PERFORM S001-FROM-FED-8 THRU S001-EXIT. CHGBD100 00687 IF L001-VALID-DATE CHGBD100 00688 MOVE L001-FED-8-DATE-9 TO WRK-BYE CHGBD100 00689 ELSE CHGBD100 00690 SET WRK-EDIT-ERROR-YES-88 TO TRUE CL*32 00691 ADD +1 TO WRK-BYE-ERR-CNT CHGBD100 00692 MOVE MSG2-ID2 TO R907-MSG-ID CHGBD100 00693 DISPLAY 'CHARGE BYE DATE ERROR: ' CHARGE-BYE-DATE CL*40 00694 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CHGBD100 00695 MOVE CHARGE-SSN TO TBL-SSN2 CHGBD100 00696 MOVE CHARGE-BYE-DATE TO TBL-BYE-DATE2 CHGBD100 00697 MOVE MSG2-LONG-TEXT TO R907-MSG-TEXT CHGBD100 00698 PERFORM S946-R907-WRITE THRU S946-EXIT CHGBD100 00699 MOVE ZERO TO WRK-BYE. CHGBD100 00700 CHGBD100 00701 P1300-EXIT. CHGBD100 00702 EXIT. CHGBD100 00703 CHGBD100 00704 P1400-EDIT-CHG-AMT. CHGBD100 00705 MOVE CHARGE-CURR-AMT TO WRK-CHG-CURR-AMT CL*41 00706 IF WRK-CHG-CURR-AMT NOT NUMERIC CL*41 00707 SET WRK-EDIT-ERROR-YES-88 TO TRUE CHGBD100 00708 DISPLAY 'CHARGE AMT ERROR: ' CHARGE-CURR-AMT CL*40 00709 ADD +1 TO WRK-CHG-AMT-ERR-CNT CHGBD100 00710 MOVE MSG4-ID2 TO R907-MSG-ID CHGBD100 00711 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CHGBD100 00712 MOVE CHARGE-SSN TO TBL-SSN2 CHGBD100 00713 MOVE CHARGE-CURR-AMT TO TBL-CURR-AMT CHGBD100 00714 MOVE MSG4-LONG-TEXT TO R907-MSG-TEXT CHGBD100 00715 PERFORM S946-R907-WRITE THRU S946-EXIT. CHGBD100 00716 CHGBD100 00717 ADD WRK-CHG-CURR-AMT TO WRK-CHG-TOT-AMT. CL*63 00718 MOVE WRK-CHG-TOT-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*63 00719 DISPLAY ' CHARGE AMOUNT ON FILER = ' CL*63 00720 TOT-CHARGE-CURR-AMT-DISP. CL*63 00721 P1400-EXIT. CHGBD100 00722 EXIT. CHGBD100 00723 CHGBD100 00724 P1500-EDIT-SUPP-CODE. CHGBD100 00725 * DISPLAY 'PRGCODE-X ' CHARGE-PROG-X CL*52 00726 * MOVE CHARGE-PROG-X TO WRK-BEN-PROG-CODE. CL*53 00727 CHGBD100 00728 IF CHARGE-PROG-X = '01' OR CHARGE-PROG-X = '02' CL*53 00729 OR CHARGE-PROG-X = '05' OR CHARGE-PROG-X = '07' CL*53 00730 OR CHARGE-PROG-X = '21' CL*53 00731 MOVE '01' TO WRK-BEN-PROG-CODE. CL*57 00732 CL*53 00733 IF CHARGE-EMPL-ACCT = 005033 CL*23 00734 MOVE 'X' TO WRK-BEN-PROG-CODE-PFX. CL*23 00735 CL*23 00736 IF CHARGE-EMPL-ACCT = 005032 CL*18 00737 MOVE 'Y' TO WRK-BEN-PROG-CODE-SFX CL*45 00738 MOVE 'Y' TO WRK-BEN-PROG-CODE-PFX. CL*45 00739 CL*20 00740 IF CHARGE-EMPL-ACCT = 005031 CL*20 00741 MOVE 'N' TO WRK-BEN-PROG-CODE-PFX. CL*21 00742 CL*20 00743 IF CHARGE-EMPL-ACCT = 005030 CL*20 00744 MOVE 'M' TO WRK-BEN-PROG-CODE-PFX. CL*21 00745 CL*20 00746 IF CHARGE-EMPL-ACCT = 005029 CL*20 00747 MOVE 'L' TO WRK-BEN-PROG-CODE-PFX. CL*21 00748 CL*20 00749 IF CHARGE-EMPL-ACCT = 005034 CL*30 00750 MOVE 'R' TO WRK-BEN-PROG-CODE-PFX. CL*25 00751 CL*30 00752 IF CHARGE-EMPL-ACCT = 005035 CL*30 00753 MOVE 'R' TO WRK-BEN-PROG-CODE-PFX. CL*30 00754 CL*30 00755 IF CHARGE-EMPL-ACCT = 005036 CL*30 00756 MOVE 'U' TO WRK-BEN-PROG-CODE-PFX. CL*30 00757 CL*30 00758 IF CHARGE-EMPL-ACCT = 005027 CL*28 00759 MOVE 'U' TO WRK-BEN-PROG-CODE-PFX. CL*28 00760 CL*28 00761 CL*24 00762 CL*11 00763 * DISPLAY 'PFX ' WRK-BEN-PROG-CODE-PFX CL*52 00764 * DISPLAY 'SFX ' WRK-BEN-PROG-CODE-SFX CL*52 00765 CL*39 00766 * EVALUATE WRK-BEN-PROG-CODE-SFX CL*48 00767 EVALUATE WRK-BEN-PROG-CODE CL*48 00768 CHGBD100 00769 WHEN '01' CL*48 00770 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UI-AMT CL*46 00771 SET WRK-PROG-UI-88 TO TRUE CHGBD100 00772 CHGBD100 00773 * WHEN '02' CL*57 00774 * ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UCFE-AMT CL*53 00775 * SET WRK-PROG-EB-88 TO TRUE CL*57 00776 CHGBD100 00777 * WHEN '2' CL*35 00778 * SET WRK-PROG-FSB-88 TO TRUE CL*35 00779 CHGBD100 00780 * WHEN '3' CL*35 00781 * SET WRK-PROG-FSC-88 TO TRUE CL*35 00782 CHGBD100 00783 * WHEN '4' CL*35 00784 * SET WRK-PROG-DUA-88 TO TRUE CL*35 00785 CHGBD100 00786 * WHEN '05' CL*57 00787 * ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UCX-AMT CL*53 00788 * SET WRK-PROG-TR2-88 TO TRUE CL*57 00789 CHGBD100 00790 * WHEN '6' CL*35 00791 * SET WRK-PROG-TRA-88 TO TRUE CL*35 00792 CHGBD100 00793 * WHEN '07' CL*57 00794 * ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-CWC-AMT CL*53 00795 * SET WRK-PROG-TEUC-88 TO TRUE CL*57 00796 CHGBD100 00797 * WHEN '21' CL*57 00798 * ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-OTH-AMT CL*53 00799 * SET WRK-PROG-TEUC-88 TO TRUE CL*57 00800 CL*50 00801 * WHEN '8' CL*35 00802 * SET WRK-PROG-TEUCA-88 TO TRUE CL*35 00803 CHGBD100 00804 * WHEN '9' CL*35 00805 * SET WRK-PROG-STEPLDR-88 TO TRUE CL*35 00806 CHGBD100 00807 * WHEN 'F' CL*35 00808 * SET WRK-PROG-FAC-88 TO TRUE CL*35 00809 CHGBD100 00810 * WHEN 'A' CL*35 00811 * SET WRK-PROG-AB-88 TO TRUE CL*35 00812 CHGBD100 00813 * WHEN 'T' CL*35 00814 * SET WRK-PROG-TRAINING-88 TO TRUE CL*35 00815 CHGBD100 00816 * WHEN 'D' CL*35 00817 * SET WRK-PROG-DEPENDENTS-88 TO TRUE CL*35 00818 CHGBD100 00819 * WHEN 'P' CL*35 00820 * SET WRK-PROG-EUC08-2PLUS-88 TO TRUE CL*35 00821 CHGBD100 00822 * WHEN 'E' CL*35 00823 * SET WRK-PROG-EUC08-TIER3-88 TO TRUE CL*35 00824 CHGBD100 00825 * WHEN 'Z' CL*35 00826 * SET WRK-PROG-EUC08-TIER4-88 TO TRUE CL*35 00827 CHGBD100 00828 * WHEN 'S' CL*35 00829 * SET WRK-PROG-SPECIAL-PAY-88 TO TRUE CL*35 00830 CHGBD100 00831 * WHEN 'U' CL*35 00832 * SET WRK-PROG-PUA-88 TO TRUE CL*35 00833 CL**3 00834 * WHEN 'L' CL*35 00835 * SET WRK-PROG-FPUC-88 TO TRUE CL*35 00836 CL**3 00837 * WHEN 'M' CL*35 00838 * SET WRK-PROG-FRUR-88 TO TRUE CL*35 00839 CL*14 00840 * WHEN 'N' CL*35 00841 * SET WRK-PROG-PEUC-88 TO TRUE CL*35 00842 CL*18 00843 WHEN 'YY' CL*48 00844 * ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-SPEC-AMT CL*59 00845 SET WRK-PROG-REUR-88 TO TRUE CL*45 00846 CL**3 00847 * WHEN 'X' CL*35 00848 * SET WRK-PROG-LWA-88 TO TRUE CL*35 00849 CL*23 00850 * WHEN 'R' CL*35 00851 * SET WRK-PROG-PUA-STIM-88 TO TRUE CL*35 00852 CL*25 00853 WHEN OTHER CHGBD100 00854 DISPLAY 'BD100 P1500 PROG CODE : ' CL*27 00855 WRK-BEN-PROG-CODE ' ' CHARGE-EMPL-ACCT CL*57 00856 SET WRK-EDIT-ERROR-YES-88 TO TRUE CL*40 00857 DISPLAY 'CHARGE PGM CODE ERROR: ' CHARGE-PROG-X CL*40 00858 ADD +1 TO WRK-SUPP-CD-ERR-CNT CHGBD100 00859 MOVE MSG5-ID2 TO R907-MSG-ID CHGBD100 00860 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CHGBD100 00861 MOVE CHARGE-SSN TO TBL-SSN5 CHGBD100 00862 MOVE WRK-BEN-PROG-CODE-PFX TO TBL-SUPP-CODE CHGBD100 00863 MOVE MSG5-LONG-TEXT TO R907-MSG-TEXT CHGBD100 00864 PERFORM S946-R907-WRITE THRU S946-EXIT CHGBD100 00865 CHGBD100 00866 END-EVALUATE. CHGBD100 00867 CHGBD100 00868 IF WRK-BEN-PROG-CODE = '01' AND CHARGE-CODE = '4' CL*53 00869 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UI4-AMT CL*53 00870 ELSE CL*53 00871 IF WRK-BEN-PROG-CODE = '01' CL*57 00872 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UI3-AMT. CL*53 00873 CL*53 00874 IF CHARGE-EMPLOYER-TYPE = '00' CL*53 00875 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-RAT-AMT CL*53 00876 ELSE CL*53 00877 IF CHARGE-EMPLOYER-TYPE = '01' CL*53 00878 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UCFE-AMT CL*53 00879 ELSE CL*53 00880 IF CHARGE-EMPLOYER-TYPE = '02' CL*53 00881 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-UCX-AMT CL*60 00882 ELSE CL*53 00883 IF CHARGE-EMPLOYER-TYPE = '04' CL*53 00884 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-CWC-AMT CL*53 00885 ELSE CL*53 00886 IF CHARGE-EMPLOYER-TYPE = '08' CL*53 00887 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-REM-AMT CL*53 00888 ELSE CL*53 00889 IF CHARGE-EMPLOYER-TYPE = '10' CL*53 00890 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-DCG-AMT CL*53 00891 ELSE CL*53 00892 ADD WRK-CHG-CURR-AMT TO TOT-CHARGE-SPEC-AMT CL*59 00893 DISPLAY ' EMPLOYER TYPE ' CHARGE-EMPLOYER-TYPE. CL*53 00894 CHGBD100 00895 P1500-EXIT. CHGBD100 00896 EXIT. CHGBD100 00897 CHGBD100 00898 P1600-EDIT-EMP-NO. CHGBD100 00899 IF CHARGE-EMPL-ACCT < +1 CHGBD100 00900 SET WRK-EDIT-ERROR-YES-88 TO TRUE CHGBD100 00901 DISPLAY 'CHARGE EMP ERROR: ' CHARGE-EMPL-ACCT CL*40 00902 ADD +1 TO WRK-EMP-NO-ERR-CNT CHGBD100 00903 MOVE MSG6-ID2 TO R907-MSG-ID CHGBD100 00904 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO CHGBD100 00905 MOVE CHARGE-SSN TO MSG6-SSN CHGBD100 00906 MOVE MSG6-LONG-TEXT TO R907-MSG-TEXT CHGBD100 00907 PERFORM S946-R907-WRITE THRU S946-EXIT. CHGBD100 00908 CHGBD100 00909 P1600-EXIT. CHGBD100 00910 EXIT. CHGBD100 00911 CHGBD100 00912 CHGBD100 00913 P1700-EDIT-SSN. CHGBD100 00914 MOVE CHARGE-KEY TO WRK-KEY-X. CHGBD100 00915 IF WRK-KEY-N NUMERIC CHGBD100 00916 IF WRK-KEY-N > ZERO CHGBD100 00917 NEXT SENTENCE CHGBD100 00918 ELSE CHGBD100 00919 PERFORM P1710-SSN-ERROR THRU P1710-EXIT CHGBD100 00920 ELSE CHGBD100 00921 PERFORM P1710-SSN-ERROR THRU P1710-EXIT. CHGBD100 00922 CHGBD100 00923 P1700-EXIT. CHGBD100 00924 EXIT. CHGBD100 00925 CHGBD100 00926 P1710-SSN-ERROR. CHGBD100 00927 SET WRK-EDIT-ERROR-YES-88 TO TRUE. CHGBD100 00928 ADD +1 TO WRK-SSN-ERR-CNT. CHGBD100 00929 DISPLAY 'CHARGE SSN ERROR: ' CHARGE-SSN CL*40 00930 MOVE MSG7-ID2 TO R907-MSG-ID. CHGBD100 00931 MOVE CHARGE-EMPL-ACCT TO R907-EMP-NO. CHGBD100 00932 MOVE CHARGE-SSN TO MSG7-SSN. CHGBD100 00933 MOVE MSG7-LONG-TEXT TO R907-MSG-TEXT. CHGBD100 00934 PERFORM S946-R907-WRITE THRU S946-EXIT. CHGBD100 00935 CHGBD100 00936 P1710-EXIT. CHGBD100 00937 EXIT. CHGBD100 00938 CHGBD100 00939 P2000-WRITE-SORT-REC. CHGBD100 00940 MOVE LOW-VALUES TO CHG1-SORT-KEY-AREA. CHGBD100 00941 MOVE WRK-KEY-N TO CHG1-SSN. CHGBD100 00942 MOVE CHARGE-EMPL-ACCT TO CHG1-EMP-NO. CHGBD100 00943 MOVE WRK-BYE TO CHG1-BYE. CHGBD100 00944 CHGBD100 00945 MOVE WRK-CHARGE-DATE TO CHG1-CHARGE-DATE. CHGBD100 00946 MOVE CHARGE-CODE TO CHG1-CHARGE-CODE. CHGBD100 00947 MOVE WRK-PROGRAM TO CHG1-CHARGE-PROGRAM. CHGBD100 00948 MOVE CHARGE-PAY-TYPE TO CHG1-CHARGE-PAY-TYPE. CHGBD100 00949 MOVE CHARGE-NAME TO CHG1-CHARGE-NAME. CHGBD100 00950 MOVE CHARGE-EMPLOYER-TYPE TO CHG1-CHARGE-EMP-TYPE. CHGBD100 00951 MOVE CHARGE-CURR-AMT TO CHG1-CHARGE-CURR-AMT. CHGBD100 00952 ADD CHG1-CHARGE-CURR-AMT TO TOT-CHARGE-CURR-AMT. CL*61 00953 CL*61 00954 WRITE SORT-CHG-REC FROM WRK-CHG-REC. CL*62 00955 ADD 1 TO WRK-SORT-CHG-WRITTEN. CHGBD100 00956 CL*60 00957 CHGBD100 00958 P2000-EXIT. CHGBD100 00959 EXIT. CHGBD100 00960 CHGBD100 00961 T0000-TERMINATE. CHGBD100 00962 CLOSE CHARGE-IN-FILE CHGBD100 00963 BD100-CHG-FILE. CHGBD100 00964 PERFORM S910-CLOSE THRU S910-EXIT. CL*36 00965 PERFORM S921-CLOSE THRU S921-EXIT. CL*36 00966 CHGBD100 00967 DISPLAY ' CHGBD100 CHARGE RECORDS READ : ' CHGBD100 00968 WRK-CHARGE-IN-READ. CHGBD100 00969 DISPLAY ' CHARGE RECORDS WRITTEN: ' CHGBD100 00970 WRK-SORT-CHG-WRITTEN. CHGBD100 00971 DISPLAY ' BYE DATE ERRORS ACCEPTED: ' CHGBD100 00972 WRK-BYE-ERR-CNT. CHGBD100 00973 DISPLAY ' CHARGE DATE ERRORS: ' CHGBD100 00974 WRK-CHG-DT-ERR-CNT CHGBD100 00975 DISPLAY ' EMPLOYER TYPE ERRORS: ' CHGBD100 00976 WRK-EMP-TYPE-ERR-CNT. CHGBD100 00977 DISPLAY ' CHARGE AMOUNT ERRORS: ' CHGBD100 00978 WRK-CHG-AMT-ERR-CNT. CHGBD100 00979 DISPLAY ' SUPP CODE ERRORS: ' CHGBD100 00980 WRK-SUPP-CD-ERR-CNT. CHGBD100 00981 CHGBD100 00982 DISPLAY ' EMP NO ERRORS: ' CHGBD100 00983 WRK-EMP-NO-ERR-CNT. CHGBD100 00984 CHGBD100 00985 DISPLAY ' SSN ERRORS: ' CHGBD100 00986 WRK-SSN-ERR-CNT. CHGBD100 00987 CHGBD100 00988 DISPLAY ' '. CHGBD100 00989 MOVE TOT-CHARGE-CURR-AMT TO TOT-CHARGE-CURR-AMT-DISP. CHGBD100 00990 DISPLAY ' TOTAL CHARGE AMOUNT ON FILER = ' CL*57 00991 TOT-CHARGE-CURR-AMT-DISP. CHGBD100 00992 * CHGBD100 00993 DISPLAY ' '. CL*46 00994 MOVE TOT-CHARGE-UI-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*46 00995 DISPLAY ' UI-TOTAL CHARGE AMT ALL ACCT = ' CL*57 00996 TOT-CHARGE-CURR-AMT-DISP. CL*46 00997 * CL*51 00998 DISPLAY ' '. CL*51 00999 MOVE TOT-CHARGE-UI4-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*51 01000 DISPLAY ' UI BENEFITS PAID AMOUNT = ' CL*57 01001 TOT-CHARGE-CURR-AMT-DISP. CL*51 01002 * CL*51 01003 DISPLAY ' '. CL*51 01004 MOVE TOT-CHARGE-UI3-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*51 01005 DISPLAY ' UI BENEFITS ADJUT AMOUNT = ' CL*57 01006 TOT-CHARGE-CURR-AMT-DISP. CL*51 01007 * CL*46 01008 DISPLAY ' '. CL*46 01009 MOVE TOT-CHARGE-UCFE-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*46 01010 DISPLAY ' UCFE TOTAL CHARGE AMOUNT = ' CL*46 01011 TOT-CHARGE-CURR-AMT-DISP. CL*47 01012 * CL*46 01013 DISPLAY ' '. CL*46 01014 MOVE TOT-CHARGE-UCX-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*46 01015 DISPLAY ' UCX TOTAL CHARGE AMOUNT = ' CL*46 01016 TOT-CHARGE-CURR-AMT-DISP. CL*53 01017 * CL*46 01018 DISPLAY ' '. CL*49 01019 MOVE TOT-CHARGE-CWC-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*49 01020 DISPLAY ' CWC TOTAL CHARGE AMOUNT = ' CL*49 01021 TOT-CHARGE-CURR-AMT-DISP. CL*53 01022 * CL*49 01023 DISPLAY ' '. CL*50 01024 MOVE TOT-CHARGE-RAT-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*53 01025 DISPLAY ' RATED TOTAL CHARGE AMOUNT = ' CL*53 01026 TOT-CHARGE-CURR-AMT-DISP. CL*53 01027 * CL*50 01028 DISPLAY ' '. CL*53 01029 MOVE TOT-CHARGE-REM-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*53 01030 DISPLAY ' SELF INF TOT CHARGE AMOUNT = ' CL*53 01031 TOT-CHARGE-CURR-AMT-DISP. CL*53 01032 * CL*53 01033 DISPLAY ' '. CL*53 01034 MOVE TOT-CHARGE-DCG-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*53 01035 DISPLAY ' DC GOV TOTAL CHARGE AMOUNT = ' CL*53 01036 TOT-CHARGE-CURR-AMT-DISP. CL*53 01037 * CL*53 01038 DISPLAY ' '. CL*53 01039 MOVE TOT-CHARGE-OTH-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*53 01040 DISPLAY ' OTH TOTAL CHARGE AMOUNT = ' CL*53 01041 TOT-CHARGE-CURR-AMT-DISP. CL*53 01042 * CL*53 01043 DISPLAY ' '. CL*46 01044 MOVE TOT-CHARGE-SPEC-AMT TO TOT-CHARGE-CURR-AMT-DISP. CL*46 01045 DISPLAY ' SPECIAL TOTAL CHARGE AMOUNT = ' CL*46 01046 TOT-CHARGE-CURR-AMT-DISP. CL*46 01047 T0000-EXIT. CHGBD100 01048 EXIT. CHGBD100 01049 EJECT CHGBD100 01050 CHGBD100 01051 S001-FROM-CAL-6. CHGBD100 01052 SET L001-FROM-CAL-6 TO TRUE. CHGBD100 01053 GO TO S001-DATE. CHGBD100 01054 CHGBD100 01055 S001-FROM-FED-8. CHGBD100 01056 SET L001-FROM-FED-8 TO TRUE. CHGBD100 01057 GO TO S001-DATE. CHGBD100 01058 S001-FROM-ABS-DAY. CL*69 01059 SET L001-FROM-ABS-DAY TO TRUE. CL*69 01060 GO TO S001-DATE. CL*69 01061 CHGBD100 01062 S001-DATE. CHGBD100 01063 CALL 'DTSBU001' USING L001-LINK-AREA. CHGBD100 01064 S001-EXIT. EXIT. CHGBD100 01065 CHGBD100 01066 S004-FROM-DATE. CHGBD100 01067 SET L004-FROM-DATE TO TRUE. CHGBD100 01068 GO TO S004-YRQ. CHGBD100 01069 CHGBD100 01070 S004-YRQ. CHGBD100 01071 CALL 'DTSBU004' USING L004-LINK-AREA. CHGBD100 01072 S004-EXIT. EXIT. CHGBD100 01073 S005-FROM-SYS. CL*73 01074 SET L005-FROM-SYS TO TRUE. CL*73 01075 CALL 'DTSBU005' USING L005-LINK-AREA. CL*73 01076 CL*73 01077 S005-EXIT. CL*73 01078 EXIT. CL*73 01079 CL*73 01080 CHGBD100 01081 ** ADD ERROR MSG PROCESS PARA. CHGBD100 01082 S910-OPEN-READ. CL*34 01083 SET L910-OPEN-READ-88 TO TRUE. CL*34 01084 GO TO S910-MSTR-IO. CL*34 01085 CL*34 01086 S910-READ. CL*35 01087 SET L910-READ-88 TO TRUE. CL*35 01088 GO TO S910-MSTR-IO. CL*35 01089 CL*34 01090 S910-CLOSE. CL*34 01091 SET L910-CLOSE-88 TO TRUE. CL*34 01092 GO TO S910-MSTR-IO. CL*34 01093 CL*34 01094 S910-MSTR-IO. CL*34 01095 CALL 'DTSBU910' USING L910-LINK-AREA CL*34 01096 MSKL-REC. CL*34 01097 CL*34 01098 S910-EXIT. CL*34 01099 EXIT. CL*34 01100 S921-OPEN-READ. CL*34 01101 SET L921-OPEN-READ-88 TO TRUE. CL*34 01102 GO TO S921-AIX-IO. CL*34 01103 CL*34 01104 S921-CLOSE. CL*34 01105 SET L921-CLOSE-88 TO TRUE. CL*34 01106 GO TO S921-AIX-IO. CL*34 01107 CL*34 01108 S921-AIX-IO. CL*34 01109 CALL 'DTSBU921' USING L921-LINK-AREA CL*34 01110 ISKL-REC. CL*34 01111 CL*34 01112 S921-EXIT. CL*34 01113 EXIT. CL*34 01114 CL*34 01115 S946-R907-WRITE. CHGBD100 01116 CALL 'DTSBU946' USING R907-REC. CHGBD100 01117 S946-EXIT. EXIT. CHGBD100 01118 CHGBD100 01119 S999-ABEND. CHGBD100 01120 DISPLAY '**** CHGBD100 ABENDING ' CHGBD100 01121 ABEND-MSG. CHGBD100 01122 CALL ABEND-MOD USING ABEND-CODE. CHGBD100 01123 CHGBD100 01124 S999-EXIT. CHGBD100 01125 EXIT. CHGBD100