DUTAS re-platformed to Raincode - Initial Source Code
This commit is contained in:
Neeraj Kumar
108
CICS/DTSCU898.cob
Normal file
108
CICS/DTSCU898.cob
Normal file
@ -0,0 +1,108 @@
|
||||
00001 IDENTIFICATION DIVISION. 08/11/98
|
||||
00002 PROGRAM-ID. DTSCU898 DTSCU898
|
||||
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV004
|
||||
00004 DATE-WRITTEN. NOVEMBER 1991. DTSCU898
|
||||
00005 DATE-COMPILED. DTSCU898
|
||||
00006 SKIP3 DTSCU898
|
||||
00007 ***** DTSCU898
|
||||
00008 * DTSCU898
|
||||
00009 * FUNCTION: DELETE ALL TEMPORARY STORAGE QUEUES ASSOCIATED DTSCU898
|
||||
00010 * WITH THE PSEUDO CONVERSATION. DTSCU898
|
||||
00011 * DTSCU898
|
||||
00012 * DTSCU898
|
||||
00013 * MODIFICATION LOG: DTSCU898
|
||||
00014 * DTSCU898
|
||||
00015 * 11/05/91 INITIAL DEVELOPMENT. DTSCU898
|
||||
00016 * WORK ORDER: PROGRAMMER: TCL DTSCU898
|
||||
00017 * DTSCU898
|
||||
00018 * 08/11/1998 REVIEWED AND MODIFIED FOR DC. CL**2
|
||||
00019 * REFERENCE: DC DEVELOPMENT PROGRAMMER: EHH CL**2
|
||||
00020 * CL**2
|
||||
00021 * MM/DD/YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2
|
||||
00022 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**2
|
||||
00023 * REFERENCE: XXXXXXXXXXXXXX PROGRAMMER: XXX CL**2
|
||||
00024 * DTSCU898
|
||||
00025 * DTSCU898
|
||||
00026 * DESCRIPTION: DTSCU898
|
||||
00027 * DTSCU898
|
||||
00028 * WHEN A PSEUDO CONVERSATION IS INITIATED, A PSEUDO DTSCU898
|
||||
00029 * CONVERSATION IS TERMINATED OR DURING ABEND PROCESSING DTSCU898
|
||||
00030 * ALL TEMPORARY STORAGE AREAS ASSOCIATED WITH THE PSEUDO DTSCU898
|
||||
00031 * CONVERSATION MUST BE DELETED. DTSCU898
|
||||
00032 * DTSCU898
|
||||
00033 * DTSCU898 DELETES ALL POSSIBLE TEMPORARY STORAGE AREAS. CL**2
|
||||
00034 * IF CERTAIN AREAS DO NOT EXIST IN A PARTICULAR PSEUDO DTSCU898
|
||||
00035 * CONVERSATION, THEN THE DELETE YIELDS A QIDERR. THE QIDERR DTSCU898
|
||||
00036 * IS SIMPLY TOLERATED. DTSCU898
|
||||
00037 * DTSCU898
|
||||
00038 * IF TEMPORARY STORAGE AREA NAMES ARE ADDED ANYWHERE IN THE DTSCU898
|
||||
00039 * COMPLEX OF MODULES CONSTITUTING CICS TRANSACTION 'DTS', THEN CL**2
|
||||
00040 * THE NEW TEMPORARY STORAGE AREA NAMES SHOULD BE ADDED TO THIS DTSCU898
|
||||
00041 * MODULE. DTSCU898
|
||||
00042 * DTSCU898
|
||||
00043 * IN PARTICULAR, THIS MODULE ASSUMES THAT CHARACTER ONE THRU DTSCU898
|
||||
00044 * CHARACTER THREE OF A TS QUEUE NAME IS EQUAL TO 'DTS' AND THAT CL**2
|
||||
00045 * CHARACTER FOUR THRU CHARACTER SEVEN OF A TS QUEUE NAME IS EQUDTSCU898
|
||||
00046 * TO EIBTRMID. IF THESE ASSUMPTIONS BECOME INVALID, THEN THIS DTSCU898
|
||||
00047 * MODULE MUST BE MOFIFIED. DTSCU898
|
||||
00048 * DTSCU898
|
||||
00049 ***** DTSCU898
|
||||
00050 SKIP3 DTSCU898
|
||||
00051 ENVIRONMENT DIVISION. DTSCU898
|
||||
00052 SKIP3 DTSCU898
|
||||
00053 DATA DIVISION. DTSCU898
|
||||
00054 SKIP3 DTSCU898
|
||||
00055 WORKING-STORAGE SECTION. DTSCU898
|
||||
000555 77 PAN-VALET PICTURE X(24) VALUE '004DTSCU898 08/11/98'. DTSCU898
|
||||
00056 SKIP3 DTSCU898
|
||||
00057 01 WRK-AREA. DTSCU898
|
||||
00058 05 WRK-RESP-CD PIC S9(08) COMP. DTSCU898
|
||||
00059 SKIP3 DTSCU898
|
||||
00060 05 WRK-CNT PIC S9(04) COMP VALUE +6. DTSCU898
|
||||
00061 CL**2
|
||||
00062 05 WRK-QUEUE-NAME-SUFFIX-LITERALS. DTSCU898
|
||||
00063 10 FILLER PIC X(06) DTSCU898
|
||||
00064 VALUE 'SPE123'. DTSCU898
|
||||
00065 05 FILLER REDEFINES WRK-QUEUE-NAME-SUFFIX-LITERALS. DTSCU898
|
||||
00066 10 WRK-QUEUE-NAME-SUFFIX-LITERAL OCCURS 6 TIMES DTSCU898
|
||||
00067 INDEXED BY WRK-IDX DTSCU898
|
||||
00068 PIC X(01). DTSCU898
|
||||
00069 01 L829-AREA. DTSCU898
|
||||
00070 ++INCLUDE DTSIL829 CL**2
|
||||
00071 EJECT DTSCU898
|
||||
00072 PROCEDURE DIVISION. DTSCU898
|
||||
00073 SKIP2 DTSCU898
|
||||
00074 *****MOVE L829-CONTROL-BLOCK-LENGTH TO L829-COMM-AREA-LENGTH. CL**2
|
||||
00075 CL**2
|
||||
00076 SET L829-DELETE-QUEUE-88 TO TRUE. CL**4
|
||||
00077 CL**2
|
||||
00078 MOVE +0 TO L829-ITEM-NO DTSCU898
|
||||
00079 L829-REC-LENGTH. DTSCU898
|
||||
00080 CL**2
|
||||
00081 SET L829-DEFAULT-STORAGE-88 TO TRUE. DTSCU898
|
||||
00082 CL**2
|
||||
00083 MOVE 'DTS' TO L829-QUEUE-NAME-PREFIX (1:3). CL**2
|
||||
00084 CL**2
|
||||
00085 MOVE EIBTRMID TO L829-QUEUE-NAME-PREFIX (4:4). DTSCU898
|
||||
00086 CL**2
|
||||
00087 PERFORM P1000-DELETE-QUEUE THRU P1000-EXIT DTSCU898
|
||||
00088 VARYING WRK-IDX FROM 1 BY 1 DTSCU898
|
||||
00089 UNTIL WRK-IDX > WRK-CNT. DTSCU898
|
||||
00090 CL**2
|
||||
00091 EXEC CICS DTSCU898
|
||||
00092 RETURN DTSCU898
|
||||
00093 END-EXEC. DTSCU898
|
||||
00094 SKIP2 DTSCU898
|
||||
00095 GOBACK. DTSCU898
|
||||
00096 EJECT DTSCU898
|
||||
00097 P1000-DELETE-QUEUE. DTSCU898
|
||||
00098 MOVE WRK-QUEUE-NAME-SUFFIX-LITERAL (WRK-IDX) DTSCU898
|
||||
00099 TO L829-QUEUE-NAME-SUFFIX. DTSCU898
|
||||
00100 CL**2
|
||||
00101 EXEC CICS DTSCU898
|
||||
00102 LINK DTSCU898
|
||||
00103 PROGRAM ('DTSCU829') CL**2
|
||||
00104 COMMAREA (L829-AREA) DTSCU898
|
||||
00105 END-EXEC. DTSCU898
|
||||
00106 P1000-EXIT. DTSCU898
|
||||
00107 EXIT. DTSCU898
|
||||
Reference in New Issue
Block a user