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
