000010 IDENTIFICATION DIVISION. 000020 PROGRAM-ID. MENU1. 000030 AUTHOR. IBMUSER (Using Jazz, Version 0.12.3.55) 000040 DATE-WRITTEN. 22/11/2014 5:49:07 p.m. 000050 ENVIRONMENT DIVISION. 000060*# Last Updated by IBMUSER at 22/11/2014 5:49:07 p.m. 000070* PROGRAM MENU1 CICS INSCREEN(MENU1S) TRANSID(MNU1) 000080* COMMAREA(MENU1C) ; 000090*ACCEPT (MENU1S.Function); 000100*CASE (MENU1C.Function); 000110* WHEN (1); 000120* EXIT TO CICS1; 000130* WHEN (2); 000140* EXIT TO CICS2; 000150* WHEN (3); 000160* EXIT TO CICS3; 000170*END CASE; 000180****************************************************************** 000190** ** 000200** Data Division ** 000210** ** 000220****************************************************************** 000230 DATA DIVISION. 000240****************************************************************** 000250** ** 000260** Working Storage Section: General Program Data ** 000270** ** 000280****************************************************************** 000290* 000300 WORKING-STORAGE SECTION. 000310****************************************************************** 000320** ** 000330** Screen Areas ** 000340** ** 000350****************************************************************** 000360* 000370 COPY DFHAID. 000380* 000390 01 MENU1S. 000400 03 FILLER PIC X(12). 000410* SpecialConstant VALUE 'MENU1' 000420 03 SCNST1. 000430 05 LTH PIC S9(4) COMP. 000440 05 ATTR PIC X. 000450 05 COLR PIC X. 000460 05 HLIT PIC X. 000470 05 FILLER PIC X(5). 000480* Constant VALUE 'MANAJAZZ TEST SYSTEM' 000490 03 CNST6. 000500 05 LTH PIC S9(4) COMP. 000510 05 ATTR PIC X. 000520 05 COLR PIC X. 000530 05 HLIT PIC X. 000540 05 FILLER PIC X(20). 000550* SpecialConstant VALUE 'MNU1' 000560 03 SCNST4. 000570 05 LTH PIC S9(4) COMP. 000580 05 ATTR PIC X. 000590 05 COLR PIC X. 000600 05 HLIT PIC X. 000610 05 FILLER PIC X(4). 000620* Constant VALUE 'Choose Function from the list below' 000630 03 CNST7. 000640 05 LTH PIC S9(4) COMP. 000650 05 ATTR PIC X. 000660 05 COLR PIC X. 000670 05 HLIT PIC X. 000680 05 FILLER PIC X(35). 000690* Constant VALUE '1 Basic Customer Enquiry' 000700 03 CNST8. 000710 05 LTH PIC S9(4) COMP. 000720 05 ATTR PIC X. 000730 05 COLR PIC X. 000740 05 HLIT PIC X. 000750 05 FILLER PIC X(27). 000760* Constant VALUE '2 Customer Enquiry and Update' 000770 03 CNST10. 000780 05 LTH PIC S9(4) COMP. 000790 05 ATTR PIC X. 000800 05 COLR PIC X. 000810 05 HLIT PIC X. 000820 05 FILLER PIC X(32). 000830* Constant VALUE '3 Orders by Customer' 000840 03 CNST11. 000850 05 LTH PIC S9(4) COMP. 000860 05 ATTR PIC X. 000870 05 COLR PIC X. 000880 05 HLIT PIC X. 000890 05 FILLER PIC X(23). 000900* Constant VALUE 'Function.' 000910 03 CNST12. 000920 05 LTH PIC S9(4) COMP. 000930 05 ATTR PIC X. 000940 05 COLR PIC X. 000950 05 HLIT PIC X. 000960 05 FILLER PIC X(9). 000970* Field ='MENU1C.Function' VALUE 'X' 000980 03 JZ-Function. 000990 05 LTH PIC S9(4) COMP. 001000 05 ATTR PIC X. 001010 05 COLR PIC X. 001020 05 HLIT PIC X. 001030 05 INPT PIC X(1). 001040 05 OUT REDEFINES INPT PIC X. 001050* ErrorFlag VALUE '*' 001060 03 EFLD14. 001070 05 LTH PIC S9(4) COMP. 001080 05 ATTR PIC X. 001090 05 COLR PIC X. 001100 05 HLIT PIC X. 001110 05 OUT PIC X(1). 001120* ErrorFlag VALUE 001130* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 001140* xxxxxxxxxxxxxxxxxxxxx' 001150 03 JZ-Error. 001160 05 LTH PIC S9(4) COMP. 001170 05 ATTR PIC X. 001180 05 COLR PIC X. 001190 05 HLIT PIC X. 001200 05 OUT PIC X(80). 001210* SpecialConstant VALUE 'PF Keys. PF3=Return, PF12 = Exit' 001220 03 SCNST6. 001230 05 LTH PIC S9(4) COMP. 001240 05 ATTR PIC X. 001250 05 COLR PIC X. 001260 05 HLIT PIC X. 001270 05 FILLER PIC X(33). 001280* SpecialConstant VALUE '@' 001290 03 SCNST7. 001300 05 LTH PIC S9(4) COMP. 001310 05 ATTR PIC X. 001320 05 COLR PIC X. 001330 05 HLIT PIC X. 001340 05 FILLER PIC X(1). 001350* 001360* Program ID etc - in case of errors 001370 01 JZ-Program-Info. 001380 03 PROG-ID PIC X(20) VALUE 'PROGRAM MENU1'. 001390 03 AUTH PIC X(40) VALUE 'IBMUSER (Using Jazz, V0.0)'. 001400 03 DTE-WRITTEN PIC X(24) VALUE '22/11/2014 5:49:07 p.m.'. 001410 03 JZ-Jazz-Stmt PIC X(80) VALUE SPACES. 001420 03 JZ-CICS-Stmt PIC X(80) VALUE SPACES. 001430 03 JZ-Response PIC S9(8) BINARY VALUE 0. 001440 03 JZ-Response2 PIC S9(8) BINARY VALUE 0. 001450* 001460* Status Flags and control data 001470 01 JZ-FileControl. 001480 03 MENU1S-Error-Flag PIC X VALUE 'Y'. 001490* 001500 LOCAL-STORAGE SECTION. 001510****************************************************************** 001520** ** 001530** JZ - Jazz Sundry fields ** 001540** ** 001550****************************************************************** 001560* 001570 01 JZ. 001580 03 JZ-TRUE PIC X VALUE 'Y'. 001590 03 JZ-FALSE PIC X VALUE 'N'. 001600 03 JZ-BLANK PIC XXXX VALUE SPACES. 001610 03 JZ-CHAR80 PIC X(80) VALUE SPACES. 001620 03 JZ-FNAME PIC X(30) VALUE SPACES. 001630 03 JZ-MLTH PIC S9(4) COMP VALUE 0. 001640 03 JZ-TinyNbr PIC S9(4) COMP VALUE ZERO. 001650 03 JZ-TinyGr REDEFINES JZ-TinyNbr. 001660 05 FILLER PIC X. 001670 05 JZ-Tiny PIC X. 001680****************************************************************** 001690** ** 001700** MENU1C (COMMAREA) ** 001710** ** 001720****************************************************************** 001730* 001740 01 MENU1C. 001750 03 JZ-Function PIC 9 VALUE ZERO. 001760****************************************************************** 001770** ** 001780** Linkage Section: Commarea ** 001790** ** 001800****************************************************************** 001810* 001820 LINKAGE SECTION. 001830* 001840 01 DFHCOMMAREA. 001850 05 JZ-Function PIC 9. 001860****************************************************************** 001870** ** 001880** Procedure Division. ** 001890** ** 001900****************************************************************** 001910* 001920 PROCEDURE DIVISION. 001930 EXEC CICS 001940 HANDLE ABEND LABEL(JZ-Abend-Exit) RESP(JZ-RESPONSE) 001950 END-EXEC. 001960 PERFORM CICS-CheckStatus. 001970* No message is returned with CLEAR or PA1-3 001980 IF EIBAID = DFHCLEAR OR DFHPA1 OR DFHPA2 OR DFHPA3 001990 GO TO JZ-Main-Program-Logic 002000 END-IF. 002010* Check that there is a message to read 002020 IF EIBCALEN = 0 002030 MOVE LOW-VALUE TO MENU1S 002040 MOVE 'SEND MAP(''MENU1S'') FROM(MENU1S) ERASE' TO 002050 JZ-CICS-Stmt 002060 EXEC CICS 002070 SEND MAP('MENU1S') FROM(MENU1S) ERASE RESP(JZ-RESPONSE) 002080 END-EXEC 002090 PERFORM CICS-CheckStatus 002100* Read Input Screen 002110 Else 002120 MOVE DFHCOMMAREA TO MENU1C 002130 MOVE 'RECEIVE MAP(''MENU1S'') INTO(MENU1S)' TO JZ-CICS-Stmt 002140 EXEC CICS 002150 RECEIVE MAP('MENU1S') INTO(MENU1S) RESP(JZ-RESPONSE) 002160 END-EXEC 002170 PERFORM CICS-CheckStatus 002180* Clear error flags (in case prior ACCEPT found errors) 002190 MOVE SPACE TO OUT OF EFLD14 OF MENU1S 002200 PERFORM JZ-Main-Program-Logic 002210 END-IF. 002220* 002230 JZ-Normal-Exit. 002240 MOVE 'RETURN TRANSID(''MNU1'') COMMAREA(MENU1C)' TO 002250 JZ-CICS-Stmt. 002260 EXEC CICS 002270 RETURN TRANSID('MNU1') COMMAREA(MENU1C) RESP(JZ-RESPONSE) 002280 END-EXEC. 002290 GOBACK. 002300* 002310 JZ-Abend-Exit. 002320 CALL 'JZABNDC' USING DFHEIBLK DFHCOMMAREA JZ-Program-Info. 002330 GOBACK. 002340****************************************************************** 002350** ** 002360** Main Program Logic ** 002370** ** 002380****************************************************************** 002390* 002400 JZ-Main-Program-Logic. 002410* 002420* Detect and handle Aid Keys 002430 EVALUATE EIBAID 002440 WHEN DFHCLEAR 002450 PERFORM JZ-AID-CLEAR 002460 WHEN DFHPF3 002470 PERFORM JZ-AID-PF3 002480 WHEN DFHPF12 002490 PERFORM JZ-AID-PF12 002500 WHEN DFHENTER 002510 PERFORM JZ-AID-ENTER 002520 WHEN OTHER 002530 PERFORM JZ-AID-OTHER 002540 END-EVALUATE. 002550 GO TO JZ-NORMAL-EXIT. 002560****************************************************************** 002570** ** 002580** Process Default AID keys ** 002590** ** 002600****************************************************************** 002610* 002620 JZ-AID-CLEAR. 002630 MOVE 'SEND TEXT FROM(JZ-BLANK) ERASE FREEKB' TO JZ-CICS-Stmt. 002640 EXEC CICS 002650 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB RESP(JZ-RESPONSE) 002660 END-EXEC. 002670 PERFORM CICS-CheckStatus. 002680 GOBACK. 002690* 002700 JZ-AID-PF3. 002710 GO TO JZ-Normal-Exit. 002720* 002730 JZ-AID-PF12. 002740 MOVE 'XCTL PROGRAM('' '')' TO JZ-CICS-Stmt. 002750 EXEC CICS 002760 XCTL PROGRAM(' ') RESP(JZ-RESPONSE) 002770 END-EXEC. 002780 PERFORM CICS-CheckStatus. 002790 GOBACK. 002800* 002810 JZ-AID-OTHER. 002820 MOVE 'INVALID FUNCTION KEY' TO OUT OF JZ-Error OF MENU1S. 002830 MOVE 'SEND MAP(''MENU1S'') FROM(MENU1S) ALARM DATAONLY' TO 002840 JZ-CICS-Stmt. 002850 EXEC CICS 002860 SEND MAP('MENU1S') FROM(MENU1S) ALARM DATAONLY 002870 RESP(JZ-RESPONSE) 002880 END-EXEC. 002890 PERFORM CICS-CheckStatus. 002900 GO TO JZ-NORMAL-EXIT. 002910* 002920 JZ-AID-ENTER. 002930****************************************************************** 002940** ** 002950** Normal Processing Logic (ENTER clicked) ** 002960** ** 002970****************************************************************** 002980* ACCEPT (MENU1S.Function); 002990 Move '000090 ACCEPT (MENU1S.Function);' TO JZ-Jazz-Stmt. 003000 MOVE SPACES TO OUT OF JZ-Error OF MENU1S. 003010 MOVE ZERO TO LTH OF JZ-Error OF MENU1S. 003020 MOVE 'N' TO MENU1S-Error-Flag. 003030* Validate MENU1S.Function, assign to MENU1C.Function 003040 MOVE SPACES TO JZ-CHAR80. 003050 MOVE 'Function' TO JZ-FNAME. 003060 IF LTH OF JZ-Function OF MENU1S > ZERO 003070 IF INPT OF JZ-Function OF MENU1S IS NUMERIC 003080 COMPUTE JZ-Function OF MENU1C = FUNCTION NUMVAL(INPT 003090 OF JZ-Function OF MENU1S) 003100 ELSE 003110 MOVE 'not numeric' TO JZ-CHAR80 003120 END-IF 003130* Check Range 003140 IF JZ-CHAR80 = SPACE 003150 IF JZ-Function OF MENU1C < 1 OR JZ-Function OF MENU1C 003160 > 3 003170 MOVE ' outside valid range' TO JZ-CHAR80 003180 END-IF 003190 END-IF 003200 END-IF. 003210 IF JZ-CHAR80 NOT = SPACE 003220 MOVE 'Y' TO MENU1S-Error-Flag 003230 MOVE '*' TO OUT OF EFLD14 OF MENU1S 003240 MOVE -1 TO LTH OF JZ-Function OF MENU1S 003250 MOVE 80 TO JZ-MLTH 003260 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 003270 MENU1S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 003280 END-IF. 003290 IF MENU1S-Error-Flag = 'Y' 003300* Respond with error messages and exit program 003310 MOVE 'SEND MAP(''MENU1S'') FROM(MENU1S) CURSOR ALARM' TO 003320 JZ-CICS-Stmt 003330 EXEC CICS 003340 SEND MAP('MENU1S') FROM(MENU1S) CURSOR ALARM 003350 RESP(JZ-RESPONSE) 003360 END-EXEC 003370 PERFORM CICS-CheckStatus 003380 GO TO JZ-Normal-Exit 003390 END-IF. 003400* CASE (MENU1C.Function); 003410 Move '000100 CASE (MENU1C.Function);' TO JZ-Jazz-Stmt. 003420 EVALUATE JZ-Function OF MENU1C 003430* WHEN (1); 003440 When 1 003450 PERFORM JZ-12-WHEN 003460* WHEN (2); 003470 When 2 003480 PERFORM JZ-14-WHEN 003490* WHEN (3); 003500 When 3 003510 PERFORM JZ-16-WHEN 003520 END-EVALUATE. 003530* 003540 JZ-12-WHEN. 003550* EXIT TO CICS1; 003560 Move '000120 EXIT TO CICS1;' TO JZ-Jazz-Stmt. 003570 MOVE 'XCTL PROGRAM(''CICS1'')' TO JZ-CICS-Stmt. 003580 EXEC CICS 003590 XCTL PROGRAM('CICS1') RESP(JZ-RESPONSE) 003600 END-EXEC. 003610 PERFORM CICS-CheckStatus. 003620* 003630 JZ-14-WHEN. 003640* EXIT TO CICS2; 003650 Move '000140 EXIT TO CICS2;' TO JZ-Jazz-Stmt. 003660 MOVE 'XCTL PROGRAM(''CICS2'')' TO JZ-CICS-Stmt. 003670 EXEC CICS 003680 XCTL PROGRAM('CICS2') RESP(JZ-RESPONSE) 003690 END-EXEC. 003700 PERFORM CICS-CheckStatus. 003710* 003720 JZ-16-WHEN. 003730* EXIT TO CICS3; 003740 Move '000160 EXIT TO CICS3;' TO JZ-Jazz-Stmt. 003750 MOVE 'XCTL PROGRAM(''CICS3'')' TO JZ-CICS-Stmt. 003760 EXEC CICS 003770 XCTL PROGRAM('CICS3') RESP(JZ-RESPONSE) 003780 END-EXEC. 003790 PERFORM CICS-CheckStatus. 003800* END CASE; 003810* 003820 CICS-CheckStatus. 003830 EVALUATE JZ-Response 003840 WHEN DFHRESP(NORMAL) 003850 CONTINUE 003860 WHEN OTHER 003870 GO TO JZ-Abend-Exit 003880 END-EVALUATE.