FTN4
      PROGRAM TGP1(5), 92080-1X352 REV.2026  800513                   
C 
C     SOURCE 92080-18352
C 
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     PRGMR : JEAN CHARLES MIARD (HPG)
C 
C*********************************************************************
C*                                                                   *
C*            THIS IS A SEGMENT OF THE TGP PROGRAM USED TO           *
C*   ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREENS 0,1,2     *
C*   3,4, 41, AND 5 .                                                     * 
C*            THE ANSWERS AFTER A CHECK ARE STORED IN IFORM.         *
C*                                                                   *
C*                                                                   *
C*            FOLLOWING ARE THE DIFFERENT WAYS TO EXECUTE THIS       *
C*  SEGMENT ACCORDING TO INDIC VALUE :                               *
C*                                                                   *
C*       INDIC = 0 : NORMAL PATH . ANALYSE ISCRN SCREEN ANSWERS .    *
C*                   OR COMING FROM TGP11 AN ERROR HAS OCCURED IN    *
C*                   OPENING THE DATA BASE REGET SCREEN #3           *
C*             = 1 : WHEN COMING FROM TGP10 . A TRANSACTION SPEC     *
C*                   HAS BEEN READ (MODE L OR M) BUT AN ERROR        *
C*                   OCURED DURING READ . ISKIP CONTAINS ERROR CODE  *
C*                   SET INDIC TO 4 AND REPRINT SCREEN # 3 .         *
C*             = 2 : WHEN COMING FROM TGP11 . A DATA BASE HAS BEEN   *
C*                   SUCCESSFULLY OPENED GO TO PRINT SCREEN # 5 .    *
C*             = 3 : WHEN COMING FROM TGP10 . A TRANSACTION SPEC     *
C*                   HAS BEEN SUCCESFULLY READ .                     *
C*             = 4 : SEE INDIC=1 AFTER PRINTING SCREEN 3 THE ISKIP   *
C*                   ERROR MESSAGE IS PRINTED .                      *
C*             =-77  A HELP MESSAGE MUST BE PRINTED                  *
C*             = 99  ABORT TGP                                       *
C*                                                                   *
C*                                                                   *
C*                                                                   *
C*********************************************************************
C 
C 
C ****** DECLARATIONS COMMON VARIABLES *********
C 
      COMMON ILU,ISCRN,IQST,ISKIP,INDIC 
      COMMON IFORM(780) 
      COMMON JFORM(1700)
      COMMON MFORM(28)
      COMMON LFORM(42)
      COMMON ITT
      COMMON IKEY(26,3) 
      COMMON IUMAX,IMMAX
      COMMON IMODB
      COMMON ILITE(15)
      COMMON IMAI(45,5) 
      COMMON IMFLG,IMAS,IMDT,IMKY 
      COMMON KFORM(2844)
      COMMON ILIBR(67)
      COMMON NIMAG
      COMMON IBASE(10),IMODE,ISWICH(5)
C 
C   LOCAL VARIABLES **********
C 
      DIMENSION ITGP0(3),ITGP10(3),ITGP11(3),ITGP13(3),ITGP3(3) 
      DIMENSION JOUT(10),IFN(9),MNAM(3) 
      DIMENSION IHP3(6),IHP4(11),IHP41(10),IRSET(8) 
      DIMENSION NOMON(10),IERROR(6),ISTAT(10),IBASE0(10)
C 
      EQUIVALENCE(NOF,KFORM(1900))
      EQUIVALENCE(WRNSET,KFORM(1023)) 
C 
      LOGICAL JPAR,ISBTW,GETBK,OKABT,ISBIT,IMBED
C 
C  DATA VALUES :
C 
      DATA JBYTES/170/
      DATA JWORDS/85/ 
      DATA ITGP0/2HTG,2HP0,2H  /
      DATA ITGP10/2HTG,2HPI,2H0 / 
      DATA ITGP11/2HTG,2HPI,2H1 / 
      DATA ITGP13/2HTG,2HPI,2H3 / 
      DATA ITGP3/2HTG,2HP3,2H  /
      DATA MNAM/2HDC,2HMO,2HN / 
      DATA IFN/5,6,7,8,9,4,2,3,1/ 
      DATA IHP3/27,2,7,3,4,5/ 
      DATA IHP4/1,6,7,28,8,11,12,9,10,29,29/
      DATA IHP41/17,13,16,23,14,19,20,21,22,15/ 
      DATA IRSET/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/ 
      DATA NOMON/2H'D,2HCM,2HON,2H' ,2HNO,2HT ,2HPR,2HES,2HEN,2HT / 
      DATA IERROR/2HER,2HRO,2HR ,2H  ,2H  ,2H  /
C 
C*********************************************************************
C 
C  ACCORDING TO INDIC VALUE GO TO THE REQUIRED PORTION OF TGP1
C 
C*********************************************************************
      IF(INDIC.NE.1) GO TO 20 
      INDIC=0 
      GO TO 227 
20    IF(INDIC.NE.2) GO TO 25 
      INDIC=0 
      GO TO 526 
25    IF(INDIC.NE.3) GO TO 30 
      INDIC=0 
      GO TO 222 
30    IF(INDIC.NE.4) GO TO 35 
      INDIC=0 
      GO TO 230 
35    IF(INDIC.NE.-77) GO TO 40 
      INDIC=0 
      GO TO 3062
40    IF(INDIC.EQ.99) GO TO 990 
C 
C 
C*********************************************************************
C 
C  INDIC = 0   GET THE ANSWERS IN THE SCREEN
C 
C*********************************************************************
C 
15    IF(ISBTW(ISCRN,3,4)) ITLOG=2
      IF(ISCRN.EQ.3) ITLOG=36 
      IF(ISCRN.EQ.4) ITLOG=52 
      IF(ISCRN.EQ.41) ITLOG=31
      IF(.NOT.(GETBK(ILU,KFORM,ITLOG,IMODE))) GO TO 10
C 
C  ERROR IN GETTING ANSWERS REPRINT SCREEN
C 
17    IF(ISCRN.EQ.41) CALL EXEC(8,ITGP3)
      CALL EXEC(8,ITGP0)
C 
C*********************************************************************
C 
C GO TO ANALYSE USER ANSWERS TO SCREEN # ISCRN
C 
C*********************************************************************
C 
10    IF(ISCRN.EQ.41) GO TO 4100
      GO TO (100,400,200,500,600) ISCRN 
C 
C*********************************************************************
C 
C  SCREEN # 0 ANSWERS  (EXPLANATORY SCREEN) 
C 
C*********************************************************************
C 
100   IF(ISCRN.EQ.1) GO TO 300
      NOF=1 
      IF(.NOT.JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 105 
      IF(IFLG.NE.4) GO TO 3000
105   ISCRN=3 
      CALL EXEC(8,ITGP0)
C 
C*********************************************************************
C 
C  SCREEN # 3 ANSWERS (MODE OF OPERATION) 
C 
C*********************************************************************
C 
C  MODE OF OPERATION
C 
C --- IF IMODE EQUALS "0", BLANC OUT ILIBR IN CASE AN AUTOMATIC 
C     MODIFY GETS DONE. ELEMENTS IN ILIBR WILL GET MOVED INTO 
C     LFORM IN THIS CASE. 
C 
200   IF(IMODE.EQ.1) GO TO 201
      CALL BLANC(ILIBR,67)
      ILIBR(7)=0
C 
201   NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      JVAL1=-1
      IF(JOUT.EQ.2HC ) JVAL1=1
      IF(JOUT.EQ.2HM ) JVAL1=2
      IF(JOUT.EQ.2HL ) JVAL1=3
      IF(JOUT.EQ.2HB ) JVAL1=4
      IF(JOUT.EQ.2HA ) JVAL1=2
      IF(JOUT.NE.2HE ) GO TO 203
        ISCRN=1 
        CALL EXEC(8,ITGP0)
203   IF(JVAL1.EQ.-1) GO TO 250 
      IMODE=0 
      IF(JOUT.EQ.2HA ) IMODE=1
      CALL MOVCA(JOUT,1,IFORM,13,1) 
      IF(JVAL1.EQ.1) IUMAX=0
      IF(JVAL1.EQ.1) IMMAX=0
      IF(JVAL1.EQ.2) CALL BLANC(LFORM(22),15) 
C 
C   TRANSACTION SPEC NAME OR #
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260
      IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.EQ.0)) GO TO 580 
      IF(IFLG.EQ.0) GO TO 207 
      IF(IFLG.NE.1) GO TO 205 
      IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 550 
      GO TO 207 
205   IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 265
207   CALL MOVEW(JOUT,IFORM(8),3) 
C 
C   TRANSACTION SPEC SECURITY CODE
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260
      IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.GT.1)) GO TO 555 
      IF(JVAL.EQ.-32768) GO TO 555
      CALL MOVEW(JOUT,IFORM(11),3)
C 
C  LIBRARY FILE NAME
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260
      IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.EQ.0)) GO TO 262 
      CALL MOVEW(JOUT,IFORM(14),3)
C 
C  CARTRIDGE #
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(ISBTW(JVAL1,2,3).AND.(IFLG.NE.0)) GO TO 260
C     BLANK?
      IF(IFLG.EQ.0) GO TO 2091
C     NO.  INTEGER? 
      IF(IFLG.NE.1) GO TO 208 
C     YES.
      IF(JVAL.LT.1) GO TO 264 
      GO TO 2091
C     ASCII?
208   IF(IFLG.NE.3) GO TO 264 
C     YES.  LEFT JUSTIFY IT & MAKE SURE IT IS A VALID 2 CHAR CR#. 
      CALL JUSTF(JOUT,1,6,1)
      IF(LNCAR(JOUT,1,6).GT.2) GO TO 264
      IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 264
      I=IGET1(JOUT,2) 
      IF(ISBTW(I,1HA,1HZ) .AND. ISBTW(I,1H0,1H9) .AND. ISBTW(I,1H ,1H ))
     .GO TO 264 
2091  CALL MOVEW(JOUT,IFORM(17),3)
C 
C  LIST FILE NAME 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF((JVAL1.NE.3).AND.(IFLG.NE.0)) GO TO 260
      IF(JVAL1.NE.3) GO TO 209
C 
C  DEFAULT LIST FILE IS INTERACTIVE LU
C 
      IF(IFLG.NE.0) GO TO 210 
      ISKIP=ILU 
      GO TO 209 
C 
C  A LIST FILE NAME HAS BEEN GIVEN CHECK FILE EXIST ,IS TYPE 0
C  GET THE LU # IN THE IDCB . 
C 
210   IF(OPEN(KFORM,ISTAT,JOUT).LT.0) GO TO 212 
      IF(ISTAT.NE.0) GO TO 211
      ISKIP=KFORM(4)
      CALL CLOSE(KFORM) 
      GO TO 209 
C 
C FILE TYPE IS NOT 0
C 
211   IMES=4
      CALL CLOSE(KFORM) 
      GO TO 232 
C 
C  ERROR IN OPENING THE FILE
C 
212   IMES=19 
      IF(ISTAT.EQ.-6) IMES=31 
      IF(IMES.EQ.19) CALL JASC(ISTAT,JOUT,1,6)
      GO TO 232 
C 
209   CALL MOVEW(JOUT,IFORM(20),3)
C 
C  IF MODE OF OPERATION IS "B" PRINT SCREEN 19
C 
      IF(JVAL1.NE.4) GO TO 199
      CALL BLANC(ILIBR,67)
      ISCRN=20
      INDIC=0 
      CALL EXEC(8,ITGP3)
C 
C  IF MODE OF OPERATION IS "L" OR "M" OR "A" GO TO READ FORM
C 
199   IF(JVAL1.GT.1) GO TO 225
C 
C  HERE POINT OF RETURN FORM TGP10 IF MODE OF OP. WAS L OR M
C  TRANS. SPEC HAS BEEN READ
C 
222   JVAL=IGET1(IFORM,13)
D     GO TO 224 
C-----IF "M"  OR "A"  BLANK THE LIBRARY HEADER
      IF(JVAL.EQ.2HM  .OR. JVAL.EQ.2HA ) CALL BLAN(LFORM,43,30) 
C 
C-----IF AUTOMATIC MODE, GET DEST LIB FNAME, CRN, HEADER, & LISTFILE NAME.
C 
      IF(IMODE.NE.1) GO TO 2221 
      CALL MOVCA(ILIBR,1,LFORM,31,6)
      CALL MOVCA(ILIBR,7,LFORM,37,6)
      CALL MOVCA(ILIBR,15,LFORM,43,ILIBR(7))
      IF(ILIBR(23).EQ.2H  ) GO TO 2221
      CALL MOVCA(ILIBR,45,LFORM,73,6) 
C 
C   IF MODE OF OPERATION IS "L" GO TO PRINT SPECS 
C 
2221  IF((JVAL.EQ.2HM ).OR.(JVAL.EQ.2HC ).OR.(JVAL.EQ.2HA )) GO TO 223
      INDIC=4278
      CALL EXEC(8,ITGP13) 
C 
C  IF MODE OF OPERATION IS "C", "A",  OR "M" INITIALISE BUFFERS 
C 
223   CALL NUL(ILITE,14)
      CALL NUL(IMAI,225)
      IMFLG=0 
      IMAS=0
      IMDT=0
      IMKY=0
      CALL NUL(IKEY,78) 
      KFORM(1060)=0 
C 
C  INITIALISE SOURCE BUFFERS ONLY FOR CREATE
C 
      CALL BLANC(ILIBR,67)
      IF(JVAL.NE.2HC ) GO TO 224
      INDIC=0 
      DO 706 I=24,780 
706   IFORM(I)=2H 
      CALL BLANC(JFORM,1700)
      CALL BLANC(LFORM,42)
      CALL BLANC(MFORM,28)
      DO 714 I=1,20 
714   JFORM(66+(I-1)*JWORDS)=0
C 
C  INITIALISE SFK'S TO THE DEFAULT SET
C 
C  KEY #
C 
      IFORM(44)=2H1 
      IFORM(60)=2H 2
      IFORM(77)=2H3 
      IFORM(93)=2H 4
      IFORM(110)=2H5
      IFORM(126)=2H 6 
      IFORM(143)=2H7
      IFORM(159)=2H 8 
      IFORM(176)=2H9
C 
C  FUNCTION # AND TERMINATOR
C 
      IFORM(53)=2HAD
      IFORM(54)=2HX 
      IFORM(69)=2H S
      IFORM(70)=2HUX
      IFORM(86)=2HMP
      IFORM(87)=2HX 
      IFORM(102)=2H D 
      IFORM(103)=2HVX 
      IFORM(119)=2HEQ 
      IFORM(120)=2HX
      IFORM(135)=2H A 
      IFORM(136)=2HBX 
      IFORM(152)=2HRC 
      IFORM(153)=2HX
      IFORM(168)=2H S 
      IFORM(169)=2HVX 
      IFORM(185)=2HTC 
      IFORM(186)=2HX
C 
C  SFK'S LABELS 
C 
      DO 720 I=1,9
      CALL FILAC(I,0,IFN(I),IFORM)
720   CONTINUE
C 
C  CALL NEXT SCREEN 
C 
224   ISCRN=4 
      IMODE=0 
      IF(JVAL.EQ.2HA ) IMODE=1
      CALL EXEC(8,ITGP0)
C 
C  GO TO READ FORM
C 
225   CALL EXEC(8,ITGP10) 
C 
C  RETURN FROM TGP10  AN ERROR HAS OCCURED IN READING SPEC REPRINT
C  SCREEN 3 SET INDIC TO 4 TO PRINT LATER THE ERROR . 
C 
227   ISCRN=3 
      INDIC=4 
      CALL EXEC(8,ITGP0)
C 
C   ERRORS ON READING FORM
C 
230   IMES=0
      IF(ISKIP.EQ.1) IMES=15
      IF(ISKIP.EQ.2) IMES=16
      IF(ISKIP.EQ.5) IMES=17
      IF(ISKIP.EQ.6) IMES=18
      IF(ISKIP.EQ.-6) IMES=20 
      IF(ISKIP.EQ.-32) IMES=14
      IF(ISKIP.EQ.7) IMES=21
      IF(ISKIP.EQ.8) IMES=24
      NOF=2 
      IF((IMES.NE.15).AND.(IMES.NE.17)) GO TO 231 
      NOF=4 
231   IF(IMES.EQ.14) NOF=5
      IF(IMES.EQ.20) NOF=4
      IF(IMES.EQ.21) NOF=3
      IF(IMES.NE.0) GO TO 232 
      IMES=19 
      CALL JASC(ISKIP,JOUT,1,6) 
232   CALL MES01(IMES,NOF,JOUT) 
      GO TO 15
C 
C  ERROR PROCESSING SCREEN # 3
C 
250   CALL MES01(1,NOF) 
      GO TO 15
260   CALL MES01(10,NOF)
      GO TO 15
261   CALL MES01(11,NOF)
      GO TO 15
262   CALL MES01(12,NOF)
      GO TO 15
263   CALL MES01(13,NOF-1)
      GO TO 15
264   CALL MES01(14,NOF)
      GO TO 15
265   CALL MES01(22,NOF)
      GO TO 15
C --- ILLEGAL LIBRARY SECURITY CODE 
266   CALL MES01(41,NOF)
      GO TO 15
C 
C*********************************************************************
C 
C  SCREEN # 1 ANSWERS (EXPLANATORY SCREEN)
C 
C*********************************************************************
C 
300   NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 
      ISCRN=2 
      CALL EXEC(8,ITGP0)
C 
C*********************************************************************
C 
C  SCREEN # 2 ANSWERS  (EXPLANATORY SCREEN) 
C 
C********************************************************************** 
C 
400   NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 
      ISCRN=5 
      CALL EXEC(8,ITGP0)
C 
C*********************************************************************
C 
C  SCREEN # 4 ANSWERS (TRANS. IDENTIFICATION AND TYPE)
C 
C********************************************************************** 
C 
C 
C  SPECS NAME 
C 
500   NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) GO TO 580 
      CALL JUSTF(JOUT,1,6,1)
      IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 265
      IF (IMBED(JOUT,1,6)) GO TO 588
      CALL MOVEW(JOUT,IFORM(29),3)
C 
C  SPECS NUMBER 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,4,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) GO TO 550 
      IF(IFLG.NE.1) GO TO 550 
      IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 550 
502   CALL MOVEW(JOUT,IFORM(32),2)
C 
C SPECS SECURITY CODE 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.GT.1) GO TO 555 
      IF(JVAL.EQ.-32768) GO TO 555
      CALL MOVEW(JOUT,IFORM(34),3)
C 
C-----INITIALIZE ITT
C 
      ITT=0 
C 
C-----LOGGING?
C 
510   NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585 
      CALL MOVCA(JOUT,1,IFORM,74,1) 
      IF(JOUT.EQ.2HX ) CALL SETBT(ITT,2,1)
C 
C  USER WRITTEN MODULES ? 
C 
520   NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585 
      IF(JOUT(1).EQ.2HX ) CALL SETBT(ITT,0,1) 
      CALL MOVCA(JOUT,1,IFORM,73,1) 
C 
C SELF COMPLETING?
C 
5200  NOF=NOF+1 
      IF (JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000
      IF ((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585
      CALL MOVCA(JOUT,1,IFORM,1545,1) 
C 
C LIGHT # TO STAY LIT DURING TRANSACTION
C 
52001 NOF=NOF+1 
      IF (JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000
      IF ((IFLG.NE.0).AND.(IFLG.NE.1)) GO TO 587
      IF ((IFLG.EQ.1).AND.((JVAL.LT.0).OR.(JVAL.GT.14))) GO TO 587
      CALL MOVCA(JOUT,1,IFORM,1546,2) 
      IF(IFLG.NE.0) CALL SETBT(ITT,8,1) 
      IF (IFLG.NE.0) ILITE(JVAL)=99 
C 
C  DATA BASE NAME 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 
      IF((IFLG.NE.0).AND.(NIMAG.EQ.1)) GO TO 586
      IF(IFLG.NE.0) CALL SETBT(ITT,1,1) 
      CALL MOVCA(JOUT,1,IFORM,75,5) 
      IFORM(40)=IAND(IFORM(40),177400B) 
      IFORM(40)=IFORM(40)+40B 
C 
C  DATA BASE SECURITY CODE
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) GO TO 525 
      IF(.NOT.ISBIT(ITT,1)) GO TO 260 
      IF(IFLG.NE.1) GO TO 570 
      IF(JVAL.LT.1) GO TO 570 
525   IF(ISBIT(ITT,1)) GO TO 5250 
           IF(IFLG.NE.0) GO TO 260
           GO TO 5255 
5250  IF(IFLG.NE.1) GO TO 570 
5255  CALL MOVCA(JOUT,1,IFORM,81,5) 
C 
C-----CR# (5 NUMERIC CHAR, REQD IF DB SPECIFIED)
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 
C     -USING DB?
      IF(ISBIT(ITT,1)) GO TO 5201 
C     -NO.  CR# BLANK?
      IF(IFLG.EQ.0)    GO TO 522
C     -NO.  ERROR.
      GO TO 260 
C 
C     NO.  INTEGER? 
5201  IF(IFLG.NE.1) GO TO 521 
C     YES.
      IF(JVAL.LT.1) GO TO 264 
      GO TO 522 
C     ASCII?
521   IF(IFLG.NE.3) GO TO 264 
C     YES.  LEFT JUSTIFY IT & MAKE SURE IT IS A VALID 2 CHAR CR#. 
      CALL JUSTF(JOUT,1,6,1)
      IF(LNCAR(JOUT,1,6).GT.2) GO TO 264
      IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 264
      I=IGET1(JOUT,2) 
      IF(ISBTW(I,1HA,1HZ) .AND. ISBTW(I,1H0,1H9) .AND. ISBTW(I,1H ,1H ))
     .GO TO 264 
522   CALL MOVCA(JOUT,1,IFORM,1534,5) 
C 
C-----HIGHEST LEVEL ACCESS WORD OF DATA BASE (6 ASCII CHAR, REQD FOR DB)
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(ISBIT(ITT,1)) GO TO 524
      IF(IFLG.EQ.0) GO TO 524 
      GO TO 260 
524   CALL MOVCA(JOUT,1,IFORM,1539,6) 
C 
C  IF DATA BASE ACESSED GO TO TGP11 TO OPEN IT ISKIP=D.B. SEC. CODE 
C 
      IF(.NOT.ISBIT(ITT,1)) GO TO 526 
C    -BUILD THE DATA BASE NAMR & STORE IT INTO IBASE BEFORE CALLING TGP11 
      DO 5257 I=1,10
         IBASE0(I)=2H 
         IBASE(I)=2H
5257  CONTINUE
C    -BYTES 1,2 : DS NODE (NOT YET IMPLEMENTED) 
      IBASE0(1)=2H
C    -BYTES 3-7 : DB NAME 
      CALL MOVCA(IFORM,75,IBASE0,3,5) 
C    -BYTE 8 : COLON
      CALL PUTCA(IBASE0,1H:,8)
C    -BYTES 9-13 : SECURITY CODE
      CALL MOVCA(IFORM,81,IBASE0,9,5) 
C    -BYTE 14 : COLON 
      CALL PUTCA(IBASE0,1H:,14) 
C    -BYTES 15-19 : CR# 
      CALL MOVCA(IFORM,1534,IBASE0,15,5)
C    -BYTE 20 : SEMI-COLON
      CALL PUTCA(IBASE0,1H;,20) 
C     -NOW PACK IBASE ELIMINATING IMBEDDED BLANKS.
      K=3 
      DO 5258 I=2,20
         J=IGET1(IBASE0,I)
         IF(J.EQ.1H ) GO TO 5258
         CALL PUTCA(IBASE,J,K)
         K=K+1
5258  CONTINUE
      ISKIP=JVAL
      INDIC=0 
      CALL EXEC(8,ITGP11) 
C 
C  RETURN FROM TGP11 : DATA BASE SUCCESFULY OPENED
C 
C 
C   PRINT SCREEN # 41 
C 
526   ISCRN=41
      CALL EXEC(8,ITGP3)
C 
C  SCREEN # 4 ERROR PROCESSING
C 
550   CALL MES01(2,NOF) 
      GO TO 15
555   CALL MES01(3,NOF) 
      GO TO 15
570   CALL MES01(6,NOF) 
      GO TO 15
580   CALL MES01(7,NOF) 
      GO TO 15
585   CALL MES01(9,NOF) 
      GO TO 15
586   CALL MES01(5,NOF) 
      GO TO 15
587   CALL MES01(32,NOF)
      GO TO 15
588   CALL MES01(35,NOF)
      GO TO 15
C 
C*********************************************************************
C 
C     SCREEN # 41 : DATA CAPTURE TERMINAL FEATURE SPECIFICATIONS
C 
C*********************************************************************
C 
C 
C---ALPHANUMERIC LED DISPLAY
C 
4100  NOF=1 
C     FIRST CLEAR BITS 3,4,5,6,7,9,10,11,12,13 IN ITT 
      ITT=IAND(ITT,140407B) 
      NOPTN=0 
      NOPT7=0 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      CALL MOVCA(JOUT,1,IFORM,1517,1) 
      IF(JOUT .EQ. 1HX) CALL SETBT(ITT,7,1) 
C 
C---ALPHANUMERIC STRIP PRINTER
C 
      IFL1=0
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX) NOPTN=NOPTN+1
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,3,1)
      CALL MOVCA(JOUT,1,IFORM,1515,1) 
      IF(IFLG.NE.0) IFL1=IFLG 
C 
C--CRT DISPLAY
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX .AND. ISBIT(ITT,7)) GO TO 4119
      CALL MOVCA(JOUT,1,IFORM,1550,1) 
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,13,1) 
      IF(IFLG.NE.0) IFL1=IFLG 
C 
C---TIME REPORTING TERMINAL - MUST BE "12" OR "24", IF SPECIFIED, 
C   CANNOT HAVE PRINTER, KEYBOARD, BAR CODE READER, CRT, LIGHT LIT. 
C   TYPE III, V AND MAGSTRIPE READER ARE MUTUALLY EXCLUSIVE 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 
      IF(IFLG .EQ. 0) GO TO 4105
      IF(JOUT(1) .NE. 2H12 .AND. JOUT(1) .NE. 2H24) GO TO 4113
      IF(ISBIT(ITT,3)) GO TO 4114 
      IF(IGET1(IFORM,1550) .EQ. 1HX) GO TO 4121 
      IF(IGET2(IFORM,1546) .NE.2H  ) GO TO 4125 
      IF(IGET1(IFORM,1545) .NE.1H ) GO TO 4122
      CALL SETBT(ITT,10,1)
      IF(JOUT(1) .EQ. 2H24) CALL SETBT(ITT,11,1)
4105  CALL MOVCA(JOUT,1,IFORM,1532,2) 
C 
C -IF TIME REPORTING TRANS, SET IKEY(26,3) TO DEFAULT & GO
C  TO SCREEN 8, SKIPPING 6-7
C 
      IF(.NOT.ISBIT(ITT,10)) GO TO 4109 
C -SET FUNCTIONS
      IKEY(1,1)=5 
      IKEY(2,1)=6 
      IKEY(3,1)=7 
      IKEY(4,1)=8 
      IKEY(5,1)=9 
      IKEY(6,1)=4 
      IKEY(7,1)=2 
      IKEY(8,1)=3 
      IKEY(9,1)=1 
C -SET TERMINATOR FLAGS 
      DO 4107 I=1,9 
        DO 4107 J=1,2 
           IKEY(I,J)=1
4107  CONTINUE
C 
C---ERROR LABEL 
C 
4109  NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,12,IFLG,JVAL)) GO TO 3000
      IF(IFL1 .EQ. 0 .AND. IFLG .NE. 0 ) GO TO 4116 
      IF(IFLG .NE. 0 .AND. ISBIT(ITT,10)) GO TO 4116
      CALL MOVCA(JOUT,1,IFORM,1520,12)
      IF(IFLG .EQ. 0 .AND. IFL1 .NE. 0) 
     .  CALL MOVCA(IERROR,1,IFORM,1520,12)
C 
C---CARD READER/TYPE III BADGE
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1).EQ.1HX) NOPTN=NOPTN+1
      IF(JOUT(1).EQ.1HX.AND.ISBIT(ITT,10)) NOPT7=NOPT7+1
      IF(JOUT(1).EQ.1HX) CALL SETBT(ITT,4,1)
      CALL MOVCA(JOUT,1,IFORM,1518,1) 
C 
C---TYPE V BADGE
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX .AND. NOPTN .EQ. 2) GO TO 4112
      IF(JOUT(1) .EQ. 1HX .AND. NOPT7 .EQ. 1) GO TO 4118
      IF(JOUT(1) .EQ. 1HX) NOPTN=NOPTN+1
      IF(JOUT(1) .EQ. 1HX.AND.ISBIT(ITT,10)) NOPT7=NOPT7+1
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,5,1)
      CALL MOVCA(JOUT,1,IFORM,1519,1) 
C 
C---MAG STRIPE READER 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX .AND. NOPTN .EQ. 2) GO TO 4112
      IF(JOUT(1) .EQ. 1HX .AND. NOPT7 .EQ. 1) GO TO 4118
      IF(JOUT(1) .EQ. 1HX) NOPTN=NOPTN+1
      IF(JOUT(1) .EQ. 1HX.AND. ISBIT(ITT,10)) NOPT7=NOPT7+1 
      IF(ISBIT(ITT,10) .AND. NOPT7 .EQ. 0) GO TO 4117 
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,12,1) 
      CALL MOVCA(JOUT,1,IFORM,1548,1) 
C 
C---BAR CODE READER 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX .AND. ISBIT(ITT,10)) GO TO 4124 
      IF(JOUT(1) .EQ. 1HX .AND. NOPTN .EQ. 2) GO TO 4112
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,9,1)
      CALL MOVCA(JOUT,1,IFORM,1549,1) 
C 
C---APLHA KEYBOARD
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(JOUT(1) .NE. 1H .AND. JOUT(1) .NE. 1HX) GO TO 4110 
      IF(JOUT(1) .EQ. 1HX .AND. ISBIT(ITT,10)) GO TO 4115 
      CALL MOVCA(JOUT,1,IFORM,1516,1) 
      IF(JOUT(1) .EQ. 1HX) CALL SETBT(ITT,6,1)
C 
C-----PRINT SCREEN # 6
C-------UNLESS A 3077 IS BEING USED IN WHICH CASE SCR 6-7 ARE SKIPPED 
C 
      ISCRN=6 
      IF(ISBIT(ITT,10)) ISCRN=9 
      IF(ISBIT(ITT,10)) CALL EXEC(8,ITGP3)
      CALL EXEC(8,ITGP0)
C 
C  SCREEN #41 ERROR PROCESSING
C 
C 
C     "FIELD MUST BE BLANK OR X"
C 
4110  CALL MES01(9,NOF) 
      GO TO 15
C 
C     "FIELD MUST BE BLANK" 
C 
4111  CALL MES01(10,NOF)
      GO TO 15
C 
C     "ONLY 2 OF THE "#" ITEMS MAY BE SPECIFIED"
C 
4112  CALL MES01(23,NOF)
      GO TO 15
C-----"MUST BE BLANK OR 12 OR 24
4113  CALL MES01(25,NOF)
      GO TO 15
C-----"PRINTER CANNOT BE SPECIFIED" 
4114  CALL MES01(26,NOF)
      GO TO 15
C-----"KEYBOARD CANNOT BE SPECIFIED"
4115  CALL MES01(27,NOF)
      GO TO 15
C-----"ERROR MESSAGE CANNOT BE SPECIFIED" 
4116  CALL MES01(28,NOF)
      GO TO 15
C    -"BADGE OR CARD READER REQUIRED" 
4117  CALL MES01(29,NOF)
      GO TO 15
C    -"BOTH TYPE III & V CANNOT BE SPECIFIED" 
4118  CALL MES01(30,NOF)
      GO TO 15
C-- BOTH ALPHA DISPLAY AND CRT NOT ALLOWED
4119  CALL MES01(40,NOF)
      GO TO 15
C--**************************************************************** 
C  **************************************************************** 
C  **************************************************************** 
C   CRT CAN NOT BE SPECIFIED
4121  CALL MES01(36,NOF)
      GO TO 15
C   CANNOT SPECIFY SELF COMPLETE WITH A 3077-IT JUST DOES IT
4122  CALL MES01(39,NOF)
      GO TO 15
C  CAN'T SPECIFY 3077 WITH SELF COMPLETE
4123  CALL MES01(38,NOF)
      GO TO 15
C  CANNOT USE BAR CODE READER WITH 3077 
4124  CALL MES01(37,NOF)
      GO TO 15
C  CANNOT HAVE LIGHT LIT FOR TRANSACTION WITH A 3077. 
4125  CALL MES01(42,NOF)
      GO TO 15
C 
C 
C*********************************************************************
C 
C  SCREEN # 5 ANSWERS  (EXPLANATORY SCREEN) 
C 
C*********************************************************************
C 
600   NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 
      ISCRN=3 
      CALL EXEC(8,ITGP0)
C 
C***********************************************************************
C 
C  CALL NEXT SCREEN 
C 
1000  CALL EXEC(8,ITGP0)
C 
C*********************************************************************
C 
C 
C*********************************************************************
C 
C  2645 SOFT FUNCTION KEY PROCESSING
C 
C*********************************************************************
C 
C  IFLG=5 MEANS NON PRINTABLE ASCII 
C 
3000  IF(IFLG.EQ.4) IFLG=5
      IF(IFLG.NE.5) GO TO 3007
3001  CALL MES01(8,NOF) 
      GO TO 15
C 
C  IFLG=6 MEANS ILLEGAL PARSE 
C 
3005  IF(IFLG.NE.6) GO TO 3007
      STOP 500
C 
C  IFLG=7 MEANS HELP
C 
3007  IF(IFLG.NE.7) GO TO 3010
      IF((ISCRN.GT.2).AND.(ISCRN.NE.5)) GO TO 3061
3006  JOUT=20040B 
      JOUT(2)=15542B
      CALL EXEC(2,ILU,JOUT,2) 
      GO TO 15
3061  INDIC=-77 
      GO TO 17
3062  IF(ISCRN.NE.3) GO TO 3050 
      IMES=IHP3(NOF)
      GO TO 3060
3050  IF(ISCRN.NE.4) GO TO 3053 
      IMES=IHP4(NOF)
      IF(WRNSET.EQ.3 .AND. NOF.EQ.-1) IMES=24 
      IF(NOF.EQ.-1) NOF=1 
      GO TO 3060
3053  IF(ISCRN.NE.41) GO TO 15
      IMES=IHP41(NOF) 
3060  CALL HLP01(IMES,NOF)
      GO TO 15
C 
C  IFLG=8 MEANS LAST SCREEN 
C 
3010  IF(IFLG.NE.8)                  GO TO 3017 
      IF(ISCRN.EQ.0)                 GO TO 3015 
C 
C  IF SCRN 4 GIVE WARNING ABOUT PRESSING PREVIOUS SCREEN
C 
      IF(ISCRN.NE.4) GO TO 30105
      IF(WRNSET.EQ.3) GO TO 30105 
      WRNSET=3
      NOF=-1
      GO TO 3061
30105 WRNSET=0
      IF(ISCRN.EQ.1 .OR. ISCRN.EQ.4) GO TO 3011 
      IF(ISCRN.EQ.2)                 GO TO 3012 
      IF(ISCRN.EQ.3)                 GO TO 30121
      IF(ISCRN.EQ.41)                GO TO 3013 
      IF(ISCRN.EQ.5)                 GO TO 3014 
      GO TO 3015
3011  ISCRN=3 
      GO TO 3015
3012  ISCRN=ISCRN-1 
      GO TO 3015
30121 ISCRN=0 
      GO TO 3015
3013  ISCRN=4 
      IF(ISBIT(ITT,1)) CALL DBCLS(IBASE,ID,1,ISTAT) 
      GO TO 3015
3014  ISCRN=2 
      GO TO 3015
3015  CALL EXEC(8,ITGP0)
C 
C-----ABORT KEY PRESSED?
C 
3017  IF(OKABT(ILU)) GO TO 990
C-----NO, RESCHEDULE TGP0.
      IF(ISCRN.EQ.41) CALL EXEC(8,ITGP3)
      CALL EXEC(8,ITGP0)
C-----YES, ABORT PROGRAM
C-----WAS A DATA BASE USED? 
990   IF(.NOT.ISBIT(ITT,1)) GO TO 992 
C-----YES, (IE, TRANS. TYPE 2 OR 3) CLOSE DATA BASE 
      CALL DBCLS(IBASE,ID,1,ISTAT)
C-----RESET TERMINAL. 
992   CALL EXEC(2,ILU,IRSET,8)
      CALL RESET(ILU,ISWICH,IVAL,0) 
C-----RE-SCHEDULE 'DCMON' 
C     FIRST UNLOCK THE TERMINAL 
      CALL LURQ(100000B,ILU,1)
      GO TO 7212
7212  CONTINUE
      CALL EXEC(100000B+23,MNAM,ILU)
      GO TO 995 
993   GO TO 999 
C-----"DCMON NOT PRESENT" 
995   CALL EXEC(2,ILU,NOMON,10) 
      GO TO 999 
C-----END OF SEGMENT
996   CALL TGP
999   END 
      END$