00001 IDENTIFICATION DIVISION. 10/31/19 00002 PROGRAM-ID. DTSBX424. DTSBX424 00003 AUTHOR. NGC. LV064 00004 DATE-WRITTEN. APRIL 2005. DTSBX424 00005 DATE-COMPILED. DTSBX424 00006 SKIP3 DTSBX424 00007 ***** DTSBX424 00008 * DTSBX424 00009 * FUNCTION: WEB IMPORT: PROFILE DATA. DTSBX424 00010 * PROCESS ADDRESSES, NAMES (EXCEPT ENTITY AND FIRST DTSBX424 00011 * TRADE NAME), OWNERS/OFFICERS/PARTNERS. DTSBX424 00012 * DTSBX424 00013 * MODIFICATION HISTORY: DTSBX424 00014 * DTSBX424 00015 * 04-05-2005 INITIAL DEVELOPMENT DTSBX424 00016 * REFERENCE RFP: WEB REGISTRATION DTSBX424 00017 * 02-20-2008 ADDED CALL TO DTSBU072 TO VERIFY ADDRESS DTSBX424 00018 * REFERENCE RFP: WEB REGISTRATION DTSBX424 00019 * DTSBX424 00020 * 09-22-2009 ADDED EDIT IN P1510 TO CATCH SIMULTANEOUS DTSBX424 00021 * CHANGES ON WEB AND MAINFRAME. DTSBX424 00022 * REFERENCE RFP: WEB REGISTRATION DTSBX424 00023 * DTSBX424 00024 * CL*23 00025 * 11-22-2014 DUE TO THE COMMAS IN ADDESS FIELDS, X110 AND 120 CL*23 00026 * DOES NOT CALL BX205 INSTED IT USES THE IMPORT REC CL*23 00027 * FROM ESSP. ESSP PASSES A FIXED LENGTH RECORD CL*23 00028 * MODIFIED X120 FOR TO USE FIELDS FROM W120 CL*24 00029 * REFERENCE RFP: WEB REGISTRATION ZL1 CL*23 00030 * CL*23 00031 * 11-24-2014 MODIFIED PROGRAM TO WWITE EMPLOYER ADDRES AND OPO CL*26 00032 * INFORMATION ON A SEPARATE BTC FILE. CL*26 00033 * REFERENCE RFP: WEB REGISTRATION ZL1 CL*26 00034 * CL*26 00035 * CL*26 00036 ***** DTSBX424 00037 SKIP3 DTSBX424 00038 ENVIRONMENT DIVISION. DTSBX424 00039 CONFIGURATION SECTION. CL*42 00040 SPECIAL-NAMES. C01 IS TOP-OF-PAGE. CL*42 00041 SKIP2 CL*42 00042 SKIP2 DTSBX424 00043 INPUT-OUTPUT SECTION. DTSBX424 00044 DTSBX424 00045 FILE-CONTROL. DTSBX424 00046 CL*25 00047 SELECT TEMP-BTC-FILE ASSIGN TO X424BTC CL*25 00048 FILE STATUS IS TEMP-BTC-STATUS. CL*25 00049 SELECT REPT-PAID-FILE ASSIGN TO X424RPT1 CL*35 00050 FILE STATUS IS REPT-STATUS. CL*35 00051 CL*35 00052 SELECT REPT-PEND-FILE ASSIGN TO X424RPT2 CL*35 00053 FILE STATUS IS REPT-STATUS. CL*35 00054 CL*35 00055 CL*25 00056 DTSBX424 00057 DATA DIVISION. DTSBX424 00058 CL*25 00059 FILE SECTION. CL*25 00060 FD TEMP-BTC-FILE CL*25 00061 RECORDING MODE IS V CL*25 00062 BLOCK CONTAINS 0 RECORDS. CL*25 00063 CL*25 00064 01 TEMP-BTC-REC. CL*25 00065 ++INCLUDE DTSIRVAR CL*25 00066 CL*25 00067 01 TSKL-REC. CL*25 00068 ++INCLUDE DTSITSKL CL*25 00069 FD REPT-PAID-FILE CL*35 00070 RECORDING MODE IS F CL*35 00071 BLOCK CONTAINS 0 RECORDS CL*35 00072 LABEL RECORDS ARE OMITTED. CL*35 00073 CL*35 00074 01 REPT-PAID-REC PIC X(200). CL*41 00075 CL*35 00076 CL*35 00077 FD REPT-PEND-FILE CL*35 00078 RECORDING MODE IS F CL*35 00079 BLOCK CONTAINS 0 RECORDS CL*35 00080 LABEL RECORDS ARE OMITTED. CL*35 00081 CL*35 00082 01 REPT-PEND-REC PIC X(133). CL*60 00083 CL*35 00084 CL*35 00085 DTSBX424 00086 WORKING-STORAGE SECTION. DTSBX424 000865 77 PAN-VALET PICTURE X(24) VALUE '064DTSBX424 10/31/19'. DTSBX424 00087 77 PAN-VALET PICTURE X(24) VALUE '011DTSBX424 10/07/14'. DTSBX424 00088 77 PAN-VALET PICTURE X(24) VALUE '011DTSBX424 09/24/14'. DTSBX424 00089 SKIP3 DTSBX424 00090 01 WRK-AREA. DTSBX424 00091 05 W-ABEND-CD PIC S9(04) COMP VALUE 424. DTSBX424 00092 05 W-MOD-NAME PIC X(08) VALUE 'DTSBX424'.DTSBX424 00093 05 W-RUN-DATE PIC 9(07) VALUE 0. CL*49 00094 05 Z-RUN-DATE REDEFINES W-RUN-DATE. CL*49 00095 10 Z-CC PIC 9(01). CL*49 00096 10 Z-YY PIC 9(02). CL*49 00097 10 Z-MM PIC 9(02). CL*49 00098 10 Z-DD PIC 9(02). CL*49 00099 DTSBX424 00100 05 W-EMP-NO PIC S9(07) COMP-3 VALUE +0. DTSBX424 00101 CL*25 00102 05 TEMP-BTC-STATUS PIC X(02). CL*25 00103 88 TEMP-BTC-STATUS-OK-88 VALUE '00'. CL*25 00104 88 TEMP-BTC-STATUS-EOF-88 VALUE '10'. CL*25 00105 CL*25 00106 05 REPT-STATUS PIC X(02). CL*38 00107 88 REPT-STATUS-OK-88 VALUE '00'. CL*38 00108 88 REPT-STATUS-EOF-88 VALUE '10'. CL*38 00109 CL*38 00110 DTSBX424 00111 05 W-NEW-X110-EMP PIC 9(01) VALUE 0. CL**5 00112 CL**5 00113 05 W-ERROR-IND PIC X(01) VALUE 'N'. CL**4 00114 88 W-ERROR-YES-88 VALUE 'Y'. DTSBX424 00115 88 W-ERROR-NO-88 VALUE 'N'. DTSBX424 00116 DTSBX424 00117 05 W-FATAL-ERROR-IND PIC X(01) VALUE 'N'. DTSBX424 00118 88 W-FATAL-ERROR-YES-88 VALUE 'Y'. DTSBX424 00119 88 W-FATAL-ERROR-NO-88 VALUE 'N'. DTSBX424 00120 DTSBX424 00121 05 W-MNTE-SUBJECT PIC X(40). DTSBX424 00122 88 W-MNTE-NOT-LIAB-88 VALUE DTSBX424 00123 'REASON FOR NOT-LIABLE DETERMINATION '. DTSBX424 00124 88 W-MNTE-KEY-WORD-88 VALUE DTSBX424 00125 'FR-500 INDUSTRY DESCRIPTION - KEY WORD '. DTSBX424 00126 88 W-MNTE-DATA-ENTRY-88 VALUE DTSBX424 00127 'FR-500 INDUSTRY DESCRIPTION - DATA ENTRY'. DTSBX424 00128 88 W-MNTE-RELATIONSHIP-88 VALUE DTSBX424 00129 'WEB REGISTRATION RELATED EMPLOYER '. DTSBX424 00130 DTSBX424 00131 05 W-MNTE-COMPLETE-IND PIC X(01) VALUE 'N'. DTSBX424 00132 88 W-MNTE-COMPLETE-YES-88 VALUE 'Y'. DTSBX424 00133 88 W-MNTE-COMPLETE-NO-88 VALUE 'N'. DTSBX424 00134 DTSBX424 00135 05 W-NAME-AREA PIC X(40). DTSBX424 00136 05 TSUB1 PIC S9(04) COMP. DTSBX424 00137 05 TSUB2 PIC S9(04) COMP. DTSBX424 00138 05 W-LAST-SPACE PIC S9(04) COMP. DTSBX424 00139 DTSBX424 00140 05 W-MNTE-LINE PIC X(72). DTSBX424 00141 DTSBX424 00142 05 W-SLASH-DATE PIC X(10). DTSBX424 00143 05 FILLER REDEFINES W-SLASH-DATE. DTSBX424 00144 10 W-SLASH-DT-MM PIC X(02). DTSBX424 00145 10 FILLER PIC X(01). DTSBX424 00146 10 W-SLASH-DT-DD PIC X(02). DTSBX424 00147 10 FILLER PIC X(01). DTSBX424 00148 10 W-SLASH-DT-CCYY PIC X(04). DTSBX424 00149 DTSBX424 00150 05 W-SLASH-QTR PIC X(06). DTSBX424 00151 05 FILLER REDEFINES W-SLASH-QTR. DTSBX424 00152 10 W-SLASH-QTR-CCYY PIC X(04). DTSBX424 00153 10 FILLER PIC X(01). DTSBX424 00154 10 W-SLASH-QTR-Q PIC X(01). DTSBX424 00155 DTSBX424 00156 05 WRK-PHONE PIC X(15) VALUE SPACES. DTSBX424 00157 05 FILLER REDEFINES WRK-PHONE. DTSBX424 00158 10 WRK-AREA-CD PIC X(03). DTSBX424 00159 10 WRK-PREFIX PIC X(03). DTSBX424 00160 10 WRK-SUFFIX PIC X(04). DTSBX424 00161 10 WRK-EXT PIC X(05). DTSBX424 00162 05 WRK-EXT-HYPHEN PIC X(01) VALUE SPACES. DTSBX424 00163 05 WRK-PHONE-TEXT1 PIC X(72) VALUE SPACES. DTSBX424 00164 05 WRK-PHONE-TEXT2 PIC X(72) VALUE SPACES. DTSBX424 00165 DTSBX424 00166 * NAME DTSBX424 00167 05 W-X106-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00168 * ADDRESS DTSBX424 00169 05 W-X110-RED-CNT PIC S9(07) COMP-3 VALUE +0. CL*19 00170 05 W-X110-ERR-CNT PIC S9(07) COMP-3 VALUE +0. CL*19 00171 * OPO DTSBX424 00172 05 W-X120-RED-CNT PIC S9(07) COMP-3 VALUE +0. CL*19 00173 05 W-X120-ERR-CNT PIC S9(07) COMP-3 VALUE +0. CL*19 00174 DTSBX424 00175 05 W-T002-NAME-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00176 05 W-T002-ADDR-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00177 05 W-T002-OPO-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00178 05 W-T002-WRITE-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00179 DTSBX424 00180 05 W-T003-WRITE-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00181 DTSBX424 00182 DTSBX424 00183 05 W-X106-LENGTH PIC S9(04) COMP. DTSBX424 00184 05 W-X110-LENGTH PIC S9(04) COMP. DTSBX424 00185 05 W-X120-LENGTH PIC S9(04) COMP. CL*28 00186 05 VAR-CHAR-CNT PIC S9(04) COMP. CL*27 00187 DTSBX424 00188 05 W-AMT-DISP1 PIC ----------9.99. DTSBX424 00189 05 W-AMT-DISP2 PIC ----------9.99. DTSBX424 00190 DTSBX424 00191 05 WRK-R140-CNT PIC S9(07) COMP-3 VALUE +0. DTSBX424 00192 05 DISPLAY-CNT PIC Z(06)9. DTSBX424 00193 05 WRK-MPRF-EXISTS-IND PIC X(01). DTSBX424 00194 88 WRK-MPRF-EXISTS-YES-88 VALUE 'Y'. DTSBX424 00195 88 WRK-MPRF-EXISTS-NO-88 VALUE 'N'. DTSBX424 00196 DTSBX424 00197 01 MESSAGE-AREA. DTSBX424 00198 05 MSG1-TYPE. DTSBX424 00199 10 FILLER PIC X(04) DTSBX424 00200 VALUE 'RATE'. DTSBX424 00201 05 MSG1-MESSAGE. DTSBX424 00202 10 FILLER PIC X(30) DTSBX424 00203 VALUE 'INVALID RATE: NO DECIMAL POINT'. DTSBX424 00204 01 HEADER-1. CL*35 00205 05 FILLER PIC X(01) VALUE SPACES. CL*35 00206 05 FILLER PIC X(49) VALUE 'X424R'. CL*35 00207 05 FILLER PIC X(60) VALUE CL*35 00208 'DISTRICT OF COLUMBIA'. CL*35 00209 05 FILLER PIC X(06) VALUE 'DATE:'. CL*35 00210 05 HDR1-DATE. CL*35 00211 10 W-MM PIC X(02). CL*35 00212 10 FILLER PIC X(01) VALUE '/'. CL*35 00213 10 W-DD PIC X(02). CL*35 00214 10 FILLER PIC X(01) VALUE '/'. CL*35 00215 10 W-YY PIC X(02). CL*35 00216 01 HEADER-2. CL*35 00217 05 FILLER PIC X(54) VALUE SPACES. CL*35 00218 05 FILLER PIC X(56) VALUE CL*35 00219 'TAX DIVISION'. CL*35 00220 * 05 FILLER PIC X(06) VALUE 'TIME:'. CL*35 00221 * 05 HDR2-LRCM-SYS-TIME PIC X(08). CL*35 00222 01 HEADER-3. CL*35 00223 05 FILLER PIC X(01) VALUE SPACES. CL*35 00224 05 FILLER PIC X(38) VALUE CL*35 00225 ' ADDR SKIP '. CL*48 00226 05 HDR3-LITERAL PIC X(43) VALUE CL*35 00227 ' ESSP DAILY REGISTRATIONS ADDRESSES '. CL*35 00228 05 FILLER PIC X(28) VALUE SPACES. CL*35 00229 * 05 FILLER PIC X(06) VALUE 'PAGE:'. CL*35 00230 * 05 HDR3-PAGE PIC ZZ,ZZ9. CL*35 00231 01 HEADER-43. CL*43 00232 05 FILLER PIC X(02) VALUE SPACES. CL*43 00233 05 FILLER PIC X(52) VALUE CL*43 00234 'EMP NO TYPE QAS ATTN LINE1'. CL*44 00235 05 FILLER PIC X(15) VALUE SPACES. CL*58 00236 05 FILLER PIC X(27) VALUE CL*43 00237 ' LINE2'. CL*43 00238 05 FILLER PIC X(27) VALUE SPACES. CL*59 00239 05 FILLER PIC X(44) VALUE CL*43 00240 'CITY ST ZIP EMAIL '. CL*43 00241 05 HDR5-NAME PIC X(31) VALUE CL*43 00242 ' '. CL*43 00243 CL*43 00244 CL*43 00245 01 BLANK-LINE PIC X(200) VALUE SPACES. CL*43 00246 01 DETAIL-LINE-1. CL*35 00247 15 FILLER PIC X(02) VALUE SPACES. CL*35 00248 15 X424-EMP-NO PIC 999B999 BLANK WHEN ZERO. CL*35 00249 15 FILLER PIC X(03) VALUE SPACES. CL*43 00250 15 X424-TYPE PIC X(02). CL*43 00251 15 FILLER PIC X(04) VALUE SPACES. CL*43 00252 15 X424-QAS PIC X(01). CL*38 00253 15 FILLER PIC X(03) VALUE SPACES. CL*43 00254 15 X424-ATTN PIC X(20). CL*35 00255 15 FILLER PIC X(07) VALUE SPACES. CL*43 00256 15 X424-LINE1 PIC X(40). CL*54 00257 15 FILLER PIC X(02) VALUE SPACES. CL*35 00258 15 X424-LINE2 PIC X(30). CL*54 00259 15 FILLER PIC X(02) VALUE SPACES. CL*35 00260 15 X424-CITY PIC X(15). CL*35 00261 15 FILLER PIC X(02) VALUE SPACES. CL*35 00262 15 X424-STATE PIC X(02). CL*35 00263 15 FILLER PIC X(02) VALUE SPACES. CL*35 00264 15 X424-ZIP PIC X(10). CL*35 00265 15 FILLER PIC X(02) VALUE SPACES. CL*35 00266 15 X424-EMAIL PIC X(30). CL*36 00267 15 FILLER PIC X(02) VALUE SPACES. CL*36 00268 15 X424-MESSAGE PIC X(01). CL*54 00269 CL*35 00270 01 DETAIL-PEND-1. CL*35 00271 15 FILLER PIC X(02) VALUE SPACES. CL*35 00272 15 P424-EMP-NO PIC 999B999 BLANK WHEN ZERO. CL*35 00273 15 FILLER PIC X(02) VALUE SPACES. CL*35 00274 15 P424-TYPE PIC X(02). CL*44 00275 15 FILLER PIC X(02) VALUE SPACES. CL*35 00276 15 P424-ATTN PIC X(20). CL*35 00277 15 FILLER PIC X(02) VALUE SPACES. CL*35 00278 15 P424-LINE1 PIC X(25). CL*35 00279 15 FILLER PIC X(02) VALUE SPACES. CL*35 00280 15 P424-LINE2 PIC X(25). CL*35 00281 15 FILLER PIC X(02) VALUE SPACES. CL*35 00282 15 P424-CITY PIC X(15). CL*35 00283 15 FILLER PIC X(02) VALUE SPACES. CL*35 00284 15 P424-STATE PIC X(02). CL*35 00285 15 FILLER PIC X(02) VALUE SPACES. CL*35 00286 15 P424-ZIP PIC X(10). CL*35 00287 15 FILLER PIC X(02) VALUE SPACES. CL*35 00288 15 P424-MESSAGE PIC X(10). CL*44 00289 CL*35 00290 01 FOOTING-LINE-51. CL*35 00291 05 FILLER PIC X(25) VALUE SPACES. CL*35 00292 05 WS-X110-PEN-CNT PIC ZZ,ZZ9. CL*35 00293 05 FILLER PIC X(02) VALUE SPACES. CL*35 00294 05 FILLER PIC X(40) VALUE CL*35 00295 '# OF ADDRESSES RECEIVED FROM ESSP '. CL*35 00296 05 FILLER PIC X(32) VALUE SPACES. CL*35 00297 CL*35 00298 01 FOOTING-LINE-6. CL*35 00299 05 FILLER PIC X(25) VALUE SPACES. CL*35 00300 05 WS-X102-RED-CNT PIC ZZ,ZZ9. CL*35 00301 05 FILLER PIC X(02) VALUE SPACES. CL*35 00302 05 FILLER PIC X(45) VALUE CL*35 00303 '# OF ADDRESSES DUTAS PASSED '. CL*35 00304 05 FILLER PIC X(32) VALUE SPACES. CL*35 00305 01 FOOTING-LINE-7. CL*35 00306 05 FILLER PIC X(25) VALUE SPACES. CL*35 00307 05 WS-X102-ERR-CNT PIC ZZ,ZZ9. CL*35 00308 05 FILLER PIC X(02) VALUE SPACES. CL*35 00309 05 FILLER PIC X(40) VALUE CL*35 00310 '# OF ADDRESSES DUTAS FAILED '. CL*35 00311 05 FILLER PIC X(32) VALUE SPACES. CL*35 00312 CL*35 00313 01 T002-REC. DTSBX424 00314 ++INCLUDE DTSIT002 DTSBX424 00315 DTSBX424 00316 * ADDRESS DTSBX424 00317 01 Y110-REC. DTSBX424 00318 ++INCLUDE DTSIY110 DTSBX424 00319 DTSBX424 00320 * OPO DTSBX424 00321 01 Y120-REC. DTSBX424 00322 ++INCLUDE DTSIY120 DTSBX424 00323 DTSBX424 00324 01 T003-REC. DTSBX424 00325 ++INCLUDE DTSIT003 DTSBX424 00326 DTSBX424 00327 * NAME DTSBX424 00328 01 X106-REC. DTSBX424 00329 ++INCLUDE DTSIX106 DTSBX424 00330 DTSBX424 00331 01 Y106-REC. DTSBX424 00332 ++INCLUDE DTSIY106 DTSBX424 00333 DTSBX424 00334 * ADDRESS DTSBX424 00335 01 X110-REC. DTSBX424 00336 ++INCLUDE DTSIX110 DTSBX424 00337 DTSBX424 00338 * OPO DTSBX424 00339 01 X120-REC. DTSBX424 00340 ++INCLUDE DTSIX120 DTSBX424 00341 DTSBX424 00342 * ERRORS DTSBX424 00343 *01 X907-REC. DTSBX424 00344 ***INCLUDE DTSIX907 DTSBX424 00345 DTSBX424 00346 01 L001-LINK-AREA. DTSBX424 00347 ++INCLUDE DTSIL001 DTSBX424 00348 DTSBX424 00349 01 L003-LINK-AREA. DTSBX424 00350 ++INCLUDE DTSIL003 DTSBX424 00351 DTSBX424 00352 01 L004-LINK-AREA. DTSBX424 00353 ++INCLUDE DTSIL004 DTSBX424 00354 CL*52 00355 01 L009-LINK-AREA. CL*52 00356 ++INCLUDE DTSIL009 CL*52 00357 CL*52 00358 01 L072-LINK-AREA. DTSBX424 00359 ++INCLUDE DTSIL072 DTSBX424 00360 DTSBX424 00361 01 L516-LINK-AREA. DTSBX424 00362 ++INCLUDE DTSIL516 DTSBX424 00363 DTSBX424 00364 01 L910-LINK-AREA. DTSBX424 00365 ++INCLUDE DTSIL910 DTSBX424 00366 01 MSKL-REC. DTSBX424 00367 ++INCLUDE DTSIMSKL DTSBX424 00368 DTSBX424 00369 01 MHDR-REC. DTSBX424 00370 ++INCLUDE DTSIMHDR DTSBX424 00371 DTSBX424 00372 01 MPRF-REC. DTSBX424 00373 ++INCLUDE DTSIMPRF DTSBX424 00374 DTSBX424 00375 01 MSOL-REC. DTSBX424 00376 ++INCLUDE DTSIMSOL DTSBX424 00377 DTSBX424 00378 01 MQTR-REC. DTSBX424 00379 ++INCLUDE DTSIMQTR DTSBX424 00380 DTSBX424 00381 01 MOPO-REC. DTSBX424 00382 ++INCLUDE DTSIMOPO DTSBX424 00383 DTSBX424 00384 01 MTAD-REC. DTSBX424 00385 ++INCLUDE DTSIMTAD DTSBX424 00386 DTSBX424 00387 01 MNTE-REC. DTSBX424 00388 ++INCLUDE DTSIMNTE DTSBX424 00389 DTSBX424 00390 01 L921-LINK-AREA. DTSBX424 00391 ++INCLUDE DTSIL921 DTSBX424 00392 SKIP3 DTSBX424 00393 01 ISKL-REC. DTSBX424 00394 ++INCLUDE DTSIISKL DTSBX424 00395 SKIP3 DTSBX424 00396 01 IEIN-REC. DTSBX424 00397 ++INCLUDE DTSIIEIN DTSBX424 00398 DTSBX424 00399 01 L927-LINK-AREA. DTSBX424 00400 ++INCLUDE DTSIL927 DTSBX424 00401 DTSBX424 00402 *01 TSKL-REC. CL*27 00403 *++INCLUDE DTSITSKL CL*27 00404 DTSBX424 00405 01 L931-LINK-AREA. DTSBX424 00406 ++INCLUDE DTSIL931 DTSBX424 00407 DTSBX424 00408 01 FSKL-REC. DTSBX424 00409 ++INCLUDE DTSIFSKL DTSBX424 00410 DTSBX424 00411 01 R140-REC. DTSBX424 00412 ++INCLUDE DTSIR140 DTSBX424 00413 DTSBX424 00414 LINKAGE SECTION. DTSBX424 00415 DTSBX424 00416 01 LX42-LINK-AREA. DTSBX424 00417 ++INCLUDE DTSILX42 CL*21 00418 DTSBX424 00419 PROCEDURE DIVISION USING LX42-LINK-AREA. DTSBX424 00420 DTSBX424 00421 DTSBX424-MAIN. DTSBX424 00422 MOVE LX42-ERROR-IND TO W-ERROR-IND. DTSBX424 00423 MOVE LX42-CURR-RUN-DATE TO W-RUN-DATE. CL*48 00424 DISPLAY 'RDATE ' W-RUN-DATE. CL*48 00425 MOVE Z-YY TO W-YY. CL*48 00426 MOVE Z-MM TO W-MM. CL*48 00427 MOVE Z-DD TO W-DD. CL*48 00428 DTSBX424 00429 EVALUATE TRUE DTSBX424 00430 WHEN LX42-INITIALIZE-88 DTSBX424 00431 PERFORM I0000-INITIATE THRU I0000-EXIT DTSBX424 00432 DTSBX424 00433 WHEN LX42-NEW-EMPLOYER-88 DTSBX424 00434 PERFORM P3000-NEW-EMP THRU P3000-EXIT DTSBX424 00435 DTSBX424 00436 WHEN LX42-PROCESS-88 DTSBX424 00437 PERFORM P0000-PROCESS THRU P0000-EXIT DTSBX424 00438 DTSBX424 00439 WHEN LX42-TERMINATE-88 DTSBX424 00440 DISPLAY '424 - TERMINATE ' CL*10 00441 PERFORM P3000-NEW-EMP THRU P3000-EXIT DTSBX424 00442 PERFORM T0000-TERMINATE THRU T0000-EXIT DTSBX424 00443 DTSBX424 00444 END-EVALUATE. DTSBX424 00445 DTSBX424 00446 * IF LX42-PROCESS-88 CL**8 00447 * MOVE W-ERROR-IND TO LX42-ERROR-IND CL**8 00448 * END-IF. CL**8 00449 DTSBX424 00450 DTSBX424-MAIN-EXIT. DTSBX424 00451 GOBACK. DTSBX424 00452 DTSBX424 00453 I0000-INITIATE. DTSBX424 00454 *** SET W-ERROR-NO-88 TO TRUE. DTSBX424 00455 SET W-FATAL-ERROR-NO-88 TO TRUE. DTSBX424 00456 MOVE LENGTH OF X110-REC TO W-X110-LENGTH. DTSBX424 00457 MOVE LENGTH OF X120-REC TO W-X120-LENGTH. DTSBX424 00458 DTSBX424 00459 *RW1 FOR VARIABLE REPORT FILE. DTSBX424 00460 MOVE LENGTH OF R140-REC TO R140-LENGTH. DTSBX424 00461 MOVE '140' TO R140-REC-TYPE. DTSBX424 00462 PERFORM S1040-OPEN-TEMP-BTC-OUT THRU S1040-EXIT. CL*25 00463 IF W-FATAL-ERROR-YES-88 CL*25 00464 DISPLAY 'CANNOT OPEN TEMP X424BTC FILE ' CL*29 00465 TEMP-BTC-STATUS CL*25 00466 PERFORM S999-ABEND THRU S999-EXIT CL*25 00467 END-IF. CL*25 00468 DTSBX424 00469 WRITE REPT-PAID-REC FROM HEADER-1 CL*45 00470 AFTER ADVANCING TOP-OF-PAGE. CL*45 00471 CL*45 00472 WRITE REPT-PAID-REC FROM HEADER-2 CL*45 00473 AFTER ADVANCING 2 LINES. CL*45 00474 CL*45 00475 WRITE REPT-PAID-REC FROM HEADER-3 CL*45 00476 AFTER ADVANCING 1 LINE. CL*45 00477 CL*45 00478 WRITE REPT-PAID-REC FROM HEADER-43 CL*45 00479 AFTER ADVANCING 1 LINE. CL*45 00480 CL*45 00481 WRITE REPT-PAID-REC FROM BLANK-LINE CL*45 00482 AFTER ADVANCING 1 LINE. CL*45 00483 I0000-EXIT. DTSBX424 00484 EXIT. DTSBX424 00485 DTSBX424 00486 P0000-PROCESS. DTSBX424 00487 *& DTSBX424 00488 DISPLAY SPACE. DTSBX424 00489 DISPLAY 'BX424 P0000 ' W-EMP-NO ' ' LX42-REC-TYPE. DTSBX424 00490 *& DTSBX424 00491 EVALUATE TRUE DTSBX424 00492 WHEN LX42-REC-TYPE-ADDR-88 DTSBX424 00493 PERFORM P1500-ADDRESS THRU P1500-EXIT DTSBX424 00494 DTSBX424 00495 WHEN LX42-REC-TYPE-OPO-88 DTSBX424 00496 * DISPLAY 'OPO REC ' LX42-EMP-NO CL*20 00497 PERFORM P1600-OPO THRU P1600-EXIT DTSBX424 00498 DTSBX424 00499 END-EVALUATE. DTSBX424 00500 P0000-EXIT. DTSBX424 00501 EXIT. DTSBX424 00502 DTSBX424 00503 P1500-ADDRESS. DTSBX424 00504 MOVE LX42-DATA-AREA TO X110-REC. CL*24 00505 DISPLAY ' P1500 X110 REC ' X110-REC. CL*61 00506 *& DTSBX424 00507 * DISPLAY 'BX424 EMP ADDRESS ' W-EMP-NO ' ' X110-REC-TYPE ' ' CL*61 00508 * ' ' X110-ADDR-TYPE. CL*61 00509 DTSBX424 00510 ADD +1 TO W-X110-RED-CNT. CL*19 00511 DTSBX424 00512 MOVE SPACES TO LX42-X110-EMP-NO. CL*50 00513 CL**2 00514 ADD 1 TO W-NEW-X110-EMP. CL**2 00515 CL*43 00516 MOVE X110-EMP-NO TO X424-EMP-NO. CL*43 00517 MOVE X110-ADDR-TYPE TO X424-TYPE CL*43 00518 MOVE X110-ATTENTION TO X424-ATTN CL*43 00519 MOVE X110-STREET-1 TO X424-LINE1 CL*43 00520 MOVE X110-STREET-2 TO X424-LINE2 CL*43 00521 MOVE X110-CITY TO X424-CITY CL*43 00522 MOVE X110-STATE TO X424-STATE. CL*43 00523 MOVE X110-ZIP TO X424-ZIP. CL*43 00524 MOVE X110-EMAIL TO X424-EMAIL. CL*43 00525 MOVE X110-QAS-FLAG TO X424-QAS. CL*43 00526 MOVE SPACES TO X424-MESSAGE. CL*46 00527 WRITE REPT-PAID-REC FROM DETAIL-LINE-1. CL*43 00528 CL**2 00529 DISPLAY 'QAS ' X110-QAS-FLAG CL*47 00530 PERFORM P1510-EDIT-ADDRESS THRU P1510-EXIT. DTSBX424 00531 CL**2 00532 IF W-ERROR-NO-88 DTSBX424 00533 DISPLAY 'X110 ADDRESS OK - PASS EDITS ' W-EMP-NO CL*12 00534 PERFORM P1520-SAVE-ADDRESS THRU P1520-EXIT DTSBX424 00535 ELSE CL**3 00536 SET W-ERROR-YES-88 TO TRUE CL**8 00537 MOVE SPACES TO R140-MESSAGE CL**8 00538 MOVE W-EMP-NO TO R140-EMP-NO CL**8 00539 ADD +1 TO W-X110-ERR-CNT CL*19 00540 DISPLAY 'X110 ADDRESS HAS ERRORS ' W-EMP-NO CL*16 00541 STRING CL**8 00542 'X110 EMP ADDRESS HAS ERRORS - CANNOT ADD ADDR' CL**8 00543 DELIMITED BY SIZE CL**8 00544 INTO R140-MESSAGE CL**8 00545 END-STRING CL**8 00546 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**8 00547 MOVE '999999' TO LX42-X110-EMP-NO CL**3 00548 END-IF. DTSBX424 00549 DTSBX424 00550 *** PERFORM P1530-CHECK-NAME THRU P1530-EXIT. CL**8 00551 DTSBX424 00552 P1500-EXIT. DTSBX424 00553 EXIT. DTSBX424 00554 DTSBX424 00555 P1510-EDIT-ADDRESS. DTSBX424 00556 CL**2 00557 * IF W-NEW-X110-EMP = 1 AND LX42-X102-EMP-NO > SPACES CL*14 00558 * IF NOT X110-ADDR-TYPE-MAIL-88 CL*14 00559 * MOVE SPACES TO R140-MESSAGE CL*14 00560 * MOVE W-EMP-NO TO R140-EMP-NO CL*14 00561 * STRING CL*14 00562 * 'X110- 1ST ADDR NOT MAILING ADDRESS ' X110-ADDR-TYPE CL*14 00563 * DELIMITED BY SIZE CL*14 00564 * INTO R140-MESSAGE CL*14 00565 * END-STRING CL*14 00566 * PERFORM S946-WRITE-R140 THRU S946-EXIT CL*14 00567 * END-IF CL*14 00568 * END-IF. CL*14 00569 CL**2 00570 CL**2 00571 IF X110-ADDR-TYPE-RECS-88 AND X110-STATE NOT = 'DC' CL**2 00572 SET W-ERROR-YES-88 TO TRUE CL**2 00573 MOVE SPACES TO R140-MESSAGE CL**2 00574 MOVE W-EMP-NO TO R140-EMP-NO CL**2 00575 DISPLAY 'X110- EMP DC ADDRESS NOT IN DC ' X110-STATE CL*17 00576 STRING CL**2 00577 'X110- EMPLOYER DC ADDRESS NOT IN DC ' X110-STATE CL**7 00578 DELIMITED BY SIZE CL**2 00579 INTO R140-MESSAGE CL**2 00580 END-STRING CL**2 00581 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**2 00582 END-IF. CL**2 00583 CL**2 00584 IF X110-STREET-1 = SPACES CL**2 00585 DISPLAY 'X110- STREET 1 ' X110-STREET-1 CL*17 00586 SET W-ERROR-YES-88 TO TRUE CL**2 00587 MOVE SPACES TO R140-MESSAGE CL**2 00588 MOVE W-EMP-NO TO R140-EMP-NO CL**2 00589 STRING CL**2 00590 'X110- EMPLOYER ADDR -STREET 1 IS BLANK ' X110-STREET-1 CL**7 00591 DELIMITED BY SIZE CL**2 00592 INTO R140-MESSAGE CL**2 00593 END-STRING CL**2 00594 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**2 00595 END-IF. CL**2 00596 CL**2 00597 IF X110-CITY = SPACES CL*17 00598 DISPLAY 'X110- CITY ' X110-CITY CL*17 00599 SET W-ERROR-YES-88 TO TRUE CL**2 00600 MOVE SPACES TO R140-MESSAGE CL**2 00601 MOVE W-EMP-NO TO R140-EMP-NO CL**2 00602 STRING CL**2 00603 'X110- EMPLOYER ADDRESS -CITY IS BLANK ' X110-CITY CL**7 00604 DELIMITED BY SIZE CL**2 00605 INTO R140-MESSAGE CL**2 00606 END-STRING CL**2 00607 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**2 00608 END-IF. CL**2 00609 CL**2 00610 IF X110-STATE = SPACES CL*17 00611 DISPLAY 'X110- STATE ' X110-STATE CL*17 00612 SET W-ERROR-YES-88 TO TRUE CL**2 00613 MOVE SPACES TO R140-MESSAGE CL**2 00614 MOVE W-EMP-NO TO R140-EMP-NO CL**2 00615 STRING CL**2 00616 'X110- EMPLOYER ADDRESS -STATE IS BLANK ' X110-STATE CL**7 00617 DELIMITED BY SIZE CL**2 00618 INTO R140-MESSAGE CL**2 00619 END-STRING CL**2 00620 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**2 00621 END-IF. CL**2 00622 CL**2 00623 IF X110-ZIP = SPACES CL*17 00624 DISPLAY 'X110- ZIP ' X110-ZIP CL*17 00625 SET W-ERROR-YES-88 TO TRUE CL**3 00626 MOVE SPACES TO R140-MESSAGE CL**3 00627 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00628 STRING CL**3 00629 'X110- EMPLOYER ADDRESS -ZIP IS BLANK ' X110-ZIP CL**7 00630 DELIMITED BY SIZE CL**3 00631 INTO R140-MESSAGE CL**3 00632 END-STRING CL**3 00633 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00634 END-IF. CL**3 00635 CL**3 00636 IF X110-ADDR-TYPE-MAIL-88 DTSBX424 00637 SET MTAD-ID-TAX-MAILING-ADDR-88 TO TRUE DTSBX424 00638 ELSE DTSBX424 00639 IF X110-ADDR-TYPE-RECS-88 DTSBX424 00640 SET MTAD-ID-TAX-RECORDS-ADDR-88 TO TRUE DTSBX424 00641 ELSE DTSBX424 00642 SET W-ERROR-YES-88 TO TRUE CL**3 00643 MOVE SPACES TO R140-MESSAGE DTSBX424 00644 MOVE W-EMP-NO TO R140-EMP-NO DTSBX424 00645 STRING DTSBX424 00646 'X110-ADDRESS TYPE INCORRECT ' X110-ADDR-TYPE DTSBX424 00647 DELIMITED BY SIZE DTSBX424 00648 INTO R140-MESSAGE DTSBX424 00649 END-STRING DTSBX424 00650 PERFORM S946-WRITE-R140 THRU S946-EXIT DTSBX424 00651 GO TO P1510-EXIT DTSBX424 00652 END-IF DTSBX424 00653 END-IF. DTSBX424 00654 CL**3 00655 MOVE LOW-VALUES TO MTAD-KEY-AREA. CL**3 00656 MOVE W-EMP-NO TO MTAD-EMP-NO. CL**3 00657 SET MTAD-TAD-88 TO TRUE. DTSBX424 00658 DTSBX424 00659 MOVE MTAD-KEY-AREA TO MSKL-KEY-AREA. DTSBX424 00660 DTSBX424 00661 PERFORM S910-READ THRU S910-EXIT. DTSBX424 00662 IF L910-OK-88 DTSBX424 00663 MOVE MSKL-REC TO MTAD-REC DTSBX424 00664 * SET W-ERROR-YES-88 TO TRUE CL**8 00665 MOVE SPACES TO R140-MESSAGE DTSBX424 00666 MOVE W-EMP-NO TO R140-EMP-NO DTSBX424 00667 STRING DTSBX424 00668 'X110- ADDRESS EXIST IN DUTAS - UPDATE ADDR ' CL**8 00669 DELIMITED BY SIZE DTSBX424 00670 INTO R140-MESSAGE DTSBX424 00671 END-STRING DTSBX424 00672 PERFORM S946-WRITE-R140 THRU S946-EXIT DTSBX424 00673 END-IF. DTSBX424 00674 DTSBX424 00675 P1510-EXIT. DTSBX424 00676 EXIT. DTSBX424 00677 DTSBX424 00678 DTSBX424 00679 P1520-SAVE-ADDRESS. DTSBX424 00680 MOVE LOW-VALUES TO T002-REC. DTSBX424 00681 DTSBX424 00682 SET T002-LENGTH-EMP-ADDR-88 TO TRUE. DTSBX424 00683 MOVE '002' TO T002-REC-TYPE. DTSBX424 00684 MOVE W-EMP-NO TO T002-EMP-NO. DTSBX424 00685 MOVE 'WEB REG ' TO T002-ORIGIN. DTSBX424 00686 MOVE LX42-SYS-DATE TO T002-SYS-DATE. DTSBX424 00687 MOVE LX42-SYS-TIME TO T002-SYS-TIME. DTSBX424 00688 DTSBX424 00689 DTSBX424 00690 MOVE X110-ADDR-TYPE TO Y110-EMP-ADDR-TYPE. DTSBX424 00691 IF X110-ATTENTION > SPACES CL*51 00692 MOVE X110-ATTENTION TO L009-DATA CL*51 00693 PERFORM S009-CONVERT-TO-CAPS THRU S009-EXIT CL*51 00694 MOVE L009-DATA TO Y110-EMP-ATTN CL*51 00695 ELSE CL*51 00696 MOVE SPACES TO Y110-EMP-ATTN. CL*51 00697 CL*53 00698 IF X110-STREET-2 = SPACES CL*53 00699 MOVE X110-STREET-1 TO X110-STREET-2 CL*53 00700 MOVE SPACES TO X110-STREET-1. CL*53 00701 CL*53 00702 IF X110-STREET-1 > SPACES CL*51 00703 MOVE X110-STREET-1 TO L009-DATA CL*51 00704 PERFORM S009-CONVERT-TO-CAPS THRU S009-EXIT CL*51 00705 MOVE L009-DATA TO Y110-EMP-DELV1 CL*51 00706 ELSE CL*51 00707 MOVE SPACES TO Y110-EMP-DELV1. CL*51 00708 CL*51 00709 IF X110-STREET-2 > SPACES CL*51 00710 MOVE X110-STREET-2 TO L009-DATA CL*51 00711 PERFORM S009-CONVERT-TO-CAPS THRU S009-EXIT CL*51 00712 MOVE L009-DATA TO Y110-EMP-DELV2 CL*51 00713 ELSE CL*51 00714 MOVE SPACES TO Y110-EMP-DELV2. CL*51 00715 CL*51 00716 IF X110-CITY > SPACES CL*51 00717 MOVE X110-CITY TO L009-DATA CL*51 00718 PERFORM S009-CONVERT-TO-CAPS THRU S009-EXIT CL*51 00719 MOVE L009-DATA TO Y110-EMP-CITY CL*51 00720 ELSE CL*51 00721 MOVE SPACES TO Y110-EMP-CITY. CL*51 00722 IF X110-STATE > SPACES CL*51 00723 MOVE X110-STATE TO L009-DATA CL*51 00724 PERFORM S009-CONVERT-TO-CAPS THRU S009-EXIT CL*51 00725 MOVE L009-DATA TO Y110-EMP-STATE CL*51 00726 ELSE CL*51 00727 MOVE SPACES TO Y110-EMP-STATE. CL*51 00728 CL*51 00729 MOVE X110-ZIP TO Y110-EMP-ZIP. DTSBX424 00730 MOVE X110-PHONE TO Y110-EMP-VOICE. DTSBX424 00731 MOVE X110-FAX TO Y110-EMP-FAX. DTSBX424 00732 **** MOVE X110-WEB-SITE TO Y110-WEB-SITE. DTSBX424 00733 MOVE X110-EMAIL TO Y110-EMP-EMAIL. DTSBX424 00734 DTSBX424 00735 MOVE Y110-REC TO T002-DATA-AREA. DTSBX424 00736 SET T002-EMP-ADDR-88 TO TRUE. DTSBX424 00737 CL*26 00738 * MOVE T002-REC TO TSKL-REC. CL*25 00739 * PERFORM S927B-WRITE THRU S927B-EXIT. CL*25 00740 ADD +1 TO W-T002-ADDR-CNT. DTSBX424 00741 * PERFORM S927B-WRITE THRU S927B-EXIT. CL*26 00742 DTSBX424 00743 MOVE T002-LENGTH TO VAR-CHAR-CNT. CL*26 00744 PERFORM S1032-WRITE-TEMP-T002 THRU S1032-EXIT. CL*26 00745 *& DTSBX424 00746 * DISPLAY 'BX424 ADDRESS ' W-EMP-NO ' ' X110-STREET-1. CL*41 00747 *& DTSBX424 00748 P1520-EXIT. DTSBX424 00749 EXIT. DTSBX424 00750 DTSBX424 00751 P1530-CHECK-NAME. DTSBX424 00752 DISPLAY 'BX424 P1530 NAME ' W-EMP-NO ' ' X110-EMP-NAME. DTSBX424 00753 MOVE LOW-VALUE TO MSKL-KEY-AREA. DTSBX424 00754 MOVE W-EMP-NO TO MSKL-EMP-NO. DTSBX424 00755 SET MSKL-PRF-88 TO TRUE. DTSBX424 00756 DTSBX424 00757 PERFORM S910-READ THRU S910-EXIT. DTSBX424 00758 IF L910-OK-88 DTSBX424 00759 NEXT SENTENCE DTSBX424 00760 ELSE DTSBX424 00761 GO TO P1530-EXIT DTSBX424 00762 END-IF. DTSBX424 00763 DTSBX424 00764 IF X110-EMP-NAME > SPACES DTSBX424 00765 PERFORM P1535-SAVE-NAME THRU P1535-EXIT DTSBX424 00766 ELSE DTSBX424 00767 SET W-ERROR-YES-88 TO TRUE DTSBX424 00768 MOVE SPACES TO R140-MESSAGE DTSBX424 00769 MOVE W-EMP-NO TO R140-EMP-NO DTSBX424 00770 STRING DTSBX424 00771 'NAME NAME IS BLANK ' DTSBX424 00772 DELIMITED BY SIZE DTSBX424 00773 INTO R140-MESSAGE DTSBX424 00774 END-STRING DTSBX424 00775 DISPLAY R140-MESSAGE DTSBX424 00776 PERFORM S946-WRITE-R140 THRU S946-EXIT DTSBX424 00777 END-IF. DTSBX424 00778 DTSBX424 00779 P1530-EXIT. DTSBX424 00780 EXIT. DTSBX424 00781 DTSBX424 00782 P1535-SAVE-NAME. DTSBX424 00783 MOVE LOW-VALUES TO T002-REC. DTSBX424 00784 DTSBX424 00785 SET T002-LENGTH-EMP-NAME-88 TO TRUE. DTSBX424 00786 MOVE '002' TO T002-REC-TYPE. DTSBX424 00787 MOVE X110-EMP-NO TO T002-EMP-NO. DTSBX424 00788 MOVE 'WEB ' TO T002-ORIGIN. DTSBX424 00789 MOVE LX42-SYS-DATE TO T002-SYS-DATE. DTSBX424 00790 MOVE LX42-SYS-TIME TO T002-SYS-TIME. DTSBX424 00791 DTSBX424 00792 SET Y106-EMP-NAME-ENTITY-88 TO TRUE. DTSBX424 00793 MOVE X110-EMP-NAME TO Y106-EMP-NAME. DTSBX424 00794 DTSBX424 00795 MOVE Y106-REC TO T002-DATA-AREA. DTSBX424 00796 SET T002-EMP-NAME-88 TO TRUE. DTSBX424 00797 DTSBX424 00798 MOVE T002-REC TO TSKL-REC. DTSBX424 00799 PERFORM S927B-WRITE THRU S927B-EXIT. DTSBX424 00800 ADD +1 TO W-T002-NAME-CNT. DTSBX424 00801 DTSBX424 00802 *& DTSBX424 00803 * DISPLAY 'BX424 NAME ' X110-EMP-NO CL**3 00804 * ' ' X110-EMP-NAME. CL**3 00805 *& DTSBX424 00806 P1535-EXIT. DTSBX424 00807 EXIT. DTSBX424 00808 DTSBX424 00809 P1600-OPO. DTSBX424 00810 MOVE LX42-DATA-AREA TO X120-REC. CL*24 00811 DTSBX424 00812 ADD +1 TO W-X120-RED-CNT. CL*19 00813 MOVE X120-EMP-NO TO LX42-X120-EMP-NO CL**3 00814 CL**3 00815 CL**6 00816 PERFORM P1610-EDIT-OPO THRU P1610-EXIT DTSBX424 00817 CL**3 00818 IF W-ERROR-NO-88 DTSBX424 00819 DISPLAY ' X120 OPO PASS EDITS -OK' W-EMP-NO CL*12 00820 PERFORM P1620-SAVE-OPO THRU P1620-EXIT DTSBX424 00821 ELSE CL**3 00822 SET W-ERROR-YES-88 TO TRUE CL**9 00823 MOVE SPACES TO R140-MESSAGE CL**9 00824 MOVE W-EMP-NO TO R140-EMP-NO CL**9 00825 ADD +1 TO W-X120-ERR-CNT CL*19 00826 STRING CL**9 00827 'X120 OPO RECORD HAS ERRORS - CANNOT ADD OPO ' CL**9 00828 DELIMITED BY SIZE CL**9 00829 INTO R140-MESSAGE CL**9 00830 END-STRING CL**9 00831 MOVE '999999' TO LX42-X120-EMP-NO CL**9 00832 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**9 00833 END-IF. DTSBX424 00834 DTSBX424 00835 P1600-EXIT. DTSBX424 00836 EXIT. DTSBX424 00837 DTSBX424 00838 P1610-EDIT-OPO. DTSBX424 00839 IF X120-OPO-SSN = SPACES DTSBX424 00840 MOVE ZEROS TO X120-OPO-SSN DTSBX424 00841 END-IF. DTSBX424 00842 CL**3 00843 IF X120-OPO-TITLE = SPACES CL**3 00844 SET W-ERROR-YES-88 TO TRUE CL**3 00845 MOVE SPACES TO R140-MESSAGE CL**3 00846 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00847 STRING CL**3 00848 'X120- EMP OPO TITLE IS BLANK ' CL**8 00849 DELIMITED BY SIZE CL**3 00850 INTO R140-MESSAGE CL**3 00851 END-STRING CL**3 00852 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00853 END-IF. CL**3 00854 CL**3 00855 IF X120-OPO-STREET-1 = SPACES CL**3 00856 SET W-ERROR-YES-88 TO TRUE CL**3 00857 MOVE SPACES TO R140-MESSAGE CL**3 00858 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00859 STRING CL**3 00860 'X120- OPO ADDRESS STREET 1 IS BLANK ' CL**7 00861 DELIMITED BY SIZE CL**3 00862 INTO R140-MESSAGE CL**3 00863 END-STRING CL**3 00864 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00865 END-IF. CL**3 00866 CL**3 00867 DISPLAY 'CITY ' X120-OPO-CITY CL*32 00868 IF X120-OPO-CITY = SPACES CL*32 00869 SET W-ERROR-YES-88 TO TRUE CL**3 00870 MOVE SPACES TO R140-MESSAGE CL**3 00871 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00872 STRING CL**3 00873 'X120- OPO ADDRESS CITY IS BLANK ' CL**7 00874 DELIMITED BY SIZE CL**3 00875 INTO R140-MESSAGE CL**3 00876 END-STRING CL**3 00877 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00878 END-IF. CL**3 00879 CL**3 00880 DISPLAY ' ST ' X120-OPO-STATE CL*32 00881 IF X120-OPO-STATE = SPACES CL**3 00882 SET W-ERROR-YES-88 TO TRUE CL**3 00883 MOVE SPACES TO R140-MESSAGE CL**3 00884 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00885 STRING CL**3 00886 'X120- OPO ADDRESS STATE IS BLANK ' CL**7 00887 DELIMITED BY SIZE CL**3 00888 INTO R140-MESSAGE CL**3 00889 END-STRING CL**3 00890 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00891 END-IF. CL**3 00892 DTSBX424 00893 DISPLAY ' ZIP ' X120-OPO-ZIP CL*32 00894 IF X120-OPO-ZIP = SPACES CL**3 00895 SET W-ERROR-YES-88 TO TRUE CL**3 00896 MOVE SPACES TO R140-MESSAGE CL**3 00897 MOVE W-EMP-NO TO R140-EMP-NO CL**3 00898 STRING CL**3 00899 'X120- OPO ADDRESS ZIP IS BLANK ' CL**7 00900 DELIMITED BY SIZE CL**3 00901 INTO R140-MESSAGE CL**3 00902 END-STRING CL**3 00903 PERFORM S946-WRITE-R140 THRU S946-EXIT CL**3 00904 END-IF. CL**3 00905 CL**3 00906 P1610-EXIT. DTSBX424 00907 EXIT. DTSBX424 00908 DTSBX424 00909 P1620-SAVE-OPO. DTSBX424 00910 MOVE LOW-VALUES TO T002-REC. DTSBX424 00911 DTSBX424 00912 SET T002-LENGTH-CONTACT-88 TO TRUE. DTSBX424 00913 MOVE '002' TO T002-REC-TYPE. DTSBX424 00914 MOVE W-EMP-NO TO T002-EMP-NO. DTSBX424 00915 MOVE 'WEB REG ' TO T002-ORIGIN. DTSBX424 00916 MOVE LX42-SYS-DATE TO T002-SYS-DATE. DTSBX424 00917 MOVE LX42-SYS-TIME TO T002-SYS-TIME. DTSBX424 00918 DTSBX424 00919 MOVE SPACES TO Y120-REC. CL*63 00920 MOVE X120-TYPE-IND TO Y120-CONTACT-TYPE. DTSBX424 00921 MOVE X120-OPO-SSN TO Y120-CONTACT-SSN. DTSBX424 00922 IF X120-OPO-MEMBER-NAME > SPACES DTSBX424 00923 MOVE X120-OPO-MEMBER-NAME TO Y120-CONTACT-NAME DTSBX424 00924 ELSE DTSBX424 00925 PERFORM P1621-FORMAT-NAME THRU P1621-EXIT DTSBX424 00926 END-IF. DTSBX424 00927 DTSBX424 00928 MOVE X120-OPO-TITLE TO Y120-CONTACT-TITLE. DTSBX424 00929 MOVE X120-OPO-ATTENTION TO Y120-CONTACT-ATTN. DTSBX424 00930 MOVE X120-OPO-STREET-1 TO Y120-CONTACT-DELV1. DTSBX424 00931 MOVE X120-OPO-STREET-2 TO Y120-CONTACT-DELV2. DTSBX424 00932 MOVE X120-OPO-CITY TO Y120-CONTACT-CITY. DTSBX424 00933 DISPLAY 'CITY ' Y120-CONTACT-CITY CL*33 00934 MOVE X120-OPO-STATE TO Y120-CONTACT-STATE. DTSBX424 00935 DISPLAY ' ST ' Y120-CONTACT-STATE CL*33 00936 MOVE X120-OPO-ZIP TO Y120-CONTACT-ZIP. DTSBX424 00937 DISPLAY ' ZIP ' Y120-CONTACT-ZIP CL*33 00938 MOVE X120-OPO-PHONE TO Y120-CONTACT-VOICE. DTSBX424 00939 DISPLAY 'FONE ' Y120-CONTACT-VOICE CL*34 00940 MOVE X120-OPO-FAX TO Y120-CONTACT-FAX. DTSBX424 00941 DISPLAY ' FAX ' Y120-CONTACT-FAX CL*34 00942 MOVE X120-OPO-EMAIL TO Y120-CONTACT-EMAIL. DTSBX424 00943 DISPLAY 'MAIL ' Y120-CONTACT-EMAIL. CL*34 00944 DTSBX424 00945 MOVE Y120-REC TO T002-DATA-AREA. DTSBX424 00946 SET T002-CONTACT-88 TO TRUE. DTSBX424 00947 CL*26 00948 * MOVE T002-REC TO TSKL-REC. CL*26 00949 * PERFORM S927B-WRITE THRU S927B-EXIT. CL*26 00950 ADD +1 TO W-T002-OPO-CNT. DTSBX424 00951 DTSBX424 00952 MOVE T002-LENGTH TO VAR-CHAR-CNT. CL*26 00953 PERFORM S1032-WRITE-TEMP-T002 THRU S1032-EXIT. CL*26 00954 *& CL*26 00955 *& DTSBX424 00956 DISPLAY 'BX424 P1620 ' X120-EMP-NO CL*30 00957 ' ' Y120-CONTACT-NAME. CL*30 00958 * ' ' Y120-CONTACT-DELV1. CL**3 00959 *& DTSBX424 00960 P1620-EXIT. DTSBX424 00961 EXIT. DTSBX424 00962 DTSBX424 00963 P1621-FORMAT-NAME. DTSBX424 00964 MOVE SPACES TO W-NAME-AREA Y120-CONTACT-NAME. CL*64 00965 STRING DTSBX424 00966 X120-OPO-LAST-NAME '/' DTSBX424 00967 X120-OPO-FIRST-NAME (1:18) ' ' DTSBX424 00968 X120-OPO-MID-INIT DTSBX424 00969 DELIMITED BY SIZE DTSBX424 00970 INTO W-NAME-AREA DTSBX424 00971 END-STRING. DTSBX424 00972 DISPLAY 'BX424 P16 ' W-NAME-AREA. CL*64 00973 DTSBX424 00974 MOVE +0 TO TSUB2 DTSBX424 00975 PERFORM DTSBX424 00976 VARYING TSUB1 FROM +1 BY +1 DTSBX424 00977 UNTIL TSUB1 > +40 OR TSUB2 > +31 DTSBX424 00978 IF W-NAME-AREA (TSUB1:1) NOT = SPACE DTSBX424 00979 ADD +1 TO TSUB2 DTSBX424 00980 MOVE W-NAME-AREA (TSUB1:1) TO DTSBX424 00981 Y120-CONTACT-NAME (TSUB2:1) DTSBX424 00982 END-IF DTSBX424 00983 END-PERFORM. DTSBX424 00984 DISPLAY 'BX424 P16 ' Y120-CONTACT-NAME. CL*64 00985 DTSBX424 00986 P1621-EXIT. DTSBX424 00987 EXIT. DTSBX424 00988 DTSBX424 00989 *P1800-IND-DESC. DTSBX424 00990 * INITIALIZE X132-REC. DTSBX424 00991 * MOVE +4 TO W-LAST-FIELD. DTSBX424 00992 * MOVE +500 TO W-LAST-FIELD-LEN. DTSBX424 00993 * PERFORM S2000-PARSE-INPUT THRU S2000-EXIT. DTSBX424 00994 *& DTSBX424 00995 * DISPLAY 'INDUSTRY DESCRIPTION'. DTSBX424 00996 *& DTSBX424 00997 * DTSBX424 00998 * SET W-PREV-REC-IND-88 TO TRUE. DTSBX424 00999 * ADD +1 TO W-X132-CNT. DTSBX424 01000 * PERFORM P1820-SAVE-IND THRU P1820-EXIT. DTSBX424 01001 * DTSBX424 01002 *P1800-EXIT. DTSBX424 01003 * EXIT. DTSBX424 01004 * DTSBX424 01005 *P1820-SAVE-IND. DTSBX424 01006 * MOVE LOW-VALUES TO MNTE-KEY-AREA. DTSBX424 01007 * MOVE W-EMP-NO TO MNTE-EMP-NO. DTSBX424 01008 * SET MNTE-NTE-88 TO TRUE. DTSBX424 01009 * MOVE +0 TO MNTE-PURGE-DATE. DTSBX424 01010 * SET MNTE-NOT-CONVERTED-88 TO TRUE. DTSBX424 01011 * DTSBX424 01012 * MOVE LX42-SYS-DATE TO MNTE-ESTB-DATE DTSBX424 01013 * MNTE-CHNG-DATE. DTSBX424 01014 * MOVE ZERO TO MNTE-KEY-ESTB-ABSTIME DTSBX424 01015 * MNTE-DATA-ESTB-ABSTIME DTSBX424 01016 * MNTE-CHNG-ABSTIME. DTSBX424 01017 * MOVE 'WEB REG ' TO MNTE-ESTB-OP-ID DTSBX424 01018 * MNTE-CHNG-OP-ID. DTSBX424 01019 * MOVE +0 TO MNTE-TEXT-CNT. DTSBX424 01020 * MOVE SPACES TO MNTE-TEXT-AREA. DTSBX424 01021 * DTSBX424 01022 * IF X132-SOURCE-KEY-WORD-88 DTSBX424 01023 * SET W-MNTE-KEY-WORD-88 TO TRUE DTSBX424 01024 * MOVE W-MNTE-SUBJECT TO MNTE-SUBJECT DTSBX424 01025 * ELSE DTSBX424 01026 * SET W-MNTE-DATA-ENTRY-88 TO TRUE DTSBX424 01027 * MOVE W-MNTE-SUBJECT TO MNTE-SUBJECT DTSBX424 01028 * END-IF. DTSBX424 01029 * DTSBX424 01030 * PERFORM P1821-MOVE-TEXT THRU P1821-EXIT. DTSBX424 01031 * DTSBX424 01032 * MOVE LENGTH OF T003-REC TO T003-LENGTH DTSBX424 01033 * MOVE '003' TO T003-REC-TYPE. DTSBX424 01034 * MOVE W-EMP-NO TO T003-EMP-NO. DTSBX424 01035 * MOVE 'WEB REG ' TO T003-ORIGIN. DTSBX424 01036 * MOVE LX42-SYS-DATE TO T003-SYS-DATE. DTSBX424 01037 * MOVE LX42-SYS-TIME TO T003-SYS-TIME. DTSBX424 01038 * SET T003-ADD-MNTE-88 TO TRUE. DTSBX424 01039 * MOVE MNTE-REC TO T003-MNTE-REC. DTSBX424 01040 * DTSBX424 01041 * PERFORM S1031-WRITE-TEMP-T003 THRU S1031-EXIT. DTSBX424 01042 * DTSBX424 01043 *P1820-EXIT. DTSBX424 01044 * EXIT. DTSBX424 01045 * DTSBX424 01046 *P1821-MOVE-TEXT. DTSBX424 01047 * SET W-MNTE-COMPLETE-NO-88 TO TRUE. DTSBX424 01048 * MOVE SPACES TO W-MNTE-LINE. DTSBX424 01049 * MOVE +0 TO W-LAST-SPACE DTSBX424 01050 * TSUB1 DTSBX424 01051 * TSUB2. DTSBX424 01052 * DTSBX424 01053 * PERFORM DTSBX424 01054 * UNTIL W-MNTE-COMPLETE-YES-88 DTSBX424 01055 * ADD +1 TO TSUB1 DTSBX424 01056 * IF TSUB1 <= +500 DTSBX424 01057 * PERFORM P1821A-MOVE-DATA THRU P1821A-EXIT DTSBX424 01058 * ELSE DTSBX424 01059 * SET W-MNTE-COMPLETE-YES-88 TO TRUE DTSBX424 01060 * END-IF DTSBX424 01061 * END-PERFORM. DTSBX424 01062 * DTSBX424 01063 *P1821-EXIT. DTSBX424 01064 * EXIT. DTSBX424 01065 * DTSBX424 01066 *P1821A-MOVE-DATA. DTSBX424 01067 * IF TSUB2 < +72 DTSBX424 01068 * ADD +1 TO TSUB2 DTSBX424 01069 * MOVE X132-IND-DESC (TSUB1:1) DTSBX424 01070 * TO W-MNTE-LINE (TSUB2:1) DTSBX424 01071 * IF X132-IND-DESC (TSUB1:1) = SPACE DTSBX424 01072 * MOVE TSUB2 TO W-LAST-SPACE DTSBX424 01073 * END-IF DTSBX424 01074 * ELSE DTSBX424 01075 * PERFORM P1821B-RESET THRU P1821B-EXIT DTSBX424 01076 * ADD +1 TO MNTE-TEXT-CNT DTSBX424 01077 * MOVE W-MNTE-LINE TO MNTE-TEXT (MNTE-TEXT-CNT) DTSBX424 01078 * MOVE SPACES TO W-MNTE-LINE DTSBX424 01079 * MOVE +0 TO W-LAST-SPACE DTSBX424 01080 * TSUB2 DTSBX424 01081 * END-IF. DTSBX424 01082 * DTSBX424 01083 *** DISPLAY 'A ' TSUB1 ' ' TSUB2 ' ' W-MNTE-LINE. DTSBX424 01084 *P1821A-EXIT. DTSBX424 01085 * EXIT. DTSBX424 01086 * DTSBX424 01087 *P1821B-RESET. DTSBX424 01088 *** DISPLAY 'B1 ' W-LAST-SPACE ' ' TSUB1 ' ' TSUB2. DTSBX424 01089 ************* DTSBX424 01090 * EXIT IF THE LAST LETTER MOVED IS A SPACE, OR IF THE CURRENT DTSBX424 01091 * LINE DOES NOT CONTAIN ANY SPACES. DTSBX424 01092 ************* DTSBX424 01093 * IF W-MNTE-LINE (72:1) = SPACE DTSBX424 01094 * SUBTRACT +1 FROM TSUB1 DTSBX424 01095 * GO TO P1821B-EXIT DTSBX424 01096 * END-IF. DTSBX424 01097 * DTSBX424 01098 * IF W-LAST-SPACE = ZERO DTSBX424 01099 * GO TO P1821B-EXIT DTSBX424 01100 * END-IF. DTSBX424 01101 * DTSBX424 01102 ************* DTSBX424 01103 * REPLACE THE LAST LETTERS WRITTEN (OCCURRING IN THE MIDDLE OF DTSBX424 01104 * A WORD) WITH SPACES. DTSBX424 01105 ************* DTSBX424 01106 * PERFORM DTSBX424 01107 * VARYING TSUB2 FROM W-LAST-SPACE BY +1 DTSBX424 01108 * UNTIL TSUB2 > +72 DTSBX424 01109 * MOVE SPACE TO W-MNTE-LINE (TSUB2:1) DTSBX424 01110 * END-PERFORM. DTSBX424 01111 * DTSBX424 01112 ************* DTSBX424 01113 * RESET TSUB1 TO POINT TO THE FIRST LETTER OF THE INCOMPLETED DTSBX424 01114 * WORD. DTSBX424 01115 ************* DTSBX424 01116 * COMPUTE TSUB1 = TSUB1 - (73 - W-LAST-SPACE). DTSBX424 01117 * DTSBX424 01118 *** DISPLAY 'B2 ' TSUB1 ' ' TSUB2 ' ' W-MNTE-LINE. DTSBX424 01119 *P1821B-EXIT. DTSBX424 01120 * EXIT. DTSBX424 01121 DTSBX424 01122 P3000-NEW-EMP. DTSBX424 01123 *& DTSBX424 01124 DISPLAY 'BX424 P3000 ' W-EMP-NO ' ' LX42-EMP-NO. CL*16 01125 *& DTSBX424 01126 PERFORM P3400-INIT-NEW-EMP THRU P3400-EXIT. DTSBX424 01127 DTSBX424 01128 P3000-EXIT. DTSBX424 01129 EXIT. DTSBX424 01130 DTSBX424 01131 P3400-INIT-NEW-EMP. DTSBX424 01132 MOVE LX42-EMP-NO TO W-EMP-NO. DTSBX424 01133 *** SET W-ERROR-NO-88 TO TRUE. DTSBX424 01134 DTSBX424 01135 MOVE ZEROS TO W-NEW-X110-EMP. CL**2 01136 INITIALIZE X110-REC DTSBX424 01137 X120-REC. DTSBX424 01138 DTSBX424 01139 P3400-EXIT. DTSBX424 01140 EXIT. DTSBX424 01141 DTSBX424 01142 DTSBX424 01143 T0000-TERMINATE. DTSBX424 01144 DISPLAY ' '. DTSBX424 01145 CLOSE TEMP-BTC-FILE REPT-PAID-FILE REPT-PEND-FILE. CL*35 01146 DISPLAY '***************************************'. CL*19 01147 DISPLAY '*** DTSBX424 TERMINATION STATISTICS ***'. DTSBX424 01148 DISPLAY '*** EMPLOYER/OPO ADDRESS ***'. CL*19 01149 DISPLAY '***************************************'. CL*19 01150 DTSBX424 01151 DISPLAY ' '. DTSBX424 01152 DTSBX424 01153 PERFORM T2000-DISPLAY-TOTALS THRU T2000-EXIT. DTSBX424 01154 DTSBX424 01155 T0000-EXIT. DTSBX424 01156 EXIT. DTSBX424 01157 DTSBX424 01158 T2000-DISPLAY-TOTALS. DTSBX424 01159 DISPLAY 'X110-ADDRESS RECORDS READ: ' CL*19 01160 W-X110-RED-CNT. CL*19 01161 CL*19 01162 DISPLAY 'X110-ADDRESS RECORDS IN ERROR: ' CL*19 01163 W-X110-ERR-CNT. CL*19 01164 DTSBX424 01165 DISPLAY 'X110- ADDRESS RECORDS WRITTEN: ' CL*19 01166 W-T002-ADDR-CNT. DTSBX424 01167 DTSBX424 01168 DISPLAY 'X120 -OPO RECORDS READ: ' CL*19 01169 W-X120-RED-CNT. CL*19 01170 DTSBX424 01171 DISPLAY 'X120 -OPO RECORDS IN ERROR: ' CL*19 01172 W-X120-ERR-CNT. CL*19 01173 CL*19 01174 CL**8 01175 DISPLAY 'X120 -OPO RECORDS WRITTEN: ' CL*19 01176 W-T002-OPO-CNT. CL**8 01177 CL**8 01178 DISPLAY ' '. DTSBX424 01179 DTSBX424 01180 T2000-EXIT. DTSBX424 01181 EXIT. DTSBX424 01182 DTSBX424 01183 S001-FROM-FED-8. DTSBX424 01184 SET L001-FROM-FED-8 TO TRUE. DTSBX424 01185 GO TO S001-DATE. DTSBX424 01186 DTSBX424 01187 S001-FROM-CAL-8. DTSBX424 01188 SET L001-FROM-CAL-8 TO TRUE. DTSBX424 01189 GO TO S001-DATE. DTSBX424 01190 DTSBX424 01191 S001-FROM-ABS-DAY. DTSBX424 01192 SET L001-FROM-ABS-DAY TO TRUE. DTSBX424 01193 GO TO S001-DATE. DTSBX424 01194 DTSBX424 01195 S001-DATE. DTSBX424 01196 CALL 'DTSBU001' USING L001-LINK-AREA. DTSBX424 01197 S001-EXIT. DTSBX424 01198 EXIT. DTSBX424 01199 DTSBX424 01200 S003-AGENCY-DAY. DTSBX424 01201 SET L003-AGENCY-DAY TO TRUE. DTSBX424 01202 GO TO S003-WORK-DAY. DTSBX424 01203 DTSBX424 01204 S003-WORK-DAY. DTSBX424 01205 CALL 'DTSBU003' USING L003-LINK-AREA. DTSBX424 01206 S003-EXIT. DTSBX424 01207 EXIT. DTSBX424 01208 DTSBX424 01209 S004-FROM-5. DTSBX424 01210 SET L004-FROM-5 TO TRUE. DTSBX424 01211 GO TO S004-YRQ. DTSBX424 01212 DTSBX424 01213 S004-FROM-DATE. DTSBX424 01214 SET L004-FROM-DATE TO TRUE. DTSBX424 01215 GO TO S004-YRQ. DTSBX424 01216 DTSBX424 01217 S004-FROM-ABS. DTSBX424 01218 SET L004-FROM-ABS TO TRUE. DTSBX424 01219 GO TO S004-YRQ. DTSBX424 01220 DTSBX424 01221 S004-YRQ. DTSBX424 01222 CALL 'DTSBU004' USING L004-LINK-AREA. DTSBX424 01223 DTSBX424 01224 S004-EXIT. DTSBX424 01225 EXIT. DTSBX424 01226 CL*51 01227 S009-CONVERT-TO-CAPS. CL*51 01228 CALL 'DTSBU009' USING L009-LINK-AREA. CL*51 01229 CL*51 01230 S009-EXIT. CL*51 01231 EXIT. CL*51 01232 DTSBX424 01233 S072-ADDRESS. DTSBX424 01234 CALL 'DTSBU072' USING L072-LINK-AREA. DTSBX424 01235 DTSBX424 01236 S072-EXIT. DTSBX424 01237 EXIT. DTSBX424 01238 DTSBX424 01239 S516-LIABILITY-INFO. DTSBX424 01240 CALL 'DTSBU516' USING L516-LINK-AREA DTSBX424 01241 MPRF-REC. DTSBX424 01242 S516-EXIT. DTSBX424 01243 EXIT. DTSBX424 01244 DTSBX424 01245 *S910-OPEN-READ. DTSBX424 01246 * SET L910-OPEN-READ-88 TO TRUE. DTSBX424 01247 * GO TO S910-MSTR-IO. DTSBX424 01248 DTSBX424 01249 S910-READ. DTSBX424 01250 SET L910-READ-88 TO TRUE. DTSBX424 01251 GO TO S910-MSTR-IO. DTSBX424 01252 DTSBX424 01253 S910-START-BROWSE. DTSBX424 01254 SET L910-START-BROWSE-88 TO TRUE. DTSBX424 01255 GO TO S910-MSTR-IO. DTSBX424 01256 DTSBX424 01257 S910-READ-NEXT. DTSBX424 01258 SET L910-READ-NEXT-88 TO TRUE. DTSBX424 01259 GO TO S910-MSTR-IO. DTSBX424 01260 DTSBX424 01261 *S910-CLOSE. DTSBX424 01262 * SET L910-CLOSE-88 TO TRUE. DTSBX424 01263 * GO TO S910-MSTR-IO. DTSBX424 01264 DTSBX424 01265 S910-MSTR-IO. DTSBX424 01266 CALL 'DTSBU910' USING L910-LINK-AREA DTSBX424 01267 MSKL-REC. DTSBX424 01268 S910-EXIT. DTSBX424 01269 EXIT. DTSBX424 01270 DTSBX424 01271 S921-OPEN-READ. DTSBX424 01272 SET L921-OPEN-READ-88 TO TRUE. DTSBX424 01273 GO TO S921-AIX-IO. DTSBX424 01274 DTSBX424 01275 S921-READ. DTSBX424 01276 SET L921-READ-88 TO TRUE. DTSBX424 01277 GO TO S921-AIX-IO. DTSBX424 01278 DTSBX424 01279 S921-START-BROWSE. DTSBX424 01280 SET L921-START-BROWSE-88 TO TRUE. DTSBX424 01281 GO TO S921-AIX-IO. DTSBX424 01282 DTSBX424 01283 S921-READ-NEXT. DTSBX424 01284 SET L921-READ-NEXT-88 TO TRUE. DTSBX424 01285 GO TO S921-AIX-IO. DTSBX424 01286 DTSBX424 01287 S921-CLOSE. DTSBX424 01288 SET L921-CLOSE-88 TO TRUE. DTSBX424 01289 GO TO S921-AIX-IO. DTSBX424 01290 DTSBX424 01291 S921-AIX-IO. DTSBX424 01292 CALL 'DTSBU921' USING L921-LINK-AREA DTSBX424 01293 ISKL-REC. DTSBX424 01294 S921-EXIT. DTSBX424 01295 EXIT. DTSBX424 01296 DTSBX424 01297 *S927A-OPEN. DTSBX424 01298 * SET L927-OPEN-UPDATE-88 TO TRUE. DTSBX424 01299 * PERFORM S927Z-IO THRU S927Z-EXIT. DTSBX424 01300 * DTSBX424 01301 *S927A-EXIT. DTSBX424 01302 * EXIT. DTSBX424 01303 DTSBX424 01304 S927B-WRITE. DTSBX424 01305 SET L927-WRITE-88 TO TRUE. DTSBX424 01306 PERFORM S927Z-IO THRU S927Z-EXIT. DTSBX424 01307 DTSBX424 01308 S927B-EXIT. DTSBX424 01309 EXIT. DTSBX424 01310 DTSBX424 01311 *S927C-CLOSE. DTSBX424 01312 * SET L927-CLOSE-88 TO TRUE. DTSBX424 01313 * PERFORM S927Z-IO THRU S927Z-EXIT. DTSBX424 01314 * DTSBX424 01315 *S927C-EXIT. DTSBX424 01316 * EXIT. DTSBX424 01317 DTSBX424 01318 S927Z-IO. DTSBX424 01319 CALL 'DTSBU927' USING L927-LINK-AREA DTSBX424 01320 TSKL-REC. DTSBX424 01321 S927Z-EXIT. DTSBX424 01322 EXIT. DTSBX424 01323 DTSBX424 01324 *S931-OPEN-READ. DTSBX424 01325 * SET L931-OPEN-READ-88 TO TRUE. DTSBX424 01326 * GO TO S931-REF-IO. DTSBX424 01327 * DTSBX424 01328 *S931-CLOSE. DTSBX424 01329 * SET L931-CLOSE-88 TO TRUE. DTSBX424 01330 * GO TO S931-REF-IO. DTSBX424 01331 * DTSBX424 01332 *S931-REF-IO. DTSBX424 01333 * CALL 'DTSBU931' USING L931-LINK-AREA DTSBX424 01334 * FSKL-REC. DTSBX424 01335 *S931-EXIT. DTSBX424 01336 * EXIT. DTSBX424 01337 DTSBX424 01338 S946-WRITE-R140. DTSBX424 01339 * MOVE SPACES TO R140-MESSAGE DTSBX424 01340 * MOVE W-EMP-NO TO R140-EMP-NO DTSBX424 01341 * STRING DTSBX424 01342 * MSG1-TYPE ' - ' DTSBX424 01343 * MSG1-MESSAGE ': ' DTSBX424 01344 * X108-RATE-YEAR DTSBX424 01345 * DELIMITED BY SIZE DTSBX424 01346 * INTO R140-MESSAGE DTSBX424 01347 * END-STRING. DTSBX424 01348 DTSBX424 01349 CALL 'DTSBU946' USING R140-REC. DTSBX424 01350 DTSBX424 01351 S946-EXIT. DTSBX424 01352 EXIT. DTSBX424 01353 CL*25 01354 S1032-WRITE-TEMP-T002. CL*25 01355 MOVE T002-REC TO TEMP-BTC-REC. CL*25 01356 WRITE TEMP-BTC-REC. CL*25 01357 IF TEMP-BTC-STATUS-OK-88 CL*25 01358 NEXT SENTENCE CL*25 01359 ELSE CL*25 01360 DISPLAY 'CANNOT WRITE ADDRESS TEMP T002: ' CL*27 01361 TEMP-BTC-STATUS CL*25 01362 END-IF. CL*25 01363 CL*25 01364 S1032-EXIT. CL*25 01365 EXIT. CL*25 01366 CL*25 01367 CL*25 01368 S1040-OPEN-TEMP-BTC-OUT. CL*25 01369 OPEN OUTPUT TEMP-BTC-FILE CL*35 01370 REPT-PAID-FILE CL*35 01371 REPT-PEND-FILE. CL*35 01372 IF TEMP-BTC-STATUS-OK-88 CL*25 01373 NEXT SENTENCE CL*25 01374 ELSE CL*25 01375 SET W-FATAL-ERROR-YES-88 TO TRUE CL*25 01376 DISPLAY 'CANNOT OPEN ADDR BTC FILE BX424 : ' CL*25 01377 TEMP-BTC-STATUS CL*25 01378 END-IF. CL*25 01379 CL*25 01380 S1040-EXIT. CL*25 01381 EXIT. CL*25 01382 S3000-INIT-T003. CL*25 01383 MOVE LOW-VALUES TO MNTE-KEY-AREA. CL*25 01384 CL*25 01385 MOVE W-EMP-NO TO MNTE-EMP-NO. DTSBX424 01386 SET MNTE-NTE-88 TO TRUE. DTSBX424 01387 MOVE +0 TO MNTE-PURGE-DATE. DTSBX424 01388 SET MNTE-NOT-CONVERTED-88 TO TRUE. DTSBX424 01389 DTSBX424 01390 MOVE LX42-SYS-DATE TO MNTE-ESTB-DATE DTSBX424 01391 MNTE-CHNG-DATE. DTSBX424 01392 MOVE ZERO TO MNTE-KEY-ESTB-ABSTIME DTSBX424 01393 MNTE-DATA-ESTB-ABSTIME DTSBX424 01394 MNTE-CHNG-ABSTIME. DTSBX424 01395 MOVE 'WEB REG ' TO MNTE-ESTB-OP-ID DTSBX424 01396 MNTE-CHNG-OP-ID. DTSBX424 01397 MOVE +0 TO MNTE-TEXT-CNT. DTSBX424 01398 MOVE SPACES TO MNTE-TEXT-AREA. DTSBX424 01399 DTSBX424 01400 MOVE LENGTH OF T003-REC TO T003-LENGTH DTSBX424 01401 MOVE '003' TO T003-REC-TYPE. DTSBX424 01402 MOVE W-EMP-NO TO T003-EMP-NO. DTSBX424 01403 MOVE 'WEB REG ' TO T003-ORIGIN. DTSBX424 01404 MOVE LX42-SYS-DATE TO T003-SYS-DATE. DTSBX424 01405 MOVE LX42-SYS-TIME TO T003-SYS-TIME. DTSBX424 01406 SET T003-ADD-MNTE-88 TO TRUE. DTSBX424 01407 DTSBX424 01408 S3000-EXIT. DTSBX424 01409 EXIT. DTSBX424 01410 DTSBX424 01411 S999-ABEND. DTSBX424 01412 CALL 'DTSBU999' USING W-ABEND-CD. DTSBX424 01413 S999-EXIT. DTSBX424 01414 EXIT. DTSBX424 01415 DTSBX424