FTN4
      SUBROUTINE TSE, 92080-16520 REV.2026  800605
C 
C 
C     NAME:   TSE 
C     SOURCE: &TSE'    92080-18521
C     RELOC:  %TSE'    ----NONE---    PART OF  %TSE  92080-16520
C 
C     PGMR: DANIEL POT/FRANCOIS GAULLIER   HPG
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     THIS PROGRAM IS A PART OF THE:
C 
C                      DATA CAPTURE SOFTWARE
C                        ( D A T A C A P )
C 
C     IT USES FEATURES OF THE TERMINAL MONITOR SOFTWARE (TMS).
C 
C     THIS MODULE: TSE  IS A T.U.S. OF THE  TMP 
C                   (TRANSACTION MONITOR PROGRAM) 
C 
C 
C                  TSE  = TRANSACTION SET EDITOR
C 
C       TSE ALLOWS THE OPERATOR TO CHANGE OR TO LIST THE MIX OF 
C       TRANSACTION SPECS. USED BY TMP, THROUGH AN INTERACTIVE
C       DIALOG. 
C       THE OPERATOR CAN REMOVE OR ADD A TRANSACTION SPEC. AND
C       LIST THE DIRECTORY OR THE CONTENT OF A SPECIFIC TRANSAC-
C       TION SPECIFICATION. 
C 
C**********************************************  F. GAULLIER  (HPG)  ***
C 
C 
      DIMENSION INPUT(150),IDCB(144),LTEMP(3),ISTBF(5)
      INTEGER TSMG(3),FORMN,SQUAL,J,FMGST,STATE,STATLN,TITLE(111) 
      INTEGER BTCHBF,DTL,BCHKL(20)
     .       ,DCMON(3),REST(8),RETUN(25),PROCS(23),LABEL(2) 
     .       ,SAVSTA,SAVSTX,CURTSN,BIT15,DCAP(22),DSTR(19)
     .       ,ACTIVE(3),QUIET(3)
C 
C-----NO TRUE COMMON
C 
C-----1ST COMMON BLOCK
C 
      COMMON LU,ICTLB,ITYP,IST,ITL,IMAGEX(18),SAVSTX,NPAD(122)
C 
C-----NO 2ND COMMON BLOCK 
C 
C-----3ND COMMON BLOCK
C 
      COMMON FORMN,SQUAL,J,FMGST,STATLN,STATE(90) 
     .      ,MBUFR(9),L,SAVSTA,CURTSN(12),IERTN 
      COMMON BTCHBF(20),NUM,BITCH,ISCBF(15),DTL 
C 
C-----LAST COMMON WORD
C 
      COMMON ICOMEN 
C 
      LOGICAL ISSLA,ISBTW,ISSPA,ISNUL,ISBIT,CMPW,CMPB,STRAP,RESET 
      LOGICAL ISNUM,JPAR,IMBED,KPAR,CREAT,CLOSE,NAMF,NAMCK,TDCBC
      LOGICAL BITCH,STRFLG
      EQUIVALENCE (REG,IA)
C 
C-----DATA DEFINITIONS
C 
D     DATA LUOXXX/1/
      DATA LENSC/29/,IFTYP/55/,BIT15/100000B/ 
      DATA TSMG/2HTS,2HMG,2H  /,IZERO/0/
      DATA DCMON/2HDC,2HMO,2HN /
      DATA BCHKL/20*2H--/ 
C 
C-----DATA DEFINITION FOR LISTING OPERATION 
C 
      DATA REST/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/
      DATA RETUN/6412B,6412B,15446B,60453B,32067B,41440B,15446B 
     .   ,62112B,2HPr,2Hes,2Hs ,15446B,62113B,2HNE,2HXT,2H S,2HCR 
     .   ,2HEE,2HN ,15446B,62112B,2Hke,74433B,23144B,40040B/
      DATA PROCS/15446B,62102B,2HRE,2HAD,2HIN,2HG ,2HTR,2HAN,2HSA,
     .   2HCT,2HIO,2HN ,2HSP,2HEC,2HIF,2HIC,2HAT,2HIO,2HN ,15446B,
     .   62100B,6412B,6412B/
      DATA ACTIVE/2HAC,2HTI,2HVE/,   QUIET/2HQU,2HIE,52000B/
      DATA DSTR/6412B,15446B,2Ha+,2H09,2HC ,2HAC,2HTI,2HVE,2H I,2HN 
     .   ,2HST,2HOR,2HAG,2HE ,2HMO,2HDU,2HLE,2H. ,6412B/
      DATA DCAP/6412B,15446B,2Ha+,2H09,2HC ,2HAC,2HTI,2HVE,2H O,2HN 
     .   ,2HDA,2HTA,2H C,2HAP,2HTU,2HRE,2H T,2HER,2HMI,2HNA,2HL.
     .   ,6412B/
      DATA TITLE/6412B,15446B,2Ha+,2H16,2HC ,2HT
     .   ,2HR ,2HA ,2HN ,2HS ,2HA ,2HC ,2HT ,2HI ,2HO ,2HN ,2H  ,2HS
     .   ,2HE ,2HT ,2H  ,2HE ,2HD ,2HI ,2HT ,2HO ,2HR ,6412B,6412B
     .   ,15446B,2Ha+,2H29,2HC ,2HDI,2HRE,2HCT,2HOR,2HY ,2HLI,2HST
     .   ,6412B,6412B,15446B,2Ha+,2H09,2HC ,2HTR,2HAN,2HSA,2HCT,2HIO
     .   ,2HN ,2HSP,2HEC,2HIF,2HIC,2HAT,2HIO,2HN ,2H  ,2H  ,2H
     .   ,2H T,2H.S,2H. ,2HLI,2HBR,2HAR,2HY ,2H  ,2H  ,2H  ,2H T
     .   ,2H.S,2H. ,6412B,15446B,2Ha+,2H08,2HC ,2HNa,2Hme 
     .   ,2H  ,2H  ,2H N,2Hum,2Hbe,2Hr ,2H  ,2HSe,2Hc.,2H C,2Hod
     .   ,2He ,2H  ,2H  ,2HNa,2Hme,2H  ,2H C,2Har,2Htr,2Hid,2Hge
     .   ,2H  ,2H  ,2H S,2Hta,2Htu,2Hs ,6412B/
C 
      IRS12(M0)=IAND(IALF2(M0),360B)/16 
      IRS14(M1)=IAND(IALF2(M1),300B)/100B 
      KPAR(ILONG)=JPAR(INPUT,LENSC,IFILD,IDCB,ILONG,IFLAG,INOMB)
      IGETB(IJBUF,JJJ)=IAND(IALF2(IGET1(IJBUF,JJJ)),177B) 
C 
C-----DEFINE COMMON BLOCK STRUCTURE 
C 
      CALL TMDFN(LU,LU,FORMN,FORMN,ICOMEN)
      SAVSTX=IST
C 
C     CALL TMSAN(6,10,10HTSE  00000)
C     CALL TMSAN(LUOXXX,100,10HTSE   0001)
C 
C-----CHECK TERMINAL TYPE AND INHIBIT ECHO
C 
      IF(ITYP .NE. 2645)  RETURN
      LOCK = LURQW(LUTRU(LU)) 
      STRFLG = STRAP(LU,ISTBF,LOCK) 
      ICTLB=0 
C 
C-----ENABLE 3RD COMMON BLOCK 
C 
      CALL TMCBE(0,FORMN) 
C 
C  SET THE BATCH FILE RECORD NUMBER TO ZERO AND THE BATCH FLAG TO 
C    INDICATE NO BATCH STARTUP
C 
      NUM=0 
      BITCH=.FALSE. 
C 
C  RECOVER THE BATCH FILE NAMR IF ANY 
C 
      CALL TMPAR(BTCHBF)
C 
C  BATCH STARTUP??
C 
      IF(BTCHBF.EQ.BCHKL)GO TO 5
      BITCH = .TRUE.
      CALL TMZAP(BCHKL) 
C 
C-----PRINT ON THE CRT THE SOFT KEY ASSIGNEMENTS
C 
5     IF(BITCH)GO TO 700
      CALL TSESF
      IF(STRFLG)CALL TSEOR(38,1)
      CALL TMRD(INPUT,-3) 
      IF(ITL.NE.2 .OR. INPUT.NE.2H  )  GOTO 5 
C 
C-----INITIALISE SCREEN CONTENT 
C 
700   CALL PUTCA(MBUFR,1H ,1) 
      CALL BLAN(MBUFR,2,6)
      CALL MOVCA(0,1,MBUFR,8,2) 
      CALL BLAN(MBUFR,10,6) 
      CALL MOVCA(0,1,MBUFR,16,2)
C 
C-----PRINT INTERACTIVE SCREEN ON THE CRT 
C 
1     CALL TSESC(MBUFR) 
C 
C-----GET OPERATOR ANSWERS
C 
10    IF(.NOT.BITCH)GO TO 12
      IEER=0
      CALL BATCH(BTCHBF,NUM,ISCBF,DTL,IEER) 
      IF(IEER.NE.0)GO TO 13 
      CALL TMBWR(ISCBF,DTL) 
      CALL ENTER
      GO TO 12
13    CALL TSEOR(IEER,1)
      BITCH=.FALSE. 
12    CALL TMRD(INPUT,-LENSC-1) 
      IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B) GOTO 18 
      IF(ITL .NE. LENSC)  GOTO 1
C 
C-----PROCESS RECEIVED BLOCK-MODE BUFFER
C 
C-----GET SELECTED FUNCTION 
C 
18    IFILD=1 
      IF (  KPAR(1)  )  GOTO 20 
      IERNB=30
      IF(IFLAG.EQ.0) GOTO 30
      IERNB=24
      IF(IFLAG.NE.3)  GOTO 30 
      IH=IGET1(IDCB,1)
      IF(IH.EQ.1HT) GOTO 40 
      SQUAL=0 
      STATE=0 
      IF(IH.EQ.1HL) SQUAL=-3
      IF(IH.EQ.1HA) SQUAL=-2
      IF(IH.EQ.1HD) SQUAL=-11 
      IF(IH.EQ.1HP) SQUAL=-4
      IF(IH.EQ.1HS) SQUAL=10
      IERNB=26
      IF(SQUAL.EQ.0) GOTO 30
      CALL MOVCA(IDCB,1,MBUFR,1,1)
      IF(SQUAL.EQ.-4) GOTO 4000 
C 
C-----SET UP FOR  LOAD TRANSACTION SPECIFICATIONS 
C 
      STATE(1)=BIT15
      STATE(4)=BIT15
      STATE(5)=BIT15
      IF(SQUAL.EQ.-3)  GOTO 70
C 
C-----GET TRANSACTION NAME OR NUMBER
C 
      IFILD=2 
      IF (  KPAR(6)  )  GOTO 20 
      IF(IFLAG.NE.1) GOTO 50
      IERNB=29
      IF(ISBTW(INOMB,1,9999)) GOTO 30 
      STATE(4)=INOMB
      CALL CNUMD(INOMB,IDCB)
      IF(IDCB(3) .EQ. 2H 0)  IDCB(3)=2H 
      GOTO 58 
50    IERNB=8 
      IF(IFLAG.NE.3)  GOTO 30 
      IF(NAMCK(IDCB))  GOTO 30
      CALL MOVEW(IDCB,STATE,3)
58    CALL MOVCA(IDCB,1,MBUFR,2,6)
C 
C-----GET TRANSACTION SECURITY CODE 
C 
      IFILD=3 
      IF (  KPAR(6)  )  GOTO 20 
      IERNB=27
      IF(IFLAG.EQ.3.OR.IFLAG.EQ.2) GOTO 30
      IF(IFLAG.EQ.0) INOMB=0
      IF(INOMB.EQ.BIT15)  GOTO 30 
      STATE(5)=INOMB
      CALL MOVCA(INOMB,1,MBUFR,8,2) 
      IF(SQUAL.EQ.10 .OR. SQUAL.EQ.-11)  GOTO 4000
C 
C-----GET DISC FILE NAME
C 
70    IFILD=4 
      CALL BLANC(IDCB,3)
      IF (  KPAR(6)  )  GOTO 20 
      IERNB=25
      IF(IFLAG.EQ.1.OR.IFLAG.EQ.2) GOTO 30
      IERNB=30
      IF(IFLAG.EQ.0) GOTO 30
      IERNB=24
      IF(IMBED(IDCB,1,6)) GOTO 30 
      CALL MOVEW(IDCB,STATE(6),3) 
      CALL MOVCA(IDCB,1,MBUFR,10,6) 
      IF(IDCB .EQ. 2H  ) GOTO 4000
C 
C-----GET CARTRIDGE NUMBER
C 
      IFILD=5 
      IF (  KPAR(6)  )  GOTO 20 
      IERNB=31
      IF(IFLAG.EQ.2) GOTO 30
      IF(IFLAG.EQ.3)GO TO 750 
      IF(IFLAG.EQ.0)  INOMB=0 
      IF(ISBIT(INOMB,15)) GOTO 30 
      STATE(9)=INOMB
      GO TO 760 
750   IF(ISUPB(IDCB,3).NE.1)GO TO 30
      INOMB=IDCB
      IF(ISBTW(IGETB(INOMB,1),101B,132B))GO TO 30 
      IF(ISBTW(IGETB(INOMB,2),101B,132B).AND.ISBTW(IGETB(INOMB,2),
     .            60B,71B).AND.IGETB(INOMB,2).NE.40B)GO TO 30 
      STATE(9)=INOMB
C 
C  OPEN THE DISC FILE TO GET ITS TYPE 
C 
760   CALL OPEN(IDCB,KER,STATE(6),0,0,STATE(9)) 
      KQFTP=IDCB(4) 
      CALL CLOSE(IDCB)
      IF(KER.NE.0)GO TO 770 
      CALL EXEC(13,KQFTP,IEQT5) 
      IEQT5=IAND(IEQT5,37400B)/256
C 
C 
      IF(IEQT5.EQ.23B.OR.IEQT5.EQ.5B)GO TO 770
      IFILD = 4 
      IERNB=23
      GO TO 30
770   CALL MOVCA(INOMB,1,MBUFR,16,2)
      GOTO 4000 
C 
C-----CHECK FOR ABORT KEY 
C 
20    IF(IFLAG.EQ.9) GOTO 40
      IERNB=24
      GOTO 30 
C 
C-----ERROR MESSAGE OUTPUT
C 
30    CALL TSEOR(IERNB,IFILD) 
      BITCH=.FALSE. 
      GOTO 10 
C 
C-----RETURN PROCESS
C 
40    CALL TMWR(REST,8) 
      STRFLG=RESET(LU,ISTBF,IXX,LOCK) 
C     IF(BITCH)GO TO 48 
C 
C-----SCHEDULE DCMON WITH WAIT
C 
C     FIRST, RTE MUST BE FOOLED INTO THINKING TERMINAL IS NOT LOCKED
C 
      ILU = LU
      CALL DRTFK(LUTRU(LU),IDRT)
      CALL EXEC(100027B,DCMON,LU,1) 
      GO TO 42
6999  IXX = 0 
C 
C     ...AND THEN UN-FOOLED 
C 
42    CALL DRTFX(LUTRU(LU),IDRT)
48    RETURN
C 
C-----CALL THE TRANSACTION SPEC. MANAGEMENT SUBROUTINE
C 
4000  CALL MOVEW(REST,INPUT,8)
      CALL MOVEW(PROCS,INPUT(9),23) 
      K=8 
      IF(SQUAL.EQ.-3 .OR. SQUAL.EQ.-2)  K=31
      CALL TMWR(INPUT,K)
      J=LU
C     WRITE(6,40009) FORMN,SQUAL,J,FMGST,STATLN,(STATE(IX),IX=1,10),
C    +               (MBUFR(IJ),IJ=1,9) 
C40009 FORMAT("TSE F40009 : "5@7/10@7/9@7)
C     WRITE(6,40008) FORMN,SQUAL,J,FMGST,STATLN,(STATE(IX),IX=1,10),
C    +               (MBUFR(IJ),IJ=1,9) 
C40008 FORMAT("TSE F40008 : "5I6/10I6/9I6)
      CALL TMSUB(TSMG)
C 
C-----CHECK REQUEST TYPE/STATUS 
C 
      IF(SQUAL.EQ.-3 .OR. SQUAL.EQ.-2)  GOTO 4020 
      IF(FMGST .NE. 0)  GOTO 5000 
      IF(SQUAL.EQ.-4 .OR. SQUAL.EQ.10)  GOTO 100
      IF(SQUAL .EQ. -11)  GOTO 4800 
      CALL TMPER(0,99,0,0,401,SQUAL)
C 
C-----RECALL ALL THE TS AND PERFORM ALL THE CHECKS
C 
4020  SAVSTA=FMGST
      IERTN=-1
4025  IERTN=IERTN+1 
      SQUAL=-10 
      CALL TMSUB(TSMG)
      IF(FMGST .EQ. -1)  GOTO 4700
      IF(FMGST .NE. 0 )  CALL TMPER(0,99,0,0,403,FMGST) 
D     WRITE(LUOXXX,9877)(STATE(KKKK),KKKK=1,36) 
D9877 FORMAT(" /TSE TS HEADER:  TSNAM="3A2"  TS#="I4" TSSC="I6,@8,2I5,/ 
D    .6X"REV="@6,2@8,3I3,"   ERRCD="I6,/6X"LIBNAM="3A2" LIB CR#="I6,
D    ./6X"DBNAM="3A2" DB SC="I5" DB CR#="I6," DB NODE="I4" DB CRC="@6,
D    ./,6X,10I3)
C 
C-----SAVE CURRENT TS NAME & NUMBER & SC
      CALL MOVEW(STATE,CURTSN,5)
C 
C-----CHECK IF TS IS OK FROM 'TSMG' (TSMG ERR FLG RETURNED IN STATE(15))
C 
      IERNB=-STATE(15)
      IF(IERNB .NE. 0)  GOTO 4600 
C 
C-----CHECK LENGTH OF U&M QUESTION
C 
      LN=STATE(7)+STATE(8)
      IERNB=28
      IF(LN+STATE(12)+25 .GT. 500)  GOTO 4600 
C 
C-----CHECK THE TS REV CODE 
C 
      IERNB=16
      IF( FMGST.EQ.-11 )  GOTO 4600 
C 
C-----CHECK FOR LOGGING 
C 
      IERNB=13
      IF( .NOT. ISBIT(STATE(10),2) )  GOTO 4032 
      IF( .NOT. ISBIT(SAVSTX,7) )  GOTO 4600
C 
C-----CHECK THE DATA BASE 
C 
4032  STATE(19)=0 
      IF(STATE(20) .EQ. 2H  )  GOTO 4040
C 
C CREATE NAMR FROM NAME, SEC. CODE, CR. NO. 
C 
      CALL MOVEW(STATE(20),STATE(19),3) 
      STATE(22)=27B 
      NCHRS=0 
      CALL BLANC(INPUT(11),11)
      CALL INAMR(STATE(19),INPUT(12),20,NCHRS)
C     CALL DMPTM(6,INPUT(11),15,12H AFTER INAMR ,12,2)
C     CALL DMPTM(6,NCHRS,1,2H  ,1,0)
      CALL TBOPN(INPUT(11),0,0,INPUT) 
C     CALL DMPTM(6,INPUT,25,12H AFTER TBOPN ,6,0) 
      IERNB=9 
      IF(INPUT .NE. 0)  GOTO 4600 
      IF(INPUT(4) .NE. STATE(26))  GOTO 4600
C 
C-----CHECK STORAGE MEDIA, GET STORAGE STATE
C 
4040  SQUAL=3 
      J=1 
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0 )  CALL TMPER(0,99,0,0,405,FMGST) 
      I=2 
4100  K=IRS12(STATE(I))+1 
      GOTO (4500,4200,4300,4200,4500),K 
C-----STORAGE CODE = 1 OR 3, CHECK FILE NAME
4200  IDCB(10)=0
      CALL TDCBS(STATE(I+1),IDCB,IERR)
      IF(IERR .NE. -1)  GOTO 4400 
C-----THIS FILE IS ALREADY USED BY TMP, SET STORAGE CODE TO 1 
4230  STATE(I)=10000B 
4250  I=I+6 
      GOTO 4100 
C-----STORAGE CODE = 2, SHOULD NOT EXIST FROM TGP 
4300  CALL TMPER(0,99,0,0,410,0)
      GOTO 4250 
C-----SAVE DCB FAILED, TMS-FMP DIRECTORY OVERFLOW ? 
4400  IERNB=12
      IF(IERR .EQ. -3)  GOTO 4600 
C-----THE FILE IS NOT USE, OPEN IT
      CALL OPEN(IDCB,IERR,STATE(I+1),1,STATE(I+5),STATE(I+4),144) 
C     CALL WRITF(IDCB,JERR,IZERO,-1)
C     CALL RWNDF(IDCB,JERR) 
      CRN=STATE(I+4)
      SECU=STATE(I+5) 
      IF(IERR .EQ. 0)  GOTO 4430
      IF(IERR .EQ. IFTYP)  GOTO 4450
      IF(IERR .NE. -6)  GOTO 4440 
C-----THE FILE DOESN'T EXIST, CREATE A NEW ONE
4420  IF(  CREAT(IDCB,IERR,STATE(I+1),128,IFTYP,STATE(I+5)
     .           ,STATE(I+4),144) )GO TO 4421 
      CALL WRITF(IDCB,JERR,IZERO,-1)
      CALL RWNDF(IDCB,JERR) 
C 
C --- IF SHARED ACCESS SPECIFIED, CLOSE THE FILE & RE-OPEN IT 
C     IN SHARED MODE. 
C 
      IF(.NOT.ISBIT(STATE(I),11)) GO TO 4480
      CALL CLOSE(IDCB)
      CALL OPEN(IDCB,IERR,STATE(I+1),1,STATE(I+5),STATE(I+4)) 
      GO TO 4480
C 
4421  IERNB=22
      IF(IERR.EQ.-33) IERNB=37
      GOTO 4600 
C-----FILE TYPE 0, CHANGE STORAGE CODE TO 2, AND CHECK DEVICE 
4430  STATE(I)=20000B 
      LUSTR=IAND(IDCB(4),77B) 
      IF(CLOSE(IDCB,IFUCK))  CALL TMPER(0,99,0,0,415,IFUCK) 
      STATE(I+1)=LUSTR
C     -GET STATUS BEFORE TESTING FOR LOCK WHICH WILL RESET STATUS BITS. 
      CALL EXEC(100015B,LUSTR,IEQT5,IEQT4,IDRT2)
      GO TO 4438
C-----IS THE LU LOCKED
44301 IERNB=19
      CALL LURQ(140001B,LUSTR,1)
      GOTO 4600 
4431  CALL ABREG(M,N) 
      IF( M .NE. 0 )  GOTO 4438 
      IERNB=17
      REG=EXEC(3B,LUSTR+600B) 
C-----CHECK DVR TYPE
4434  IF( IAND(IEQT5,37400B)/256 .NE. 23B )  GOTO 4438
C-----IS LU OR EQT DOWN 
      IERNB=18
      IF( ISBIT(IDRT2,15) )  GOTO 4438
      IF( IRS14(IEQT5) .EQ. 1 )  GOTO 4438
C-----CHECK STATUS BITS 
      IERNB=20
      IF( IAND(IEQT5,77B) .NE. 0 )  GOTO 4438 
C-----CHECK THAT THE TAPE IS AFTER AN EOF OR AT THE BEGINNING 
      IF( IAND(IEQT5,300B) .EQ. 0 )  GOTO 4438
      IERNB=17
      CALL LURQ(40000B,LUSTR,1) 
      GOTO 4600 
4436  GOTO 4250 
C-----ERROR AFTER THE LU LOCK, UNLOCK LU AND REPORT ERROR 
4438  CALL LURQ(40000B,LUSTR,1) 
      GOTO 4600 
4439  GOTO 4600 
C-----THE FILE TYPE IS INCORRECT, CLOSE THE FILE AND REPORT ERROR 
4440  IF( CLOSE(IDCB,I) )  CALL TMPER(0,99,0,0,417,I) 
      IERNB=10
      GOTO 4600 
C-----THE FILE ALREADY EXIST, ASK A NEW NAME TO RENAME IT 
4450  CALL MOVEW(STATE(I+1),CURTSN(6),4)
      CALL BLAN(LTEMP,1,6)
      LTEMP=CURTSN(9) 
      IF(.NOT.ISBTW(LTEMP,040501B,055132B)) 
     *             CALL JASC(CURTSN(9),LTEMP,1,6) 
      CALL TCVTB(LTEMP,6) 
      CURTSN(9)=LTEMP 
4453  CALL TSDFE(CURTSN)
4455  CALL TMRD(INPUT,-7) 
      IF(ITL .EQ. 6)  GOTO 4460 
C-----WRONG INPUT, CLEAR CRT AND RE-ISSUE 
      CALL TMWR(REST,8) 
      GOTO 4453 
C-----CHECK IF THE FILE EXIST 
4460  IF( .NOT. ISSPA(INPUT,1,6) )  GOTO 4470 
      IERNB=23
      IF( NAMCK(INPUT) )  GOTO 4461 
      IERNB=21
      IF( CMPW(STATE(I+1),INPUT,3) )  GOTO 4461 
      CALL OPEN(INPUT(4),IERR,INPUT,1,STATE(I+5),STATE(I+4))
      IF(IERR .LT. 0)  GOTO 4462
C-----THE FILE ALREADY EXIST, REPORT ERROR
      IF( CLOSE(INPUT(4),I) )  CALL TMPER(0,99,0,0,419,I) 
4461  CALL TSEOR(IERNB,1) 
      BITCH=.FALSE. 
C 
C#################
      I=I+2 
C#################
C 
      GOTO 4455 
C-----THE OPEN FAIL, WHICH ERROR ?
4462  IF(IERR.EQ.-7 .OR. IERR.EQ.-8)  GOTO 4461 
      IERNB=23
      IF(IERR .NE. -6)  GOTO 4461 
C     PAUSE 776 
      IF(NAMF(IDCB,IERR,STATE(I+1),INPUT,STATE(I+5),STATE(I+4)))
     .                CALL TMPER(0,99,0,0,421,IERR) 
C     PAUSE 777 
      CALL TMBWR(REST,8)
      GOTO 4420 
C-----THE NAME IS BLANK, RESET THE SCREEN AND REJECT THAT TS
4470  CALL TMBWR(REST,8)
      GOTO 4440 
C-----THE STORAGE FILE HAS BEEN SUCCESSFULLY CREATED, PASSES
C     DCB TO TMS. 
4480  CALL TDCBS(STATE(I+1),IDCB,IERR)
      IF(IERR .EQ. 0)  GOTO 4230
      IF(IERR .EQ. -3)  GOTO 4400 
      CALL TMPER(0,99,0,0,423,IERR) 
C-----THE STORAGE DEFINTION IS OK, SEND IT BACK TO 'TSMG' 
4500  CALL SETBT(SQUAL,8,1) 
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  CALL TMPER(0,99,0,0,425,FMGST)
C-----THIS TS IS OK AND WILL NOT BE DELETED NOW,
C     UPDATE THE FILE DIRECTORY THAT KEEP TRACK OF IN USE FILE. 
      CALL TSEFD(STATE,1) 
C 
C-----THIS TS IS OK, MAKE IT ACCESSIBLE FROM THE DATACATURE TERMINALS 
C 
      SQUAL=-11 
      CALL MOVEW(CURTSN,STATE,5)
      STATE(4)=-STATE(4)
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  CALL TMPER(0,99,0,0,427,FMGST)
      INPUT=6412B 
      CALL MSTSN(CURTSN,K,INPUT(2)) 
      CALL MOVEW(30H has been succesfully added.  ,INPUT(K+2),15) 
      CALL TMWR(INPUT,K+16) 
      GOTO 4025 
C 
C-----ERROR HAS OCCURS ON THAT TRANSACTION SPEC.
C     REPORT ERROR AND DELETE IT. 
C 
4600  INPUT=6412B 
      INPUT(2)=5012B
      CALL MSTSN(CURTSN,K,INPUT(3)) 
      CALL MOVEW(22H has NOT been added.  ,INPUT(K+3),11) 
      CALL TMBWR(INPUT,K+12)
      CALL TSEOR(IERNB,0,IASC(LUSTR)) 
C-----DELETE THIS TS NOW !
      SQUAL=-1
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  CALL TMPER(0,99,0,0,429,FMGST)
      GOTO 4025 
C 
C-----END OF THE CHECK ALL TS, RECALL THE FMGST FROM THE LOAD/ADD 
C     REPORT ERROR IF NECESSARY AND WAIT FOR OPERATOR INPUT 
C 
4700  FMGST=SAVSTA
      IF(IERTN .EQ. 0)  GOTO 295
      GOTO 290
C 
C-----DELETE A TS FORM THE WORKING SET. THIS TS HAS NOW A NEG TS# 
C     NO DATACAPTURE CAN ACCESS IT, UPDATE THE FILE DIRECTORY 
C     CLOSE FILE THAT ARE NOT USE ANY MORE, AND PHISYCALLY
C     REMOVE THE TS FORM THE WORKING SET. 
C 
4800  SQUAL=3 
      J=1 
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  CALL TMPER(0,99,0,0,431,FMGST)
C-----UPDATE THE FILE DIRECTORY 
      CALL TSEFD(STATE,-1)
C-----CLOSE ALL FILE THAT CAN BE CLOSED 
4820  CALL TSEFD(INPUT,0) 
      IF(INPUT .EQ. 0)  GOTO 4870 
      IF( TDCBC(INPUT) )  CALL TMPER(0,99,0,0,435,0)
      GOTO 4820 
C-----ACTUALLY DELETE THE TS FROM WORKING SET 
4870  SQUAL=-1
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  CALL TMPER(0,99,0,0,437,FMGST)
C-----PRINT TS SUCCESSFULLY DELETED 
      INPUT=6412B 
      CALL MSTSN(STATE,K,INPUT(2))
      CALL MOVEW(30H has been succesfully deleted.,INPUT(K+2),15) 
      CALL TMWR(INPUT,K+16) 
      GOTO 290
C 
C-----TSMG ERROR MESSAGE
C 
5000  IERNB=-FMGST
      CALL TSESC(MBUFR) 
      IFILD=2 
      GOTO (30,30,5030,30,30,5060,5070,30,5300,5300,5300,5300,5300, 
     .5200,5200,5300),IERNB 
C-----TRANSACTION ALREADY IN THE WORKING SET
5030  IF(SQUAL.EQ.-3) IFILD=1 
      GOTO 30 
C-----INTERNAL ERROR (TSMG OR CLOSE MEDIA) !! 
5200  CONTINUE
      GOTO 5300 
C-----BAD SECURITY CODE 
5060  IFILD=3 
      GOTO 30 
C-----ILLEGAL MEDIA 
5070  IFILD=4 
      GOTO 30 
C-----ANY OTHER ERROR (CURSOR ON THE FIRST FIELD) 
5300  IFILD=1 
      GOTO 30 
C 
C 
C     ********************
C     * LISTING FUNCTION *                   =====================
C     ********************
C 
C 
100   CALL TMWR(REST,8) 
      IF(SQUAL.EQ.10)  GOTO 300 
C 
C-----DIRECTORY LIST                         *********************
C 
      CALL MOVEW(18H31CDIRECTORY LIST ,TITLE(32),9) 
      CALL TMBWR(TITLE,111) 
220   CALL BLANC(INPUT,40)
      IF(STATLN .EQ. 0)  GOTO 250 
      DO 230 L=1,STATLN 
      K=L*10-8
      ASSIGN 230 TO IERTN 
      GOTO 225
230   CONTINUE
      GOTO 240
C 
C-----FORMAT ONE LINE FOR THE DIRECTORY PRINT-OUT 
C 
225   CALL MOVEW(STATE(K+1),INPUT(5),3) 
      CALL MOVEW(STATE(K+6),INPUT(21),3)
      CALL MOVEW(ACTIVE,INPUT(32),3)
      IF(STATE(K) .EQ. 0)  CALL MOVEW(QUIET,INPUT(32),3)
      CALL JASC(STATE(K+4),INPUT,18,6)
      CALL JASC(STATE(K+5),INPUT,29,6)
      CALL JASC(STATE(K+9),LTEMP,1,6) 
      CALL TCVTB(LTEMP,6) 
      CALL MOVCA(LTEMP,1,INPUT,50,6)
      IF(IGET2(INPUT,54) .EQ. 2H 0)  CALL PUTCA(INPUT,1H ,55) 
      CALL TMWR(INPUT,34) 
      GOTO IERTN
C 
C-----GET NEXT DIRECTORY ENTRIES
C 
240   STATE=STATE+STATLN
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  GOTO 5000 
      GOTO 220
C 
250   INPUT=6412B 
      INPUT(2)=6412B
      CALL JASC(STATE,INPUT,21,6) 
      CALL MOVEW(8H ENTRIES,INPUT(14),4)
      IF(STATE .EQ. 0)  CALL MOVEW(14H      NO ENTRY,INPUT(11),7) 
      IF(STATE .EQ. 1)  CALL MOVEW(14H       1 ENTRY,INPUT(11),7) 
      CALL MOVEW(18H IN THE DIRECTORY ,INPUT(18),9) 
      CALL TMWR(INPUT,26) 
C 
C-----END OF LISTING OPERATION: WAIT FOR OPERATOR 
C 
290   CALL TMWR(RETUN,25) 
      IF(BITCH)CALL ENTER 
      CALL TMRD(INPUT,1)
      IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B)  GOTO 40
295   IF(FMGST .NE. 0)  GOTO 5000 
      GOTO 1
C 
C-----SATUS OF A TRANSACTION SPECIFICATIONS   ********************* 
C 
300   CALL MOVEW(STATE,STATE(2),-5) 
      CALL MOVEW(STATE(16),STATE(7),4)
      STATE=J-1 
      CALL MOVEW(18H33CT.S. STATUS    ,TITLE(32),9) 
      CALL TMWR(TITLE,111)
      K=1 
      ASSIGN 305 TO IERTN 
      CALL BLANC(INPUT,40)
      GOTO 225
C-----PRINT "ACTIVE/QUIET ON DATA CAPTURE TERMINAL" 
305   CALL MOVEW(ACTIVE,DCAP(6),3)
      IF(IAND(STATE,377B) .NE. 0)  GOTO 310 
      CALL MOVEW(QUIET,DCAP(6),3) 
      CALL TMWR(DCAP,21)
      GOTO 400
C-----DATA CAPTURE TERMINAL ARE ACTIVE, PRINT LU'S
310   CALL TMWR(DCAP,22)
      L=STATE(STATLN+1) 
315   I=9 
      CALL BLANC(INPUT,40)
320   K=IGETB(STATE(STATLN+2),L)
      IF(K .EQ. LU)  GOTO 325 
      CALL JASC(K,INPUT,I,2)
      I=I+3 
325   L=L-1 
      IF(I .GE. 70)  GOTO 330 
      IF(L .GE.  1)  GOTO 320 
330   CALL TMWR(INPUT,35) 
      IF(L .GE.  1)  GOTO 315 
C-----PRINT "ACTIVE/QUIET IN STORAGE MODULE"
400   CALL MOVEW(ACTIVE,DSTR(6),3)
      IF(IAND(J,177400B) .EQ. 0)  CALL MOVEW(QUIET,DSTR(6),3) 
      CALL TMWR(DSTR,19)
C 
C-----CLOSE THE TRANSACTION IN THE WORKING SET
C 
      SQUAL=11
      CALL TMSUB(TSMG)
      IF(FMGST.NE.0)  CALL TMPER(0,99,0,0,439,FMGST)
      GOTO 290
      END 
      SUBROUTINE TSEFD(IBUF,ICOD), 92080-16520 REV.2026  800507 
C 
C 
C     NAME:   TSEFD 
C     SOURCE: &TSE'     92080-18521     PART OF &TSE' 
C     BINARY: %TSE'     ----NONE---     PART OF %TSE  92080-16520 
C 
C     PGMR:   FRANCOIS GAULLIER   DSD 
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     ****************************************************************
C     *                                                              *
C     *   THIS SUBROUTINE MAINTAIN A DIRECTORY OF ALL THE            *
C     *   DATA-STORAGE-DISC-FILE ACCESS BY TMP. THIS IS TO BE        *
C     *   ABLE TO CLOSE A FILE WHEN THE LAST TS ACCESSING THAT FILE  *
C     *   IS DELETED FROM THE WORKING SET.                           *
C     *                                                              *
C     *   CALLING SEQUENCE:                                          *
C     *                                                              *
C     *         CALL TSEFD(IBUF,ICOD)                                *
C     *                                                              *
C     *            IBUF:   FILE NAME - CR#                           *
C     *                    PROVIDED IF ICOD=1 OR -1, RETURNED FOR    *
C     *                    ICOD=0                                    *
C     *                                                              *
C     *            ICOD:   TYPE OF REQUEST                           *
C     *                = 1 FILE BEING ACCESS BY A TS ADDED TO THE    *
C     *                    WORKING SET. INCREMENT THE IN USE COUNTER.*
C     *                =-1 FILE BEING ACCESS BY A TS DELETED FROM    *
C     *                    THE WORKING SET. DECREMENT THE IN USE     *
C     *                    COUNTER.                                  *
C     *                = 0 SEARCH FOR FILE NOT IN USE.               *
C     *                    IF NOT FOUND --> RETURN IBUF=0.           *
C     *                    IF FOUND     --> RETURN IBUF=FILE NAME-CR *
C     *                                     AND THE FILE IS DELETED  *
C     *                                     FROM THE DIRECTORY.      *
C     *                                                              *
C     *                                                              *
C     ****************************************************************
C 
      DIMENSION IBUF(1) 
C 
      INTEGER FILDIR(80),DIRLN,ENTLN
C 
      LOGICAL CMPW
C 
      DATA FILDIR/80*0/,DIRLN/80/,ENTLN/5/
C 
      IRS12(M0)=IAND(IALF2(M0),360B)/16 
C 
      IF( ICOD .EQ. 0 )  GOTO 500 
C 
C-----SEARCH FOR STORAGE CODE = 1, AND UPDATE THE FILE DIRECTORY
C     IF NECESSARY, INCREMENT OR DECREMENT IN USE COUNTER 
C 
      IF( ICOD .LT. 0 )  ICD=-1 
      IF( ICOD .GT. 0 )  ICD=1
      I=-3
20    I=I+5 
      J=1+IRS12(IBUF(I))
      I=I+1 
      GOTO (200,100,20,20,200),J
C-----STORAGE CODE = 1
100   DO 120 J=1,DIRLN-1,ENTLN
      IF(FILDIR(J) .EQ. 0)  GOTO 130
      IF( CMPW(FILDIR(J),IBUF(I),4) )  GOTO 140 
120   CONTINUE
      CALL TMPER(0,99,0,0,441,0)
130   CALL MOVEW(IBUF(I),FILDIR(J),4) 
140   FILDIR(J+4)=FILDIR(J+4)+ICD 
      GOTO 20 
200   RETURN
C 
C-----SEARCH IN THE DIRECTORY FOR FILE THAT ARE NOT USED
C 
500   DO 550 J=1,DIRLN-1,ENTLN
      IF(FILDIR(J).NE.0 .AND. FILDIR(J+4).EQ.0)  GOTO 600 
550   CONTINUE
      IBUF=0
      RETURN
C-----ONE FILE NOT USE HAS BEEN FIND, RETURN THE FILE NAME
C     TO THE USER 
600   CALL MOVEW(FILDIR(J),IBUF,4)
C-----DELETE THAT FILE FROM THE DIRECTORY 
      CALL MOVEW(FILDIR(J+ENTLN),FILDIR(J),DIRLN-J-ENTLN+1) 
      CALL NUL(FILDIR(DIRLN-ENTLN+1),ENTLN) 
      RETURN
      END 
      SUBROUTINE TCVTB(IARG,IARGLN), 92080-16520 REV.2026  800507 
      DIMENSION IARG(1) 
      LOGICAL ISBTW,ISSPA 
      IF(ISSPA(IARG,1,IARGLN))GO TO 100 
      RETURN
100   IF(.NOT.ISBTW(IARG,040501B,055132B))GO TO 200 
300   K=NUMD(IARG,1,IARGLN) 
      IF(ISBTW(K,040501B,055132B))RETURN
      CALL BLAN(IARG,1,IARGLN)
      IARG=K
      RETURN
200   CALL JASC(IARG,IARG,1,IARGLN) 
      RETURN
      END 
C 
      SUBROUTINE BATCH(FILNM,NUM,DTXMT,DTL,ERR) 
     *, 92080-16520 REV.2026  800507
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 PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.     *
C  *************************************************************
C 
      DIMENSION FILNM(1),DTXMT(1) 
      INTEGER FILNM,DTXMT,ERR,PNAMR(10),DTL 
      INTEGER FC,RC,RL,REC(5),DCB(144),FLDLN(5) 
      EQUIVALENCE(ISC,PNAMR(5)),(ICR,PNAMR(6))
C 
C  FIELD LENGTH (BYTES) TABLE 
C 
      DATA FLDLN/1,6,6,6,6/ 
      ERR=0 
      FC=1
C 
C  PARSE FILENAMR PASSED TO 'BATCH' 
C 
      CALL NAMR(PNAMR,FILNM,20,FC)
C 
C  OPEN FILE
C 
      CALL OPEN(DCB,ERR,PNAMR,ISC,ICR)
C 
C  CHECK FOR ERRORS 
C 
      IF(ERR.LT.0)GO TO 990 
C 
C  SPACE DOWN TO CORRECT RECORD IN FILE 
C 
      IF(NUM.EQ.0)GO TO 468 
      DO 455 I=1,NUM
      CALL READF(DCB,ERR,REC,5,RL)
      IF(RL.EQ.-1) GO TO 995
      IF(ERR.LT.0)GO TO 991 
455   CONTINUE
C 
C  SET UP COUNTERS
C 
C  FC=FIELD COUNTER 
C  RC=DATA TRANSMISSION BUFFER POINTER
C 
468   RC=1
      FC=1
C 
C  BLANK OUT DATA TRANSMISSION BUFFER 
C 
      CALL BLANC(DTXMT,15)
C 
C  BLANK OUT RECORD BUFFER
C 
467   CALL BLANC(REC,5) 
C 
C  READ A RECORD
C 
      CALL READF(DCB,ERR,REC,5,RL)
      NUM=NUM+1 
C 
C  IF END OF FILE THEN DO THE WRITE AND THEN READ 
C 
      IF(RL.EQ.-1)GO TO 469 
C 
C  CHECK FOR ERRORS 
C 
      IF(ERR.LT.0)GO TO 991 
C 
C  TURN WORD COUNT INTO BYTE COUNT
C 
      RL=RL*2 
C 
C  CHECK LAST CHAR FOR AN 'EDITR' PAD CHARACTER 
C    AND ADJUST BYTE COUNT IF IT IS 
C 
C 
      IF(IGETB(REC,RL).EQ.0B.OR.IGETB(REC,RL).EQ.40B)RL=RL-1
C 
C  CHECK BYTE COUNT TO SEE IF IT IS ONE (REQUIRES SPECIAL HANDLING
C 
      IF(RL.EQ.1)GO TO 100
C 
C  BYTE COUNT GREATER THAN ONE -- IF FIRST CHAR NOT A '+' THEN ERR
C 
      IF(IGET1(REC,1).NE.1H+)GO TO 992
C 
C  MOVE DATA INTO DATA TRANSMISSION BUFFER
C 
      CALL MOVCA(REC,2,DTXMT,RC,RL-1) 
101   RC=RC+RL-1
      FC=FC+1 
      GO TO 467 
C 
C  HANDLING OF ONE-BYTE RECORDS IS HERE 
C 
100   IF(IGET1(REC,RL).EQ.1H-)GO TO 103 
      IF(IGET1(REC,RL).EQ.1H+)GO TO 102 
      GO TO 992 
102   RC=RC+FLDLN(FC) 
      FC=FC+1 
      GO TO 467 
C 
103   IF(FC.GT.6)GO TO 994
C 
C  PASS SCREEN BUFFER BACK TO TSE 
C 
469   IF(RC-1.LE.0)GO TO 1000 
      DTL=-(RC-1) 
      GO TO 1000
C 
C 
C  E R R O R  SECTION!!!
C 
C 
C 
C  OPEN ERROR 
C 
990   ERR=32
      GO TO 1000
C 
C  READ ERROR 
C 
991   ERR=33
      GO TO 1000
C 
C  RECORD LEN IS NOT 1 AND FIRST CHARACTER IS NOT A '+' 
C     OR RECORD LEN IS 1 AND FIRST CHAR IS NOT A '+' OR '-' 
C 
992   ERR=34
      GO TO 1000
C 
C  FIELD COUNT > 5 AND NO SCREEN GROUP SEPARATOR FOUND
C 
994   ERR=35
      GO TO 1000
C 
C  END OF FILE REACHED BEFORE A SCREEN GROUP SEPARATOR
C 
995   ERR=36
1000  CALL CLOSE(DCB) 
      RETURN
      END 
      END$
                                                                                                                                                                                              