 SYSTEM SIG7
*M*      TFDUTL IS USED TO CREATE AND MAINTAIN THE TP TFD FILE
 SYSTEM BPM
LNLEN    EQU      72                LENGTH OF A PRINT LINE-132  FOR ON LINE
MAX      EQU      I12-I11           MAX NUMBER OF OPERATIONS
         DEF      TFDUTL            MAIN ONE AND ONLY ONE ENTRY POINT
         DEF      PATCH
TFDSZ     EQU      17                SIZE OF TFD CODE OR NAME IN BYTES
XLIMIT   EQU      5                 MAX NUMBER OF FORMAL TRANS
TFDTEXT  EQU      1979              MAX TFD SIZE
BSIZ     EQU      TFDTEXT+1
R1        EQU     1                  REGESTER EQUIV
R2        EQU     2
R3        EQU     3
R4        EQU     4
R5        EQU     5
R6        EQU     6
R7        EQU     7
R8        EQU     8
R9        EQU     9
R10       EQU     10
R11       EQU     11
R12       EQU     12
R13       EQU     13
R14       EQU     14
R15       EQU     15
         PAGE
MOVE     CNAME                      CONVENTION FOR MOVE STRING PROC
         PROC                       XR4 AND XR5 USED FOR THE MBS INSTRUCTION
LF       LI,R4    AF(1)             FROM
         LI,R5    AF(2)             TO
         OR,R5    AF(3)             COUNT
         MBS,R4   0                 MOVE IT
         PEND
**********USAGE EXAMPLE    MOVE  BA(HERE),BA(THERE),=COUNT LEFT JUSTIFIED
**********USAGE EXAMPLE  PTCH       THIS DOES THE MOVE
PTCH     CNAME                      THIS PUTS CHARACTERS AWAY
         PROC                       CHARACTER IN 15
LF       LW,R3    PTWS              COUNT OF NUMBER OF CHAR
         STB,R15  CDBUF,R3          PUT THE BYTE AWAY
         AI,R3    1
         CI,R3    TFDTEXT           MAX SIZE OF THE WHOLE THING
         BG       ER2
         STW,R3   PTWS
         PEND
F:TFDX   DSECT 1
F:TFDX   M:DCB    (DEVICE,'DC'),(FILE,'DUMMYFILE'),(KEYED),(DIRECT),;
                  (INOUT),(SAVE),(ABN,OM),(KEYM,TFDSZ),(RECL,BSIZ),;
         (ERR,OM)
         REF      M:LO              LISTING AND ERROR OUTPUT FILE
         REF      M:SI              INPUT DIRECTIVES AND DATA
         CSECT    0
         BOUND    4
NFSW     RES      1                 PROCESSING ROUTINE
NFSW1    RES      1                 FOUND IT SWITCH
NFSW2    RES      1                 EOF SWITCH
GETCC    GEN,32   X'0'         NUMBER OF CHARACTERS USED
PTWS     GEN,32   X'0'
         GEN,32   X'0'
ZSVTX    RES      1                 LOCATION OF BYTE IN PIC
CRET     RES      1                 RETURN LINKAGE FOR CARD ROUTING ETC
ADSW1    RES      1                 SWITCH LINKAGE
CDSZ     RES      1                 SIZE OF CD IMAGE FOR TSS
PCON     GEN,32   LNLEN             LINE LENGTH
PBA      RES      1                  POINTER FOR PRINTING LINES
P1       RES      1                 RETURN LINKAGE
P2       RES      1                 LOCATION OF BUFFER
P3       RES      1                 SIZE OF DATA
PSIZ     RES      2                  WORK LOCATION FOR LINE SIZES
PFTST    RES       1                 TEMP BLANK ZERO SWITCH
PFM1      RES     LNLEN              LINE OUTPUT BUFFER
PF1       RES     1                  TENS COUNTER
FMLPOS   RES      1                 CURRENT LOC POINTER IN FORMAL TRANS
BAD%END%FLG DATA 0     FLAG TO SIGNAL THAT WE ARE READING
         PAGE
BDCD3    TEXTC    C'*****ERROR IN THE Z STRING OF THE FOLLOWING CARD'
BDCDM    TEXTC    C'*****INVALID OPTION SPECIFIED'
ERAD1    TEXTC    C'*****YOU TRIED TO ADD A NAME THAT ALREADY EXISTS'
ERAD2    TEXTC    C'*****THE FOLLOWING TFD EXCEEDS THE INPUT BUFFER ',;
  'SIZE'
PICE2    TEXTC    C'*****THE FOLLOWING TFD HAS AN ERROR IN PRIMITIVE '
PICE4    TEXTC    C'*****TOO LARGE A WW FIELD SPECIFIED '
PICE5    TEXTC    C'*****VALID CHARACTERS PROCESSED ARE:'
PICE7    TEXTC    C'*****THE FOLLOWING TFD IS TOO LARGE FOR TPO'
PICE9    TEXTC    C'*****THE FOLLOWING TFD NEEDS A NUMBER AFTER',;
                  ' THE @ PRIMITIVE COMMA'
NF2      TEXTC    '*****FOREMENTIONED TFD COULD NOT BE FOUND'
FTHD     TEXTC    C'            TRANSACTION-REPORT    TEXT'
MDHD     TEXTC    C'                        STATION IMAGE'
ZW1      TEXTC    C'*****TFD POINTED TO IN Z PRIMITIVE DOES NOT EXIST'
BDR1     TEXTC    C'*****FOLLOWING PRIMITIVE(S) UNDEFINED'
ER44     TEXTC    C'*****TFD NAME MUST BE ON SAME LINE AS DIRECTIVE'
ER55     TEXTC    C'*****ONE BLANK SEPARATES DIRECTIVE AND TFD'
ER56     TEXTC    C'*****UNEXPECTED END OF FILE REACHED ON INPUT'
DEOK     TEXTC    C'DELETED'
BDR2     RES      10
ZKEY     GEN,8,24 TFDSZ,0           KEY FOR Z PRIMITIVES
         RES      4
OLDKEY   RES      5                 FOR KEEPING OLD WHEN DOING Z LOOP
         BOUND    4
EPR      RES,1    LNLEN+1           LINE RESERVATION AREA
         BOUND    4
         GEN,32   X'535C5C5C'       THIS CONTROLS ERROR CARD PRINTING
GETB1    RES,150  1                 CARD READ IN AREA
         BOUND  4
KEY  RES  5   THE KEY RECORD
         BOUND 4             SET WORD BOUNDRIES
OPERN  RES    1        OPERATION  TYPE
CDBUF    RES,BSIZ  1                1980 BYTES RESERVED
ZBUF     RES,BSIZ  1                Z PRIMITIVE BUFFER
         BOUND    4
         PAGE
*P*      NAME:    TFDUTL
*P*      PURPOSE: THE TFDUTL IS A TRANSACTION PROCESSING UTILITY
*P*               PROCESSOR USED TO CREATE AND MAINTAIN THE TFD FILE
*P*               THIS FILE IS USED BY THE TP T-I-C TO FORMAT AND
*P*               EDIT TERMINAL DEVICES.
*P*
*P*               THE UTILITY VALDITY CHECKS ALL TFD INPUT AGAINST
*P*               ANY ERRORS.
*P*               ANY ERRORS FOUND ARE DISPLAYED BY THE UTILITY.
*P*
*P*               A PICTURE OF THE TFD CAN BE DISPLAYED TO GIVE
*P*               THE SYSTEM DESIGNOR SOME IDEA AS TO THE APPEARENCE
*P*               OF THE TFD AT THE TP USERS TERMINAL DEVICE.
*P*      REFERENCE: TRANSACTION PROCESSING REFERENCE MANUAL
*P*               90-31-12
*D*      NAME:    TFDUTL
*D*      ENTRY:   TFDUTL
*D*      CALL:    THE TFDUTL PROGRAM IS A FREE STANDING SLAVE PROGRAM
*D*               USABLE EITHER ON-LINE OR IN THE BATCH MODE.
*D*      INTERFACE: NO SPECIAL ROUTINES ARE USED ONLY STD I/O CALLS
*D*      ENVIRONMENT: UNMAPPED, SLAVE, PRIVILEGE 40
*D*      DATA:    THE TFDFILE IS KEYED (17 CHARACTER KEY)
*D*               FIRST 13 CHARACTER ARE THE TRANSACTION/REPORT NAME
*D*               NEXT 2 CHARACTERS ARE THE STATION TYPE
*d*               NEXT 2 CHARACTERS ARE THE TFD NUMBER
*D*               THE TFDFILE DATA CONSISTS OF THE VARIOUS PRIMITIVES
*D*               AS DESCRIBED IN THE TP REFERENCE MANUAL 90-31-12.
*D*               DCB NAME IS F:TFDX AND OPENED IN-OUT
*D*      INPUT:  FILE M:SI IS USED TO READ ALL INPUT DIRECTIVES
*D*               AND DATA.
*D*      OUTPUT: FILE M:LO IS USED FOR ALL OUTPUT LISTINGS AND
*D*               ERROR MESSAGES.
TFDUTL   EQU      %
         M:OPEN   F:TFDX,(KEYM,TFDSZ),(KEYED),(INOUT)
         M:PC     '<'
DRIVER   EQU      %                 DRIVER ROUTING
         LI,R1    CARD              INITILIZE THINGS
         STW,R1   ADSW1
         BAL,R1   CARD              PRIME CARD INPUT BUFFER
I1       EQU      %                 TEST THE DIFFERENT TYPE OF OPERATION
         M:CHECK  M:LO              WAIT FOR EVERYTHING TO STOP
         M:SETDCB F:TFDX,(ERR,OM),(ABN,OM)
         LI,R4    TFDSZ             SET KEY SIZE
         SLS,R4   24
         STW,R4   KEY
         MOVE     BA(CDBUF),BA(KEY)+1,=X'11000000'
         LI,R1    0                 AND GO TO DO ONE TYPE
         LW,R2    OPERN             CONTAINS TYPE OF OPERATION JUST READ
         AND,R2   =X'00FFFFFF'      CLEAN UP IN CASE
         CW,R2    ALLOW,R1          CHECK AGAINST ALLOWABLE
         BE       I1A               GOT ONE
         AI,R1    1                 SPIN THRU LOOP
         CI,R1    MAX               TEST FOR MAX
         BE       ER1               BAD TYPE OF OPERATION
         B        %-5               KEEP GOING
I1B      RES      1                 SAVE R1 HERE
I1A      STW,R1   I1B
         LI,R3    8                 PRINT CONFIRMATION MSG
         LI,R2    ALLM              MESSAGE AREA
         SLS,R1   1                 MULTIPLY BY TWO
         AW,R2    R1
         SLS,R2   2                 BYTE ADDRESS
         BAL,R1   PRINT             PRINT THE MESSAGE
         LW,R1    I1B
         B        I11,R1            NOW DO THE OPERATION
I11      B        AD                OPERATION VECTORS
         B        RE
         B        DE
         B        LI
         B        PI                PICTURE AND LIST OF A TFD
         B        DI                PICTURE AND LIST OF ATTACHED TFD
         B        LA                LIST ENTIRE TFD FILE
         B        PAUIO             PERMIT USER TO TYPE END
I12      EQU      %                 END OF CHECKING
ALLOW    GEN,32,32,32,32 C'ADD',C'REP',C'DEL',C'LIS'
         GEN,32,32,32,32 C'PIC',C'DIS',C'LAL',C'END'
ALLM TEXT 'ADD TFD REPLACE DELETE  LIST TFDPICTURE '
 TEXT 'DISPLAY LIST ALL'
         TEXT     'END     '
         PAGE
AD       EQU      %                 ADD THE CARD TO THE STREAM
         LI,R2    BA(CDBUF)+TFDSZ+1 FAKE A PICTURE
         LW,R3    PTWS              TO CHECK PRIMITIVES
         LI,R10   0
         BAL,R1   P2C1              DONT PRINT A PICTURE
         CI,R10   X'77'             CHECK FOR ERROR FLAG
         BNE      OKAD              OK TO ADD IT
         LI,R1    AD4               PRINT OUT ALL WE DID
         STW,R1   PLCMM             SET UP LINKAGE
         B        PLEFT
OKAD     EQU      %                 WRITE THE RECORD
         M:SETDCB F:TFDX,(ERR,OM),(ABN,OM)
         M:WRITE  F:TFDX,(BUF,CDBUF),(SIZE,*PTWS),(KEY,KEY),(NEWKEY),;
                  (WAIT),(ERR,OM),(ABN,OM)
AD4      BAL,R1   *ADSW1            REPRIME CARD BUFFER
         B        I1                RELOOP THRU ACTION TESTS
RE       EQU      %                 REPLACE THIS TFD
         M:WRITE  F:TFDX,(BUF,CDBUF),(SIZE,*PTWS),(KEY,KEY),(WAIT),;
                  (ERR,OM),(ABN,OM)
         B        AD4
DE       EQU      %                 DELETE THIS TFD
         M:SETDCB F:TFDX,(ABN,OM),(ERR,OM)
         M:DELREC F:TFDX,(KEY,KEY)
         M:DELREC F:TFDX            IN CASE HE WANTS TO DE ALL
         LI,R12   DEOK              TELL HIM ITS DONE
         BAL,R2   PRNT
         LW,R1    =C'    '
         STW,R1   KEY+4             IN CASE HE WANTS TO DEL ALL
         B        AD4
         PAGE
LI       EQU      %                 LIST THIS TFD (S)
         LI,R2    AD4
LIPI     LI,R1    1                 SAVE A SWITCH
         STH,R2   LPSW,R1           SET TO NOT DO FORMAL TRANS
         M:READ   F:TFDX,(KEY,KEY),(BUF,CDBUF),(WAIT),;
         (SIZE,BSIZ),(ERR,OM),(ABN,OM)
         LW,R3    F:TFDX+4
         SLS,R3   -17
         LI,R2    BA(CDBUF)
         BAL,R1   PRINT
LPSW     BAL,R1   PLCM              DISPLAY OF SCREEN
         B        AD4
PI       EQU      %                 PICTURE AND LIST
         LI,R2    PLCM              DO A PICTURE ALSO
         B        LIPI
DI       EQU      %                 PICTURE AND LIST OF ATTACHED
         LI,R1    AD4               GO TO DRIVER WHEN CMPLT
         LW,R3    PTWS              GET SIZE
PLCM     STW,R1   PLCMM
         LI,R2    BA(CDBUF)+TFDSZ+1 LOCATION OF TEXT
         BAL,R1   P2C1              DO PICTURE
PLEFT    EQU      %                 JUST PRINT OUT ACCUMULATED TEXT
         LI,R12   BLANKS            INSERT A BLANK LINE
         BAL,R2   PRNT
         LI,R12   MDHD
         BAL,R2   PRNT
         LI,R12   BLANKS
         BAL,R2   PRNT
         LW,R1    =C'****'          PRINT TOP BANNER
         STW,R1   PFM1
         MOVE     BA(PFM1),BA(PFM1+1),=X'83000000'
         LI,R2    BA(PFM1)
         LI,R3    LNLEN
         BAL,R1   PRINT
         LW,R3     SVLEN               THIS GETS AN EVEN LINE MULTIPLE
         AI,R3     -LNLEN              SO WE GET THE WHOLE LAST LINE
         BGZ       %-1
         MI,R3     -1                  MAKE IT ADDABLE
         AW,R3     SVLEN
         LI,R2    BA(PICBF)         ADDRESS OF THE BUFFER
         BAL,R1   PRINT             GO WRITE IT OUT
         LW,R1    =C'****'          PRINT BOTTOM BANNER
         STW,R1   PFM1
         MOVE     BA(PFM1),BA(PFM1+1),=X'83000000'
         LI,R2    BA(PFM1)
         LI,R3    LNLEN
         BAL,R1   PRINT
         B        *PLCMM            RETURN TO CORRECT RTN
PLCMM    RES      1
         PAGE
LA       EQU      %                 LIST THE ENTIRE TFD FILE
         M:PFIL   F:TFDX,(BOF)
LALOP    EQU      %
         LI,R12   BLANKS            INSERT A BLANK LINE
         BAL,R2   PRNT
         M:READ   F:TFDX,(BUF,CDBUF),(WAIT),(SIZE,BSIZ),;
                  (ERR,OM),(ABN,OM)
         LW,R3    F:TFDX+4          GET JUST READ SIZE
         SLS,R3   -17
         LI,R2    BA(CDBUF)         LOCATION OF BUFFER
         BAL,R1   PRINT             PRINT THE IMAGE
         B        LALOP
CARD     STW,R1   CRET              SAVE THE LINKAGE
TFDCD    EQU      %
         BAL,R2   GETCD            GET A NEW CARD
         LI,R3    0                 ZERO OUT CHAR COUNT FOR PTCH
         STW,R3   OLDKEY            INITILIZE OLD KEY
         STW,R3   PTWS              INITILIZE THE COUNTER
         STW,R3   XCNT              INITILIZE FMLT TRNS COUNTER
         BAL,R1   GETCH             GET ME A CHARACTER
         LW,R14   R15               WE WANT TO CHECK THE OP CODE
         SLS,R14  8                 ALIGN THINGS
         BAL,R1   GETCH             CARD COLUMN TWO
         OR,R14   R15               PUT TWO TOGETHER
         SLS,R14  8                 GET THIRD CHARACTER
         BAL,R1   GETCH
         OR,R14   R15
         LI,R1    0
         CW,R14   ALLOW,R1          CHECK FOR ALLOWABLES
         BE       CDOK              GOT A GOOD ONE
         CI,R1    MAX               CHECK FOR MAX COUNT OF GGOOD ONES
         BE       CEE1
         AI,R1    1                 ZIP THRU TABLE
         B        %-5
CEE1     CW,R14   =C' TF'           CHECK FOR A TFD CARD
         BE       TFDCD             IGNOR A TFD CARD
         B        ER1
CDOK     EQU      %                 NOW WE HAVE A GOOD OPERATION CODE
         MTW,1    BAD%END%FLG       TP-0547
         STW,R14  OPERN             TYPE OF OPERATION
         SLS,R14  -8                JUST WORK WITH TWO CHAR
         CI,R14   C'LA'             CHECK FOR LIST ENTIRE FILE
         BE       CD13
         CI,R14   'EN'              CHECK FOR END CARD
         BE       CD13
         LW,R2    BLANKS+1          BLANK OUT TFD NAME FIELD
         STW,R2   CDBUF             SEED BLANKS
         LI,R2    BA(CDBUF)         DO MOVE OF SEED BLANK
         LI,R3    BA(CDBUF)+1
         OR,R3    =X'50000000'
         MBS,R2   0
         BAL,R1   GETCH             KEEP SCANNING TILL WE GET
         CI,R15   C' '              A BLANK
         BNE      %-2               HE MUST HAVE THE DIRECTIVE
         LI,R14   TFDSZ
         LW,R6    GETCC             GET CURRENT CHAR POSITION
         CW,R6    CDSZ              CHECK IF ANYTHING LEFT
         BE       ER4               NO TFD NAME TYPED ON LIINE
         LB,R15   GETB1,R6          CHECK FIRST CHARACTER
         CI,R15   C' '              FOR BLANK
         BE       ER5               ONLY ONE SPACE ALLOWED
         B        CDXX+1
CDOK1    CW,R6    CDSZ              SEE WHATS LEFT
         BG       CD9               NOTHING
CDXX     LB,R15   GETB1,R6          GET A BYTE
         AI,R6    1                 INCREMENT THRU CARD
         CI,R15   C','              CHECK FOR A COMMA
         BNE      NM                NOPE SO NO EXPANSION YET
         LI,R15   13                BLANK FILL TFD NAME
         STW,R15  PTWS
         LI,R14   TFDSZ-13          ONLY FOUR LEFT
         B        CDXX              NOW GET NEXT CHARACTER
NM       EQU      %
         CI,R15   X'40'
         BG       %+2
         LI,R15   X'40'
         PTCH
         AI,R14   -1
         CI,R14   0                 ARE WE  THRU WITH TFD
         BNE      CDOK1             YES THRU
CD9      EQU      %
         LI,R3    17                START HERE FOR TFD STRING
         STW,R3   PTWS
         STW,R6   GETCC
         LW,R1    OPERN
         SLS,R1   -8                JUST USE TWO BYTE
         CI,R1    C'DE'
         BE       CD13              THAT IS ALL WE NEED TO KNOW FOR DE
         CI,R1    C'LI'
         BE       CD13              THAT IS ALL WE NEED TO KNOW FOR LI
         CI,R1    C'PI'             PICTURE A TFD
         BE       CD13
         LI,R15   C' '              INSERT COLUMN 19
         PTCH
CNXT     EQU      %                 LOOP AREA FOR READING
         BAL,R1   GETCH             NOW GO ON FOR THE AD,RE
         CI,R15   X'40'             GET RID OF A BLANKS
         BE       %-2
         CI,R15   C'Z'
         BNE      CD4               DO SQUEEZE TRICK
         PTCH
         LW,R6    GETCC             CHECK IF ANYTHING LEFT
         CW,R6    CDSZ
         BGE      CD15              ERROR IF NOTHING AFTER Z
         BAL,R1   GETCH             GET NEXT CHAR
         CI,R15   X'7D'             CHECK FOR APOS
         BNE      CD12              NONE THEN CHECK NEXT TWO
         PTCH     SAVE THE QUOTE
         LI,R14   0                 NOW DO QUOTE CONTENTT
CD11     BAL,R1   GETCH             GET QUOTE BODY
         CI,R15   C','              CHECK FOR COMMA EXPANDER
         BE       CDCM              DO COMMA EXPANSION
         CI,R15   X'7D'             ANOTHER QUOTE IS BAD
         BE       CD15              ERROR
         PTCH                       SAVE THE CHARACTER
         AI,R14   1
         CI,R14   TFDSZ             SEE IF WE ARE DONE
         BL       CD11              NOPE
         B        CDEN              ALL DONE CHECK FOR QUOTE
CDCM     AI,R14   -(TFDSZ-4)        SEE HOW MANY BLANKS TO
         BGEZ     CD15              INSERT-ALSO ERROR CHECK
         LI,R15   C' '              SEED BLANK
CDCMB    PTCH                       PUT THE BLANK AWAY
         AI,R14   1                 DO APPROIATE AMOUNT
         BLZ      CDCMB
         LI,R14   13                JUST ALLOW FOUR CHARACTERS
         B        CD11
CDEN     BAL,R1   GETCH             NOW CHECK FOR A QUOTE
         CI,R15   X'7D'
         BNE      CD15              ERROR IS NONE
CD10     PTCH
         B        CD13              AFTER PUTTING APOS AWAY FINISHED
CD12     EQU      %                 Z DIGET PROCESSING
         CI,R15   X'F0'             CHECK FOR NUMBER
         BL       CD15              ERROR IF NOT
         CI,R15   X'F9'
         BG       CD15
         LW,R13   R15               SEE IF WE  WANT A ZERO PREFIS
         LW,R6    GETCC
         CW,R6    CDSZ              SEE IF ANYTHING LEFT
         BGE      CDINZ             INSERT A ZERO IF NOTHING LEFT
         BAL,R1   GETCH             GET ANOTHER CHARACTER
         CI,R15   X'40'             CHECK FOR SPCL CHARS
         BLE      CDINZ             IF SO ITS OK
         CI,R15   X'F0'             CHECK FOR NUMBER
         BL       CD15
         CI,R15   X'F9'
         BG       CD15
         XW,R15   R13               OTHERWISE STORE THE TWO
         PTCH
CD12A    EQU      %
         LW,R15   R13
         PTCH
CD13     EQU      %                 WRITE CARD IMAGE OUT
         LI,R2    BA(CDBUF)         LOCATE THE CARD BUFFER
         LW,R3    PTWS              SIZE OF DATA STRING
         BAL,R1   PRINT             GO PRINT IT
         MTW,-1   BAD%END%FLG       UNSET QUOTE PROCESSING FLAG
         B        *CRET             RETURN TO CALLER
CDINZ    EQU      %                 INSERT A ZERO IF ONLY ONE
         LI,R15   C'0'              DIGET SPECIFIED
         PTCH
         B        CD12A
CD15     LI,R1    ER3               PRINT CARD IMAGE AND
         STW,R1   CRET              ERROR Z STRING MESSAGE
         B        CD13
CD4      EQU      %
         CI,R15   X'7D'             CHECK FOR QUOTES
         BNE      CD8
CD7      PTCH
         BAL,R1   GETCH
         CI,R15   X'7D'             CHECK FOR QUOTES
         BNE      CD7               PUT IT AWAY
CD8       EQU      %                 ALMOST READY TO PUT IT AWAY
          CI,R15   X'4B'             CHECK FOR AN ENDING PERIOD
         BE       CD14      IF PERIOD INSERT A Z0
          PTCH
         B        CNXT
CD14    LI,R15    C'Z'         END THE TFD
         PTCH
         LI,R15  C'0'
         PTCH                       WANT TWO CHARACTERS
         B    CD10
         PAGE
GETCH    EQU      %                 CHARACTER READ ROUTINE
*                                   CONVENTIONS ARE AS FOLLOWS
*                                   1.  XR1 USED FOR LINDAGE
*                                   2.  XR7 USED FOR EOF RETURN
*                                   3.  FETCHED CHARACTER IS IN XR15
         LW,R6    GETCC
         CW,R6    CDSZ
         BL       GETOK              STILL HAVE MORE GOOD ONES
         BAL,R2   GETCD             READ ANOTHER RECORD
GETOK    LB,R15   GETB1,R6          PICK UP A CHARACTER
         AI,R6    1                 JUST READ ONE
         STW,R6   GETCC
         CI,R15   X'40'             CHECK FOR BAD CHARACTERS
         BG       %+2               ALL OK
         LI,R15   X'40'             MAKE THEM BLANKS
          CI,R15   X'5E'             CHECK FOR A SEMI COLON
          BNE      *R1              NOPE RETURN TO CALLER
          B        GETOK-1           READ ANOTHER CARD
GETCD    EQU      %                 CARD READ ROUTINE
*                                   CONVENTIONS
*                                   1.  XR2 USED FOR LINKAGE
*                                   2.  READ IN BUFFER IS GETB1
         LW,R6    BLANKS+1          BLANK OUT CARD BUFFER
         STW,R6   GETB1
         LI,R6    BA(GETB1)
         LI,R7    BA(GETB1)+1
         OR,R7    =X'47000000'
         MBS,R6   0
         M:READ   M:SI,(BUF,GETB1),(SIZE,150),(WAIT),(ABN,CEOF)
         LI,R6    0
         STW,R6   GETCC             4.  XR6 CONTAINS CHAR
         LW,R15   M:SI+4            GET JUST READ SIZE
         SLS,R15  -17               IN CASE OF TRUNCATION
         CI,R15   71                NO TRUNCATION IE SEQUENCED
         BL       %+2
         LI,R15   71                SET TO IGNOR SEQUENCE
         STW,R15  CDSZ              SAVE THE SIZE
         B        *R2               RETURN TO CALLER
         PAGE
PRNT1    RES      1                 SAVE XR1 HERE
PRNT     EQU      %                 TITLE AND LINE PRINTER
         STW,R1   PRNT1
         LW,R1    R2                RETURN LINKAGE
         LW,R2    *R12              GET 'POINTED TO' BYTE COUNT
         AND,R2   =X'FF000000'      JUST WANT COUNT
         LI,R3    BA(EPR)           LOCATION OF PRINT OUT AREA
         OR,R3    R2                SET UP TO MOVE LINE
         LW,R2    R12               LOCATION OF IMAGE
         SLS,R2   2                 BYTE LOCATION
         AI,R2    1                 DON'T WANT COUNT
         MBS,R2   0
         LW,R3    *R12              SET FOR PRINT RTN
         SLS,R3   -24               COUNT AGAIN
         LI,R2    BA(EPR)           POINT TO LOCATION
PRINT    EQU      %                 GENERAL PRINT ROUTINE
         STW,R1   P1                LINKAGE
         SLS,R2   -2                WANT THE WORD ADRESS
         STW,R2   P2                BYTE LOCATION
         STW,R3   P3                SIZE
         LW,R1    P3                GET CHARACTER SIZE
         BEZ      PDONE             RETURN TO CALLER IF ZERO
         CI,R1    LNLEN             LINE LENGTH
         BG       P4
         STW,R1   PSIZ+1            SIZE
         M:WRITE  M:LO,(BUF,*P2),(SIZE,*PSIZ+1),(WAIT)
         B        PDONE             GO TO COMMON EXIT
P4       LW,R2    P2                GET LOCATION
CW1      STW,R2   PBA
         SW,R1    PCON              SUBTRACT A LINE
         BCS,1    CWLS              LAST LINE
         M:WRITE  M:LO,(BUF,*PBA),(SIZE,*PCON),(WAIT)
         AI,R2    LNLEN/4           ADD WORDS
        B        CW1               RE-LOOP
CWLS     AI,R1    LNLEN             LAST PARTIAL LINE
         STW,R1   PSIZ+1
         M:WRITE  M:LO,(BUF,*PBA),(SIZE,*PSIZ+1),(WAIT)
PDONE    EQU      %                 COMMON EXIT
         LW,R1    PRNT1             RESTORE XR 1
         B        *P1               RETURN TO CALLER
PF11     RES      1                 RETURN LINKAGE
PFMLT     EQU     %                  FORMAL TRANSACTION PRINTER
         STW,R1   PF11               SAVE RETURN LINKAGE
         LI,R12   BLANKS
         BAL,R2   PRNT
         LI,R12   FTHD
         BAL,R2   PRNT
         LI,R12   BLANKS
         BAL,R2   PRNT
         LI,R1    BA(FMLT)          LOC OF FORMAL TRANS
          STW,R1  FMLPOS            INITIAL LOCATION
          LI,R1    0
         STW,R1   PF1                INITLIZE TENS COUNTER
TENS     EQU      %                  PRINT OUT THE TENS LINE
         LW,R1    PICBF-1           BLANK OUT LINE BUFFER
          STW,R1   PFM1              INSERT THE SEED BLANKS
         MOVE    BA(PFM1),BA(PFM1+1),=X'83000000'
         LI,R4    6                  START IN CC6
PL2      LW,R2    PF1               GET TENS
          AI,R2   1
          STW,R2   PF1               INCREMENT BY 10
          CI,R2    TFDTEXT           CHECK LIMITS
         BG       PICE6              TOO LARGE
         BAL,R1   CNVRT             CONVERT TO PRINTABLE
         LI,R5    X'F0'              SET UP TO CHECK FOR ZEROES
          STW,R5   PFTST
         LI,R5    0                 SET UP TO BLANK SUPPRESS ZEROES
PFX      LB,R6    R1,R5
         STB,R6   PFM1,R4           THIS NOPS THE ZERO TEST
         CW,R6    PFTST
         BE       %+3             REPLACE ZERO WITH A BLANK
         STW,R5   PFTST           NEGATES THE ZERO TEST ALL CHAR ARE INSERTED
         B        %+3
         LI,R6    X'40'           PUT A BLANK ON TOP OF LEADING ZEROES
         STB,R6   PFM1,R4
         AI,R4    1           SET FOR NEXT POSITION
          AI,R5   1                  NEXT CHARACTER
         CI,R5    4                  ONLY DO FOUR OF THEM
         BGE      %+2                THIS NUMBER FINISHED
         B        PFX               MORE OF THIS NUMBER
          AI,R4   6                  NEXT NUMBER
         CI,R4    LNLEN-3            SEE IF WE ARE THRU WITH LINE
         BL       PL2
         LI,R2    BA(PFM1)          PRINT OUT THE TENS LINE
          LI,R3   LNLEN-2           CHAR DOUNT
         BAL,R1   PRINT
         LI,R1    0                  NOW DO THE UNITS LINE
         LI,R2    X'F0'
UNIT1    AI,R2    1                  START AT ONE
         CI,R2    X'FA'              TEN MEANS RESTART TO ZERO
          BL      %+2                LESS THAN ZERO
         LI,R2    X'F0'              RESTART AT ZERO
         STB,R2   PFM1,R1
         AI,R1    1
         CI,R1    LNLEN-2           SEE IF THE LINE IF FULL
          BL       UNIT1             NOPE SO FILL IT UP
          LI,R2    BA(PFM1)
         LI,R3    LNLEN-2            NOW PRINT OUT THE UNITS LINE
         BAL,R1   PRINT
          LW,R3   SVLEN1            SEE WHERE WE ARE IN IMAGE
         AI,R3    -(LNLEN-2)        DECREMENT BY ONE LINE
         STW,R3   SVLEN1
         BGZ      %+3               WHOLE LINE TO DO
         AI,R3    LNLEN-2          JUST DO THE RESIDUE
         B        %+2
         LI,R3    LNLEN-2           DO ONE LINE
         LI,R5    BA(EPR)           MOVE IMAGE TO PRINT
         SLS,R3   24                AREA
         OR,R5    R3
         SLS,R3   -24               REALIGN THINGS
         LW,R4    FMLPOS            LOCATION OF FORMAL TRANS
         MBS,R4   0
         LI,R2    BA(EPR)
          BAL,R1  PRINT              PRINT OUT THE TRANS
         LW,R1    SVLEN1
         BLEZ     PFDONE             ALL DONE SO RETURN TO CALLER
         LW,R2    FMLPOS
          AI,R2   LNLEN-2           INCREMENT OUR CURRENT POSITION
         STW,R2   FMLPOS
         B        TENS               DO IT AGAIN
CNVRT    EQU      %                 ROUTINE CONVERTS XR2 TO PRINTABLE
         STW,R1   R5                 SAVE LINKAGE
         CVS,2    TABLE
         SLS,R2   24                 ALIGN FOR TRANSLATION INSERTION
         SCD,R2   -4
         SLS,R2   -4
         SCD,R2   -4
         SLS,R2   -4
         SCD,R2   -4
         SLS,R2   -4
         OR,R2    =X'F0F0F0F0'       MAKE IT PRINTABLE
         LW,R1    R2                 PUT CONVERTED NUMBER IN X1
         B        *R5                RETURN TO CALLER
PFDONE   EQU      %                 RETURN TO CALLER AFTER CLEAN
         LW,R1    BLANKS+1          UP OF BUFFERS
         STW,R1   FMLT
         LI,R1    (EBF2-FMLT)*4/255
         LI,R2    BA(FMLT)          BLANK OUT FMLT
         LI,R3    BA(FMLT)+1
PFCLN    OR,R3    =X'FF000000'
         MBS,R2   0
         AI,R1    -1
         BNEZ     PFCLN             DO WHOLE BUFFER
         LI,R1    1                 INITILIZE COUNTERS
         STW,R1   FMPOS
         STW,R1   SVLEN1
         B        *PF11             NOW WE CAN RETURN TO CALLER
         BOUND     4
TABLE    DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA      X'FFFFFFFF'
         DATA     80000
         DATA     40000
         DATA      20000
         DATA     10000
         DATA     8000
         DATA     4000
         DATA     2000
         DATA     1000
         DATA      800
         DATA      400
        DATA      200
         DATA      100
         DATA      80
         DATA      40
         DATA      20
        DATA      10
         PAGE
P2C1     EQU      %                 ROUTING TO PICTURE A TFD
         STW,R1   P11               SAVE LINKAGE
         LI,R1    0                 INITILIZE BAD PRIMITIVE
         STW,R1   BDR2              SWITCH
         LW,R1    R2                BUFFER LOCATION
         STW,R1   ZSVTX             SAVE THE LOCATION OF THE STRING
         AND,R1   =X'00000003'      BYTE LOCATION
         STW,R1   PICA2
         SLS,R2   -2                WORD LOCATION
         STW,R2   P22
         STW,R3   P33               SIZE
         LI,R1    1                 INITILIZE ROW AND COLUMN
         STW,R1   ROW
         STW,R1   COL
         STW,R1   FMPOS         INITILIZE FORMAL TRANSACTION
         STW,R1   SVLEN1            INIT MAX SIZE COUNTER
         LI,R1    0
         STW,R1   SVLEN             INITILIZE MAX SIZE COUNTERS
         STW,R1   NCH6              INITILIZE CHAR SUPPLIER
         LI,R1    (EBF2-PICBF)*4/255
          LI,R2    BA(PICBF)-1       SET UP FROM ADDRESS
          LI,R3    BA(PICBF)         MOVE TO
P2C2      OR,R3    =X'FF000000'
          MBS,R2   0                 MOVE IT
          AI,R1    -1              NEXT BLOCK
          BNEZ     P2C2              LOOP THRU BLOCKS
         LI,R2    0                 BUILD AND PRINT A BANNER
         LI,R1    C'*'              LERT AND FT BORDER CAN USE *
         STB,R1   PICBF,R2
         AI,R2    LNLEN             INITILIZE LEFT BORDER
         CI,R2   (EBF1-PICBF)*4
         BL       %-3
*        LI,R2    LNLEN-1           NOW DO RIGHT BORDER
*        STB,R1   PICBF,R2
*        AI,R2    LNLEN
*        CI,R2   (EBF1-PICBF)*4
*        BL       %-3
APPO     EQU      %
         LI,R3    PICE1             ERROR LOCATION IF FIRST IS BAD
         BAL,R1   PICA              GO TO READ THE FIRST CHAR
APP      EQU      %                 ASSUME XR 2 IS SET
         CI,R2    (EPTBL-PICTBL-1)*4
         BG       PICE1
         LI,R1    PICTBL            GET TABEL ADDRESS
         AW,R1    R2                X2 HAS THE NTH ENTRY
         LI,R2    1                 SET UP FOR TWO LEVELS OF INDIRECTION
         STH,R1   %+1,2
         B        *,0
A        EQU      %                 ALPHA I.E. A TO Z
B         EQU      %
C        EQU      %
D        EQU      %
E        EQU      %
F        EQU      %
G        EQU      %
I        EQU      %
J        EQU      %
L        EQU      %
M        EQU      %
         LI,R3    PICE1             ERROR RETURN
DOCNVRT  BAL,R1   BYBIN             CONVERT TO BIN 3270 ADDITION
         CI,R9    0                 SEE IF A NUMBER FILLOWED 3270
         BE       NOWDONE           IF SO NORMAL CONTINUE 3270
         B        DOCNVRT-1         SKIP OVER EVERYTING TILL A NUMBER 3270
NOWDONE  EQU      %
*C*      VERSION C01: ALLOWS TFDS TO BE WRITTEN FOR 3270 TYPE DEVICES
         BAL,R5   NCH               GET THE NEXT CHARACTER
*                                   XR13 WILL  HAVE IT UPON RETURN
         LW,R6    FMPOS              SET TO ADD TO FORMAL TRANS
          BAL,R7   PICPUT
         B        APP
H        EQU      %                 THESE PRIMITIVES NOTYET
N        EQU      %                 DEFINED SO IGNOR THEM
O        EQU      %                 AND NOTIFY USER
Q        EQU      %
R        EQU      %
S        EQU      %
T        EQU      %
U        EQU      %
V        EQU      %
W        EQU      %
         LW,R1    BDR2              GET SWITCH
         STB,R15  BDR2+1,R1         SAVE THE BAD PRIMITIVE
         AI,R1    1                 INCREMENT TO NEXT POSITION
         STW,R1   BDR2              SAVE SWITCH
         LI,R3    BADCHK            ALLOW A QUOTE STRING AFTER UNKNOWN
         BAL,R1   BYBIN
         B        APP
BADCHK EQU %      RMC
         CI,R15   X'7D'             CHECK FOR A QUOTE STRING
         BNE      APP               NO QUOTE SO CONTINUE
         B        PROM3             DO JUST LIKE A P QUOTE SEQUENCE
         PAGE
P        EQU      %                 PROMPT PRIMITIVE
         LI,R3    PROM1             RETURN TO ME FOR ERRORS
         BAL,R1   BYBIN             GO CONVERT TO BINARY
         CI,R9    0                 3270 SEE IF A NUMBER FOLLOWS
         BE       OKDOPRIM
         B        P                 3270
OKDOPRIM EQU      %
         CW,R1    =0                CHECK IF HE WANTS TRN ID
         BNE      PP                NOPE
         LI,R1    8                 JUST INSERT 8 ZEROES
         LI,R13   C'0'
         B        %+2
PP       LI,R13   C' '              INSERT SPACES
         LI,R6    0                 TURN OFF FORMAL TRANS
        BAL,R7   PICPUT            INSERT SOME BLANKS
         B        APP               DO NEXT
PROM1    EQU      %
         AI,4     -2                IF THE LAST CHARACTER
         LB,4     *P22,4            IN THE TFD WAS A NUMERIC
         CI,4     C'0'
         BL       %+4
         CI,4     C'9'
         BG       %+2
         B        PICE1             THEN WE SHOULDN'T BE HERE
         CI,15    X'7D'             ELSE, WE CAN LOOK FOR A QUOTE
         BNE      PICE1             SOME SORT OF ERROR
PROM3    LW,R4    PICA2
         LB,R15   *P22,R4            GET A CHAR
         AI,R4    1                 GET THE NEXT CHARACTER
         CI,R4    TFDTEXT           CHECK SIZE
         BG       PICE1             TOO BIG
         STW,R4   PICA2             SAVE COUNTER
         CI,R15   X'7D'             CHECK FOR CLOSING APOS
         BNE      PROM2
         B        APPO              GET NEXT CHARACTER
PROM2    LW,R13   R15               SET UP TO OUTPUT ONE CHAR
         LI,R1    1                 JUST DO ONE
         LI,R6    0                 TURN OFF FORMAL TRANS
         BAL,R7   PICPUT
         B        PROM3             DO NEXT
         PAGE
AT       EQU      %                 MOVE ROW COLUMN POINTER
         LI,R6    0                 SET UP FOR PLUS FLAG
AT7      LI,R3    AT10              GO HERE IF NOT NUMBER
         BAL,R1   BYBIN             CONVERT OT NUMBER
         BEZ %+3         DO NOTHING IF NO NUMBER
         EXU      ATS1,R6           DO INCREMENT TRICK
         STW,R1   ROW               SAVE IT
         CI,R2     (EPTBL-PICTBL-1)*4     CHECK IF A PRIMITIVE ENCOUNTERED
        BLE       AT13                GO TO APPROIATE ROUTINE
         LI,R6    0                 NOW WORK ON COLUMN
AT1      CI,R15   C','              CHECK FOR COMMA
         BNE      PICE1             NO COMMA SO ERROR
AT12     LI,R3    AT11              GO TO CHECK FOR A PLUS
         BAL,R1   BYBIN             CONVERT TO NUMBER
AT12A    BEZ      PICE8             BRANCH IF NO # FOLLOWS COMMA
         AND,R1   =X'FFFFFF'        REMOVE 1ST BYTE
         EXU      ATS2,R6           DO INCREMENT TRICK
         STW,R1   COL               SAVE IT
         B        AT13              NOW DO NEXT PRIMITIVE
ATS1     NOP                        PLUS SWITCH
         AW,R1    ROW               ADDER
AT10    EQU       %                   CHECK FOR PRIMITIVE HIT
         CI,R2     (EPTBL-PICTBL-1)*4     CHECK IF A PRIMITIVE ENCOUNTERED
        BLE       AT13                GO TO APPROIATE ROUTINE
         CI,R15   C'+'              CHECK FOR A PLUS
*                                     CHECK FOR A,5 SITUATION
         BNE      AT1               NO SO CHECK FOR A COMMA
         LI,R6    1                 SET PLUS SWITCH
         B        AT7               RELOOP
ATS2     NOP                        NO ADDER
         AW,R1    COL               ADD TO CURRENT
AT11    EQU       %                   CHECK FOR PRIMITIVE HIT
         CI,R2     (EPTBL-PICTBL-1)*4     CHECK IF A PRIMITIVE ENCOUNTERED
        BLE       AT13                GO TO APPROIATE ROUTINE
         CI,R15   C'+'              IS IT A PLUS
         BNE      PICE1             ERROR
         LI,R6    1                 SET ADD SWITCH
         B        AT12
AT13     EQU      %                 CHECK IF THE ROW COL IS TOO LARGE
         LW,R4    COL               GET COLUMN
         LW,R11   ROW
         AI,R11   -1
         MI,R11   LNLEN
         AW,R4    R11               TOTAL NUMBER OF BYTES AVAILIABLE
         CI,R4    (EBF1-PICBF)*4
         BG       PICE6             TOO LARGE A NUMBER OF BYTES
         B        APP               NOW GO TO APPROIATE RTN
         PAGE
LB       EQU      %                 FORMAL TRANSACTION POSITIONER
         LI,R3    LB01              RETURN TO HERE IF NOT A NUMBER
         BAL,R1   BYBIN             GO CONVERT IT
LB03     CI,R1    (EBF2-FMLT)*4     CHECK FOR TOO LARGE A SIZE
         BG       PICE6             ERROR CAUSE TOO LARGE
         CI,R1    0                 POSITION ZERO INVALID
         BE       PICE1
         STW,R1   FMPOS             SAVE UPDATED POSITION
LB02     CI,R2    (EPTBL-PICTBL-1)*4
         BLE      APP               GO TO NEXT PRIMITIVE
         B        PICE1             ERROR IN PRIMITIVE
LB01     CI,R15   C'+'              CHECK FOR A PLUS
         BNE      LB02              MAY BE HE HAS NO NUMBER THERE
         LI,R3    LB02              RETURN TO CHECK NEXT
         BAL,R1   BYBIN             GO CONVERT THE NEXT NUMBER
         AW,R1    FMPOS             ADD THE NEXT POSITION
         B        LB03              SAVE IT
         PAGE
Z        EQU      %                 THIS IS THE WINDUP TYPE
         LW,R4    PICA2             KEEP SCANNING TO SEE IF
         LB,R15   *P22,R4           THERE IS ANOTHER TFD
         CI,R15   X'7D'             CHECK FOR QUOTE
         BE       ZQ                YES THERE IS
         CI,R15   X'F0'             CHECK FOR A NUMBER
         BL       PICE1             NOT NUMERIC SO ERROR
         CI,R15   X'F9'             SEE IF GREATER THAN 9
         BG       PICE1             YES SO ERROR
         LW,R14   R15               BUILD TWO POSSIBLE
         SLS,R14  8
         AI,R4    1                 INCREMENT THRU STRING
         STW,R4   PICA2
         LB,R15   *P22,R4           GET NEXT BYTE
         AI,R4    TFDSZ             SEE IF WE ARE THRU
         CW,R4    P33
         BG       ZOK               YES THRU
         CI,R15   X'F0'             IF NOT NUMBER ITS OK
         BL       ZOK
         CI,R15   X'F9'
         BG       ZOK
         OR,R14   R15               MAKE TWO NUMERICS
         B        ZRD               NOW DO READ IF NOT SAME
ZOK      SLS,R14  -8                REALIGN THINGS
         OR,R14   =X'F000'          PRECEED IT WITH A ZERO
ZRD      CI,R14   X'F0F0'           IF ZERO ALL DONE
         BE       PCOM              RETURN TO CALLER
         LW,R2    ZSVTX             GET CURRENT KEY
         AI,R2    -TFDSZ-1
         LI,R3    BA(ZKEY)+1        MOVE IT TO ZKEY FOR NEXT READ
         OR,R3    =X'F000000'       SEQ NUMBER WILL BE ADDED
         MBS,R2   0
         SLS,R14  16                INSERT THE SEQ NUMBER
         STW,R14  ZKEY+4
         B        ZREAD             NOW GO READ THE RECORD
ZQ       EQU      %                 GOT A QUOTE
         AI,R4    1
         LW,R2    P22               LOCATION OF INPUT IMAGE
         SLS,R2   2                 WANT BYTE ADDRESS
         AW,R2    R4                GET THE Z QUOTE STRING
         LI,R3    BA(ZKEY)+1        MOVE TO KEY POSITION
         LI,R15   TFDSZ
         SLS,R15  24
         OR,R3    R15               TFD SIZE
         MBS,R2   0
ZREAD    EQU      %                 COMMON READ POINT
         LI,R3    BA(ZKEY)          SEE IF WE JUST DID THIS PRIMITIVE
         OR,R3    =X'11000000'      COMPARE THE 17 CHARACTERS
         LI,R2    BA(OLDKEY)        THIS IS THE OLD KEY
         CBS,R2   0                 DID WE JUST DO THIS KEY
         BE       PCOM              YES SO WE ARE DONE
         M:SETDCB F:TFDX,(ERR,ZWARN),(ABN,ZWARN)
         M:READ   F:TFDX,(KEY,ZKEY),(BUF,ZBUF),(WAIT),(SIZE,BSIZ),;
                  (ERR,OM),(ABN,OM)
         LI,R2    BA(ZKEY)          SAVE THE JUST READ KEY
         LI,R3    BA(OLDKEY)        MOVE IT TO THE OLD KEY AREA
         OR,R3    =X'11000000'      COMPARE ALL 17 CHARACTERS
         MBS,R2   0                 MOVE IT
         LI,R1    2
         STW,R1   PICA2             STARTING LOCATION
         LI,R1    ZBUF+4            BUFFER LOCATION
         STW,R1   P22
         LW,R1    F:TFDX+4          SIZE OF RECORD
         SLS,R1   -17
         AI,R1    TFDSZ
         STW,R1   P33
         B        APPO
ZWARN    LI,R12   ZW1               WARN HIM THAT Z PRIMITIVE
         BAL,R2   PRNT              POINTED TO DOES NOT EXIST
         B        PCOM              JUST RETURN
         PAGE
Y        EQU      %                 Y PRIMITIVE
         LI,R3    YAPOS             IF NOT A NUMBER TO TO YAPOS
         BAL,R1   BYBIN             CONVERT TO NUMBER
         B        APP               NUMBER STATES FORMAL TRANS
YAPOS    EQU      %                 QUOTE USES THE STRING
         CI,R15   X'7D'             CHECK FOR QUOTE
         BNE      PICE1             ERROR IF NO QUOTE
         LW,R4    PICA2             CURRENT POSITION
         LB,R15   *P22,R4           GET NEXT BYTE
         AI,R4    1                 SET UP FOR NEXT BYTE
         CI,R15   X'7D'             CHECK FOR ENDING QUOTE
         BNE      %-3               SPIN TILL WE FIND IT
         STW,R4   PICA2             SAVE IT FOR LATER
         B        APPO              ALL DONE WITH Y
         PAGE
X        EQU      %                 JOURNAL ETC FLAG  SO ACTION
         LW,R3    XCNT              GET NUMBER OF FORMAL TRANS
         CI,R3    XLIMIT            CHECK LIMIT
         BE       XERR              ERROR IF TOO MANY
         AI,R3    1                 INCREMENT IT
         STW,R3   XCNT
         LW,R4    PICA2             MAKE SURE A NUMBER FOLOWS X
         LB,R15   *P22,R4
         CI,R15   X'F0'             LESS THAN ZERO
         BL       PICE1             ERROR IS LESS THAN ZERO
         CI,R15   X'F9'             ERROR IF GREATER THAN 9
         BG       PICE1
*  NOW CONTINUE PROCESSING X PRIMITIVE
         LI,R3    X01               IF NO NUMBER PRINT FMLT
         BAL,R1   BYBIN             GO CONVERT NUMBER
         LI,R3    0                 SEE WHAT WE WANT TO HONOR
XSRC     CW,R1    XTBL,R3
         BE       X01               DO THIS ONE
         AI,R3    1
         CI,R3    XENTBL-XTBL
         BL       XSRC              LOOP
         B        NOX               DO NOT PRINT THIS ONE
X01      LW,R1    OPERN             SEE IF WE WANT TO PRINT
         CW,R1    =C'ADD'           NO IF ONLY ADDING
         BE       NOX
         STW,R2   XSV2              SAVE THE NEXT PRIMITIVE
         BAL,R1   PFMLT             PRINT THE FORMAL TRANSACTION
         LW,R2    XSV2              RESTORE NXT PRIM POINTER
NOX      CI,R2    (EPTBL-PICTBL-1)*4
         BLE      APP
         B        PICE1
XSV2     RES      1
XTBL     DATA     0,1,2,10,11,12    PRINT FORMAL TRANS IF THESE
XERR     LI,R12   XE1               TOO MANY FORMAL TRANS
         BAL,R2   PRNT              TELL USER
         B        PCOM
XE1      TEXTC    C'*****TOO MANY FORMAL TRANSACTIONS'
XCNT     RES      1                 FORMAL TRANS COUNTER
XENTBL   EQU      %
         PAGE
K        EQU      %
         LI,R3    PICE1             ERROR IF NO NUMBER
         BAL,R1   BYBIN
         CI,R1    9                 ONLY ONE DIGET ALLOWED
         BG       PICE1             ERROR IF MORE
         LI,R1    1                 PRINT ONLY ONE CHRACTER
         BAL,R5   NCH               GET ANOTHER ACHARACTER
         LW,R6    FMPOS             SET TO INSERT INTO FM TRN
         BAL,R7   PICPUT            INSET IT
         B        APP
PCOM     EQU      %                 COMMON EXIT FOR PICTURE
         LW,R3    BDR2              CHECK FOR BAD PRIMITIVE
         BEZ      *P11              NO SO JUST EXIT
         LI,R12   BDR1              BAD PRIMITIVE MESSAGE
         BAL,R2   PRNT
         LW,R3    BDR2              GET COUNT
         LI,R2    BA(BDR2+1)        LOCATION OF PRIMITIVE ERRORS
         BAL,R1   PRINT             PRINT THEM OUT
         B        *P11              NOW RETURN TO CALLER
PICA     EQU      %                 GET ONE CHAR AND DO SOME COMPARING
*                                   X1 LINKAGE
*                                   X2 LOCATION IN TABLE OF HIT IF FOUND
*                                   X3 NO HIT RETURN
*                                   X4 CHARACTER OFFSET IN TFD
         LW,R4    PICA2
         LB,R15   *P22,R4            GET A BYTE
*                                   X1K HAS JUST READ CHARACTER UPON RETURN
         AI,R4    1
         CI,R4    TFDTEXT           SEE IF IT IS TOO BIG
         BG       PICE1             YES
         STW,R4   PICA2             COUNTER
         LI,R2    0                 SET UP TO SEARCH THRU TABLE
PICB      CB,R15   PICTBL,R2         LOOK FOR A KEY CHARACTER
          BE       PICC              GOT ONE
          AI,R2    4                 INCREMENT TO NEXT HALF WORD
          CI,R2   (EPTBL-PICTBL-1)*4   CHECK AGAINST TABLE SIZE
         BG        *R3                 NO HIT RETURN
         B        PICB
PICC      SLS,R2   -2                GET PROPER X2 SETTING
          B        *R1               RETURN TO CALLER
PICTBL   GEN,08,24 C'A',A           A TYPE PRIVITIVE
         GEN,08,24 C'B',B           B TYPE PRINITIVE
         GEN,08,24 C'C',C
         GEN,08,24 C'D',D
         GEN,08,24 C'E',E
         GEN,08,24 C'F',F
         GEN,08,24 C'G',G
         GEN,08,24 C'H',H
         GEN,08,24 C'I',I
         GEN,08,24 C'J',J
         GEN,08,24 C'K',K
         GEN,08,24 C'L',L
         GEN,08,24 C'M',M
         GEN,08,24 C'N',N
         GEN,08,24 C'O',O
         GEN,08,24 C'Q',Q
         GEN,08,24 C'R',R
         GEN,08,24 C'S',S
         GEN,08,24 C'T',T
         GEN,08,24 C'U',U
         GEN,08,24 C'V',V
         GEN,08,24 C'W',W
         GEN,08,24 C'@',AT
         GEN,08,24 C'#',LB
         GEN,08,24 C'X',X
         GEN,08,24 C'Y',Y
          GEN,08,24 C'P',P
          GEN,08,24 C'Z',Z           END TYPE PRIMITIVE
EPTBL    EQU      %
         PAGE
BYBIN    EQU      %                 CONVERT BYTES TO BINARY
         STW,R1   BY1               LINKAGE
         STW,R3   BY2               NO HIT RETURN
         LI,R13   0                 ADDER
         LI,R9    -1                NOW NUMBER FLAG 3270
         LI,R1    BY3               FINISHED LOCATION
BY4      BAL,R3   PICA              GET A CHARACTER
        CI,R15    C','                NORMAL RETURN ON A COMMA
        BE        BY3
         CI,R15   X'F0'             CHECK LIMITS
         BL       *BY2              ERROR
         CI,R15   X'F9'             TOO BIG CHECK
         BG       *BY2              ERROR
         LI,R9    0                 NUMBER FOLLOWS THIS PRIMITIVE
         AND,R15   =X'0F'            CLEAN UP
         MI,R13   10                DO TENS BUSINESS
         AW,R13   R15
         BOV      P2CWT             BRANCH IF AN OVERFLOW OCCURRED
         BNEZ     BY4
         LW,R3    BY1               CHK FOR RETURN ADDRESS
         CI,R3    AT12A          CHK IF WE BAL'D FROM THERE
         BNE      BY4
         AW,R13   =X'80000000'   SET BIT 0 FOR AN INPUT # OF ZERO
         B        BY4               LOOP
BY3      LW,R1    R13               SWITCH REGISTERS AROUND
         B        *BY1              RETURN TO CALLER
         PAGE
PICPUT   EQU      %                 BUILD PICTURE
         CI,R1    0                 CHECK FOR NO CHARACTER
         BE       *R7               RETURN IF NONE
         LW,R4    COL               GET CURRENT COLUMN
         LW,R11   ROW               GET THE ROW FOR PROPER ALIGNMENT
         AI,R11   -1                START AT 1,1
         MI,R11   LNLEN             LINE LENGTH
         AW,R4    R11
*                                    CONVENTIONS FOR INSERT CHAR
*                                    X1 HAS COUNT
*                                   X6 IS SWITCH TO MAKE FORMAL TRANS ENTRY
*                                    X7 FOR LINKAGE
*                                    X13 HAS CHARACTER TO INSERT
*                                    ASSUME ROW AND COLUMN ARE SET
         CI,R4   (EBF1-PICBF)*4     MAX BUFFER SIZE
         BG       PICE6             ERROR CAUSE BUFFER  OVEFLOW
          STB,R13 PICBF,R4           INSERT IT
         CW,R4    SVLEN             KEEP TRACT OF MAX BUFFER SIZE
         BL       %+2               OK
         STW,R4   SVLEN
         SW,R4    R11                BACK UP THE OFFSET
          AI,R4    1                 INCREMENT
          STW,R4   COL               SAVE IT
         LW,R6    R6                TEST FORMAL TRANS SWITCH
         BEZ      NOFML             NO FORMAL TRANS ENTRY
         CI,R6   (EBF2-FMLT)*4      CHECK SIZE OF BUFFER
         BG       PICE6             TOO LARGE A PICTURE
         AI,R6    -1
         STB,R13  FMLT,R6
         AI,R6    1
         CW,R6    SVLEN1            KEEP TRACT OF MAX SIZE
         BL  %+2
         STW,R6   SVLEN1            KEEP MAX SIZE PROCESSED
         AI,R6    1
         STW,R6   FMPOS             SAVE OUR CURRENT POSITION
NOFML    EQU      %                 NO FORMAL FORMAL TRANS ENTRY
          AI,R1    -1
          BEZ      *R7               RETURN TO CALLER
          B        PICPUT+2          LOOP THRU INCREMENTING CHAR
PICE1    LI,R12   PICE2
         BAL,R2   PRNT
PICE3    LW,R2    P22               LOCATION OF CURRENT TEXT
         SLS,R2   2                 BYTE LOCATION
         AI,R2    -(TFDSZ-2)
         LW,R3    P33
         BAL,R1   PRINT             PRINT THE TFD
PICE3A LI,R12 PICE5
         BAL,R2   PRNT
         LI,R2    BA(CDBUF)         PRINT THE BUFFER
         LW,R3    PICA2             SIZE OF GOOD ONES
         AI,R3    TFDSZ-1-1
         BAL,R1   PRINT             GO PRINT IT
         LI,R10   X'77'             DELETE FLAG
         B        PCOM              RETURN TO CALLER
PICE6    LI,R12   PICE7
         BAL,R2   PRNT
         B        PICE3             GO PRINT THINGS WE HAVE THUS PROCESSED
PICE8    LI,R12   PICE9             NO NUMBER FOLLOWING '@' PRIMITIVE
         BAL,R2   PRNT              COMMA
         B        PICE3A
P2CWT    LI,R12   PICE4
         BAL,R2   PRNT
         B        PICE3
         PAGE
P11      RES      1                 LINKAGE FOR MAIN LEVEL PICTURE RTN
P22      RES      1                 BA OF IMAGE TO BE PICTURED
P33      RES      1                 SIZE OF TFD
ROW      RES      1                 ROW AND
COL      RES      1                 COLUMN
PICA2    RES      1                 LOCATION IN TFD WE JUST WORKED ON
BY1      RES      1                 LINKAGE FOR BYTE TO BIN CONVERSION
BY2      RES      1                 ERROR RETURN
SVLEN    RES      1                 MAX SIZE OF TFD PICTURE
SVLEN1   RES      1                 MAX SIZE OF FORMAL TRANS
BLANKS    TEXTC    C'    '          SEED DATA FOR CLEAN UP
PICBF     RES,133 50                 SAVE 50 LINES
EBF1     EQU      %                 END OF THE PICTURE BUFFER
         BOUND    4
FMLT     RES,133   50                SAVE ABOUT FIFTY    LINES
EBF2     EQU      %                 END OF FORMAL TRANS BUFFER
         BOUND    4
         RES      1
FMPOS    GEN,32   0                  POSITION IN THE FORMAL TRANS
NCH      STW,R5   NCH5              SAVE LINKAGE FOR CHAR SUPPLIER RTN
         LW,R5    NCH6              GET NEXT CHAR
         LB,R13   NC,R5             PICK-UP CHARACTER
         AI,R5    1                 POINT TO NEXT
         CI,R5    26                0-25 EQUALS A-Z
         BE       %+3               RE SET TO A
         STW,R5   NCH6              SAVE FOR NEXT TIME
         B        *NCH5             RETURN TO CALLER
         LI,R5    0                 START A A AGAIN
         B        %-3               RETURN
NCH6     RES      1                 CHAR POSITION WE ARE ON NEXT
NCH5     RES      1                 LINKAGE
NC       TEXT     'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
         PAGE
CEOF     EQU      %                 EOF OR NON EXISTANT CARD INPUT
         MTW,0    BAD%END%FLG       SEE IF WE ARE IN THE PROCESS
         BEZ      OKCEOF
         LI,R12   ER56              OF DOING A QUOTE STRING
         BAL,R2   PRNT              TELL USER ABOUT ERROR
         LI,R2    BA(CDBUF)         PRINT THE LAST BUFFER
         LI,R3    80                DO ABOUT 80 CHARACTERS
         BAL,R1   PRINT
OKCEOF   EQU %                      NOT DOING A QUOTE STRING
         LW,R4    R10
         SLS,R4   -24               ALIGN STATUS
         CI,R4    X'06'             CHECK FOR E O F
         BLE      PAUIO
         M:MERC                     LET MONITOR HANDLE OTHERS
ER1      EQU      %
         LI,R12   BDCDM
         B        ERAA
ER2      EQU      %
         LI,R12   PICE7
PRNTIMAJ BAL,R2   PRNT
         LI,R2    CDBUF
         LW,R1    PTWS
         LI,R12   EXIT
         STW,R12  P1
         B        CW1
EXIT     M:EXIT
ER3      EQU      %
         LI,R12   BDCD3
         B        ERAA
ER4      LI,R12   ER44
         B        ERAA              COMMON MESSAGE PRINTER
ER5      LI,R12   ER55              TWO SPACE ERROR
ERAA     EQU      %                 COMMONE MESSAGE AND CARD
         BAL,R2   PRNT              PRINTER ROUTING
         LI,R1    DRIVER            ALL GO TO START CLEAN
ERA      EQU      %                 PRINT THE JUST READ IMAGE
         LW,R12   M:SI+4            GET COUNT
         SLS,R12  -17               ALIGN COUNT
         AI,R12   2
         LI,R2    0                 STORE BYTE
         STB,R12  GETB1-1,R2
         LI,R12   GETB1-1           LOCATION  OF IMAGE
         BAL,R2   PRNT
         B        *R1               RETURN TO APPROIATE STREAM
OM       EQU      %                 ERROR RETURN
         LI,R1    DRIVER            PRINT CARD IMAGE AND RTN
         LW,R4    R10               CHECK ERROR TYPE
         SLS,R4   -24
         LI,R2    0                 ZIP THRU ERROR TBL
OM1      CB,R4    EROM,R2
         BE       OMHIT             GOT A KNOWN TYPE
         AI,R2    4
         CI,R2    (ENOM-EROM-1)*4
         BLE      OM1               KEEP SEARCHING
         M:MERC                     LET MONITOR HANDEL IT
         B        DRIVER
OMHIT    SLS,R2   -2                GET APPROIATE X2 SETTING
         LI,R4    EROM
         AW,R4    R2
         LW,R4    *R4
         B        *R4               GO TO APPROIATE RTN
EROM     GEN,8,24 X'16',DUP         DUPLICATE KEYS
         GEN,8,24 X'13',NF1         NOT FOUND
         GEN,8,24 X'43',NF1         READ NOT FOUND
         GEN,8,24 X'03',GETONE      IF NOT PRESENT ITS OK
         GEN,8,24 X'06',DRIVER      END FILE SO DO MORE
         GEN,8,24 X'07',REC2LG      RECORD EXCEEDS INPUT BUFFER SIZE
ENOM     EQU      %                 END OF ERROR TABLE
GETONE   M:OPEN   F:TFDX,(OUTIN),(SAVE),(KEYM,TFDSZ),(KEYED)
         M:CLOSE  F:TFDX,SAVE
         B        TFDUTL            NOW CONTINUE PROCESSING
REC2LG   LI,R12   ERAD2             ERR MESSAGE TFD EXCEEDS BUFFER SIZE
         B        PRNTIMAJ
DUP      LI,R12   ERAD1
         BAL,R2   PRNT
         B        *R1
NF1      EQU      %                 COULD NOT FIND A TFD
         LW,R2    KEY+4             CHECK IF HE HAS A NUMBER
         SLS,R2   -16               SPECIFIED
         CI,R2    X'4040'           IF SO HE WANTS ONLY THAT ONE
         BNE      NF11              SO NO NEED TO SEARCH FURTHER
         M:PFIL   F:TFDX,(BOF)      START AT BEGINNING
         STW,R8   NFSW              SAVE WHERE WE CAME FROM
         LI,R5    NF3               LOOP IN READ
         STW,R5   NFSW1
         LI,R5    NF11              IF EOF NOTIFY USER IT IS
         STW,R5   NFSW2             NON EXISTANT
NF3      M:READ   F:TFDX,(BUF,CDBUF),(WAIT),(SIZE,BSIZ),;
                  (ABN,*NFSW2),(ERR,OM)
         LI,R3    BA(KEY)+1         CHECK WHAT WE READ
         LI,R2    BA(CDBUF)         COMPARE AGAINST KEY
         OR,R3    =X'0F000000'      ONLY COMPARE TFD NAME
         CBS,R2   0
         BNE      *NFSW1            LOOP OR GO TO DRIVER
         OR,R3    =X'2000000'       JUST MOVE THE NUMBER
         MBS,R2   0                 SAVE THE REST OF KEY
         LI,R5    DRIVER            GO TO DRIVER AFTER HITS
         STW,R5   NFSW1
         STW,R5   NFSW2
         LI,R5    NF4               COME BACK HERE AFTER DOING
         STW,R5   ADSW1             ACTION
         B        *NFSW
NF4      EQU      %                 RESET THE FILE POSITION
         M:SETDCB F:TFDX,(ERR,NF5)
         M:READ   F:TFDX,(KEY,KEY),(BUF,CDBUF),(WAIT),;
                  (SIZE,BSIZ),(ABN,*NFSW2),(ERR,OM)
         B        NF3               ALL READY TO READ NEXT
NF11     LI,R12   NF2
         BAL,R2   PRNT
         B        DRIVER
NF5      M:SETDCB F:TFDX,(ERR,OM)   RESET THE DCB
         LW,R4    R10               CHECK WHY WE CAME HERE
         SLS,R4   -24
         CI,R4    X'43'
         BNE      OM                LET STD ERR CHECK DO IT
         LW,R4    OPERN             SEE IF IT WAS CAUSE A DEL
         CW,R4    =C'DEL'
         BNE      OM
         B        NF3               DO ANOTHER DELETE
PAUIO    EQU      %                 WIND UP CODING
         M:CLOSE  F:TFDX,SAVE
        M:EXIT                     ALL DONE
PATCH    RES      25
         END      TFDUTL

