MFmainframe-rea
WS carddemo · 26f629ef

cobol · 2098 lines · sha256 916a5fe2279ad626 · guides at columns 7 and 72app/app-transaction-type-db2/cbl/COTRTLIC.cbl

1000100*****************************************************************
2000200* Program: COTRTLIC.CBL *
3000300* Layer: Business logic *
4000400* Function: List Transaction Type for updates and deletes *
5000500* Demonstrates paging with cursors in Db2 *
6000600* and Simple, select, delete and update use cases *
7000700*****************************************************************
8000800* Copyright Amazon.com, Inc. or its affiliates.
9000900* All Rights Reserved.
10001000*
11001100* Licensed under the Apache License, Version 2.0 (the "License").
12001200* You may not use this file except in compliance with the License.
13001300* You may obtain a copy of the License at
14001400*
15001500* http://www.apache.org/licenses/LICENSE-2.0
16001600*
17001700* Unless required by applicable law or agreed to in writing,
18001800* software distributed under the License is distributed on an
19001900* "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
20002000* either express or implied. See the License for the specific
21002100* language governing permissions and limitations under the License
22002200******************************************************************
23002300
24002400 IDENTIFICATION DIVISION.
25002500 PROGRAM-ID.
26002600 COTRTLIC.
27002700 DATE-WRITTEN.
28002800 Jan 2023.
29002900 DATE-COMPILED.
30003000 Today.
31003100
32003200 ENVIRONMENT DIVISION.
33003300 INPUT-OUTPUT SECTION.
34003400
35003500 DATA DIVISION.
36003600
37003700 WORKING-STORAGE SECTION.
38003800
39003900******************************************************************
40004000* Literals and Constants
41004100******************************************************************
42004200 01 WS-CONSTANTS.
43004300 05 LIT-THISPGM PIC X(8) VALUE 'COTRTLIC'.
44004400 05 LIT-THISTRANID PIC X(4) VALUE 'CTLI'.
45004500 05 LIT-THISMAPSET PIC X(7) VALUE 'COTRTLI'.
46004600 05 LIT-THISMAP PIC X(7) VALUE 'CTRTLIA'.
47004700 05 LIT-ADMINPGM PIC X(8) VALUE 'COADM01C'.
48004800 05 LIT-ADMINTRANID PIC X(4) VALUE 'CA00'.
49004900 05 LIT-ADMINMAPSET PIC X(7) VALUE 'COADM01'.
50005000 05 LIT-ADDTPGM PIC X(8) VALUE 'COTRTUPC'.
51005100 05 LIT-ADDTTRANID PIC X(4) VALUE 'CTTU'.
52005200 05 LIT-ADDTMAPSET PIC X(7) VALUE 'COTRTUP'.
53005300 05 LIT-ADDTMAP PIC X(7) VALUE 'CTRTUPA'.
54005400 05 LIT-DSNTIAC PIC X(7) VALUE 'DSNTIAC'.
55005500 05 LIT-ASTERISK PIC X(7) VALUE '*'.
56005600 05 LIT-TRANTYPE-TABLE PIC X(30) VALUE
57005700 'TRANSACTION_TYPE '.
58005800 05 LIT-DELETE-FLAG PIC X(1) VALUE 'D'.
59005900 05 LIT-UPDATE-FLAG PIC X(1) VALUE 'U'.
60006000 05 WS-MAX-SCREEN-LINES PIC S9(4) COMP VALUE 7.
61006100
62006200******************************************************************
63006300* Literals for use in INSPECT statements
64006400******************************************************************
65006500 05 LIT-ALL-ALPHANUM-FROM-X.
66006600 10 LIT-ALL-ALPHA-FROM-X.
67006700 15 LIT-UPPER PIC X(26)
68006800 VALUE 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
69006900 15 LIT-LOWER PIC X(26)
70007000 VALUE 'abcdefghijklmnopqrstuvwxyz'.
71007100 10 LIT-NUMBERS PIC X(10)
72007200 VALUE '0123456789'.
73007300
74007400******************************************************************
75007500* Variables for use in INSPECT statements
76007600******************************************************************
77007700 01 LIT-ALL-ALPHA-FROM PIC X(52) VALUE SPACES.
78007800 01 LIT-ALL-ALPHANUM-FROM PIC X(62) VALUE SPACES.
79007900 01 LIT-ALL-NUM-FROM PIC X(10) VALUE SPACES.
80008000 77 LIT-ALPHA-SPACES-TO PIC X(52) VALUE SPACES.
81008100 77 LIT-ALPHANUM-SPACES-TO PIC X(62) VALUE SPACES.
82008200 77 LIT-NUM-SPACES-TO PIC X(10) VALUE SPACES.
83008300
84008400 01 WS-MISC-STORAGE.
85008500******************************************************************
86008600* General CICS related
87008700******************************************************************
88008800
89008900 05 WS-CICS-PROCESSNG-VARS.
90009000 07 WS-RESP-CD PIC S9(9) COMP VALUE ZEROS.
91009100 07 WS-REAS-CD PIC S9(9) COMP VALUE ZEROS.
92009200 07 WS-TRANID PIC X(4) VALUE SPACES.
93009300
94009400
95009500******************************************************************
96009600* Input edits
97009700******************************************************************
98009800 05 WS-INPUT-FLAG PIC X(1).
99009900 88 INPUT-OK VALUES '0'
100010000 ' '
101010100 LOW-VALUES.
102010200 88 INPUT-ERROR VALUE '1'.
103010300 05 WS-EDIT-TYPE-FLAG PIC X(1).
104010400 88 FLG-TYPEFILTER-NOT-OK VALUE '0'.
105010500 88 FLG-TYPEFILTER-ISVALID VALUE '1'.
106010600 88 FLG-TYPEFILTER-BLANK VALUE ' '.
107010700 05 WS-EDIT-DESC-FLAG PIC X(1).
108010800 88 FLG-DESCFILTER-NOT-OK VALUE '0'.
109010900 88 FLG-DESCFILTER-ISVALID VALUE '1'.
110011000 88 FLG-DESCFILTER-BLANK VALUE ' '.
111011100 05 WS-TYPEFILTER-CHANGED PIC X(1).
112011200 88 FLG-TYPEFILTER-CHANGED-NO VALUE LOW-VALUES.
113011300 88 FLG-TYPEFILTER-CHANGED-YES VALUE 'Y'.
114011400 05 WS-DESCFILTER-CHANGED PIC X(1).
115011500 88 FLG-DESCFILTER-CHANGED-NO VALUE LOW-VALUES.
116011600 88 FLG-DESCFILTER-CHANGED-YES VALUE 'Y'.
117011700 05 WS-ROW-RECORDS-CHANGED PIC X(01)
118011800 OCCURS 7 TIMES.
119011900 88 FLG-ROW-DESCR-CHANGED-NO VALUE LOW-VALUES.
120012000 88 FLG-ROW-DESCR-CHANGED-YES VALUE 'Y'.
121012100 05 WS-DELETE-STATUS PIC X(1).
122012200 88 FLG-DELETED-NO VALUE LOW-VALUES.
123012300 88 FLG-DELETED-YES VALUE 'Y'.
124012400 05 WS-UPDATE-STATUS PIC X(1).
125012500 88 FLG-UPDATED-NO VALUE LOW-VALUES.
126012600 88 FLG-UPDATE-COMPLETED VALUE 'Y'.
127012700 05 WS-ROW-SELECTION-CHANGED PIC X(1).
128012800 88 FLG-ROW-SELECTION-CHANGED-NO VALUE LOW-VALUES.
129012900 88 FLG-ROW-SELECTION-CHANGED-YES VALUE 'Y'.
130013000 05 WS-BAD-SELECTION-ACTION PIC X(1).
131013100 88 FLG-BAD-ACTIONS-SELECTED-NO VALUE LOW-VALUES.
132013200 88 FLG-BAD-ACTIONS-SELECTED-YES VALUE 'Y'.
133013300 05 WS-ARRAY-DESCRIPTION-FLGS PIC X(1).
134013400 88 FLG-ROW-DESCRIPTION-ISVALID VALUE LOW-VALUES
135013500 SPACES.
136013600 88 FLG-ROW-DESCRIPTION-NOT-OK VALUE '0'.
137013700 88 FLG-ROW-DESCRIPTION-BLANK VALUE 'B'.
138013800 05 WS-DATACHANGED-FLAG PIC X(1).
139013900 88 NO-CHANGES-FOUND VALUE '0'.
140014000 88 CHANGES-HAVE-OCCURRED VALUE '1'.
141014100
142014200* Generic Input Edits
143014300 05 WS-GENERIC-EDITS.
144014400 10 WS-EDIT-VARIABLE-NAME PIC X(25).
145014500
146014600 10 WS-EDIT-ALPHANUM-ONLY PIC X(256).
147014700 10 WS-EDIT-ALPHANUM-LENGTH PIC S9(4) COMP-3.
148014800
149014900 10 WS-EDIT-ALPHANUM-ONLY-FLAGS PIC X(1).
150015000 88 FLG-ALPHNANUM-ISVALID VALUE LOW-VALUES.
151015100 88 FLG-ALPHNANUM-NOT-OK VALUE '0'.
152015200 88 FLG-ALPHNANUM-BLANK VALUE 'B'.
153015300
154015400 05 WS-OTHER-EDIT-VARS.
155015500 10 WS-RECORDS-COUNT PIC S9(4) COMP-3
156015600 VALUE 0.
157015700
158015800******************************************************************
159015900* Input edits array variables
160016000******************************************************************
161016100******************************************************************
162016200* Screen Data Array 52 CHARS X 7 ROWS = 364
163016300******************************************************************
164016400
165016500 05 WS-SCREEN-DATA-IN.
166016600 10 WS-ALL-ROWS-IN PIC X(364).
167016700 10 FILLER REDEFINES WS-ALL-ROWS-IN.
168016800 15 WS-SCREEN-ROWS-IN OCCURS 7 TIMES.
169016900 20 WS-EACH-ROW-IN.
170017000 25 WS-EACH-TTYP-IN.
171017100 30 WS-ROW-TR-CODE-IN PIC X(02).
172017200 30 WS-ROW-TR-DESC-IN PIC X(50).
173017300
174017400
175017500 05 WS-EDIT-SELECT-COUNTER PIC S9(04)
176017600 USAGE COMP-3
177017700 VALUE 0.
178017800 05 WS-EDIT-SELECT-FLAGS PIC X(7)
179017900 VALUE LOW-VALUES.
180018000 05 FILLER REDEFINES WS-EDIT-SELECT-FLAGS.
181018100 10 WS-EDIT-SELECT PIC X(1)
182018200 OCCURS 7 TIMES.
183018300 88 SELECT-OK VALUES 'D', 'U'.
184018400 88 DELETE-REQUESTED-ON VALUE 'D'.
185018500 88 UPDATE-REQUESTED-ON VALUE 'U'.
186018600 88 SELECT-BLANK VALUES
187018700 ' ',
188018800 LOW-VALUES.
189018900
190019000 05 WS-EDIT-SELECT-ERROR-FLAGS PIC X(7)
191019100 VALUE LOW-VALUES.
192019200 05 FILLER REDEFINES WS-EDIT-SELECT-ERROR-FLAGS.
193019300 10 WS-EDIT-SELECT-ERRORS OCCURS 7 TIMES.
194019400 20 WS-ROW-TRTSELECT-ERROR PIC X(1).
195019500 88 WS-ROW-SELECT-ERROR VALUE '1'.
196019600
197019700 05 WS-SUBSCRIPT-VARS.
198019800 10 I PIC S9(4) COMP
199019900 VALUE 0.
200020000 10 I-SELECTED PIC S9(4) COMP
201020100 VALUE 0.
202020200 05 WS-ACTIONS-SELECTED.
203020300 07 WS-ACTIONS-REQUESTED PIC S9(04)
204020400 USAGE COMP-3
205020500 VALUE 0.
206020600 88 WS-ONLY-1-ACTION VALUE 1.
207020700 88 WS-MORETHAN1ACTION VALUES 2 THRU 7.
208020800 07 WS-DELETES-REQUESTED PIC S9(04)
209020900 USAGE COMP-3
210021000 VALUE 0.
211021100 07 WS-UPDATES-REQUESTED PIC S9(04)
212021200 USAGE COMP-3
213021300 VALUE 0.
214021400 07 WS-NO-ACTIONS-SELECTED PIC S9(04)
215021500 COMP-3
216021600 VALUE 0.
217021700 05 WS-VALID-ACTIONS-SELECTED PIC S9(04)
218021800 USAGE COMP-3
219021900 VALUE 0.
220022000 88 WS-ONLY-1-VALID-ACTION VALUE 1.
221022100
222022200******************************************************************
223022300* Output edits
224022400******************************************************************
225022500 05 CICS-OUTPUT-EDIT-VARS.
226022600 10 TRAN-TYPE-CD-X PIC X(02).
227022700 10 TRAN-TYPE-CD-N REDEFINES TRAN-TYPE-CD-X
228022800 PIC 9(02).
229022900 10 FLG-PROTECT-SELECT-ROWS PIC X(1).
230023000 88 FLG-PROTECT-SELECT-ROWS-NO VALUE '0'.
231023100 88 FLG-PROTECT-SELECT-ROWS-YES VALUE '1'.
232023200******************************************************************
233023300* Output Message Construction
234023400******************************************************************
235023500 05 WS-LONG-MSG PIC X(800).
236023600 05 WS-INFO-MSG PIC X(45).
237023700 88 WS-NO-INFO-MESSAGE VALUES
238023800 SPACES LOW-VALUES.
239023900 88 WS-INFORM-REC-ACTIONS VALUE
240024000 'Type U to update, D to delete any record'.
241024100 88 WS-INFORM-DELETE VALUE
242024200 'Delete HIGHLIGHTED row ? Press F10 to confirm'.
243024300 88 WS-INFORM-UPDATE VALUE
244024400 'Update HIGHLIGHTED row. Press F10 to save'.
245024500 88 WS-INFORM-DELETE-SUCCESS VALUE
246024600 'HIGHLIGHTED row deleted.Hit Enter to continue'.
247024700 88 WS-INFORM-UPDATE-SUCCESS VALUE
248024800 'HIGHLIGHTED row was updated'.
249024900 05 WS-RETURN-MSG PIC X(75).
250025000 88 WS-RETURN-MSG-OFF VALUE SPACES.
251025100 88 WS-EXIT-MESSAGE VALUE
252025200 'PF03 pressed. Exiting'.
253025300 88 WS-MESG-NO-RECORDS-FOUND VALUE
254025400 'No records found for this search condition.'.
255025500 88 WS-MESG-NO-MORE-RECORDS VALUE
256025600 'No more pages for these search conditions'.
257025700 88 WS-MESG-MORE-THAN-1-ACTION VALUE
258025800 'Please select only 1 action'.
259025900 88 WS-MESG-INVALID-ACTION-CODE VALUE
260026000 'Action code selected is invalid'.
261026100 88 WS-MESG-NO-CHANGES-DETECTED VALUE
262026200 'No change detected with respect to database values.'.
263026300 05 WS-PFK-FLAG PIC X(1).
264026400 88 PFK-VALID VALUE '0'.
265026500 88 PFK-INVALID VALUE '1'.
266026600 05 WS-STRING-FORMAT-VARS.
267026700 10 WS-STRING-MID PIC 9(3) VALUE 0.
268026800 10 WS-STRING-LEN PIC 9(3) VALUE 0.
269026900 10 WS-STRING-OUT PIC X(45).
270027000
271027100******************************************************************
272027200* Data Handling
273027300******************************************************************
274027400 05 WS-DATA-FILTERS.
275027500 10 WS-START-KEY PIC X(02).
276027600 10 WS-TYPE-CD-FILTER PIC X(02)
277027700 VALUE SPACES.
278027800 10 WS-TYPE-DESC-FILTER PIC X(52).
279027900 10 WS-TYPE-CD-DELETE-FILTER.
280028000 15 FILLER PIC X(01)
281028100 VALUE '('.
282028200 15 WS-TYPE-CD-DELETE-FILTER-X.
283028300 20 WS-TYPE-CD-DELETE-KEYS OCCURS 7 TIMES.
284028400 25 FILLER PIC X(01)
285028500 VALUE QUOTE.
286028600 25 WS-TYPE-CD-DELETE-KEY PIC X(02)
287028700 VALUE SPACES.
288028800 25 FILLER PIC X(01)
289028900 VALUE QUOTE.
290029000 25 FILLER PIC X(01)
291029100 VALUE ','.
292029200 20 WS-DUMMY.
293029300 25 FILLER PIC X(01)
294029400 VALUE QUOTE.
295029500 25 FILLER PIC X(01)
296029600 VALUE SPACE.
297029700 25 FILLER PIC X(01)
298029800 VALUE QUOTE.
299029900
300030000 15 FILLER PIC X(1)
301030100 VALUE ')'.
302030200
303030300
304030400 EXEC SQL INCLUDE CSDB2RWY END-EXEC
305030500
306030600******************************************************************
307030700* Screen Edit Vars
308030800******************************************************************
309030900 05 WS-SCREEN-EDIT-VARS.
310031000 10 WS-IN-TYPE-CD PIC X(02)
311031100 VALUE SPACES.
312031200 10 WS-IN-TYPE-CD-N REDEFINES WS-IN-TYPE-CD PIC 9(02).
313031300 10 WS-IN-TYPE-DESC PIC X(50).
314031400
315031500******************************************************************
316031600* Screen Array Vars
317031700******************************************************************
318031800 05 WS-ROW-NUMBER PIC S9(4) COMP VALUE 0.
319031900
320032000 05 WS-RECORDS-TO-PROCESS-FLAG PIC X(1).
321032100 88 READ-LOOP-EXIT VALUE '0'.
322032200 88 MORE-RECORDS-TO-READ VALUE '1'.
323032300
324032400******************************************************************
325032500*Other common working storage Variables
326032600******************************************************************
327032700 COPY CVCRD01Y.
328032800******************************************************************
329032900* Relational Database stuff
330033000******************************************************************
331033100 EXEC SQL INCLUDE SQLCA END-EXEC
332033200
333033300 EXEC SQL INCLUDE DCLTRTYP END-EXEC
334033400
335033500******************************************************************
336033600*Cursor Declarations
337033700******************************************************************
338033800 EXEC SQL
339033900 DECLARE C-TR-TYPE-FORWARD CURSOR FOR
340034000 SELECT TR_TYPE
341034100 ,TR_DESCRIPTION
342034200 FROM CARDDEMO.TRANSACTION_TYPE
343034300 WHERE TR_TYPE >= :WS-START-KEY
344034400 AND ((:WS-EDIT-TYPE-FLAG = '1'
345034500 AND TR_TYPE = :WS-TYPE-CD-FILTER)
346034600 OR (:WS-EDIT-TYPE-FLAG <> '1'))
347034700 AND ((:WS-EDIT-DESC-FLAG = '1'
348034800 AND TR_DESCRIPTION LIKE
349034900 TRIM(:WS-TYPE-DESC-FILTER))
350035000 OR (:WS-EDIT-DESC-FLAG <> '1'))
351035100 ORDER BY TR_TYPE
352035200 END-EXEC
353035300
354035400 EXEC SQL
355035500 DECLARE C-TR-TYPE-BACKWARD CURSOR FOR
356035600 SELECT TR_TYPE
357035700 ,TR_DESCRIPTION
358035800 FROM CARDDEMO.TRANSACTION_TYPE
359035900 WHERE TR_TYPE < :WS-START-KEY
360036000 and ((:WS-EDIT-TYPE-FLAG = '1'
361036100 and TR_TYPE = :WS-TYPE-CD-FILTER)
362036200 OR (:WS-EDIT-TYPE-FLAG <> '1'))
363036300 AND ((:WS-EDIT-DESC-FLAG = '1'
364036400 AND TR_DESCRIPTION LIKE
365036500 TRIM(:WS-TYPE-DESC-FILTER))
366036600 OR (:WS-EDIT-DESC-FLAG <> '1'))
367036700 ORDER BY TR_TYPE DESC
368036800 END-EXEC
369036900
370037000
371037100******************************************************************
372037200* Commarea manipulations
373037300******************************************************************
374037400*Application Commmarea Copybook
375037500 COPY COCOM01Y.
376037600
377037700 01 WS-THIS-PROGCOMMAREA.
378037800 10 WS-CA-TYPE-CD PIC X(02)
379037900 VALUE SPACES.
380038000 10 WS-CA-TYPE-CD-N REDEFINES WS-CA-TYPE-CD PIC 9(02).
381038100 10 WS-CA-TYPE-DESC PIC X(50).
382038200
383038300******************************************************************
384038400* Screen Data Array 52 CHARS X 7 ROWS = 364
385038500******************************************************************
386038600 10 FILLER.
387038700 15 WS-CA-ALL-ROWS-OUT PIC X(364).
388038800 15 FILLER REDEFINES WS-CA-ALL-ROWS-OUT.
389038900 20 WS-CA-SCREEN-ROWS-OUT OCCURS 7 TIMES.
390039000 30 WS-CA-EACH-ROW-OUT.
391039100 35 WS-CA-ROW-TR-CODE-OUT PIC X(02).
392039200 35 WS-CA-ROW-TR-DESC-OUT PIC X(50).
393039300
394039400
395039500 10 WS-CA-ROW-SELECTED PIC S9(4) COMP
396039600 VALUE 0.
397039700 10 WS-CA-PAGING-VARIABLES.
398039800 15 WS-CA-LAST-TTYPEKEY.
399039900 20 WS-CA-LAST-TR-CODE PIC X(02).
400040000 15 WS-CA-FIRST-TTYPEKEY.
401040100 20 WS-CA-FIRST-TR-CODE PIC X(02).
402040200
403040300 15 WS-CA-SCREEN-NUM PIC 9(1).
404040400 88 CA-FIRST-PAGE VALUE 1.
405040500 15 WS-CA-LAST-PAGE-DISPLAYED PIC 9(1).
406040600 88 CA-LAST-PAGE-SHOWN VALUE 0.
407040700 88 CA-LAST-PAGE-NOT-SHOWN VALUE 9.
408040800 15 WS-CA-NEXT-PAGE-IND PIC X(1).
409040900 88 CA-NEXT-PAGE-NOT-EXISTS VALUE LOW-VALUES.
410041000 88 CA-NEXT-PAGE-EXISTS VALUE 'Y'.
411041100 10 WS-CA-DELETE-FLAG PIC X.
412041200 88 CA-DELETE-NOT-REQUESTED VALUE LOW-VALUES.
413041300 88 CA-DELETE-REQUESTED VALUE 'Y'.
414041400 88 CA-DELETE-SUCCEEDED VALUE LOW-VALUES.
415041500 10 WS-CA-UPDATE-FLAG PIC X.
416041600 88 CA-UPDATE-NOT-REQUESTED VALUE LOW-VALUES.
417041700 88 CA-UPDATE-REQUESTED VALUE 'Y'.
418041800 88 CA-UPDATE-SUCCEEDED VALUE LOW-VALUES.
419041900
420042000 01 WS-COMMAREA PIC X(2000).
421042100
422042200
423042300
424042400*IBM SUPPLIED COPYBOOKS
425042500 COPY DFHBMSCA.
426042600 COPY DFHAID.
427042700
428042800*COMMON COPYBOOKS
429042900*Screen Titles
430043000 COPY COTTL01Y.
431043100
432043200*Credit Card List Screen Layout
433043300 COPY COTRTLI.
434043400 01 FILLER REDEFINES CTRTLIAI.
435043500 05 FILLER PIC X(238).
436043600 05 WS-ROW-DATAI.
437043700 06 EACH-ROWI OCCURS 7 TIMES.
438043800 07 TRTSELL PIC S9(4) COMP.
439043900 07 TRTSELF PIC X.
440044000 07 FILLER REDEFINES TRTSELF.
441044100 10 TRTSELA PIC X.
442044200 07 FILLER PIC X(4).
443044300 07 TRTSELI PIC X(1).
444044400 07 TRTTYPL PIC S9(4) COMP.
445044500 07 TRTTYPF PIC X.
446044600 07 FILLER REDEFINES TRTTYPF.
447044700 10 TRTTYPA PIC X.
448044800 07 FILLER PIC X(4).
449044900 07 TRTTYPI PIC X(2).
450045000 07 TRTYPDL PIC S9(4) COMP.
451045100 07 TRTYPDF PIC X.
452045200 07 FILLER REDEFINES TRTYPDF.
453045300 10 TRTYPDA PIC X.
454045400 07 FILLER PIC X(4).
455045500 07 TRTYPDI PIC X(50).
456045600 05 FILLER PIC X(137).
457045700 01 FILLER REDEFINES CTRTLIAO.
458045800 05 FILLER PIC X(238).
459045900 05 EACH-ROWO OCCURS 7 TIMES.
460046000 07 FILLER PIC X(3).
461046100 07 TRTSELC PIC X.
462046200 07 TRTSELP PIC X.
463046300 07 TRTSELH PIC X.
464046400 07 TRTSELV PIC X.
465046500 07 TRTSELO PIC X(1).
466046600 07 FILLER PIC X(3).
467046700 07 TRTTYPC PIC X.
468046800 07 TRTTYPP PIC X.
469046900 07 TRTTYPH PIC X.
470047000 07 TRTTYPV PIC X.
471047100 07 TRTTYPO PIC X(2).
472047200 07 FILLER PIC X(3).
473047300 07 TRTYPDC PIC X.
474047400 07 TRTYPDP PIC X.
475047500 07 TRTYPDH PIC X.
476047600 07 TRTYPDV PIC X.
477047700 07 TRTYPDO PIC X(50).
478047800 05 FILLER PIC X(137).
479047900*Current Date
480048000 COPY CSDAT01Y.
481048100*Common Messages
482048200 COPY CSMSG01Y.
483048300
484048400*Signed on user data
485048500 COPY CSUSR01Y.
486048600
487048700*Dataset layouts
488048800
489048900*CARD RECORD LAYOUT
490049000 COPY CVACT02Y.
491049100
492049200 LINKAGE SECTION.
493049300 01 DFHCOMMAREA.
494049400 05 FILLER PIC X(1)
495049500 OCCURS 1 TO 32767 TIMES DEPENDING ON EIBCALEN.
496049600
497049700 PROCEDURE DIVISION.
498049800 0000-MAIN.
499049900
500050000 INITIALIZE CC-WORK-AREA
501050100 WS-MISC-STORAGE
502050200 WS-COMMAREA
503050300
504050400*****************************************************************
505050500* Store our context
506050600*****************************************************************
507050700 MOVE LIT-THISTRANID TO WS-TRANID
508050800*****************************************************************
509050900* Ensure error message is cleared *
510051000*****************************************************************
511051100 SET WS-RETURN-MSG-OFF TO TRUE
512051200*****************************************************************
513051300* Retrieve passed data if any. Initialize them if first run.
514051400*****************************************************************
515051500 IF EIBCALEN = 0
516051600 INITIALIZE CARDDEMO-COMMAREA
517051700 WS-THIS-PROGCOMMAREA
518051800 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
519051900 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
520052000 SET CDEMO-USRTYP-ADMIN TO TRUE
521052100 SET CDEMO-PGM-ENTER TO TRUE
522052200 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
523052300 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
524052400 SET CA-FIRST-PAGE TO TRUE
525052500 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
526052600 ELSE
527052700 MOVE DFHCOMMAREA (1:LENGTH OF CARDDEMO-COMMAREA) TO
528052800 CARDDEMO-COMMAREA
529052900 MOVE DFHCOMMAREA(LENGTH OF CARDDEMO-COMMAREA + 1:
530053000 LENGTH OF WS-THIS-PROGCOMMAREA )TO
531053100 WS-THIS-PROGCOMMAREA
532053200 END-IF
533053300
534053400******************************************************************
535053500* Remap PFkeys as needed.
536053600* Store the Mapped PF Key
537053700*****************************************************************
538053800 PERFORM YYYY-STORE-PFKEY
539053900 THRU YYYY-STORE-PFKEY-EXIT
540054000
541054100*****************************************************************
542054200* If coming in from menu. Lets forget the past and start afresh *
543054300*****************************************************************
544054400 IF (CDEMO-PGM-ENTER
545054500 AND CDEMO-FROM-PROGRAM NOT EQUAL LIT-THISPGM)
546054600 OR ( CCARD-AID-PFK03
547054700 AND CDEMO-FROM-TRANID EQUAL LIT-ADDTTRANID)
548054800 INITIALIZE WS-THIS-PROGCOMMAREA
549054900 SET CDEMO-PGM-ENTER TO TRUE
550055000 SET CCARD-AID-ENTER TO TRUE
551055100 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
552055200 SET CA-FIRST-PAGE TO TRUE
553055300 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
554055400 END-IF
555055500
556055600******************************************************************
557055700* If something is present in commarea
558055800* and the from program is this program itself,
559055900* read and edit the inputs given
560056000*****************************************************************
561056100 IF EIBCALEN > 0
562056200 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
563056300 PERFORM 1000-RECEIVE-MAP
564056400 THRU 1000-RECEIVE-MAP-EXIT
565056500
566056600 END-IF
567056700*****************************************************************
568056800* Check the mapped key to see if its valid at this point *
569056900* F3 - Exit
570057000* Enter - List of cards for current start key
571057100* F8 - Page down
572057200* F7 - Page up
573057300*****************************************************************
574057400 SET PFK-INVALID TO TRUE
575057500 IF CCARD-AID-ENTER OR
576057600 CCARD-AID-PFK02 OR
577057700 CCARD-AID-PFK03 OR
578057800 CCARD-AID-PFK07 OR
579057900 CCARD-AID-PFK08 OR
580058000 (CCARD-AID-PFK10 AND CA-DELETE-REQUESTED) OR
581058100 (CCARD-AID-PFK10 AND CA-UPDATE-REQUESTED)
582058200 SET PFK-VALID TO TRUE
583058300 END-IF
584058400
585058500 IF PFK-INVALID
586058600 SET CCARD-AID-ENTER TO TRUE
587058700 END-IF
588058800*****************************************************************
589058900* If the user pressed PF3 go back to main menu
590059000*****************************************************************
591059100 IF CCARD-AID-PFK03
592059200 IF CDEMO-FROM-TRANID EQUAL LOW-VALUES
593059300 OR CDEMO-FROM-TRANID EQUAL SPACES
594059400 OR CDEMO-FROM-TRANID EQUAL LIT-THISTRANID
595059500 MOVE LIT-ADMINTRANID TO CDEMO-TO-TRANID
596059600 ELSE
597059700 MOVE CDEMO-FROM-TRANID TO CDEMO-TO-TRANID
598059800 END-IF
599059900
600060000 IF CDEMO-FROM-PROGRAM EQUAL LOW-VALUES
601060100 OR CDEMO-FROM-PROGRAM EQUAL SPACES
602060200 OR CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
603060300 MOVE LIT-ADMINPGM TO CDEMO-TO-PROGRAM
604060400 ELSE
605060500 MOVE CDEMO-FROM-PROGRAM TO CDEMO-TO-PROGRAM
606060600 END-IF
607060700
608060800 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
609060900 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
610061000
611061100 SET CDEMO-USRTYP-ADMIN TO TRUE
612061200 SET CDEMO-PGM-ENTER TO TRUE
613061300 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
614061400 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
615061500
616061600 EXEC CICS
617061700 SYNCPOINT
618061800 END-EXEC
619061900*
620062000 EXEC CICS XCTL
621062100 PROGRAM (CDEMO-TO-PROGRAM)
622062200 COMMAREA(CARDDEMO-COMMAREA)
623062300 END-EXEC
624062400
625062500 END-IF
626062600
627062700*****************************************************************
628062800* If the user pressed PF2 transfer to add screen
629062900*****************************************************************
630063000 IF (CCARD-AID-PFK02
631063100 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM)
632063200 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
633063300 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
634063400 SET CDEMO-USRTYP-USER TO TRUE
635063500 SET CDEMO-PGM-ENTER TO TRUE
636063600 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
637063700 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
638063800 MOVE LIT-ADDTPGM TO CDEMO-TO-PROGRAM
639063900
640064000 MOVE LIT-ADDTMAPSET TO CCARD-NEXT-MAPSET
641064100 MOVE LIT-ADDTMAP TO CCARD-NEXT-MAP
642064200 SET WS-EXIT-MESSAGE TO TRUE
643064300
644064400* CALL MENU PROGRAM
645064500*
646064600 SET CDEMO-PGM-ENTER TO TRUE
647064700*
648064800 EXEC CICS XCTL
649064900 PROGRAM (LIT-ADDTPGM)
650065000 COMMAREA(CARDDEMO-COMMAREA)
651065100 END-EXEC
652065200 END-IF
653065300
654065400*****************************************************************
655065500* If the user did not press PF8, lets reset the last page flag
656065600*****************************************************************
657065700 IF CCARD-AID-PFK08
658065800 CONTINUE
659065900 ELSE
660066000 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
661066100 END-IF
662066200*****************************************************************
663066300* If the user pressed F10 to confirm delete
664066400* But changed some criteria on screen. Treat it as ENTER
665066500*****************************************************************
666066600 IF CCARD-AID-PFK10
667066700 IF (CA-DELETE-REQUESTED
668066800 OR CA-UPDATE-REQUESTED)
669066900 AND FLG-TYPEFILTER-CHANGED-NO
670067000 AND FLG-DESCFILTER-CHANGED-NO
671067100 AND FLG-ROW-SELECTION-CHANGED-NO
672067200 CONTINUE
673067300 ELSE
674067400 SET CCARD-AID-ENTER TO TRUE
675067500 END-IF
676067600 ELSE
677067700 CONTINUE
678067800 END-IF
679067900
680068000
681068100*****************************************************************
682068200* Check Db2 connectivity. Quit if no Access.
683068300*****************************************************************
684068400 PERFORM 9998-PRIMING-QUERY
685068500 THRU 9998-PRIMING-QUERY-EXIT
686068600
687068700 IF WS-DB2-ERROR
688068800 PERFORM SEND-LONG-TEXT
689068900 THRU SEND-LONG-TEXT-EXIT
690069000 GO TO COMMON-RETURN
691069100 END-IF
692069200
693069300
694069400
695069500*****************************************************************
696069600* Now we decide what to do
697069700*****************************************************************
698069800 EVALUATE TRUE
699069900 WHEN INPUT-ERROR
700070000*****************************************************************
701070100* ASK FOR CORRECTIONS TO INPUTS
702070200*****************************************************************
703070300 MOVE WS-RETURN-MSG TO CCARD-ERROR-MSG
704070400 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
705070500 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
706070600 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
707070700
708070800 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
709070900 MOVE LIT-THISMAPSET TO CCARD-NEXT-MAPSET
710071000 MOVE LIT-THISMAP TO CCARD-NEXT-MAP
711071100 MOVE WS-CA-FIRST-TR-CODE
712071200 TO WS-START-KEY
713071300 IF NOT FLG-TYPEFILTER-NOT-OK
714071400 AND NOT FLG-DESCFILTER-NOT-OK
715071500 PERFORM 8000-READ-FORWARD
716071600 THRU 8000-READ-FORWARD-EXIT
717071700 END-IF
718071800 PERFORM 2000-SEND-MAP
719071900 THRU 2000-SEND-MAP-EXIT
720072000 GO TO COMMON-RETURN
721072100 WHEN CCARD-AID-PFK07
722072200 AND CA-FIRST-PAGE
723072300*****************************************************************
724072400* PAGE UP - PF7 - BUT ALREADY ON FIRST PAGE
725072500*****************************************************************
726072600 WHEN CCARD-AID-PFK07
727072700 AND CA-FIRST-PAGE
728072800 MOVE WS-CA-FIRST-TR-CODE
729072900 TO WS-START-KEY
730073000 PERFORM 8000-READ-FORWARD
731073100 THRU 8000-READ-FORWARD-EXIT
732073200 PERFORM 2000-SEND-MAP
733073300 THRU 2000-SEND-MAP-EXIT
734073400 GO TO COMMON-RETURN
735073500*****************************************************************
736073600* BACK - PF3 IF WE CAME FROM SOME OTHER PROGRAM
737073700*****************************************************************
738073800 WHEN CCARD-AID-PFK03
739073900 WHEN CDEMO-PGM-REENTER AND
740074000 CDEMO-FROM-PROGRAM NOT EQUAL LIT-THISPGM
741074100
742074200 INITIALIZE CARDDEMO-COMMAREA
743074300 WS-THIS-PROGCOMMAREA
744074400 WS-MISC-STORAGE
745074500
746074600 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
747074700 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
748074800 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
749074900 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
750075000
751075100 SET CDEMO-USRTYP-ADMIN TO TRUE
752075200 SET CDEMO-PGM-ENTER TO TRUE
753075300 SET CA-FIRST-PAGE TO TRUE
754075400 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
755075500
756075600 MOVE WS-CA-FIRST-TR-CODE TO WS-START-KEY
757075700
758075800 PERFORM 8000-READ-FORWARD
759075900 THRU 8000-READ-FORWARD-EXIT
760076000 PERFORM 2000-SEND-MAP
761076100 THRU 2000-SEND-MAP-EXIT
762076200 GO TO COMMON-RETURN
763076300*****************************************************************
764076400* PAGE DOWN
765076500*****************************************************************
766076600 WHEN CCARD-AID-PFK08
767076700 AND CA-NEXT-PAGE-EXISTS
768076800 MOVE WS-CA-LAST-TR-CODE
769076900 TO WS-START-KEY
770077000 ADD +1 TO WS-CA-SCREEN-NUM
771077100 PERFORM 8000-READ-FORWARD
772077200 THRU 8000-READ-FORWARD-EXIT
773077300 INITIALIZE WS-EDIT-SELECT-FLAGS
774077400 PERFORM 2000-SEND-MAP
775077500 THRU 2000-SEND-MAP-EXIT
776077600 GO TO COMMON-RETURN
777077700*****************************************************************
778077800* PAGE UP
779077900*****************************************************************
780078000 WHEN CCARD-AID-PFK07
781078100 AND NOT CA-FIRST-PAGE
782078200 MOVE WS-CA-FIRST-TR-CODE
783078300 TO WS-START-KEY
784078400 SUBTRACT 1 FROM WS-CA-SCREEN-NUM
785078500 PERFORM 8100-READ-BACKWARDS
786078600 THRU 8100-READ-BACKWARDS-EXIT
787078700 INITIALIZE WS-EDIT-SELECT-FLAGS
788078800 PERFORM 2000-SEND-MAP
789078900 THRU 2000-SEND-MAP-EXIT
790079000 GO TO COMMON-RETURN
791079100*****************************************************************
792079200* ENTER AND DELETE REQUESTED
793079300*****************************************************************
794079400 WHEN CCARD-AID-ENTER
795079500 AND WS-DELETES-REQUESTED > 0
796079600 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
797079700 MOVE WS-CA-FIRST-TR-CODE
798079800 TO WS-START-KEY
799079900 IF NOT FLG-TYPEFILTER-NOT-OK
800080000 AND NOT FLG-DESCFILTER-NOT-OK
801080100 PERFORM 8000-READ-FORWARD
802080200 THRU 8000-READ-FORWARD-EXIT
803080300 END-IF
804080400 PERFORM 2000-SEND-MAP
805080500 THRU 2000-SEND-MAP-EXIT
806080600 GO TO COMMON-RETURN
807080700*****************************************************************
808080800* F10 AFTER DELETE CONFIRM REQUESTED
809080900*****************************************************************
810081000 WHEN CCARD-AID-PFK10
811081100 AND WS-DELETES-REQUESTED > 0
812081200 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
813081300
814081400 PERFORM 9300-DELETE-RECORD
815081500 THRU 9300-DELETE-RECORD-EXIT
816081600
817081700 IF CA-DELETE-SUCCEEDED
818081800 SET FLG-DELETED-YES TO TRUE
819081900 ELSE
820082000 SET FLG-DELETED-NO TO TRUE
821082100 END-IF
822082200
823082300 PERFORM 2000-SEND-MAP
824082400 THRU 2000-SEND-MAP-EXIT
825082500
826082600 IF FLG-DELETED-YES
827082700 INITIALIZE CARDDEMO-COMMAREA
828082800 WS-THIS-PROGCOMMAREA
829082900 WS-MISC-STORAGE
830083000 SET CDEMO-PGM-ENTER TO TRUE
831083100 SET CA-FIRST-PAGE TO TRUE
832083200 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
833083300 END-IF
834083400 GO TO COMMON-RETURN
835083500*****************************************************************
836083600* ENTER AND UPDATE REQUESTED
837083700*****************************************************************
838083800 WHEN CCARD-AID-ENTER
839083900 AND WS-UPDATES-REQUESTED > 0
840084000 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
841084100 MOVE WS-CA-FIRST-TR-CODE
842084200 TO WS-START-KEY
843084300 IF NOT FLG-TYPEFILTER-NOT-OK
844084400 AND NOT FLG-DESCFILTER-NOT-OK
845084500 PERFORM 8000-READ-FORWARD
846084600 THRU 8000-READ-FORWARD-EXIT
847084700 END-IF
848084800 PERFORM 2000-SEND-MAP
849084900 THRU 2000-SEND-MAP-EXIT
850085000 GO TO COMMON-RETURN
851085100*****************************************************************
852085200* F10 AFTER UPDATE CONFIRM REQUESTED
853085300*****************************************************************
854085400 WHEN CCARD-AID-PFK10
855085500 AND WS-UPDATES-REQUESTED > 0
856085600 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
857085700
858085800 PERFORM 9200-UPDATE-RECORD
859085900 THRU 9200-UPDATE-RECORD-EXIT
860086000 IF CA-UPDATE-SUCCEEDED
861086100 SET FLG-UPDATE-COMPLETED TO TRUE
862086200 END-IF
863086300 MOVE WS-CA-FIRST-TR-CODE
864086400 TO WS-START-KEY
865086500 PERFORM 8000-READ-FORWARD
866086600 THRU 8000-READ-FORWARD-EXIT
867086700 PERFORM 2000-SEND-MAP
868086800 THRU 2000-SEND-MAP-EXIT
869086900*****************************************************************
870087000 WHEN OTHER
871087100*****************************************************************
872087200 MOVE WS-CA-FIRST-TR-CODE
873087300 TO WS-START-KEY
874087400 PERFORM 8000-READ-FORWARD
875087500 THRU 8000-READ-FORWARD-EXIT
876087600 PERFORM 2000-SEND-MAP
877087700 THRU 2000-SEND-MAP-EXIT
878087800 GO TO COMMON-RETURN
879087900 END-EVALUATE
880088000
881088100* If we had an error setup error message to display and return
882088200 IF INPUT-ERROR
883088300 MOVE WS-RETURN-MSG TO CCARD-ERROR-MSG
884088400 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
885088500 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
886088600 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
887088700
888088800 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
889088900 MOVE LIT-THISMAPSET TO CCARD-NEXT-MAPSET
890089000 MOVE LIT-THISMAP TO CCARD-NEXT-MAP
891089100
892089200 GO TO COMMON-RETURN
893089300 END-IF
894089400
895089500 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
896089600 GO TO COMMON-RETURN
897089700 .
898089800
899089900 COMMON-RETURN.
900090000 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
901090100 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
902090200 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
903090300 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
904090400 MOVE CARDDEMO-COMMAREA TO WS-COMMAREA
905090500 MOVE WS-THIS-PROGCOMMAREA TO
906090600 WS-COMMAREA(LENGTH OF CARDDEMO-COMMAREA + 1:
907090700 LENGTH OF WS-THIS-PROGCOMMAREA )
908090800
909090900
910091000 EXEC CICS RETURN
911091100 TRANSID (LIT-THISTRANID)
912091200 COMMAREA (WS-COMMAREA)
913091300 LENGTH(LENGTH OF WS-COMMAREA)
914091400 END-EXEC
915091500 .
916091600 0000-MAIN-EXIT.
917091700 EXIT
918091800 .
919091900 1000-RECEIVE-MAP.
920092000 PERFORM 1100-RECEIVE-SCREEN
921092100 THRU 1100-RECEIVE-SCREEN-EXIT
922092200
923092300 PERFORM 1200-EDIT-INPUTS
924092400 THRU 1200-EDIT-INPUTS-EXIT
925092500 .
926092600 1000-RECEIVE-MAP-EXIT.
927092700 EXIT
928092800 .
929092900
930093000 1100-RECEIVE-SCREEN.
931093100 EXEC CICS RECEIVE MAP(LIT-THISMAP)
932093200 MAPSET(LIT-THISMAPSET)
933093300 INTO(CTRTLIAI)
934093400 RESP(WS-RESP-CD)
935093500 END-EXEC
936093600
937093700 MOVE TRTYPEI OF CTRTLIAI TO WS-IN-TYPE-CD
938093800 MOVE TRDESCI OF CTRTLIAI TO WS-IN-TYPE-DESC
939093900
940094000 PERFORM VARYING I FROM 1 BY 1 UNTIL I > WS-MAX-SCREEN-LINES
941094100 MOVE TRTSELI(I) TO WS-EDIT-SELECT(I)
942094200 MOVE TRTTYPI(I) TO WS-ROW-TR-CODE-IN(I)
943094300
944094400 MOVE LOW-VALUES TO WS-ROW-TR-DESC-IN(I)
945094500 IF TRTYPDI(I) = LIT-ASTERISK
946094600 OR TRTYPDI(I) = SPACES
947094700 CONTINUE
948094800 ELSE
949094900 MOVE FUNCTION TRIM(TRTYPDI(I))
950095000 TO WS-ROW-TR-DESC-IN(I)
951095100 END-IF
952095200
953095300 END-PERFORM
954095400 .
955095500
956095600 1100-RECEIVE-SCREEN-EXIT.
957095700 EXIT
958095800 .
959095900
960096000 1200-EDIT-INPUTS.
961096100
962096200 SET INPUT-OK TO TRUE
963096300 SET FLG-PROTECT-SELECT-ROWS-NO TO TRUE
964096400
965096500 PERFORM 1210-EDIT-ARRAY
966096600 THRU 1210-EDIT-ARRAY-EXIT
967096700
968096800 PERFORM 1230-EDIT-DESC
969096900 THRU 1230-EDIT-DESC-EXIT
970097000
971097100 PERFORM 1220-EDIT-TYPECD
972097200 THRU 1220-EDIT-TYPECD-EXIT
973097300
974097400 PERFORM 1290-CROSS-EDITS
975097500 THRU 1290-CROSS-EDITS-EXIT
976097600 .
977097700
978097800 1200-EDIT-INPUTS-EXIT.
979097900 EXIT
980098000 .
981098100
982098200 1210-EDIT-ARRAY.
983098300
984098400 MOVE ZERO TO WS-ACTIONS-REQUESTED
985098500 WS-NO-ACTIONS-SELECTED
986098600 WS-DELETES-REQUESTED
987098700 WS-UPDATES-REQUESTED
988098800 WS-VALID-ACTIONS-SELECTED
989098900
990099000
991099100 IF FLG-TYPEFILTER-CHANGED-YES
992099200 OR FLG-DESCFILTER-CHANGED-YES
993099300 INITIALIZE WS-EDIT-SELECT-FLAGS
994099400 GO TO 1210-EDIT-ARRAY-EXIT
995099500 ELSE
996099600
997099700 INSPECT WS-EDIT-SELECT-FLAGS
998099800 TALLYING WS-NO-ACTIONS-SELECTED FOR ALL SPACES
999099900 LOW-VALUES
1000100000 WS-DELETES-REQUESTED FOR ALL LIT-DELETE-FLAG
1001100100 WS-UPDATES-REQUESTED FOR ALL LIT-UPDATE-FLAG
1002100200
1003100300 COMPUTE WS-ACTIONS-REQUESTED
1004100400 = WS-MAX-SCREEN-LINES
1005100500 - WS-NO-ACTIONS-SELECTED
1006100600 END-COMPUTE
1007100700
1008100800
1009100900 COMPUTE WS-VALID-ACTIONS-SELECTED =
1010101000 WS-DELETES-REQUESTED
1011101100 + WS-UPDATES-REQUESTED
1012101200 END-COMPUTE
1013101300
1014101400 MOVE ZERO TO I-SELECTED
1015101500 SET FLG-BAD-ACTIONS-SELECTED-NO TO TRUE
1016101600
1017101700 PERFORM VARYING I
1018101800 FROM WS-MAX-SCREEN-LINES
1019101900 BY -1
1020102000 UNTIL I = 0
1021102100 EVALUATE TRUE
1022102200 WHEN SELECT-OK(I)
1023102300 MOVE I TO I-SELECTED
1024102400 IF WS-MORETHAN1ACTION
1025102500 MOVE '1' TO WS-ROW-TRTSELECT-ERROR(I)
1026102600 SET FLG-BAD-ACTIONS-SELECTED-YES TO TRUE
1027102700 END-IF
1028102800 IF UPDATE-REQUESTED-ON(I)
1029102900 PERFORM 1211-EDIT-ARRAY-DESC
1030103000 THRU 1211-EDIT-ARRAY-DESC-EXIT
1031103100 END-IF
1032103200 WHEN SELECT-BLANK(I)
1033103300 CONTINUE
1034103400 WHEN OTHER
1035103500 SET INPUT-ERROR TO TRUE
1036103600 MOVE '1' TO WS-ROW-TRTSELECT-ERROR(I)
1037103700 SET FLG-BAD-ACTIONS-SELECTED-YES TO TRUE
1038103800 SET WS-MESG-INVALID-ACTION-CODE TO TRUE
1039103900 END-EVALUATE
1040104000 END-PERFORM
1041104100
1042104200 IF I-SELECTED EQUAL WS-CA-ROW-SELECTED
1043104300 SET FLG-ROW-SELECTION-CHANGED-NO TO TRUE
1044104400 ELSE
1045104500 SET FLG-ROW-SELECTION-CHANGED-YES TO TRUE
1046104600 MOVE I-SELECTED TO WS-CA-ROW-SELECTED
1047104700 END-IF
1048104800
1049104900 IF WS-MORETHAN1ACTION
1050105000 SET INPUT-ERROR TO TRUE
1051105100 SET WS-MESG-MORE-THAN-1-ACTION TO TRUE
1052105200 END-IF
1053105300 .
1054105400
1055105500 1210-EDIT-ARRAY-EXIT.
1056105600 EXIT
1057105700 .
1058105800
1059105900
1060106000 1211-EDIT-ARRAY-DESC.
1061106100
1062106200 SET NO-CHANGES-FOUND TO TRUE
1063106300
1064106400 IF FUNCTION UPPER-CASE (
1065106500 FUNCTION TRIM (WS-ROW-TR-DESC-IN(I)))=
1066106600 FUNCTION UPPER-CASE (
1067106700 FUNCTION TRIM (WS-CA-ROW-TR-DESC-OUT(I)))
1068106800 AND FUNCTION LENGTH (
1069106900 FUNCTION TRIM (WS-ROW-TR-DESC-IN(I)))=
1070107000 FUNCTION LENGTH (
1071107100 FUNCTION TRIM (WS-CA-ROW-TR-DESC-OUT(I)))
1072107200 SET WS-MESG-NO-CHANGES-DETECTED TO TRUE
1073107300 GO TO 1211-EDIT-ARRAY-DESC-EXIT
1074107400 ELSE
1075107500 SET CHANGES-HAVE-OCCURRED TO TRUE
1076107600 END-IF
1077107700
1078107800 SET FLG-ROW-DESCRIPTION-NOT-OK TO TRUE
1079107900
1080108000******************************************************************
1081108100* Edit Description
1082108200******************************************************************
1083108300 MOVE 'Transaction Desc' TO WS-EDIT-VARIABLE-NAME
1084108400 MOVE WS-ROW-TR-DESC-IN(I) TO WS-EDIT-ALPHANUM-ONLY
1085108500 MOVE 50 TO WS-EDIT-ALPHANUM-LENGTH
1086108600 PERFORM 1240-EDIT-ALPHANUM-REQD
1087108700 THRU 1240-EDIT-ALPHANUM-REQD-EXIT
1088108800 MOVE WS-EDIT-ALPHANUM-ONLY-FLAGS
1089108900 TO WS-ARRAY-DESCRIPTION-FLGS
1090109000 .
1091109100
1092109200 1211-EDIT-ARRAY-DESC-EXIT.
1093109300 EXIT
1094109400 .
1095109500
1096109600 1220-EDIT-TYPECD.
1097109700
1098109800 SET FLG-TYPEFILTER-BLANK TO TRUE
1099109900
1100110000* Not supplied
1101110100 IF WS-IN-TYPE-CD EQUAL LOW-VALUES
1102110200 OR WS-IN-TYPE-CD EQUAL SPACES
1103110300 OR WS-IN-TYPE-CD EQUAL ZEROS
1104110400 SET FLG-TYPEFILTER-BLANK TO TRUE
1105110500 MOVE ZEROES TO WS-TYPE-CD-FILTER
1106110600 GO TO 1220-EDIT-TYPECD-EXIT
1107110700 END-IF
1108110800*
1109110900* Not numeric
1110111000* Not 2 characters
1111111100 IF WS-IN-TYPE-CD IS NOT NUMERIC
1112111200 SET INPUT-ERROR TO TRUE
1113111300 SET FLG-TYPEFILTER-NOT-OK TO TRUE
1114111400 SET FLG-PROTECT-SELECT-ROWS-YES TO TRUE
1115111500 MOVE
1116111600 'TYPE CODE FILTER,IF SUPPLIED MUST BE A 2 DIGIT NUMBER'
1117111700 TO WS-RETURN-MSG
1118111800 GO TO 1220-EDIT-TYPECD-EXIT
1119111900 ELSE
1120112000 MOVE WS-IN-TYPE-CD TO WS-TYPE-CD-FILTER
1121112100 SET FLG-TYPEFILTER-ISVALID TO TRUE
1122112200 END-IF
1123112300 .
1124112400
1125112500 1220-EDIT-TYPECD-EXIT.
1126112600
1127112700 IF WS-IN-TYPE-CD EQUAL WS-CA-TYPE-CD
1128112800 OR FLG-TYPEFILTER-BLANK
1129112900 AND (WS-CA-TYPE-CD EQUAL ZEROES
1130113000 OR WS-CA-TYPE-CD EQUAL LOW-VALUES
1131113100 OR WS-CA-TYPE-CD EQUAL SPACES)
1132113200 SET FLG-TYPEFILTER-CHANGED-NO TO TRUE
1133113300 ELSE
1134113400 INITIALIZE WS-CA-PAGING-VARIABLES
1135113500 MOVE WS-IN-TYPE-CD TO WS-CA-TYPE-CD
1136113600 SET FLG-TYPEFILTER-CHANGED-YES TO TRUE
1137113700 END-IF
1138113800
1139113900 EXIT
1140114000 .
1141114100
1142114200 1230-EDIT-DESC.
1143114300
1144114400 SET FLG-DESCFILTER-BLANK TO TRUE
1145114500
1146114600* Not supplied
1147114700 IF WS-IN-TYPE-DESC EQUAL LOW-VALUES
1148114800 OR WS-IN-TYPE-DESC EQUAL SPACES
1149114900 SET FLG-DESCFILTER-BLANK TO TRUE
1150115000 GO TO 1230-EDIT-DESC-EXIT
1151115100 ELSE
1152115200 SET FLG-DESCFILTER-ISVALID TO TRUE
1153115300 END-IF
1154115400
1155115500 IF FLG-DESCFILTER-ISVALID
1156115600 STRING '%'
1157115700 FUNCTION TRIM(WS-IN-TYPE-DESC)
1158115800 '%'
1159115900 DELIMITED BY SIZE
1160116000 INTO
1161116100 WS-TYPE-DESC-FILTER
1162116200 END-STRING
1163116300 END-IF
1164116400 .
1165116500 1230-EDIT-DESC-EXIT.
1166116600 IF WS-IN-TYPE-DESC EQUAL WS-CA-TYPE-DESC
1167116700 OR FLG-DESCFILTER-BLANK
1168116800 AND (WS-CA-TYPE-DESC EQUAL LOW-VALUES
1169116900 OR WS-CA-TYPE-DESC EQUAL SPACES)
1170117000 SET FLG-DESCFILTER-CHANGED-NO TO TRUE
1171117100 ELSE
1172117200 INITIALIZE WS-CA-PAGING-VARIABLES
1173117300 MOVE WS-IN-TYPE-DESC TO WS-CA-TYPE-DESC
1174117400 SET FLG-DESCFILTER-CHANGED-YES TO TRUE
1175117500 END-IF
1176117600
1177117700 EXIT
1178117800 .
1179117900
1180118000
1181118100 1240-EDIT-ALPHANUM-REQD.
1182118200* Initialize
1183118300 SET FLG-ALPHNANUM-NOT-OK TO TRUE
1184118400
1185118500* Not supplied
1186118600 IF WS-EDIT-ALPHANUM-ONLY(1:WS-EDIT-ALPHANUM-LENGTH)
1187118700 EQUAL LOW-VALUES
1188118800 OR WS-EDIT-ALPHANUM-ONLY(1:WS-EDIT-ALPHANUM-LENGTH)
1189118900 EQUAL SPACES
1190119000 OR FUNCTION LENGTH(FUNCTION TRIM(
1191119100 WS-EDIT-ALPHANUM-ONLY(1:WS-EDIT-ALPHANUM-LENGTH))) = 0
1192119200
1193119300 SET INPUT-ERROR TO TRUE
1194119400 SET FLG-ALPHNANUM-BLANK TO TRUE
1195119500 IF WS-RETURN-MSG-OFF
1196119600 STRING
1197119700 FUNCTION TRIM(WS-EDIT-VARIABLE-NAME)
1198119800 ' must be supplied.'
1199119900 DELIMITED BY SIZE
1200120000 INTO WS-RETURN-MSG
1201120100 END-STRING
1202120200 END-IF
1203120300
1204120400 GO TO 1240-EDIT-ALPHANUM-REQD-EXIT
1205120500 END-IF
1206120600
1207120700* Only Alphabets,numbers and space allowed
1208120800 MOVE LIT-ALL-ALPHANUM-FROM-X TO LIT-ALL-ALPHANUM-FROM
1209120900
1210121000 INSPECT WS-EDIT-ALPHANUM-ONLY(1:WS-EDIT-ALPHANUM-LENGTH)
1211121100 CONVERTING LIT-ALL-ALPHANUM-FROM
1212121200 TO LIT-ALPHANUM-SPACES-TO
1213121300
1214121400 IF FUNCTION LENGTH(
1215121500 FUNCTION TRIM(
1216121600 WS-EDIT-ALPHANUM-ONLY(1:WS-EDIT-ALPHANUM-LENGTH)
1217121700 )) = 0
1218121800 CONTINUE
1219121900 ELSE
1220122000 SET INPUT-ERROR TO TRUE
1221122100 SET FLG-ALPHNANUM-NOT-OK TO TRUE
1222122200 IF WS-RETURN-MSG-OFF
1223122300 STRING
1224122400 FUNCTION TRIM(WS-EDIT-VARIABLE-NAME)
1225122500 ' can have numbers or alphabets only.'
1226122600 DELIMITED BY SIZE
1227122700 INTO WS-RETURN-MSG
1228122800 END-STRING
1229122900 END-IF
1230123000 GO TO 1240-EDIT-ALPHANUM-REQD-EXIT
1231123100 END-IF
1232123200
1233123300 SET FLG-ALPHNANUM-ISVALID TO TRUE
1234123400 .
1235123500 1240-EDIT-ALPHANUM-REQD-EXIT.
1236123600 EXIT
1237123700 .
1238123800
1239123900 1290-CROSS-EDITS.
1240124000
1241124100 IF FLG-TYPEFILTER-ISVALID
1242124200 OR FLG-DESCFILTER-ISVALID
1243124300 CONTINUE
1244124400 ELSE
1245124500 GO TO 1290-CROSS-EDITS-EXIT
1246124600 END-IF
1247124700
1248124800 PERFORM 9100-CHECK-FILTERS
1249124900 THRU 9100-CHECK-FILTERS-EXIT
1250125000
1251125100 IF WS-RECORDS-COUNT = 0
1252125200 SET INPUT-ERROR TO TRUE
1253125300 IF FLG-TYPEFILTER-ISVALID
1254125400 SET FLG-TYPEFILTER-NOT-OK TO TRUE
1255125500 END-IF
1256125600
1257125700 IF FLG-DESCFILTER-ISVALID
1258125800 SET FLG-DESCFILTER-NOT-OK TO TRUE
1259125900 END-IF
1260126000
1261126100
1262126200 SET FLG-PROTECT-SELECT-ROWS-YES TO TRUE
1263126300 MOVE
1264126400 'No Records found for these filter conditions'
1265126500 TO WS-RETURN-MSG
1266126600 GO TO 1290-CROSS-EDITS-EXIT
1267126700 END-IF
1268126800 .
1269126900 1290-CROSS-EDITS-EXIT.
1270127000 EXIT
1271127100 .
1272127200
1273127300
1274127400 2000-SEND-MAP
1275127500 .
1276127600 PERFORM 2100-SCREEN-INIT
1277127700 THRU 2100-SCREEN-INIT-EXIT
1278127800 PERFORM 2200-SETUP-ARRAY-ATTRIBS
1279127900 THRU 2200-SETUP-ARRAY-ATTRIBS-EXIT
1280128000 PERFORM 2300-SCREEN-ARRAY-INIT
1281128100 THRU 2300-SCREEN-ARRAY-INIT-EXIT
1282128200 PERFORM 2400-SETUP-SCREEN-ATTRS
1283128300 THRU 2400-SETUP-SCREEN-ATTRS-EXIT
1284128400 PERFORM 2500-SETUP-MESSAGE
1285128500 THRU 2500-SETUP-MESSAGE-EXIT
1286128600 PERFORM 2600-SEND-SCREEN
1287128700 THRU 2600-SEND-SCREEN-EXIT
1288128800 .
1289128900
1290129000 2000-SEND-MAP-EXIT.
1291129100 EXIT
1292129200 .
1293129300 2100-SCREEN-INIT.
1294129400 MOVE LOW-VALUES TO CTRTLIAO
1295129500
1296129600 MOVE FUNCTION CURRENT-DATE TO WS-CURDATE-DATA
1297129700
1298129800 MOVE CCDA-TITLE01 TO TITLE01O OF CTRTLIAO
1299129900 MOVE CCDA-TITLE02 TO TITLE02O OF CTRTLIAO
1300130000 MOVE LIT-THISTRANID TO TRNNAMEO OF CTRTLIAO
1301130100 MOVE LIT-THISPGM TO PGMNAMEO OF CTRTLIAO
1302130200
1303130300 MOVE FUNCTION CURRENT-DATE TO WS-CURDATE-DATA
1304130400
1305130500 MOVE WS-CURDATE-MONTH TO WS-CURDATE-MM
1306130600 MOVE WS-CURDATE-DAY TO WS-CURDATE-DD
1307130700 MOVE WS-CURDATE-YEAR(3:2) TO WS-CURDATE-YY
1308130800
1309130900 MOVE WS-CURDATE-MM-DD-YY TO CURDATEO OF CTRTLIAO
1310131000
1311131100 MOVE WS-CURTIME-HOURS TO WS-CURTIME-HH
1312131200 MOVE WS-CURTIME-MINUTE TO WS-CURTIME-MM
1313131300 MOVE WS-CURTIME-SECOND TO WS-CURTIME-SS
1314131400
1315131500 MOVE WS-CURTIME-HH-MM-SS TO CURTIMEO OF CTRTLIAO
1316131600* PAGE NUMBER
1317131700*
1318131800 MOVE WS-CA-SCREEN-NUM TO PAGENOO OF CTRTLIAO
1319131900
1320132000 SET WS-NO-INFO-MESSAGE TO TRUE
1321132100 MOVE WS-INFO-MSG TO INFOMSGO OF CTRTLIAO
1322132200 MOVE DFHBMDAR TO INFOMSGC OF CTRTLIAO
1323132300 .
1324132400
1325132500 2100-SCREEN-INIT-EXIT.
1326132600 EXIT
1327132700 .
1328132800
1329132900 2200-SETUP-ARRAY-ATTRIBS.
1330133000* REPLACE BMS GENERATED MAP WITH PROVIDED COPYBOOK
1331133100* AND CLEAN UP REPETITIVE CODE !!
1332133200
1333133300 PERFORM VARYING I
1334133400 FROM WS-MAX-SCREEN-LINES
1335133500 BY -1
1336133600 UNTIL I = 0
1337133700 MOVE DFHBMPRF TO TRTYPDA(I)
1338133800
1339133900 IF WS-CA-EACH-ROW-OUT(I) EQUAL LOW-VALUES
1340134000 OR FLG-PROTECT-SELECT-ROWS-YES
1341134100 MOVE DFHBMPRO TO TRTSELA (I)
1342134200 ELSE
1343134300 IF WS-ROW-TRTSELECT-ERROR(I) = '1'
1344134400 MOVE DFHRED TO TRTSELC(I)
1345134500 MOVE -1 TO TRTSELL(I)
1346134600 END-IF
1347134700
1348134800 IF DELETE-REQUESTED-ON(I)
1349134900 AND WS-ONLY-1-VALID-ACTION
1350135000 AND FLG-BAD-ACTIONS-SELECTED-NO
1351135100 MOVE DFHNEUTR TO TRTTYPC(I)
1352135200 TRTYPDC(I)
1353135300 MOVE -1 TO TRTSELL(I)
1354135400 END-IF
1355135500
1356135600 IF UPDATE-REQUESTED-ON(I)
1357135700 AND WS-ONLY-1-VALID-ACTION
1358135800 AND FLG-BAD-ACTIONS-SELECTED-NO
1359135900 MOVE DFHNEUTR TO TRTTYPC(I)
1360136000 IF FLG-UPDATE-COMPLETED
1361136100 MOVE -1 TO TRTSELL(I)
1362136200 MOVE DFHNEUTR TO TRTYPDC(I)
1363136300 ELSE
1364136400 MOVE -1 TO TRTYPDL(I)
1365136500 MOVE DFHBMFSE TO TRTYPDA(I)
1366136600 IF NOT FLG-ROW-DESCRIPTION-ISVALID
1367136700 MOVE DFHRED TO TRTYPDC(I)
1368136800 END-IF
1369136900 END-IF
1370137000 END-IF
1371137100 MOVE DFHBMFSE TO TRTSELA(I)
1372137200 END-IF
1373137300 END-PERFORM
1374137400 .
1375137500
1376137600
1377137700 2200-SETUP-ARRAY-ATTRIBS-EXIT.
1378137800 EXIT
1379137900 .
1380138000
1381138100
1382138200
1383138300 2300-SCREEN-ARRAY-INIT.
1384138400* USING REDEFINES TO AVOID UP REPETITIVE CODE !!
1385138500*
1386138600 PERFORM VARYING I FROM 1 BY 1 UNTIL I > WS-MAX-SCREEN-LINES
1387138700
1388138800 IF WS-CA-EACH-ROW-OUT(I) EQUAL LOW-VALUES
1389138900 CONTINUE
1390139000 ELSE
1391139100 IF DELETE-REQUESTED-ON(I)
1392139200 AND WS-ONLY-1-VALID-ACTION
1393139300 AND FLG-BAD-ACTIONS-SELECTED-NO
1394139400 IF FLG-DELETED-YES
1395139500 SET SELECT-BLANK(I) TO TRUE
1396139600 ELSE
1397139700 SET CA-DELETE-REQUESTED TO TRUE
1398139800 END-IF
1399139900 END-IF
1400140000
1401140100* Type code
1402140200 MOVE WS-CA-ROW-TR-CODE-OUT(I) TO TRTTYPO(I)
1403140300* Type Description
1404140400 IF UPDATE-REQUESTED-ON(I)
1405140500 AND WS-ONLY-1-VALID-ACTION
1406140600 AND FLG-BAD-ACTIONS-SELECTED-NO
1407140700 IF FLG-UPDATE-COMPLETED
1408140800 SET SELECT-BLANK(I) TO TRUE
1409140900 ELSE
1410141000 SET CA-UPDATE-REQUESTED TO TRUE
1411141100 END-IF
1412141200 IF CHANGES-HAVE-OCCURRED
1413141300 EVALUATE TRUE
1414141400 WHEN FLG-ROW-DESCRIPTION-BLANK
1415141500 MOVE LIT-ASTERISK TO TRTYPDO(I)
1416141600 WHEN OTHER
1417141700 MOVE WS-ROW-TR-DESC-IN(I)
1418141800 TO TRTYPDO(I)
1419141900 END-EVALUATE
1420142000 ELSE
1421142100 MOVE WS-CA-ROW-TR-DESC-OUT(I) TO TRTYPDO(I)
1422142200 END-IF
1423142300 ELSE
1424142400 MOVE WS-CA-ROW-TR-DESC-OUT(I) TO TRTYPDO(I)
1425142500 END-IF
1426142600
1427142700* Select flag because we may update it above
1428142800 MOVE WS-EDIT-SELECT(I) TO TRTSELO(I)
1429142900 END-IF
1430143000 END-PERFORM
1431143100 .
1432143200
1433143300 2300-SCREEN-ARRAY-INIT-EXIT.
1434143400 EXIT
1435143500 .
1436143600
1437143700
1438143800 2400-SETUP-SCREEN-ATTRS.
1439143900* INITIALIZE SEARCH CRITERIA
1440144000 IF EIBCALEN = 0
1441144100 OR (CDEMO-PGM-ENTER
1442144200 AND CDEMO-FROM-PROGRAM = LIT-ADMINPGM)
1443144300 CONTINUE
1444144400 ELSE
1445144500 EVALUATE TRUE
1446144600 WHEN WS-ACTIONS-REQUESTED > 0
1447144700 MOVE WS-IN-TYPE-CD TO TRTYPEO OF CTRTLIAO
1448144800 MOVE DFHBMASF TO TRTYPEA OF CTRTLIAI
1449144900 MOVE DFHBLUE TO TRTYPEC OF CTRTLIAO
1450145000 WHEN FLG-TYPEFILTER-ISVALID
1451145100 WHEN FLG-TYPEFILTER-NOT-OK
1452145200 MOVE WS-IN-TYPE-CD TO TRTYPEO OF CTRTLIAO
1453145300 MOVE DFHBMFSE TO TRTYPEA OF CTRTLIAI
1454145400 WHEN WS-IN-TYPE-CD = 0
1455145500 MOVE LOW-VALUES TO TRTYPEO OF CTRTLIAO
1456145600 WHEN OTHER
1457145700 MOVE LOW-VALUES TO TRTYPEO OF CTRTLIAO
1458145800 MOVE DFHBMFSE TO TRTYPEA OF CTRTLIAI
1459145900 END-EVALUATE
1460146000
1461146100 EVALUATE TRUE
1462146200 WHEN WS-ACTIONS-REQUESTED > 0
1463146300 MOVE WS-IN-TYPE-DESC TO TRDESCO OF CTRTLIAO
1464146400 MOVE DFHBMASF TO TRDESCA OF CTRTLIAI
1465146500 MOVE DFHBLUE TO TRDESCC OF CTRTLIAO
1466146600 WHEN FLG-DESCFILTER-ISVALID
1467146700 WHEN FLG-DESCFILTER-NOT-OK
1468146800 MOVE WS-IN-TYPE-DESC TO TRDESCO OF CTRTLIAO
1469146900 MOVE DFHBMFSE TO TRDESCA OF CTRTLIAI
1470147000 WHEN OTHER
1471147100 MOVE DFHBMFSE TO TRDESCA OF CTRTLIAI
1472147200 END-EVALUATE
1473147300 END-IF
1474147400
1475147500* POSITION CURSOR
1476147600
1477147700 IF FLG-TYPEFILTER-NOT-OK
1478147800 MOVE DFHRED TO TRTYPEC OF CTRTLIAO
1479147900 MOVE -1 TO TRTYPEL OF CTRTLIAI
1480148000 END-IF
1481148100
1482148200 IF FLG-DESCFILTER-NOT-OK
1483148300 MOVE DFHRED TO TRDESCC OF CTRTLIAO
1484148400 MOVE -1 TO TRDESCL OF CTRTLIAI
1485148500 END-IF
1486148600
1487148700
1488148800* IF NO ERRORS POSITION CURSOR
1489148900 IF INPUT-OK
1490149000 IF WS-ACTIONS-REQUESTED > 0
1491149100 AND NOT CCARD-AID-PFK07
1492149200 AND NOT CCARD-AID-PFK08
1493149300 CONTINUE
1494149400 ELSE
1495149500 MOVE -1 TO TRTYPEL OF CTRTLIAI
1496149600 END-IF
1497149700 END-IF
1498149800 .
1499149900 2400-SETUP-SCREEN-ATTRS-EXIT.
1500150000 EXIT
1501150100 .
1502150200
1503150300
1504150400 2500-SETUP-MESSAGE.
1505150500* SETUP MESSAGE
1506150600 EVALUATE TRUE
1507150700 WHEN FLG-DELETED-YES
1508150800 SET WS-INFORM-DELETE-SUCCESS TO TRUE
1509150900 WHEN FLG-UPDATE-COMPLETED
1510151000 SET WS-INFORM-UPDATE-SUCCESS TO TRUE
1511151100 WHEN FLG-TYPEFILTER-NOT-OK
1512151200 WHEN FLG-DESCFILTER-NOT-OK
1513151300 CONTINUE
1514151400 WHEN CCARD-AID-ENTER
1515151500 AND WS-DELETES-REQUESTED > 0
1516151600 AND WS-ONLY-1-ACTION
1517151700 AND WS-ONLY-1-VALID-ACTION
1518151800 IF WS-NO-INFO-MESSAGE
1519151900 AND FLG-TYPEFILTER-CHANGED-NO
1520152000 AND FLG-DESCFILTER-CHANGED-NO
1521152100 SET WS-INFORM-DELETE TO TRUE
1522152200 END-IF
1523152300 WHEN CCARD-AID-ENTER
1524152400 AND WS-UPDATES-REQUESTED > 0
1525152500 AND WS-ONLY-1-ACTION
1526152600 AND WS-ONLY-1-VALID-ACTION
1527152700 IF WS-NO-INFO-MESSAGE
1528152800 AND FLG-TYPEFILTER-CHANGED-NO
1529152900 AND FLG-DESCFILTER-CHANGED-NO
1530153000 SET WS-INFORM-UPDATE TO TRUE
1531153100 END-IF
1532153200 WHEN CCARD-AID-PFK07
1533153300 AND CA-FIRST-PAGE
1534153400 MOVE 'No previous pages to display'
1535153500 TO WS-RETURN-MSG
1536153600 WHEN CCARD-AID-PFK08
1537153700 AND CA-NEXT-PAGE-NOT-EXISTS
1538153800 AND CA-LAST-PAGE-SHOWN
1539153900 MOVE 'No more pages to display'
1540154000 TO WS-RETURN-MSG
1541154100 WHEN CCARD-AID-PFK08
1542154200 AND CA-NEXT-PAGE-NOT-EXISTS
1543154300 IF WS-NO-INFO-MESSAGE
1544154400 SET WS-INFORM-REC-ACTIONS TO TRUE
1545154500 END-IF
1546154600 IF CA-LAST-PAGE-NOT-SHOWN
1547154700 AND CA-NEXT-PAGE-NOT-EXISTS
1548154800 SET CA-LAST-PAGE-SHOWN TO TRUE
1549154900 END-IF
1550155000 WHEN WS-NO-INFO-MESSAGE
1551155100 WHEN CA-NEXT-PAGE-EXISTS
1552155200 SET WS-INFORM-REC-ACTIONS TO TRUE
1553155300 WHEN OTHER
1554155400 SET WS-NO-INFO-MESSAGE TO TRUE
1555155500 END-EVALUATE
1556155600
1557155700 MOVE WS-RETURN-MSG TO ERRMSGO OF CTRTLIAO
1558155800
1559155900
1560156000* Center justify the text
1561156100*
1562156200 COMPUTE WS-STRING-LEN =
1563156300 FUNCTION LENGTH(
1564156400 FUNCTION TRIM(WS-INFO-MSG)
1565156500 )
1566156600 COMPUTE WS-STRING-MID =
1567156700 (FUNCTION LENGTH(WS-INFO-MSG)
1568156800 - WS-STRING-LEN) / 2 + 1
1569156900 MOVE WS-INFO-MSG(1:WS-STRING-LEN)
1570157000 TO WS-STRING-OUT(WS-STRING-MID:
1571157100 WS-STRING-LEN)
1572157200
1573157300
1574157400
1575157500 IF NOT WS-NO-INFO-MESSAGE
1576157600 AND NOT WS-MESG-NO-RECORDS-FOUND
1577157700 MOVE WS-STRING-OUT TO INFOMSGO OF CTRTLIAO
1578157800 MOVE DFHNEUTR TO INFOMSGC OF CTRTLIAO
1579157900 END-IF
1580158000
1581158100 .
1582158200 2500-SETUP-MESSAGE-EXIT.
1583158300 EXIT
1584158400 .
1585158500
1586158600
1587158700 2600-SEND-SCREEN.
1588158800 EXEC CICS SEND MAP(LIT-THISMAP)
1589158900 MAPSET(LIT-THISMAPSET)
1590159000 FROM(CTRTLIAO)
1591159100 CURSOR
1592159200 ERASE
1593159300 RESP(WS-RESP-CD)
1594159400 FREEKB
1595159500 END-EXEC
1596159600 .
1597159700 2600-SEND-SCREEN-EXIT.
1598159800 EXIT
1599159900 .
1600160000
1601160100
1602160200
1603160300 8000-READ-FORWARD.
1604160400 MOVE LOW-VALUES TO WS-CA-ALL-ROWS-OUT
1605160500
1606160600*****************************************************************
1607160700* Start Reading
1608160800*****************************************************************
1609160900 PERFORM 9400-OPEN-FORWARD-CURSOR
1610161000 THRU 9400-OPEN-FORWARD-CURSOR-EXIT
1611161100
1612161200 IF WS-DB2-ERROR
1613161300 GO TO 8000-READ-FORWARD-EXIT
1614161400 END-IF
1615161500*****************************************************************
1616161600* Loop through records and fetch max screen records
1617161700*****************************************************************
1618161800 MOVE ZEROES TO WS-ROW-NUMBER
1619161900 SET CA-NEXT-PAGE-EXISTS TO TRUE
1620162000 SET MORE-RECORDS-TO-READ TO TRUE
1621162100
1622162200 PERFORM UNTIL READ-LOOP-EXIT
1623162300
1624162400 INITIALIZE DCLTRANSACTION-TYPE
1625162500
1626162600 EXEC SQL
1627162700 FETCH C-TR-TYPE-FORWARD
1628162800 INTO :DCL-TR-TYPE
1629162900 ,:DCL-TR-DESCRIPTION
1630163000 END-EXEC
1631163100
1632163200 MOVE SQLCODE TO WS-DISP-SQLCODE
1633163300
1634163400 EVALUATE TRUE
1635163500 WHEN SQLCODE = ZERO
1636163600 ADD 1 TO WS-ROW-NUMBER
1637163700
1638163800 MOVE DCL-TR-TYPE TO WS-CA-ROW-TR-CODE-OUT(
1639163900 WS-ROW-NUMBER)
1640164000
1641164100 MOVE DCL-TR-DESCRIPTION-TEXT
1642164200 TO WS-CA-ROW-TR-DESC-OUT(
1643164300 WS-ROW-NUMBER)
1644164400 IF WS-ROW-NUMBER = 1
1645164500 MOVE DCL-TR-TYPE TO WS-CA-FIRST-TR-CODE
1646164600 IF WS-CA-SCREEN-NUM = 0
1647164700 ADD +1 TO WS-CA-SCREEN-NUM
1648164800 ELSE
1649164900 CONTINUE
1650165000 END-IF
1651165100 ELSE
1652165200 CONTINUE
1653165300 END-IF
1654165400******************************************************************
1655165500* Max Screen size
1656165600******************************************************************
1657165700 IF WS-ROW-NUMBER = WS-MAX-SCREEN-LINES
1658165800 SET READ-LOOP-EXIT TO TRUE
1659165900 MOVE DCL-TR-TYPE TO WS-CA-LAST-TR-CODE
1660166000
1661166100 EXEC SQL
1662166200 FETCH C-TR-TYPE-FORWARD
1663166300 INTO :DCL-TR-TYPE
1664166400 ,:DCL-TR-DESCRIPTION
1665166500 END-EXEC
1666166600
1667166700 MOVE SQLCODE TO WS-DISP-SQLCODE
1668166800
1669166900 EVALUATE TRUE
1670167000 WHEN SQLCODE = ZERO
1671167100 SET CA-NEXT-PAGE-EXISTS
1672167200 TO TRUE
1673167300 MOVE DCL-TR-TYPE TO WS-CA-LAST-TR-CODE
1674167400 WHEN SQLCODE = +100
1675167500 SET CA-NEXT-PAGE-NOT-EXISTS TO TRUE
1676167600
1677167700 IF WS-RETURN-MSG-OFF
1678167800 AND CCARD-AID-PFK08
1679167900 SET WS-MESG-NO-MORE-RECORDS TO TRUE
1680168000 END-IF
1681168100 WHEN OTHER
1682168200* This is some kind of error. Close Cursor
1683168300* And exit
1684168400 SET READ-LOOP-EXIT TO TRUE
1685168500 IF WS-RETURN-MSG-OFF
1686168600 MOVE 'C-TR-TYPE-FORWARD fetch'
1687168700 TO
1688168800 WS-DB2-CURRENT-ACTION
1689168900 PERFORM 9999-FORMAT-DB2-MESSAGE
1690169000 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1691169100 END-IF
1692169200 END-EVALUATE
1693169300 END-IF
1694169400 WHEN SQLCODE = +100
1695169500 SET READ-LOOP-EXIT TO TRUE
1696169600 SET CA-NEXT-PAGE-NOT-EXISTS TO TRUE
1697169700 MOVE DCL-TR-TYPE TO WS-CA-LAST-TR-CODE
1698169800 IF WS-RETURN-MSG-OFF
1699169900 AND CCARD-AID-PFK08
1700170000 SET WS-MESG-NO-MORE-RECORDS TO TRUE
1701170100 END-IF
1702170200 IF WS-CA-SCREEN-NUM = 1
1703170300 AND WS-ROW-NUMBER = 0
1704170400 SET WS-MESG-NO-RECORDS-FOUND TO TRUE
1705170500 END-IF
1706170600 WHEN OTHER
1707170700* This is some kind of error. Change to END BR
1708170800* And exit
1709170900 SET READ-LOOP-EXIT TO TRUE
1710171000 SET WS-DB2-ERROR TO TRUE
1711171100 IF WS-RETURN-MSG-OFF
1712171200 MOVE 'C-TR-TYPE-FORWARD close'
1713171300 TO WS-DB2-CURRENT-ACTION
1714171400
1715171500 PERFORM 9999-FORMAT-DB2-MESSAGE
1716171600 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1717171700 END-IF
1718171800 END-EVALUATE
1719171900 END-PERFORM
1720172000
1721172100 PERFORM 9450-CLOSE-FORWARD-CURSOR
1722172200 THRU 9450-CLOSE-FORWARD-CURSOR-EXIT
1723172300 .
1724172400 8000-READ-FORWARD-EXIT.
1725172500 EXIT
1726172600 .
1727172700 8100-READ-BACKWARDS.
1728172800
1729172900 MOVE LOW-VALUES TO WS-CA-ALL-ROWS-OUT
1730173000
1731173100 MOVE WS-CA-FIRST-TTYPEKEY TO WS-CA-LAST-TTYPEKEY
1732173200*****************************************************************
1733173300* Loop through records and fetch max screen records
1734173400*****************************************************************
1735173500 COMPUTE WS-ROW-NUMBER =
1736173600 WS-MAX-SCREEN-LINES
1737173700 END-COMPUTE
1738173800 SET CA-NEXT-PAGE-EXISTS TO TRUE
1739173900 SET MORE-RECORDS-TO-READ TO TRUE
1740174000
1741174100*****************************************************************
1742174200* Now we show the records from previous set.
1743174300*****************************************************************
1744174400* Start Reading Backwards
1745174500*****************************************************************
1746174600 PERFORM 9500-OPEN-BACKWARD-CURSOR
1747174700 THRU 9500-OPEN-BACKWARD-CURSOR-EXIT
1748174800
1749174900 PERFORM UNTIL READ-LOOP-EXIT
1750175000
1751175100 INITIALIZE DCLTRANSACTION-TYPE
1752175200
1753175300 EXEC SQL
1754175400 FETCH C-TR-TYPE-BACKWARD
1755175500 INTO :DCL-TR-TYPE
1756175600 ,:DCL-TR-DESCRIPTION
1757175700 END-EXEC
1758175800
1759175900 MOVE SQLCODE TO WS-DISP-SQLCODE
1760176000
1761176100 EVALUATE TRUE
1762176200 WHEN SQLCODE = ZERO
1763176300 MOVE DCL-TR-TYPE
1764176400 TO WS-CA-ROW-TR-CODE-OUT(WS-ROW-NUMBER)
1765176500 MOVE DCL-TR-DESCRIPTION-TEXT
1766176600 TO
1767176700 WS-CA-ROW-TR-DESC-OUT(WS-ROW-NUMBER)
1768176800
1769176900 SUBTRACT 1 FROM WS-ROW-NUMBER
1770177000 IF WS-ROW-NUMBER = 0
1771177100 SET READ-LOOP-EXIT TO TRUE
1772177200 MOVE DCL-TR-TYPE
1773177300 TO WS-CA-FIRST-TR-CODE
1774177400 ELSE
1775177500 CONTINUE
1776177600 END-IF
1777177700 WHEN OTHER
1778177800* This is some kind of error. Change to END BR
1779177900* And exit
1780178000 SET READ-LOOP-EXIT TO TRUE
1781178100 SET WS-DB2-ERROR TO TRUE
1782178200
1783178300 IF WS-RETURN-MSG-OFF
1784178400 MOVE 'Error on fetch Cursor C-TR-TYPE-BACKWARD'
1785178500 TO WS-DB2-CURRENT-ACTION
1786178600 PERFORM 9999-FORMAT-DB2-MESSAGE
1787178700 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1788178800
1789178900 END-IF
1790179000 END-EVALUATE
1791179100 END-PERFORM
1792179200 .
1793179300
1794179400 8100-READ-BACKWARDS-EXIT.
1795179500 PERFORM 9550-CLOSE-BACK-CURSOR
1796179600 THRU 9550-CLOSE-BACK-CURSOR-EXIT
1797179700
1798179800 EXIT
1799179900 .
1800180000
1801180100 9100-CHECK-FILTERS.
1802180200
1803180300 EXEC SQL
1804180400 SELECT COUNT(1)
1805180500 INTO :WS-RECORDS-COUNT
1806180600 FROM CARDDEMO.TRANSACTION_TYPE
1807180700 WHERE ((:WS-EDIT-TYPE-FLAG = '1'
1808180900 AND TR_TYPE = :WS-TYPE-CD-FILTER)
1809181000 OR :WS-EDIT-TYPE-FLAG <> '1')
1810181200 AND
1811181300 ((:WS-EDIT-DESC-FLAG = '1'
1812181500 AND TR_DESCRIPTION LIKE
1813181600 TRIM(:WS-TYPE-DESC-FILTER))
1814181700 OR :WS-EDIT-DESC-FLAG <> '1')
1815181900 END-EXEC
1816182000
1817182100 MOVE SQLCODE TO WS-DISP-SQLCODE
1818182200
1819182300 EVALUATE TRUE
1820182400 WHEN SQLCODE = ZERO
1821182500 CONTINUE
1822182600 WHEN OTHER
1823182700 SET INPUT-ERROR TO TRUE
1824182800
1825182900 IF WS-RETURN-MSG-OFF
1826183000 MOVE 'Error reading TRANSACTION_TYPE table '
1827183100 TO WS-DB2-CURRENT-ACTION
1828183200 PERFORM 9999-FORMAT-DB2-MESSAGE
1829183300 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1830183400 END-IF
1831183500 GO TO 9100-CHECK-FILTERS-EXIT
1832183600 END-EVALUATE
1833183700 .
1834183800 9100-CHECK-FILTERS-EXIT.
1835183900 EXIT
1836184000 .
1837184100 9200-UPDATE-RECORD.
1838184200
1839184300 MOVE WS-ROW-TR-CODE-IN (I-SELECTED)
1840184400 TO DCL-TR-TYPE
1841184500 MOVE FUNCTION TRIM(WS-ROW-TR-DESC-IN (I-SELECTED))
1842184600 TO DCL-TR-DESCRIPTION-TEXT
1843184700 COMPUTE DCL-TR-DESCRIPTION-LEN
1844184800 = FUNCTION LENGTH(WS-ROW-TR-DESC-IN (I-SELECTED))
1845184900
1846185000 EXEC SQL
1847185100 UPDATE CARDDEMO.TRANSACTION_TYPE
1848185200 SET TR_DESCRIPTION = :DCL-TR-DESCRIPTION
1849185300 WHERE TR_TYPE = :DCL-TR-TYPE
1850185400 END-EXEC
1851185500
1852185600 MOVE SQLCODE TO WS-DISP-SQLCODE
1853185700
1854185800 EVALUATE TRUE
1855185900 WHEN SQLCODE = ZERO
1856186000 EXEC CICS SYNCPOINT END-EXEC
1857186100 SET CA-UPDATE-SUCCEEDED TO TRUE
1858186200 IF WS-NO-INFO-MESSAGE
1859186300 SET WS-INFORM-UPDATE-SUCCESS TO TRUE
1860186400 END-IF
1861186500 WHEN SQLCODE = +100
1862186600 SET CA-UPDATE-REQUESTED TO TRUE
1863186700 IF WS-RETURN-MSG-OFF
1864186800 MOVE 'Record not found. Deleted by others ? '
1865186900 TO WS-DB2-CURRENT-ACTION
1866187000 PERFORM 9999-FORMAT-DB2-MESSAGE
1867187100 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1868187200 END-IF
1869187300 GO TO 9200-UPDATE-RECORD-EXIT
1870187400 WHEN SQLCODE = -911
1871187500 SET CA-UPDATE-REQUESTED TO TRUE
1872187600 SET INPUT-ERROR TO TRUE
1873187700 IF WS-RETURN-MSG-OFF
1874187800 MOVE 'Deadlock. Someone else updating ?'
1875187900 TO WS-DB2-CURRENT-ACTION
1876188000 PERFORM 9999-FORMAT-DB2-MESSAGE
1877188100 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1878188200 END-IF
1879188300 GO TO 9200-UPDATE-RECORD-EXIT
1880188400 WHEN SQLCODE < 0
1881188500 SET CA-UPDATE-REQUESTED TO TRUE
1882188600 IF WS-RETURN-MSG-OFF
1883188700 MOVE 'Update failed with'
1884188800 TO WS-DB2-CURRENT-ACTION
1885188900 PERFORM 9999-FORMAT-DB2-MESSAGE
1886189000 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1887189100 END-IF
1888189200 GO TO 9200-UPDATE-RECORD-EXIT
1889189300 END-EVALUATE
1890189400 .
1891189500
1892189600 9200-UPDATE-RECORD-EXIT.
1893189700 EXIT
1894189800 .
1895189900
1896190000 9300-DELETE-RECORD.
1897190100
1898190200 MOVE WS-ROW-TR-CODE-IN (I-SELECTED) TO DCL-TR-TYPE
1899190300
1900190400 EXEC SQL
1901190500 DELETE FROM CARDDEMO.TRANSACTION_TYPE
1902190600 WHERE TR_TYPE = :DCL-TR-TYPE
1903190700 END-EXEC
1904190800
1905190900 MOVE SQLCODE TO WS-DISP-SQLCODE
1906191000
1907191100 EVALUATE TRUE
1908191200 WHEN SQLCODE = ZERO
1909191300 EXEC CICS SYNCPOINT END-EXEC
1910191400 SET CA-DELETE-SUCCEEDED TO TRUE
1911191500 IF WS-NO-INFO-MESSAGE
1912191600 SET WS-INFORM-DELETE-SUCCESS TO TRUE
1913191700 END-IF
1914191800 WHEN SQLCODE = -532
1915191900 SET CA-DELETE-REQUESTED TO TRUE
1916192000
1917192100 IF WS-RETURN-MSG-OFF
1918192200 MOVE
1919192300 'Please delete associated child records first:'
1920192400 TO WS-DB2-CURRENT-ACTION
1921192500 PERFORM 9999-FORMAT-DB2-MESSAGE
1922192600 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1923192700 END-IF
1924192800
1925192900 GO TO 9300-DELETE-RECORD-EXIT
1926193000 WHEN OTHER
1927193100 IF WS-RETURN-MSG-OFF
1928193200 MOVE
1929193300 'Delete failed with message:'
1930193400 TO WS-DB2-CURRENT-ACTION
1931193500 PERFORM 9999-FORMAT-DB2-MESSAGE
1932193600 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1933193700 END-IF
1934193800 GO TO 9300-DELETE-RECORD-EXIT
1935193900 END-EVALUATE
1936194000 .
1937194100
1938194200 9300-DELETE-RECORD-EXIT.
1939194300 EXIT
1940194400 .
1941194500
1942194600 9400-OPEN-FORWARD-CURSOR.
1943194700 EXEC SQL
1944194800 OPEN C-TR-TYPE-FORWARD
1945194900 END-EXEC
1946195000
1947195100 MOVE SQLCODE TO WS-DISP-SQLCODE
1948195200
1949195300 EVALUATE TRUE
1950195400 WHEN SQLCODE = ZERO
1951195500 CONTINUE
1952195600 WHEN OTHER
1953195700* This is some kind of error. Close Cursor
1954195800* And exit
1955195900 SET WS-DB2-ERROR TO TRUE
1956196000 IF WS-RETURN-MSG-OFF
1957196100 MOVE
1958196200 'C-TR-TYPE-FORWARD Open'
1959196300 TO WS-DB2-CURRENT-ACTION
1960196400 PERFORM 9999-FORMAT-DB2-MESSAGE
1961196500 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1962196600 END-IF
1963196700 END-EVALUATE
1964196800 .
1965196900 9400-OPEN-FORWARD-CURSOR-EXIT.
1966197000 EXIT
1967197100 .
1968197200
1969197300
1970197400 9450-CLOSE-FORWARD-CURSOR.
1971197500 EXEC SQL
1972197600 CLOSE C-TR-TYPE-FORWARD
1973197700 END-EXEC
1974197800
1975197900 MOVE SQLCODE TO WS-DISP-SQLCODE
1976198000
1977198100 EVALUATE TRUE
1978198200 WHEN SQLCODE = ZERO
1979198300 CONTINUE
1980198400 WHEN OTHER
1981198500* This is some kind of error. Close Cursor
1982198600* And exit
1983198700 SET WS-DB2-ERROR TO TRUE
1984198800 IF WS-RETURN-MSG-OFF
1985198900 MOVE
1986199000 'C-TR-TYPE-FORWARD close'
1987199100 TO WS-DB2-CURRENT-ACTION
1988199200 PERFORM 9999-FORMAT-DB2-MESSAGE
1989199300 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
1990199400 END-IF
1991199500 END-EVALUATE
1992199600 .
1993199700 9450-CLOSE-FORWARD-CURSOR-EXIT.
1994199800 EXIT
1995199900 .
1996200000
1997200100 9500-OPEN-BACKWARD-CURSOR.
1998200200 EXEC SQL
1999200300 OPEN C-TR-TYPE-BACKWARD
2000200400 END-EXEC
2001200500
2002200600 MOVE SQLCODE TO WS-DISP-SQLCODE
2003200700
2004200800 EVALUATE TRUE
2005200900 WHEN SQLCODE = ZERO
2006201000 CONTINUE
2007201100 WHEN OTHER
2008201200* This is some kind of error. Close Cursor
2009201300* And exit
2010201400 SET WS-DB2-ERROR TO TRUE
2011201500 IF WS-RETURN-MSG-OFF
2012201600 MOVE
2013201700 'C-TR-TYPE-BACKWARD Open'
2014201800 TO WS-DB2-CURRENT-ACTION
2015201900 PERFORM 9999-FORMAT-DB2-MESSAGE
2016202000 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
2017202100 END-IF
2018202200*
2019202300 END-EVALUATE
2020202400 .
2021202500 9500-OPEN-BACKWARD-CURSOR-EXIT.
2022202600 EXIT
2023202700 .
2024202800
2025202900
2026203000 9550-CLOSE-BACK-CURSOR.
2027203100 EXEC SQL
2028203200 CLOSE C-TR-TYPE-BACKWARD
2029203300 END-EXEC
2030203400
2031203500 MOVE SQLCODE TO WS-DISP-SQLCODE
2032203600
2033203700 EVALUATE TRUE
2034203800 WHEN SQLCODE = ZERO
2035203900 CONTINUE
2036204000 WHEN OTHER
2037204100* This is some kind of error. Close Cursor
2038204200* And exit
2039204300 SET WS-DB2-ERROR TO TRUE
2040204400 IF WS-RETURN-MSG-OFF
2041204500 MOVE
2042204600 'C-TR-TYPE-BACKWARD close'
2043204700 TO WS-DB2-CURRENT-ACTION
2044204800 PERFORM 9999-FORMAT-DB2-MESSAGE
2045204900 THRU 9999-FORMAT-DB2-MESSAGE-EXIT
2046205000 END-IF
2047205100 END-EVALUATE
2048205200 .
2049205300 9550-CLOSE-BACK-CURSOR-EXIT.
2050205400 EXIT
2051205500 .
2052205600*****************************************************************
2053205700*Common Db2 routines
2054205800*****************************************************************
2055205900 EXEC SQL INCLUDE CSDB2RPY END-EXEC
2056206000
2057206100*****************************************************************
2058206200*Common code to store PFKey
2059206300*****************************************************************
2060206400 COPY 'CSSTRPFY'
2061206500 .
2062206600
2063206700*****************************************************************
2064206800* Plain text exit - Dont use in production *
2065206900*****************************************************************
2066207000 SEND-PLAIN-TEXT.
2067207100 EXEC CICS SEND TEXT
2068207200 FROM(WS-RETURN-MSG)
2069207300 LENGTH(LENGTH OF WS-RETURN-MSG)
2070207400 ERASE
2071207500 FREEKB
2072207600 END-EXEC
2073207700
2074207800 EXEC CICS RETURN
2075207900 END-EXEC
2076208000 .
2077208100 SEND-PLAIN-TEXT-EXIT.
2078208200 EXIT
2079208300 .
2080208400*****************************************************************
2081208500* Display Long text and exit *
2082208600* This is primarily for debugging and should not be used in *
2083208700* regular course *
2084208800*****************************************************************
2085208900 SEND-LONG-TEXT.
2086209000 EXEC CICS SEND TEXT
2087209100 FROM(WS-LONG-MSG)
2088209200 LENGTH(LENGTH OF WS-LONG-MSG)
2089209300 ERASE
2090209400 FREEKB
2091209500 END-EXEC
2092209600
2093209700 EXEC CICS RETURN
2094209800 END-EXEC
2095209900 .
2096210000 SEND-LONG-TEXT-EXIT.
2097210100 EXIT
2098210200 .