00001  IDENTIFICATION DIVISION.                                         09/09/98
00002  PROGRAM-ID.             DTSCU825.                                DTSCU825
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV002
00004  DATE-WRITTEN.           NOVEMBER 1991.                           DTSCU825
00005  DATE-COMPILED.                                                   DTSCU825
00006      SKIP3                                                        DTSCU825
00007 *****                                                             DTSCU825
00008 *                                                                 DTSCU825
00009 *    FUNCTION:  ONLINE ACTIVITY FILE OUTPUT                       DTSCU825
00010 *                                                                 DTSCU825
00011 *                                                                 DTSCU825
00012 *    MODIFICATION LOG:                                            DTSCU825
00013 *                                                                 DTSCU825
00014 *    11/13/91  INITIAL DEVELOPMENT.                               DTSCU825
00015 *              WORK ORDER:                      PROGRAMMER: TCL   DTSCU825
00016 *                                                                 DTSCU825
00017 *    04/06/94  MODIFIED FOR MONTANA.                              DTSCU825
00018 *              WORK ORDER:                      PROGRAMMER: EHH   DTSCU825
00019 *                                                                 DTSCU825
00020 *    09/09/1998  REVIEWED AND MODIFIED FOR DC.                       CL**2
00021 *                REFERENCE: DC DEVELOPMENT      PROGRAMMER: EHH      CL**2
00022 *                                                                    CL**2
00023 *    MM/DD/YYYY  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**2
00024 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**2
00025 *                REFERENCE: XXXXXXXXXXXXXXX     PROGRAMMER: XXX      CL**2
00026 *                                                                 DTSCU825
00027 *                                                                 DTSCU825
00028 *    DESCRIPTION:                                                 DTSCU825
00029 *                                                                 DTSCU825
00030 *        DTSCU825 WRITES VARIABLE LENGTH RECORDS TO THE              CL**2
00031 *        ON-LINE ACTIVITY FILE.  DTSCU825'S COMMAREA CONSIST OF      CL**2
00032 *        DTSIL825, FOLLOWED BY DTSIRSK3. SEE DFHCOMMAREA             CL**2
00033 *        OF THIS MODULE FOR AN EXAMPLE.                           DTSCU825
00034 *                                                                 DTSCU825
00035 *        ACTUALLY, DTSIRSK1 OR DTSIRSK2 MAY BE SUBSITITUED FOR       CL**2
00036 *        DTSIRSK3 IN THE LINKING MODULE. USE OF DTSIRSK1 OR          CL**2
00037 *        DTSIRSK2 IN THE LINKING MODULE (RATHER THAN DTSIRSK3)       CL**2
00038 *        WILL RESULT IN A SHORTER LINKING MODULE WORKING          DTSCU825
00039 *        STORAGE AREA.                                            DTSCU825
00040 *                                                                 DTSCU825
00041 *        PRIOR TO THE LINK TO DTSIL825, THE LINKING MODULE           CL**2
00042 *        MUST CALCULATE L825-LENGTH.  L825-LENGTH =               DTSCU825
00043 *        L825-CB-LENGTH + R***-LENGTH.                            DTSCU825
00044 *                                                                 DTSCU825
00045 *    GENERAL SPECIFICATIONS:                                      DTSCU825
00046 *                                                                 DTSCU825
00047 *        IF AN INVALID COMMAND IS REQUESTED, THEN ABEND THE       DTSCU825
00048 *        MODULE.                                                  DTSCU825
00049 *                                                                 DTSCU825
00050 *        IF THE WRITE COMMAND YIELDS A RESPONSE OTHER THAN        DTSCU825
00051 *        NORMAL, NOTOPEN, OR DISABLED, THEN ABEND THE MODULE.     DTSCU825
00052 *                                                                 DTSCU825
00053 *        RSK3-REC IS THE RECORD TO BE WRITTEN.                    DTSCU825
00054 *                                                                 DTSCU825
00055 *        RSK3-LENGTH IS THE LENGTH OF THE RECORD TO BE WRITTEN.   DTSCU825
00056 *        IF RSK3-LENGTH IS LESS THAN RLEN-MIN-LENGTH OR           DTSCU825
00057 *        RSK3-LENGTH IS GREATER THAN RLEN-MAX-LENGTH, THEN        DTSCU825
00058 *        ABEND THE MODULE.                                        DTSCU825
00059 *                                                                 DTSCU825
00060 *        DTS*OLA IS A VSAM ESDS. A VSAM ESDS WRITE COMMAND           CL**2
00061 *        RETURNS THE RELATIVE BYTE ADDRESS (RBA) OF THE RECORD    DTSCU825
00062 *        IN RIDFLD.  SPECIFY RIDFLD (WRK-RBA).                    DTSCU825
00063 *                                                                 DTSCU825
00064 *                                                                 DTSCU825
00065 *****                                                             DTSCU825
00066      SKIP3                                                        DTSCU825
00067  ENVIRONMENT DIVISION.                                            DTSCU825
00068      SKIP3                                                        DTSCU825
00069  DATA DIVISION.                                                   DTSCU825
00070      SKIP3                                                        DTSCU825
00071  WORKING-STORAGE SECTION.                                         DTSCU825
000715 77  PAN-VALET PICTURE X(24) VALUE '002DTSCU825  09/09/98'.       DTSCU825
00072      SKIP3                                                        DTSCU825
00073  01  WRK-AREA.                                                    DTSCU825
00074      05  WRK-ABEND-CD                PIC  X(04)  VALUE 'U825'.    DTSCU825
00075      05  WRK-RESP-CD                 PIC S9(08)  COMP.            DTSCU825
00076                                                                      CL**2
00077      05  WRK-PROD-FILE-NAME          PIC  X(08)  VALUE 'DTSFOLA'.    CL**2
00078                                                                      CL**2
00079      05  EMSG-NOT-AVAILABLE.                                      DTSCU825
00080          10  FILLER                  PIC  X(04)  VALUE 'E091'.    DTSCU825
00081          10  FILLER                  PIC  X(06)  VALUE 'FILE  '.  DTSCU825
00082          10  EMSG-FILE-NAME          PIC  X(08).                  DTSCU825
00083          10  FILLER                  PIC  X(33)                   DTSCU825
00084        VALUE '  NOT AVAILABLE  PLEASE TRY LATER'.                 DTSCU825
00085      05  WRK-FILE-NAME               PIC  X(08).                  DTSCU825
00086                                                                      CL**2
00087      05  WRK-RBA                     PIC S9(08)  COMP.            DTSCU825
00088      EJECT                                                        DTSCU825
00089  01  RLEN-LITERALS.                                               DTSCU825
00090  ++INCLUDE DTSIRLEN                                                  CL**2
00091      EJECT                                                        DTSCU825
00092  LINKAGE SECTION.                                                 DTSCU825
00093      SKIP3                                                        DTSCU825
00094  01  DFHCOMMAREA.                                                 DTSCU825
00095      05  L825-CONTROL-BLOCK.                                      DTSCU825
00096  ++INCLUDE DTSIL825                                                  CL**2
00097      SKIP3                                                        DTSCU825
00098      05  RSK3-REC.                                                DTSCU825
00099  ++INCLUDE DTSIRSK3                                                  CL**2
00100      EJECT                                                        DTSCU825
00101  PROCEDURE DIVISION.                                              DTSCU825
00102                                                                      CL**2
00103      MOVE WRK-PROD-FILE-NAME TO WRK-FILE-NAME.                       CL**2
00104                                                                      CL**2
00105      MOVE SPACES TO L825-MSG-AREA.                                DTSCU825
00106                                                                      CL**2
00107      SET L825-OK-88 TO TRUE.                                      DTSCU825
00108                                                                      CL**2
00109      IF L825-WRITE-88                                             DTSCU825
00110          PERFORM P3100-WRITE THRU P3100-EXIT                      DTSCU825
00111      ELSE                                                         DTSCU825
00112          PERFORM S899-ABEND THRU S899-EXIT.                       DTSCU825
00113                                                                      CL**2
00114                                                                      CL**2
00115      EXEC CICS                                                    DTSCU825
00116          RETURN                                                   DTSCU825
00117      END-EXEC.                                                    DTSCU825
00118                                                                      CL**2
00119                                                                      CL**2
00120                                                                      CL**2
00121      GOBACK.                                                      DTSCU825
00122      EJECT                                                        DTSCU825
00123  P3100-WRITE.                                                     DTSCU825
00124      PERFORM S2300-CHECK-LENGTH THRU S2300-EXIT.                  DTSCU825
00125                                                                      CL**2
00126      EXEC CICS                                                    DTSCU825
00127          WRITE                                                    DTSCU825
00128              DATASET (WRK-FILE-NAME)                              DTSCU825
00129              FROM (RSK3-REC)                                      DTSCU825
00130              LENGTH (RSK3-LENGTH)                                 DTSCU825
00131              RIDFLD (WRK-RBA)                                     DTSCU825
00132              RBA                                                  DTSCU825
00133              RESP (WRK-RESP-CD)                                   DTSCU825
00134      END-EXEC.                                                    DTSCU825
00135                                                                      CL**2
00136      IF WRK-RESP-CD = DFHRESP (DISABLED) OR DFHRESP (NOTOPEN)     DTSCU825
00137                         OR DFHRESP (SYSIDERR)                     DTSCU825
00138          PERFORM S1100-NOT-AVAILABLE THRU S1100-EXIT              DTSCU825
00139          GO TO P3100-EXIT.                                        DTSCU825
00140                                                                      CL**2
00141      IF WRK-RESP-CD = DFHRESP (NORMAL)                            DTSCU825
00142          NEXT SENTENCE                                            DTSCU825
00143      ELSE                                                         DTSCU825
00144          PERFORM S899-ABEND THRU S899-EXIT.                       DTSCU825
00145  P3100-EXIT.                                                      DTSCU825
00146      EXIT.                                                        DTSCU825
00147      EJECT                                                        DTSCU825
00148  S1100-NOT-AVAILABLE.                                             DTSCU825
00149      MOVE WRK-FILE-NAME TO EMSG-FILE-NAME.                        DTSCU825
00150                                                                      CL**2
00151      MOVE EMSG-NOT-AVAILABLE TO L825-MSG-AREA.                    DTSCU825
00152                                                                      CL**2
00153      SET L825-FILE-CLOSED-88 TO TRUE.                             DTSCU825
00154  S1100-EXIT.                                                      DTSCU825
00155      EXIT.                                                        DTSCU825
00156      EJECT                                                        DTSCU825
00157  S2300-CHECK-LENGTH.                                              DTSCU825
00158      IF RSK3-LENGTH IS GREATER THAN RLEN-MAX-LENGTH               DTSCU825
00159      OR RSK3-LENGTH IS LESS THAN    RLEN-MIN-LENGTH               DTSCU825
00160          PERFORM S899-ABEND THRU S899-EXIT.                       DTSCU825
00161  S2300-EXIT.                                                      DTSCU825
00162      EXIT.                                                        DTSCU825
00163      EJECT                                                        DTSCU825
00164  S899-ABEND.                                                      DTSCU825
00165                                                                      CL**2
00166      EXEC CICS                                                    DTSCU825
00167          ABEND                                                    DTSCU825
00168              ABCODE (WRK-ABEND-CD)                                DTSCU825
00169      END-EXEC.                                                    DTSCU825
00170                                                                      CL**2
00171  S899-EXIT.                                                       DTSCU825
00172      EXIT.                                                        DTSCU825
