00001  IDENTIFICATION DIVISION.                                         09/30/98
00002  PROGRAM-ID.             DTSBU947.                                DTSBU947
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV002
00004  DATE-WRITTEN.           DECEMBER 1991.                           DTSBU947
00005  DATE-COMPILED.                                                   DTSBU947
00006      SKIP3                                                        DTSBU947
00007 *****                                                             DTSBU947
00008 *                                                                 DTSBU947
00009 *    FUNCTION:  VARIABLE LENGTH RECORD (FILE 2) OUTPUT.           DTSBU947
00010 *                                                                 DTSBU947
00011 *                                                                 DTSBU947
00012 *    MODIFICATION LOG:                                            DTSBU947
00013 *                                                                 DTSBU947
00014 *    12/18/91  INITIAL DEVELOPMENT.                               DTSBU947
00015 *              WORK ORDER:                      PROGRAMMER: TCL   DTSBU947
00016 *                                                                 DTSBU947
00017 *    XX/XX/XX  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSBU947
00018 *              XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   DTSBU947
00019 *              WORK ORDER:                      PROGRAMMER: XXX   DTSBU947
00020 *                                                                 DTSBU947
00021 *                                                                 DTSBU947
00022 *    DESCRIPTION:                                                 DTSBU947
00023 *                                                                 DTSBU947
00024 *        DTSBU947 WRITES REPORT RECORDS TO DTSFVRO2.                 CL**2
00025 *                                                                 DTSBU947
00026 *                                                                 DTSBU947
00027 *****                                                             DTSBU947
00028      SKIP3                                                        DTSBU947
00029  ENVIRONMENT DIVISION.                                            DTSBU947
00030      SKIP2                                                        DTSBU947
00031  INPUT-OUTPUT SECTION.                                            DTSBU947
00032                                                                      CL**2
00033  FILE-CONTROL.                                                    DTSBU947
00034      SELECT VAR-FILE ASSIGN TO DTSFVRO2                              CL**2
00035          FILE STATUS IS FILE-STATUS.                              DTSBU947
00036      SKIP3                                                        DTSBU947
00037  DATA DIVISION.                                                   DTSBU947
00038      SKIP3                                                        DTSBU947
00039  FILE SECTION.                                                    DTSBU947
00040      SKIP3                                                        DTSBU947
00041  FD  VAR-FILE                                                     DTSBU947
00042      RECORDING MODE IS V                                          DTSBU947
00043      BLOCK CONTAINS 0 RECORDS.                                    DTSBU947
00044                                                                      CL**2
00045  01  FILE-REC.                                                    DTSBU947
00046  ++INCLUDE DTSIRVAR                                                  CL**2
00047      EJECT                                                        DTSBU947
00048  WORKING-STORAGE SECTION.                                         DTSBU947
000485 77  PAN-VALET PICTURE X(24) VALUE '002DTSBU947  09/30/98'.       DTSBU947
00049      SKIP3                                                        DTSBU947
00050  01  WRK-AREA.                                                    DTSBU947
00051      05  WRK-ABEND-CD                PIC S9(04)  COMP  VALUE +947.DTSBU947
00052                                                                      CL**2
00053      05  FIRST-TIME-IND              PIC  X(01)  VALUE 'Y'.       DTSBU947
00054                                                                      CL**2
00055      05  VAR-CHAR-CNT                PIC S9(04)  COMP.            DTSBU947
00056                                                                      CL**2
00057      05  WRK-REC-CNT                 PIC S9(07)  COMP-3.          DTSBU947
00058                                                                      CL**2
00059      05  FILE-STATUS                 PIC  X(02).                  DTSBU947
00060          88  FILE-OK-88                     VALUE '00'.           DTSBU947
00061      EJECT                                                        DTSBU947
00062  01  RLEN-LENGTH-LITERALS.                                        DTSBU947
00063  ++INCLUDE DTSIRLEN                                                  CL**2
00064      EJECT                                                        DTSBU947
00065  LINKAGE SECTION.                                                 DTSBU947
00066      SKIP3                                                        DTSBU947
00067  01  LINK-REC.                                                    DTSBU947
00068  ++INCLUDE DTSIRVAR                                                  CL**2
00069      EJECT                                                        DTSBU947
00070  PROCEDURE DIVISION USING LINK-REC.                               DTSBU947
00071                                                                      CL**2
00072                                                                      CL**2
00073      IF FIRST-TIME-IND = 'Y'                                      DTSBU947
00074          PERFORM P1000-OPEN THRU P1000-EXIT                       DTSBU947
00075          MOVE +0 TO WRK-REC-CNT                                   DTSBU947
00076          MOVE 'N' TO FIRST-TIME-IND.                              DTSBU947
00077                                                                      CL**2
00078      IF RVAR-LENGTH OF LINK-REC = -1                              DTSBU947
00079          DISPLAY '*** '                                           DTSBU947
00080                  WRK-REC-CNT                                      DTSBU947
00081                  ' DTSFVRO2 RECORDS WRITTEN'                         CL**2
00082          PERFORM P2000-CLOSE THRU P2000-EXIT                      DTSBU947
00083      ELSE                                                         DTSBU947
00084      IF RVAR-LENGTH OF LINK-REC < RLEN-MIN-LENGTH                 DTSBU947
00085                 OR                                                DTSBU947
00086         RVAR-LENGTH OF LINK-REC > RLEN-MAX-LENGTH                 DTSBU947
00087          PERFORM S999-ABEND THRU S999-EXIT                        DTSBU947
00088      ELSE                                                         DTSBU947
00089          COMPUTE VAR-CHAR-CNT = RVAR-LENGTH OF LINK-REC - 2       DTSBU947
00090          MOVE LINK-REC TO FILE-REC                                DTSBU947
00091          PERFORM P3000-WRITE THRU P3000-EXIT                      DTSBU947
00092          ADD +1 TO WRK-REC-CNT.                                   DTSBU947
00093                                                                      CL**2
00094                                                                      CL**2
00095      GOBACK.                                                      DTSBU947
00096      EJECT                                                        DTSBU947
00097  P1000-OPEN.                                                      DTSBU947
00098      OPEN OUTPUT VAR-FILE.                                        DTSBU947
00099                                                                      CL**2
00100      IF FILE-OK-88                                                DTSBU947
00101          NEXT SENTENCE                                            DTSBU947
00102      ELSE                                                         DTSBU947
00103          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBU947
00104  P1000-EXIT.                                                      DTSBU947
00105      EXIT.                                                        DTSBU947
00106      SKIP3                                                        DTSBU947
00107  P2000-CLOSE.                                                     DTSBU947
00108      CLOSE VAR-FILE.                                              DTSBU947
00109                                                                      CL**2
00110      IF FILE-OK-88                                                DTSBU947
00111          NEXT SENTENCE                                            DTSBU947
00112      ELSE                                                         DTSBU947
00113          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBU947
00114  P2000-EXIT.                                                      DTSBU947
00115      EXIT.                                                        DTSBU947
00116      SKIP3                                                        DTSBU947
00117  P3000-WRITE.                                                     DTSBU947
00118      WRITE FILE-REC.                                              DTSBU947
00119                                                                      CL**2
00120      IF FILE-OK-88                                                DTSBU947
00121          NEXT SENTENCE                                            DTSBU947
00122      ELSE                                                         DTSBU947
00123          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBU947
00124  P3000-EXIT.                                                      DTSBU947
00125      EXIT.                                                        DTSBU947
00126      EJECT                                                        DTSBU947
00127  S999-ABEND.                                                      DTSBU947
00128      DISPLAY '*** I/O MODULE ABENDING'.                           DTSBU947
00129                                                                      CL**2
00130      DISPLAY '*** FILE-STATUS = ' FILE-STATUS.                    DTSBU947
00131                                                                      CL**2
00132      CALL 'DTSBU999' USING WRK-ABEND-CD.                             CL**2
00133  S999-EXIT.                                                       DTSBU947
00134      EXIT.                                                        DTSBU947
