FTN4
      PROGRAM QY11(5,90),92069-16060 REV.1912 790202
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-18074
C     RELOC:     92069-16060
C 
C 
C************************************************************ 
C 
C 
C  DESTROY SERVICE ROUTINE
C 
      DIMENSION NAME(2) 
      INTEGER ERR2(22)
      INTEGER ERR3(7) 
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 NAME/2HNA,2HME/
      DATA ERR2/2H P,2HRO,2HCE,2HDU,
     1 2HRE,2H N,2HAM,2HE ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  , 
     2 2H  ,2H N,2HOT,2H F,2HOU,2HND/ 
      DATA ERR3/2H S,2HYN,2HTA, 
     1 2HX ,2HER,2HRO,2HR / 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C BEGIN 
C 
C 
C 
C  DESTROY NAME =<PROCEDURE NAME> 
C 
C  RETURN TO NEXT?
C 
C 
C  SCAN FOR NAME
C 
      CALL LSCAN(IB,I,J,K)
      IF(J-I.NE.3) GO TO 30 
      IF (JSCOM(NAME,1,4,IB,I,IERR).EQ.0) GO TO 35
30    CONTINUE
      IP = 1
34    IF(IEND .LE. 72) GOTO 37
      CALL QRIO(2,ITTY,IB(IP),-72)
      IEND = IEND - 72
      IP = IP + 36
      GOTO 34 
C 
C WRITE LAST LINE OUT 
C 
37    CALL QRIO(2,ITTY,IB(IP),-IEND)
C 
C 
      CALL SFILL(IMA,1,72,40B)
      IF(I .GT. 72) I = I- I/72*72
      CALL SPUT(IMA,I,136B) 
      CALL QRIO(2,ITTY,IMA,-I)
C  ERROR - SYNTAX 
      CALL ERIO(2,ITTY,ERR3,7)
      GO TO 10
C 
C  FMGR ERROR 
C 
   25 CALL FMERR(IERR,ITTY) 
      GOTO 10 
C 
C  PROCEDURE NOT FOUND
C 
   40 CONTINUE
      CALL SMOVE(IB,I,J,ERR2,17)
      CALL ERIO(2,ITTY,ERR2,22) 
      GO TO 10
C 
C  SCAN ACROSS =
C 
   35 CALL LSCAN(IB,I,J,K)
      IF (K.NE.6) GO TO 30
C 
C  GET PROCEDURE NAME 
C    GTPRM RETURNS A -1 IN IDCB WHEN THE NAME IS A FILE 
C                     0 IN IDCB WHEN THERE WAS NO INPUT 
C                    LU IN IDCB WHEN A DEVICE WAS SPECIFIED 
C          RETURNS A DCB IN WORDS 2-145 OF IDCB 
C          OPENS THE FILE AND RETURNS THE ERROR CODE IN IERR
C          RETURNS THE FILE NAME IN WORDS 1-3 OF IMA
C                      SECURITY CODE IN WORDS 5 OF IMA
C                      CARTRIDGE NUMBER IN WORD 6 OF IMA
C 
      CALL LSCAN(IB,I,J,K)
      IF (K.NE.2) GO TO 30
      IPTR = I
      CALL GTPRM(IMA,IB,J,IPTR,IDCB,IDCB(2),.FALSE.,IERR) 
      IF(IERR .EQ. -200) GOTO 30
      IF(IERR .EQ. -6) GOTO 40
      IF(IERR .LT. 0) GOTO 25 
      IF(IDCB .GE. 0) GOTO 30 
C 
C  PURGE FILE 
C 
      CALL PURGE(IDCB(2),IERR,IMA,IMA(5),IMA(6) ) 
      IF (IERR.LT.0) GOTO 25
C 
C EXIT
C 
10    CONTINUE
      SNAM(2) = 2H
      CALL LOAD(SNAM) 
      END 
$ 
                                                