Retro1.org codex

*DECK DLSM
USETEXT DLFPDEF 
USETEXT ABH 
USETEXT DIRTBL
USETEXT DIRTBLS 
USETEXT ERRMSG
USETEXT NHEADER 
USETEXT ZHRCD 
PROC DLSM(TEMPB2);           # SELECT SUPERVISORY MSG                  #
 
*IF DEF,IMS 
 #
*1DC  DLSM
* 
*     1. PROC NAME           AUTHOR              DATE 
*        DLSM                P.C.TAM             79/01/09 
* 
*     2. FUNCTIONAL DESCRIPTION 
*        SELECT SUPERVISORY MESSAGES FOR OUTPUT 
* 
*     3. METHOD USED
*        IF AIP LOG FILE AND BLOCK TYPE IS LESS THAN
*        APPCMD, CLEAR CHOSEN FLAG. 
*        IF NIP LOG FILE AND BLOCK TYPE IS NETCMD, CLEAR CHOSEN FLAG. 
*        LOOP THROUGH SUPMSG PROCESSING TABLE, PROCESS EACH ENTRY.
*        AS FOLLOWS WHILE THE SELECT$ FLAG IS STILL SET OR
*        UNTIL EVERY ENTRY HAS BEEN PROCESSED.
*        E       CHECK IF ERROR BIT IS SET IN SUPERVISORY MESSAGE 
*                OF CURRENT MESSAGE, OTHERWISE CLEAR CHOSEN FLAG. 
*        R       CHECK IF RESPONSE BIT IS SET IN SUPERVISORY
*                MESSAGE OF CURRENT MESSAGE, OTHERWISE CLEAR CHOSEN 
*                FLAG.
*        CN      COMPARE THE CONNECTION NUMBER IN THE SUPERVISORY 
*                MESSAGE PROCESSING TABLE WITH ONE IN CURRENT TABLE.
*                IF NOT MATCH, CLEAR CHOSEN FLAG. 
*        PF      COMPARE THE PFC IN TABLE WITH ONE IN MESSAGE. IF 
*                NOT MATCH, CLEAR CHOSEN FLAG.
*        PS      COMPARE THE PFC/SFC IN TABLE WITH ONE IN MESSAGE. IF 
*                NOT MATCH, CLEAR CHOSEN FLAG.
* 
*     4. ENTRY PARAMETERS.
*        DIRTBLS             COMMON BLOCK WITH ALL SELECTION
*                            CRITERIA.
*        TEMPB2              CONTAINS TEXT
*        ZHRCD               COMMON BLOCK WHERE THE INPUT RECORD IS.
* 
*     5. EXIT PARAMETERS. 
*        CHOSEN              IN ZHRCD COMMON BLOCK
* 
*     6. COMDECKS CALLED AND SYMPL TEXTS CALLED.
*        ABH       DIRTBL    DIRTBLS   DLFPDEF
*        ERRMSG    NP$DLA    NHEADER   SUPMSG 
*        ZHRCD
* 
*     7. ROUTINES CALLED. 
*        DLABEND             ABORT PROGRAM
*        DLDFM               ISSUE DAYFILE MESSAGE
* 
*     8. DAYFILE MESSAGES.
*        BAD DIRECTIVE TABLE ENTRY. 
* 
 #
*ENDIF
# 
      FORMAL PARAMETER
# 
      ARRAY TEMPB2; ;        # CONTAINS MESSAGE TEXT                   #
# 
      EXTERNAL PROCEDURES 
# 
      XREF
        BEGIN 
        PROC DLABEND;        # ABORT PROGRAM                           #
        PROC DLDFM;          # ISSUE DAYFILE MESSAGE                   #
        END 
 
# 
      LOCAL VARIABLES 
# 
      BASED ARRAY DATLINE P(4);         # AIP ENTRY TEMPLATE           #
*CALL NP$DLA
 
      BASED ARRAY SUPMS;
        BEGIN 
*CALL SUPMSG
        ITEM SUPCN U(0,24,12);# CONNECTION NUMBER IN SUP MSG           #
        END 
 
      SWITCH CRIT 
              ERR, ERR, ERR, ERR, ERR, ERR, ERR, ERR, ERR, ERR, ERR,ERR,
              ERR, ERR, ERR, ERR, CN$PROC, E$PROC, R$PROC, PF$PROC, 
              PS$PROC, ERR, ERR;
      ITEM
        I,                   # TEMPORARY VARIABLE                      #
        TEMP1;               # TEMPORARY VARIABLE                      #
 
# ******************************************************************** #
      BEGIN 
      P<NHEADER> = LOC(ZHWD1[0]) + BLKHSIZE;
      P<ABH> = P<NHEADER> + 1;
      P<SUPMS> = LOC(TEMPB2); 
      IF NOT NIP
      THEN
        BEGIN                # AIP LOG FILE                            #
        P<DATLINE> = LOC(TEMPB1); 
        IF DL$OPC[0] GQ OP$GETF AND DL$OPC[0] LQ OP$GTFL
        THEN
          P<SUPMS> = P<SUPMS> + 1;
 
        IF ABHABT[0] LS APPCMD
        THEN
          IF DIRNUMS GR 1 OR DIRSID[1] NQ ID$CN 
          THEN
            CHOSEN = FALSE; 
          ELSE
            GOTO DLSMX; 
 
        END 
      ELSE
        BEGIN                # NIP LOG FILE                            #
        IF BT[0] NQ NETCMD
        THEN
          IF DIRNUMS GR 1 OR DIRSID[1] NQ ID$CN 
          THEN               # ENTRY MUST BE SUP MSG                   #
            CHOSEN = FALSE;  # CURRENT ENTRY IS NOT SUP MSG            #
          ELSE               # DO NOT CHECK FOR VALID CN               #
            GOTO DLSMX; 
        END 
# 
      LOOP TO PROCESS ALL SELECTION REQUIREMENTS
# 
      FOR I = 1 STEP 1 WHILE CHOSEN AND I LQ DIRNUMS
      DO
        BEGIN 
        GOTO CRIT[DIRSID[I]]; 
E$PROC:                      # ERROR BIT PROCESSING                    #
        CHOSEN = EB[0]; 
        GOTO NEXT;
R$PROC:                      # RESPONSE BIT PROCESSING                 #
        CHOSEN = RB[0]; 
        GOTO NEXT;
CN$PROC:                     # CONNECTION NUMBER PROCESSING            #
        IF (ABHADR[0] EQ 0 AND SUPCN[0] NQ DIRSVAL[I] AND NOT NIP) OR 
           (CN[0] EQ 0 AND SUPCN[0] NQ DIRSVAL[I] AND NIP)
        THEN
          CHOSEN = FALSE; 
        GOTO NEXT;
PF$PROC:                     # PFC PROCESSING                          #
        IF PFC[0] NQ DIRSVAL[I] 
        THEN
          CHOSEN = FALSE; 
        GOTO NEXT;
PS$PROC:                     # PFC/SFC PROCESSING                      #
        TEMP1 = DIRSVAL[I]; 
        IF B<54,6>TEMP1 NQ SFC[0] OR
           B<44,8>TEMP1 NQ PFC[0] 
        THEN
          CHOSEN = FALSE; 
        GOTO NEXT;
ERR:  
        DLDFM(BAD$DNTRY);    # BAD DIRECTIVE TABLE ENTRY               #
        DLABEND;             # ABORT PROGRAM                           #
NEXT: 
        END 
DLSMX:  
      END 
TERM