494 lines
39 KiB
COBOL
494 lines
39 KiB
COBOL
00001 IDENTIFICATION DIVISION. 02/02/99
|
|
00002 PROGRAM-ID. DTSBD390. DTSBD390
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV010
|
|
00004 DATE-WRITTEN. AUGUST 1994. DTSBD390
|
|
00005 DATE-COMPILED. DTSBD390
|
|
00006 SKIP3 DTSBD390
|
|
00007 ***** DTSBD390
|
|
00008 * DTSBD390
|
|
00009 * FUNCTION: LMI UPDATE PROCESSING. CL**2
|
|
00010 * DTSBD390
|
|
00011 * DTSBD390
|
|
00012 * MODIFICATION LOG: DTSBD390
|
|
00013 * DTSBD390
|
|
00014 * 09/01/94 INITIAL DEVELOPMENT. DTSBD390
|
|
00015 * WORK ORDER: PROGRAMMER: RHC DTSBD390
|
|
00016 * DTSBD390
|
|
00017 * 11/13/95 JOINT REGISTRATION PROCESSING. DURING MODIFY DTSBD390
|
|
00018 * PROCESSING, IF (EMPLOYER IS "CONNECTED" TO A DTSBD390
|
|
00019 * WH/OFLT EMPLOYER), AND (AREA CD IS MODIFIED OR DTSBD390
|
|
00020 * SIC CD IS MODIFIED) THEN WRITE A R122 RECORD DTSBD390
|
|
00021 * REPORTING THE MODIFICATIONS TO THE WH/OFLT SYSTEM. DTSBD390
|
|
00022 * WORK ORDER: JR PROGRAMMER: RPA DTSBD390
|
|
00023 * DTSBD390
|
|
00024 * 01/30/1999 REVIEWED AND MODIFIED FOR DC. CL**2
|
|
00025 * REFERENCE: DC DEVELOPMENT PROGRAMMER: EHH CL**2
|
|
00026 * CL**2
|
|
00027 * MM/DD/YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2
|
|
00028 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2
|
|
00029 * REFERENCE: XXXXXXXXXXXXXXX PROGRAMMER: XXX CL**2
|
|
00030 * DTSBD390
|
|
00031 * DTSBD390
|
|
00032 * DESCRIPTION: DTSBD390
|
|
00033 * DTSBD390
|
|
00034 * PROCESS DTSIT016 RECORDS, UPDATING THE MPRF RECORD. CL**2
|
|
00035 * DTSBD390
|
|
00036 * REMEMBER TO MAINTAIN MPRF-OLD-SIC-CD, MPRF-SIC-CHNG-DATE, CL**2
|
|
00037 * MPRF-OLD-NAICS-CD, MPRF-NAICS-CHNG-DATE, MPRF-OLD-OWN-CD, CL**2
|
|
00038 * AND MPRF-OWN-CHNG-DATE. CL**2
|
|
00039 * DTSBD390
|
|
00040 * CALL DTSBU331 AS APPROPRIATE. CL**2
|
|
00041 * DTSBD390
|
|
00042 * DTSBD390
|
|
00043 * MASTER FILE RECORDS READ: DTSBD390
|
|
00044 * DTSBD390
|
|
00045 * NONE. CL**2
|
|
00046 * DTSBD390
|
|
00047 * MASTER FILE RECORDS UPDATED: DTSBD390
|
|
00048 * DTSBD390
|
|
00049 * NONE. DTSBD390
|
|
00050 * DTSBD390
|
|
00051 * DTSBD390
|
|
00052 * REPORT RECORDS WRITTEN: DTSBD390
|
|
00053 * DTSBD390
|
|
00054 * NONE. CL**2
|
|
00055 * DTSBD390
|
|
00056 * DTSBD390
|
|
00057 * MODULES CALLED: DTSBD390
|
|
00058 * DTSBD390
|
|
00059 * DTSBU004 QUARTER CONVERSION. CL**2
|
|
00060 * DTSBU038 LMI CODES EDIT/DESCRIPTION. CL**3
|
|
00061 * DTSBU039 SIC CODE EDIT/DESCRIPTION. CL**2
|
|
00062 * DTSBU040 NAICS CODE EDIT/DESCRIPTION. CL**3
|
|
00063 * DTSBU331 WRITE ON-LINE MODIFICATION LOG RECORD. CL**3
|
|
00064 * DTSBD390
|
|
00065 ***** DTSBD390
|
|
00066 SKIP3 DTSBD390
|
|
00067 ENVIRONMENT DIVISION. DTSBD390
|
|
00068 SKIP3 DTSBD390
|
|
00069 DATA DIVISION. DTSBD390
|
|
00070 SKIP3 DTSBD390
|
|
00071 WORKING-STORAGE SECTION. DTSBD390
|
|
000715 77 PAN-VALET PICTURE X(24) VALUE '010DTSBD390 02/02/99'. DTSBD390
|
|
00072 SKIP3 DTSBD390
|
|
00073 01 WRK-AREA. DTSBD390
|
|
00074 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +390.DTSBD390
|
|
00075 CL**2
|
|
00076 05 WRK-MOD-NAME PIC X(08) VALUE 'DTSBD390'. CL**2
|
|
00077 CL**2
|
|
00078 05 FIRST-TIME-IND PIC X(01) VALUE 'Y'. DTSBD390
|
|
00079 SKIP3 DTSBD390
|
|
00080 01 MSG-TABLE. DTSBD390
|
|
00081 05 MSG1-INVALID-TRN-CD. DTSBD390
|
|
00082 10 MSG1-ID PIC X(11) VALUE 'DTSBD390905'. CL**2
|
|
00083 10 MSG1-SHORT-TEXT PIC X(20) VALUE 'INVALID TRN CD'. DTSBD390
|
|
00084 10 MSG1-LONG-TEXT. DTSBD390
|
|
00085 15 FILLER PIC X(30) DTSBD390
|
|
00086 VALUE 'TRANSACTION FAILED - TRANSACTI'. DTSBD390
|
|
00087 15 FILLER PIC X(30) DTSBD390
|
|
00088 VALUE 'ON CODE NOT VALID '. DTSBD390
|
|
00089 CL**2
|
|
00090 05 MSG2-INVALID-SIC-CD. CL**2
|
|
00091 10 MSG2-ID PIC X(11) VALUE 'DTSBD390702'. CL**2
|
|
00092 10 MSG2-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00093 10 MSG2-LONG-TEXT. CL**2
|
|
00094 15 FILLER PIC X(30) DTSBD390
|
|
00095 VALUE 'TRANSACTION FAILED - SIC CODE '. DTSBD390
|
|
00096 15 FILLER PIC X(30) DTSBD390
|
|
00097 VALUE 'IS NOT VALID '. CL**2
|
|
00098 CL**2
|
|
00099 05 MSG3-INVALID-SIC-AUX-CD. CL**2
|
|
00100 10 MSG3-ID PIC X(11) VALUE 'DTSBD390703'. CL**2
|
|
00101 10 MSG3-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00102 10 MSG3-LONG-TEXT. CL**2
|
|
00103 15 FILLER PIC X(30) DTSBD390
|
|
00104 VALUE 'TRANSACTION FAILED - SIC AUXIL'. CL**2
|
|
00105 15 FILLER PIC X(30) DTSBD390
|
|
00106 VALUE 'IARY CODE NOT VALID '. CL**2
|
|
00107 CL**2
|
|
00108 05 MSG4-INVALID-NAICS-CD. CL**2
|
|
00109 10 MSG4-ID PIC X(11) VALUE 'DTSBD390704'. CL**2
|
|
00110 10 MSG4-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00111 10 MSG4-LONG-TEXT. CL**2
|
|
00112 15 FILLER PIC X(30) CL**2
|
|
00113 VALUE 'TRANSACTION FAILED - NAICS COD'. CL**2
|
|
00114 15 FILLER PIC X(30) CL**2
|
|
00115 VALUE 'E IS NOT VALID '. CL**2
|
|
00116 CL**2
|
|
00117 05 MSG5-INVALID-NAICS-AUX-CD. CL**2
|
|
00118 10 MSG5-ID PIC X(11) VALUE 'DTSBD390705'. CL**2
|
|
00119 10 MSG5-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00120 10 MSG5-LONG-TEXT. CL**2
|
|
00121 15 FILLER PIC X(30) CL**2
|
|
00122 VALUE 'TRANSACTION FAILED - NAICS AUX'. CL**2
|
|
00123 15 FILLER PIC X(30) CL**2
|
|
00124 VALUE 'ILIARY CODE IS NOT VALID '. CL**2
|
|
00125 CL**2
|
|
00126 05 MSG6-INVALID-OWN-CD. CL**2
|
|
00127 10 MSG6-ID PIC X(11) VALUE 'DTSBD390706'. CL**2
|
|
00128 10 MSG6-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00129 10 MSG6-LONG-TEXT. CL**2
|
|
00130 15 FILLER PIC X(30) CL**2
|
|
00131 VALUE 'TRANSACTION FAILED - OWNERSHIP'. CL**2
|
|
00132 15 FILLER PIC X(30) CL**2
|
|
00133 VALUE ' CODE IS NOT VALID '. CL**2
|
|
00134 CL**2
|
|
00135 05 MSG7-INVALID-MULTI-IND. CL**2
|
|
00136 10 MSG7-ID PIC X(11) VALUE 'DTSBD390707'. CL**2
|
|
00137 10 MSG7-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00138 10 MSG7-LONG-TEXT. CL**2
|
|
00139 15 FILLER PIC X(30) DTSBD390
|
|
00140 VALUE 'TRANSACTION FAILED - MULTI SIT'. DTSBD390
|
|
00141 15 FILLER PIC X(30) DTSBD390
|
|
00142 VALUE 'E INDICATOR IS NOT VALID. '. DTSBD390
|
|
00143 CL**2
|
|
00144 05 MSG8-INVALID-WARD-CD. CL**2
|
|
00145 10 MSG8-ID PIC X(11) VALUE 'DTSBD390708'. CL**2
|
|
00146 10 MSG8-SHORT-TEXT PIC X(20) VALUE ' '. CL**2
|
|
00147 10 MSG8-LONG-TEXT. CL**2
|
|
00148 15 FILLER PIC X(30) CL**2
|
|
00149 VALUE 'TRANSACTION FAILED - WARD CODE'. CL**2
|
|
00150 15 FILLER PIC X(30) CL**2
|
|
00151 VALUE ' IS NOT VALID. '. CL*10
|
|
00152 EJECT DTSBD390
|
|
00153 *01 L910-LINK-AREA. CL**2
|
|
00154 ***INCLUDE DTSIL910 CL**2
|
|
00155 SKIP3 CL**2
|
|
00156 *01 MSKL-REC. CL**2
|
|
00157 ***INCLUDE DTSIMSKL CL**2
|
|
00158 SKIP3 CL**2
|
|
00159 *01 MRTE-REC. CL**2
|
|
00160 ***INCLUDE DTSIMRTE CL**2
|
|
00161 EJECT DTSBD390
|
|
00162 *01 L004-LINK-AREA. CL**3
|
|
00163 ***INCLUDE DTSIL004 CL**3
|
|
00164 SKIP3 DTSBD390
|
|
00165 01 L038-LINK-AREA. DTSBD390
|
|
00166 ++INCLUDE DTSIL038 CL**2
|
|
00167 SKIP3 DTSBD390
|
|
00168 01 L039-LINK-AREA. DTSBD390
|
|
00169 ++INCLUDE DTSIL039 CL**2
|
|
00170 SKIP3 DTSBD390
|
|
00171 01 L040-LINK-AREA. CL**2
|
|
00172 ++INCLUDE DTSIL040 CL**2
|
|
00173 SKIP3 DTSBD390
|
|
00174 01 L331-LINK-AREA. CL**2
|
|
00175 ++INCLUDE DTSIL331 CL**2
|
|
00176 EJECT DTSBD390
|
|
00177 LINKAGE SECTION. DTSBD390
|
|
00178 SKIP3 DTSBD390
|
|
00179 01 LBCM-LINK-AREA. DTSBD390
|
|
00180 ++INCLUDE DTSILBCM CL**2
|
|
00181 EJECT DTSBD390
|
|
00182 01 MPRF-REC. DTSBD390
|
|
00183 ++INCLUDE DTSIMPRF CL**2
|
|
00184 EJECT DTSBD390
|
|
00185 01 T016-REC. DTSBD390
|
|
00186 ++INCLUDE DTSIT016 CL**2
|
|
00187 EJECT DTSBD390
|
|
00188 PROCEDURE DIVISION USING LBCM-LINK-AREA DTSBD390
|
|
00189 MPRF-REC DTSBD390
|
|
00190 T016-REC. DTSBD390
|
|
00191 CL**2
|
|
00192 CL**2
|
|
00193 IF FIRST-TIME-IND = 'Y' DTSBD390
|
|
00194 PERFORM I0000-INITIATE THRU I0000-EXIT DTSBD390
|
|
00195 MOVE 'N' TO FIRST-TIME-IND. DTSBD390
|
|
00196 CL**2
|
|
00197 CL**2
|
|
00198 IF NOT T016-EMP-LVL DTSBD390
|
|
00199 MOVE MSG1-INVALID-TRN-CD TO LBCM-TRN-MSG-AREA DTSBD390
|
|
00200 SET LBCM-TRN-NOT-OK-88 TO TRUE DTSBD390
|
|
00201 ELSE DTSBD390
|
|
00202 PERFORM P1000-EMP-LVL-CHECKS THRU P1000-EXIT DTSBD390
|
|
00203 IF LBCM-TRN-OK-88 DTSBD390
|
|
00204 PERFORM P2000-EMP-LVL-UPDATE THRU P2000-EXIT. CL**2
|
|
00205 CL**2
|
|
00206 CL**2
|
|
00207 GOBACK. DTSBD390
|
|
00208 EJECT CL**2
|
|
00209 I0000-INITIATE. DTSBD390
|
|
00210 *****MOVE LBCM-TRACE-IND TO L910-TRACE-IND. CL**3
|
|
00211 CL**2
|
|
00212 *****MOVE WRK-MOD-NAME TO L910-MOD-NAME. CL**3
|
|
00213 CL**5
|
|
00214 CL**5
|
|
00215 MOVE LBCM-CURR-RUN-DATE TO L331-CURR-RUN-DATE. CL**5
|
|
00216 CL**5
|
|
00217 MOVE 'BATCH' TO L331-OP-ID. CL**5
|
|
00218 CL**5
|
|
00219 MOVE SPACES TO L331-FIELD-NAME. CL**5
|
|
00220 I0000-EXIT. CL**2
|
|
00221 EXIT. CL**2
|
|
00222 EJECT DTSBD390
|
|
00223 P1000-EMP-LVL-CHECKS. DTSBD390
|
|
00224 IF T016-SIC-CD NOT = SPACE CL**3
|
|
00225 MOVE T016-SIC-CD TO L039-SIC-CD CL**3
|
|
00226 PERFORM S039-SIC-EDIT THRU S039-EXIT CL**3
|
|
00227 IF L039-SIC-NOT-VALID DTSBD390
|
|
00228 SET LBCM-TRN-NOT-OK-88 TO TRUE DTSBD390
|
|
00229 MOVE MSG2-INVALID-SIC-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00230 GO TO P1000-EXIT. DTSBD390
|
|
00231 CL**3
|
|
00232 IF T016-SIC-AUXILIARY-CD NOT = SPACE CL**6
|
|
00233 MOVE T016-SIC-AUXILIARY-CD TO L038-CD-1 CL**3
|
|
00234 PERFORM S038-MPRF-SIC-AUXILIARY-CD THRU S038-EXIT CL**6
|
|
00235 IF L038-NOT-VALID CL**3
|
|
00236 SET LBCM-TRN-NOT-OK-88 TO TRUE CL**3
|
|
00237 MOVE MSG3-INVALID-SIC-AUX-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00238 GO TO P1000-EXIT. CL**3
|
|
00239 CL**3
|
|
00240 IF T016-NAICS-CD NOT = SPACE CL**6
|
|
00241 MOVE T016-NAICS-CD TO L040-NAICS-CD CL**6
|
|
00242 PERFORM S040-NAICS-EDIT THRU S040-EXIT CL**6
|
|
00243 IF L040-NAICS-NOT-VALID CL**6
|
|
00244 SET LBCM-TRN-NOT-OK-88 TO TRUE CL**6
|
|
00245 MOVE MSG4-INVALID-NAICS-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00246 GO TO P1000-EXIT. CL**6
|
|
00247 CL**6
|
|
00248 IF T016-NAICS-AUXILIARY-CD NOT = SPACE CL**6
|
|
00249 MOVE T016-NAICS-AUXILIARY-CD TO L038-CD-1 CL**6
|
|
00250 PERFORM S038-MPRF-NAICS-AUXILIARY-CD THRU S038-EXIT CL**6
|
|
00251 IF L038-NOT-VALID CL**6
|
|
00252 SET LBCM-TRN-NOT-OK-88 TO TRUE CL**6
|
|
00253 MOVE MSG5-INVALID-NAICS-AUX-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00254 GO TO P1000-EXIT. CL**6
|
|
00255 CL**6
|
|
00256 IF T016-OWN-CD NOT = SPACE CL**6
|
|
00257 MOVE T016-OWN-CD TO L038-CD-2 CL**6
|
|
00258 PERFORM S038-MPRF-OWN-CD THRU S038-EXIT CL**6
|
|
00259 IF L038-NOT-VALID DTSBD390
|
|
00260 SET LBCM-TRN-NOT-OK-88 TO TRUE DTSBD390
|
|
00261 MOVE MSG6-INVALID-OWN-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00262 GO TO P1000-EXIT. DTSBD390
|
|
00263 CL**6
|
|
00264 IF T016-MULTI-IND NOT = SPACE CL**6
|
|
00265 MOVE T016-MULTI-IND TO L038-CD-1 CL**6
|
|
00266 PERFORM S038-MPRF-MULTI-IND THRU S038-EXIT CL**6
|
|
00267 IF L038-NOT-VALID CL**6
|
|
00268 SET LBCM-TRN-NOT-OK-88 TO TRUE CL**6
|
|
00269 MOVE MSG7-INVALID-MULTI-IND TO LBCM-TRN-MSG-AREA CL**6
|
|
00270 GO TO P1000-EXIT. CL**6
|
|
00271 CL**6
|
|
00272 IF T016-WARD-CD NOT = SPACE CL**6
|
|
00273 MOVE T016-WARD-CD TO L038-CD-2 CL**6
|
|
00274 PERFORM S038-MPRF-WARD-CD THRU S038-EXIT CL**6
|
|
00275 IF L038-NOT-VALID CL**6
|
|
00276 SET LBCM-TRN-NOT-OK-88 TO TRUE CL**6
|
|
00277 MOVE MSG8-INVALID-WARD-CD TO LBCM-TRN-MSG-AREA CL**6
|
|
00278 GO TO P1000-EXIT. CL**6
|
|
00279 P1000-EXIT. CL**6
|
|
00280 EXIT. CL**6
|
|
00281 EJECT DTSBD390
|
|
00282 P2000-EMP-LVL-UPDATE. CL**2
|
|
00283 MOVE MPRF-EMP-NO TO L331-EMP-NO. CL**5
|
|
00284 CL**5
|
|
00285 MOVE LBCM-EMP-ABSTIME TO L331-UPDATE-ABSTIME. CL**5
|
|
00286 CL**5
|
|
00287 CL**5
|
|
00288 IF (T016-SIC-CD = SPACE) DTSBD390
|
|
00289 OR CL**7
|
|
00290 (T016-SIC-CD = MPRF-SIC-CD) CL**7
|
|
00291 NEXT SENTENCE DTSBD390
|
|
00292 ELSE DTSBD390
|
|
00293 MOVE 'MPRF-SIC-CD' TO L331-FIELD-NAME CL**7
|
|
00294 MOVE MPRF-SIC-CD TO L331-FROM-VALUE CL**7
|
|
00295 MOVE T016-SIC-CD TO L331-TO-VALUE CL**7
|
|
00296 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00297 SET LBCM-EMP-UPDATE-YES-88 TO TRUE DTSBD390
|
|
00298 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00299 MPRF-SIC-CHNG-DATE CL**7
|
|
00300 MOVE MPRF-SIC-CD TO MPRF-OLD-SIC-CD CL**7
|
|
00301 MOVE T016-SIC-CD TO MPRF-SIC-CD. CL**7
|
|
00302 CL**7
|
|
00303 CL**7
|
|
00304 IF (T016-SIC-AUXILIARY-CD = SPACE) CL**7
|
|
00305 OR CL**7
|
|
00306 (T016-SIC-AUXILIARY-CD = MPRF-SIC-AUXILIARY-CD) CL**7
|
|
00307 NEXT SENTENCE CL**7
|
|
00308 ELSE CL**7
|
|
00309 MOVE 'MPRF-SIC-AUXILIARY-CD' TO L331-FIELD-NAME CL**7
|
|
00310 MOVE MPRF-SIC-AUXILIARY-CD TO L331-FROM-VALUE CL**7
|
|
00311 MOVE T016-SIC-AUXILIARY-CD TO L331-TO-VALUE CL**7
|
|
00312 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00313 SET LBCM-EMP-UPDATE-YES-88 TO TRUE CL**7
|
|
00314 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00315 MOVE T016-SIC-AUXILIARY-CD TO MPRF-SIC-AUXILIARY-CD. CL**7
|
|
00316 CL**7
|
|
00317 CL**7
|
|
00318 IF (T016-NAICS-CD = SPACE) CL**7
|
|
00319 OR CL**7
|
|
00320 (T016-NAICS-CD = MPRF-NAICS-CD) CL**7
|
|
00321 NEXT SENTENCE CL**7
|
|
00322 ELSE CL**7
|
|
00323 MOVE 'MPRF-NAICS-CD' TO L331-FIELD-NAME CL**7
|
|
00324 MOVE MPRF-NAICS-CD TO L331-FROM-VALUE CL**7
|
|
00325 MOVE T016-NAICS-CD TO L331-TO-VALUE CL**7
|
|
00326 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00327 SET LBCM-EMP-UPDATE-YES-88 TO TRUE CL**7
|
|
00328 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00329 MPRF-NAICS-CHNG-DATE CL**7
|
|
00330 MOVE MPRF-NAICS-CD TO MPRF-OLD-NAICS-CD CL**7
|
|
00331 MOVE T016-NAICS-CD TO MPRF-NAICS-CD. CL**7
|
|
00332 CL**7
|
|
00333 CL**7
|
|
00334 IF (T016-NAICS-AUXILIARY-CD = SPACE) CL**7
|
|
00335 OR CL**7
|
|
00336 (T016-NAICS-AUXILIARY-CD = MPRF-NAICS-AUXILIARY-CD) CL**7
|
|
00337 NEXT SENTENCE CL**7
|
|
00338 ELSE CL**7
|
|
00339 MOVE 'MPRF-NAICS-AUXILIARY-CD' TO L331-FIELD-NAME CL**7
|
|
00340 MOVE MPRF-NAICS-AUXILIARY-CD TO L331-FROM-VALUE CL**7
|
|
00341 MOVE T016-NAICS-AUXILIARY-CD TO L331-TO-VALUE CL**7
|
|
00342 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00343 SET LBCM-EMP-UPDATE-YES-88 TO TRUE CL**7
|
|
00344 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00345 MOVE T016-NAICS-AUXILIARY-CD TO MPRF-NAICS-AUXILIARY-CD. CL**7
|
|
00346 CL**2
|
|
00347 CL**7
|
|
00348 IF (T016-OWN-CD = SPACE) DTSBD390
|
|
00349 OR CL**7
|
|
00350 (T016-OWN-CD = MPRF-OWN-CD) CL**7
|
|
00351 NEXT SENTENCE DTSBD390
|
|
00352 ELSE DTSBD390
|
|
00353 MOVE 'MPRF-OWN-CD' TO L331-FIELD-NAME CL**7
|
|
00354 MOVE MPRF-OWN-CD TO L331-FROM-VALUE CL**7
|
|
00355 MOVE T016-OWN-CD TO L331-TO-VALUE CL**7
|
|
00356 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00357 SET LBCM-EMP-UPDATE-YES-88 TO TRUE DTSBD390
|
|
00358 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00359 MPRF-OWN-CHNG-DATE CL**7
|
|
00360 MOVE MPRF-OWN-CD TO MPRF-OLD-OWN-CD CL**7
|
|
00361 MOVE T016-OWN-CD TO MPRF-OWN-CD. CL**7
|
|
00362 CL**2
|
|
00363 CL**7
|
|
00364 IF (T016-MULTI-IND = SPACE) CL**7
|
|
00365 OR CL**7
|
|
00366 (T016-MULTI-IND = MPRF-MULTI-IND) CL**7
|
|
00367 NEXT SENTENCE DTSBD390
|
|
00368 ELSE DTSBD390
|
|
00369 MOVE 'MPRF-MULTI-IND' TO L331-FIELD-NAME CL**7
|
|
00370 MOVE MPRF-MULTI-IND TO L331-FROM-VALUE CL**7
|
|
00371 MOVE T016-MULTI-IND TO L331-TO-VALUE CL**7
|
|
00372 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**7
|
|
00373 SET LBCM-EMP-UPDATE-YES-88 TO TRUE DTSBD390
|
|
00374 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00375 MOVE T016-MULTI-IND TO MPRF-MULTI-IND. CL**7
|
|
00376 CL**2
|
|
00377 CL**8
|
|
00378 IF (T016-WARD-CD = SPACE) CL**7
|
|
00379 OR CL**7
|
|
00380 (T016-WARD-CD = MPRF-WARD-CD) CL**7
|
|
00381 NEXT SENTENCE DTSBD390
|
|
00382 ELSE DTSBD390
|
|
00383 MOVE 'MPRF-WARD-CD' TO L331-FIELD-NAME CL**7
|
|
00384 MOVE MPRF-WARD-CD TO L331-FROM-VALUE CL**7
|
|
00385 MOVE T016-WARD-CD TO L331-TO-VALUE CL**7
|
|
00386 PERFORM S331-WRITE-MLOG THRU S331-EXIT CL**9
|
|
00387 SET LBCM-EMP-UPDATE-YES-88 TO TRUE DTSBD390
|
|
00388 MOVE LBCM-CURR-RUN-DATE TO MPRF-CHNG-DATE CL**7
|
|
00389 MOVE T016-WARD-CD TO MPRF-WARD-CD. CL**7
|
|
00390 P2000-EXIT. CL**2
|
|
00391 EXIT. CL**2
|
|
00392 EJECT DTSBD390
|
|
00393 *S004-FROM-5. CL**3
|
|
00394 *****SET L004-FROM-5 TO TRUE. CL**3
|
|
00395 *****GO TO S004-QTR. CL**3
|
|
00396 CL**2
|
|
00397 *S004-FROM-ABS. CL**3
|
|
00398 *****SET L004-FROM-ABS TO TRUE. CL**3
|
|
00399 *****GO TO S004-QTR. CL**3
|
|
00400 CL**2
|
|
00401 *S004-QTR. CL**3
|
|
00402 *****CALL 'DTSBU004' USING L004-LINK-AREA. CL**3
|
|
00403 *S004-EXIT. CL**3
|
|
00404 EXIT. CL**3
|
|
00405 SKIP3 DTSBD390
|
|
00406 S038-MPRF-SIC-AUXILIARY-CD. CL**3
|
|
00407 SET L038-MPRF-SIC-AUXILIARY-CD TO TRUE. CL**3
|
|
00408 GO TO S038-LMI-CODES-EDIT. CL**3
|
|
00409 CL**2
|
|
00410 S038-MPRF-NAICS-AUXILIARY-CD. CL**3
|
|
00411 SET L038-MPRF-NAICS-AUXILIARY-CD TO TRUE. CL**3
|
|
00412 GO TO S038-LMI-CODES-EDIT. CL**3
|
|
00413 CL**3
|
|
00414 S038-MPRF-OWN-CD. CL**3
|
|
00415 SET L038-MPRF-OWN-CD TO TRUE. CL**3
|
|
00416 GO TO S038-LMI-CODES-EDIT. CL**3
|
|
00417 CL**3
|
|
00418 S038-MPRF-MULTI-IND. CL**3
|
|
00419 SET L038-MPRF-MULTI-IND TO TRUE. CL**3
|
|
00420 GO TO S038-LMI-CODES-EDIT. CL**3
|
|
00421 CL**3
|
|
00422 S038-MPRF-WARD-CD. CL**3
|
|
00423 SET L038-MPRF-WARD-CD TO TRUE. CL**3
|
|
00424 GO TO S038-LMI-CODES-EDIT. CL**3
|
|
00425 CL**3
|
|
00426 S038-LMI-CODES-EDIT. CL**3
|
|
00427 CALL 'DTSBU038' USING L038-LINK-AREA. CL**2
|
|
00428 S038-EXIT. CL**3
|
|
00429 EXIT. CL**3
|
|
00430 SKIP3 DTSBD390
|
|
00431 S039-SIC-EDIT. CL**3
|
|
00432 CALL 'DTSBU039' USING L039-LINK-AREA. CL**2
|
|
00433 S039-EXIT. CL**3
|
|
00434 EXIT. CL**3
|
|
00435 SKIP3 CL**3
|
|
00436 S040-NAICS-EDIT. CL**3
|
|
00437 CALL 'DTSBU040' USING L040-LINK-AREA. CL**3
|
|
00438 S040-EXIT. CL**3
|
|
00439 EXIT. CL**3
|
|
00440 SKIP3 CL**3
|
|
00441 S331-WRITE-MLOG. CL**4
|
|
00442 CALL 'DTSBU331' USING L331-LINK-AREA. CL**4
|
|
00443 S331-EXIT. CL**4
|
|
00444 EXIT. CL**4
|
|
00445 SKIP3 CL**4
|
|
00446 *S910-READ. DTSBD390
|
|
00447 *****SET L910-READ-88 TO TRUE. CL**3
|
|
00448 *****GO TO S910-MSTR-IO. CL**3
|
|
00449 CL**2
|
|
00450 *S910-START-BROWSE. CL**3
|
|
00451 *****SET L910-START-BROWSE-88 TO TRUE. CL**3
|
|
00452 *****GO TO S910-MSTR-IO. CL**3
|
|
00453 CL**2
|
|
00454 *S910-READ-NEXT. CL**3
|
|
00455 *****SET L910-READ-NEXT-88 TO TRUE. CL**3
|
|
00456 *****GO TO S910-MSTR-IO. CL**3
|
|
00457 CL**2
|
|
00458 *S910-COUNT. DTSBD390
|
|
00459 *****SET L910-COUNT-88 TO TRUE. CL**3
|
|
00460 *****GO TO S910-MSTR-IO. CL**3
|
|
00461 CL**3
|
|
00462 *S910-WRITE. DTSBD390
|
|
00463 *****SET L910-WRITE-88 TO TRUE. CL**3
|
|
00464 *****SET LBCM-EMP-UPDATE-YES-88 TO TRUE. CL**3
|
|
00465 *****GO TO S910-MSTR-IO. CL**3
|
|
00466 CL**3
|
|
00467 *S910-REWRITE. DTSBD390
|
|
00468 *****SET L910-REWRITE-88 TO TRUE. CL**3
|
|
00469 *****SET LBCM-EMP-UPDATE-YES-88 TO TRUE. CL**3
|
|
00470 *****GO TO S910-MSTR-IO. CL**3
|
|
00471 CL**3
|
|
00472 *S910-DELETE. DTSBD390
|
|
00473 *****SET L910-DELETE-88 TO TRUE. CL**3
|
|
00474 *****SET LBCM-EMP-UPDATE-YES-88 TO TRUE. CL**3
|
|
00475 *****GO TO S910-MSTR-IO. CL**3
|
|
00476 CL**2
|
|
00477 *S910-MSTR-IO. CL**3
|
|
00478 *****CALL 'DTSBU910' USING L910-LINK-AREA CL**3
|
|
00479 ***************************MSKL-REC. CL**3
|
|
00480 *S910-EXIT. CL**3
|
|
00481 *****EXIT. CL**3
|
|
00482 SKIP3 DTSBD390
|
|
00483 *S946-WRITE-R101. CL**3
|
|
00484 *****CALL 'DTSBU946' USING R101-REC. CL**3
|
|
00485 *****GO TO S946-EXIT. CL**3
|
|
00486 CL**2
|
|
00487 *S946-WRITE-R725. CL**3
|
|
00488 *****CALL 'DTSBU946' USING R725-REC. CL**3
|
|
00489 *****GO TO S946-EXIT. CL**3
|
|
00490 CL**2
|
|
00491 *S946-EXIT. CL**4
|
|
00492 *****EXIT. CL**4
|