FTN4
      SUBROUTINE TSE, 92903-16520 REV.1913  790226
C 
C 
C     NAME:   TSE 
C     SOURCE: &TSE'    92903-18521
C     RELOC:  %TSE'    ----NONE---    PART OF  %TSE  92903-16520
C 
C     PGMR: DANIEL POT/FRANCOIS GAULLIER   HPG
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  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)
      INTEGER TSMG(3),FORMN,SQUAL,J,FMGST,STATE,STATLN,TITLE(111) 
     .       ,DCMON(3),RESET(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(14),SAVSTX
C 
C-----NO 2ND COMMON BLOCK 
C 
C-----3ND COMMON BLOCK
C 
      COMMON FORMN,SQUAL,J,FMGST,STATLN,STATE(80) 
     .      ,MBUFR(9),L,SAVSTA,CURTSN(12),IERTN 
C 
C-----LAST COMMON WORD
C 
      COMMON ICOMEN 
C 
      LOGICAL ISSLA,ISBTW,ISSPA,ISNUL,ISBIT,CMPW,CMPB 
      LOGICAL ISNUM,JPAR,IMBED,KPAR,CREAT,CLOSE,NAMF,NAMCK,TDCBC
C 
C-----DATA DEFINITIONS
C 
D     DATA LUOXXX/1/
      DATA LENSC/29/,IFTYP/55/,BIT15/100000B/ 
      DATA TSMG/2HTS,2HMG,2H  / 
      DATA DCMON/2HDC,2HMO,2HN /
C 
C-----DATA DEFINITION FOR LISTING OPERATION 
C 
      DATA RESET/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     CALL TMSAN(6,10,10HTSE  00000)
D     CALL TMSAN(LUOXXX,100,10HTSE   0001)
C 
C-----CHECK TERMINAL TYPE AND INHIBIT ECHO
C 
      IF(ITYP .NE. 2645)  RETURN
      ICTLB=0 
C 
C-----ENABLE 3RD COMMON BLOCK 
C 
      CALL TMCBE(0,FORMN) 
C 
C-----PRINT ON THE CRT THE SOFT KEY ASSIGNEMENTS
C 
5     CALL TSESF
      CALL TMRD(INPUT,-3) 
      IF(ITL.NE.2 .OR. INPUT.NE.2H  )  GOTO 5 
C 
C-----INITIALISE SCREEN CONTENT 
C 
      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    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=27
      IF(IFLAG.EQ.2.OR.IFLAG.EQ.3) GOTO 30
      IF(IFLAG.EQ.0)  INOMB=0 
      IF(INOMB.EQ.BIT15)  GOTO 30 
      STATE(9)=INOMB
      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) 
      GOTO 10 
C 
C-----RETURN PROCESS
C 
40    CALL TMWR(RESET,8)
      CALL EXEC(100030B,DCMON,LU,1) 
      GOTO 48 
C-----AFTER DCMON SCHEDULE, WAIT 1 SECOND TO AVOID THE FMGR PROMPT
C     ON THE CRT BEFORE THE DCMON SCREEN. (PROVIDING THAT DCMON HAS 
C     A HIGHER PRIORITY THAN FMGR)
42    CALL TMPZ(100)
48    RETURN
C 
C-----CALL THE TRANSACTION SPEC. MANAGEMENT SUBROUTINE
C 
4000  CALL MOVEW(RESET,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
      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. 250)  GOTO 4600 
C 
C-----CHECK THE TS REV CODE 
C 
      IERNB=16
      IF( STATE(9) .NE. 1001B )  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
      CALL TBOPN(STATE(19),0,0,INPUT) 
      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),0,STATE(I+5),STATE(I+4),144) 
      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( .NOT. CREAT(IDCB,IERR,STATE(I+1),128,IFTYP,STATE(I+5) 
     .           ,STATE(I+4),144) )   GOTO 4480 
      IERNB=22
      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,I))  CALL TMPER(0,99,0,0,415,I) 
      STATE(I+1)=LUSTR
C-----IS THE LU LOCKED
      IERNB=19
      CALL LURQ(140001B,LUSTR,1)
      GOTO 4600 
4431  CALL ABREG(M,N) 
      IF( M .NE. 0 )  GOTO 4438 
      IERNB=17
      CALL EXEC(100003B,LUSTR+600B) 
      GOTO 4438 
4432  CALL EXEC(100015B,LUSTR,IEQT5,IEQT4,IDRT2)
      GOTO 4438 
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)
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(RESET,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,0,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) 
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 
      IF(NAMF(IDCB,IERR,STATE(I+1),INPUT,STATE(I+5),STATE(I+4)))
     .                CALL TMPER(0,99,0,0,421,IERR) 
      CALL TMBWR(RESET,8) 
      GOTO 4420 
C-----THE NAME IS BLANK, RESET THE SCREEN AND REJECT THAT TS
4470  CALL TMBWR(RESET,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(RESET,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),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) 
      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), 92903-16520 REV.1913  781122 
C 
C 
C     NAME:   TSEFD 
C     SOURCE: &TSE'     92903-18521     PART OF &TSE' 
C     BINARY: %TSE'     ----NONE---     PART OF %TSE  92903-16520 
C 
C     PGMR:   FRANCOIS GAULLIER   DSD 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  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 
END$
                                                      