FTN4
      PROGRAM QY08(5,90),92069-16060 REV.2026 800312
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C     SOURCE:    92069-18071
C     RELOC:     92069-16060
C 
C     ALTERED:   JANUARY 22, 1980 FOR SORTED CHAINS FEATURE - CEJ 
C 
C************************************************************ 
C 
C 
C     FORM SERVICE MODULE 
C 
C         DISPLAYS DATA-SET AND 
C         DATA-ITEM NAMES 
C 
      LOGICAL ISPTH 
      LOGICAL IFBRK 
      INTEGER D 
      INTEGER STYPE 
      INTEGER SETBF(51) 
      INTEGER IBUF(256) 
      INTEGER INFO(17)
      INTEGER BLANK 
      INTEGER SUBHD(38) 
      INTEGER NUM(5)
      INTEGER ISTAT(10) 
      INTEGER YES(2)
      INTEGER TITLE(21) 
      INTEGER NOTE(15)
      INTEGER STITL(22) 
      INTEGER ERR2(12)
      INTEGER ERR3(12)
C 
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
      INTEGER INLU,ITTY,ILP,IDCB,JDCB,XEQ 
      INTEGER DBNAM,DBLEV,DSNAM,DINAM,SELECT,SNAM 
      INTEGER DSNUM,DINUM,PARM,LPARM,ECHO,QSERR 
      INTEGER IMA,IB,IBSZ,SECNO,IEND,ISCAN
      LOGICAL BREAK 
      INTEGER IPFLAG,IOFLAG,RMOTE 
      LOGICAL BATCH,XQBCH 
      INTEGER PAGCNT,LNCNT
      INTEGER PAGLEN,COLLIM 
      REAL    RRCNT 
      REAL    SELT,RSEC 
      INTEGER IPTR
      REAL    RCOUNT
      INTEGER S,R3,TRKNM,IDILU
      INTEGER R6
      REAL    ATOTAL
      INTEGER LIST,L,T,U
      INTEGER LEVSTR,LEVLEN 
      INTEGER IBUFF 
      INTEGER SS(7,100) 
C 
      COMMON INLU(145),ITTY(145),ILP(145),IDCB(145),JDCB(144),XEQ(145)
      COMMON DBNAM(10),DBLEV(3),DSNAM(3),DINAM(3),SELECT(6),SNAM(3) 
      COMMON DSNUM,DINUM,PARM(40),LPARM,ECHO,QSERR
      COMMON IMA(37),IB(896),IBSZ,SECNO,IEND,ISCAN
      COMMON BREAK
      COMMON IPFLAG,IOFLAG,RMOTE
      COMMON BATCH,XQBCH
      COMMON PAGCNT,LNCNT 
      COMMON PAGLEN,COLLIM
      COMMON RRCNT
      COMMON SELT(64),RSEC
      COMMON IPTR 
      COMMON RCOUNT 
      COMMON S(15,50),R3,TRKNM,IDILU
      COMMON R6 
      COMMON ATOTAL(6,5)
      COMMON LIST(101,6),L(7),T(5),U(7,5) 
      COMMON LEVSTR(66,5),LEVLEN(5) 
      COMMON IBUFF(2048)
C 
      EQUIVALENCE (S,SS)
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
      DATA D/104B/
      DATA YES/2HYE,2HS / 
      DATA BLANK/2H  /
C ITEM NAME  ITEM TYPE  ITEM LENGTH  PATH ITEM  # ARRAY ELE.  WRT ACCESS
      DATA SUBHD/2H  ,2H  ,2HIT,2HEM,2H N,2HAM,2HE ,2H  , 
     & 2HTY,2HPE,2H  ,2H L,2HEN,2HGT,2HH ,2H  ,2HKE,2HY , 
     & 2HIT,2HEM,2H  ,2H S,2HOR,2HT ,2HIT,2HEM,2H  ,2H #, 
     & 2H E,2HLE,2HMT,2HS ,2H  ,2HWR,2HT ,2HAC,2HCE,2HSS/ 
C        * * * * IMAGE/1000 SCHEMA * * * *
      DATA TITLE/2H  ,2H  ,2H  ,2H  ,2H* ,2H* ,2H* ,2H* , 
     & 2HIM,2HAG,2HE/,2H10,2H00,2H S,2HCH,2HEM,2HA ,2H* , 
     & 2H* ,2H* ,2H* /
C           (USING XX AS THE LEVEL WORD)
      DATA NOTE/2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H(U,2HSI,
     & 2HNG,2H L,2HEV,
     & 2HEL,2H X,2HX ,2H )/ 
C 
C 
      DATA STITL/2H  ,2HDA,2HTA,2H S,2HET,2H -,2H X,2HXX, 
     & 2HXX,2HX,,2H  ,2H C,2HAP,2HAC,2HIT,2HY ,2H= ,
     & 2HXX,2HXX,2HXX,2HXX,2HXX/
C 
C 
C 
      DATA ERR2/2H D,2HAT,2HA-,2HBA,2HSE,2H N,2HOT,2H D,2HEC, 
     &  2HLA,2HRE,2HD / 
      DATA ERR3/2H N,2HO ,2HAC,2HCE,2HSS,2H T,2HO ,2HDA,2HTA, 
     &  2H S,2HET,2HS / 
C 
C     IMAGE/1000 SCHEMA 
C 
C        MAX SETS    - 50 
C        MAX ITEMS   - 255
C        MAX NAMES   - 6 CHARS
C        MAX LENGTH  - 2048 
C 
C 
C 
C 
C 
C 
C BEGIN 
C 
C BE SURE DATA BASE IS DECLARED 
C 
      IF(DBNAM .EQ. 2H  ) GOTO 100
C 
C SKIP TO TOP OF PAGE 
C 
      CALL TOPAG(RMOTE,ILP,IERR)
C 
C OUTPUT TITLE - "* * * * IMAGE/1000 SCHEMA * * * *"
C                " (USING XXXXXX AS THE LEVEL WORD) " 
C 
      CALL QRIO(2,ILP,TITLE,21) 
      CALL CITA(DBLEV,INFO) 
      CALL SMOVE(INFO,5,6,NOTE,26)
      CALL QRIO(2,ILP,NOTE,15)
      CALL QRIO(2,ILP,BLANK,1)
      CALL QRIO(2,ILP,BLANK,1)
C 
C GET ALL DATA SETS IN DATA BASE
C 
      CALL DBINF(DBNAM,IDMY,203,ISTAT,SETBF)
      IF(ISTAT .NE. 0) GOTO 90
      IF(SETBF .LE. 0) GOTO 110 
C 
C GET ALL THE ITEMS FOR EACH DATA SET 
C 
      DO 70 ISET = 2,SETBF+1
      ISNUM = IABS(SETBF(ISET) )
C 
C OUTPUT TITLE FOR DATA SET 
C 
      CALL DBINF(DBNAM,ISNUM,202,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 90
C 
C GET SET NAME AND PUT IT IN THE MESSAGE
C 
      CALL SMOVE(INFO,1,6,STITL,14) 
C 
C GET SET TYPE AND PUT IT IN THE MESSAGE
C 
      CALL SGET(INFO,17,STYPE)
      CALL SPUT(STITL,21,STYPE) 
C 
C PUT CAPACITY IN MESSAGE 
C 
      CALL DCITA(INFO(16),STITL(18))
      CALL QRIO(2,ILP,BLANK,1)
      CALL QRIO(2,ILP,BLANK,1)
      CALL QRIO(2,ILP,STITL,22) 
      CALL QRIO(2,ILP,BLANK,1)
C 
C ITEM NAME   TYPE   LENGTH   KEY ITEM   SORT ITEM   # ELEMTS   WRT ACCESS
C 
      CALL QRIO(2,ILP,SUBHD,37) 
      CALL QRIO(2,ILP,BLANK,1)
C 
C GET ALL THE ITEMS ASSOCIATED WITH THIS SET
C 
      CALL DBINF(DBNAM,ISNUM,104,ISTAT,IBUF)
      IF(ISTAT .NE. 0) GOTO 90
      IF(IBUF .LE. 0) GOTO 70 
C 
C GET EACH ITEM IN SET
C 
      DO 80 ITM=2,IBUF+1
      CALL SFILL(IB,1,80,40B) 
      DINUM = IBUF(ITM) 
C 
C INDICATE WRITE ACCESS 
C 
      IF(DINUM .GT. 0) GOTO 50
      CALL SMOVE(YES,1,3,IB,69) 
      DINUM= -DINUM 
C 
C GET ITEM CHARACTERISTICS
C 
50    CONTINUE
      CALL DBINF(DBNAM,DINUM,102,ISTAT,INFO)
      IF(ISTAT .NE. 0) GOTO 90
C 
C PUT NAME IN PRINT BUFFER
C 
      CALL SMOVE(INFO,1,6,IB,7) 
C 
C PUT ITEM TYPE IN PRINT BUFFER 
C 
      CALL SGET(INFO,17,ITYPE)
      CALL SPUT(IB,19,ITYPE)
C 
C PUT ITEM LENGTH IN PRINT BUFFER 
C 
      CALL CITA(INFO(10),NUM) 
      CALL SMOVE(NUM,3,6,IB,25) 
C 
C OUTPUT ELEMENT COUNT
C 
      CALL CITA(INFO(11),NUM) 
      CALL SMOVE(NUM,4,6,IB,59) 
C 
C INDICATE WHETHER OR NOT A PATH ITEM 
C 
      IF( .NOT. ISPTH(DBNAM,ISNUM,DINUM,ISTAT) ) GOTO 65
      CALL SMOVE(YES,1,3,IB,35) 
C 
C OUTPUT SORT ITEM IF ANY 
C 
      IF (STYPE .NE. D) GOTO 65 
      CALL GTSRT(DBNAM,ISNUM,DINUM,INFO)
      CALL SMOVE(INFO,1,6,IB,46)
C 
C WRITE OUTPUT BUFFER 
C 
65    CALL QRIO(2,ILP,IB,37)
      IF(IFBRK(IDMY)) GOTO 75 
80    CONTINUE
70    CONTINUE
75    CONTINUE
      SNAM(2) = 2H
77    CALL LOAD(SNAM) 
C 
C DBMS ERROR
C 
90    CONTINUE
      SNAM(2) = 2H23
      GOTO 77 
C 
C DATA SET NOT DECLARED 
100   CONTINUE
      CALL ERIO(2,ITTY,ERR2,12) 
      GOTO 75 
C 
C NO ACCESS TO DATA SETS
C 
110   CONTINUE
      CALL ERIO(2,ITTY,ERR3,12) 
      GOTO 75 
      END 
$ 
                                                                                                                                                                                                                                                  