-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathEDUPGM.cbl
154 lines (128 loc) · 6.67 KB
/
EDUPGM.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
*----------------------------------------------------------------*
* 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 *
*----------------------------------------------------------------*
* AUTHOR : Giovanni Creato/Italy/IBM *
* DATE : 16 / 04 / 2016 *
* VERSION : 1.1 *
* HISTORY : *
* 16/06/16 Moved 01 level DFHCOMMAREA to EDUCPY *
*----------------------------------------------------------------*
* Description *
* *
* This program defines different types of COBOL data and can be *
* used to understand different COBOL data types *
* *
*----------------------------------------------------------------*
TITLE 'Sample program that treats different types of COBOL data'
IDENTIFICATION DIVISION.
PROGRAM-ID. "EDUPGM".
Author. "Giovanni Creato/Italy/IBM".
DATE-WRITTEN. 20/11/2014.
*----------------------------------------------------------------*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-zSeries WITH DEBUGGING MODE.
*SOURCE-COMPUTER. IBM-zSeries.
*----------------------------------------------------------------*
DATA DIVISION.
*----------------------------------------------------------------*
WORKING-STORAGE SECTION.
01 Program-Description.
03 NN.
05 pic x(10) value 'EDUPGM : '.
01 WS-VARIABLES.
03 DISPLAYABLE-NUMERIC PIC -z(3)9.
03 REQUIRED-CA-LEN PIC S9(4) VALUE +0.
03 VALID-INPUT-PARAMETERS PIC X.
88 VALID-INPUT-PARAMETERS-FALSE value X'00'.
88 VALID-INPUT-PARAMETERS-TRUE value X'01' through X'FF'.
03 Switches.
05 Switch-condition Pic X value space.
88 Switch-condition-1 value "A".
88 Switch-condition-2 value "B".
LINKAGE SECTION.
COPY EDUCPY.
*----------------------------------------------------------------*
PROCEDURE DIVISION.
MAIN-PROGRAM section.
D DISPLAY NN 'Starting'
PERFORM INPUT-PARAMETER-CHECK.
if VALID-INPUT-PARAMETERS-TRUE then
PERFORM BUSINESS-LOGIC
else
MOVE -1 TO RESULT-CODE
MOVE 'INVALID INPUT PARAMETERS'
TO RESULT-TEXT
end-if.
D MOVE RESULT-CODE TO DISPLAYABLE-NUMERIC.
D DISPLAY NN 'Returning with RESULT-CODE : '
D DISPLAYABLE-NUMERIC.
PERFORM END-PROGRAM.
INPUT-PARAMETER-CHECK section.
* If NO commarea received issue an ABEND
IF EIBCALEN IS EQUAL TO ZERO
DISPLAY NN 'NO COMMAREA RECEIVED. ABENDING THE TASK'
EXEC CICS ABEND ABCODE('LENG') NODUMP END-EXEC
END-IF
* Compute partial LENGTH
D MOVE ZERO TO REQUIRED-CA-LEN
D ADD LENGTH OF BINARY-DIGIT TO REQUIRED-CA-LEN
D ADD LENGTH OF CHARACTER-STRING TO REQUIRED-CA-LEN
D ADD LENGTH OF NUMERIC-STRING TO REQUIRED-CA-LEN
D ADD LENGTH OF PACKED-DIGIT TO REQUIRED-CA-LEN
D MOVE REQUIRED-CA-LEN TO DISPLAYABLE-NUMERIC
D DISPLAY NN 'PARTIAL SUM IS : ' DISPLAYABLE-NUMERIC
D ADD LENGTH OF SIGNED-PACKED TO REQUIRED-CA-LEN
D MOVE REQUIRED-CA-LEN TO DISPLAYABLE-NUMERIC
D DISPLAY NN 'PARTIAL SUM IS : ' DISPLAYABLE-NUMERIC
D ADD LENGTH OF BOOL TO REQUIRED-CA-LEN
D ADD LENGTH OF RESULT-CODE TO REQUIRED-CA-LEN
D MOVE REQUIRED-CA-LEN TO DISPLAYABLE-NUMERIC
D DISPLAY NN 'PARTIAL SUM IS : ' DISPLAYABLE-NUMERIC
D ADD LENGTH OF RESULT-TEXT TO REQUIRED-CA-LEN
D MOVE REQUIRED-CA-LEN TO DISPLAYABLE-NUMERIC
D DISPLAY NN 'PARTIAL SUM IS : ' DISPLAYABLE-NUMERIC
* if COMMAREA is less then required issue an ABEND
MOVE LENGTH OF DATA-PAYLOAD TO REQUIRED-CA-LEN
D MOVE REQUIRED-CA-LEN TO DISPLAYABLE-NUMERIC
D DISPLAY NN 'MINIMUM COMMAREA LENGTH IS : '
DISPLAYABLE-NUMERIC
IF EIBCALEN IS LESS THAN REQUIRED-CA-LEN
MOVE EIBCALEN TO DISPLAYABLE-NUMERIC
DISPLAY NN 'COMMAREA SHORTER THAN : ' DISPLAYABLE-NUMERIC
'. ABEND THE TASK'
EXEC CICS ABEND ABCODE('GCCO') NODUMP END-EXEC
END-IF
* Clean result area
MOVE ZERO TO RESULT-CODE
MOVE SPACES TO RESULT-TEXT
Set VALID-INPUT-PARAMETERS-TRUE to True.
* NOTE BINARY-DIGIT cannot be controlled
if CHARACTER-STRING IS NOT ALPHABETIC then
D DISPLAY NN 'CHARACTER-STRING IS NOT ALPHABETIC'
Set VALID-INPUT-PARAMETERS-FALSE to TRUE.
if NUMERIC-STRING IS NOT NUMERIC then
D DISPLAY NN 'NUMERIC-STRING IS NOT NUMERIC'
Set VALID-INPUT-PARAMETERS-FALSE to TRUE.
if PACKED-DIGIT IS NOT NUMERIC then
D DISPLAY NN 'PACKED-DIGIT IS NOT NUMERIC'
Set VALID-INPUT-PARAMETERS-FALSE to TRUE.
if SIGNED-PACKED IS NOT NUMERIC then
D DISPLAY NN 'SIGNED-PACKED IS NOT NUMERIC'
Set VALID-INPUT-PARAMETERS-FALSE to TRUE.
if BOOL IS NOT NUMERIC then
D DISPLAY NN 'BOOL IS NOT NUMERIC'
Set VALID-INPUT-PARAMETERS-FALSE to TRUE.
BUSINESS-LOGIC section.
D DISPLAY NN 'Performing Business Logic'.
MOVE ZERO TO RESULT-CODE.
MOVE 'PARAMETERS ARE ALL OK'
TO RESULT-TEXT.
END-PROGRAM section.
D DISPLAY NN 'Performing END-PROGRAM'.
EXEC CICS RETURN END-EXEC.