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 = ; C A,; C D; C R,=""; 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$