1417 lines
112 KiB
COBOL
1417 lines
112 KiB
COBOL
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
|