00001  IDENTIFICATION DIVISION.                                         10/30/07
00002  PROGRAM-ID.             DTSBU601.                                DTSBU601
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV001
00004  DATE-WRITTEN.           FEBRUARY 1999.                           DTSBU601
00005  DATE-COMPILED.                                                   DTSBU601
00006      SKIP3                                                        DTSBU601
00007 *****                                                             DTSBU601
00008 *                                                                 DTSBU601
00009 *    FUNCTION:  FIND ULTIMATE SUCCESSOR ACCOUNT.                  DTSBU601
00010 *               UNLIKE DTSBU600, THIS PROGRAM FINDS NON-RATING    DTSBU601
00011 *               SUCCESSORS AS WELL AS RATING SUCCESSORS.          DTSBU601
00012 *               IT IS USED IN PROCESSING ELECTRONIC REPORTS       DTSBU601
00013 *               AND FOR CHARGE STATEMENTS.                        DTSBU601
00014 *                                                                 DTSBU601
00015 *    MODIFICATION LOG:                                            DTSBU601
00016 *                                                                 DTSBU601
00017 *    11/03/2005  INITIAL DEVELOPMENT.                             DTSBU601
00018 *                WORK ORDER:                      PROGRAMMER: GD  DTSBU601
00019 *                                                                 DTSBU601
00020 *    XX/XX/XXXX  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU601
00021 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU601
00022 *                WORK ORDER:                      PROGRAMMER: XXX DTSBU601
00023 *                                                                 DTSBU601
00024 *                                                                 DTSBU601
00025 *    DESCRIPTION:                                                 DTSBU601
00026 *                                                                 DTSBU601
00027 *    SCAN THE IPES RECORDS LOOKING FOR THE ULTIMATE SUCCESSOR     DTSBU601
00028 *    ACCOUNT RELATED TO THE EMPLOYER NUMBER PASSED.               DTSBU601
00029 *                                                                 DTSBU601
00030 *    FIRST LOOK FOR AN IPES RECORD FOR THE EMPLOYER.  IF ONE      DTSBU601
00031 *    EXISTS, READ THE IPES RECORDS LOOKING FOR THE NEXT           DTSBU601
00032 *    SUCCESSOR.                                                   DTSBU601
00033 *                                                                 DTSBU601
00034 *    IF THE SEARCH FINDS MORE THAN 100 SUCCESSORS, IT RETURNS     DTSBU601
00035 *    WITH AN ERROR CODE.                                          DTSBU601
00036 *                                                                 DTSBU601
00037 *    IF L600-EXP-TRN-EFF-DATE CONTAINS A VALID DATE, THE PROGRAM  DTSBU601
00038 *    WILL IGNORE CHANGES OF OWNERSHIP THAT OCCURRED AFTER THIS    DTSBU601
00039 *    DATE.  THE PARAMETER IS NORMALLY SET TO ALL NINES, AND       DTSBU601
00040 *    IGNORED.  IT IS ONLY USED IN SPECIAL SITUATIONS WHERE IT IS  DTSBU601
00041 *    NECESSARY TO RECREATE THE CHARGE HISTORY REPORTED FOR A      DTSBU601
00042 *    PRIOR RATING YEAR.                                           DTSBU601
00043 *                                                                 DTSBU601
00044 *****                                                             DTSBU601
00045      SKIP3                                                        DTSBU601
00046  ENVIRONMENT DIVISION.                                            DTSBU601
00047      SKIP3                                                        DTSBU601
00048  DATA DIVISION.                                                   DTSBU601
00049      SKIP3                                                        DTSBU601
00050  WORKING-STORAGE SECTION.                                         DTSBU601
000505 77  PAN-VALET PICTURE X(24) VALUE '001DTSBU601  10/30/07'.       DTSBU601
00051      SKIP3                                                        DTSBU601
00052  01  WRK-AREA.                                                    DTSBU601
00053      05  WRK-ABEND-CODE              PIC S9(04)  COMP             DTSBU601
00054                                                  VALUE +600.      DTSBU601
00055                                                                   DTSBU601
00056      05  WRK-MAX-CNT                 PIC S9(04)  COMP             DTSBU601
00057                                                  VALUE +100.      DTSBU601
00058                                                                   DTSBU601
00059      05  WRK-EMP-NO                  PIC S9(07)  COMP-3.          DTSBU601
00060      05  WRK-SUCCESSOR               PIC S9(07)  COMP-3.          DTSBU601
00061      05  WRK-EFF-DATE                PIC S9(09)  COMP-3.          DTSBU601
00062                                                                   DTSBU601
00063 *  THE FOLLOWING FIELD USED FOR SPECIAL RUNS THAT EXCLUDE         DTSBU601
00064 *  EXPERIENCE TRANSFERS PAST A CERTAIN DATE.                      DTSBU601
00065      05  WRK-END-DATE                PIC S9(09)  COMP-3.          DTSBU601
00066                                                                   DTSBU601
00067      05  WRK-SEARCH-IND              PIC  X(01).                  DTSBU601
00068          88  WRK-START-SEARCH-88  VALUE '0'.                      DTSBU601
00069          88  WRK-SEARCH-ENDED-88  VALUE '1'.                      DTSBU601
00070                                                                   DTSBU601
00071      05  WRK-SUCCESSOR-IND           PIC  X(01).                  DTSBU601
00072          88  WRK-SUCCESSOR-YES-88 VALUE 'Y'.                      DTSBU601
00073          88  WRK-SUCCESSOR-NO-88  VALUE 'N'.                      DTSBU601
00074                                                                   DTSBU601
00075      05  WRK-ERROR-IND               PIC  X(01).                  DTSBU601
00076          88  WRK-ERROR-YES-88     VALUE 'Y'.                      DTSBU601
00077          88  WRK-ERROR-NO-88      VALUE 'N'.                      DTSBU601
00078                                                                   DTSBU601
00079      05  WRK-IPES-CNT                PIC S9(04)  COMP.            DTSBU601
00080                                                                   DTSBU601
00081      EJECT                                                        DTSBU601
00082  01  L001-LINK-AREA.                                              DTSBU601
00083  ++INCLUDE DTSIL001                                               DTSBU601
00084      SKIP3                                                        DTSBU601
00085  01  L921-LINK-AREA.                                              DTSBU601
00086  ++INCLUDE DTSIL921                                               DTSBU601
00087      SKIP3                                                        DTSBU601
00088  01  ISKL-REC.                                                    DTSBU601
00089  ++INCLUDE DTSIISKL                                               DTSBU601
00090      SKIP3                                                        DTSBU601
00091  01  IPES-REC.                                                    DTSBU601
00092  ++INCLUDE DTSIIPES                                               DTSBU601
00093      EJECT                                                        DTSBU601
00094  LINKAGE SECTION.                                                 DTSBU601
00095      SKIP3                                                        DTSBU601
00096  01  L600-LINK-AREA.                                              DTSBU601
00097  ++INCLUDE DTSIL600                                               DTSBU601
00098      EJECT                                                        DTSBU601
00099  PROCEDURE DIVISION                                               DTSBU601
00100      USING L600-LINK-AREA.                                        DTSBU601
00101                                                                   DTSBU601
00102  DTSBU601-MAIN.                                                   DTSBU601
00103      MOVE ZERO      TO L600-ULTIMATE-SUCCESSOR                    DTSBU601
00104                        WRK-SUCCESSOR                              DTSBU601
00105                        WRK-EFF-DATE                               DTSBU601
00106                        WRK-IPES-CNT.                              DTSBU601
00107                                                                   DTSBU601
00108      SET WRK-START-SEARCH-88  TO TRUE.                            DTSBU601
00109                                                                   DTSBU601
00110      MOVE L600-EMP-NO         TO WRK-EMP-NO.                      DTSBU601
00111                                                                   DTSBU601
00112      PERFORM I1000-END-DATE   THRU I1000-EXIT.                    DTSBU601
00113                                                                   DTSBU601
00114      PERFORM P1000-FIND-SUCCESSOR THRU P1000-EXIT                 DTSBU601
00115         UNTIL WRK-SEARCH-ENDED-88.                                DTSBU601
00116                                                                   DTSBU601
00117      IF WRK-ERROR-YES-88                                          DTSBU601
00118         SET L600-ERROR-88 TO TRUE                                 DTSBU601
00119      ELSE                                                         DTSBU601
00120      IF WRK-SUCCESSOR = ZERO                                      DTSBU601
00121         SET L600-NO-SUCCESSOR-88 TO TRUE                          DTSBU601
00122      ELSE                                                         DTSBU601
00123         MOVE WRK-SUCCESSOR TO L600-ULTIMATE-SUCCESSOR             DTSBU601
00124         SET L600-SUCCESSOR-FOUND-88 TO TRUE.                      DTSBU601
00125                                                                   DTSBU601
00126  DTSBU601-MAIN-EXIT.                                              DTSBU601
00127      GOBACK.                                                      DTSBU601
00128      EJECT                                                        DTSBU601
00129  I1000-END-DATE.                                                  DTSBU601
00130      IF L600-EXP-TRN-EFF-DATE NOT NUMERIC                         DTSBU601
00131         MOVE 99999999                 TO WRK-END-DATE             DTSBU601
00132      ELSE                                                         DTSBU601
00133         MOVE L600-EXP-TRN-EFF-DATE    TO L001-FED-8-DATE-9        DTSBU601
00134         PERFORM S001-FROM-FED-8       THRU S001-EXIT              DTSBU601
00135         IF L001-VALID-DATE                                        DTSBU601
00136            MOVE L600-EXP-TRN-EFF-DATE TO WRK-END-DATE             DTSBU601
00137         ELSE                                                      DTSBU601
00138            MOVE 99999999              TO WRK-END-DATE.            DTSBU601
00139                                                                   DTSBU601
00140  I1000-EXIT. EXIT.                                                DTSBU601
00141                                                                   DTSBU601
00142  P1000-FIND-SUCCESSOR.                                            DTSBU601
00143      MOVE LOW-VALUE         TO IPES-KEY-AREA.                     DTSBU601
00144      MOVE WRK-EMP-NO        TO IPES-PRED-EMP-NO.                  DTSBU601
00145      SET IPES-PES-88        TO TRUE.                              DTSBU601
00146      MOVE IPES-KEY-AREA     TO ISKL-KEY-AREA.                     DTSBU601
00147                                                                   DTSBU601
00148      PERFORM S921-START-BROWSE THRU S921-EXIT.                    DTSBU601
00149      IF L921-NO-REC-88                                            DTSBU601
00150         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00151         GO TO P1000-EXIT.                                         DTSBU601
00152                                                                   DTSBU601
00153      ADD +1 TO WRK-IPES-CNT.                                      DTSBU601
00154      IF WRK-IPES-CNT > WRK-MAX-CNT                                DTSBU601
00155         SET WRK-ERROR-YES-88    TO TRUE                           DTSBU601
00156         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00157         GO TO P1000-EXIT.                                         DTSBU601
00158                                                                   DTSBU601
00159      MOVE ISKL-REC               TO IPES-REC.                     DTSBU601
00160                                                                   DTSBU601
00161      IF IPES-PRED-EMP-NO NOT =   WRK-EMP-NO                       DTSBU601
00162         SET WRK-SEARCH-ENDED-88  TO TRUE                          DTSBU601
00163         GO TO P1000-EXIT.                                         DTSBU601
00164                                                                   DTSBU601
00165      IF IPES-EFF-DATE > WRK-END-DATE                              DTSBU601
00166         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00167         GO TO P1000-EXIT                                          DTSBU601
00168      ELSE                                                         DTSBU601
00169         IF IPES-EFF-DATE NOT < WRK-EFF-DATE                       DTSBU601
00170            MOVE IPES-EFF-DATE TO WRK-EFF-DATE                     DTSBU601
00171            MOVE IPES-SUC-EMP-NO TO WRK-EMP-NO                     DTSBU601
00172                                    WRK-SUCCESSOR                  DTSBU601
00173            GO TO P1000-EXIT                                       DTSBU601
00174         END-IF                                                    DTSBU601
00175      END-IF.                                                      DTSBU601
00176                                                                   DTSBU601
00177      SET WRK-SUCCESSOR-NO-88 TO TRUE.                             DTSBU601
00178      PERFORM P1100-SCAN-IPES THRU P1100-EXIT                      DTSBU601
00179         UNTIL WRK-SUCCESSOR-YES-88                                DTSBU601
00180         OR    WRK-SEARCH-ENDED-88.                                DTSBU601
00181                                                                   DTSBU601
00182  P1000-EXIT. EXIT.                                                DTSBU601
00183                                                                   DTSBU601
00184  P1100-SCAN-IPES.                                                 DTSBU601
00185      PERFORM S921-READ-NEXT THRU S921-EXIT.                       DTSBU601
00186      IF L921-NO-REC-88                                            DTSBU601
00187         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00188         GO TO P1100-EXIT                                          DTSBU601
00189      END-IF.                                                      DTSBU601
00190                                                                   DTSBU601
00191      ADD +1 TO WRK-IPES-CNT.                                      DTSBU601
00192      IF WRK-IPES-CNT > WRK-MAX-CNT                                DTSBU601
00193         SET WRK-ERROR-YES-88    TO TRUE                           DTSBU601
00194         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00195         GO TO P1100-EXIT                                          DTSBU601
00196      END-IF.                                                      DTSBU601
00197                                                                   DTSBU601
00198      MOVE ISKL-REC               TO IPES-REC.                     DTSBU601
00199      IF IPES-PRED-EMP-NO NOT = WRK-EMP-NO                         DTSBU601
00200         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00201         GO TO P1100-EXIT                                          DTSBU601
00202      END-IF.                                                      DTSBU601
00203                                                                   DTSBU601
00204      IF IPES-EFF-DATE > WRK-END-DATE                              DTSBU601
00205         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU601
00206         GO TO P1100-EXIT                                          DTSBU601
00207      ELSE                                                         DTSBU601
00208         IF IPES-EFF-DATE NOT < WRK-EFF-DATE                       DTSBU601
00209            SET WRK-SUCCESSOR-YES-88 TO TRUE                       DTSBU601
00210            MOVE IPES-EFF-DATE TO WRK-EFF-DATE                     DTSBU601
00211            MOVE IPES-SUC-EMP-NO TO WRK-EMP-NO                     DTSBU601
00212                                    WRK-SUCCESSOR                  DTSBU601
00213         END-IF                                                    DTSBU601
00214      END-IF.                                                      DTSBU601
00215                                                                   DTSBU601
00216  P1100-EXIT. EXIT.                                                DTSBU601
00217      EJECT                                                        DTSBU601
00218  S001-FROM-FED-8.                                                 DTSBU601
00219      SET L001-FROM-FED-8 TO TRUE.                                 DTSBU601
00220      GO TO S001-DATE.                                             DTSBU601
00221                                                                   DTSBU601
00222  S001-DATE.                                                       DTSBU601
00223      CALL 'DTSBU001' USING L001-LINK-AREA.                        DTSBU601
00224  S001-EXIT. EXIT.                                                 DTSBU601
00225                                                                   DTSBU601
00226  S921-START-BROWSE.                                               DTSBU601
00227      SKIP1                                                        DTSBU601
00228      SET L921-START-BROWSE-88 TO TRUE.                            DTSBU601
00229      GO TO S921-AIX-IO.                                           DTSBU601
00230                                                                   DTSBU601
00231  S921-READ-NEXT.                                                  DTSBU601
00232      SKIP1                                                        DTSBU601
00233      SET L921-READ-NEXT-88 TO TRUE.                               DTSBU601
00234      GO TO S921-AIX-IO.                                           DTSBU601
00235                                                                   DTSBU601
00236  S921-AIX-IO.                                                     DTSBU601
00237      CALL 'DTSBU921'                                              DTSBU601
00238          USING L921-LINK-AREA                                     DTSBU601
00239                ISKL-REC.                                          DTSBU601
00240      SKIP1                                                        DTSBU601
00241  S921-EXIT. EXIT.                                                 DTSBU601
00242      SKIP3                                                        DTSBU601
00243  S999-ABEND.                                                      DTSBU601
00244      SKIP1                                                        DTSBU601
00245      CALL 'DTSBU999'                                              DTSBU601
00246          USING WRK-ABEND-CODE.                                    DTSBU601
00247      SKIP1                                                        DTSBU601
00248  S999-EXIT. EXIT.                                                 DTSBU601
