DUTAS re-platformed to Raincode - Initial Source Code
This commit is contained in:
Neeraj Kumar
173
CICS/DTSCU825.cob
Normal file
173
CICS/DTSCU825.cob
Normal file
@ -0,0 +1,173 @@
|
||||
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
|
||||
Reference in New Issue
Block a user