FTN4
      PROGRAM QY14(5,90),92069-16060 REV.1912 781221
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-18077
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C  UPDATE SERVICE MODULE (PART II)
C  REPLACE AND DELETE ROUTINES
C  SEE QS07 FOR ADD ROUTINE 
C 
      LOGICAL DDS 
      INTEGER A,R,D 
      INTEGER INBR(128) 
      INTEGER ISTAT(10) 
      INTEGER ISTAT2(10)
      INTEGER ERR1(9) 
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   $$$$$$$$$$$$$$$$$$$$$
      EQUIVALENCE(S(1,1),ICHAR) 
      EQUIVALENCE(S(3,1),INBR)
C 
      DATA A/101B/
      DATA D/104B/
      DATA R/122B/
      DATA ERR1/2H S,2HEL,2HEC,2HT ,2HFI,2HLE,2H E,2HRR,2HOR/ 
C 
C  UPDATE NAME = <PROCEDURE NAME>;
C         A,<DATA SET NAME>;
C         D;
C         R,<DATA ITEM NAME>="<VALUE>"; 
C 
C 
C 
C 
C 
C BEGIN 
C 
C 
C READ THE FIRST RECORD OF SELECT FILE AND SKIP THE OVERHEAD
C 
      RSEC = DBLEI(1) 
      CALL EREAD(JDCB,ISTAT,SELT,128,IL,RSEC) 
      IF(ISTAT .LT. 0) GOTO 70
      RSEC = DIN(RSEC)
      IPTR = 9
C 
C TOP OF LOOP 
C 
405   CONTINUE
      IF(IPTR.LT.65) GOTO 410 
      CALL EREAD(JDCB,ISTAT,SELT,128,IL,RSEC) 
      IF(ISTAT .LT. 0) GOTO 70
      RSEC = DIN(RSEC)
      IPTR = 1
C 
C GET RECORD NUMBER IN SELECT FILE
C 
410   RCOUNT = SELT(IPTR) 
      IPTR = IPTR + 1 
C 
C  GET RECORD VIA DIRECTED READ 
C 
20    CONTINUE
      CALL DBLCK(DBNAM,DSNUM,1,ISTAT) 
      IF(ISTAT .NE. 0) GOTO 60
C 
C POSITION THE DBMS TO THE CORRECT RECORD 
C 
      CALL DBGET(DBNAM,DSNUM,4,ISTAT,0,IBUFF,RCOUNT)
      IF(ISTAT.EQ.0) GOTO 420 
      CALL DBUNL(DBNAM,DSNUM,1,ISTAT) 
      GOTO 60 
C 
C  DELETE UPDATE
C 
420   CONTINUE
      IF(ICHAR.EQ.D) GOTO 300 
C  REPLACE UPDATE 
      IF(ICHAR.EQ.R) GOTO 200 
C 
C  RETURN TO NEXT?
C 
50    SNAM(2) = 2H
55    CALL LOAD(SNAM) 
C 
C  ERROR - DBMS 
C 
60    CONTINUE
      QSERR = ISTAT 
      SNAM(2) = 2H23
      GOTO 55 
C 
C ERROR READING SELECT FILE 
C 
70    CONTINUE
      CALL ERIO(2,ITTY,ERR1,9)
      GOTO 60 
C 
C 
C  UPDATE RECORD
C 
200   CALL DBUPD(DBNAM,DSNUM,1,ISTAT,INBR,IBUFF)
      GOTO 500
C 
C  DELETE RECORD
C 
300   CALL DBDEL(DBNAM,DSNUM,1,ISTAT) 
500   CALL DBUNL(DBNAM,DSNUM,1,ISTAT2)
C 
C CHECK THE STATUS OF THE DELETE
C 
      IF(ISTAT .NE. 0) GOTO 60
C 
C CHECK THE STATUS OF THE UNLOCK
C 
      ISTAT= ISTAT2 
      IF(ISTAT .NE. 0) GOTO 60
      IF(ICHAR .EQ. A) GOTO 50
      IF(DDS(RRCNT) ) GOTO 50 
      GOTO 405
      END 
      END$
                            