MFmainframe-rea
WS carddemo · 26f629ef

Converted program · 615 lines of TypeScript from 1459 lines of COBOL · 1248 COBOL lines cited (86%)COCRDLIC

Run it on the 3270 →Analysis →All programs

TypeScript carddemo-ts/src/programs/COCRDLIC.ts

1/**
2 * COCRDLIC — list credit cards (transaction CCLI).
3 * Converted from app/cbl/COCRDLIC.cbl; screen COCRDLI/CCRDLIA; file CARDDAT browsed by card number.
4 *
5 * The header comment of the COBOL says non-admin users only see their account's cards,
6 * but the code never looks at CDEMO-USER-TYPE: every user browses all cards unless an
7 * account / card filter is typed. Converted as coded.
8 */
9import { digits, isNumericText } from "../runtime/cobol.js";
10import { RESP, type Cics, type CardDemoCommarea, type Program } from "../runtime/cics.js";
11import type { SymbolicMap } from "../runtime/screen.js";
12import type { CardRecord } from "../generated/records.js";
13import { populateHeaderInfo } from "./common.js";
14import {
15 BYTE,
16 CursorRequests,
17 cardNumIsZero,
18 fileErrorMessage,
19 initializeCommarea,
20 isLowOrSpaces,
21 receive,
22 resp2Of,
23 storePfkey,
24 xctlCommarea,
25 zonedIsZero,
26 type CcardAid,
27} from "./cards-lib.js";
28
29// WS-CONSTANTS (COCRDLIC.cbl:176-217)
30const WS_MAX_SCREEN_LINES = 7;
31const LIT_THISPGM = "COCRDLIC";
32const LIT_THISTRANID = "CCLI";
33const LIT_THISMAPSET = "COCRDLI";
34const LIT_THISMAP = "CCRDLIA";
35const LIT_MENUPGM = "COMEN01C";
36const LIT_CARDDTLPGM = "COCRDSLC";
37const LIT_CARDUPDPGM = "COCRDUPC";
38const LIT_CARD_FILE = "CARDDAT";
39
40// WS-INFO-MSG / WS-ERROR-MSG 88 levels (COCRDLIC.cbl:111-126)
41const WS_INFORM_REC_ACTIONS = "TYPE S FOR DETAIL, U TO UPDATE ANY RECORD";
42const WS_EXIT_MESSAGE = "PF03 PRESSED.EXITING";
43const WS_NO_RECORDS_FOUND = "NO RECORDS FOUND FOR THIS SEARCH CONDITION.";
44const WS_MORE_THAN_1_ACTION = "PLEASE SELECT ONLY ONE RECORD TO VIEW OR UPDATE";
45const WS_INVALID_ACTION_CODE = "INVALID ACTION CODE";
46
47/** WS-SCREEN-ROWS entry: null = LOW-VALUES (row not filled). */
48interface Row {
49 acctNo: string;
50 cardNum: string;
51 status: string;
52}
53
54/**
55 * WS-THIS-PROGCOMMAREA (COCRDLIC.cbl:229-260). WS-SCREEN-DATA is coded at level 05
56 * after level-10 items, so it belongs to this group and travels in the COMMAREA:
57 * the rows of the previous screen are still known on the next input.
58 */
59export interface CardListCommarea {
60 lastCardNum: string;
61 lastCardAcctId: number;
62 firstCardNum: string;
63 firstCardAcctId: number;
64 /** WS-CA-SCREEN-NUM PIC 9(1); 88 CA-FIRST-PAGE VALUE 1 */
65 screenNum: number;
66 /** WS-CA-LAST-PAGE-DISPLAYED PIC 9(1); 0 = CA-LAST-PAGE-SHOWN, 9 = CA-LAST-PAGE-NOT-SHOWN */
67 lastPageDisplayed: number;
68 /** WS-CA-NEXT-PAGE-IND: 'Y' = CA-NEXT-PAGE-EXISTS, "" (LOW-VALUES) = CA-NEXT-PAGE-NOT-EXISTS */
69 nextPageInd: string;
70 returnFlag: string;
71 rows: (Row | null)[];
72}
73
74/** INITIALIZE WS-THIS-PROGCOMMAREA: spaces and zeros (not LOW-VALUES). */
75function initialProgCommarea(): CardListCommarea {
76 return {
77 lastCardNum: "",
78 lastCardAcctId: 0,
79 firstCardNum: "",
80 firstCardAcctId: 0,
81 screenNum: 0,
82 lastPageDisplayed: 0,
83 nextPageInd: " ",
84 returnFlag: " ",
85 rows: Array.from({ length: WS_MAX_SCREEN_LINES }, () => ({ acctNo: "", cardNum: "", status: "" })),
86 };
87}
88
89/** WS-MISC-STORAGE (COCRDLIC.cbl:41-171) and CC-WORK-AREA (CVCRD01Y), both INITIALIZEd. */
90interface Task {
91 ctx: Cics;
92 area: CardDemoCommarea;
93 ext: CardListCommarea;
94 out: SymbolicMap;
95 cursor: CursorRequests;
96 ccardAid: CcardAid;
97 ccAcctId: string;
98 ccCardNum: string;
99 /** WS-INPUT-FLAG: '1' = INPUT-ERROR; '0', ' ' or LOW-VALUES = INPUT-OK */
100 inputFlag: string;
101 /** WS-EDIT-ACCT-FLAG / WS-EDIT-CARD-FLAG: '0' NOT-OK, '1' ISVALID, ' ' BLANK */
102 acctFlag: string;
103 cardFlag: string;
104 editSelect: string[];
105 selectErrors: string[];
106 iSelected: number;
107 /** FLG-PROTECT-SELECT-ROWS: '1' = YES, '0' = NO */
108 protectRows: string;
109 infoMsg: string;
110 errorMsg: string;
111 cardRidCardnum: string;
112 scrnCounter: number;
113 cardRecord: CardRecord | undefined;
114}
115
116export const COCRDLIC: Program = {
117 name: LIT_THISPGM,
118 source: "app/cbl/COCRDLIC.cbl",
119 run(ctx: Cics) {
120 // 0000-MAIN (COCRDLIC.cbl:298-602)
121 const area = ctx.area();
122 const t: Task = {
123 ctx,
124 area,
125 ext: ctx.ext(initialProgCommarea),
126 out: ctx.map(LIT_THISMAPSET, LIT_THISMAP),
127 cursor: new CursorRequests(),
128 ccardAid: "",
129 ccAcctId: "",
130 ccCardNum: "",
131 inputFlag: " ",
132 acctFlag: " ",
133 cardFlag: " ",
134 editSelect: Array.from({ length: 7 }, () => " "),
135 selectErrors: Array.from({ length: 7 }, () => " "),
136 iSelected: 0,
137 protectRows: " ",
138 infoMsg: "",
139 errorMsg: "", // SET WS-ERROR-MSG-OFF TO TRUE
140 cardRidCardnum: "",
141 scrnCounter: 0,
142 cardRecord: undefined,
143 };
144 const ext = t.ext;
145 const from = () => area.fromProgram.trim();
146
147 if (ctx.eib.calen === 0) {
148 initializeCommarea(area);
149 Object.assign(ext, initialProgCommarea());
150 area.fromTranid = LIT_THISTRANID;
151 area.fromProgram = LIT_THISPGM;
152 area.userType = "U"; // SET CDEMO-USRTYP-USER
153 area.pgmContext = 0;
154 area.lastMap = LIT_THISMAP;
155 area.lastMapset = LIT_THISMAPSET;
156 ext.screenNum = 1;
157 ext.lastPageDisplayed = 9;
158 }
159 // Coming in from another program (e.g. the menu): forget the past (:336-343).
160 if (area.pgmContext === 0 && from() !== LIT_THISPGM) {
161 Object.assign(ext, initialProgCommarea());
162 area.pgmContext = 0;
163 area.lastMap = LIT_THISMAP;
164 ext.screenNum = 1;
165 ext.lastPageDisplayed = 9;
166 }
167
168 t.ccardAid = storePfkey(ctx.eib.aid);
169
170 if (ctx.eib.calen > 0 && from() === LIT_THISPGM) receiveMapPara(t);
171
172 // F3 exit, ENTER list, F8 page down, F7 page up; anything else acts as ENTER (:370-380).
173 const pfkValid = ["ENTER", "PFK03", "PFK07", "PFK08"].includes(t.ccardAid);
174 if (!pfkValid) t.ccardAid = "ENTER";
175
176 if (t.ccardAid === "PFK03" && from() === LIT_THISPGM) {
177 // :384-406 back to the main menu
178 area.fromTranid = LIT_THISTRANID;
179 area.fromProgram = LIT_THISPGM;
180 area.userType = "U";
181 area.pgmContext = 0;
182 area.lastMapset = LIT_THISMAPSET;
183 area.lastMap = LIT_THISMAP;
184 area.toProgram = LIT_MENUPGM;
185 t.errorMsg = WS_EXIT_MESSAGE; // SET WS-EXIT-MESSAGE (never displayed); CCARD-NEXT-MAPSET/MAP unused
186 xctlCommarea(ctx, LIT_MENUPGM);
187 }
188
189 if (t.ccardAid !== "PFK08") ext.lastPageDisplayed = 9; // SET CA-LAST-PAGE-NOT-SHOWN
190
191 const firstPage = () => ext.screenNum === 1;
192 const selected = (code: string) => t.iSelected >= 1 && t.iSelected <= 7 && t.editSelect[t.iSelected - 1] === code;
193
194 // EVALUATE TRUE (:418-583)
195 if (t.inputFlag === "1") {
196 // Ask for corrections. WS-CARD-RID-CARDNUM is still the INITIALIZEd spaces here,
197 // so a selection error re-reads from the start of the file (faithful).
198 area.fromProgram = LIT_THISPGM;
199 area.lastMapset = LIT_THISMAPSET;
200 area.lastMap = LIT_THISMAP;
201 if (t.acctFlag !== "0" && t.cardFlag !== "0") readForward(t);
202 sendMap(t);
203 commonReturn(t);
204 } else if (t.ccardAid === "PFK07" && firstPage()) {
205 // :439-454 (the first, empty WHEN falls into this one)
206 t.cardRidCardnum = ext.firstCardNum;
207 readForward(t);
208 sendMap(t);
209 commonReturn(t);
210 } else if (t.ccardAid === "PFK03" || (area.pgmContext === 1 && from() !== LIT_THISPGM)) {
211 // :458-482 back from some other program (PF3 in COCRDSLC / COCRDUPC)
212 initializeCommarea(area);
213 Object.assign(ext, initialProgCommarea());
214 area.fromTranid = LIT_THISTRANID;
215 area.fromProgram = LIT_THISPGM;
216 area.userType = "U";
217 area.pgmContext = 0;
218 area.lastMap = LIT_THISMAP;
219 area.lastMapset = LIT_THISMAPSET;
220 ext.screenNum = 1;
221 ext.lastPageDisplayed = 9;
222 t.cardRidCardnum = ext.firstCardNum;
223 readForward(t);
224 sendMap(t);
225 commonReturn(t);
226 } else if (t.ccardAid === "PFK08" && ext.nextPageInd === "Y") {
227 // :486-497 page down
228 t.cardRidCardnum = ext.lastCardNum;
229 ext.screenNum = (ext.screenNum + 1) % 10; // PIC 9(1)
230 readForward(t);
231 sendMap(t);
232 commonReturn(t);
233 } else if (t.ccardAid === "PFK07" && !firstPage()) {
234 // :501-513 page up
235 t.cardRidCardnum = ext.firstCardNum;
236 ext.screenNum = Math.abs(ext.screenNum - 1) % 10; // unsigned PIC 9(1)
237 readBackwards(t);
238 sendMap(t);
239 commonReturn(t);
240 } else if (t.ccardAid === "ENTER" && selected("S") && from() === LIT_THISPGM) {
241 // :517-541 card detail view
242 transferTo(t, LIT_CARDDTLPGM);
243 } else if (t.ccardAid === "ENTER" && selected("U") && from() === LIT_THISPGM) {
244 // :545-569 card update
245 transferTo(t, LIT_CARDUPDPGM);
246 } else {
247 // :572-582
248 t.cardRidCardnum = ext.firstCardNum;
249 readForward(t);
250 sendMap(t);
251 commonReturn(t);
252 }
253 // :586-601 are unreachable: every WHEN ends in GO TO COMMON-RETURN or XCTL.
254 },
255};
256
257/** XCTL to COCRDSLC / COCRDUPC with the selected row (COCRDLIC.cbl:517-569). */
258function transferTo(t: Task, program: string): never {
259 const { area, ext } = t;
260 area.fromTranid = LIT_THISTRANID;
261 area.fromProgram = LIT_THISPGM;
262 area.userType = "U";
263 area.pgmContext = 0;
264 area.lastMapset = LIT_THISMAPSET;
265 area.lastMap = LIT_THISMAP;
266 const row = ext.rows[t.iSelected - 1];
267 // MOVE WS-ROW-ACCTNO (X(11)) TO CDEMO-ACCT-ID (9(11)); WS-ROW-CARD-NUM TO CDEMO-CARD-NUM
268 area.acctId = row && isNumericText(row.acctNo) ? Number(row.acctNo) : 0;
269 area.cardNum = row && isNumericText(row.cardNum.padEnd(16).slice(0, 16)) ? row.cardNum : "0".repeat(16);
270 xctlCommarea(t.ctx, program);
271}
272
273/** COMMON-RETURN (COCRDLIC.cbl:604-620) */
274function commonReturn(t: Task): never {
275 const { area } = t;
276 area.fromTranid = LIT_THISTRANID;
277 area.fromProgram = LIT_THISPGM;
278 area.lastMapset = LIT_THISMAPSET;
279 area.lastMap = LIT_THISMAP;
280 t.ctx.return(LIT_THISTRANID, area);
281}
282
283/** 1000-SEND-MAP (COCRDLIC.cbl:624-637) */
284function sendMap(t: Task): void {
285 screenInit(t);
286 screenArrayInit(t);
287 setupArrayAttribs(t);
288 setupScreenAttrs(t);
289 setupMessage(t);
290 sendScreen(t);
291}
292
293/** 1100-SCREEN-INIT (COCRDLIC.cbl:642-672) */
294function screenInit(t: Task): void {
295 const { out, ext } = t;
296 out.clear(); // MOVE LOW-VALUES TO CCRDLIAO
297 t.cursor.clear();
298 populateHeaderInfo(t.ctx, out, LIT_THISTRANID, LIT_THISPGM);
299 out.set("PAGENO", String(ext.screenNum));
300 t.infoMsg = ""; // SET WS-NO-INFO-MESSAGE
301 out.set("INFOMSG", " ".repeat(45));
302 // MOVE DFHBMDAR TO INFOMSGC moves an attribute value into the colour byte; the
303 // field holds spaces at this point, so nothing is visible either way.
304}
305
306/** 1200-SCREEN-ARRAY-INIT (COCRDLIC.cbl:678-743) */
307function screenArrayInit(t: Task): void {
308 for (let i = 1; i <= 7; i++) {
309 const row = t.ext.rows[i - 1];
310 if (!row) continue; // WS-EACH-CARD(i) = LOW-VALUES
311 t.out.set(`CRDSEL${i}`, t.editSelect[i - 1] === "" ? null : t.editSelect[i - 1]!);
312 t.out.set(`ACCTNO${i}`, row.acctNo);
313 t.out.set(`CRDNUM${i}`, row.cardNum);
314 t.out.set(`CRDSTS${i}`, row.status);
315 }
316}
317
318/**
319 * 1250-SETUP-ARRAY-ATTRIBS (COCRDLIC.cbl:748-832). Row 1 differs from rows 2-7 in the
320 * original: an empty / protected row 1 gets DFHBMPRF (others DFHBMPRO), and a row-1
321 * error shows '*' when blank but does not position the cursor. (Line 790 holds a stray
322 * 'I' token with no effect on the logic.)
323 */
324function setupArrayAttribs(t: Task): void {
325 const { out } = t;
326 for (let i = 1; i <= 7; i++) {
327 const name = `CRDSEL${i}`;
328 if (!t.ext.rows[i - 1] || t.protectRows === "1") {
329 out.attr(name, i === 1 ? BYTE.PRF : BYTE.PRO);
330 } else {
331 if (t.selectErrors[i - 1] === "1") {
332 out.color(name, "RED");
333 if (i === 1) {
334 if (isLowOrSpaces(t.editSelect[0]!, 1)) out.set(name, "*");
335 } else {
336 t.cursor.add(name);
337 }
338 }
339 out.attr(name, BYTE.FSE);
340 }
341 }
342}
343
344/** 1300-SETUP-SCREEN-ATTRS (COCRDLIC.cbl:837-889) */
345function setupScreenAttrs(t: Task): void {
346 const { ctx, area, out } = t;
347 if (!(ctx.eib.calen === 0 || (area.pgmContext === 0 && area.fromProgram.trim() === LIT_MENUPGM))) {
348 if (t.acctFlag === "1" || t.acctFlag === "0") {
349 out.set("ACCTSID", t.ccAcctId.replace(/\0/g, ""));
350 out.attr("ACCTSID", BYTE.FSE);
351 } else if (area.acctId === 0) {
352 out.set("ACCTSID", null);
353 } else {
354 out.set("ACCTSID", digits(area.acctId, 11));
355 out.attr("ACCTSID", BYTE.FSE);
356 }
357
358 if (t.cardFlag === "1" || t.cardFlag === "0") {
359 out.set("CARDSID", t.ccCardNum.replace(/\0/g, ""));
360 out.attr("CARDSID", BYTE.FSE);
361 } else if (cardNumIsZero(area.cardNum)) {
362 out.set("CARDSID", null);
363 } else {
364 out.set("CARDSID", area.cardNum);
365 out.attr("CARDSID", BYTE.FSE);
366 }
367 }
368 if (t.acctFlag === "0") {
369 out.color("ACCTSID", "RED");
370 t.cursor.add("ACCTSID");
371 }
372 if (t.cardFlag === "0") {
373 out.color("CARDSID", "RED");
374 t.cursor.add("CARDSID");
375 }
376 if (t.inputFlag !== "1") t.cursor.add("ACCTSID"); // INPUT-OK
377}
378
379/** 1400-SETUP-MESSAGE (COCRDLIC.cbl:895-932) */
380function setupMessage(t: Task): void {
381 const { ext, out } = t;
382 const nextNotExists = ext.nextPageInd === "";
383 if (t.acctFlag === "0" || t.cardFlag === "0") {
384 // CONTINUE
385 } else if (t.ccardAid === "PFK07" && ext.screenNum === 1) {
386 t.errorMsg = "NO PREVIOUS PAGES TO DISPLAY";
387 } else if (t.ccardAid === "PFK08" && nextNotExists && ext.lastPageDisplayed === 0) {
388 t.errorMsg = "NO MORE PAGES TO DISPLAY";
389 } else if (t.ccardAid === "PFK08" && nextNotExists) {
390 t.infoMsg = WS_INFORM_REC_ACTIONS;
391 if (ext.lastPageDisplayed === 9 && nextNotExists) ext.lastPageDisplayed = 0;
392 } else if (t.infoMsg === "" || ext.nextPageInd === "Y") {
393 t.infoMsg = WS_INFORM_REC_ACTIONS;
394 } else {
395 t.infoMsg = "";
396 }
397 out.set("ERRMSG", t.errorMsg);
398 if (t.infoMsg !== "" && t.errorMsg !== WS_NO_RECORDS_FOUND) {
399 out.set("INFOMSG", t.infoMsg);
400 out.color("INFOMSG", "NEUTRAL");
401 }
402}
403
404/** 1500-SEND-SCREEN (COCRDLIC.cbl:938-947): SEND MAP ... CURSOR ERASE FREEKB */
405function sendScreen(t: Task): void {
406 t.cursor.apply(t.out);
407 t.ctx.sendMap(t.out, { cursor: true, erase: true, freekb: true });
408}
409
410/** 2000-RECEIVE-MAP (COCRDLIC.cbl:951-957) */
411function receiveMapPara(t: Task): void {
412 receiveScreen(t);
413 editInputs(t);
414}
415
416/** 2100-RECEIVE-SCREEN (COCRDLIC.cbl:962-979) */
417function receiveScreen(t: Task): void {
418 const inp = receive(t.ctx, LIT_THISMAPSET, LIT_THISMAP);
419 t.out = inp;
420 t.ccAcctId = inp.get("ACCTSID");
421 t.ccCardNum = inp.get("CARDSID");
422 for (let i = 1; i <= 7; i++) t.editSelect[i - 1] = inp.get(`CRDSEL${i}`).slice(0, 1);
423}
424
425/** 2200-EDIT-INPUTS (COCRDLIC.cbl:985-997) */
426function editInputs(t: Task): void {
427 t.inputFlag = "0";
428 t.protectRows = "0";
429 editAccount(t);
430 editCard(t);
431 editArray(t);
432}
433
434/** 2210-EDIT-ACCOUNT (COCRDLIC.cbl:1003-1030) */
435function editAccount(t: Task): void {
436 t.acctFlag = " ";
437 if (isLowOrSpaces(t.ccAcctId, 11) || zonedIsZero(t.ccAcctId, 11)) {
438 t.acctFlag = " ";
439 t.area.acctId = 0;
440 return;
441 }
442 const x = t.ccAcctId.padEnd(11, " ").slice(0, 11);
443 if (!isNumericText(x)) {
444 t.inputFlag = "1";
445 t.acctFlag = "0";
446 t.protectRows = "1";
447 t.errorMsg = "ACCOUNT FILTER,IF SUPPLIED MUST BE A 11 DIGIT NUMBER";
448 t.area.acctId = 0;
449 return;
450 }
451 t.area.acctId = Number(x);
452 t.acctFlag = "1";
453}
454
455/** 2220-EDIT-CARD (COCRDLIC.cbl:1036-1067) */
456function editCard(t: Task): void {
457 t.cardFlag = " ";
458 if (isLowOrSpaces(t.ccCardNum, 16) || zonedIsZero(t.ccCardNum, 16)) {
459 t.cardFlag = " ";
460 t.area.cardNum = "0".repeat(16);
461 return;
462 }
463 const x = t.ccCardNum.padEnd(16, " ").slice(0, 16);
464 if (!isNumericText(x)) {
465 t.inputFlag = "1";
466 t.cardFlag = "0";
467 t.protectRows = "1";
468 if (t.errorMsg === "") t.errorMsg = "CARD ID FILTER,IF SUPPLIED MUST BE A 16 DIGIT NUMBER";
469 t.area.cardNum = "0".repeat(16);
470 return;
471 }
472 t.area.cardNum = x;
473 t.cardFlag = "1";
474}
475
476/** 2250-EDIT-ARRAY (COCRDLIC.cbl:1073-1117) */
477function editArray(t: Task): void {
478 if (t.inputFlag === "1") return;
479 // INSPECT WS-EDIT-SELECT-FLAGS TALLYING I FOR ALL 'S' ALL 'U'
480 const count = t.editSelect.filter((c) => c === "S" || c === "U").length;
481 if (count > 1) {
482 t.inputFlag = "1";
483 t.errorMsg = WS_MORE_THAN_1_ACTION;
484 t.selectErrors = t.editSelect.map((c) => (c === "S" || c === "U" ? "1" : "0"));
485 }
486 t.iSelected = 0;
487 for (let i = 1; i <= 7; i++) {
488 const c = t.editSelect[i - 1]!;
489 if (c === "S" || c === "U") {
490 t.iSelected = i;
491 if (t.errorMsg === WS_MORE_THAN_1_ACTION) t.selectErrors[i - 1] = "1";
492 } else if (c === " " || c === "") {
493 // SELECT-BLANK
494 } else {
495 t.inputFlag = "1";
496 t.selectErrors[i - 1] = "1";
497 if (t.errorMsg === "") t.errorMsg = WS_INVALID_ACTION_CODE;
498 }
499 }
500}
501
502function rowOf(card: CardRecord): Row {
503 return { acctNo: digits(card.cardAcctId, 11), cardNum: card.cardNum, status: card.cardActiveStatus };
504}
505
506function fileError(t: Task, resp: number): void {
507 t.errorMsg = fileErrorMessage("READ", LIT_CARD_FILE, resp, resp2Of(resp)).slice(0, 75);
508}
509
510/** 9000-READ-FORWARD (COCRDLIC.cbl:1123-1260) */
511function readForward(t: Task): void {
512 const { ctx, ext } = t;
513 ext.rows = Array.from({ length: 7 }, () => null); // MOVE LOW-VALUES TO WS-ALL-ROWS
514 ctx.startbr(LIT_CARD_FILE, t.cardRidCardnum); // GTEQ, RESP not tested
515 t.scrnCounter = 0;
516 ext.nextPageInd = "Y";
517 let more = true;
518 while (more) {
519 const r = ctx.readnext<CardRecord>(LIT_CARD_FILE);
520 if ((r.resp === RESP.NORMAL || r.resp === RESP.DUPREC) && r.record) {
521 t.cardRecord = r.record;
522 if (filterRecords(t, r.record)) {
523 t.scrnCounter++;
524 ext.rows[t.scrnCounter - 1] = rowOf(r.record);
525 if (t.scrnCounter === 1) {
526 ext.firstCardAcctId = r.record.cardAcctId;
527 ext.firstCardNum = r.record.cardNum;
528 if (ext.screenNum === 0) ext.screenNum++;
529 }
530 }
531 if (t.scrnCounter === WS_MAX_SCREEN_LINES) {
532 more = false;
533 ext.lastCardAcctId = r.record.cardAcctId;
534 ext.lastCardNum = r.record.cardNum;
535 // Look ahead one record (not filtered) to know whether a next page exists.
536 const n = ctx.readnext<CardRecord>(LIT_CARD_FILE);
537 if ((n.resp === RESP.NORMAL || n.resp === RESP.DUPREC) && n.record) {
538 t.cardRecord = n.record;
539 ext.nextPageInd = "Y";
540 ext.lastCardAcctId = n.record.cardAcctId;
541 ext.lastCardNum = n.record.cardNum;
542 } else if (n.resp === RESP.ENDFILE) {
543 ext.nextPageInd = "";
544 if (t.errorMsg === "") t.errorMsg = "NO MORE RECORDS TO SHOW";
545 } else {
546 more = false;
547 fileError(t, n.resp);
548 }
549 }
550 } else if (r.resp === RESP.ENDFILE) {
551 more = false;
552 ext.nextPageInd = "";
553 // CARD-RECORD still holds the last record read (READNEXT ENDFILE leaves INTO alone).
554 ext.lastCardAcctId = t.cardRecord?.cardAcctId ?? 0;
555 ext.lastCardNum = t.cardRecord?.cardNum ?? "";
556 if (t.errorMsg === "") t.errorMsg = "NO MORE RECORDS TO SHOW";
557 if (ext.screenNum === 1 && t.scrnCounter === 0) t.errorMsg = WS_NO_RECORDS_FOUND;
558 } else {
559 more = false;
560 fileError(t, r.resp);
561 }
562 }
563 ctx.endbr(LIT_CARD_FILE);
564}
565
566/** 9100-READ-BACKWARDS (COCRDLIC.cbl:1264-1380) */
567function readBackwards(t: Task): void {
568 const { ctx, ext } = t;
569 ext.rows = Array.from({ length: 7 }, () => null);
570 ext.lastCardNum = ext.firstCardNum; // MOVE WS-CA-FIRST-CARDKEY TO WS-CA-LAST-CARDKEY
571 ext.lastCardAcctId = ext.firstCardAcctId;
572 ctx.startbr(LIT_CARD_FILE, t.cardRidCardnum);
573 t.scrnCounter = WS_MAX_SCREEN_LINES + 1;
574 ext.nextPageInd = "Y";
575 let more = true;
576
577 // The first READPREV returns the record the browse started on (the current first row).
578 const first = ctx.readprev<CardRecord>(LIT_CARD_FILE);
579 if ((first.resp === RESP.NORMAL || first.resp === RESP.DUPREC) && first.record) {
580 t.cardRecord = first.record;
581 t.scrnCounter--;
582 } else {
583 more = false;
584 fileError(t, first.resp);
585 ctx.endbr(LIT_CARD_FILE); // GO TO 9100-READ-BACKWARDS-EXIT, which ends the browse
586 return;
587 }
588
589 while (more) {
590 const r = ctx.readprev<CardRecord>(LIT_CARD_FILE);
591 if ((r.resp === RESP.NORMAL || r.resp === RESP.DUPREC) && r.record) {
592 t.cardRecord = r.record;
593 if (filterRecords(t, r.record)) {
594 ext.rows[t.scrnCounter - 1] = rowOf(r.record);
595 t.scrnCounter--;
596 if (t.scrnCounter === 0) {
597 more = false;
598 ext.firstCardAcctId = r.record.cardAcctId;
599 ext.firstCardNum = r.record.cardNum;
600 }
601 }
602 } else {
603 more = false;
604 fileError(t, r.resp);
605 }
606 }
607 ctx.endbr(LIT_CARD_FILE);
608}
609
610/** 9500-FILTER-RECORDS (COCRDLIC.cbl:1382-1407): true = WS-DONOT-EXCLUDE-THIS-RECORD */
611function filterRecords(t: Task, card: CardRecord): boolean {
612 if (t.acctFlag === "1" && digits(card.cardAcctId, 11) !== t.ccAcctId.padEnd(11, " ").slice(0, 11)) return false;
613 if (t.cardFlag === "1" && card.cardNum !== t.ccCardNum.padEnd(16, " ").slice(0, 16)) return false;
614 return true;
615}

COBOL app/cbl/COCRDLIC.cbl

1 *****************************************************************
2 * Program: COCRDLIC.CBL *
3 * Layer: Business logic *
4 * Function: List Credit Cards
5 * a) All cards if no context passed and admin user
6 * b) Only the ones associated with ACCT in COMMAREA
7 * if user is not admin
8 ******************************************************************
9 * Copyright Amazon.com, Inc. or its affiliates.
10 * All Rights Reserved.
11 *
12 * Licensed under the Apache License, Version 2.0 (the "License").
13 * You may not use this file except in compliance with the License.
14 * You may obtain a copy of the License at
15 *
16 * http://www.apache.org/licenses/LICENSE-2.0
17 *
18 * Unless required by applicable law or agreed to in writing,
19 * software distributed under the License is distributed on an
20 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
21 * either express or implied. See the License for the specific
22 * language governing permissions and limitations under the License
23 ******************************************************************
24
25 IDENTIFICATION DIVISION.
26 PROGRAM-ID.
27 COCRDLIC.
28 DATE-WRITTEN.
29 April 2022.
30 DATE-COMPILED.
31 Today.
32
33 ENVIRONMENT DIVISION.
34 INPUT-OUTPUT SECTION.
35
36 DATA DIVISION.
37
38 WORKING-STORAGE SECTION.
39
40
41 01 WS-MISC-STORAGE.
42 ******************************************************************
43 * General CICS related
44 ******************************************************************
45
46 05 WS-CICS-PROCESSNG-VARS.
47 07 WS-RESP-CD PIC S9(09) COMP
48 VALUE ZEROS.
49 07 WS-REAS-CD PIC S9(09) COMP
50 VALUE ZEROS.
51 07 WS-TRANID PIC X(4)
52 VALUE SPACES.
53 ******************************************************************
54 * Input edits
55 ******************************************************************
56 05 WS-INPUT-FLAG PIC X(1).
57 88 INPUT-OK VALUES '0'
58 ' '
59 LOW-VALUES.
60 88 INPUT-ERROR VALUE '1'.
61 05 WS-EDIT-ACCT-FLAG PIC X(1).
62 88 FLG-ACCTFILTER-NOT-OK VALUE '0'.
63 88 FLG-ACCTFILTER-ISVALID VALUE '1'.
64 88 FLG-ACCTFILTER-BLANK VALUE ' '.
65 05 WS-EDIT-CARD-FLAG PIC X(1).
66 88 FLG-CARDFILTER-NOT-OK VALUE '0'.
67 88 FLG-CARDFILTER-ISVALID VALUE '1'.
68 88 FLG-CARDFILTER-BLANK VALUE ' '.
69 05 WS-EDIT-SELECT-COUNTER PIC S9(04)
70 USAGE COMP-3
71 VALUE 0.
72 05 WS-EDIT-SELECT-FLAGS PIC X(7)
73 VALUE LOW-VALUES.
74 05 WS-EDIT-SELECT-ARRAY REDEFINES WS-EDIT-SELECT-FLAGS.
75 10 WS-EDIT-SELECT PIC X(1)
76 OCCURS 7 TIMES.
77 88 SELECT-OK VALUES 'S', 'U'.
78 88 VIEW-REQUESTED-ON VALUE 'S'.
79 88 UPDATE-REQUESTED-ON VALUE 'U'.
80 88 SELECT-BLANK VALUES
81 ' ',
82 LOW-VALUES.
83 05 WS-EDIT-SELECT-ERROR-FLAGS PIC X(7).
84 05 WS-EDIT-SELECT-ERROR-FLAGX REDEFINES
85 WS-EDIT-SELECT-ERROR-FLAGS.
86 10 WS-EDIT-SELECT-ERRORS OCCURS 7 TIMES.
87 20 WS-ROW-CRDSELECT-ERROR PIC X(1).
88 88 WS-ROW-SELECT-ERROR VALUE '1'.
89 05 WS-SUBSCRIPT-VARS.
90 10 I PIC S9(4) COMP
91 VALUE 0.
92 10 I-SELECTED PIC S9(4) COMP
93 VALUE 0.
94 88 DETAIL-WAS-REQUESTED VALUES 1 THRU 7.
95 ******************************************************************
96 * Output edits
97 ******************************************************************
98 05 CICS-OUTPUT-EDIT-VARS.
99 10 CARD-ACCT-ID-X PIC X(11).
100 10 CARD-ACCT-ID-N REDEFINES CARD-ACCT-ID-X
101 PIC 9(11).
102 10 CARD-CVV-CD-X PIC X(03).
103 10 CARD-CVV-CD-N REDEFINES CARD-CVV-CD-X
104 PIC 9(03).
105 10 FLG-PROTECT-SELECT-ROWS PIC X(1).
106 88 FLG-PROTECT-SELECT-ROWS-NO VALUE '0'.
107 88 FLG-PROTECT-SELECT-ROWS-YES VALUE '1'.
108 ******************************************************************
109 * Output Message Construction
110 ******************************************************************
111 05 WS-LONG-MSG PIC X(500).
112 05 WS-INFO-MSG PIC X(45).
113 88 WS-NO-INFO-MESSAGE VALUES
114 SPACES LOW-VALUES.
115 88 WS-INFORM-REC-ACTIONS VALUE
116 'TYPE S FOR DETAIL, U TO UPDATE ANY RECORD'.
117 05 WS-ERROR-MSG PIC X(75).
118 88 WS-ERROR-MSG-OFF VALUE SPACES.
119 88 WS-EXIT-MESSAGE VALUE
120 'PF03 PRESSED.EXITING'.
121 88 WS-NO-RECORDS-FOUND VALUE
122 'NO RECORDS FOUND FOR THIS SEARCH CONDITION.'.
123 88 WS-MORE-THAN-1-ACTION VALUE
124 'PLEASE SELECT ONLY ONE RECORD TO VIEW OR UPDATE'.
125 88 WS-INVALID-ACTION-CODE VALUE
126 'INVALID ACTION CODE'.
127 05 WS-PFK-FLAG PIC X(1).
128 88 PFK-VALID VALUE '0'.
129 88 PFK-INVALID VALUE '1'.
130 05 WS-CONTEXT-FLAG PIC X(1).
131 88 WS-CONTEXT-FRESH-START VALUE '0'.
132 88 WS-CONTEXT-FRESH-START-NO VALUE '1'.
133 ******************************************************************
134 * File and data Handling
135 ******************************************************************
136 05 WS-FILE-HANDLING-VARS.
137 10 WS-CARD-RID.
138 20 WS-CARD-RID-CARDNUM PIC X(16).
139 20 WS-CARD-RID-ACCT-ID PIC 9(11).
140 20 WS-CARD-RID-ACCT-ID-X REDEFINES
141 WS-CARD-RID-ACCT-ID PIC X(11).
142
143
144
145 05 WS-SCRN-COUNTER PIC S9(4) COMP VALUE 0.
146
147 05 WS-FILTER-RECORD-FLAG PIC X(1).
148 88 WS-EXCLUDE-THIS-RECORD VALUE '0'.
149 88 WS-DONOT-EXCLUDE-THIS-RECORD VALUE '1'.
150 05 WS-RECORDS-TO-PROCESS-FLAG PIC X(1).
151 88 READ-LOOP-EXIT VALUE '0'.
152 88 MORE-RECORDS-TO-READ VALUE '1'.
153 05 WS-FILE-ERROR-MESSAGE.
154 10 FILLER PIC X(12)
155 VALUE 'File Error:'.
156 10 ERROR-OPNAME PIC X(8)
157 VALUE SPACES.
158 10 FILLER PIC X(4)
159 VALUE ' on '.
160 10 ERROR-FILE PIC X(9)
161 VALUE SPACES.
162 10 FILLER PIC X(15)
163 VALUE
164 ' returned RESP '.
165 10 ERROR-RESP PIC X(10)
166 VALUE SPACES.
167 10 FILLER PIC X(7)
168 VALUE ',RESP2 '.
169 10 ERROR-RESP2 PIC X(10)
170 VALUE SPACES.
171 10 FILLER PIC X(5).
172
173 ******************************************************************
174 * Literals and Constants
175 ******************************************************************
176 01 WS-CONSTANTS.
177 05 WS-MAX-SCREEN-LINES PIC S9(4) COMP
178 VALUE 7.
179 05 LIT-THISPGM PIC X(8)
180 VALUE 'COCRDLIC'.
181 05 LIT-THISTRANID PIC X(4)
182 VALUE 'CCLI'.
183 05 LIT-THISMAPSET PIC X(7)
184 VALUE 'COCRDLI'.
185 05 LIT-THISMAP PIC X(7)
186 VALUE 'CCRDLIA'.
187 05 LIT-MENUPGM PIC X(8)
188 VALUE 'COMEN01C'.
189 05 LIT-MENUTRANID PIC X(4)
190 VALUE 'CM00'.
191 05 LIT-MENUMAPSET PIC X(7)
192 VALUE 'COMEN01'.
193 05 LIT-MENUMAP PIC X(7)
194 VALUE 'COMEN1A'.
195 05 LIT-CARDDTLPGM PIC X(8)
196 VALUE 'COCRDSLC'.
197 05 LIT-CARDDTLTRANID PIC X(4)
198 VALUE 'CCDL'.
199 05 LIT-CARDDTLMAPSET PIC X(7)
200 VALUE 'COCRDSL'.
201 05 LIT-CARDDTLMAP PIC X(7)
202 VALUE 'CCRDSLA'.
203 05 LIT-CARDUPDPGM PIC X(8)
204 VALUE 'COCRDUPC'.
205 05 LIT-CARDUPDTRANID PIC X(4)
206 VALUE 'CCUP'.
207 05 LIT-CARDUPDMAPSET PIC X(7)
208 VALUE 'COCRDUP'.
209 05 LIT-CARDUPDMAP PIC X(7)
210 VALUE 'CCRDUPA'.
211
212
213 05 LIT-CARD-FILE PIC X(8)
214 VALUE 'CARDDAT '.
215 05 LIT-CARD-FILE-ACCT-PATH PIC X(8)
216
217 VALUE 'CARDAIX '.
218 ******************************************************************
219 *Other common working storage Variables
220 ******************************************************************
221 COPY CVCRD01Y.
222
223 ******************************************************************
224 * Commarea manipulations
225 ******************************************************************
226 *Application Commmarea Copybook
227 COPY COCOM01Y.
228
229 01 WS-THIS-PROGCOMMAREA.
230 10 WS-CA-LAST-CARDKEY.
231 15 WS-CA-LAST-CARD-NUM PIC X(16).
232 15 WS-CA-LAST-CARD-ACCT-ID PIC 9(11).
233 10 WS-CA-FIRST-CARDKEY.
234 15 WS-CA-FIRST-CARD-NUM PIC X(16).
235 15 WS-CA-FIRST-CARD-ACCT-ID PIC 9(11).
236
237 10 WS-CA-SCREEN-NUM PIC 9(1).
238 88 CA-FIRST-PAGE VALUE 1.
239 10 WS-CA-LAST-PAGE-DISPLAYED PIC 9(1).
240 88 CA-LAST-PAGE-SHOWN VALUE 0.
241 88 CA-LAST-PAGE-NOT-SHOWN VALUE 9.
242 10 WS-CA-NEXT-PAGE-IND PIC X(1).
243 88 CA-NEXT-PAGE-NOT-EXISTS VALUE LOW-VALUES.
244 88 CA-NEXT-PAGE-EXISTS VALUE 'Y'.
245
246 10 WS-RETURN-FLAG PIC X(1).
247 88 WS-RETURN-FLAG-OFF VALUE LOW-VALUES.
248 88 WS-RETURN-FLAG-ON VALUE '1'.
249 ******************************************************************
250 * File Data Array 28 CHARS X 7 ROWS = 196
251 ******************************************************************
252 05 WS-SCREEN-DATA.
253 10 WS-ALL-ROWS PIC X(196).
254 10 FILLER REDEFINES WS-ALL-ROWS.
255 15 WS-SCREEN-ROWS OCCURS 7 TIMES.
256 20 WS-EACH-ROW.
257 25 WS-EACH-CARD.
258 30 WS-ROW-ACCTNO PIC X(11).
259 30 WS-ROW-CARD-NUM PIC X(16).
260 30 WS-ROW-CARD-STATUS PIC X(1).
261
262 01 WS-COMMAREA PIC X(2000).
263
264
265
266 *IBM SUPPLIED COPYBOOKS
267 COPY DFHBMSCA.
268 COPY DFHAID.
269
270 *COMMON COPYBOOKS
271 *Screen Titles
272 COPY COTTL01Y.
273 *Credit Card Search Screen Layout
274 *COPY COCRDSL.
275 *Credit Card List Screen Layout
276 COPY COCRDLI.
277
278 *Current Date
279 COPY CSDAT01Y.
280 *Common Messages
281 COPY CSMSG01Y.
282 *Abend Variables
283 *COPY CSMSG02Y.
284 *Signed on user data
285 COPY CSUSR01Y.
286
287 *Dataset layouts
288
289 *CARD RECORD LAYOUT
290 COPY CVACT02Y.
291
292 LINKAGE SECTION.
293 01 DFHCOMMAREA.
294 05 FILLER PIC X(1)
295 OCCURS 1 TO 32767 TIMES DEPENDING ON EIBCALEN.
296
297 PROCEDURE DIVISION.
298 0000-MAIN.
299
300 INITIALIZE CC-WORK-AREA
301 WS-MISC-STORAGE
302 WS-COMMAREA
303
304 *****************************************************************
305 * Store our context
306 *****************************************************************
307 MOVE LIT-THISTRANID TO WS-TRANID
308 *****************************************************************
309 * Ensure error message is cleared *
310 *****************************************************************
311 SET WS-ERROR-MSG-OFF TO TRUE
312 *****************************************************************
313 * Retrived passed data if any. Initialize them if first run.
314 *****************************************************************
315 IF EIBCALEN = 0
316 INITIALIZE CARDDEMO-COMMAREA
317 WS-THIS-PROGCOMMAREA
318 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
319 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
320 SET CDEMO-USRTYP-USER TO TRUE
321 SET CDEMO-PGM-ENTER TO TRUE
322 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
323 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
324 SET CA-FIRST-PAGE TO TRUE
325 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
326 ELSE
327 MOVE DFHCOMMAREA (1:LENGTH OF CARDDEMO-COMMAREA) TO
328 CARDDEMO-COMMAREA
329 MOVE DFHCOMMAREA(LENGTH OF CARDDEMO-COMMAREA + 1:
330 LENGTH OF WS-THIS-PROGCOMMAREA )TO
331 WS-THIS-PROGCOMMAREA
332 END-IF
333 *****************************************************************
334 * If coming in from menu. Lets forget the past and start afresh *
335 *****************************************************************
336 IF (CDEMO-PGM-ENTER
337 AND CDEMO-FROM-PROGRAM NOT EQUAL LIT-THISPGM)
338 INITIALIZE WS-THIS-PROGCOMMAREA
339 SET CDEMO-PGM-ENTER TO TRUE
340 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
341 SET CA-FIRST-PAGE TO TRUE
342 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
343 END-IF
344
345 ******************************************************************
346 * Remap PFkeys as needed.
347 * Store the Mapped PF Key
348 *****************************************************************
349 PERFORM YYYY-STORE-PFKEY
350 THRU YYYY-STORE-PFKEY-EXIT
351
352 ******************************************************************
353 * If something is present in commarea
354 * and the from program is this program itself,
355 * read and edit the inputs given
356 *****************************************************************
357 IF EIBCALEN > 0
358 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
359 PERFORM 2000-RECEIVE-MAP
360 THRU 2000-RECEIVE-MAP-EXIT
361
362 END-IF
363 *****************************************************************
364 * Check the mapped key to see if its valid at this point *
365 * F3 - Exit
366 * Enter - List of cards for current start key
367 * F8 - Page down
368 * F7 - Page up
369 *****************************************************************
370 SET PFK-INVALID TO TRUE
371 IF CCARD-AID-ENTER OR
372 CCARD-AID-PFK03 OR
373 CCARD-AID-PFK07 OR
374 CCARD-AID-PFK08
375 SET PFK-VALID TO TRUE
376 END-IF
377
378 IF PFK-INVALID
379 SET CCARD-AID-ENTER TO TRUE
380 END-IF
381 *****************************************************************
382 * If the user pressed PF3 go back to main menu
383 *****************************************************************
384 IF (CCARD-AID-PFK03
385 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM)
386 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
387 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
388 SET CDEMO-USRTYP-USER TO TRUE
389 SET CDEMO-PGM-ENTER TO TRUE
390 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
391 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
392 MOVE LIT-MENUPGM TO CDEMO-TO-PROGRAM
393
394 MOVE LIT-MENUMAPSET TO CCARD-NEXT-MAPSET
395 MOVE LIT-THISMAP TO CCARD-NEXT-MAP
396 SET WS-EXIT-MESSAGE TO TRUE
397
398 * CALL MENU PROGRAM
399 *
400 SET CDEMO-PGM-ENTER TO TRUE
401 *
402 EXEC CICS XCTL
403 PROGRAM (LIT-MENUPGM)
404 COMMAREA(CARDDEMO-COMMAREA)
405 END-EXEC
406 END-IF
407 *****************************************************************
408 * If the user did not press PF8, lets reset the last page flag
409 *****************************************************************
410 IF CCARD-AID-PFK08
411 CONTINUE
412 ELSE
413 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
414 END-IF
415 *****************************************************************
416 * Now we decide what to do
417 *****************************************************************
418 EVALUATE TRUE
419 WHEN INPUT-ERROR
420 *****************************************************************
421 * ASK FOR CORRECTIONS TO INPUTS
422 *****************************************************************
423 MOVE WS-ERROR-MSG TO CCARD-ERROR-MSG
424 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
425 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
426 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
427
428 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
429 MOVE LIT-THISMAPSET TO CCARD-NEXT-MAPSET
430 MOVE LIT-THISMAP TO CCARD-NEXT-MAP
431 IF NOT FLG-ACCTFILTER-NOT-OK
432 AND NOT FLG-CARDFILTER-NOT-OK
433 PERFORM 9000-READ-FORWARD
434 THRU 9000-READ-FORWARD-EXIT
435 END-IF
436 PERFORM 1000-SEND-MAP
437 THRU 1000-SEND-MAP
438 GO TO COMMON-RETURN
439 WHEN CCARD-AID-PFK07
440 AND CA-FIRST-PAGE
441 *****************************************************************
442 * PAGE UP - PF7 - BUT ALREADY ON FIRST PAGE
443 *****************************************************************
444 WHEN CCARD-AID-PFK07
445 AND CA-FIRST-PAGE
446 MOVE WS-CA-FIRST-CARD-NUM
447 TO WS-CARD-RID-CARDNUM
448 * MOVE WS-CA-FIRST-CARD-ACCT-ID
449 * TO WS-CARD-RID-ACCT-ID
450 PERFORM 9000-READ-FORWARD
451 THRU 9000-READ-FORWARD-EXIT
452 PERFORM 1000-SEND-MAP
453 THRU 1000-SEND-MAP
454 GO TO COMMON-RETURN
455 *****************************************************************
456 * BACK - PF3 IF WE CAME FROM SOME OTHER PROGRAM
457 *****************************************************************
458 WHEN CCARD-AID-PFK03
459 WHEN CDEMO-PGM-REENTER AND
460 CDEMO-FROM-PROGRAM NOT EQUAL LIT-THISPGM
461
462 INITIALIZE CARDDEMO-COMMAREA
463 WS-THIS-PROGCOMMAREA
464 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
465 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
466 SET CDEMO-USRTYP-USER TO TRUE
467 SET CDEMO-PGM-ENTER TO TRUE
468 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
469 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
470 SET CA-FIRST-PAGE TO TRUE
471 SET CA-LAST-PAGE-NOT-SHOWN TO TRUE
472
473 MOVE WS-CA-FIRST-CARD-NUM
474 TO WS-CARD-RID-CARDNUM
475 * MOVE WS-CA-FIRST-CARD-ACCT-ID
476 * TO WS-CARD-RID-ACCT-ID
477
478 PERFORM 9000-READ-FORWARD
479 THRU 9000-READ-FORWARD-EXIT
480 PERFORM 1000-SEND-MAP
481 THRU 1000-SEND-MAP
482 GO TO COMMON-RETURN
483 *****************************************************************
484 * PAGE DOWN
485 *****************************************************************
486 WHEN CCARD-AID-PFK08
487 AND CA-NEXT-PAGE-EXISTS
488 MOVE WS-CA-LAST-CARD-NUM
489 TO WS-CARD-RID-CARDNUM
490 * MOVE WS-CA-LAST-CARD-ACCT-ID
491 * TO WS-CARD-RID-ACCT-ID
492 ADD +1 TO WS-CA-SCREEN-NUM
493 PERFORM 9000-READ-FORWARD
494 THRU 9000-READ-FORWARD-EXIT
495 PERFORM 1000-SEND-MAP
496 THRU 1000-SEND-MAP-EXIT
497 GO TO COMMON-RETURN
498 *****************************************************************
499 * PAGE UP
500 *****************************************************************
501 WHEN CCARD-AID-PFK07
502 AND NOT CA-FIRST-PAGE
503
504 MOVE WS-CA-FIRST-CARD-NUM
505 TO WS-CARD-RID-CARDNUM
506 * MOVE WS-CA-FIRST-CARD-ACCT-ID
507 * TO WS-CARD-RID-ACCT-ID
508 SUBTRACT 1 FROM WS-CA-SCREEN-NUM
509 PERFORM 9100-READ-BACKWARDS
510 THRU 9100-READ-BACKWARDS-EXIT
511 PERFORM 1000-SEND-MAP
512 THRU 1000-SEND-MAP-EXIT
513 GO TO COMMON-RETURN
514 *****************************************************************
515 * TRANSFER TO CARD DETAIL VIEW
516 *****************************************************************
517 WHEN CCARD-AID-ENTER
518 AND VIEW-REQUESTED-ON(I-SELECTED)
519 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
520 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
521 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
522 SET CDEMO-USRTYP-USER TO TRUE
523 SET CDEMO-PGM-ENTER TO TRUE
524 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
525 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
526 MOVE LIT-CARDDTLPGM TO CCARD-NEXT-PROG
527
528 MOVE LIT-CARDDTLMAPSET TO CCARD-NEXT-MAPSET
529 MOVE LIT-CARDDTLMAP TO CCARD-NEXT-MAP
530
531 MOVE WS-ROW-ACCTNO (I-SELECTED)
532 TO CDEMO-ACCT-ID
533 MOVE WS-ROW-CARD-NUM (I-SELECTED)
534 TO CDEMO-CARD-NUM
535
536 * CALL CARD DETAIL PROGRAM
537 *
538 EXEC CICS XCTL
539 PROGRAM (CCARD-NEXT-PROG)
540 COMMAREA(CARDDEMO-COMMAREA)
541 END-EXEC
542 *****************************************************************
543 * TRANSFER TO CARD UPDATED PROGRAM
544 *****************************************************************
545 WHEN CCARD-AID-ENTER
546 AND UPDATE-REQUESTED-ON(I-SELECTED)
547 AND CDEMO-FROM-PROGRAM EQUAL LIT-THISPGM
548 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
549 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
550 SET CDEMO-USRTYP-USER TO TRUE
551 SET CDEMO-PGM-ENTER TO TRUE
552 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
553 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
554 MOVE LIT-CARDUPDPGM TO CCARD-NEXT-PROG
555
556 MOVE LIT-CARDUPDMAPSET TO CCARD-NEXT-MAPSET
557 MOVE LIT-CARDUPDMAP TO CCARD-NEXT-MAP
558
559 MOVE WS-ROW-ACCTNO (I-SELECTED)
560 TO CDEMO-ACCT-ID
561 MOVE WS-ROW-CARD-NUM (I-SELECTED)
562 TO CDEMO-CARD-NUM
563
564 * CALL CARD UPDATE PROGRAM
565 *
566 EXEC CICS XCTL
567 PROGRAM (CCARD-NEXT-PROG)
568 COMMAREA(CARDDEMO-COMMAREA)
569 END-EXEC
570
571 *****************************************************************
572 WHEN OTHER
573 *****************************************************************
574 MOVE WS-CA-FIRST-CARD-NUM
575 TO WS-CARD-RID-CARDNUM
576 * MOVE WS-CA-FIRST-CARD-ACCT-ID
577 * TO WS-CARD-RID-ACCT-ID
578 PERFORM 9000-READ-FORWARD
579 THRU 9000-READ-FORWARD-EXIT
580 PERFORM 1000-SEND-MAP
581 THRU 1000-SEND-MAP
582 GO TO COMMON-RETURN
583 END-EVALUATE
584
585 * If we had an error setup error message to display and return
586 IF INPUT-ERROR
587 MOVE WS-ERROR-MSG TO CCARD-ERROR-MSG
588 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
589 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
590 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
591
592 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
593 MOVE LIT-THISMAPSET TO CCARD-NEXT-MAPSET
594 MOVE LIT-THISMAP TO CCARD-NEXT-MAP
595 * PERFORM 1000-SEND-MAP
596 * THRU 1000-SEND-MAP
597 GO TO COMMON-RETURN
598 END-IF
599
600 MOVE LIT-THISPGM TO CCARD-NEXT-PROG
601 GO TO COMMON-RETURN
602 .
603
604 COMMON-RETURN.
605 MOVE LIT-THISTRANID TO CDEMO-FROM-TRANID
606 MOVE LIT-THISPGM TO CDEMO-FROM-PROGRAM
607 MOVE LIT-THISMAPSET TO CDEMO-LAST-MAPSET
608 MOVE LIT-THISMAP TO CDEMO-LAST-MAP
609 MOVE CARDDEMO-COMMAREA TO WS-COMMAREA
610 MOVE WS-THIS-PROGCOMMAREA TO
611 WS-COMMAREA(LENGTH OF CARDDEMO-COMMAREA + 1:
612 LENGTH OF WS-THIS-PROGCOMMAREA )
613
614
615 EXEC CICS RETURN
616 TRANSID (LIT-THISTRANID)
617 COMMAREA (WS-COMMAREA)
618 LENGTH(LENGTH OF WS-COMMAREA)
619 END-EXEC
620 .
621 0000-MAIN-EXIT.
622 EXIT
623 .
624 1000-SEND-MAP.
625 PERFORM 1100-SCREEN-INIT
626 THRU 1100-SCREEN-INIT-EXIT
627 PERFORM 1200-SCREEN-ARRAY-INIT
628 THRU 1200-SCREEN-ARRAY-INIT-EXIT
629 PERFORM 1250-SETUP-ARRAY-ATTRIBS
630 THRU 1250-SETUP-ARRAY-ATTRIBS-EXIT
631 PERFORM 1300-SETUP-SCREEN-ATTRS
632 THRU 1300-SETUP-SCREEN-ATTRS-EXIT
633 PERFORM 1400-SETUP-MESSAGE
634 THRU 1400-SETUP-MESSAGE-EXIT
635 PERFORM 1500-SEND-SCREEN
636 THRU 1500-SEND-SCREEN-EXIT
637 .
638
639 1000-SEND-MAP-EXIT.
640 EXIT
641 .
642 1100-SCREEN-INIT.
643 MOVE LOW-VALUES TO CCRDLIAO
644
645 MOVE FUNCTION CURRENT-DATE TO WS-CURDATE-DATA
646
647 MOVE CCDA-TITLE01 TO TITLE01O OF CCRDLIAO
648 MOVE CCDA-TITLE02 TO TITLE02O OF CCRDLIAO
649 MOVE LIT-THISTRANID TO TRNNAMEO OF CCRDLIAO
650 MOVE LIT-THISPGM TO PGMNAMEO OF CCRDLIAO
651
652 MOVE FUNCTION CURRENT-DATE TO WS-CURDATE-DATA
653
654 MOVE WS-CURDATE-MONTH TO WS-CURDATE-MM
655 MOVE WS-CURDATE-DAY TO WS-CURDATE-DD
656 MOVE WS-CURDATE-YEAR(3:2) TO WS-CURDATE-YY
657
658 MOVE WS-CURDATE-MM-DD-YY TO CURDATEO OF CCRDLIAO
659
660 MOVE WS-CURTIME-HOURS TO WS-CURTIME-HH
661 MOVE WS-CURTIME-MINUTE TO WS-CURTIME-MM
662 MOVE WS-CURTIME-SECOND TO WS-CURTIME-SS
663
664 MOVE WS-CURTIME-HH-MM-SS TO CURTIMEO OF CCRDLIAO
665 * PAGE NUMBER
666 *
667 MOVE WS-CA-SCREEN-NUM TO PAGENOO OF CCRDLIAO
668
669 SET WS-NO-INFO-MESSAGE TO TRUE
670 MOVE WS-INFO-MSG TO INFOMSGO OF CCRDLIAO
671 MOVE DFHBMDAR TO INFOMSGC OF CCRDLIAO
672 .
673
674 1100-SCREEN-INIT-EXIT.
675 EXIT
676 .
677
678 1200-SCREEN-ARRAY-INIT.
679 * USE REDEFINES AND CLEAN UP REPETITIVE CODE !!
680 IF WS-EACH-CARD(1) EQUAL LOW-VALUES
681 CONTINUE
682 ELSE
683 MOVE WS-EDIT-SELECT(1) TO CRDSEL1O OF CCRDLIAO
684 MOVE WS-ROW-ACCTNO(1) TO ACCTNO1O OF CCRDLIAO
685 MOVE WS-ROW-CARD-NUM(1) TO CRDNUM1O OF CCRDLIAO
686 MOVE WS-ROW-CARD-STATUS(1) TO CRDSTS1O OF CCRDLIAO
687 END-IF
688
689 IF WS-EACH-CARD(2) EQUAL LOW-VALUES
690 CONTINUE
691 ELSE
692 MOVE WS-EDIT-SELECT(2) TO CRDSEL2O OF CCRDLIAO
693 MOVE WS-ROW-ACCTNO(2) TO ACCTNO2O OF CCRDLIAO
694 MOVE WS-ROW-CARD-NUM(2) TO CRDNUM2O OF CCRDLIAO
695 MOVE WS-ROW-CARD-STATUS(2) TO CRDSTS2O OF CCRDLIAO
696 END-IF
697
698 IF WS-EACH-CARD(3) EQUAL LOW-VALUES
699 CONTINUE
700 ELSE
701 MOVE WS-EDIT-SELECT(3) TO CRDSEL3O OF CCRDLIAO
702 MOVE WS-ROW-ACCTNO(3) TO ACCTNO3O OF CCRDLIAO
703 MOVE WS-ROW-CARD-NUM(3) TO CRDNUM3O OF CCRDLIAO
704 MOVE WS-ROW-CARD-STATUS(3) TO CRDSTS3O OF CCRDLIAO
705 END-IF
706
707 IF WS-EACH-CARD(4) EQUAL LOW-VALUES
708 CONTINUE
709 ELSE
710 MOVE WS-EDIT-SELECT(4) TO CRDSEL4O OF CCRDLIAO
711 MOVE WS-ROW-ACCTNO(4) TO ACCTNO4O OF CCRDLIAO
712 MOVE WS-ROW-CARD-NUM(4) TO CRDNUM4O OF CCRDLIAO
713 MOVE WS-ROW-CARD-STATUS(4) TO CRDSTS4O OF CCRDLIAO
714 END-IF
715
716 IF WS-EACH-CARD(5) EQUAL LOW-VALUES
717 CONTINUE
718 ELSE
719 MOVE WS-EDIT-SELECT(5) TO CRDSEL5O OF CCRDLIAO
720 MOVE WS-ROW-ACCTNO(5) TO ACCTNO5O OF CCRDLIAO
721 MOVE WS-ROW-CARD-NUM(5) TO CRDNUM5O OF CCRDLIAO
722 MOVE WS-ROW-CARD-STATUS(5) TO CRDSTS5O OF CCRDLIAO
723 END-IF
724
725
726 IF WS-EACH-CARD(6) EQUAL LOW-VALUES
727 CONTINUE
728 ELSE
729 MOVE WS-EDIT-SELECT(6) TO CRDSEL6O OF CCRDLIAO
730 MOVE WS-ROW-ACCTNO(6) TO ACCTNO6O OF CCRDLIAO
731 MOVE WS-ROW-CARD-NUM(6) TO CRDNUM6O OF CCRDLIAO
732 MOVE WS-ROW-CARD-STATUS(6) TO CRDSTS6O OF CCRDLIAO
733 END-IF
734
735 IF WS-EACH-CARD(7) EQUAL LOW-VALUES
736 CONTINUE
737 ELSE
738 MOVE WS-EDIT-SELECT(7) TO CRDSEL7O OF CCRDLIAO
739 MOVE WS-ROW-ACCTNO(7) TO ACCTNO7O OF CCRDLIAO
740 MOVE WS-ROW-CARD-NUM(7) TO CRDNUM7O OF CCRDLIAO
741 MOVE WS-ROW-CARD-STATUS(7) TO CRDSTS7O OF CCRDLIAO
742 END-IF
743 .
744
745 1200-SCREEN-ARRAY-INIT-EXIT.
746 EXIT
747 .
748 1250-SETUP-ARRAY-ATTRIBS.
749 * USE REDEFINES AND CLEAN UP REPETITIVE CODE !!
750
751 IF WS-EACH-CARD(1) EQUAL LOW-VALUES
752 OR FLG-PROTECT-SELECT-ROWS-YES
753 MOVE DFHBMPRF TO CRDSEL1A OF CCRDLIAI
754 ELSE
755 IF WS-ROW-CRDSELECT-ERROR(1) = '1'
756 MOVE DFHRED TO CRDSEL1C OF CCRDLIAO
757 IF WS-EDIT-SELECT(1) = SPACE OR LOW-VALUES
758 MOVE '*' TO CRDSEL1O OF CCRDLIAO
759 END-IF
760 END-IF
761 MOVE DFHBMFSE TO CRDSEL1A OF CCRDLIAI
762 END-IF
763
764 IF WS-EACH-CARD(2) EQUAL LOW-VALUES
765 OR FLG-PROTECT-SELECT-ROWS-YES
766 MOVE DFHBMPRO TO CRDSEL2A OF CCRDLIAI
767 ELSE
768 IF WS-ROW-CRDSELECT-ERROR(2) = '1'
769 MOVE DFHRED TO CRDSEL2C OF CCRDLIAO
770 MOVE -1 TO CRDSEL2L OF CCRDLIAI
771 END-IF
772 MOVE DFHBMFSE TO CRDSEL2A OF CCRDLIAI
773 END-IF
774
775 IF WS-EACH-CARD(3) EQUAL LOW-VALUES
776 OR FLG-PROTECT-SELECT-ROWS-YES
777 MOVE DFHBMPRO TO CRDSEL3A OF CCRDLIAI
778
779 ELSE
780 IF WS-ROW-CRDSELECT-ERROR(3) = '1'
781 MOVE DFHRED TO CRDSEL3C OF CCRDLIAO
782 MOVE -1 TO CRDSEL3L OF CCRDLIAI
783 END-IF
784 MOVE DFHBMFSE TO CRDSEL3A OF CCRDLIAI
785 END-IF
786
787 IF WS-EACH-CARD(4) EQUAL LOW-VALUES
788 OR FLG-PROTECT-SELECT-ROWS-YES
789 MOVE DFHBMPRO TO CRDSEL4A OF CCRDLIAI
790 I
791 ELSE
792 IF WS-ROW-CRDSELECT-ERROR(4) = '1'
793 MOVE DFHRED TO CRDSEL4C OF CCRDLIAO
794 MOVE -1 TO CRDSEL4L OF CCRDLIAI
795 END-IF
796 MOVE DFHBMFSE TO CRDSEL4A OF CCRDLIAI
797 END-IF
798
799 IF WS-EACH-CARD(5) EQUAL LOW-VALUES
800 OR FLG-PROTECT-SELECT-ROWS-YES
801 MOVE DFHBMPRO TO CRDSEL5A OF CCRDLIAI
802 ELSE
803 IF WS-ROW-CRDSELECT-ERROR(5) = '1'
804 MOVE DFHRED TO CRDSEL5C OF CCRDLIAO
805 MOVE -1 TO CRDSEL5L OF CCRDLIAI
806 END-IF
807 MOVE DFHBMFSE TO CRDSEL5A OF CCRDLIAI
808 END-IF
809
810 IF WS-EACH-CARD(6) EQUAL LOW-VALUES
811 OR FLG-PROTECT-SELECT-ROWS-YES
812 MOVE DFHBMPRO TO CRDSEL6A OF CCRDLIAI
813
814 ELSE
815 IF WS-ROW-CRDSELECT-ERROR(6) = '1'
816 MOVE DFHRED TO CRDSEL6C OF CCRDLIAO
817 MOVE -1 TO CRDSEL6L OF CCRDLIAI
818 END-IF
819 MOVE DFHBMFSE TO CRDSEL6A OF CCRDLIAI
820 END-IF
821
822 IF WS-EACH-CARD(7) EQUAL LOW-VALUES
823 OR FLG-PROTECT-SELECT-ROWS-YES
824 MOVE DFHBMPRO TO CRDSEL7A OF CCRDLIAI
825 ELSE
826 IF WS-ROW-CRDSELECT-ERROR(7) = '1'
827 MOVE DFHRED TO CRDSEL7C OF CCRDLIAO
828 MOVE -1 TO CRDSEL7L OF CCRDLIAI
829 END-IF
830 MOVE DFHBMFSE TO CRDSEL7A OF CCRDLIAI
831 END-IF
832 .
833
834 1250-SETUP-ARRAY-ATTRIBS-EXIT.
835 EXIT
836 .
837 1300-SETUP-SCREEN-ATTRS.
838 * INITIALIZE SEARCH CRITERIA
839 IF EIBCALEN = 0
840 OR (CDEMO-PGM-ENTER
841 AND CDEMO-FROM-PROGRAM = LIT-MENUPGM)
842 CONTINUE
843 ELSE
844 EVALUATE TRUE
845 WHEN FLG-ACCTFILTER-ISVALID
846 WHEN FLG-ACCTFILTER-NOT-OK
847 MOVE CC-ACCT-ID TO ACCTSIDO OF CCRDLIAO
848 MOVE DFHBMFSE TO ACCTSIDA OF CCRDLIAI
849 WHEN CDEMO-ACCT-ID = 0
850 MOVE LOW-VALUES TO ACCTSIDO OF CCRDLIAO
851 WHEN OTHER
852 MOVE CDEMO-ACCT-ID TO ACCTSIDO OF CCRDLIAO
853 MOVE DFHBMFSE TO ACCTSIDA OF CCRDLIAI
854 END-EVALUATE
855
856 EVALUATE TRUE
857 WHEN FLG-CARDFILTER-ISVALID
858 WHEN FLG-CARDFILTER-NOT-OK
859 MOVE CC-CARD-NUM TO CARDSIDO OF CCRDLIAO
860 MOVE DFHBMFSE TO CARDSIDA OF CCRDLIAI
861 WHEN CDEMO-CARD-NUM = 0
862 MOVE LOW-VALUES TO CARDSIDO OF CCRDLIAO
863 WHEN OTHER
864 MOVE CDEMO-CARD-NUM
865 TO CARDSIDO OF CCRDLIAO
866 MOVE DFHBMFSE TO CARDSIDA OF CCRDLIAI
867 END-EVALUATE
868 END-IF
869
870 * POSITION CURSOR
871
872 IF FLG-ACCTFILTER-NOT-OK
873 MOVE DFHRED TO ACCTSIDC OF CCRDLIAO
874 MOVE -1 TO ACCTSIDL OF CCRDLIAI
875 END-IF
876
877 IF FLG-CARDFILTER-NOT-OK
878 MOVE DFHRED TO CARDSIDC OF CCRDLIAO
879 MOVE -1 TO CARDSIDL OF CCRDLIAI
880 END-IF
881
882 * IF NO ERRORS POSITION CURSOR AT ACCTID
883
884 IF INPUT-OK
885 MOVE -1 TO ACCTSIDL OF CCRDLIAI
886 END-IF
887
888
889 .
890 1300-SETUP-SCREEN-ATTRS-EXIT.
891 EXIT
892 .
893
894
895 1400-SETUP-MESSAGE.
896 * SETUP MESSAGE
897 EVALUATE TRUE
898 WHEN FLG-ACCTFILTER-NOT-OK
899 WHEN FLG-CARDFILTER-NOT-OK
900 CONTINUE
901 WHEN CCARD-AID-PFK07
902 AND CA-FIRST-PAGE
903 MOVE 'NO PREVIOUS PAGES TO DISPLAY'
904 TO WS-ERROR-MSG
905 WHEN CCARD-AID-PFK08
906 AND CA-NEXT-PAGE-NOT-EXISTS
907 AND CA-LAST-PAGE-SHOWN
908 MOVE 'NO MORE PAGES TO DISPLAY'
909 TO WS-ERROR-MSG
910 WHEN CCARD-AID-PFK08
911 AND CA-NEXT-PAGE-NOT-EXISTS
912 SET WS-INFORM-REC-ACTIONS TO TRUE
913 IF CA-LAST-PAGE-NOT-SHOWN
914 AND CA-NEXT-PAGE-NOT-EXISTS
915 SET CA-LAST-PAGE-SHOWN TO TRUE
916 END-IF
917 WHEN WS-NO-INFO-MESSAGE
918 WHEN CA-NEXT-PAGE-EXISTS
919 SET WS-INFORM-REC-ACTIONS TO TRUE
920 WHEN OTHER
921 SET WS-NO-INFO-MESSAGE TO TRUE
922 END-EVALUATE
923
924 MOVE WS-ERROR-MSG TO ERRMSGO OF CCRDLIAO
925
926 IF NOT WS-NO-INFO-MESSAGE
927 AND NOT WS-NO-RECORDS-FOUND
928 MOVE WS-INFO-MSG TO INFOMSGO OF CCRDLIAO
929 MOVE DFHNEUTR TO INFOMSGC OF CCRDLIAO
930 END-IF
931
932 .
933 1400-SETUP-MESSAGE-EXIT.
934 EXIT
935 .
936
937
938 1500-SEND-SCREEN.
939 EXEC CICS SEND MAP(LIT-THISMAP)
940 MAPSET(LIT-THISMAPSET)
941 FROM(CCRDLIAO)
942 CURSOR
943 ERASE
944 RESP(WS-RESP-CD)
945 FREEKB
946 END-EXEC
947 .
948 1500-SEND-SCREEN-EXIT.
949 EXIT
950 .
951 2000-RECEIVE-MAP.
952 PERFORM 2100-RECEIVE-SCREEN
953 THRU 2100-RECEIVE-SCREEN-EXIT
954
955 PERFORM 2200-EDIT-INPUTS
956 THRU 2200-EDIT-INPUTS-EXIT
957 .
958
959 2000-RECEIVE-MAP-EXIT.
960 EXIT
961 .
962 2100-RECEIVE-SCREEN.
963 EXEC CICS RECEIVE MAP(LIT-THISMAP)
964 MAPSET(LIT-THISMAPSET)
965 INTO(CCRDLIAI)
966 RESP(WS-RESP-CD)
967 END-EXEC
968
969 MOVE ACCTSIDI OF CCRDLIAI TO CC-ACCT-ID
970 MOVE CARDSIDI OF CCRDLIAI TO CC-CARD-NUM
971
972 MOVE CRDSEL1I OF CCRDLIAI TO WS-EDIT-SELECT(1)
973 MOVE CRDSEL2I OF CCRDLIAI TO WS-EDIT-SELECT(2)
974 MOVE CRDSEL3I OF CCRDLIAI TO WS-EDIT-SELECT(3)
975 MOVE CRDSEL4I OF CCRDLIAI TO WS-EDIT-SELECT(4)
976 MOVE CRDSEL5I OF CCRDLIAI TO WS-EDIT-SELECT(5)
977 MOVE CRDSEL6I OF CCRDLIAI TO WS-EDIT-SELECT(6)
978 MOVE CRDSEL7I OF CCRDLIAI TO WS-EDIT-SELECT(7)
979 .
980
981 2100-RECEIVE-SCREEN-EXIT.
982 EXIT
983 .
984
985 2200-EDIT-INPUTS.
986 SET INPUT-OK TO TRUE
987 SET FLG-PROTECT-SELECT-ROWS-NO TO TRUE
988
989 PERFORM 2210-EDIT-ACCOUNT
990 THRU 2210-EDIT-ACCOUNT-EXIT
991
992 PERFORM 2220-EDIT-CARD
993 THRU 2220-EDIT-CARD-EXIT
994
995 PERFORM 2250-EDIT-ARRAY
996 THRU 2250-EDIT-ARRAY-EXIT
997 .
998
999 2200-EDIT-INPUTS-EXIT.
1000 EXIT
1001 .
1002
1003 2210-EDIT-ACCOUNT.
1004 SET FLG-ACCTFILTER-BLANK TO TRUE
1005
1006 * Not supplied
1007 IF CC-ACCT-ID EQUAL LOW-VALUES
1008 OR CC-ACCT-ID EQUAL SPACES
1009 OR CC-ACCT-ID-N EQUAL ZEROS
1010 SET FLG-ACCTFILTER-BLANK TO TRUE
1011 MOVE ZEROES TO CDEMO-ACCT-ID
1012 GO TO 2210-EDIT-ACCOUNT-EXIT
1013 END-IF
1014 *
1015 * Not numeric
1016 * Not 11 characters
1017 IF CC-ACCT-ID IS NOT NUMERIC
1018 SET INPUT-ERROR TO TRUE
1019 SET FLG-ACCTFILTER-NOT-OK TO TRUE
1020 SET FLG-PROTECT-SELECT-ROWS-YES TO TRUE
1021 MOVE
1022 'ACCOUNT FILTER,IF SUPPLIED MUST BE A 11 DIGIT NUMBER'
1023 TO WS-ERROR-MSG
1024 MOVE ZERO TO CDEMO-ACCT-ID
1025 GO TO 2210-EDIT-ACCOUNT-EXIT
1026 ELSE
1027 MOVE CC-ACCT-ID TO CDEMO-ACCT-ID
1028 SET FLG-ACCTFILTER-ISVALID TO TRUE
1029 END-IF
1030 .
1031
1032 2210-EDIT-ACCOUNT-EXIT.
1033 EXIT
1034 .
1035
1036 2220-EDIT-CARD.
1037 * Not numeric
1038 * Not 16 characters
1039 SET FLG-CARDFILTER-BLANK TO TRUE
1040
1041 * Not supplied
1042 IF CC-CARD-NUM EQUAL LOW-VALUES
1043 OR CC-CARD-NUM EQUAL SPACES
1044 OR CC-CARD-NUM-N EQUAL ZEROS
1045 SET FLG-CARDFILTER-BLANK TO TRUE
1046 MOVE ZEROES TO CDEMO-CARD-NUM
1047 GO TO 2220-EDIT-CARD-EXIT
1048 END-IF
1049 *
1050 * Not numeric
1051 * Not 16 characters
1052 IF CC-CARD-NUM IS NOT NUMERIC
1053 SET INPUT-ERROR TO TRUE
1054 SET FLG-CARDFILTER-NOT-OK TO TRUE
1055 SET FLG-PROTECT-SELECT-ROWS-YES TO TRUE
1056 IF WS-ERROR-MSG-OFF
1057 MOVE
1058 'CARD ID FILTER,IF SUPPLIED MUST BE A 16 DIGIT NUMBER'
1059 TO WS-ERROR-MSG
1060 END-IF
1061 MOVE ZERO TO CDEMO-CARD-NUM
1062 GO TO 2220-EDIT-CARD-EXIT
1063 ELSE
1064 MOVE CC-CARD-NUM-N TO CDEMO-CARD-NUM
1065 SET FLG-CARDFILTER-ISVALID TO TRUE
1066 END-IF
1067 .
1068
1069 2220-EDIT-CARD-EXIT.
1070 EXIT
1071 .
1072
1073 2250-EDIT-ARRAY.
1074
1075 IF INPUT-ERROR
1076 GO TO 2250-EDIT-ARRAY-EXIT
1077 END-IF
1078
1079 INSPECT WS-EDIT-SELECT-FLAGS
1080 TALLYING I
1081 FOR ALL 'S'
1082 ALL 'U'
1083
1084 IF I > +1
1085 SET INPUT-ERROR TO TRUE
1086 SET WS-MORE-THAN-1-ACTION TO TRUE
1087
1088 MOVE WS-EDIT-SELECT-FLAGS
1089 TO WS-EDIT-SELECT-ERROR-FLAGS
1090 INSPECT WS-EDIT-SELECT-ERROR-FLAGS
1091 REPLACING ALL 'S' BY '1'
1092 ALL 'U' BY '1'
1093 CHARACTERS BY '0'
1094
1095 END-IF
1096
1097 MOVE ZERO TO I-SELECTED
1098
1099 PERFORM VARYING I FROM 1 BY 1 UNTIL I > 7
1100 EVALUATE TRUE
1101 WHEN SELECT-OK(I)
1102 MOVE I TO I-SELECTED
1103 IF WS-MORE-THAN-1-ACTION
1104 MOVE '1' TO WS-ROW-CRDSELECT-ERROR(I)
1105 END-IF
1106 WHEN SELECT-BLANK(I)
1107 CONTINUE
1108 WHEN OTHER
1109 SET INPUT-ERROR TO TRUE
1110 MOVE '1' TO WS-ROW-CRDSELECT-ERROR(I)
1111 IF WS-ERROR-MSG-OFF
1112 SET WS-INVALID-ACTION-CODE TO TRUE
1113 END-IF
1114 END-EVALUATE
1115 END-PERFORM
1116
1117 .
1118
1119 2250-EDIT-ARRAY-EXIT.
1120 EXIT
1121 .
1122
1123 9000-READ-FORWARD.
1124 MOVE LOW-VALUES TO WS-ALL-ROWS
1125
1126 *****************************************************************
1127 * Start Browse
1128 *****************************************************************
1129 EXEC CICS STARTBR
1130 DATASET(LIT-CARD-FILE)
1131 RIDFLD(WS-CARD-RID-CARDNUM)
1132 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1133 GTEQ
1134 RESP(WS-RESP-CD)
1135 RESP2(WS-REAS-CD)
1136 END-EXEC
1137 *****************************************************************
1138 * Loop through records and fetch max screen records
1139 *****************************************************************
1140 MOVE ZEROES TO WS-SCRN-COUNTER
1141 SET CA-NEXT-PAGE-EXISTS TO TRUE
1142 SET MORE-RECORDS-TO-READ TO TRUE
1143
1144 PERFORM UNTIL READ-LOOP-EXIT
1145
1146 EXEC CICS READNEXT
1147 DATASET(LIT-CARD-FILE)
1148 INTO (CARD-RECORD)
1149 LENGTH(LENGTH OF CARD-RECORD)
1150 RIDFLD(WS-CARD-RID-CARDNUM)
1151 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1152 RESP(WS-RESP-CD)
1153 RESP2(WS-REAS-CD)
1154 END-EXEC
1155
1156 EVALUATE WS-RESP-CD
1157 WHEN DFHRESP(NORMAL)
1158 WHEN DFHRESP(DUPREC)
1159 PERFORM 9500-FILTER-RECORDS
1160 THRU 9500-FILTER-RECORDS-EXIT
1161
1162 IF WS-DONOT-EXCLUDE-THIS-RECORD
1163 ADD 1 TO WS-SCRN-COUNTER
1164
1165 MOVE CARD-NUM TO WS-ROW-CARD-NUM(
1166 WS-SCRN-COUNTER)
1167 MOVE CARD-ACCT-ID TO
1168 WS-ROW-ACCTNO(WS-SCRN-COUNTER)
1169 MOVE CARD-ACTIVE-STATUS
1170 TO WS-ROW-CARD-STATUS(
1171 WS-SCRN-COUNTER)
1172
1173 IF WS-SCRN-COUNTER = 1
1174 MOVE CARD-ACCT-ID
1175 TO WS-CA-FIRST-CARD-ACCT-ID
1176 MOVE CARD-NUM TO WS-CA-FIRST-CARD-NUM
1177 IF WS-CA-SCREEN-NUM = 0
1178 ADD +1 TO WS-CA-SCREEN-NUM
1179 ELSE
1180 CONTINUE
1181 END-IF
1182 ELSE
1183 CONTINUE
1184 END-IF
1185 ELSE
1186 CONTINUE
1187 END-IF
1188 ******************************************************************
1189 * Max Screen size
1190 ******************************************************************
1191 IF WS-SCRN-COUNTER = WS-MAX-SCREEN-LINES
1192 SET READ-LOOP-EXIT TO TRUE
1193
1194 MOVE CARD-ACCT-ID TO WS-CA-LAST-CARD-ACCT-ID
1195 MOVE CARD-NUM TO WS-CA-LAST-CARD-NUM
1196
1197 EXEC CICS READNEXT
1198 DATASET(LIT-CARD-FILE)
1199 INTO (CARD-RECORD)
1200 LENGTH(LENGTH OF CARD-RECORD)
1201 RIDFLD(WS-CARD-RID-CARDNUM)
1202 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1203 RESP(WS-RESP-CD)
1204 RESP2(WS-REAS-CD)
1205 END-EXEC
1206
1207 EVALUATE WS-RESP-CD
1208 WHEN DFHRESP(NORMAL)
1209 WHEN DFHRESP(DUPREC)
1210 SET CA-NEXT-PAGE-EXISTS
1211 TO TRUE
1212 MOVE CARD-ACCT-ID TO
1213 WS-CA-LAST-CARD-ACCT-ID
1214 MOVE CARD-NUM TO WS-CA-LAST-CARD-NUM
1215 WHEN DFHRESP(ENDFILE)
1216 SET CA-NEXT-PAGE-NOT-EXISTS TO TRUE
1217
1218 IF WS-ERROR-MSG-OFF
1219 MOVE 'NO MORE RECORDS TO SHOW'
1220 TO WS-ERROR-MSG
1221 END-IF
1222 WHEN OTHER
1223 * This is some kind of error. Change to END BR
1224 * And exit
1225 SET READ-LOOP-EXIT TO TRUE
1226 MOVE 'READ' TO ERROR-OPNAME
1227 MOVE LIT-CARD-FILE TO ERROR-FILE
1228 MOVE WS-RESP-CD TO ERROR-RESP
1229 MOVE WS-REAS-CD TO ERROR-RESP2
1230 MOVE WS-FILE-ERROR-MESSAGE TO WS-ERROR-MSG
1231 END-EVALUATE
1232 END-IF
1233 WHEN DFHRESP(ENDFILE)
1234 SET READ-LOOP-EXIT TO TRUE
1235 SET CA-NEXT-PAGE-NOT-EXISTS TO TRUE
1236 MOVE CARD-ACCT-ID TO WS-CA-LAST-CARD-ACCT-ID
1237 MOVE CARD-NUM TO WS-CA-LAST-CARD-NUM
1238 IF WS-ERROR-MSG-OFF
1239 MOVE 'NO MORE RECORDS TO SHOW' TO WS-ERROR-MSG
1240 END-IF
1241 IF WS-CA-SCREEN-NUM = 1
1242 AND WS-SCRN-COUNTER = 0
1243 * MOVE 'NO RECORDS TO SHOW' TO WS-ERROR-MSG
1244 SET WS-NO-RECORDS-FOUND TO TRUE
1245 END-IF
1246 WHEN OTHER
1247 * This is some kind of error. Change to END BR
1248 * And exit
1249 SET READ-LOOP-EXIT TO TRUE
1250 MOVE 'READ' TO ERROR-OPNAME
1251 MOVE LIT-CARD-FILE TO ERROR-FILE
1252 MOVE WS-RESP-CD TO ERROR-RESP
1253 MOVE WS-REAS-CD TO ERROR-RESP2
1254 MOVE WS-FILE-ERROR-MESSAGE TO WS-ERROR-MSG
1255 END-EVALUATE
1256 END-PERFORM
1257
1258 EXEC CICS ENDBR FILE(LIT-CARD-FILE)
1259 END-EXEC
1260 .
1261 9000-READ-FORWARD-EXIT.
1262 EXIT
1263 .
1264 9100-READ-BACKWARDS.
1265
1266 MOVE LOW-VALUES TO WS-ALL-ROWS
1267
1268 MOVE WS-CA-FIRST-CARDKEY TO WS-CA-LAST-CARDKEY
1269
1270 *****************************************************************
1271 * Start Browse
1272 *****************************************************************
1273 EXEC CICS STARTBR
1274 DATASET(LIT-CARD-FILE)
1275 RIDFLD(WS-CARD-RID-CARDNUM)
1276 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1277 GTEQ
1278 RESP(WS-RESP-CD)
1279 RESP2(WS-REAS-CD)
1280 END-EXEC
1281 *****************************************************************
1282 * Loop through records and fetch max screen records
1283 *****************************************************************
1284 COMPUTE WS-SCRN-COUNTER =
1285 WS-MAX-SCREEN-LINES + 1
1286 END-COMPUTE
1287 SET CA-NEXT-PAGE-EXISTS TO TRUE
1288 SET MORE-RECORDS-TO-READ TO TRUE
1289
1290 *****************************************************************
1291 * Now we show the records from previous set.
1292 *****************************************************************
1293
1294 EXEC CICS READPREV
1295 DATASET(LIT-CARD-FILE)
1296 INTO (CARD-RECORD)
1297 LENGTH(LENGTH OF CARD-RECORD)
1298 RIDFLD(WS-CARD-RID-CARDNUM)
1299 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1300 RESP(WS-RESP-CD)
1301 RESP2(WS-REAS-CD)
1302 END-EXEC
1303
1304 EVALUATE WS-RESP-CD
1305 WHEN DFHRESP(NORMAL)
1306 WHEN DFHRESP(DUPREC)
1307 SUBTRACT 1 FROM WS-SCRN-COUNTER
1308 WHEN OTHER
1309 * This is some kind of error. Change to END BR
1310 * And exit
1311 SET READ-LOOP-EXIT TO TRUE
1312 MOVE 'READ' TO ERROR-OPNAME
1313 MOVE LIT-CARD-FILE TO ERROR-FILE
1314 MOVE WS-RESP-CD TO ERROR-RESP
1315 MOVE WS-REAS-CD TO ERROR-RESP2
1316 MOVE WS-FILE-ERROR-MESSAGE TO WS-ERROR-MSG
1317 GO TO 9100-READ-BACKWARDS-EXIT
1318 END-EVALUATE
1319
1320 PERFORM UNTIL READ-LOOP-EXIT
1321
1322 EXEC CICS READPREV
1323 DATASET(LIT-CARD-FILE)
1324 INTO (CARD-RECORD)
1325 LENGTH(LENGTH OF CARD-RECORD)
1326 RIDFLD(WS-CARD-RID-CARDNUM)
1327 KEYLENGTH(LENGTH OF WS-CARD-RID-CARDNUM)
1328 RESP(WS-RESP-CD)
1329 RESP2(WS-REAS-CD)
1330 END-EXEC
1331
1332 EVALUATE WS-RESP-CD
1333 WHEN DFHRESP(NORMAL)
1334 WHEN DFHRESP(DUPREC)
1335 PERFORM 9500-FILTER-RECORDS
1336 THRU 9500-FILTER-RECORDS-EXIT
1337 IF WS-DONOT-EXCLUDE-THIS-RECORD
1338 MOVE CARD-NUM
1339 TO WS-ROW-CARD-NUM(WS-SCRN-COUNTER)
1340 MOVE CARD-ACCT-ID
1341 TO WS-ROW-ACCTNO(WS-SCRN-COUNTER)
1342 MOVE CARD-ACTIVE-STATUS
1343 TO
1344 WS-ROW-CARD-STATUS(WS-SCRN-COUNTER)
1345
1346 SUBTRACT 1 FROM WS-SCRN-COUNTER
1347 IF WS-SCRN-COUNTER = 0
1348 SET READ-LOOP-EXIT TO TRUE
1349
1350 MOVE CARD-ACCT-ID
1351 TO WS-CA-FIRST-CARD-ACCT-ID
1352 MOVE CARD-NUM
1353 TO WS-CA-FIRST-CARD-NUM
1354 ELSE
1355 CONTINUE
1356 END-IF
1357 ELSE
1358 CONTINUE
1359 END-IF
1360
1361 WHEN OTHER
1362 * This is some kind of error. Change to END BR
1363 * And exit
1364 SET READ-LOOP-EXIT TO TRUE
1365 MOVE 'READ' TO ERROR-OPNAME
1366 MOVE LIT-CARD-FILE TO ERROR-FILE
1367 MOVE WS-RESP-CD TO ERROR-RESP
1368 MOVE WS-REAS-CD TO ERROR-RESP2
1369 MOVE WS-FILE-ERROR-MESSAGE TO WS-ERROR-MSG
1370 END-EVALUATE
1371 END-PERFORM
1372 .
1373
1374 9100-READ-BACKWARDS-EXIT.
1375 EXEC CICS
1376 ENDBR FILE(LIT-CARD-FILE)
1377 END-EXEC
1378
1379 EXIT
1380 .
1381
1382 9500-FILTER-RECORDS.
1383 SET WS-DONOT-EXCLUDE-THIS-RECORD TO TRUE
1384
1385 IF FLG-ACCTFILTER-ISVALID
1386 IF CARD-ACCT-ID = CC-ACCT-ID
1387 CONTINUE
1388 ELSE
1389 SET WS-EXCLUDE-THIS-RECORD TO TRUE
1390 GO TO 9500-FILTER-RECORDS-EXIT
1391 END-IF
1392 ELSE
1393 CONTINUE
1394 END-IF
1395
1396 IF FLG-CARDFILTER-ISVALID
1397 IF CARD-NUM = CC-CARD-NUM-N
1398 CONTINUE
1399 ELSE
1400 SET WS-EXCLUDE-THIS-RECORD TO TRUE
1401 GO TO 9500-FILTER-RECORDS-EXIT
1402 END-IF
1403 ELSE
1404 CONTINUE
1405 END-IF
1406
1407 .
1408
1409 9500-FILTER-RECORDS-EXIT.
1410 EXIT
1411 .
1412
1413 *****************************************************************
1414 *Common code to store PFKey
1415 *****************************************************************
1416 COPY 'CSSTRPFY'
1417 .
1418
1419 *****************************************************************
1420 * Plain text exit - Dont use in production *
1421 *****************************************************************
1422 SEND-PLAIN-TEXT.
1423 EXEC CICS SEND TEXT
1424 FROM(WS-ERROR-MSG)
1425 LENGTH(LENGTH OF WS-ERROR-MSG)
1426 ERASE
1427 FREEKB
1428 END-EXEC
1429
1430 EXEC CICS RETURN
1431 END-EXEC
1432 .
1433 SEND-PLAIN-TEXT-EXIT.
1434 EXIT
1435 .
1436 *****************************************************************
1437 * Display Long text and exit *
1438 * This is primarily for debugging and should not be used in *
1439 * regular course *
1440 *****************************************************************
1441 SEND-LONG-TEXT.
1442 EXEC CICS SEND TEXT
1443 FROM(WS-LONG-MSG)
1444 LENGTH(LENGTH OF WS-LONG-MSG)
1445 ERASE
1446 FREEKB
1447 END-EXEC
1448
1449 EXEC CICS RETURN
1450 END-EXEC
1451 .
1452 SEND-LONG-TEXT-EXIT.
1453 EXIT
1454 .
1455
1456
1457 *
1458 * Ver: CardDemo_v1.0-15-g27d6c6f-68 Date: 2022-07-19 23:12:33 CDT
1459 *