-
Notifications
You must be signed in to change notification settings - Fork 11
/
EDUCHAN.cbl
172 lines (143 loc) · 6.67 KB
/
EDUCHAN.cbl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
*----------------------------------------------------------------*
* Licensed Materials - Property of IBM *
* SAMPLE *
* (c) Copyright IBM Corp. 2016 All Rights Reserved *
* US Government Users Restricted Rights - Use, duplication or *
* disclosure restricted by GSA ADP Schedule Contract with *
* IBM Corp *
*----------------------------------------------------------------*
******************************************************************
* *
* Module Name EDUCHAN.CBL *
* Version 1.0 *
* Date 22/10/2016 *
* *
* CICS back-end channel/container sample *
* *
* This program expects to be invoked with a CHAR container named *
* INPUTDATA and returns the following containers: *
* A CHAR container containing the reversed input string *
* A CHAR container containing the time *
* A BIT container containing the CICS return code from reading *
* the input container *
******************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. EDUCHAN.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
DATA DIVISION.
WORKING-STORAGE SECTION.
* Container name declarations
* Channel and container names are case sensitive
01 DATE-CONT PIC X(16) VALUE 'CICSTIME'.
01 INPUT-CONT PIC X(16) VALUE 'INPUTDATA'.
01 OUTPUT-CONT PIC X(16) VALUE 'OUTPUTDATA'.
01 LENGTH-CONT PIC X(16) VALUE 'INPUTDATALENGTH'.
01 ERROR-CONT PIC X(16) VALUE 'ERRORDATA'.
01 RESP-CONT PIC X(16) VALUE 'CICSRC'.
* Data fields used by the program
01 INPUTLENGTH PIC S9(8) COMP-4.
01 DATALENGTH PIC S9(8) COMP-4.
01 CURRENTTIME PIC S9(15) COMP-3.
01 ABENDCODE PIC X(4) VALUE SPACES.
01 CHANNELNAME PIC X(16) VALUE SPACES.
01 INPUTSTRING PIC X(72) VALUE SPACES.
01 OUTPUTSTRING PIC X(72) VALUE SPACES.
01 RESPCODE PIC S9(8) COMP-4 VALUE 0.
01 RESPCODE2 PIC S9(8) COMP-4 VALUE 0.
01 DATE-TIME.
03 DATESTRING PIC X(10) VALUE SPACES.
03 TIME-SEP PIC X(1) VALUE SPACES.
03 TIMESTRING PIC X(8) VALUE SPACES.
01 RC-RECORD PIC S9(8) COMP-4 VALUE 0.
01 ERR-RECORD.
03 ERRORCMD PIC X(16) VALUE SPACES.
03 ERRORSTRING PIC X(32) VALUE SPACES.
PROCEDURE DIVISION.
* -----------------------------------------------------------
MAIN-PROCESSING SECTION.
* -----------------------------------------------------------
* Get name of channel
EXEC CICS ASSIGN CHANNEL(CHANNELNAME)
END-EXEC.
* If no channel passed in, terminate with abend code NOCH
IF CHANNELNAME = SPACES THEN
MOVE 'NOCH' TO ABENDCODE
PERFORM ABEND-ROUTINE
END-IF.
* Read content and length of input container
MOVE LENGTH OF INPUTSTRING TO INPUTLENGTH.
EXEC CICS GET CONTAINER(INPUT-CONT)
CHANNEL(CHANNELNAME)
FLENGTH(INPUTLENGTH)
INTO(INPUTSTRING)
RESP(RESPCODE)
RESP2(RESPCODE2)
END-EXEC.
* Place RC in binary container for return to caller
MOVE RESPCODE TO RC-RECORD.
EXEC CICS PUT CONTAINER(RESP-CONT)
FROM(RC-RECORD)
FLENGTH(LENGTH OF RC-RECORD)
BIT
RESP(RESPCODE)
END-EXEC.
IF RESPCODE NOT = DFHRESP(NORMAL)
PERFORM RESP-ERROR
END-IF.
* Place reversed string in output container
MOVE FUNCTION REVERSE(INPUTSTRING) TO OUTPUTSTRING.
EXEC CICS PUT CONTAINER(OUTPUT-CONT)
FROM(OUTPUTSTRING)
FLENGTH(LENGTH OF OUTPUTSTRING)
CHAR
RESP(RESPCODE)
END-EXEC.
IF RESPCODE NOT = DFHRESP(NORMAL)
PERFORM RESP-ERROR
END-IF.
* Get the current time
EXEC CICS ASKTIME ABSTIME(CURRENTTIME)
END-EXEC.
* Format date and time
EXEC CICS FORMATTIME
ABSTIME(CURRENTTIME)
DDMMYYYY(DATESTRING)
DATESEP('/')
TIME(TIMESTRING)
TIMESEP(':')
RESP(RESPCODE)
END-EXEC.
* Check return code
IF RESPCODE NOT = DFHRESP(NORMAL)
STRING 'Failed' DELIMITED BY SIZE
INTO DATESTRING END-STRING
END-IF.
* Place current date in container CICSTIME
EXEC CICS PUT CONTAINER(DATE-CONT)
FROM(DATE-TIME)
FLENGTH(LENGTH OF DATE-TIME)
CHAR
RESP(RESPCODE)
END-EXEC.
* Check return code
IF RESPCODE NOT = DFHRESP(NORMAL)
PERFORM RESP-ERROR
END-IF.
* Return back to caller
PERFORM END-PGM.
* -----------------------------------------------------------
RESP-ERROR.
MOVE 'EDUC' TO ABENDCODE
PERFORM ABEND-ROUTINE.
PERFORM END-PGM.
* -----------------------------------------------------------
* Abnormal end
* -----------------------------------------------------------
ABEND-ROUTINE.
EXEC CICS ABEND ABCODE(ABENDCODE) END-EXEC.
* -----------------------------------------------------------
* Finish
* -----------------------------------------------------------
END-PGM.
EXEC CICS RETURN END-EXEC.