*COMDECK DIAG904
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     D I A G 9 0 4                                                    #
#                                                                      #
#     IF NO ITEM ORDINAL IN DATA BASE STATUS BLOCK, ISSUE DIAG 904     #
#                                                                      #
#           CRM/CDCS ERROR -X- FILE/RELATION -Y- FUNCTION -Z-          #
#                                                                      #
#     ELSE ISSUE DIAG 908                                              #
#                                                                      #
#           CDCS ERROR -W- FILE/RELATION -X- FUNCTION -Y- ITEM -Z-     #
#                                                                      #
#     IF ERROR -X- IS A CDCS ERROR, ISSUE CDCS MESSAGE TEXT.           #
#     IF FATAL ERROR, CALL RTNSSCM TO RELEASE ALL CM ASSOCIATED WITH   #
#     THIS SUBSCHEMA AND SET FLAGS TO INDICATE THAT CDCS IS NOT INVOKED#
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC DIAG904;
      PROC DIAG904; 
      BEGIN 
      ITEM CHAR I;                 # CHARACTER POSITION                #
      ITEM I I;                    # LOOP COUNTER                      #
      ITEM LOOPCON1 B;             # LOOP CONTROL VARIABLE             #
      ITEM RC I;                   # RETURN CODE FROM WRITEBL          #
  
      BASED ARRAY GIVEA;           # ARRAY FOR SEARCHING FOR ZERO      #
        BEGIN 
        ITEM GIVEITEM I(0,0,60);   # ENTIRE WORD                       #
        END 
  
      IF DBSAUXSTAT1 EQ 0          # IF NO ITEM ORDINAL                #
      THEN
        BEGIN 
                                   # CRM/CDCS ERROR -X- FILE/RELATION  #
                                   # -Y- FUNCTION -Z-                  #
        DIAG (904, DBSERRCODE, DBSNAME, DBSFUNCTION); 
        END 
  
      ELSE                         # IF ERROR INVOLVES ITEM ORDINAL    #
        BEGIN 
                                   # CDCS ERROR -W- FILE/RELATION -X-  #
                                   # FUNCTION -Y- ITEM -Z-             #
        DIAG (908, DBSERRCODE, DBSNAME, DBSFUNCTION, DBSAUXSTAT1);
        DBSAUXSTAT1 = 0;           # CLEAR ITEM ORDINAL                #
        END 
  
      IF DBSERRCODE GQ CDCSERRCODE  # IF CDCS ERROR, PRINT ERROR TEXT  #
        AND DBSMSGADDR NQ 0        # IF MESSAGE TEXT EXISTS            #
      THEN
        BEGIN 
        P<GIVEA> = DBSMSGADDR;     # POSITION TO ERROR TEXT            #
        C<0,2>GIVEITEM[0] = " ";   # CARRIAGE CONTROL                  #
        LOOPCON1 = TRUE;
        FOR I = 0 STEP 1           # SCAN ERROR TEXT FOR TRAILING ZERO #
          WHILE LOOPCON1
        DO
          BEGIN 
          FOR CHAR = 0 STEP 1      # SCAN 1 WORD                       #
            UNTIL 9 
          DO
            BEGIN 
            IF B<CHAR*6,6>GIVEITEM[I] EQ 0  # IF TRAILING ZERO         #
            THEN
              BEGIN 
              LOOPCON1 = FALSE;    # ZERO FOUND, TERMINATE LOOP        #
              TEST I; 
              END 
            END 
          END 
  
        WRITEBL (GIVEA, ((I - 1) * 10) + CHAR, RC);  # PRINT ERROR TEXT#
        END 
  
      DBSERRCODE = 0;              # CLEAR ERROR FIELD                 #
      IF DBSFATALFLG               # IF CDCS FATAL ERROR FORCED TERMINT#
      THEN
        BEGIN 
        RELEASESPACE;              # RELEASE CM USED BY THIS XMISSN    #
        RTNSSCM;                   # RETURN ALL CM USED BY SUBSCHEMA   #
        DIAG (404);                # FATAL CDCS ERROR, SUBSCHEMA       #
                                   # RETURNED                          #
        LOADOVL (BASEX0,1,0);      # LOAD OVERLAY 1,0                  #
        END 
      RETURN; 
      END                          # END PROC    D I A G 9 0 4         #
