00001 IDENTIFICATION DIVISION. 01/11/05 00002 PROGRAM-ID. DTSBR127. DTSBR127 00003 AUTHOR. TRW LV083 00004 DATE-WRITTEN. NOVEMBER 1998. DTSBR127 00005 DATE-COMPILED. DTSBR127 00006 DTSBR127 00007 ***** DTSBR127 00008 * CALLING SEQUENCE: DTSBD400 CALLS DTSBR127 00009 * DTSBD390 WHICH UPDATES DTSIR127 DTSBR127 00010 * DTSBR127 READS DTSIR127 RECORDS. DTSBR127 00011 * DTSBR127 00012 * FUNCTION: PRINT FR-500 EMPLOYER REGISTRATION FORM DTSBR127 00013 * DTSBR127 00014 * DTSBR127 00015 * MODIFICATION HISTORY: DTSBR127 00016 * DTSBR127 00017 * DTSBR127 00018 * DESCRIPTION: DTSBR127 00019 * DTSBR127 00020 * THIS IS AN "AT LEAST ONCE" MODULE. DTSBR127 00021 * DTSBR127 00022 * DTSBR127 00023 * RECORDS READ: DTSBR127 00024 * DTSBR127 00025 * NONE. DTSBR127 00026 * DTSBR127 00027 * DTSBR127 00028 * PRINTED OUTPUTS: DTSBR127 00029 * DTSBR127 00030 * NONE. DTSBR127 00031 * DTSBR127 00032 * DTSBR127 00033 * RECORDS WRITTEN: DTSBR127 00034 * DTSBR127 00035 * NONE DTSBR127 00036 * DTSBR127 00037 * DTSBR127 00038 * MODULES CALLED: DTSBR127 00039 * DTSBR127 00040 * DTSBR127 00041 ***** DTSBR127 00042 EJECT DTSBR127 00043 ENVIRONMENT DIVISION. DTSBR127 00044 DTSBR127 00045 INPUT-OUTPUT SECTION. DTSBR127 00046 DTSBR127 00047 FILE-CONTROL. DTSBR127 00048 SELECT RPT127R1 ASSIGN TO RPT127R1. DTSBR127 00049 DTSBR127 00050 DATA DIVISION. DTSBR127 00051 DTSBR127 00052 FILE SECTION. DTSBR127 00053 DTSBR127 00054 FD RPT127R1 DTSBR127 00055 RECORDING MODE IS F DTSBR127 00056 LABEL RECORDS ARE OMITTED DTSBR127 00057 BLOCK CONTAINS 0 RECORDS. DTSBR127 00058 01 RPT127-REC PIC X(132). DTSBR127 00059 EJECT DTSBR127 00060 WORKING-STORAGE SECTION. DTSBR127 000605 77 PAN-VALET PICTURE X(24) VALUE '083DTSBR127 01/11/05'. DTSBR127 00061 DTSBR127 00062 01 WRK-AREA. DTSBR127 00063 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +127.DTSBR127 00064 05 WS-EMP-NO-A PIC 9(06) VALUE ZEROES. DTSBR127 00065 DTSBR127 00066 05 FIRST-TIME-IND PIC X(01) VALUE 'Y'. DTSBR127 00067 DTSBR127 00068 05 SKIP-CNT PIC 9(02). DTSBR127 00069 DTSBR127 00070 05 WS-FEINX PIC 9(9) VALUE ZEROS. DTSBR127 00071 05 WS-FEIN-Z REDEFINES WS-FEINX. DTSBR127 00072 10 WS-FEINA PIC 9(4). DTSBR127 00073 10 WS-FEINB PIC 9(5). DTSBR127 00074 01 WS-TELEPHONE. DTSBR127 00075 05 WS-AREA PIC X(03). DTSBR127 00076 05 FILLER PIC X VALUE '-'. DTSBR127 00077 05 WS-EXCH PIC X(03). DTSBR127 00078 05 FILLER PIC X VALUE '-'. DTSBR127 00079 05 WS-NUM PIC X(04). DTSBR127 00080 05 WS-LIT PIC X VALUE '-'. DTSBR127 00081 05 WS-EXT PIC X(05). DTSBR127 00082 01 WS-NAME-ADDR-SSN. DTSBR127 00083 05 FILLER PIC X(03) VALUE SPACES. DTSBR127 00084 05 FILLER PIC X(32) VALUE ALL '_'. DTSBR127 00085 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00086 05 FILLER PIC X(33) VALUE ALL '_'. DTSBR127 00087 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00088 05 FILLER PIC X(09) VALUE ALL '_'. DTSBR127 00089 01 WS-LINE-1. DTSBR127 00090 05 FILLER PIC X(17) VALUE SPACES. DTSBR127 00091 05 WS-FEIN. DTSBR127 00092 07 WS-FEINAA PIC 9BB9BBB9B9B BLANK WHEN ZEROS. DTSBR127 00093 07 WS-FEINBB PIC 9BB9B9BB9BB9 BLANK WHEN ZEROS. DTSBR127 00094 05 FILLER PIC X(29) VALUE SPACES. DTSBR127 00095 05 WS-EMP-NO PIC 9BB9BBB9BB9BB9BB9. DTSBR127 00096 01 WS-LINE-2. DTSBR127 00097 05 FILLER PIC X(01) VALUE SPACES. DTSBR127 00098 05 WS-ENTITY PIC X(40). DTSBR127 00099 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00100 05 WS-PRIMARY PIC X(40). DTSBR127 00101 *01 WS-LINE-2A. DTSBR127 00102 * 05 FILLER PIC X(45) VALUE SPACES. DTSBR127 00103 * 05 WS-ENTITY PIC X(40). DTSBR127 00104 * 05 FILLER PIC X(20) VALUE SPACES. DTSBR127 00105 * 05 WS-PRIMARY PIC X(40). DTSBR127 00106 01 WS-LINE-3. DTSBR127 00107 05 FILLER PIC X(01) VALUE SPACES. DTSBR127 00108 05 WS-ST-ATTN PIC X(40). DTSBR127 00109 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00110 05 WS-ML-ATTN PIC X(40). DTSBR127 00111 01 WS-LINE-4. DTSBR127 00112 05 FILLER PIC X(01) VALUE SPACES. DTSBR127 00113 05 WS-ST-LN1 PIC X(40). DTSBR127 00114 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00115 05 WS-ML-LN1 PIC X(40). DTSBR127 00116 01 WS-LINE-5. DTSBR127 00117 05 FILLER PIC X(01) VALUE SPACES. DTSBR127 00118 05 WS-ST-LN2 PIC X(40). DTSBR127 00119 05 FILLER PIC X(02) VALUE SPACES. DTSBR127 00120 05 WS-ML-LN2 PIC X(40). DTSBR127 00121 01 WS-LINE-6. DTSBR127 00122 05 FILLER PIC X(01) VALUE SPACES. DTSBR127 00123 05 WS-ST-CITY PIC X(20). DTSBR127 00124 05 FILLER PIC X(01) VALUE ' '. DTSBR127 00125 05 WS-ST-ST PIC X(02). DTSBR127 00126 05 FILLER PIC X(02) VALUE ' '. DTSBR127 00127 05 WS-ST-ZIP PIC X(10). DTSBR127 00128 05 FILLER PIC X(07) VALUE SPACES. DTSBR127 00129 05 WS-ML-CITY PIC X(20). DTSBR127 00130 05 FILLER PIC X(01) VALUE ' '. DTSBR127 00131 05 WS-ML-ST PIC X(02). DTSBR127 00132 05 FILLER PIC X(02) VALUE ' '. DTSBR127 00133 05 WS-ML-ZIP PIC X(10). DTSBR127 00134 01 WS-LINE-7. DTSBR127 00135 05 FILLER PIC X(25) VALUE SPACES. DTSBR127 00136 05 WS-LV PIC X(17). DTSBR127 00137 01 WS-LINE-8. DTSBR127 00138 05 FILLER PIC X(25) VALUE SPACES. DTSBR127 00139 05 WS-LF PIC X(17). DTSBR127 00140 01 WS-LINE-9. DTSBR127 00141 05 FILLER PIC X(25) VALUE SPACES. DTSBR127 00142 05 WS-MV PIC X(17). DTSBR127 00143 01 WS-LINE-10. DTSBR127 00144 05 FILLER PIC X(25) VALUE SPACES. DTSBR127 00145 05 WS-MF PIC X(17). DTSBR127 00146 01 WS-LINE-11. DTSBR127 00147 05 FILLER PIC X(25) VALUE SPACES. DTSBR127 00148 05 WS-EMAIL PIC X(17). DTSBR127 00149 DTSBR127 00150 ++INCLUDE DTSXL127 DTSBR127 00151 EJECT DTSBR127 00152 LINKAGE SECTION. DTSBR127 00153 DTSBR127 00154 01 LRCM-LINK-AREA. DTSBR127 00155 ++INCLUDE DTSILRCM DTSBR127 00156 EJECT DTSBR127 00157 01 R127-REC. DTSBR127 00158 ++INCLUDE DTSIR127 DTSBR127 00159 EJECT DTSBR127 00160 PROCEDURE DIVISION USING LRCM-LINK-AREA DTSBR127 00161 R127-REC. DTSBR127 00162 DTSBR127 00163 IF FIRST-TIME-IND = 'Y' DTSBR127 00164 PERFORM I1000-INITIATE DTSBR127 00165 THRU I1000-EXIT DTSBR127 00166 MOVE 'N' TO FIRST-TIME-IND. DTSBR127 00167 DTSBR127 00168 IF LRCM-EOR-88 DTSBR127 00169 PERFORM T1000-TERMINATE DTSBR127 00170 THRU T1000-EXIT DTSBR127 00171 ELSE DTSBR127 00172 PERFORM P1000-PROCESS DTSBR127 00173 THRU P1000-EXIT. DTSBR127 00174 DTSBR127 00175 GOBACK. DTSBR127 00176 EJECT DTSBR127 00177 I1000-INITIATE. DTSBR127 00178 DTSBR127 00179 OPEN OUTPUT RPT127R1. DTSBR127 00180 DTSBR127 00181 WRITE RPT127-REC FROM XEROX-CNTL-LINE AFTER ADVANCING PAGE. DTSBR127 00182 WRITE RPT127-REC FROM XEROX-CNTL-LINE2. DTSBR127 00183 WRITE RPT127-REC FROM LINE-13 AFTER 35. DTSBR127 00184 WRITE RPT127-REC FROM LINE-14. DTSBR127 00185 WRITE RPT127-REC FROM LINE-15. DTSBR127 00186 WRITE RPT127-REC FROM LINE-16. DTSBR127 00187 WRITE RPT127-REC FROM LINE-17. DTSBR127 00188 MOVE SPACES TO RPT127-REC. DTSBR127 00189 I1000-EXIT. DTSBR127 00190 EXIT. DTSBR127 00191 EJECT DTSBR127 00192 P1000-PROCESS. DTSBR127 00193 MOVE SPACES TO RPT127-REC. DTSBR127 00194 WRITE RPT127-REC AFTER ADVANCING PAGE. DTSBR127 00195 WRITE RPT127-REC AFTER ADVANCING 1. DTSBR127 00196 DTSBR127 00197 MOVE R127-FEIN TO WS-FEINX. DTSBR127 00198 MOVE WS-FEINA TO WS-FEINAA. DTSBR127 00199 MOVE WS-FEINB TO WS-FEINBB. DTSBR127 00200 DTSBR127 00201 MOVE R127-EMP-NO TO WS-EMP-NO-A. DTSBR127 00202 MOVE WS-EMP-NO-A TO WS-EMP-NO. DTSBR127 00203 WRITE RPT127-REC FROM WS-LINE-1 DTSBR127 00204 * AFTER ADVANCING 13. DTSBR127 00205 AFTER ADVANCING 9. DTSBR127 00206 DTSBR127 00207 MOVE R127-ENTITY-NAME TO WS-ENTITY. DTSBR127 00208 MOVE R127-PRIMARY-NAME TO WS-PRIMARY. DTSBR127 00209 WRITE RPT127-REC FROM WS-LINE-2 DTSBR127 00210 AFTER ADVANCING 23. DTSBR127 00211 DTSBR127 00212 * IF R127-STREET-ADDRESS = SPACES DTSBR127 00213 * MOVE 4 TO SKIP-CNT DTSBR127 00214 * ELSE DTSBR127 00215 MOVE 2 TO SKIP-CNT DTSBR127 00216 * IF R127-STREET-ATTN-LINE = SPACES DTSBR127 00217 MOVE R127-STREET-ATTN-LINE TO WS-ST-ATTN DTSBR127 00218 MOVE R127-MAILING-ATTN-LINE TO WS-ML-ATTN DTSBR127 00219 WRITE RPT127-REC FROM WS-LINE-3 DTSBR127 00220 AFTER ADVANCING 5. DTSBR127 00221 * END-IF DTSBR127 00222 * IF R127-STREET-DELIV-LINE-1 NOT = SPACES DTSBR127 00223 MOVE R127-STREET-DELIV-LINE-1 TO WS-ST-LN1 DTSBR127 00224 MOVE R127-MAILING-DELIV-LINE-1 TO WS-ML-LN1 DTSBR127 00225 WRITE RPT127-REC FROM WS-LINE-4 DTSBR127 00226 AFTER ADVANCING 1 DTSBR127 00227 * END-IF DTSBR127 00228 MOVE R127-STREET-DELIV-LINE-2 TO WS-ST-LN2 DTSBR127 00229 MOVE R127-MAILING-DELIV-LINE-2 TO WS-ML-LN2 DTSBR127 00230 WRITE RPT127-REC FROM WS-LINE-5 DTSBR127 00231 AFTER ADVANCING 1 DTSBR127 00232 MOVE R127-STREET-CITY TO WS-ST-CITY DTSBR127 00233 MOVE R127-MAILING-CITY TO WS-ML-CITY DTSBR127 00234 MOVE R127-STREET-ST TO WS-ST-ST DTSBR127 00235 MOVE R127-MAILING-ST TO WS-ML-ST DTSBR127 00236 MOVE R127-STREET-ZIP TO WS-ST-ZIP DTSBR127 00237 MOVE R127-MAILING-ZIP TO WS-ML-ZIP DTSBR127 00238 WRITE RPT127-REC FROM WS-LINE-6 DTSBR127 00239 AFTER ADVANCING 1. DTSBR127 00240 DTSBR127 00241 DTSBR127 00242 IF R127-STREET-VOICE-1 = SPACES DTSBR127 00243 MOVE ALL ' ' TO WS-LV DTSBR127 00244 ELSE DTSBR127 00245 MOVE R127-STREET-VOICE-1-AREA-CD TO WS-AREA DTSBR127 00246 MOVE R127-STREET-VOICE-1-PREFIX TO WS-EXCH DTSBR127 00247 MOVE R127-STREET-VOICE-1-SUFFIX TO WS-NUM DTSBR127 00248 IF R127-STREET-VOICE-1-EXT NOT = SPACES DTSBR127 00249 MOVE '-' TO WS-LIT DTSBR127 00250 MOVE R127-STREET-VOICE-1-EXT TO WS-EXT DTSBR127 00251 ELSE DTSBR127 00252 MOVE SPACES TO WS-EXT DTSBR127 00253 WS-LIT DTSBR127 00254 END-IF DTSBR127 00255 MOVE WS-TELEPHONE TO WS-LV. DTSBR127 00256 DTSBR127 00257 WRITE RPT127-REC FROM WS-LINE-7 DTSBR127 00258 AFTER ADVANCING 3. DTSBR127 00259 DTSBR127 00260 IF R127-STREET-FAX = SPACES DTSBR127 00261 MOVE ALL ' ' TO WS-LF DTSBR127 00262 ELSE DTSBR127 00263 MOVE R127-STREET-FAX-AREA-CD TO WS-AREA DTSBR127 00264 MOVE R127-STREET-FAX-PREFIX TO WS-EXCH DTSBR127 00265 MOVE R127-STREET-FAX-SUFFIX TO WS-NUM DTSBR127 00266 IF R127-STREET-FAX-EXT NOT = SPACES DTSBR127 00267 MOVE '-' TO WS-LIT DTSBR127 00268 MOVE R127-STREET-FAX-EXT TO WS-EXT DTSBR127 00269 ELSE DTSBR127 00270 MOVE SPACES TO WS-EXT DTSBR127 00271 WS-LIT DTSBR127 00272 END-IF DTSBR127 00273 MOVE WS-TELEPHONE TO WS-LF. DTSBR127 00274 DTSBR127 00275 WRITE RPT127-REC FROM WS-LINE-8 DTSBR127 00276 AFTER ADVANCING 1. DTSBR127 00277 DTSBR127 00278 IF R127-MAILING-VOICE-1 = SPACES DTSBR127 00279 MOVE ALL ' ' TO WS-MV DTSBR127 00280 ELSE DTSBR127 00281 MOVE R127-MAILING-VOICE-1-AREA-CD TO WS-AREA DTSBR127 00282 MOVE R127-MAILING-VOICE-1-PREFIX TO WS-EXCH DTSBR127 00283 MOVE R127-MAILING-VOICE-1-SUFFIX TO WS-NUM DTSBR127 00284 IF R127-MAILING-VOICE-1-EXT NOT = SPACES DTSBR127 00285 MOVE '-' TO WS-LIT DTSBR127 00286 MOVE R127-MAILING-VOICE-1-EXT TO WS-EXT DTSBR127 00287 ELSE DTSBR127 00288 MOVE SPACES TO WS-EXT DTSBR127 00289 WS-LIT DTSBR127 00290 END-IF DTSBR127 00291 MOVE WS-TELEPHONE TO WS-MV. DTSBR127 00292 DTSBR127 00293 WRITE RPT127-REC FROM WS-LINE-9 DTSBR127 00294 AFTER ADVANCING 1. DTSBR127 00295 DTSBR127 00296 IF R127-MAILING-FAX = SPACES DTSBR127 00297 MOVE ALL ' ' TO WS-MF DTSBR127 00298 ELSE DTSBR127 00299 MOVE R127-MAILING-FAX-AREA-CD TO WS-AREA DTSBR127 00300 MOVE R127-MAILING-FAX-PREFIX TO WS-EXCH DTSBR127 00301 MOVE R127-MAILING-FAX-SUFFIX TO WS-NUM DTSBR127 00302 IF R127-MAILING-FAX-EXT NOT = SPACES DTSBR127 00303 MOVE '-' TO WS-LIT DTSBR127 00304 MOVE R127-MAILING-FAX-EXT TO WS-EXT DTSBR127 00305 ELSE DTSBR127 00306 MOVE SPACES TO WS-EXT DTSBR127 00307 WS-LIT DTSBR127 00308 END-IF DTSBR127 00309 MOVE WS-TELEPHONE TO WS-MF. DTSBR127 00310 DTSBR127 00311 WRITE RPT127-REC FROM WS-LINE-10 DTSBR127 00312 AFTER ADVANCING 1. DTSBR127 00313 DTSBR127 00314 IF R127-MAILING-EMAIL-ADDRESS = SPACES DTSBR127 00315 MOVE ALL ' ' TO WS-EMAIL DTSBR127 00316 ELSE DTSBR127 00317 MOVE R127-MAILING-EMAIL-ADDRESS TO WS-EMAIL. DTSBR127 00318 DTSBR127 00319 WRITE RPT127-REC FROM WS-LINE-11 DTSBR127 00320 AFTER ADVANCING 1. DTSBR127 00321 DTSBR127 00322 DTSBR127 00323 P1000-EXIT. DTSBR127 00324 EXIT. DTSBR127 00325 EJECT DTSBR127 00326 T1000-TERMINATE. DTSBR127 00327 DTSBR127 00328 CLOSE RPT127R1. DTSBR127 00329 DTSBR127 00330 T1000-EXIT. DTSBR127 00331 EXIT. DTSBR127 00332 EJECT DTSBR127 00333 S999-ABEND. DTSBR127 00334 DTSBR127 00335 CALL 'DTSBU999' USING WRK-ABEND-CD. DTSBR127 00336 DTSBR127 00337 S999-EXIT. DTSBR127 00338 EXIT. DTSBR127