*DECK C$DM
          IDENT  C$DM 
          SST 
          TITLE  C$DM - CDCS INTERFACE CONVENIENCE ROUTINE
          COMMENT  CDCS INTERFACE CONVENIENCE ROUTINES
          B1=1
* 
* 
*                OBJECT ROUTINE USED IN CONJUNCTION WITH THE CDCS 
*                FEATURE.  THIS ROUTINE IS USED AS A CONVENIENCE BY THE 
*                CDCS INTERFACE OBJECT ROUTINES WHICH PERFORM THE ACTUAL
*                CDCS CALLS.
* 
* 
*CALL,IOMICROS
          ENTRY  C.DMDFO
 CDCS     IFNE   OP.DCS,OP.NO 
          ENTRY  C.DMDKO
          ENTRY  C.DMPAR
          ENTRY  C.KRORD
          ENTRY  C.RELTL
          ENTRY  C.RORD 
          ENTRY  C.SVLF 
          ENTRY  C.SVNF 
          ENTRY  C.SVSKP
          ENTRY  F.R.ORD
 C.DMPAR  BSS    6           CDCS CALL PARAMETER LIST AREA
 C.KRORD  BSS    1           DATABASE ORDINALS OF IMBEDDED KEY/RECORD 
 F.R.ORD  BSS    0           DATABASE ORDINAL OF RECORD OR FILE (AREA)
 C.RORD   BSS    1           DATABASE ORDINAL OF RECORD (WRITE/REWRITE) 
 C.RELTL  DATA   0           LOCATION OF RELATIONS/AREAS TABLE
 C.SVLF   DATA   0           ONLY REQUIRED FOR COBOL4 COMPATIBILITY 
 C.SVNF   EQU    C.SVLF      SAME 
 C.SVSKP  BSS    1           NUMBER OF LOGICAL RECORDS TO -SKIP-
          EJECT 
 CDCS     ENDIF 
* CONVENIENCE ROUTINES
* 
* 
 C.DMDFO  BSS    1           ROUTINE TO STORE AREA (FILE) ORDINAL INTO
*                            LOCATION -F.R.ORD- 
*                             ENTER WITH A0=FIT ADDRESS 
*                             EXIT  WITH X7=F.R.ORD (CONTAINS ORDINAL)
 CDCS     IFNE   OP.DCS,OP.NO 
          FETCH  A0,DBFO,X6 
          SA6    F.R.ORD
          SX7    A6 
          EQ     C.DMDFO
* 
* 
* 
 C.DMDKO  BSS    1           ROUTINE TO STORE POSSIBLE KEY AND RECORD 
*                            ORDINALS, IF KEY IS IMBEDDED IN RECORD,
*                            INTO 
*                            LOCATION -C.KRORD- 
*                             ENTER WITH A0=FIT ADDRESS 
*                             EXIT  WITH X7=C.KRORD (CONTAINS RECORD
*                              ORDINAL, BITS 19-10, KEY ORDINAL, BITS 
*                              9-0, OR CONTAINS 0 IF KEY NOT IMBEDDED IN
*                              RECORD)
          FETCH  A0,DBRK,X6 
 DCS1     IFEQ   OP.DCS,OP.DCS1 
          BX5    X6 
          AX6    2           CHANGE TO 10 BIT FIELDS
          MX7    60-10
          BX5    -X7*X5 
          BX6    X7*X6
          BX6    X6+X5
 DCS1     ENDIF 
          SA6    C.KRORD
          SX7    A6 
          EQ     C.DMDKO
* 
* 
* 
           ENTRY C.DMRAG
 C.DMRAG  DATA   0           ROUTINE TO SCAN THE RELATIONS/AREAS TABLE
*                            FOR THE DESIRED RELATION/AREAS GROUP 
*                              ENTER WITH A0=RELATION ORDINAL 
*                              EXIT WITH A2=ADDRESS-1 OF RELATION/AREAS 
*                                           GROUP 
*                                        B7=NUMBER OF AREAS IN GROUP
*                                          =0 IF ERROR
          SA5    C.RELTL     X5=ADDRESS OF RELATIONS/AREAS TABLE
          ZR     X5,C.DMRAG2  JUMP IF NO TABLE
          SA2    X5 
          ZR     X2,C.DMRAG2  JUMP IF VOID ENTRY
 C.DMRAG1 SB7    X2          RELATION ORDINAL FROM TABLE
          SX3    A0-B7
          AX2    45 
          SB7    X2          NUMBER OF AREAS IN RELATION
          ZR     X3,C.DMRAG  JUMP IF MATCHING RELATION/AREAS GROUP
          SB7    B7+2 
          SA2    A2+B7       NEXT RELATION/AREAS GROUP
          NZ     X2,C.DMRAG1  JUMP IF ANOTHER RELATION/AREAS GROUP
 C.DMRAG2 SB7    B0          INDICATE ERROR 
          EQ     C.DMRAG
          EJECT 
          ENTRY  C.DMRST
 C.DMRST  DATA   0           ROUTINE CALLED FROM EXECUTING COBOL PROGRAM
*                            TO ASCERTAIN FILE, AND STATUS THEREOF, 
*                            WHICH CAUSED CDCS RELATION READ ERROR. 
*                            CALLED BY -ENTER "C.DMRST" USING RELATION- 
*                             NAME, DATA-NAME-1, DATA-NAME-2-, WHERE
*                                 DATA-NAME-1 IS DEFINED WITH PIC X(7)
*                                 DATA-NAME-2 IS DEFINED WITH 
*                                  USAGE COMP-1 
* 
*                            ON ENTRY A1=ADDRESS OF PARAMETER LIST
*                            PARAMETER LIST - 
*                                 WORD 1 = RELATION ORDINAL 
*                                 WORD 2 = ADDRESS OF DATA-NAME-1 
*                                 WORD 3 = ADDRESS OF DATA-NAME-2 
*                               (NOTE REF. MAN. FOR FORMATS OF WORDS 2
*                                AND 3.)
*                            ON EXIT (DATA-NAME-1) = IMPLEMENTOR-NAME OF
*                                      LOWEST RANK FILE (CLOSEST TO 
*                                      -ROOT-) IN ERROR, OR UNDEFINED IF
*                                      NO FILE IN ERROR 
*                            (DATA-NAME-2) = FIT -ES-/-IRS- FIELD (DECI-
*                                      MALIZED) OF FILE IN ERROR, OR 0
*                                      IF NO FILE IN ERROR
          SA0    X1          RELATION ORDINAL 
          RJ     C.DMRAG     FIND RELATION/AREAS GROUP
          SX1    #DMREL1     MESSAGE, NO MESSAGE INSERT IN CASE 
          MX2    0            RELATION/AREAS GROUP NOT FOUND
          EQ     B7,B0,C.DMRST7  JUMP IF RELATION/AREAS GROUP NOT FOUND 
*                FIND TRAVERSED AREA (FILE) ON WHICH ERROR OCCURRED BY
*                SCANNING RELATION/AREAS GROUP
          SB6    B1 
 C.DMRST1 SA3    A2+B6
          FETCH  X3,IRS,X5   ERROR CODE FIELD 
          NZ     X5,C.DMRST2  JUMP IF ERROR ON THIS FILE
          SB6    B6+B1
          LE     B6,B7,C.DMRST1  JUMP IF MORE TRAVERSED AREA(S) 
*                X3=FIT ADDRESS OF FILE ON WHICH ERROR OCCURRED 
*                X5=FIT -ES-/-IRS- (CRM/CDCS ERROR) FIELD 
*                CHECK VALIDITY OF DATA-NAME-1 ATTRIBUTES, I.E. PIC X(7)
 C.DMRST2 SA2    A1+B1       X2=DATA-NAME-1 PARAMETER WORD
          SA4    X2          A4=ADDRESS OF DATA-NAME-1
          AX2    30 
          MX0    54 
          BX1    -X0*X2      BCP OF RECEIVING FIELD 
          AX2    6
          MX0    42 
          BX6    -X0*X2      SIZE OF RECEIVING FIELD
          SB7    X6-7 
          NE     B7,B0,C.DMRST6  JUMP IF RCV NOT SIZE OF 7
          SX7    6
          IX7    X1*X7       BCP OF RCV X 6 (BIT POSITION)
          BX7    -X7
          SB7    X7+60       CONVERTED TO COMPASS BIT NOTATION
*                MOVE IMPLEMENTOR-NAME, BLANK-FILLED, TO DATA-NAME-1
          SB6    X6          7 CHARACTERS TO MOVE 
          SA3    X3          IMPLEMENTOR-NAME TO X3 
 C.DMRST3 MX0    6
          BX6    X0*X3
          NZ     X6,C.DMRST4  JUMP IF NOT A ZERO
          SX6    55B         REPLACE ZERO WITH BLANK
          LX6    54 
 C.DMRST4 LX6    B7,X6       SHIFT CHAR TO POSITION IN RCV
          LX0    B7,X0       SHIFT MASK 
          SA4    A4          RECEIVING FIELD WORD 
          BX7    -X0*X4 
          IX7    X6+X7
          SA7    A4          CHARACTER INTO RECEIVING FIELD 
          SB7    B7-6 
          NE     B7,B0,C.DMRST5  JUMP IF NOT RCV WORD BOUNDARY
          SA4    A4+B1       SET UP RCV FOR NEXT WORD 
          SB7    60 
 C.DMRST5 SB6    B6-B1
          LX3    6           SHIFT TO NEXT IMPLEMENTOR-NAME CHAR
          NE     B6,B0,C.DMRST3  JUMP IF MORE CHARACTERS
*                ENSURE VALIDITY OF FIELD TO RECEIVE -ES-/-IRS- VALUE 
          SA1    A1+2 
          SB7    X1          ADDRESS OF DATA-NAME-2 
          AX1    18 
          MX0    54 
          BX1    -X0*X1 
          SX1    X1-24B      TEST FOR ALPHANUMERIC (2), COMP-1 (4)
          NZ     X1,C.DMRST6  JUMP IF BAD PARAMETER 
*                            X5=FIT ES/IRS FIELD
*                            ES/IRS IS IN OCTAL - MAKE THIS VALUE APPEAR
*                             AS DECIMAL (NOT CONVERTED TO DECIMAL) IN
*                             DATA-NAME-2 
          MX0    57 
          BX1    -X0*X5      LOW (OCTAL) DIGIT
          AX5    3
          SX7    10 
          BX2    -X0*X5 
          IX2    X2*X7       MIDDLE (OCTAL) DIGIT TIMES 10
          AX5    3
          SX7    100
          IX3    X5*X7       HIGH (OCTAL) DIGIT TIMES 100 
          IX7    X1+X2
          IX7    X7+X3
          SA7    B7          FINAL RESULT INTO DATA-NAME-2
          STORE  A3,IRS=B0   ZERO FIT ERROR CODE FIELD
          EQ     C.DMRST     EXIT 
* 
 C.DMRST6 SX1    #PRMERR     MESSAGE NUMBER 
          SA3    =9L-C.DMRST- 
          BX6    X3 
          SA6    =XC.MSINS
          MX2    1           X2"0, MESSAGE HAS INSERT 
* 
*                OUTPUT ERROR MESSAGE TO DAYFILE, AND EXIT
*                 X1=MESSAGE NUMBER 
*                 X2=0 IF NO MESSAGE INSERT, "0 IF INSERT (IN -C.MSINS-)
 C.DMRST7 SA3    C.DMRST     ISOLATE SOURCE LINE NUMBER (FROM BITS 29-18
          AX3    30           OF -RJ C.DMRST-) AND PLACE IN LOWER HALF
          MX0    48           OF -RJ C.MSG- AT -C.DMRST8- 
          SA3    X3-1 
          AX3    18 
          BX7    -X0*X3 
          SA3    C.DMRST8 
          BX3    X0*X3
          IX7    X3+X7
          SA7    A3 
          MX3    0           LINE NO. IN LOWER HALF OF -RJ C.MSG- 
          MX6    0           NO ABORT BY -CBMSG-
 C.DMRST8 RJ     =XC.MSG     MESSAGE TO DAYFILE 
 -        VFD    30/0 
          EQ     C.DMRST     EXIT 
          EJECT 
 CDCS     ENDIF 
          END 
