bdfp1m0v | Programming Concepts and Reference |
This section shows how you might code this example using the TPFDF macros.
The member file requires the following types of processing:
Figure 10 shows the file maintenance procedure.
Figure 11 shows the departure control interface.
Figure 12 shows the monthly maintenance procedure.
Figure 10. SAM0-File Maintenance Program
BEGIN NAME=SAM0,VERSION=00 SPACE , *---------------------------------------------------------------------* * MEMBERSHIP FILE MAINTENANCE * * Display a member's record : *member-nbr * * Delete a member's number : Dmember-nbr * * Add a new member : Amember-name * * Change members details : Cmember-nbr/option/info * * where option - A address * * - M meal preference * * - S seat preference * * - P payment method * *---------------------------------------------------------------------* MI0MI REG=R1 INPUT MESSAGE DSECT GLOBZ REGR=R2 BASE GLOBALS L R1,EBCCR0 BASE OF INPUT MESSAGE BLOCK *---------------------------------------------------------------------* * CHECK TO SEE IF SUBFILE IS TO BE OPENED WITH HOLD * *---------------------------------------------------------------------* #IF CLI,MI0ACC,EQ,C'*' DISPLAY REQUEST ? DBOPN REF=IR00DF,REG=R5,DETAC NO NEED FOR HOLD #ELSE MUST BE TYPE OF MODIFY DBOPN REF=IR00DF,REG=R5,HOLD,DETAC HOLD REQUIRED #EIF *---------------------------------------------------------------------* * CHECK TO SEE IF MEMBER NUMBER IS TO BE DELETED * *---------------------------------------------------------------------* #IF CLI,MI0ACC,EQ,C'D' DELETE REQUEST ? DBRED REF=IR00DF,REG=R5,ALG=MI0ACC+1, READ SUBFILE X ERROR=SUBFILE-ERROR #IF DBIDX,NO WTOPC TEXT='INVALID NUMBER',PREFIX=SAM0,NUM=001,LET=I #ELSE *---------------------------------------------------------------------* * DBCLS WITH RELFC HAS IMPLIED DEINDEX AND DBDEL,ALL. * * SPECIFY THE REUSE PARAMETER TO USE THE SAME SW00SR SLOT TO * * UPDATE THE 'DELETED MEMBERS' SUBFILE * *---------------------------------------------------------------------* DBCLS REF=IR00DF,RELFC,NOKEY,REUSE DBOPN REF=IR00DF,REG=R5,HOLD,DETAC,ALG==C'9999999999' *---------------------------------------------------------------------* * BUILD NEW LREC FOR DELETED MEMBERSHIP NUMBER * *---------------------------------------------------------------------* MVC EBW000(L'IR00SIZ),=AL2(#IR00LC0) SET UP SIZE MVI EBW002,#IR00KC0 PRIMARY KEY MVC EBW003(L'IR00NUM),MI0ACC+1 DELETED NBR.
*---------------------------------------------------------------------* * ADD NEW LREC - DEFAULT KEYS SPECIFIED IN DBDEF. * *---------------------------------------------------------------------* DBADD REF=IR00DF,REG=R5,NEWLREC=EBW000, X ERROR=SUBFILE-ERROR #EIF #ELIF CLI,MI0ACC,EQ,C'*' DBRED REF=IR00DF,REG=R5,ALG=MI0ACC+1, X ERROR=SUBFILE-ERROR #IF DBIDX,NO WTOPC TEXT='INVALID NUMBER',PREFIX=SAM0,NUM=001,LET=I #ELSE *---------------------------------------------------------------------* * THIS IS JUST AN EXAMPLE OF THE USE OF DISPLAY, ITS USE IS NOT * * APPROPRIATE HERE AS SOME OF THE DATA IS NOT IN DISPLAYABLE FORMAT. * * DBDSP AUTOMATICALLY DELETES THE SIZE FIELDS FROM THE DISPLAY. * *---------------------------------------------------------------------* DBDSP REF=IR00DF,STRIP==AL2(L'IR00KEY),NOKEY, X ERROR=SUBFILE-ERROR #EIF #ELIF CLI,MI0ACC,EQ,C'A' *---------------------------------------------------------------------* * CHECK THE LENGTH OF THE INPUT MESSAGE DOESN'T EXCEDE MAX. ALLOWED * *---------------------------------------------------------------------* #IF MI0CCT,GT,=AL2(L'IR00NAM+1) INPUT MSG > MAXIMUM ? WTOPC TEXT='NAME EXCEEDS MAX.',PREFIX=SAM0,NUM=002,LET=E #ELSE *---------------------------------------------------------------------* * GET NEW MEMBERSHIP NUMBER * *---------------------------------------------------------------------* DBRED REF=IR00DF,REG=R5,ALG==C'9999999999',NOKEY, X ERROR=SUBFILE-ERROR #IF DBIDX,NO *---------------------------------------------------------------------* * DOESN'T EXIST, SO INITIALIZE THE FILE * *---------------------------------------------------------------------* DBADD REF=IR00DF,REG=R5,NEWLREC=SAM0INIT, X ERROR=SUBFILE-ERROR MVC EBX000(L'IR00NUM),=C'0000000001' NEW NBR. #ELSE *---------------------------------------------------------------------* * FILE EXISTS, SO CHECK TO SEE IF PREVIOUSLY DELETED NUMBER * *---------------------------------------------------------------------* #IF IR00KEY,EQ,#IR00KC0 PREVIOUSLY DELETED NBR. MVC EBX000(L'IR00NUM),IR00NUM DBDEL REF=IR00DF,REG=R5,ERROR=SUBFILE-ERROR #ELSE
*---------------------------------------------------------------------* * THIS IS THE CONSECUTIVE LREC, SO MUST UPDATE IT, * *---------------------------------------------------------------------* MVC EBX000(L'IR00NUC),IR00NUC #PERF R7,UPDATE-NEXT-AVAIL-NUMBER #EIF DBCLS REF=IR00DF,REUSE DBOPN REF=IR00DF,REG=R5,HOLD *---------------------------------------------------------------------* * CREATE A NEW SUBFILE USING THE NEW MEMBER NBR. AS ALG= STRING. * *---------------------------------------------------------------------* DBCRE REF=IR00DF,INDEX,ALG=EBX000, X ERROR=NEW-ERROR *---------------------------------------------------------------------* * BUILD THE NAME LREC FROM THE INPUT MSG. * *---------------------------------------------------------------------* LH R4,MI0CCT GET INPUT MESSAGE LENGTH #STPR R4,-2 ADJUST FOR 'A' PART & EX EX R4,SAM0MOV1 START TO BUILD NEW LREC #STPR R4,L'IR00KEY+l'IR00SIZ SIZ + PRIMARY KEY STH R4,EBW000 STORE SIZE MVI EBW002,#IR00L80 SET UP PRIMARY KEY *---------------------------------------------------------------------* * ADD THE NAME LREC AND DUMMY LRECS FOR THE OTHER INFORMATION. * *---------------------------------------------------------------------* DBADD REF=IR00DF,REG=R5,NEWLREC=EBW000, X ERROR=NEW-ERROR DBADD REF=IR00DF,REG=R5,NEWLREC=SAM0ADDR, X ERROR=NEW-ERROR DBADD REF=IR00DF,REG=R5,NEWLREC=SAM0MEAL, X ERROR=NEW-ERROR DBADD REF=IR00DF,REG=R5,NEWLREC=EBW000, X ERROR=NEW-ERROR *---------------------------------------------------------------------* * UPDATE THE EXPIRATION DATE FOR THE NEW MEMBER, TODAY + A YEAR. * *---------------------------------------------------------------------* LH R4,@YEAR #STPR R4,1 STH R4,IR00EXY MVC IR00EXM,@MONTH DBMOD REF=IR00DF MVC EBW000(L'SAM0MSG1),SAM0MSG1 SKELETON MSG MVC EBW000+21(L'IR00NUM),EBX000 MOVE IN NEW NBR WTOPC TEXTA=EBW000,PREFIX=SAM0,NUM=006,LET=I #EIF #EIF
*---------------------------------------------------------------------* * MODIFY REQUEST * *---------------------------------------------------------------------* #ELIF CLI,MI0ACC,EQ,C'C',AND, CHANGE REQUEST ? # CLI,MI0ACC+11,EQ,C'/' #IF CLI,MI0ACC+12,EQ,C'A',AND, ADDRESS ? # MI0CCT,GT,=AL2(L'IR00ADR+L'IR00NUM+4) INPUT OK ? DBRED REF=IR00DF,ALG=MI0ACC+1,KEY1=(PKY=#IR00K90), X REG=R5,ERROR=SUBFILE-ERROR LH R4,MI0CCT LOAD LENGTH OF INPUT SH R4,=AL2(L'IR00NUM+4) ADJUST FOR EX & NUMBER EX R4,SAM0MOV2 MOVE #STPR R4,l'IR00SIZ+l'IR00KEY STH R4,IR00SIZ MVI IR00KEY,#IR00K90 DBMOD REF=IR00DF,REG=R5 #ELIF CLI,MI0ACC+12,EQ,C'M',OR, MEAL ? # CLI,MI0ACC+12,EQ,C'S',OR, SEAT ? # CLI,MI0ACC+12,EQ,C'P',ANDIF, PAYMENT ? # MI0CCT,GT,=AL2(L'IR00MPR+L'IR00NUM+4) INPUT OK ? DBRED REF=IR00DF,ALG=MI0ACC+1,KEY1=(PKY=#IR00KA0), X REG=R5,ERROR=SUBFILE-ERROR LH R4,MI0ACC+15 GET NEW INFORMATION #IF MI0ACC+12,EQ,C'M' MEAL ? ST R4,IR00MPR STORE IT IN CORRECT FIELD #ELIF MI0ACC+12,EQ,C'S' SEAT ? ST R4,IR00SPR STORE IT IN CORRECT FIELD #ELIF MI0ACC+12,EQ,C'P' PAYMENT ? ST R4,IR00PAY STORE IT IN CORRECT FIELD #EIF DBMOD REF=IR00DF,REG=R5 UPDATE DATABASE WTOPC TEXT='DETAILS MODIFIED',PREFIX=SAM0,NUM=005,LET=E #EIF WTOPC TEXT='INVALID INPUT',PREFIX=SAM0,NUM=005,LET=E #EIF #LOCA EXIT DBCLS REF=IR00DF,RELEASE CLOSE SUBFILE & RELEASE SW00SR EXITC , SPACE , *---------------------------------------------------------------------* * SUBROUTINE TO INCREMENT CONSECUTIVE MEMBER RECORD BY 1 (DATA PACKED)* *---------------------------------------------------------------------* SPACE , #SUBR UPDATE-NEXT-AVAIL-NUMBER PACK EBX010(L'IR00NUC),EBX000(L'IR00NUC) PACK DATA AP EBX010(L'IR00NUC),=P'1' ADD '1' UNPK EBX000(L'IR00NUC),EBX010(L'IR00NUC) UNPACK DATA OI EBX009,X'F0' CLEAR SIGN BIT #IF EBX000(L'IR00NUC),EQ,=C'9999999999' NO MORE NBRS #GOTO DATABASE-FULL #EIF MVC IR00NUC,EBX000 UPDATE LREC DBMOD REF=IR00DF,REG=R5 UPDATE DATABASE #ESUB
*---------------------------------------------------------------------* * ERROR HANDLING * *---------------------------------------------------------------------* #LOCA SUBFILE-ERROR WTOPC TEXT='ERROR IN DETAIL SUBFILE',PREFIX=SAM0,NUM=006,LET=E #GOTO EXIT #LOCA NEW-ERROR WTOPC TEXT='ERROR IN NEW SUBFILE',PREFIX=SAM0,NUM=007,LET=E #GOTO EXIT #LOCA DATABASE-FULL WTOPC TEXT='DATABASE FULL',PREFIX=SAM0,NUM=006,LET=E *---------------------------------------------------------------------* * EXECUTABLE MOVE INSTRUCTIONS * *---------------------------------------------------------------------* SAM0MOV1 MVC EBW003(0),MI0ACC+1 EXECUTABLE MOVE INSTR. SAM0MOV2 MVC IR00ADR(0),MI0ACC+13 EXECUTABLE MOVE INSTR. SPACE , *---------------------------------------------------------------------* * LREC TO INITIALIZE NUMBERS SUBFILE, FIRST NUMBER TO BE ADDED IS * * '2' AS WILL ONLY BE INITIALIZED WHEN NBR '1' IS ALLOCATED. * *---------------------------------------------------------------------* SPACE , SAM0INIT DC AL2(#IR00LD0),AL1(#IR00KD0),C'0000000002' SPACE , *---------------------------------------------------------------------* * DUMMY RECORD TO INITIALIZE NEW MEMBER'S SUBFILE * *---------------------------------------------------------------------* SPACE , SAM0ADDR DC AL2(#IR00L90),AL1(#IR00K90),CL43' ' SAM0MEAL DC AL2(#IR00LA0),AL1(#IR00KA0),CL7' ' SAM0INFO DC AL2(#IR00LB0),AL1(#IR00KB0),C' ',XL6'00' SPACE , SAM0MSG1 DC AL1(SAM0END1-SAM0MSG1) DC C'NEW MEMBER CREATED - ..........' SAM0END1 EQU * SPACE , LTORG FINIS SAM0 END
Figure 11. SAM-Departure Control Interface
BEGIN NAME=SAM1,VERSION=00 SPACE , *---------------------------------------------------------------------* * DEPARTURE CONTROL INTERFACE - UPDATES THE MILEAGE FLOWN AND * * ADJUSTS THE EXPIRATION DATE OF THE MEMBERSHIP BASED ON AN * * EXTRA MONTH'S MEMBERSHIP FOR EACH 1000 MILES FLOWN. * * NO ERRORS ARE ISSUED FROM THIS PROGRAM, INDICATORS ARE * * RETURNED AS SHOWN BELOW. * *---------------------------------------------------------------------* * INPUT CONDITIONS * * EBW000(L'10) - MEMBERSHIP NUMBER * * EBW010(L'2 ) - MILEAGE TO CREDIT * * * * OUTPUT CONDITIONS * * EBSW01 X'80'- NO SUBFILE FOR MEMBER NUMBER SPECIFIED * * X'40'- NO MILEAGE LREC IN SUBFILE * * X'20'- SERIOUS ERROR ON READ * * X'00'- EVERYTHING OK * *---------------------------------------------------------------------* SPACE , *---------------------------------------------------------------------* * OPEN SUBFILE USING MEMBER-NBR. AS ALG= STRING * *---------------------------------------------------------------------* SPACE , DBOPN REF=IR00DF,REG=R5,HOLD SPACE ,
*---------------------------------------------------------------------* * SEARCH FOR MILEAGE LREC BASED ON ITS UNIQUE PRIMARY KEY * *---------------------------------------------------------------------* SPACE , DBRED REF=IR00DF,REG=R5,ALG=EBW000, X KEY1=(PKY=#IR00KB0), X ERROR=READ-ERROR #IF DBIDX,NO DETAIL SUBFILE INDEXED MVI EBSW01,X'80' INDICATE ERROR #ELIF DBFOUND,NO MILEAGE LREC NOT FOUND MVI EBSW01,X'40' INDICATE ERROR #ELSE LH R6,EBW010 MILEAGE TO CREDIT A R6,IR00MLS ADD TO EXISTING MILEAGE SRDA R6,32(0) SET UP EVEN-ODD REG. FOR D D R6,=H'1000' CALC THE INC. OF EXPIRATION DATE AH R7,IR00EXM ADD EXTRA MONTHS TO EXP. MONTH #IF R7,GT,=H'12' MORE THAN 12 MONTHS #DO WHILE=(R7,GT,=H'12) WHILE MORE THAN 12 MONTHS #STPR R7,-12 DELETE A YEAR #STPH R6,1,IR00EXY ADD A YEAR TO EXPIRATION DATE #EDO #EIF STH R7,IR00EXM STORE NBR OF EXPIRATION MONTHS DBMOD REF=IR00DF,REG=R5 UPDATE DATABASE MVI EBSW01,X'00' EVERYTHING OK #EIF #LOCA EXIT DBCLS REF=IR00DF,RELEASE CLOSE SUBFILE, RELEASE SW00SR SLOT BACKC , RETURN TO CALLER *---------------------------------------------------------------------* * ERROR HANDLING * *---------------------------------------------------------------------* #LOCA READ-ERROR MVI EBSW01,X'20' INDICATE ERROR #GOTO EXIT CLOSE FILE & RETURN TO CALLER LTORG FINIS SAM1 END
Figure 12. SAM2-Monthly Maintenance Program
BEGIN NAME=SAM2,VERSION=00 SPACE , *---------------------------------------------------------------------* * MONTHLY MAINTENANCE PROGRAM, DELETES MEMBERS RECORDS WHICH * * HAVE EXPIRED AND ADDS THE MEMBERSHIP NUMBER TO A SUBFILE * * SO THAT THEY CAN BE RE-ISSUED. * *---------------------------------------------------------------------* GLOBZ REGR=R2 BASE GLOBALS #IF CLI,@DAY,NE,X'01' NOT FIRST DAY OF MONTH WTOPC TEST='NOT FIRST OF MONTH - UNABLE TO PROCESS', X PREFIX=SAM2,NUM=001,LET=I #ELSE *---------------------------------------------------------------------* * OPEN DETAIL SUBFILE FOR FULLFILE PROCESSING (IR00DF) AND OPEN THE * * SUBFILE WHICH CONTAINS DELETED NUMBERS (ALG==C'9999999999'). * *---------------------------------------------------------------------* DBOPN REF=IR00DF,HOLD,REG=R5 DBOPN REF=IR00DFA,HOLD,REG=R6, X ALG==C'9999999999',SUFFIX=A #DO INF INFINITE LOOP - EXIT WHEN EOF SPACE , *---------------------------------------------------------------------* * READ EACH EXPIRATION DATE LREC, SAVING MEMBER NUMBER FROM INDEX * * FILE IN EBW000 USING AREA PARAMETER (SETUP IN DBDEF). * *---------------------------------------------------------------------* SPACE , DBRED REF=IR00DF,REG=R5,FULLFILE, X AREA=EBW003, X KEY1=(PKY=#IR00KB0), X ERROR=READ-ERROR #DOEX DBEOF,YES EXIT LOOP IF END OF FILE #IF IR00EXM,LT,@MONTH,AND, EXP. MONTH < CURRENT MONTH # IR00EXY,LE,@YEAR,ORIF, & EXP. YEAR <= CURR. YEAR # IR00EXY,LT,@YEAR EXP. YEAR < CURRENT YEAR #PERF R7,UPDATE-FREE-SLOT EXPIRED MEMBERSHIP SPACE , *---------------------------------------------------------------------* * DELETE ALL LOGICAL RECORDS IN DETAIL SUBFILE, DE-INDEX IS AUTOMATIC * *---------------------------------------------------------------------* SPACE , DBDEL REF=IR00DF,ALL,NOKEY,ALG=EBW003 #EIF #EDO WTOPC TEXT='PROCESSING COMPLETED',PREFIX=SAM2,NUM=002, X LET=I *---------------------------------------------------------------------* * CLOSE BOTH FILES AND RELEASE SW00SR SLOTS * *---------------------------------------------------------------------* #LOCA EXIT DBCLS REF=IR00DF,RELEASE DBCLS REF=IR00DFA,RELEASE #EIF EXITC , SPACE ,
*---------------------------------------------------------------------* * SUBROUTINE TO UPDATE SUBFILE WITH NUMBERS TO REUSE * *---------------------------------------------------------------------* #SUBR UPDATE-FREE-SLOT MVC EBW000(L'IR00SIZ+L'IR00KEY),SAM2INFO LREC SIZE + KEY SPACE , *---------------------------------------------------------------------* * ADD LREC CONTAINING DELETED MEMEBER NBR. - ORGANIZATION OF FILE * * DETERMINED BY THE DEFAULT KEYS DEFINED IN DBDEF. * *---------------------------------------------------------------------* SPACE , DBADD REF=IR00DFA,NEWLREC=EBW000, X ERROR=ADD-ERROR #ESUB , SPACE , *---------------------------------------------------------------------* * ERROR HANDLING * *---------------------------------------------------------------------* SPACE , #LOCA ADD-ERROR SERRC R,DF0000 ISSUE DUMP & SEND MSG WTOPC TEXT='JOB ABORTED - ADD ERROR ON FILE IR00DF', X PREFIX=SAM2,NUM=003,LET=E #GOTO EXIT GO & CLOSE FILES #LOCA READ-ERROR SERRC R,DF0001 ISSUE DUMP & SEND MSG WTOPC TEXT='JOB ABORTED - READ-ERROR ON FILE IR00DF', X PREFIX=SAM2,NUM=004,LET=E #GOTO EXIT GO & CLOSE FILES SPACE , SAM2INFO DC AL2(L'IR00LC0),AL1(#IR00KC0) LENGTH + PRIMARY KEY LTORG FINIS SAM2 END