bdfp1m0vProgramming Concepts and Reference

Assembler Application Program Example

This section shows how you might code this example using the TPFDF macros.

Processing the Member File Using TPFDF Macros

The member file requires the following types of processing:

File Maintenance Program

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

Departure Control Interface Program

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

Monthly Maintenance Program

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