Retro1.org codex

*DECK DLABH 
USETEXT DLFPDEF 
USETEXT ABH 
USETEXT DIRTBLH 
USETEXT ERRMSG
USETEXT OUTCDA
USETEXT ZHRCD 
PROC DLABH;                  # SELECT APPLICATION BLOCK HEADER         #
 
*IF DEF,IMS 
 #
*1DC  DLABH 
* 
*     1. PROC NAME           AUTHOR              DATE 
*        DLABH               P.C.TAM             79/01/10 
* 
*     2. FUNCTIONAL DESCRIPTION 
*        SELECT APPLICATION BLOCKS FOR OUTPUT 
* 
*     3. METHOD USED
*        LOOP THROUGH APPLICATION BLOCK PROCESSING TABLE, PROCESS 
*        EACH ENTRY AS FOLLOWS UNTIL EITHER THE CHOSEN FLAG IS CLEARED
*        OR ALL ENTRIES PROCESSED.
*        B         IF BREAK FLAG IN ABH WORD IS NOT SET, CLEAR
*                  CHOSEN FLAG
*        C         IF CANCEL FLAG IN ABH WORD IS NOT SET, CLEAR 
*                  CHOSEN FLAG
*        F         IF NO FORMAT EFFECTOR IN ABH WORD IS NOT SET,
*                  CLEAR CHOSEN FLAG
*        P         IF PARITY/AUTO INPUT FLAG IS NOT SET, CLEAR
*                  CHOSEN FLAG
*        T         IF TRUNCATED DATA FLAG IS NOT SET, CLEAR 
*                  CHOSEN FLAG
*        U         IF IBU FLAG IS NOT SET, CLEAR CHOSEN FLAG. 
*        X         IF TRANSPARENT DATA FLAG IS NOT SET, CLEAR 
*                  CHOSEN FLAG
*        CN        IF CN IN MESSAGE IS NOT ZERO AND IT DOES NOT 
*                  MATCH ONE IN PROCESSING TABLE, CLEAR CHOSEN
*                  FLAG.
* 
*     4. ENTRY PARAMETERS 
*        DIRTBLH             COMMON BLOCK CONTAINING THE SELECTION
*                            CRITERION
*        ZHRCD               COMMON BLOCK CONTAINING THE INPUT
*                            RECORD HEADER
* 
*     5. EXIT PARAMETERS
*        CHOSEN              IN ZHRCD COMMON DECK, CLEARED IF 
*                            RECORD NOT SELECTED
* 
*     6. COMDECKS CALLED AND SYMPL TEXTS USED.
*        ABH       DIRTBLH   DLFPDEF   ERRMSG 
*        OUTCDA    ZHRCD
* 
*     7. ROUTINES CALLED. 
*        DLABEND             ABORT PROGRAM
*        DLDFM               ISSUE DAYFILE MESSAGE
* 
*     8. DAYFILE MESSAGES 
*        BAD DIRECTIVE TABLE ENTRY
* 
* 
 #
*ENDIF
# 
      EXTERNAL VARIABLES
# 
      XREF
        BEGIN 
        PROC DLABEND;        # ABORT PROGRAM                           #
        PROC DLDFM;          # ISSUE DAYFILE MESSAGE                   #
        END 
 
# 
      INTERNAL VARIABLES
# 
      SWITCH CRIT 
               ERR, 
              ERR, ERR, ERR, ERR, ERR, ERR, 
              L$B, L$C, L$F, L$P, L$T, L$U, L$X, ERR, 
              ERR, L$CN, ERR, ERR, ERR, ERR, ERR, ERR;
 
      ITEM
      I;                     # TEMPORARY VARIABLE                      #
# ******************************************************************** #
      BEGIN 
# 
      THE ABH IS IN THE 4TH WORD OF ARRAY TEMPB1 IN COMMON BLOCK
      ZHRCD. RTIME(IN ZHWD0), OPCODE, AND TA WORDS PRECEDE THE ABH. 
# 
      P<ABH> = LOC(ZHWD3[0]); 
      FOR I = 1 STEP 1 WHILE CHOSEN AND I LQ DIRNUMH
      DO
        BEGIN 
        GOTO CRIT[DIRHID[I]]; 
L$B:                         # BREAK FLAG PROCESSING                   #
          IF ABHBRK[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$C:                         # CANCEL BIT PROCESSING                   #
          IF ABHCAN[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$F:                         # NO FORMAT EFFECTOR PROCESSING           #
          IF ABHNFE[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$P:                         # PARITY/AUTO INPUT FLAG PROCESSING       #
          IF ABHBIT[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$T:                         # TRUNCATED DATA FLAG PROCESSING          #
          IF ABHTRU[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$U:                         # IBU BIT PROCESSING                      #
          IF ABHIBU[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$X:                         # TRANSPARENT BIT PROCESSING              #
          IF ABHXPT[0] NQ 1 
          THEN
            CHOSEN = FALSE; 
          GOTO NEXT;
L$CN:                        # CONNECTION NUMBER PROCESSING            #
          IF ABHADR[0] NQ 0 AND 
             ABHADR[0] NQ DIRHVAL[I]
          THEN
            CHOSEN = FALSE; 
        GOTO NEXT;
ERR:  
        DLDFM(BAD$DNTRY);    # BAD DIRECTIVE TABLE ENTRY               #
        DLABEND;             # ABORT PROGRAM                           #
NEXT: 
        END 
      END 
TERM