         TITLE    'S U P E R'
         SYSTEM SIG7
         SYSTEM   BPM
         PCC      0
LL       EQU      1
***** S U P E R 1******
*
* ONE OF THE THREE MODULES COMPRISING SUPER. DOCUMENTAION
* APPEARS IN THE CPV SYSTEM MANAGEMENT GUIDE.
*
*
*                   WRITTEN FOR XEROX DATA SYSTEMS
*                   BY: DIANE SLATER 1969
*         WITH EXTENSIVE MODIFICATION BY VELMA FAHRER 1970
*
** AND VERY EXTENSIVELY REMODIFIED IN EARLY 1973
** BY RICK SINATRA TO HANDLE GENERALIZED RESOURCE
** MANAGEMENT (GERM) AND WORKSTATION (:RBLOG)  STUFF.
** NOTE- THERE REMAINS CONSIDERABLE DEAD CODE WHICH
** OUGHT TO BE REMOVED WHEN TIME PERMITS.  THE
** MODIFICATIONS WERE INTERWOVEN INTO THE EXISTING,
** ALREADY MODIFIED CODE RATHER THAN REWRITING
** THE WHOLE PROGRAM.  SUPER NOW EXISTS IN TWO LARGE
** MODULES, THE OTHER MODULE CONTAINING 98 PERCENT OF
** THE CHANGES.  MY APOLOGIES TO WHOEVER INHERITS THIS.
*
*
*  ANOTHER MAJOR SET OF MODIFICATIONS MADE BY RICK SINATRA
*  FOR CPV-C00 IN JULY 1974.  A NEW MODULE, SUPER3, CONTAINS
*  THE BULK OF THE NEW CODE.  SUPER1 AND SUPER2 WERE UPDATED
*  WITH THE CONNECTORS TO SUPER3.  THE NEW FEATURES ARE FOR
*  RESTRICTED PROCESSOR LIST (:PROCS FILE), EXECUTE ONLY :SYS
*  PROCESSORS,TRANSACTION PROCESSING, SECURITY CHECKING.  :PROCS
*  IS HANDLED IN PARALLEL WITH :USERS.  ALSO, IN THIS RELEASE
*  MUCH OF THE DEAD CODE FROM THE UTS VERSION WAS REMOVED.
*
*
***********************************************************************
         PAGE
         SPACE
ACCT     CNAME
         PROC
LF       TEXT     ':SYS    '
         PEND
PASSWORD CNAME
         PROC
         DATA     X'DFEF803F',X'AFC0BF9F'    PASSWORD
         PEND
         PAGE
******************************************************
         SPACE
*        S O M E   H E L P   F O R   M O D U L E   O W N E R
         SPACE
*        TO CONVERT SUPER FOR TESTING IN A PRIVATE
*        ACCOUNT, MAKE THE FOLLOWING CHANGES TO A
*        SEPARATE COPY OF SUPER USING GENMD. THESE
*        MODIFICATIONS GO INTO THE SUPER1 MODULE AND
*        ARE 1-8 CHARACTER BLANK-FILLED.
         SPACE
*        YOUR ACCOUNT NAME IN LOCATIONS:
*                 XXX+1 - XXX+2
*                 ACCT - ACCT+1
*                 PACT - PACT+1
*        YOUR PASSWORD IN LOCATIONS:
*                 xxx+4 - xxx+5
*                 acct+3 - acct+4
*                 PACT+3 - PATC+4
*        IN START20:  B START30
*        IN FAST: LI,12 0     (ALLOW FAST IN ON-LINE MODE)
         SPACE    2
*        YOU WILL REQUIRE YOUR OWN :USERS FILE. SUPER
*        WILL BUILD YOU A :RBLOG FILE WHEN THE FIRST
*        WORKSTATION COMMAND IS ISSUED. IT WILL HAVE
*        YOUR PASSWORD.
******************************************************
         SPACE    2
*        HERE IS A FACSIMILE OF THE CODE TO BUILD
*        A :USERS FILE IN YOUR ACCOUNT
         SPACE
*        SYSTEM   BPM
*        SYSTEM   SIG7
*        REF      M:BO
*START   M:OPEN   M:BO,(FILE,':USERS','3171RS'),;
*                 (KEYED),(DIRECT),(OUT),(SAVE),;
*                 (ABN,ERROR),(ERR,ERROR),(KEYM,21),;
*                 (PASS,'XXXXXXXX')
*        M:CLOSE  M:BO,(SAVE)
*        M:PRINT  (MESS,MESS)
*        M:EXIT
*MESS    TEXTC    'NEW :USERS.3171RS.XXXXXXXX FILE MADE'
*ERROR   M:MERC
*        M:XXX
*        END      START
******************************************************
                  PAGE
         DEF      START
         DEF      INBUFF
         DEF      CMNDBUF
         DEF      FIELD
         DEF      KEY
         REF      F:EI
         REF      JACCN
         REF      J:JIT
         REF      M:UC
         REF      M:SI
         REF      M:C
         REF      M:LO
         REF      M:EO              MUST HAVE ROOM FOR READ ACCT.
         REF      PROCBUF,PBUF2DEF,PDEF2BUF,BUILDKEY,PSIZE
         REF      PMODWR,PWRITE,PERABN,M:BO
         REF      MCMSG
R0       EQU      0
R1       EQU      1
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
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
RBLOGSIZ EQU      80                WORDS/:RBLOG RECORD
BARBLGSZ EQU      4*RBLOGSIZ        BYTES/:RBLOG RECORD
FORUTS   EQU      1
FORBTM   EQU      0
M:EI     EQU      M:UC
LOGSZ    EQU      4*126             LOGON REC SIZE= 126 WORDS
LOGSZW   EQU      126               NR WORDS IN :USERS REC
HOU      EQU      3                 BYTE DISP FOR HEAD OF USED
TOU      EQU      2                 BYTE DISP FOR TAIL OF USED
         PAGE
*        DATA ETC USED BY CP5/A00 MODIFICATION
         SPACE
OPTCOUNT DATA
LMODE    DATA     0                 NONZERO WHILE LISTING
OPTLIST  DATA     0
KWXI     DATA
         BOUND    8
HOLD23   DATA     0,0               HOLDS R2,R3
NAME     DATA     0,0
R10BUF   RES      2*20              EVEN NUMBER
LENGTH   DATA     0
MODE     DATA     0                 0=:USERS, 1=:RBLOG
XSW      DATA     0                 SWITCH
         REF      PRNTRT,NLOPTS,LOPTS,LFLAGS
         SPACE
         REF      UOPTCOUNT,WOPTCOUNT
         REF      UMOD,WMOD
         REF      UOPTIONS,WOPTIONS
         REF      WVERIFY
         REF      WHK,DEF7670
         REF      LISTRB,GETN,LINIT
         REF      EVAL3R
         SPACE
         DEF      KWXI,NAME,TMORE,MODE
         DEF      PAS,CLL3,XACCT3,ERVALU82
         DEF      LENGTH,RMERRMES,HEX2BIN,BCD2BIN
         DEF      TXCSUB,RESTART,R10BUF,NTERMS,TERMS
         DEF      ERVALU7,KILLP
         DEF      PWRITERC,PMODWRIT
         DEF      :USERS,PDEFSW,DMODE
         DEF      CMOPPT,RM4,READ3
         DEF      BIN2BCD,BIN2HEX,BLK2
         DEF      ERVALU3,ERVALU9
         DEF      DRET3,MRET3
         TITLE    'PROCEDURES'
TRMSRCH  CNAME
         PROC
         LOCAL    TERMLOOP
LF       LI,R7    NTERMS
TERMLOOP CB,CF(2) TERMS,R7
         BE       ERVALU7
         BDR,R7   TERMLOOP
         PEND
*             *           *            *           *
CLRFLD   CNAME
         PROC
LF       LCI      3
         STM,R4   SAVEREGS
         LD,R4    BLANKS
         LW,R6    BLANK
         LCI      3
         STM,R4   FIELD
         LM,R4    SAVEREGS
         PEND
*             *           *            *           *
ORSWITCH CNAME
         PROC
LF       STW,R2   SAVEREGS
         LW,R2    AF(2)
         OR,R2    AF(1)
         STW,R2   AF(2)
         LW,R2    SAVEREGS
         PEND
*             *           *            *           *
ANSWITCH CNAME
         PROC
LF       STW,R2   SAVEREGS
         LW,R2    AF(2)
         AND,R2   AF(1)
         STW,R2   AF(2)
         LW,R2    SAVEREGS
         PEND
*             *           *            *
MVVALU   CNAME
         PROC
         LOCAL    MV5,MV10,MV15
LF       STD,R2   SAVEREGS
         LI,R2    0
MV5      LB,R3    FIELD,R2
         CI,R3   ' '
         BE       MV10
         AI,R2    1
         B        MV5
MV10     AI,R2    1
         CI,R2    13
         BE       MV15
         LI,R3    '?'
         STB,R3   FIELD,R2
         LI,R2    BA(FIELD)
         LW,R3    AF(1)
         MBS,R2   0
MV15     LD,R2    SAVEREGS
         CLRFLD
         PEND
ERR      CNAME
         PROC
         LOCAL    ERR1
LF       DO1      NUM(AF)=2
         GEN,12,3,17     AF(2),,ERR1
         LI,R1    AF(1)
         B        RMERRMES
ERR1     EQU      %
         LOCAL
         PEND
BE       EQU      X'683'
BGE      EQU      X'681'
BLE      EQU      X'682'
BG       EQU      X'692'
BNE      EQU      X'693'
BGZ      EQU      X'692'
BL       EQU      X'691'
         TITLE    'OUTPUT MESSAGES'
***********************************************************************
SUPERP   CSECT    1
         DEF      SUPERP
BCETX    TEXT    ' COMMAND ERRORS '
BUETX    TEXT     ' :USERS FILE I/O ERRORS   '
         BOUND    8
C1C6     DATA     X'C1',X'C6'
ACN      TEXTC    'ACCOUNT,NAME?'
         DATA,1   X'15'
CA       TEXTC    'CALL ACCOUNT?'
         DATA,1   X'15'
WHO      TEXTC    'WHO?'
         DATA,1   X'15'
MDF      TEXTC    'MODIFY?'
         DATA,1   X'15'
LOSTOPT  TEXTC    '* * LOST AN OPTION; ADVISE LISTING USER * *'
         DATA,1   X'15'
         BOUND    8
F0F9     DATA     X'F0',X'F9'
RALL     TEXT     C'ALL'
RNONE    EQU      TEST
         DATA,1   'E',X'15'
NOACCSS  TEXTC    'SORRY YOU ARE NOT ALLOWED TO ACCESS SUPER'
         DATA,1   X'15'
NOEXIST  TEXTC    '* * THE :USERS FILE DOES NOT EXIST * *'
         DATA,1   X'15'
OPPMT    TEXT     '--'
         DATA     X'40404040'
PROMPT   DATA,1   2,X'15',C'-'      COMMAND LEVEL PROMPT
SUPHERE  TEXTC    'SUPER HERE'
         DATA,1   X'15'
CRDERR   TEXT     'ERROR ON M:SI DEVICE; SUPER EXITING'
NOTMAIN  TEXTC    'NOT MAIN COMMAND'
         DATA,1   X'15'
FASTMSG  TEXTC    'FAST COMMAND INVALID ON-LINE'
         DATA,1   X'15'
         BOUND    8
BLANKS   DATA     X'40404040',X'40404040'
         TITLE    'DATA AND  STORAGE AREAS USED BY SUPER'
         SPACE
         SPACE
************************************************************************
*  THESE AREAS ARE USED AS DATA AND STORAGE BY SUPER. PLEASE NOTE THAT *
*  CORLMT,RADLMT,TAPLMT & SPINLMT SHOULD BE SET TO THE MAXIMUM VALUES *
*  DECIDED UPON FOR EACH INSTALLATION.
*                                                                      *
************************************************************************
         SPACE
SUPERD   CSECT    0
         DEF      SUPERD
ABOPN    TEXTC    'ABNORMAL RETURN ON :USERS FILE--   ,  '
         DATA,1   X'15'
EROPN    TEXTC    'ERROR RETURN ON :USERS FILE--   ,  '
         DATA,1   X'15'
VALU     TEXTC    '            '
         DATA,1   X'15'
EQVALU   TEXTC    '=            '
         DATA,1   X'15'
         BOUND    8
FIELD    DATA     X'40404040'       COMMAND/OPTION FIELD STORAGE
         DATA     X'40404040'
         DATA     X'40404040'
         BOUND    8
SAVEREGS RES      16                TEMP FOR R1-R15, PLUS 1 WORD
         BOUND    4
SWITCH   DATA     0
*       *                           BYTE 0:
*       *                             NEG=MULTI-OPTS IN CMNDBUF
*       *                             X1= CREATE
*       *                             X2= MODIFY
*       *                             X3= LIST
*       *                             X4= REMOVE
*       *                             X5= END
*                                     X6= WORK STATION
*       *                           BYTE 3:  TYPE OF LIST COMMAND
*       *                             01= LIST ALL USERS
*       *                             02= LIST ACCOUNT
*       *                             03= LIST GIVEN USER(S)
BLANK    EQU      BLANKS
COMPWRD  EQU      F0F9
CORLMT   EQU      255               MAXIMUM AMOUNT OF CORE
CMNDBUF  DO1      20                RECEIVING AREA FOR USER INPUT
         DATA     X'40404040'
         DATA,1   X'15'
         BOUND    4
RBUFF    DATA     X'01000000'       HEADER OF RBID TABLE
RBTBL    EQU      %
I        DO       64
I        SET      (I-1)*4+1
         GEN,8,8,8,8  I,I+1,I+2,I+3&255
         FIN
         BOUND    8
INBUFF   RES      140               BIG ENOUGHT FOR ALL
:USERS   EQU      INBUFF
         BOUND    8
WSBUF    EQU      %
         LIST     0                 HIDDEN HERE IS DO1 512
         DO1      512               OF DATA 0
         DATA     0
         LIST     1
         BOUND    8
KEY      RES      6                 AREA WHICH CONTAINS THE KEYS
         BOUND    8
LINE1    DO1      15                OUTPUT BUFFER #1 TO M:EO AND M:LO
         DATA     X'40404040'
         DATA,1   X'15'
         BOUND    4
LINE2    DO1      18                OUTPUT BUFFER #2 TP M:EO AND M:LO
         DATA     X'40404040'
         BOUND    4
LINE3    DO1      8
         DATA     X'40404040'
         DATA,1   X'15'
MASK     DATA     X'FFFFFFFC'       USED IN OUTPUTING TEXTC FORMATS
         BOUND    8
NAMESAV  DO1      9
         DATA     X'40404040'
NAMESTR  DO1      12                HOLDING AREA FOR NAMES IN LIST CM
         DATA     X'40404040'
PASWTH   DATA     0                 USED AS A SWITCH IN CREATE PASWORD
PROGKEY  DATA     X'13F1F2F3'       THIS KEY IS USED TO OPEN LOGON
         DATA     X'F4F5F6F7'
         DATA     X'F8C4C9C1'
         DATA     X'D5C5E2D3'
         DATA     X'C1E3C5D9'
RADLMT   DATA     X'7FFFFFFF'       MAX NUMBER OF GRANULES
DISKLMT  DATA     X'7FFFFFFF'       MAX NUMBER OF GRANULES
PRVLM    EQU      255               MAXIMUM PRIVILEGE LEVEL
         BOUND    8
SAVEACT  DATA     X'40404040'       HOLDING AREA FOR ACCOUNT
         DATA     X'40404040'
SAVE3    RES      1                 SAVES R3 FOR LIST PRINT ROUTINE
SAVE6    RES      1                 SAVES R6 FOR LIST PRINT ROUTINE
FASTFLG  DATA     0                 FAST COMMAND FLAG
RBOPNFLG DATA     0                 :RBLOG OPEN FLAG
TAPLMT   EQU      127               MAXIMUM NUMBER OF TAPES
SPINLMT  EQU      127               MAX NUMBER OF SPINDLES
         BOUND    8
TEST     DATA,6   'NONE  '          USED TO TEST CLEARING OF AUTO-CALL
         BOUND    4
PREC     RES      1
BACMDERR DATA     0                 COUNT OF BATCH CMND ERRORS
BAUSRERR DATA     0                 COUNT OF BATCH USERS FILE I/O ERRORS
CMNDFLG  DATA      0                BATCH-COMMAND-IN-BUFFER 1=YES
X:JIT    DATA     -1                0=BATCH
EODFLG   DATA     0                 1=EOD ENCOUNTERED
OPTFLG   DATA     0                 1= READING FOR OPTIONS
MAYBE    DATA     0                 WILL BE CAL OR NOP
PDEFSW   DATA     0                 SET IF IN DEFAULT MODE W PROC
DELPSW   DATA     0                 SWITCH FOR REMOVE OPTION
DMODE    DATA     0                 DEFAULT MODE SWITCH
MORE     DATA     0                 SWITCH; 1= MORE OPTIONS IN CMNDBUF.
         BOUND    8
TEMP     DATA     0
         DATA     0
PRDFLT   EQU      X'40'             DEFAULT PRIV
SAVREG3  RES      1                 FOR
DAYHR    RES      2                    EXAMINING
DAY      RES      1                        THE
HOUR     RES      1                          FILE RETENTION
FLAG     RES      1                                FIELD.
*
*
*        SUBROUTINES TO MOVE DEFAULT RECORD ETC
INB2DEF  LI,R2    4
         LW,R3    INBUFF,R2
         STW,R3   DEFREC,R2
         AI,R2    1
         CI,R2    LOGSZW
         BL       %-4
         BAL,R15  PBUF2DEF          LIKEWISE FOR :PROCS DEFAULT
         B        *R6
*
DEF2INB  LI,R2    4
         LW,R3    DEFREC,R2
         STW,R3   INBUFF,R2
         AI,R2    1
         CI,R2    LOGSZW
         BL       %-4
         BAL,R15  PDEF2BUF          LIKEWISE FOR :PROCS DEFAULT
         B        *R6
*
DEFREC   DO1      15
         DATA     0
         DATA     X'00010100'       BILLING DEFAULTS
         DATA     X'40404000'       PROV DEFAULTS
         DO1      118
         DATA     0                 TO MAKE 135
         TITLE    'OPTION MASKS AND COMMAND LISTS'
******** OPTION MASKS **************
         USECT    SUPERP
AMSK     DATA     X'FFFFFFFF'       ALL OPTION MASK
BILMASK  DATA     X'00000010'       BILLING OPTION MASK
CALMASK  DATA     X'00000004'       AUTO-CALL OPTION MASK
FLGMASK  DATA     X'00000001'       FLAG OPTION MASK
PASMASK  DATA     X'00000002'       PASS OPTION MASK
RADMASK  DATA     X'00000008'       RAD OPTION MASK
PRVMASK  DATA     X'00000020'       PRIVILEGE  OPTION MASK
CORMASK  DATA     X'00000040'       CORE OPTION MASK
TAPMASK  DATA     X'00000080'       TAPE OPTION MASK
SPNMASK  DATA     X'00000200'       SPIN OPTION MASK
TRAMASK  DATA     X'00000100'       TEMP STORAGE (TRAD) OPTION MASK
DRTMASK  DATA     X'00000400'       DEF RETNT OPTION MASK
MRTMASK  DATA     X'00000800'       MAX RETNT OPTION MASK
DISMASK  DATA     X'00001000'
TDIMASK  DATA     X'00002000'
REAMASK  DATA     X'00004000'
XACMASK  DATA     X'00008000'
RMPMASK  DATA     X'00010000'
SYSMASK  DATA     X'00020000'
DELMASK  DATA     X'00040000'
RWLMASK  DATA     X'00080000'
NSYMASK  DATA     X'00100000'
******** FLAG MASKS ****************
MASKA    DATA     X'00000008'       MASK FOR FLAG A
MASKB    DATA     X'00000004'       MASK FOR FLAG B
MASKC    DATA     X'00000002'       MASK FOR FLAG C
MASKD    DATA     X'00000001'       MASK FOR FLAG D
**      *     *      *      *       ERROR MSG CODE/SUBCODE SIZE & DES
MSKAB1   GEN,8,24  X'2',BA(ABOPN)+34
MSKAB2   GEN,8,24  X'2',BA(ABOPN)+37
MSKER1   GEN,8,24  X'2',BA(EROPN)+31
MSKER2   GEN,8,24  X'2',BA(EROPN)+34
**      *     *       *    *       * ERROR VALUE SIZE & DEST.
MSKVAL   GEN,8,24  X'C',BA(VALU)+1
MSKEQVAL GEN,8,24 X'C',BA(EQVALU)+2
*********ILLEGAL CHARACTERS FOR NAME,ACCOUNT & PASSWORD*****************
TERMS    DATA,1   0
         DATA,1   C'?'   QUESTION MARK
         DATA,1   C'='   EQUALS SIGN
         DATA,1   C'/'   SLASH
         DATA,1   C'.'   PERIOD
         DATA,1   C'>'   GREATER THAN SIGN
         DATA,1   C'<'   LESS THAN SIGN
         DATA,1   C';'   SEMI-COLON
         DATA,1   C','   COMMA
***      DATA,1   C'#'   NUMBER SIGN   REMOVED FOR VERSION BOO-CPV
         DATA,1   C'('   LEFT PARENTHESIS
         DATA,1   C')'   RIGHT PARENTHESIS
NTERMS   EQU      BA(%)-BA(TERMS)-1
         BOUND    4
         LIST     1
         PAGE
******* COMMAND LIST FOR SUPPER *********************************
CMNDS    DATA,1   0
         DATA,1   'L'    LIST
         DATA,1   'C'    CREATE
         DATA,1   'M'    MODIFY
         DATA,1   'R'    REMOVE
         DATA,1   'E'    END
         DATA,1   'D'               DEFAULT
         DATA,1   'W'               WORKSTATION
         DATA,1   'F'               FAST
         DATA,1   'X'               DELETE WSN
         DATA,1   'P'               DELETE :PROC RECORD
NCMDS    EQU      BA(%)-BA(CMNDS)-1  NUMBER OF COMMANDS
         TITLE    'PLISTS USED BY SUPER'
***********************************************************************
*    PLISTS  USED BY SUPER
***********************************************************************
         BOUND    4
INPUT    GEN,8,7,17    X'10',0,M:EI     INPUT FROM TELETYPE
         GEN,4,4,24  3,4,0
         DATA     CMNDBUF           BUFFER ADDRESS
         DATA     80                    BUFFER SIZE
         DATA     0
OUTPUT   GEN,8,7,17       X'11',0,M:UC    OUTPUT TO TTY
         GEN,4,4,24 3,4,0
         GEN,1,14,17  1,0,R12           BUFFER ADDRESS
         GEN,1,14,17  1,0,R13           BUFFER SIZE
         GEN,1,29,2 1,0,2
SLEEP    EQU       %
         GEN,8,24  X'F',1           SLEEP FPT (M:WAIT)
*                  INTERVAL OF SLEEP IS 1 SECOND.
*                   SUPER DISMISSES ITSELF WHILE
*                   AWAITING USERS FILE TO BECOME
*                   NOT BUSY.
OPENLOG  GEN,8,7,17  X'14',0,F:EI   OPEN LOGON FILE
         DATA     X'F7480009'
         DATA     OPER
         DATA     OPAB
         DATA     INBUFF            BUFFER ADDRESS
         DATA     LOGSZ             BUFFER SIZE
         DATA     2                 KEYED
         DATA     2                 DIRRECT
         DATA     4                 UPDATE MODE
         DATA     2                 SAVE
         DATA     21                MAXIMUM KEY LENGHT
         DATA,1   1,0,2,2           FILE NAME FOR
         TEXTC    ':USERS'          LOGIN CONTROL FILE
XXX     DATA,1    2,0,2,2
         ACCT
         DATA,1   3,0,2,2           PASS WORD
         PASSWORD
         GEN,8,8,8,8 5,1,1,1        READ ACCOUNT
         TEXT     'NONE'
WRITERC  GEN,8,7,17 X'11',0,F:EI    WRITE A RECORD TO LOGON FILE
         DATA     X'38000030'
         DATA     INBUFF            OUTPUT BUFFER TO LOGON
         DATA     LOGSZ             BUFFER SIZE
         DATA     KEY               KEY ADDRESS
MODWRIT  GEN,8,7,17 X'11',0,F:EI    WRITE A MODIFIED RECORD TO LOGON
         DATA     X'38000050'
         DATA     INBUFF            OUTPUT BUFFER TO THE LOGON FILE
         DATA     LOGSZ             BUFFER SIZE
         DATA     KEY               KEY ADDRESS
KEYREAD  GEN,8,7,17 X'10',0,F:EI    KEY READ OF LOGON
         DATA     X'38000010'
         DATA     INBUFF            INPUT BUFFER FROM LOGON
         DATA     LOGSZ             BUFFER SIZE
         DATA     KEY               KEY ADDRESS
CLOSE    GEN,8,7,17 X'15',0,F:EI    CLOSE LOGON FILE
         DATA     X'80000000'
         DATA     2                 SAVE FILE
KILUSER GEN,8,7,17  X'0D',0,F:EI  DELETE A RECORD FROM LOGON
         DATA     X'80000000'
         DATA     KEY               ADDRESS OF KEY
***********************************************************************
         PAGE
*        PLISTS FOR :PROCS FILE
OPENP    GEN,8,7,17  X'14',0,M:BO   OPEN :PROCS FILE
         DATA     X'F7480009'
         DATA     PERABN,PERABN,PROCBUF,2048,2,2
         DATA     4                 UPDATE MODE
         DATA     2,21
         DATA,1   1,0,2,2
         TEXTC    ':PROCS'
         DATA,1   2,0,2,2
PACT     ACCT                       :SYS OR 3171RS FOR TESTING
         DATA,1   3,0,2,2
PPSW     PASSWORD
         GEN,8,8,8,8  5,1,1,1
         TEXT     'NONE'            READ ACCT
*******************************************************
PWRITERC GEN,8,7,17  X'11',0,M:BO   WRITE :PROCS FILE
         DATA     X'38000030'
         DATA     PROCBUF,PSIZE+X'80000000',KEY
PMODWRIT GEN,8,7,17  X'11',0,M:BO   WRITE MODIFIED REC :PROCS
         DATA     X'38000050'
         DATA     PROCBUF,PSIZE+X'80000000',KEY
PKEYREAD GEN,8,7,17  X'10',0,M:BO
         DATA     X'38000010'
         DATA     PROCBUF
         DATA     2048,KEY
CLOSEP   GEN,8,7,17   X'15',0,M:BO
         DATA     X'80000000',2
KILLP    GEN,8,7,17  X'0D',0,M:BO
         DATA     X'80000000',KEY
*******************************************************
         PAGE
OPNRBLOG GEN,8,7,17      X'14',0,M:EO   OPEN :RBLOG
         DATA     X'CF480209'
         PZE      RMERR             ERROR
         PZE      RMABN             ABNORMAL
         PZE      10                RETRIES
         PZE      2                 ORG-KEYED
         PZE      *R2               ACC
         PZE      *R1               MODE
         PZE      2                 SAVE
         PZE      8                 MAX KEY LENGTH
         DATA     X'01000202'
         TEXTC    ':RBLOG'                   NAME
         DATA     X'02000202'
ACCT     ACCT                       :SYS OR 3171RS
         DATA     X'03000202'
         PASSWORD
         DATA     X'05010101'
         TEXT     'NONE'                     READ NONE
RDRBLOG  GEN,8,7,17      X'10',0,M:EO   READ :RBLOG
         DATA     X'F8000010'
         DATA     RMERR             ERROR
         DATA     RMABN             ABNORMAL
         DATA     INBUFF            BUFFER
         DATA     BARBLGSZ          SIZE
         DATA     KEY               KEY ADDRESS
WRRBLOG  GEN,8,7,17      X'11',0,M:EO        WRITE :RBLOG
         DATA     X'F8000050'
         DATA     RMERR             ERROR
         DATA     RMABN             ABNORMAL
         DATA     INBUFF            BUFFER
         DATA     BARBLGSZ          SIZE
         DATA     KEY               KEY ADDRESS
CLSRBLOG GEN,8,7,17      X'15',0,M:EO        CLOSE :RBLOG
         DATA     X'80000000'
         DATA     2                 SAVE
DELRBLOG GEN,8,7,17      X'0D',0,M:EO        DELETE A WORK STATION
         DATA     X'80000000'
         DATA     KEY               KEY ADDRESS
RDRBID   GEN,8,7,17    X'10',0,M:EO   READ RBID RECORD
         DATA     X'F8000010'
         DATA     RMERR             ERROR
         DATA     RMABN             ABNORMAL
         DATA     RBUFF             BUFFER
         DATA     260               SIZE
         DATA     RBIDKEY           RBID KEY BUFFER
RBIDKEY  TEXTC    '...'
WRRBID   GEN,8,7,17   X'11',0,M:EO    WRITE RBID RECORD
         DATA     X'F8000050'
         DATA     RMERR             ERROR
         DATA     RMABN             ABNORMAL
         DATA     RBUFF             BUFFER
         DATA     260               SIZE
         DATA     RBIDKEY           RBID KEY BUFFER
         SPACE
*        FPT'S TO MANAGE RECORD CONTAINING WORK STATION
*        NAMES KEYED BY RBID.  THE RECORD IS 256 HW'S
         SPACE
RDWSN    GEN,8,7,17 X'10',0,M:EO
         DATA     X'F8000010'
         DATA     RMERR
         DATA     RMABN
         DATA     WSBUF             ONLY USED TO HOLD RECORD
         DATA     4*512             LENGTH IN BYTES
         DATA     WSKEY             SPECIAL KEY '///'
         SPACE
WSKEY    TEXTC    '///'
         SPACE
WRWSN    GEN,8,7,17 X'11',0,M:EO
         DATA     X'F8000050'
         DATA     RMERR
         DATA     RMABN
         DATA     WSBUF
         DATA     4*512
         DATA     WSKEY
         TITLE    'S U P E R   MODULE 1 OF 2'
         PAGE
***********************************************************************
*                 THE FOLLOWING CODE WILL CHECK TO SEE IF THE USER IS  *
*                 LOGGED ON UNDER THE ':SYS' ACCOUNT.                 *
***********************************************************************
START    EQU      %
         MTW,0    J:JIT
         BLZ      START20           ON-LINE JOB
         LI,R2    0
         STW,R2   X:JIT
         M:READ   M:C,(BUF,CMNDBUF),(SIZE,80),(WAIT)  READ !SUPER CMND
         M:OPEN   M:LO,(SAVE)       OPEN PRINTER
         M:DEVICE M:LO,(PAGE)       ADVANCE PRINTER TO NEW PAGE
START20 LW,R2     J:JIT+JACCN       GET FIRST WORD OF USER ACCOUNT
         CW,R2    ACCT              THE RIGHT ACCOUNT
         BNE      NOACCES           NO; ERR MSG
         LW,R2    J:JIT+JACCN+1     2ND WORD OF ACCT
         CW,R2    BLANK             IS IT BLANK
         BNE      NOACCES           NO; ERR MSG
         REF      JB:PRIV
         LB,R2    JB:PRIV
         CI,R2    X'C0'             ENOUGH PRIV
         BL       NOACCES           NO - ERR MSG+EXIT
START30  EQU      %
         MTW,0    J:JIT
         BGEZ     %+3               BATCH MODE
         LI,R12   SUPHERE           GET ADDRESS OF THE MESSAGE
         BAL,R11  TXCSUB            OUTPUT MESSAGE 'SUPER HERE'
         LI,R2    2                 DIRECT
         LI,R1    1                 INPUT MODE
         CAL1,1   OPNRBLOG          OPEN :RBLOG
         CAL1,1   CLSRBLOG          FILE EXISTS - CLOSE IT
         TITLE    'SUPER'
RESTART  EQU      %
         LI,R1    0
         STW,R1   SWITCH            CLEAR FOR NEW COMMAND
         STW,R1   LMODE             RESET LISTING SWITCH
         STW,R1   DELPSW
         CLRFLD
*        SWITCH IS NONZERO IF USER TYPED -X ID TO DEL WSN
         LI,R3    0
         STW,R3   XSW               ***W MOD
         MTW,0    CMNDFLG           TEST FOR CMND IN BUFFER
         BNEZ     RSR
         LW,R2    BLANK             *
         LI,R3    -20               * CLEAR THE COMMAND BUFFER TO BLANKS
         STW,R2   CMNDBUF+20,R3     *
         BIR,R3   %-1               *
RSR      MTW,0    X:JIT
         BLZ      RST10
         MTW,0    EODFLG
         BNEZ     END
         STW,R1   OPTFLG
         MTW,0    CMNDFLG           TEST FOR CMND ALREADY IN BUFFER
         BGZ      RSS               YES; DO NOT READ ANOTHER
         M:READ   M:SI,(BUF,CMNDBUF),(SIZE,80),(ABN,BABN)
RSS      EQU      %
         STW,R1   CMNDFLG           TURN OFF FLAG
         LB,R2    CMNDBUF
         CI,R2    'L'               LIST COMMAND?
         BNE      RST               NO
         M:DEVICE M:LO,(PAGE)       YES;ADVANCE PRINTER TO NEW PAGE
RST      M:WRITE  M:LO,(BUF,CMNDBUF),(SIZE,80),(BTD,0) PRINT CMND
         LB,R2    CMNDBUF
         CI,R2    '*'               IS IT A COMMENT CARD
         BE       RSX               YES, CLEAR AND BYPASS
         CI,R2    ' '               FIFST CHARACTER BLANK?
         BNE      RST20              NO; ANALYZE COMMAND
         LI,R12   NOTMAIN          YES; EXPECTED A COMMAND;
         BAL,R11  ADDBCERR
         BAL,R11  TXCSUB            PRINT ERROR MSG
         B        RESTART
RST10    LI,R12   PROMPT            LOAD ADDR. OF PROMPT MSG
         LI,R2    1                 PUT IN OUTPUT DISPLACEMENT
         LB,R13   *R12              GET LENGHT
         CAL1,1   OUTPUT            OUTPUT THE PROMPT
         CAL1,1   INPUT             READ COMMAND BUFFER
         LW,R1    M:UC+4            GET LENGHT OF INPUT MESSAGE
         SLS,R1   -17               RIGHT JUSTIFY THE LENGTH
         AI,R1    -1                POSITION BUFFER POINTER
         LI,R2    C' '              GET A BLANK AND CHANGE THE
         STB,R2   CMNDBUF,R1        CARRIAGE RETURN TO A BLANK
         LB,R2    CMNDBUF           LOAD A BYTE FROM THE COMMAND BUFFER
         STB,R2   FIELD
         SPACE
*        SET UP TO PROCESS :USERS FILE
RST20    EQU      %
         SPACE
         LI,R1    0
         STW,R1   MODE              MODE=:USERS
         LI,R1    UOPTIONS          NR OF :USER OPTIONS
         STW,R1   OPTLIST
         LW,R1    UOPTCOUNT         NR OF OPTIONS
         STW,R1   OPTCOUNT
         SPACE
         LI,R1    NCMDS             LOAD NO. OF COMMANDS
SEARCH1  CB,R2    CMNDS,R1          IS THE BYTE = TO ONE OF THE COMMANDS
         BE       CMNDVEC,R1        YES;GO TO THE CORRESPONDING CMND
         BDR,R1   SEARCH1           NO; CONTINUE SEARCHING COMMANDS
         B        ERVALU12          DO NOT RECOGNIZE 'COMMAND'
CMNDVEC  EQU      %-1
         B        LIST              GO TO LIST COMMAND
         B        CREATE            GO TO CREATE COMMAND
         B        MODIFY            GO TO MODIFY COMMAND
         B        REMOVE            GO TO REMOVE COMMAND
         B        END               GO TO END COMMAND
         B        DEFAULT           GO TO DEFAULT COMMAND
         B        WORKSTA           REMOTE WORK STATION COMMAND
         B        FAST              FAST COMMAND
         B        XWSN              DELETE WSN
         B        DEL:P             DELETE :PROC RECORD
         TITLE    'THE LIST COMMAND'
***********************************************************************
*     THE LIST COMMAND                                                 *
***********************************************************************
LIST     EQU      %
         ORSWITCH      =X'03000000',SWITCH
         SPACE
*        GOO INTO OTHER MODULE AND CLEAR OUT ALL LIST
*        OPTION SWITCHES,FLAGS AND RESET POINTERS
         SPACE
         BAL,R7   LINIT
         LI,R7    0                 CLEAR SAVEACT POINTER
         LI,R1    -79               SET CMNDBUF POINTER
         LI,R3    80
         LD,R4    BLANKS
         STD,R4    SAVEACT          CLEAR SAVEACT WITH BLANKS
         STD,R4   FIELD             CLEAR COMMAND FIELD STORAGE
         STW,R4   FIELD+2
         STD,R4   NAMESAV           CLEAR NAMESAV WITH BLANKS
         STW,R4   NAMESAV+2
         LI,R5    0                 CLEAR NAMESAV POINTER
LOOP1    EQU      %
         LB,R2    CMNDBUF+20,R1     GET A BYTE FROM CMNDBUF
         CI,R2    X'40'             HAS THE END OF THE CMND BEEN FOUND
         BE       LOOP2             YES; GO SEE IF THERE IS AN ACCOUNT
         CI,R2    X'05'             TAB
         BE       LOOP2
         AI,R1    1                 NO; INCREMENT THE POINTER
         BDR,R3   LOOP1             COMMAND OPERATOR EXCEED 80 CHARS.
         B        ERAN              MSG: ACCOUNT,NAME?, GOTO RESTART
LOOP2    EQU      %
         AI,R1    1                 INCREMENT CMNDBUF POINTER
         BEZ      SETL1             BUFFER SCANNED-LIST ALL RECORDS
         LB,R2    CMNDBUF+20,R1     GET ANOTHER BYTE FROM CMNDBUF
         CI,R2    X'40'             IS THERE  AN ACCOUNT  NUMBER?
         BE       LOOP2
         CI,R2    X'05'             TAB
         BNE      LOOP3             YES;GO SAVE THE ACCOUNT
         BE       LOOP2             NO; CONTINUE SCANNING CMNDBUFF
SETL1    LI,R15   1                 ALL RECORDS ARE TO BE LISTED
         ORSWITCH  =X'00000001',SWITCH            LIST1
         B        OPTNRT            GO GET OPTIONS
LOOP3    EQU      %
         LB,R8    CMNDBUF+20,R1     PICK UP A BYTE OF ACCOUNT
         STB,R8   SAVEACT,R7        SAVE THE ACCOUNT NUMBER
         STB,R8   FIELD,R7
         AI,R7    1                 INCREMENT THE SAVEACT POINTER
         AI,R1    1                 INCREMENT CMNDBUFF POINTER
         LB,R2    CMNDBUF+20,R1     GET A BYTE OF CMNDBUFF
         CI,R2    ','               IS THERE A NAME FIELD?
         BE       LOOP5A            YES; GO GET THE NAME
         CI,R2    '('               IS THERE A NAME FIELD?
         BE       LOOP5A            YES
         CI,R2    X'40'             HAS THE END OF ACT. BEEN REACHED
         BNE      LOOP3             NO; CONTINUE SAVING  ACCOUNT
         AI,R1    1                 YES; INCREMENT CMNDBUF POINTER
LOOP4    EQU      %
         LB,R2    CMNDBUF+20,R1     GET A BYTE FROM CMNDBUFF
         CI,R2    X'05'             TAB
         BE       LP410
         CI,R2    X'40'             IS THERE A NAME?
         BNE      LOOP5             YES; GO GET THE NAME
LP410    BIR,R1   LOOP4             NO; CONTINUE SCANNING BUFFER
         BNE      LOOP4             ***
         LI,R15   2                 LIST ONLY SPECIFIED ACCOUNT
         ORSWITCH  =X'00000002',SWITCH            LIST2
         B        OPTNRT            GO GET OPTIONS
LOOP5    EQU      %
         CI,R2    ','               IS THERE A NAME FIELD?
         BE       LOOP5A            YES
         CI,R2    '('               IS THERE A NAME FIELD?
         BNE      ERAN
LOOP5A   CLRFLD
         AI,R1    1                 INCR. CMNDBUF POINTER
         LB,R2    CMNDBUF+20,R1     GET A BYTE FROM CMNDBUF
         LI,R3    0                 CLEAR NAMESTR POINTER
         LI,R6    1                 RESET NAME COUNT
LOOP6    EQU      %
         STB,R2   NAMESAV,R5        SAVE NAME IN NAMESAV
         STB,R2   FIELD,R5
         AI,R5    1                 ADD 1 TO NAMESAVE POINTER
         AI,R1    1                 INCREMENT BUFFER POINTER
LP610    LB,R2    CMNDBUF+20,R1     GET ANOTHER BYTE FROM CMNDBUF
         CI,R2    X'6B'             COMPARE TO A COMMA
         BNE      LP6A              IF NOT A COMMA SEE IF IT IS A ')'
         LI,R5    0                 ZERO NAMESAV POINTER
         AI,R6    1                 ADD 1 TO NAME COUNT
         LD,R10   NAMESAV           GET NAME FROM
         LW,R12   NAMESAV+2         NAMESAV AND PUT
         LCI      3                 IT INTO
         STM,R10  NAMESTR,R3        NAMESTR TO BE LISTED
         LD,R10   BLANKS
         LW,R12   BLANK             *
         LCI      3                 *
         STM,R10  NAMESAV           *
         STM,R10  FIELD
         CI,R6    4
         BGE      LP6A6
         AI,R3    3                 ADVANCE THE POINTER PAST THE
         BIR,R1   LP610              PREV. NAME; GET BYTE OF NEXT NAM
         B        ERVALU12
LP6A     CI,R2    X'40'             END OF A NAME ?
         BE       LP6A5
         CI,R2    X'05'             TAB
         BE        LP6A5
         CI,R2    X'15'
         BE       LP6A5
         CI,R2    ')'               END OF NAME FIELD?
         BNE      LP6B
LP6A5    EQU      %
         LCI      3                 NAMESAV AND
         LM,R10   NAMESAV
         STM,R10  NAMESTR,R3        PUT IT INTO NAMESTR
         LD,R10   BLANKS
         LW,R12   BLANK              *
         LCI      3                 **
         STM,R10  NAMESAV           CLEAR NAMESTR WITH BLANKS
         STM,R10  FIELD
LP6A6    LI,R15   3
         ORSWITCH =X'00000003',SWITCH        LIST3
         B        OPTNRT            GO GET OPTIONS
LP6B     CI,R1    0                 HAS END OF BUFFER BEEN REACHED
         BE       ERVALU12
         B        LOOP6             NO; CONTINUE SCANING BUFFER
********************************************************
         TITLE    'THE OPTION ROUTINE FOR THE LIST COMMAND'
OPTNRT   EQU      %
         LI,R14   0                 CLEAR OPTIONS INDICATOR
         LI,R2    0                 CLEAR THE LIST OPTION
         STW,R14  LFLAGS,R2
         AI,R2    1                 STEP INDEX
         CI,R2    NLOPTS            NUMBER OF OPTIONS
         BLE      %-3               LOOP
OPTPRMT  EQU      %
         CLRFLD
         ANSWITCH =X'0F00000F',SWITCH        CLEAR MULTI-OPTS
         LW,R2    BLANK             *
         LI,R3    -20               * CLEAR BUFFER WITH BLANKS
         STW,R2   CMNDBUF+20,R3     *
         BIR,R3   %-1               *
         MTW,0    X:JIT
         BLZ      OPT20             ON-LINE JOB
         MTW,1      OPTFLG
OPRD     EQU      %
         M:READ   M:SI,(BUF,CMNDBUF),(SIZE,80),(ABN,BABN)
OPTNRD   LB,R2    CMNDBUF
         CI,R2    '*'               IS THIS A COMMENT CARD
         BE       OPWR              YES, WRITE IT AND READ AGAIN
         CI,R2    ' '               SPACE?
         BNE      OPTNEND
OPWR     EQU      %
         M:WRITE  M:LO,(BUF,CMNDBUF),(SIZE,80),(BTD,0)  PRINT OPTION
         CI,R2    '*'               WAS THIS A COMMENT CARD
         BE       OPRDX             YES, READ AGAIN
         B        OPT30
OPTNEND  MTW,1    CMNDFLG
         B        DETMLIST          HAVE OPTIONS; DETERM LIST TYPE
OPT20    EQU      %
         M:WRITE  M:UC,(BUF,OPPMT),(SIZE,2),(BTD,0)
         CAL1,1   INPUT             READ THE USER'S RESPONSE
         LW,R1    M:UC+4            GET LENGTH OF INPUT
         SLS,R1   -17               RIGHT JUSTIFY LENGTH
         AI,R1    -1                PUT POINTER ON CARRIAGE RETURN
         LI,R2    X'15'             *
         STB,R2   CMNDBUF,R1        STORE A CARRIAGE RETURN
OPT30    LI,R3     -84              SET BUFFER POINTER
OPSCAN   LB,R2    CMNDBUF+21,R3     GET A BYTE FROM THE BUFFER
         STB,R2   FIELD
         CI,R2    X'05'             TAB
         BE       OPSC5
         CI,R2    X'40'             IS THE BYTE A BLANK
         BNE      %+3               NO; THE FIELD HAS BEEN REACHED
OPSC5    BIR,R3   OPSCAN            YES; CONTINUE THE SCAN
         B        OPTPRMT           NO OPT.FOUND; GET NEW INPUT.
         CI,R2    X'15'             ARE    MORE OPTIONS WANTED
         BNE      OPSC10
         CI,R3    -84
         BNE      OPTPRMT           GET ANOTHER LINE OF INPUT
         BE       DETMLIST          NULL LINE.
OPSC10   CI,R2    ';'
         BNE      OPSC15
         ORSWITCH =X'80000000',SWITCH        MULTI-OPTS
         AI,R3    1
         B        OPSCAN
OPSC15   SLS,R2   24                LEFT-JUSTIFY 1ST CHARACTER.
         LI,R1    1                 SET THE REGISTER POINTER
         AI,R3    1                 INCREMENT THE BUFFER POINTER
         LB,R4    CMNDBUF+21,R3     GET NEXT BYTE FROM THE BUFFER
         STB,R4   R2,R1             STORE THE SECOND BYTE OF THE OPTION
         STB,R4   FIELD,R1
         SPACE
* GO INTO OTHER MODULE AND PRE-EVALUATE OPTIONS
         SPACE
         BAL,R1   GETN              RETURNS TO BAL+1 OR +2
           B      TLMORE            HANDLED IN GETN
         SPACE
         LI,R1    NLOPTS            GET NUMBER OF OPTIONS
SEARCH2  EQU      %
         CW,R2    LOPTS,R1          IS THIS THE ONE
         BE       SETLOP            GO SET THE FLAG
         AI,R1    -1                NO; MOVE POINTER TO NEXT OPTION
         BNEZ     SEARCH2           CONTINUE SEARCH
         B        ERVALU13
SETLOP   MTW,1    LFLAGS,R1
TLMORE   CI,R2    ';'               LOOK FOR MORE OPTIONS OR BUFFER END
         BNE      TLM1
         ORSWITCH =X'80000000',SWITCH        MULTI-OPTS
         AI,R3    1
         B        OPSCAN
TLM1     CI,R2    X'15'
         BE       OPTPRMT           GET ANOTHER LINE OF INPUT.
         AI,R3    1
         LB,R2    CMNDBUF+21,R3
         B        TLMORE
*    *      *      *      *  *    *     *      *     *      *    *      *
         TITLE    'LIST ROUTINES'
DETMLIST EQU      %
         LW,R8    PROGKEY           GET A DUMMY KEY
         STW,R8   KEY               PUT THE DUMMY KEY INTO KEY BUFFER
         MTW,0    FASTFLG           ARE WE IN FAST MODE
         BEZ      %+3
         CAL1,1   CLOSE             CLOSE & RE-OPEN IN
         CAL1,1   CLOSEP            LIKEWISE FOR :PROCS
         LI,R1     1                OPEN IN THE IN MODE
         BAL,R11  OPEN              GO TO OPEN ROUTINE
DET20    CI,R15   2
         BE       LIST2             LIST SPECIFIED ACCOUNT
         BG       LIST3             LIST SPECIFIED NAMES
LIST1    EQU      %                 LIST1 WILL LIST ALL THE USERS
         MTW,0    FASTFLG           ARE WE IN FAST MODE
         BNEZ     LIST1B            YES; SKIP CLOSE AND OPEN
         CAL1,1   CLOSE
         CAL1,1   CLOSEP            LIKEWISE FOR :PROCS
         LI,15    0                                             #5727
         STW,15   PREC
LIST1A   EQU      %                                             #5727
         LI,R1    1                 OPEN IN INPUT MODE
         BAL,R11  OPEN
         M:PRECORD F:EI,(N,*PREC),FWD,(ABN,ENDFLE)
         MTW,1    PREC
LIST1B   EQU      %
         M:READ F:EI,(BUF,INBUFF),(SIZE,LOGSZ),(ABN,ENDFLE),(BTD,0),WAIT
         BAL,R15  BUILDKEY          MAKE KEY FROM :USERS FOR PROCS
         CAL1,1   PKEYREAD          READ CORRESPONDING :PROCS ITEM
         MTW,0    FASTFLG           ARE WE IN FAST MODE
         BNEZ     LIST1C            YES SKIP CLOSE
         CAL1,1   CLOSEP            LIKEWISE FOR :PROCS
         M:CLOSE  F:EI,(SAVE)                                   #5727
LIST1C   EQU      %
         BAL,R13  PRNTRT            GO PRINT THE RECORD
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     LIST1B            YES; GO READ NEXT RECORD
         B        LIST1A                                        #5727
LIST2    EQU      %                 LIST2 WILL LIST SPECIFIED ACCOUNT
         CLRFLD
         LI,R13   1                 GET A ONE
         STW,R13  PASWTH            SET A SWITCH FOR LIST2
         LI,R7    0                 CLEAR RECORD PRINTED SWITCH
LIST2A   LD,R4     SAVEACT          GET SPECIFIED ACCOUNT
         STD,R4   FIELD
         M:READ F:EI,(BUF,INBUFF),(SIZE,LOGSZ),(ABN,ENDFLE),(BTD,0),WAIT
         CD,R4    INBUFF            COMPARE ACT IN REC WITH ACT. IN R4
         BNE      LIST2A+2
         BAL,R15  BUILDKEY          MAKE KEY FROM :USERS FOR :PROCS
         CAL1,1   PKEYREAD          READ CORRESPONDING :PROCS ITEM
         BAL,R13  PRNTRT            GO PRINT THE RECORD
         LI,R7    1                 SET SWITCH FOR A RECORD PRINTED
         B        LIST2A            GO BACK & READ ANOTHER RECORD
LISTCLR  LD,R4    BLANKS
         STD,R4   SAVEACT           CLEAR SAVEACT WITH BLANKS
         CLRFLD
         LI,R13   0                 GET A ZERO AND
         STW,R13  PASWTH            CLEAR THE SWITCH
         CI,R7    1                 HAS A RECORD BEEN  PRINTED
         BGE      RESTART           YES; GET A NEW CMND
         LI,R12   WHO
         BAL,R11  TXCSUB            GO PRINT THE MESSAGE
         B        RESTART           GO BACK TO COMMAND LEVEL & PROMPT
LIST3    EQU      %
         LI,R3    0                 SET NAMESTR POINTER TO ZERO
         LI,R7    0                 SET INDICATOR FOR REC READING TO 0
LIST3A   EQU      %
         LI,R1    0                 LOAD KEY POINTER
         LW,R8    BLANK
LIST3A1  STW,R8   KEY,R1            CLEAR KEY TO BLANKS
         AI,R1    1                 INCREMENT KEY POINTER
         CI,R1    6                 HAS KEY BEEN FILLED
         BL       LIST3A1           NO
         CLRFLD
         LI,R2    0                 SET SAVEACT POINTER
         LI,R5    1                 SET KEY POINTER TO ONE
         LI,R1    0                 SET COUNTER FOR KEY LENGHT TO ZERO
LIST3A2  EQU      %
         LB,R4    SAVEACT,R2        GET A BYTE FROM SAVEACT
         CI,R4    X'40'             COMPARE THE BYTE TO A BLANK
         BE       LIST3A3           IF = TO BLANK GO GET NAME INTO KEY
         CI,R4    X'05'             TAB
         BE       LIST3A3
         STB,R4   KEY,R5            IF NOT A BLANK PUT THE BYTE INTO KEY
         STB,R4   FIELD,R5
         AI,R1    1                  ADD ONE TO KEY LENGHT COUNTER
         AI,R5    1                  ADD ONE TO KEY POINTER
         AI,R2    1                 ADD ONE TO SAVEACT POINTER
         CI,R2    7                 HAS THE END OF SAVEACT BEEN REACHED
         BLE      LIST3A2           NO KEEP FILLING KEY WITH ACCOUNT
LIST3A3  EQU      %
         LCI      3
         LM,R10   NAMESTR,R3        GET A NAME FROM NAMESTR
         CW,R10   BLANK             MORE RECORDS TO LIST?
         BE       LIST3B            NO, ALL FINISHED.
         LI,R2    0                 CLEAR NAME POINTER
         AI,R1    1                 INCREMENT FOR BLANK SEPARATOR
LIST3A4  EQU      %
         LB,R4    R10,R2            LOAD A BYTE FROM NAME
         CI,R4    X'40'             IS THE BYTE = TO A BLANK
         BE       KEYREED           YES ; THEN END OF NAME WAS REACHED
         CI,R4    X'05'             TAB
         BE       KEYREED
         AI,R5    1                 INCREMENT KEY POINTER
         STB,R4   KEY,R5            STORE BYTE INTO KEY
         STB,R4   FIELD,R5
         AI,R1    1                 ADD ONE TO KEY COUNTER
         AI,R2    1                 ADD ONE TO NAME POINTER
         CI,R2    11                HAS THE END OF THE NAME BEEN REACHED
         BLE      LIST3A4           NO; KEEP STORING NAME INTO KEY
KEYREED  EQU      %
         STB,R1   KEY               STORE LENGHT INTO KEY
         CAL1,1   PKEYREAD          READ CORRESPONDING :PROCS ITEM
         M:READ F:EI,(BUF,INBUFF),(SIZE,LOGSZ),(ABN,OPAB),(ERR,OPER),;
         (BTD,0),(KEY,KEY),WAIT
         STW,R6   SAVE6             SAVE REG 6
         STW,R3   SAVE3             SAVE REG 3
         BAL,R13  PRNTRT            PRINT THE RECORD
         LW,R6    SAVE6             RESTORE REG6
         LW,R3    SAVE3             RESTORE REG3
KEY310   AI,R3    3                 MOVE NAMESTR PTR. TO NEXT NAME
         BDR,R6   LIST3A            NOTE:R6 =NUMBER OF NAMES TO LIST
LIST3B   LD,R6    BLANKS            CLEAR NAMESAV WITH BLANKS
         LW,R8    BLANK             *
         LCI      3                 *
         STM,R6   NAMESAV
         STM,R6   NAMESTR           *
         STM,R6   NAMESTR+3         * CLEAR NAME STORE
         STM,R6   NAMESTR+6         *
         STM,R6   FIELD
         STD,R6   SAVEACT           CLEAR SAVEACT
         CAL1,1   CLOSE             CLOSE THE USERS FILE
         CAL1,1   CLOSEP            LIKEWISE FOR :PROCS
         MTW,0    FASTFLG           TEST IF FAST MODE
         BEZ      RESTART           NO
         LI,R1    4
         BAL,R11  OPEN              RE-OPEN IN UPDATE MODE
         B        RESTART           GO BACK TO COMMAND LEVEL
         TITLE    'PRINT ROUTINE FOR THE LIST COMMAND'
         TITLE    'THE END COMMAND'
***********************************************************************
*    THE END COMMAND                                                  *
***********************************************************************
END      EQU      %
         ORSWITCH =X'05000000',SWITCH         END COMMAND.
         MTW,0     X:JIT
         BLZ      END10             ON-LINE JOB
         MTW,0    FASTFLG           TEST IF FAST MODE
         BEZ      END1              NO
         CAL1,1   CLOSE             CLOSE :USERS FILE
         CAL1,1   CLOSEP            LIKEWISE FOR :PROCS
         MTW,0    RBOPNFLG          IS :RBLOG OPEN
         BEZ      END1              NO
*****    CAL1,1   CLSRBLOG          VOIDED INSTR.
END1     EQU      %
         LI,R3    -18
         LW,R2    BLANK             CLEAR LINE BUFFER FOR PRINTOUT
         STW,R2   LINE2+18,R3
         BIR,R3   %-1
         LW,R3    BACMDERR          CONVERT # CMND ERRORS
         BAL,R8   BIN2BCD
         BAL,R8   BLK2              CHANGE LEAD. ZEROES TO BLANKS
         STD,R6   LINE2
         LW,R3    BAUSRERR          CONVERT # USERS I/O ERRORS
         BAL,R8   BIN2BCD
         BAL,R8   BLK2
         STW,R6   LINE2+7
         STW,R7   LINE2+8
       LCI        4
         LM,R2    BCETX
         STM,R2   LINE2+2           STORE TEXT IN LINE2 BUFFER
         LCI      6
        LM,R2     BUETX
         STM,R2   LINE2+9           STORE TEXT IN LINE2 BUFFER
         M:WRITE  M:LO,(BUF,LINE2),(SIZE,60),(BTD,0)   WRITE PRINTER
         M:DEVICE M:LO,(PAGE)
         M:CLOSE  M:LO,(SAVE)        CLOSE PRINTER
END10    CAL1,9   1
***********************************************************************
*    THE  FAST  COMMAND
************************************************************************
FAST     MTW,0    X:JIT             TEST IF BATCH
         BGEZ     FAST10            YES; OK
         LI,R12   FASTMSG           FAST INVALID ONLINE
         BAL,R11  TXCSUB            GO WRITE MESSAGE
         B        RESTART
FAST10   LI,R1    4
         MTW,0    FASTFLG           ARE WE ALREADY IN FAST MODE
         BNEZ     RESTART           YES; IGNORE COMMAND
         BAL,R11  OPEN              GO OPEN :USERS FILE
         STW,R1   FASTFLG           SET FLAG FOR FAST MODE
         LI,R1    0
         STW,R1   RBOPNFLG          ZERO :RBLOG OPEN FLAG
         B        RESTART
         TITLE    'THE CREATE COMMAND'
***********************************************************************
*    THE  CREATE  COMMAND                                             *
***********************************************************************
CREATE   EQU      %
         ORSWITCH =X'01000000',SWITCH             CREATE COMMAND
         LI,R1    -79               LOAD BUFFER POINTER
         LI,R3    80
CLOOP1   EQU      %
         LB,R2    CMNDBUF+20,R1     LOAD A BYTE OF CMNDBUF  INTO R2
         CI,R2    X'40'             COMPARE THE BYTE IN R2 TO A BLANK
         BE       CLOOP2
         CI,R2    X'05'             TAB
         BE       CLOOP2
         AI,R1    1                 INCREMENT THE POINTER
         BDR,R3   CLOOP1
         B        ERAN
CLOOP2   LI,R3    0
         BAL,R6   DEF2INB           MOVE IN DEFAULT REC
         BAL,R6   NAMEACT           GO TO GET NAME & ACCOUNT SUBROUTINE
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     CLOOP30           YES
         LI,R1    4
         BAL,R11  OPEN
         MTW,0    PDEFSW            HAVE WE ALREADY GOT DEFAULT
         BNEZ     %+2               YES, SKIP :PROCS READ
         CAL1,1   PKEYREAD          RAD CORRESPONDING :PROCS REC
         CAL1,1   CLOSEP
         CAL1,1   KEYREAD
         CAL1,1   CLOSE
         LI,R12   MDF
         BAL,R11  TXCSUB
         B        MLOOP20           USER EXISTS; PROCESS AS A MODIFY
CLOOP20  EQU      %
         BAL,R6   CMOPTS            GET OPTIONS
         LI,R1    4                 OPEN USERS IN OUT MODE
         BAL,R11  OPEN              GO TO OPEN ROUTINE
         CAL1,1   WRITERC
         CAL1,1   CLOSE
         BAL,R15  PWRITE            WRITE CORRESPONDING PROC
         CAL1,1   CLOSEP
         B        RESTART
CLOOP30  MTW,0    PDEFSW            HAVE WE ALREADY GOT DEFAULT
         BNEZ     %+2               YES, SKIP :PROCS READ
         CAL1,1   PKEYREAD          GET CORRESPONDING :PROCS ITEM
         CAL1,1   KEYREAD           GET :USERS REC
         LI,R12   MDF
         BAL,R11  TXCSUB
         B        MLOOP40
CLOOP40  BAL,R6   CMOPTS            GET OPTIONS
         CAL1,1   WRITERC
         BAL,R15  PWRITE            WRITE CORRESPONDIG PROC REC
         B        RESTART
         TITLE    'THE MODIFY COMMAND'
***********************************************************************
*    THE   MODIFY  COMMAND                                            *
***********************************************************************
MODIFY   EQU      %
         ORSWITCH =X'02000000',SWITCH             MODIFY CMND
         LI,R1    -79               LOAD BUFFER POINTER
         LI,R3    80
MLOOP1   EQU      %
         LB,R2    CMNDBUF+20,R1     LOAD BYGE OF CMNDBUF INTO R2
         CI,R2    X'40'             BLANK?
         BE       MLOOP2
         CI,R2    X'05'             TAB
         BE       MLOOP2
         AI,R1     1                 NO
         BDR,R3   MLOOP1            GO BACK AND READ ANOTHER BYTE
         B        ERAN
MLOOP2   BAL,R6   NAMEACT
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     MLOOP30
         LI,R1     4
         BAL,R11  OPEN              OPEN USERS FILE IN INOUT MODE
         CAL1,1   PKEYREAD          GET CORESP. :PROC RECORD
         CAL1,1   CLOSEP
         CAL1,1   KEYREAD           READ RECORD TO BE MODIFIED
         CAL1,1   CLOSE             CLOSE USERS FILE
MLOOP20  EQU      %
         BAL,R6   CMOPTS            HANDLE COMMAND OPTIONS
         LI,R1    4
         BAL,R11  OPEN              OPEN USERS FILE IN INOUT MODE
         CAL1,1   MODWRIT           WRITE MODIFIED RECORD TO USERS FILE
         CAL1,1   CLOSE             CLOSE FILE
         BAL,R15  PMODWR            WRITE CORRESPONDING :PROCS
         CAL1,1   CLOSEP
         B        RESTART           RETURN TO COMMAND LEVEL
MLOOP30  CAL1,1   PKEYREAD          GET :PROCS ITEM
         CAL1,1   KEYREAD           GET :USERS REC
MLOOP40  BAL,R6   CMOPTS            GET OPTIONS
         CAL1,1   MODWRIT           WRITE MODIFIED REC TO USERS FILE
         BAL,R15  PMODWR            WRITE CORRESPONDING :PROCS
         B        RESTART
*
*        ROUTINE TO REMOVE SPECIFIED :PROC RECORD IF PRESENT
*
*        USES BULK OF THE REMOVE ROUTING FOR THE :USERS FILE
*
DEL:P    EQU      %
         LI,R0    X'10'             MC BIT 27 :USERS+5
         CW,R0    INBUFF+5
         BAZ      DEL:P1
         LI,R12   MCMSG             MC IS SET, CANT DELETE :PROCS
         BAL,R11  TXCSUB            PRINT ERROR MESSAGE
         B        RESTART           PROCESS NEXT OPTION
DEL:P1   LI,R2    RESETRP
         B        KILLIT            BYPASS DELETING :USERS RECORD
         TITLE    'THE REMOVE COMMAND'
************************************************************************
*    THE  REMOVE  COMMAND                                             *
***********************************************************************
REMOVE   EQU      %
         LI,R2    KILLU             TO DELETE :USERS RECORD
KILLIT   STW,R2   MAYBE             DELETE CAL
         ORSWITCH =X'04000000',SWITCH             REMOVE CMND
         LI,R2    0
         STW,R2   CMNDFLG           CLEAR FLAG
         LI,R1    -79               LOAD BUFFER POINTER
         LI,R3    80
RLOOP1   EQU      %
         LB,R2    CMNDBUF+20,R1     LOAD BYTE OF CMNDBUF INTO R2
         CI,R2    X'40'             BLANK?
         BE       RLOOP2            YES, MAKE UP KEY
         CI,R2    X'05'             TAB
         BE       RLOOP2
         AI,R1    1                 NO
         BDR,R3   RLOOP1            GO BACK AND READ ANOTHER BYTE
         B        ERAN
RLOOP2   BAL,R6   NAMEACT           READ NAME&ACCT AND FORM KEY
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     RLOOP3            YES
          LI,R1   4
         BAL,R11  OPEN              OPEN USERS FILE IN INOUT MODE
         CAL1,1   KILLP             DELEETE CORRESP. :PROCS REC
         CAL1,1   CLOSEP
         BAL,R11  *MAYBE            TO DELETE OR RESET
         CAL1,1   CLOSE             CLOSE FILE
         B        RESTART           RETURN TO COMMAND LEVEL
RLOOP3   CAL1,1   KILLP             DELETE :PROC RECORD IF THERE
         BAL,R11  *MAYBE            TO DELETE OR RESET
         B        RESTART
KILLU    CAL1,1   KILUSER           DELETE :USERS RECORD
         B        *R11
*
RESETRP  MTW,1    DELPSW            SET ABN ROUTINE
         CAL1,1   KEYREAD           READ :USERS RECORD IF PRESENT
         LI,R12   0
         STW,R12  DELPSW            RESET ABN SWITCH
         LI,R13   4                 MASK FOR RP BIT (29)
         STS,R12  INBUFF+5          RESET RP BIT IN :USERS
         CAL1,1   MODWRIT           REWRITE :USERS RCORD
         B        *R11
***********************************************************************
         TITLE    'THE DEFAULT COMMAND'
********************************************************
*    THE DEFAULT COMMAND                             ***
********************************************************
DEFAULT  EQU      %
DLOOP2   MTW,1    DMODE             SET DEFAULT SWITCH
         BAL,R6   DEF2INB
         LI,R6    4                 INITIALIZE PROC DEFAULT
         STW,R6   PROCBUF
         BAL,R6   CMOPTS            DO OPTINS
         BAL,R6   INB2DEF           COPY BACK
         B        RESTART
*
         TITLE    'KEY BUILDING ROUTINES FOR CREATE, MODIFY AND REMOVE'
***********************************************************************
*  THIS SUBROUTINE GETS THE NAME AND ACCOUNT FROM CMNDBUF AND BUILDS  **
*  A KEY. ENTERANCE TO THIS SUBROUTINE IS MADE THROUGH R6.            **
***********************************************************************
NAMEACT  EQU      %                 THIS ROUTINE LOOKS FOR START OF ACT#
         CLRFLD
         LI,R4    0                 LOAD SAVEACT POINTER
         LI,R5    0                 LOAD NAMESAV POINTER
NA10     AI,R1    1
         CI,R1    0                 HAS THE END OF CMNDBUF BEEN REACHED
         BE       ERAN
         LB,R2    CMNDBUF+20,R1
         STB,R2   FIELD,R4
         CI,R2    X'40'             IS THERE AN ACCOUNT FIELD?
         BE       NA10              NOTHING WAS FOUND; KEEP SEARCHING
         CI,R2    X'05'             TAB
         BE       NA10
NALOOP   EQU      %                 THIS ROUTINE CLEARS SAVEACT&NAMESAV
         CI,R2    ','               HAS AN ACCOUNT BEEN SPECIFIED?
         BE       ERAN              NO
         CI,R2    '('               HAS AN ACCOUNT BEEN SPECIFIED?
         BE       ERAN              NO; GO PRINT MSG.
         TRMSRCH,R2
         LD,R8    BLANKS            CLEAR SAVEACT AND NAMESAV
         STD,R8   SAVEACT           *
         STD,R8   NAMESAV           *
         STW,R8   NAMESAV+2         *
NALOOPA  STB,R2   SAVEACT,R4        STORE BYTE IN SAVEACT
         STB,R2   FIELD,R4
         AI,R1    1                 INCREMENT CMNDBUF POINTER
         LB,R2    CMNDBUF+20,R1
         AI,R4    1
         STB,R2   FIELD,R4
         AI,R4    -1
         CI,R2    ','               IS THERE A NAME FIELD?
         BE       NALOOP3
         CI,R2    '('               IS THERE A NAME FIELD?
         BE       NALOOP3           YES; GO GET THE NAME FIELD
         TRMSRCH,R2
         CI,R2    X'40'             HAS THE END OF THE ACT. BEEN REACHED
         BE       NALOOP2
         CI,R2    X'05'             TAB
         BE       NALOOP2
         AI,R4    1                 INCREMENT THE SAVEACT POINTER
         CI,R4    8                 DOES ACNT HAVE TOO MANY CHARACTERS
         BE       ERVALU4
         B        NALOOPA
NALOOP2  EQU      %                 THIS ROUTINE SEARCHES FOR A NAME
         CLRFLD
         AI,R1    1                 INCREMENT CMNDBUF POINTER
         BEZ      ERAN              NO NAME FIELD
         LB,R2    CMNDBUF+20,R1
         STB,R2   FIELD,R5
         CI,R2    X'40'             COMPARE  TO A BLANK
         BE       NALOOP2
         CI,R2    X'05'             TAB
         BE       NALOOP2
         CI,R2    ','               IS THERE A NAME FIELD?
         BE       NALOOP3
         CI,R2    '('               IS THERE A NAME FIELD?
         BNE      ERAN              SEE IF THERE IS A NAME FIELD
NALOOP3  EQU      %                 THIS ROUTINE FILLS NAME FIELD
         AI,R1    1                 INCREMENT CMNDBUF POINTER
         LB,R2    CMNDBUF+20,R1
         AI,R5    1
         STB,R2   FIELD,R5
         AI,R5    -1
         CI,R2    X'40'
         BE       NALOOP3           IGNORE LEADING BLANKS.
         CI,R2    X'05'             TAB
         BE       NALOOP3
         CI,R2    X'15'
         BE       ERAN              NO NAME
NALOOP4  TRMSRCH,R2                 SEE IF CHAR. LEGAL
         STB,R2   NAMESAV,R5
         STB,R2   FIELD,R5
         AI,R5    1
         CI,R5    13                DOES NAME HAVE TOO MANY CHARACTERS?
         BE       ERVALU5           YES
         AI,R1    1
         LB,R2    CMNDBUF+20,R1
         AI,R5    1
         STB,R2   FIELD,R5
         AI,R5    -1
         CI,R2    X'40'             END OF NAME FIELD?
         BE       GETKEY
         CI,R2    X'05'             TAB
         BE       GETKEY
         CI,R2    X'15'             END OF NAME FIELD
         BE       GETKEY
         CI,R2    ')'               END OF NAME FIELD?
         BNE      NALOOP4           NO
***********************************************************************
** THE GETKEY ROUTINE GETS THE KEY FROM SAVEACT AND NAMESAV ***********
GETKEY   EQU      %
         LB,R2    NAMESAV           CHECK TO SEE IF
         CI,R2    X'40'             THERE IS A NAME
         BE       ERAN              NO NAME
         CI,R2    X'05'             TAB
         BE       ERAN
         LI,R1    0                 *
         LW,R2    BLANK
GET5     STW,R2   KEY,R1
         AI,R1    1                 CLEAR KEY TO BLANKS
         CI,R1    6                 *
         BL       GET5
         LI,R7    1
         AI,R4    1                 ADD 1 TO SAVACT POINTER TO GET SIZE
         AW,R7    R5                *  GET TOTAL SIZE
         AW,R7    R4                *  FOR  KEY LENGHT
         STB,R7   KEY
         LI,R7    1
         LI,R2    0
         LD,R8    SAVEACT
         LD,R10   NAMESAV
         LW,R12   NAMESAV+2
         STD,R8   INBUFF            PUT NAME & ACCOUNT INTO INBUFF
         LCI      3
         STM,R10  INBUFF+2
KEYACT   LB,R3    R8,R2
         STB,R3   KEY,R7            PUT ACCOUNT INTO KEY
         AI,R7    1
         AI,R2    1
         BDR,R4   KEYACT
         LI,R2    0
KEYNAME  LB,R3    R10,R2
         AI,R7    1
         STB,R3   KEY,R7            PUT NAME INTO KEY
         AI,R2    1
         BDR,R5   KEYNAME
         CLRFLD
         B        *R6               GO BACK TO THE MAIN ROUTINE
         LIST     1
         TITLE    'OPTION ROUTINES FOR THE CREATE AND MODIFY COMMANDS'
***********************************************************************
** THIS SUBROUTINE HANDLES THE OPTIONS FOR THE CREATE & MODIFY COMMANDS*
***********************************************************************
CMOPTS   EQU      %                 THIS ROUTINE PRINTS OUT 'OPTIONS'
CMOPPT   EQU      %                 THIS ROUTINE ISSUES AN OPTION PROMPT
         LW,R2    BLANK             *
         LI,R3    -20               * CLEAR BUFFER WITH BLANKS
         STW,R2   CMNDBUF+20,R3     *
         BIR,R3   %-1               *
         MTW,0    X:JIT
         BLZ      CMOP20            ON-LINE JOB
         MTW,1    OPTFLG
CMRD     EQU      %
         M:READ   M:SI,(BUF,CMNDBUF),(SIZE,80),(ABN,BABN)
CMOPRD   LB,R2    CMNDBUF
         CI,R2    '*'               IS THIS A COMMENT CARD
         BE       CMWR              YES, WRITE AND READ AGAIN
         CI,R2    ' '
       BNE        CMOPEND
CMWR     EQU      %
         M:WRITE  M:LO,(BUF,CMNDBUF),(SIZE,80),(BTD,0)  PRINT OPTION
         CI,R2    '*'               IS THIS A COMMENT CARD
         BE       CMRDX             YES, READ AGAIN
         B        CMOP30
CMOPEND  LI,R14   0
         MTW,1    CMNDFLG           NO; SET FLG THAT CMND IN BUFFER
         B        *6                CONTINUE PROCESSIG COMMAND
CMOP20   EQU      %
         M:WRITE  M:UC,(BUF,OPPMT),(SIZE,2),(BTD,0)
         CAL1,1   INPUT             READ IN REQUESTED OPTION
         LW,R1    M:UC+4
         SLS,R1   -17
         AI,R1    -1
         LI,R2    X'15'
         STB,R2   CMNDBUF,R1
CMOP30   EQU      %
         LI,R3    -84               LOAD BUFFER POINTER
***********************************************************************
** THIS ROUTINE WILL SEARCH CMNDBUF FOR AN OPTION
CMSCAN   CLRFLD
         LB,R2    CMNDBUF+21,R3     LOAD BYTE FROM CMNDBUF
         STB,R2   FIELD
         CI,R2    X'05'             TAB
         BE       CMSC5
         CI,R2    X'40'
         BNE      CMSC10
CMSC5    BIR,R3   CMSCAN            READ ANOTHER BYTE; NO OPT FOUND
         B        ILEGLOOP          (SHOULD NEVER BE EXECUTED
CMSC10   LI,R14   0
         CI,R2    X'15'
         BNE      CMSC15
         CI,R3    -84
         BE       *R6               NULL LINE; RETURN TO CMND PROCESSING
         B        CMOPPT            (PROMT&) READ MORE OPTIONS.
CMSC15   CI,R2    C';'
         BE       CMSC5             GET NEXT OPTION
CMSC20   SLS,R2   24                LEFT-JUSTIFY 1ST CHARACTER.
         LI,R1    1
         AI,R3    1
         LB,R4    CMNDBUF+21,R3
         STB,R4   R2,R1
         STB,R4   FIELD,R1
         LW,R1    OPTCOUNT          U OR W OPT COUNT
***********************************************************************
** THIS  ROUTINE  SEARCHS FOR THE OPTION SPECIFIED BY THE USER
SERCH    EQU      %
         CW,R2    *OPTLIST,R1       U OR W OPT LIST
         BE       SETFLAG
         AI,R1    -1
         CI,R1    0
         BNE      SERCH
         B        ERVALU82
SETFLAG  STW,R1   KWXI              KEY-WORD-INDEX
* SET UP ARGUMENTS FOR WMOD/UMOD
         LI,R1    0
         STW,R1   LENGTH            NR OF CHAR IN NAME
         LD,R10   BLANKS
         LI,R1    0
         STW,R1   NAME
         STW,R1   NAME+1
*
         STD,R10  R10BUF            BLANK OUT NAME BUFFER
         B        BUFSCAN
ILEGLOOP CI,R3     0                SEARCH NEXT OR END OF OPTIONS.
         BE       CMOPPT
         LB,R2    CMNDBUF+21,R3
         CI,R2    X'15'
         BE       CMOPPT
         CI,R2    ';'
         BNE      ILEGL1
         B        CMSCAN
ILEGL1   AI,R3    1
         B        ILEGLOOP
TMORE    MTW,0    MORE
         BEZ      CMOPPT            END OF OPTIONS IN CMNDBUF.
         LI,R4    0
         STW,R4   MORE              RESET MORE TO 'NO MORE OPTIONS'.
         B        CMSCAN            CONTINUE SCANNING CMNDBUF.
** THE BUFSCAN ROUTINE SCANS THE CMNDBUF UNTIL IT FINDS THE OPTION FIELD
BUFSCAN  EQU      %
         LI,R1    0
BUFSCANL CLRFLD
         AI,R3    1                 INCREMENT CMNDBUF POINTER
         BGEZ     FNDAREA1          SEARCH FOR OPTN WITH NO PARAMETER
         LB,R2    CMNDBUF+21,R3     LOAD BYTE INTO R2
         CI,R2    X'7E'             COMPARE  TO = SIGN
         BE       BUF1
         CI,R2    ';'               END OF OPTION
         BE       BUF0
         CI,R2    ' '
         BE       BUFSCANL
         STB,R2   NAME,R1           COLLECT CHARS 3-N OF NAME
         AI,R1    1
         B        BUFSCANL
BUF0     MTW,1    MORE
         B        FNDAREA1          SEARCH OPTION ,NO PARAMETER
BUF1     EQU      %
BUF5     AI,R3    1
         LB,R2    CMNDBUF+21,R3     LOAD BYTE INTO R2
         CI,R2    X'40'             COMPARE TO A BLANK
         BE       BUF5
         CI,R2    X'05'             TAB
         BE       BUF5
         STD,R2   HOLD23            HOLD FOR CALL,XA
         CI,R2    X'15'             HAS A CARRIAGE RETURN BEEN RECEIVED
         BE       CMOPPT            YES; GO BACK AND GIVE ANOTHER PROMPT
         CI,R2    ';'               MORE COMMANDS IN BUFFER?
         BE       CMSCAN
         LD,R10   BLANKS
         STD,R10  R10BUF
         LI,R1    0                 LOAD POINTER TO R10
***********************************************************************
* THE STORE ROUTINE PUTS ALL FIELDS EXCEPT FLAGS AND CALL
*           INTO  REGISTERS  R10 & R11.                                *
STORE    STB,R2   R10BUF,R1
         STB,R2   FIELD,R1
         AI,R3    1
         LW,R4    R3
ST05     EQU      %
         LB,R2    CMNDBUF+21,R3
         CI,R2    X'15'
         BE       FNDAREA2
         CI,R2    ';'
         BNE      ST10
         MTW,1    MORE
         B        FNDAREA2          STORE VALUE
ST10     CI,R2    X'40'
         BE        FNDAREA
         CI,R2    X'05'             TAB
         BE       FNDAREA
         CW,R3    R4
         BNE      ERVALU9           BAD SYNTAX-EMBEDDED BLANKS
         AI,R1    1
*****    CI,R1    8                 ARE TOO MANY CHARACTERS IN FIELD
         STW,R1   LENGTH            OF VALUE
*****    BE       ERVALU9
         BNE      STORE
** FINDAREA ROUTINE PUTS THE OPTION FIELD IN R10 & R11 INTO INBUF
FNDAREA  EQU      %
         AI,R3    1
         B        ST05              SCAN TRAILING BLANKS IN FIELD
FNDAREA2 EQU      %
FNDAREA1 EQU      %
         LD,R10   R10BUF            WHAT FOLLOWED =
         MTW,0    MODE
         BEZ      UMOD              EXTERNAL ROUTINE :USERS
         B        WMOD              EXTERNAL ROUTINE :RBLOG
*        B        TMORE             (RETURNS TO TMORE)
PAS      LW,R4    LENGTH            OF PASSWORD
         CI,R4    7
         BG       ERVALU9           TOO LONG. ERR MSG
         CW,R10   RNONE             SHOULD FIELD BE CLEARED
         BNE      PASSPUT
         LI,R10   0                 YES; LOAD WITH ZEROES
         LI,R11   0
         STD,R10  INBUFF+6          PUT PASSWORD INTO INBUFF
         B        TMORE             MULTIPLE OPTIONS?
PASSPUT  LI,R4    0                 PASSWORD WANTED.
         LI,R5    0                 MAKE CERTAIN PASSWORD WILL
         STD,R4   INBUFF+6           CONTAIN TRAILING ZEROES.
PLOOP    LB,R4    R10,R5            GET A BYTE OF THE PASSWORD.
         CI,R4    X'40'             END OF PASSWORD
         BE       PLPEND            YES;
         CI,R4    X'05'
         BE       PLPEND
         LI,R14   1                 SET SWITCH FOR AN OPTION RETURN
         STW,R14  PASWTH
         TRMSRCH,R4
         LW,R14   0
         STW,R14  PASWTH
         STB,R4   INBUFF+6,R5       NO,  STORE BYTE INTO INBUFF.
         AI,R5    1                 INCREMENT POINTER.
         CI,R5    7                 REACHED END OF FIELD?
         BLE      PLOOP             NO;
PLPEND   B        TMORE             MULTIPLE OPTIONS?
* THIS ROUTINE PROCESSES REMOTE WORK STATION :SYS AUTHORIZATION
RM1      EQU      %
         LI,R1    RWSYSFLG          REMOTE WORK STATION FLAG
         STS,R1   RWSFLAG
         B        TMORE
* THIS ROUTINE PROCESSES REMOTE WORK STATION DELETE
RM2      EQU      %
         CAL1,1   DELRBLOG          DELETE :RBLOG RECORD
         CAL1,1   RDRBID            READ RBID RECORD
         LB,R2    INBUFF            GET RBID TO DELETE
         LI,R4    0
         CAL1,1   RDWSN             READ THE WSN RECORD
         STD,R4   WSBUF,R2          CLOBBER 1ST HALF OF WSN
         LI,R1    HOU
         LB,R3    RBUFF,R1          GET HEAD OF USED
         CW,R3    R2                IS IT SAME AS RBID
         BNE      RM21              NO
         LB,R3    RBTBL,R2
         STB,R3   RBUFF,R1          SET NEW HEAD OF USED
         B        RM22
RM21     LW,R4    R3
         LB,R3    RBTBL,R3
         CW,R3    R2                SEARCH FOR MATCH IN TABLE
         BNE      RM21
         LB,R3    RBTBL,R2
         STB,R3   RBTBL,R4
RM22     BNEZ     RM23
         LI,R1    TOU
         STB,R4   RBUFF,R1          SET NEW TAIL OF USED
RM23     LB,R3    RBUFF
         STB,R2   RBUFF             SET HEAD OF FREE TO CUR RBID
         STB,R3   RBTBL,R2
*****    AI,R6    1
*****    B        *R6               RETURN BAL+2
         B        XDONE             RETURN
* THIS ROUTINE PROCESSES REMOTE WORK STATION MAX PRIORITY
RM3      EQU      %
         BAL,R1   HEX2BIN           GO-CONVERT PRIORITY TO BINARY
         CI,R5    X'F'
         BG       ERVALU9           ERROR-PRIORITY TO HIGH
RM32     STB,R5   MAXPRI            WORK STATION MAX PRIORITY
         B        TMORE             MORE OPTIONS
* THIS ROUTINE PROCESSES THE WS LIST OPTION
RM4      EQU      %
         LI,R1    1
         STW,R1   LMODE             SET LISTING SWITCH
RM42     CW,R10   RALL
         BE       RM43              'ALL' SPECIFIED
         CAL1,1   RDRBLOG           READ RECORD FOR CURRENT ID
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     %+2               YES; SKIP CLOSE
         CAL1,1   CLSRBLOG          CLOSE :RBLOG
         BAL,R11  LISTRB            LIST OPTIONS
         B        RESTART
RM43     EQU      %
         CAL1,1   CLSRBLOG          CLOSE :RBLOG
         LI,R1    2                 IGNORE FIRST TWO RECORDS
         STW,R1 PREC
RM44     EQU      %
         M:OPEN   M:EO,(FILE,':RBLOG',':SYS'),;
                  (IN),(SEQUEN),(ABN,RMEOF)
         M:PRECORD M:EO,(N,*PREC),(FWD),(ABN,RMEOF)
RM46     EQU      %
         M:READ   M:EO,(BUF,INBUFF),(SIZE,LOGSZ),(ABN,RMEOF),;
                  (BTD,0),(WAIT)
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     RM45              YES; SKIP CLOSE
         CAL1,1   CLSRBLOG          CLOSE :RBLOG
         MTW,1    PREC
         BAL,R11  LISTRB            LIST OPTIONS
         B        RM44
RM45     BAL,R11  LISTRB            LIST OPTIONS
         B        RM46              CONTINUE READING FILE
RMEOF    CAL1,1   CLSRBLOG
         MTW,0    FASTFLG
         BE       RESTART
         LI,R1    4                 UPDATE MODE
         CAL1,1   OPNRBLOG
         B        RESTART
RMERR1   EQU      %
         CI,SR3   X'43'
         ERR      RME3,BNE          WORKSTATION NOT PRESENT
         ERR      RME4
*        B        *R11
* THIS ROUTINE RESETS THE WS :SYS AUTHORIZATION BIT
RM5      EQU      %
         LI,R1    RWSYSFLG
         STS,R1   RWSFLAG
         EOR,R1   RWSFLAG
         STW,R1   RWSFLAG           RESET :SYS AUTHORIZATION
         B        TMORE
** THE BILRT ROUTINE STORES THE BILLING OPTION INTO R10 & PUTS IT
*   INTO INBUF
BILRT    EQU      %
         CW,R10   L(C'NONE')        SHOULD THE FIELD BE CLEARED
         B        PUTBIL            GO PUT ZEROS INTO THE FIELD
BIL10    LI,R7    1
         AW,R7    R1                GET THE NUMBER OF DIGITS IN FIELD.
         BAL,R1   BCD2BIN           GO CONVERT THE NUMBER TO BINARY
         CI,R5    7
         BG       ERVALU9           VALUE-GREATER-THAN-LIMIT=ERROR
PUTBIL   STH,R5   INBUFF+15         STORE FIELD INTO RECORD.
         B        TMORE             MULTIPLE OPTIONS?
** THE FLGRT ROUTINE SETS THE SPECIFIED FLAGS & MOVES THEM INTO INBUF
FLGRT    EQU      %
         LI,R1    0                 POINTER INTO FIELD
         LI,R10   0
         LI,R11   0
FL10     EQU      %
         LB,R2    CMNDBUF+21,R3     LOAD A BYTE FROM CMNDBUF
         AI,R3    1
         CI,R2    X'40'             IS IT EQUAL TO A BLANK
         BE       FL10              YES; GO BACK & GET ANOTHER BYTE
         CI,R2    X'05'             TAB
         BE       FL10
         CI,R2    X'15'             IS IT EQUAL TO A CARRIAGE RETURN
         BE       CMOPPT            YES; GO BACK & PROMPT AGAIN
         CI,R2    ';'
         BNE      FLGLPB
         B        CMSCAN
FLGLPA   EQU      %
         LB,R2    CMNDBUF+21,R3
         AI,R3    1
         CI,R2    X'40'
         BE       FLGLPA
         CI,R2    X'05'             TAB
         BE       FLGLPA
         CI,R2    X'15'
         BE       TENMOV
         CI,R2    ';'
         BNE      FLGLPB
         MTW,1    MORE              MORE OPTIONS IN BUFFER.
         B        TENMOV            STORE FLAGS.
FLGLPB   EQU      %
         AI,R11   0
         BNE      ERVALU9           SYNTAX PROBLEM
         CI,R2    'N'               SHOULD THE FLAG FIELD BE CLEARED
         BNE      FLGTST            NO
         STB,R2   R11
         LI,R4    -3                PICK UP NEXT 3 CHARS
         LB,R2    CMNDBUF+21,R3
         STB,R2   R12,R4            ENTER IN R11
         AI,R3    1
         BIR,R4   %-3
         CW,R11   RNONE             WAS NONE SPECIFIED
         BE       FLGLPA            YES - GO CONTINUE SCAN
         B        ERVALU9
FLGTST   EQU      %
         CI,R2    C'A'
         BE       AMSKST
         CI,R2    C'B'
         BE       BMSKST
         CI,R2    C'C'
         BE       CMSKST
         CI,R2    C'D'
         BE       DMSKST
         STB,R2   FIELD,R1
         AI,R1    1
         B        FLGLPA
AMSKST   OR,R10   MASKA
         B        FLGLPA
BMSKST   OR,R10   MASKB
         B        FLGLPA
CMSKST   OR,R10   MASKC
         B        FLGLPA
DMSKST   OR,R10   MASKD
         B        FLGLPA
TENMOV   LI,R11   X'F'
         STS,R10  INBUFF+5          STORE FLAG BITS IN BUFF
         LW,R11   FIELD
         CW,R11   BLANK
         BNE      ERVALU8
         B        TMORE             MULTIPLE OPTIONS?
*THIS ROUTINE PUTS THE EXT. ACCOUTING INFO. INTO INBUFF
*  ALL CHARACTERS ALLOWED EXCEPT THAT ; IS REGARDED AS DELIMETER
*   MAX=24 CHAR. ,  R10 TO R15 USED AS STORAGE AREA
*
XACCT3   EQU      %
         LD,R2    HOLD23            RESTORE R3
         LCI      6
         LM,R10   LINE1             BLANK OUT R10 TO R15
         STM,R10  INBUFF+24                  INITIALLY BLANK XACC
         LI,R1    0                 USE R1 AS COUNT
XACCT310 EQU      %
         LB,R2    CMNDBUF+21,R3     GET A BYTE
         CI,R2    X'15'             CARRIAGE RETURN?
         BE       THSALL
         CI,R2    X'40'             END OF FIELD IN BATCH
         BE       ADIN2             YES
         CI,R2    ';'               IS THAT ALL?
         BNE      ADIN
         MTW,1    MORE              MORE OPTNS TO COME
         B        THSALL
ADIN     EQU      %
         CI,R1    24                MAX. REACHED?
         BGE      ERVALU9           OUTPUT MESSAGE
         STB,R2   R10,R1            STORE CHARACTER
         AI,R1    1                 BUMP POINTERS
ADIN2    AI,R3    1
         B        XACCT310
THSALL   LCI      6
         STM,R10  INBUFF+24         STORE IN INBUFF
         B        TMORE
* THIS ROUTINE WILL PUT THE AUTOCALL NAME, ACCOUNT AND PASSWORD INTO
*  INBUFF.
CLL3     EQU      %
         LI,R7    0                POINTER INTO FIELD
         LD,R2    HOLD23            RESTORE R2,R3
         LI,R10   0                 PUT ZEROES INTO REGISTERS
         LI,R11   0                 AND THEN GO
         STD,R10  INBUFF+10         CLEAR ACCOUNT FIELD
         STD,R10  INBUFF+8          CLEAR PASSWORD FIELD
         CI,R2    'N'               SHOULD THE AUTO-CALL FIELDS BE CLEAR
         BE       CLEAR             YES; GO CLEAR THEM.
CLL4     LD,R10   BLANKS            BLANK R10-12 FOR AUTO-CALL
         LW,R12   BLANK             * BE PUT THERE.
         LI,R1    1                 CLEAR THE REGISTER POINTER
CLRT     STB,R2   R10,R1            PUT A BYTE OF A.-CALL NAME INTO REGS
         STB,R2   FIELD,R7
         AI,R7    1
         AI,R3    1                 INCREMENT CMNDBUFF POINTER
         LB,R2    CMNDBUF+21,R3
         CI,R2    X'40'             HAS END OF NAME BEEN FOUND
         BE       STRCLNM           YES; PUT NAME INTO INBUFF
         CI,R2    X'05'             TAB
         BE       STRCLNM
         CI,R2    X'15'
         BE       STRCLNM
         CI,R2    '.'               CALL ACCT IS USER'S ACCT?
         BE       STRCLNM           YES
         CI,R2    ';'
         BE       STRCLNM
CLR1     AI,R1    1                 NO; INCREMENT REGISTER POINTER.
         CI,R1    12                ARE THERE TOO MANY CHARACTERS
         BL       CLRT              NO; KEEP FILLING IN THE NAME
         BGE      ERVALU1           YES; OUTPUT ERROR MSG.
STRCLNM  STB,R1   R10               PUT IN THE BYTE COUNT
         LCI      3
         STM,R10  INBUFF+12         STORE AUTO-CALL NAME INTO INBUFF
         CLRFLD
         LI,R7    0
CLRT1    CI,R2    X'40'
         BE       CLRT10
         CI,R2    X'05'             TAB
         BNE      CLRT15
CLRT10   AI,R3    1
         LB,R2    CMNDBUF+21,R3
         B        CLRT1             LOOP& LOOK FOR NONBLANK CHAR.
CLRT15   CI,R2    X'15'
         BNE      CLRT17            NOT A SYSTEM PROCESSOR
CLRT16   LW,R10   =':SYS'           SYSTEM PROCESSOR; USE :SYS ACCOUNT.
         LW,R11   BLANK
         B        PUTACT1
CLRT17   CI,R2    ';'
         BNE      CLRT18
         MTW,1    MORE              MORE OPTIONS IN CMNDBUF.
         B        CLRT16            SYSTEM PROCESSOR.
CLRT18   CI,R2    '.'
         BNE      ERCA              NOT CR,., NOR ;
CLRT14   AI,R3    1                 LOOK FOR '..'
         LB,R5    CMNDBUF+21,R3
         CI,R5    X'40'
         BE       CLRT14            IGNORE BLANKS
         CI,R5    X'05'
         BE       CLRT14
         CI,R5    '.'
         BNE      CLRT21            NOT '..'
CLRT19   LCI      2
         LM,R10   INBUFF            USE ACCOUNT IN RECORD.
         B        PUTACT2
CLRT21   CI,R5    X'15'
         BNE      CLRT22
CLRT23   EQU      %
         LCI      2                 LAST OPTION;
         LM,R10   INBUFF              STORE USER'S ACCOUNT.
         B        PUTACT1
CLRT22   CI,R5    ';'
         BNE      CLACT             GO SCAN ACCOUNT
         MTW,1    MORE
         B        CLRT23
CLACT    EQU      %
         AI,R3    -1                BACK UP CMNDBUF POINTER
         LD,R10   BLANKS
         LI,R1    0                 CLEAR REGISTER POINTER
         LI,R4    0                 SCAN FLAG FOR LEADING BLANKS
CLRT3    AI,R4    0                 ARE WE SCANNING LEAD BLANKS
         BEZ      CLRT32            YES
         LI,R4    2                 INDICATE TRAILING BLANKS
CLRT32   AI,R3    1                 INCREMENT CMNDBUF POINTER
         LB,R2    CMNDBUF+21,R3
         CI,R2    '.'               PASSWORD?
         BE       PUTACT2
         CI,R2    X'15'
         BE       PUTACT1           NO PASSWORD.
CLRT33   CI,R2    X'40'
         BE       CLRT3             IGNORE BLANK
         CI,R2    X'05'             TAB
         BE       CLRT3
CLRT34   CI,R2    ';'
         BNE      CLRT35            STORE BYTE
         MTW,1    MORE              YES, MORE OPTIONS IN BUFFER.
         B        PUTACT1
CLRT35   STB,R2   R10,R1            STORE BYTE OF ACCOUNT FIELD
         STB,R2   FIELD,R1
         AI,R1    1                 INCREMENT REGISTER POINTER
         CI,R1    8                 ARE THERE TOO MANY CHARACTERS IN ACT
         BG       ERVALU1
         AI,R4    -2                TEST IF TRAILING BLANKS PRESENT
         BEZ      ERVALU1           YES-BAD SYNTAX
         LI,R4    1                 INDICATE NON-BLANK FIELD
         B        CLRT32            CONTINUE SCAN
PUTACT1  STD,R10  INBUFF+10         PUT ACCOUNT INTO INBUFF
         B        TMORE             NO PASSWORD; MORE OPTIONS?
PUTACT2  STD,R10  INBUFF+10         STORE ACCT.
         LD,R10   BLANKS            CLEAR FOR AUTO-CALL PASSWORD
         CLRFLD
         LI,R1    0                 CLEAR REGISTER POINTER
         LI,R4    0                 SET FLAG FOR LEADING BLANKS
CLRT4    AI,R4    0                 ARE WE SCANNING LEAD BLANKS
         BEZ      CLRT42            YES
         LI,R4    2                 INDICATE TRAILING BLANKS
CLRT42   EQU      %
         AI,R3    1                 INCREMENT CMNDBUF POINTER
         LB,R2    CMNDBUF+21,R3
         CI,R2    X'15'
         BE       PUTPAS
CLRT43   CI,R2    X'40'
         BE       CLRT4             IGNORE BLANKS
         CI,R2    X'05'             TAB
         BE       CLRT4
CLRT44   CI,R2    ';'
         BNE      CLRT45
         MTW,1    MORE              YES, MORE OPTIONS IN BUFFER.
         B        PUTPAS
CLRT45   STB,R2   R10,R1            STORE BYTE OF PASSWORD FIELD.
         STB,R2   FIELD,R1
         AI,R1    1                 INCREMENT THE REGISTER POINTER
         CI,R1    8                 IS THE PASSWORD MORE THAN 8 BYTES
         BG       ERVALU1
         AI,R4    -2                WERE TRAILING BLANKS PRESENT
         BEZ      ERVALU1           YES-BAD SYNTAX
         LI,R4    1                 INDICATE NON-BLANK FIELD
         B        CLRT42            CONTINUE SCAN
PUTPAS   STD,R10  INBUFF+8          SOTRE PASSWORD IN INBUFF
         B        TMORE             MULTIPLE OPTIONS?
CLEAR    EQU       %                THIS ROUTINE CLEARS AUTO-CALL
         LW,R4    R3
         LI,R1    1
CLEAR10  AI,R4    1
         LB,R2    CMNDBUF+21,R4
         CB,R2    TEST,R1           COMPARE 'NONE  ' W CMNDBUF FIELD.
         BNE      NOTNONE           FOUND NON-MATCHING CHARACTER.
         AI,R1    1
         CI,R1    5
         BL       CLEAR10
CLEAR20  LI,R12   0                 CLEAR AUTO-CALL FIELDS IN INBUFF.
         LCI      3
         STM,R10  INBUFF+12
         LW,R3    R4
CLEAR30  LB,R2    CMNDBUF+21,R3
         CI,R2    X'05'             TAB
         BE       CLEAR35
         CI,R2    X'40'
         BNE      CLEAR40
CLEAR35  AI,R3    1
         B        CLEAR30
CLEAR40  CI,R2    ';'               MORE OPTIONS IN CMNDBUF?
         BNE      TMORE
         MTW,1    MORE
         B        TMORE
NOTNONE  EQU      %                 VALUE NOT 'NONE  '
         CI,R1    4
         BL       NOT5              POSSIBLY A LMN NAME.
         CI,R2    X'15'
         BE       CLEAR20
NOT3     CI,R2    ';'               'NONE;'
         BNE      NOT5
         MTW,1    MORE
         B        CLEAR20
NOT5     LI,R2    'N'               R3 STILL POINTING AT 'N' IN CMNDBUF.
         B        CLL4
*  THIS ROUTINE SETS THE FILE READ OPTION BIT IN WD 5 ACCORDINGLY  *
READ3    EQU      %
         LI,R5    0
         CW,R10   RALL              IS READ=ALL
         BE       READ3PT           YES
         LI,R5    X'80'
         CW,R10   RNONE             IS READ=NONE
         BNE      ERVALU9           ILLEGAL
READ3PT  EQU      %
         STB,R5   INBUFF+5
         B        TMORE
*  THIS ROUTINE PUTS THE DEF RETNT INTO INBUFF
DRET3    EQU      %
         LI,R5    0
         CW,R10   RNONE             SHOULD THE DEF RETNT FLD BE CLEARED
         BE       DRET3PT           YES-GO ZERO FIELD
         LI,R5    X'FFFF'
         CW,R10   L(C'NEVE')        IS NEVER SPECIFIED
         BE       DRET3PT           YES-GO SET FIELD
         BAL,R4   CNVTDH            GO EXAMINE FIELD
         CI,R5    X'FFFF'
         BGE      ERVALU9
DRET3PT  STH,R5   INBUFF+20         STORE INTO INBUFF
         B        TMORE
*** THIS ROUTINE PUTS THE MAX RETNT INTO INBUFF ***
MRET3    EQU      %
         LI,R5    0
         CW,R10   RNONE
         BE       MRET3PT
         LI,R5    X'FFFF'
         CW,R10   L(C'NEVE')
         BE       MRET3PT
         BAL,R4   CNVTDH            GO EXAMINE FIELD
         CI,R5    X'FFFF'
         BGE      ERVALU9
MRET3PT  LI,R1    1                                CHANGES)
         STH,R5   INBUFF+20,R1
         B        TMORE
         TITLE    'SUBROUTINES USED BY SUPER'
***********************************************************************
*    SUBROUTINES  USED BY SUPER                                       *
***********************************************************************
         LIST     LL
ADDBCERR MTW,0    X:JIT
         BLZ      *11
         MTW,1    BACMDERR          IN BATCH UPDATE ERROR COUNTER
         B        *11
ADDBUERR MTW,0    X:JIT
         BLZ      *11
         MTW,1    BAUSRERR          IN BATCH UPDATE ERROR OCUNTER
         B        *11
         SPACE
         SPACE
ENDFLE   CAL1,1   CLOSE             CLOSE :USERS AT EOF
         MTW,0    FASTFLG           TEST IF FAST MODE
         BEZ      %+3               NO
         LI,R1    4
         BAL,R11  OPEN              RE-OPEN IN UPDATE MODE
         LI,R13   1                 GET A ONE
         CW,R13   PASWTH            IS THE SWITCH ON FOR LIST2 ROUTINE
         BE       LISTCLR           YES RETURN TO LIST 2
         B        RESTART           FILE IS REACHED
         SPACE
*           *          *          *         *         *          *
*       * CALL OPT ERR MSG: 'VALUE?' & SCAN FOR MORE OPTIONS *     *
ERVALU1  MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
TCMORE   CI,R2    ';'               LOOK FOR MORE OPTIONS OR BUFFER E
         BNE      TCM1
         ORSWITCH =X'80000000',SWITCH       MULTI-OPTS
         AI,R3    1
         B        CMSCAN
TCM1     CI,R2    X'15'
         BE       CMOPPT            GET NEW LINE OF INPUT
         AI,R3    1
         LB,R2    CMNDBUF+21,R3
         B        TCMORE
*           *          *          *         *         *          *
*           *          *          *         *         *          *
*       *  COMMAND ERROR MSG: 'VALUE?' AND RETURN TO RESTART  *   *
ERVALU12 MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        RESTART
*           *       *          *         *           *            *
*       * LIST OPTION ERROR MSG 'VALUE?' & RETURN TO TLMORE    *    *
ERVALU13 MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        TLMORE
*           *          *          *         *         *          *
*       *   OPTION CONVERSION ERROR MSG: '=VALUE?' , RETURN TO TMORE
ERVALU3  MVVALU   MSKEQVAL
         LI,R12   EQVALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         LW,R6    R15               RESTORE RETURN ADDRESS
         B        TMORE
*           *          *          *         *         *          *
*       *   COMMAND ACCOUNT FIELD ERROR MSG: 'VALUE?' RETURN TO RESTA
ERVALU4  MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         LD,R2    BLANKS
         STD,R2   SAVEACT
         B        RESTART
*           *          *          *         *         *          *
*       *  COMMAND NAME FIELD ERROR MSG:  'VALUE?' RETURN TO RESTART
ERVALU5  MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         LD,R2    BLANKS            CLEAR NAMESAV
         LW,R4    BLANK
         LCI      3
         STM,R2   NAMESAV
         B        RESTART
*           *          *          *         *         *          *
*           *          *          *         *         *          *
*       *  ILLEGAL CHAR IN NAME/ACCOUNT OF C/M/R CMND, OR IN PASSWORD
*       *    OPTION OF  C/M CMND. MSG: 'VALUE?'  RETURN TO RESTART
*       *    OR TMORE AS APPROPRIATE.
ERVALU7  MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         LI,R14   0
         CW,R14   PASWTH
         BE       RESTART           CMND LEVEL
         STW,R14  PASWTH
         B        TMORE             OPTION LEVEL
*           *          *          *         *         *          *
*       *   ILLEGAL FLAG VALUE, MSG:  '=VALUE?'
ERVALU8  MVVALU   MSKEQVAL
         LI,R12   EQVALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        ILEGLOOP
*           *          *          *         *         *          *
*       *   OPTION OPERATOR ERROR, MSG: 'VALUE?'
ERVALU82 MVVALU   MSKVAL
         LI,R12   VALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        ILEGLOOP
*           *          *          *         *         *          *
*           *          *          *         *         *          *
*       *   OPTION VALUE EXCEEDS LIMITS, MSG:  '=VALUE?'
ERVALU9  MVVALU   MSKEQVAL
         LI,R12   EQVALU
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        TMORE
*           *          *          *         *         *          *
*       *   MISSING CALL ACCOUNT INDICATOR,  MSG: 'CALL ACCOUNT?'
ERCA     LI,R12   CA
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        TMORE
*           *          *          *         *         *          *
*       *   MISSING ACCOUNT/NAME FIELDS, MSG: 'ACCOUNT,NAME?'
ERAN     LI,R12   ACN
         BAL,R11  TXCSUB
         BAL,R11  ADDBCERR
         B        RESTART
         SPACE
*           *          *          *         *         *          *
*       *  GO TO CLOOP20 IF CREATING A NEW USER   *      *     *
*       *   MSG: 'WHO?' IF TRYING TO M/R/L A NONEXISTING USER.  IF
*       *     LIST3,  PROCESS REMAINING REQUESTED USERS.
*           *          *          *         *         *          *
KRER     LW,R12   SWITCH
         AND,R12  =X'07000000'
         CW,R12   =X'01000000'
         BNE      KRER10            M/R/L
         MTW,0    DELPSW            FOR ABN ROUTINE
         BNEZ     *R11              BYPASS 'MAYBE' SUBROUTINE
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     CLOOP40           YES; SKIP CLOSE
         CAL1,1   CLOSE             CREATE A
         B        CLOOP20             NEW USER.
KRER10   LI,R12   WHO
KRER15   BAL,11   TXCSUB            *
         BAL,R11  ADDBUERR
         LW,R12   SWITCH
         AND,R12  =X'07'
         CI,R12   3
         BE       KEY310            LIST3 BEING PROCESSED; CONTINUE I
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     RESTART           YES; SKIP CLOSE
         CAL1,1   CLOSE
         B        RESTART           M/R NONEXISTING USER.
* PUTS OUT MESSAGE  'SORRY YOU ARE NOT ALLOWED TO ACCESS SUPER'
NOACCES  LI,R12   NOACCSS
         BAL,R11  TXCSUB
         B        END
         SPACE
         SPACE
         SPACE
         SPACE
* THIS ROUTINE OPENS THE USERS FILE
OPEN     EQU      %
         CAL1,1   OPENLOG
         CAL1,1   OPENP             OPEN :PROCS FILE IN PARALLEL
         B        *R11
         SPACE
         SPACE
*
         SPACE
*
OPER     LB,R11   R10
         CI,R11   X'43'
         BE       KRER
OPER10   STW,R3   TEMP
         LH,R2    R10
         STW,R2   SAVEREGS+13       BINARY CODE & SUBCODE IN BYTES 2&
         LB,R2    R10
         BAL,R8   BIN2HEX
         STW,R4   SAVEREGS+14       BYTES 2&3 = PRINTABLE HEX CODE
         STW,R6   SAVEREGS
         LI,R6    3
         LB,R2    SAVEREGS+13,R6
         SLS,R2   -1                SUBCODE ONLY 7 BITS; ADJUST IT.
         BAL,R8   BIN2HEX             CONVERT
         STW,R4   SAVEREGS+15       BYTES 2&3 = PRINTABLE HEX SUBCODE
         LI,R10   BA(SAVEREGS+14)+2    PICK UP CODE;
         LW,R11   MSKER1               STORE IN EROPN MSG.
         MBS,R10  0
         LI,R10   BA(SAVEREGS+15)+2    PICK UP SUBCODE;
         LW,R11   MSKER2               STORE IN EROPN.
         MBS,R10  0
         LW,R3    TEMP              RESTORE REGS.
         LW,R6    SAVEREGS
         LI,R12   EROPN
         BAL,R11  TXCSUB            PRINT MSG.
         BAL,R11  ADDBUERR
         CAL1,1   CLOSE
         MTW,0    FASTFLG           TEST IF FAST MODE
         BEZ      RESTART           NO
         LI,R1    4
         BAL,R11  OPEN              RE-OPEN IN UPDATE MODE
         B        RESTART
*           *          *          *         *         *          *
*           *          *          *         *         *          *
BABN     SLS,R10   -24
         CI,R10   5
         BE       BABN10            EOD
         CI,R10   6
         BE       BABN10            EOF
         LI,R12   CRDERR
         LI,R13    40
         BAL,R11  TEXTSUB           PRINT ERROR MSG
         B        END               GET OUT
BABN10   MTW,0    OPTFLG
         BEZ      END
         MTW,1    EODFLG
         AND,8    =X'1FFFF'
         CI,8     OPTNRD
         BE       DETMLIST          ONLY TWO POSSIBLE ABNORMAL READS
         B        CMOPEND
         SPACE
*
OPAB     LW,R12   R10
         SLS,R12  -17
         CI,R12   X'A01'
         BNE       OPAB1            FILE NOT BUSY; CONTINUE TEST
         CAL1,8    SLEEP       BUSY, GOTO SLEEP 1 SEC
         B         OPEN             RETRY OPEN.
OPAB1    SLS,R12  -7                CONTINUE TEST
         CI,R12   X'13'
         BE       KRER
OPAB2    CI,R12   X'03'
         BNE      OPAB3
         LI,R12   NOEXIST           NO; PUT OUT MESSAGE THAT THE FILE
         BAL,R11  TXCSUB            DOESN'T EXIST AND EXIT
         BAL,R11  ADDBUERR
         B        END               TO TEL.
OPAB3    STW,R3   TEMP
         LH,R2    R10
         STW,R2   SAVEREGS+13       BIN. CODE & SUBCODE IN BYTES 2 &
         LB,R2    R10               CONVERT CODE
         BAL,R8   BIN2HEX
         STW,R4   SAVEREGS+14       BYTES 2&3 = PRINTABLE HEX CODE
         STW,R6   SAVEREGS
         LI,R6    3
         LB,R2    SAVEREGS+13,R6
         SLS,R2   -1                SUBCODE 7 BITS; ADJUST FIRST
         BAL,R8   BIN2HEX
         STW,R4   SAVEREGS+15       BYTES 2&3 = PRINTABLE HEX SUBCODE
         LI,R10   BA(SAVEREGS+14)+2     PICK UP CODE
         LW,R11   MSKAB1                STORE IN ABOPN MSG.
         MBS,R10  0
         LI,R10   BA(SAVEREGS+15)+2     PICK UP SUBCODE
         LW,R11   MSKAB2            STORE IN ABOPN MSG.
         MBS,R10  0
         LW,R3    TEMP              RESTORE REGS
         LW,R6    SAVEREGS
         LI,R12   ABOPN
         BAL,R11  TXCSUB            PRINT MSG.
         BAL,R11  ADDBUERR
         B        END
*           *          *          *         *         *          *
*           *          *          *         *         *          *
         SPACE
TEXTSUB  LI,R2    0                 THIS ROUTINE HANDLES TEXT FOR OUTPUT
         MTW,0    X:JIT
         BGEZ     TXCSUB0           BATCH JOB
         CAL1,1   OUTPUT
         B        *R11               pan  t(  tu  t)
         SPACE
TXCSUB   LI,R2    1                 THIS ROUTINE HANDLES TEXTC FORMAT
         LB,R13   *R12              FOR OUTPUT.
         MTW,0    X:JIT
         BGEZ     TXCSUB1           BATCH JOB
         AND,R13  MASK
         AI,R13   4
         CAL1,1   OUTPUT
         B        *R11
TXCSUB0  AI,R13   -1                STRIP CARRIAGE RETURN
TXCSUB1  M:WRITE  M:LO,(BUF,*12),(SIZE,*13),(BTD,*2)
         B        *R11
         SPACE
         PAGE
*        THIS ROUTINE SCANS THE FILE RETENTION OPTION FIELD
*        AND CONVERTS DAYS TO HOURS
*        AND OBTAIN THE TOTAL IN HOURS
*        ENTER WITH BAL,R3
*
*        R1       NO. OF DIGITS IN EXPRESSION
*        R6       STORAGE BUFFER
*        R3       INDEX
*        R4,R5    RESULTING VALUE FROM SUBRTN BCD2BIN
*        R7       NO. OF DIGITS TO BE CONVERTED IN SUBRTN BCD2BIN
*        R8       SUBS. FOR R1
*        R10,R11  NUMBER TO BE CONVERTED
*        R2       INDEX
*
*      R5 WILL CONTAIN THE RESULTING NUMBER
*
CNVTDH   EQU      %
         STW,R4   SAVE3
         STW,R6   SAVE6             SAVE LINK
         STW,R3   SAVREG3           SAVE LINK
         STW,R10  DAYHR             R10,R11 CONTAIN THE EXPRESSION
         STW,R11  DAYHR+1
         AI,R1    1                 R1 CONTAINS THE NO. OF DIGITS IN EXP.
         LW,R8    R1                USE R8
         LI,R3    0                 USE R3 AS INDEX REG
         LI,R2    0                 CLEAR INDEX
         STW,R3   DAY               CLEAR THE TWO NUMBERS
         STW,R3   HOUR
         STW,R3   FLAG              CLEAR THE FLAG
GOON     LB,R6    DAYHR,R3          SCAN THE EXPRESSION
         CI,R6    ','               IS COMMA ENCOUNTERED
         BE       CHECK             YES;GO CHECK
         STB,R6   R10,R3            PREPARE FOR BCD2BIN CONV
         AI,R3    1
         BDR,R8   GOON
FIRST    LW,R7    R3                R3 CONTAINS THE NO. OF DIGITS FOR DAYS
         LW,R6    SAVE6             SAVE IN CASE OF ERROR
         BAL,R1   BCD2BIN           CALL SUBRTN
         MI,R5    24                DAYS TO HRS
         STW,R5   DAY               FIRST PART DONE
         MTW,0    FLAG              TEST IF HRS PART IN EXP.
         BEZ      ADD               NO
         B        SECOND            YES
CHECK    CI,R3    0                 IS THE FIRST CHAR. COMMA
         BNE      OK
SECOND   AI,R8    -1                MAKE SURE THE ITERATION
         AI,R3    1                 INITIALLY DONT WANT THE COMMA
         LB,R6    DAYHR,R3
         CI,R6    ','
         BE       ADD
         STB,R6   R10,R2            R2 IS INITIALLY ZERO
         AI,R2    1
         BDR,R8   SECOND+1
         LW,R7    R2                NO. OF DIGITS FOR HOURS
         BAL,R1   BCD2BIN           CONVERT
         STW,R5   HOUR              SECOND PART DONE
         B        ADD
OK       MTW,1    FLAG              THE EXP CONTAINS DAYS
         B        FIRST             AND MAYBE ALSO HOURS
ADD      LW,R5    DAY
         AW,R5    HOUR              SUMMING
         LW,R3    SAVREG3           STORE LINK
         LW,R6    SAVE6             STORE LINK
         B        *SAVE3
         PAGE
* THIS IS A SUBROUTINE WHICH CONVERTS A BINARY BUFFER POSITION TO A
* PRINTABLE DECIMAL VALUE.
* ENTER WITH
*       BAL,R8
*       R3 = NUMBER TO BE CONVERTED FROM BINARY
* EXIT WITH
*         R6 & R7 = 8 CHARACTER RESULT
*
*         REG  R1,R4 AND R3 ARE DESTROYED
*
BIN2BCD  EQU      %
         LI,R1    7
BINA     LI,R2    0
         DW,R2    =10               DIVIDE BY TEN
         AI,R2    X'F0'             PUT IN THE  'F'
         STB,R2   R6,R1             STORE RESULT INTO  R6
         AI,R1    -1
         BGEZ     BINA
         B        *R8
*
*        IF COMMENT DETECTED, CLEAR CMNDBUF AND REREAD
*
RSX      LI,R12   RSS-1
         B        CLEARCB
CMRDX LI,R12 CMRD
 B CLEARCB
OPWRX    LI,R12   OPWR
         B        CLEARCB
OPRDX    LI,R12   OPRD
CLEARCB  LI,R2    79
         LI,R11   ' '
         STB,R11  CMNDBUF,R2
         BDR,R2   %-1
         B        *R12
         PAGE
* BLK2 WILL BLANK OUT LEADING ZEROES AFTER THE BINARY TO BCD CONVERSION
* ROUTINE IN REGS 6 & 7. BLK1 WILL BLANK LEADING ZEROES IN REG 7.
* ENTER WITH BAL,R8.
BLK2     EQU      %
         LW,R10   BLANK
         LW,R11   =X'FF000000'      MASK
         LI,R1    0
BETA     LB,R2    R6,R1              LOAD A BYTE FR
         CI,R2    X'F0'
         BNE      OUT
         STS,R10  R6                PUT IN BLANKS WHERE  FF POINTS TO
         SLS,R11  -8                SHIFT MASK
         AI,R1    1
         CI,R1    4
         BNE      BETA
BLK1     EQU      %
         LW,R10   BLANK
         LW,R11   =X'FF000000'
         LI,R1    4
ALPHA    LB,R2    R6,R1             LOAD A BYTE FROM R7
         CI,R2    X'F0'             IS BYTE EQUAL TO ZERO
         BNE      OUT
         STS,R10  R7
         SLS,R11  -8
         AI,R1    1
         CI,R1    7
         BNE      ALPHA
OUT      B        *R8
         PAGE
* THIS ROUTINE CONVERTS BCD NUMBERS TO BINARY
* NOTE THAT THE ROUTINE WILL STOP WHEN A NON NUMERIC VALUE IS ENCOUNTERD
* ENTER WITH BAL,R1
*
*   REGISTER ASSIGNMENTS
*        R4 = MULTIPLY AREA
*        R5 = MULTIPLY AREA; WILL CONTAIN RESULT IN BINARY.
*        R6 = BYTE INDEX REGISTER.
*        R7 = DECREMENTING REGISTER.
*        R0 = CONTAINS BYTE TO BE CONVERTED
*        R10&R11 CONTAIN NUMBER TO BE CONVERTED IN HEX.
*
BCD2BIN  EQU      %
         LW,R15   R6                SAVE RETURN ADDRESS
         LI,R6    0
         LI,R4    0
         LI,R5    0
BINARY   LB,R0    R10,R6
         CLM,R0   COMPWRD
         BCS,9    EVAL3R
         AND,R0   =X'0000000F'
         MI,R4    10
         AW,R5    R0
         AI,R6    1
   BDR,R7         BINARY
OUT2     LW,R6    R15               RESTORE RETURN ADDRESS
         B        *R1
         PAGE
*  THIS ROUTINE COVERTS A HEX FIELD TO BINARY
*     ENTER BAL,R1
*           R10 = FIELD TO BE CONVERTED
*     EXIT
*         R5 = BINARY RESULT
*
HEX2BIN  EQU      %
         LW,R15   R6                 FOR COMPATIBILITY W ERBIN SUBRTN
         LI,R8    0
         LI,R4    0
SCN      LB,R9    R10,R4
         CI,R9    X'40'
         BE       RETRN
         CLM,R9   F0F9
         BCR,9    CONTINUE
         CLM,R9   C1C6
         BCR,9    CONTINUE-1
         B        EVAL3R
         AI,R9    9
CONTINUE SLS,R9   28
         SLD,R8   4
         AI,R4    1
         B        SCN
RETRN    LW,R5    R8
          LW,R6    R15              FOR COMPATIBILITY W ERBIN SUBRTN
         B        *R1
         PAGE
* THE BIN2HEX ROUTINE WILL CONVERT A BINARY BYTE TO THE PRINTABLE
* HEXIDECIMAL VALUE.
*  ENTER WITH BAL,R8
*        R2 = BINARY NUMBER TO BE CONVERTED.
* EXIT WITH
*       R4 = RESULT
*
*
BIN2HEX  EQU      %
         LI,R5    3
         LW,R4    BLANK
TAG      SLD,R2   -4
         SLS,R3   -28
         CW,R3    =X'00000009'
         BG       X
         OR,R3    =X'000000F0'
         B        OUTA
X        SW,R3    =X'00000009'
         OR,R3    =X'000000C0'
OUTA     STB,R3   R4,R5
         AI,R5    -1
         CI,R5    1
         BG       TAG
         B        *R8
         LIST     1
         PAGE
*        ENTERED IF USER TYPES X ID TO DEL WSN
         SPACE
XWSN     MTW,1    XSW               SET X SWITCH
         B        WORKSTA
         SPACE
WORKSTA  EQU      %
         ORSWITCH =X'06000000',SWITCH
         SPACE
*        SET UP TO PROCESS WORKSTATION
         SPACE
         LI,R14   1
         STW,R14  MODE              MODE=WORKSTA
         LI,R14   WOPTIONS          NR OF W OPTIONS
         STW,R14  OPTLIST
         LW,R14   WOPTCOUNT
         STW,R14  OPTCOUNT
         BAL,R14  WHK               WMOD HOUSEKEEPING
         LI,R14   0                 CLEAR OPTIONS INDICATOR
         LI,R0    CMNDBUF           SET UP SCAN PARAMETERS
         LI,R1    80
         LI,R2    0
         LI,R3    D1
         BAL,SR4  SCAN              GO-GET WORKSTATION VERB
         CI,R1    1
         ERR      RME2,BGE          ERROR-INVALID WS ID
         BAL,SR4  SCAN              GO-GET WORK STATION ID IN(D1)
         CI,R7    1
         ERR      RME2,BGE          ERROR-INVALID WS ID
         CI,R7    8
         ERR      RME2,BLE          ERROR-INVALID WS ID
         LI,SR1   0                 RESET ALPHA INCOUNTERD
         STB,R7   KEY               FORM TEXTC KEY
         LW,R4    R7
WORK9    AI,R4    -1
         LB,R5    D1,R4
         CI,R5    X'F0'             ALPHA CHAR
         BGE      %+2               NO
         LI,SR1   1                 YES-SET ALPHA INCOUNTERED
         STB,R5   KEY,R7
         BDR,R7   WORK9             FORM TEXT KEY NAME RIGHT JUSTIFIED
         CI,SR1   0                 ALPHA IN WS ID
         ERR      RME2,BG           NO-ERROR-INVALID WS ID
         LI,R2    2                 DIRECT
         LI,R1    4                 INOUT MODE-ONLINE
         MTW,0    FASTFLG           TEST IF FAST MODE
         BEZ      SPINN             NO
         MTW,0    RBOPNFLG          IS :RBLOG OPEN
         BNEZ     WORK7             YES
SPINN    CAL1,1   OPNRBLOG          OPEN :RBLOG
         MTW,1    RBOPNFLG          SET :RBLOG OPEN FLAG
WORK7    EQU      %
         CAL1,1   RDRBLOG           READ :RBLOG RECORD
         CAL1,1   RDRBID            GET THE ID RECORD
         SPACE
*        IF USER SAID X ID GO TO DELETE WSN
         CAL1,1   RDWSN             READ THE WSN RECORD
*        WHICH RETURNS TO XDONE
         SPACE
WORK8    MTW,0    XSW
         BNEZ     RM2               GO DELETE
         SPACE
         BAL,R6   CMOPTS            GO-PROCESS OPTIONS
         SPACE
*        GO TO EXTERNAL SUBROUTINE WHICH INSURES THAT
*        RCB HAS BEEN SPECIFIED ON ALL DEVICES IN RBLOG
*        AND OTHER CHECKS DOCUMENTED IN WVERIFY
         SPACE
         BAL,R14  WVERIFY           IS IT OK
           B      CMOPTS            NO. MSG HAS BEEN TYPED
         CAL1,1   WRRBLOG           WRITE RECORD BACK OUT
XDONE    CAL1,1   WRRBID            WRITE OUT RBID RECORD
         CAL1,1   WRWSN             WRITE THE WSN RECORD
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     RESTART           YES; SKIP CLOSE
WORK6    EQU      %
         CAL1,1   CLSRBLOG
         MTW,-1   RBOPNFLG          RESET FILE OPEN FLAG
         B        RESTART           NEXT COMMAND
RMABN    SLS,SR3  -17
         CI,SR3   X'A01'            :RBLOG BUSY
         BE       SPINN             YES-SPIN UNTIL FREE
         SLS,SR3  -7
         CI,SR3   3                 :RBLOG PRESENT
         BE       WORK4             NO-CREATE
         CI,SR3   X'13'             BAD DELETE OPTION
         ERR      RME3,BNE          YES-ERROR-WS NOT PRESENT
         ERR      RME4              UNABLE TO OPEN :RBLOG
RMERR    LB,SR3   SR3
         MTW,0    LMODE             ARE WE IN LISTING ROUTINE
         BNEZ     RMERR1            YES
         CI,SR3   X'43'             CREATE A NEW RECORD
         BE       WORK1             YES
         ERR      RME4              UNABLE TO OPEN :RBLOG
WORK4    LI,R2    2                 DIRECT ACC.
         LI,R1    8                 OUTIN MODE
         CAL1,1   OPNRBLOG          OPEN :RBLOG
         CAL1,1   WRRBID            CREATE RBID RECORD
         CAL1,1   WRWSN             WRITE THE WSN RECORD
         B        WORK6
WORK1    CAL1,1   RDRBID
         CAL1,1   RDWSN             READ THE WSN RECORD
WORK5    LI,R2    0
         STW,R2   INBUFF+1          ZERO R:FLAG
         STW,R2   INBUFF
         LW,R2    R14               HOLD BAL REG
         BAL,R14  DEF7670           DEFAULT :RBLOG REC
         LW,R14   R2                RESTORE BAL REG
         LD,R0    BLANKS
         STD,R0   KEYNAM            BLANK FILL KEY NAME
         LB,R2    RBUFF             GET HEAD OF FREE
         ERR      RME5,BNE          IF ZERO, NO MORE RBIDS
         LB,R3    RBTBL,R2
         STB,R3   RBUFF             SET NEW HEAD OF FREE
         LI,R1    TOU
         LB,R3    RBUFF,R1          GET TAIL OF USED
         STB,R2   RBUFF,R1          NEW TOU = OLD HEAD OF FREE
         BNEZ     WORK51
         LI,R1    HOU               IF FIRST ENTRY,
         STB,R2   RBUFF,R1          SET HOU = OLD HEAD OF FREE
         B        WORK52
WORK51   STB,R2   RBTBL,R3
WORK52   LI,R1    0
         STB,R1   RBTBL,R2          ZERO TABLE ENTRY FOR NEW RBID
         STB,R2   RBID              ENTER RBID IN RECORD
         LB,R2    KEY
         LB,R1    KEY
         AI,R1    -1
         LB,R3    KEY,R2
         STB,R3   KEYNAM,R1
         BDR,R2   %-3               FORM TEXT KEY NAME LEFT  JUSTIFIED
         LB,R1    RBID              INDEX TO WSN TABLE
         LD,R2    KEYNAM
         STD,R2   WSBUF,R1          PUT THE NEW NAME IN
         B        WORK8             FILL IN OPTIONS
RBID     EQU      INBUFF
RWSFLAG  EQU      INBUFF+1
KEYNAM   EQU      INBUFF+2
MAXPRI   EQU      INBUFF+4
RWSYSFLG EQU      X'1000'           REMOTE WORK STATION :SYS FLAG
RME1     TEXTC    'OPTION VALID ONLY FOR WORK STATION COMMAND'
RME2     TEXTC    'INVALID WORK STATION ID'
RME3     TEXTC    'WORK STATION NOT PRESENT'
RME4     TEXTC    'UNABLE TO OPEN :RBLOG FILE'
RME5     TEXTC    'NO MORE RBIDS'
RMERRMES LB,R2    *R1               BYTES TO PRINT
         M:WRITE  M:LO,(BUF,*R1),(SIZE,*R2),(BTD,1)  PRINT MESSAGE
         MTW,0    FASTFLG           TEST IF FAST MODE
         BNEZ     RESTART           YES
         MTW,0    RBOPNFLG          IS :RBLOG OPEN
         BEZ      RESTART           NO; BACK TO COMMAND LEVEL
         CAL1,1   CLSRBLOG          YES-CLOSE :RBLOG
         B        RESTART           BACK TO COMMAND LEVEL
         PAGE
*
* THE SCAN SUB-ROUTINE PROGRESSES THROUGH THE INPUT COMMAND PICKING UP
* THE NEXT FIELD. IT PROVIDES THE BOOKEEPING TO ALWAYS START AT THE
* BEGINNING OF A FIELD. FIELD TERMINATORS ARE DETERMINED BY THE CONTENTS
* OF TABLE 'TERMS'. LEADING AND TRAILING BLANKS ARE SUPPRESSED AS WELL
* AS SERVING AS A TERMINATOR
*
* ENTRY IS MADE WITH A BAL,SR4 SCAN.
*   R2 =  BYTE DISPLACEMENT WITHIN INPUT FIELD(NEXT FIELDS' STARTING
*         POSITION).
*   R3 =  ADDRESS TO WHERE FIELD IS TO BE MOVED. ZERO IF NO MOVE IS TO
*         TAKE PLACE.
*   R1 =  REMAINING SIZE OF INPUT MESSAGE(ARS).
*
* ON EXIT, THE FOLLOWING IS IN THE REGISTERS:
*   R6 =  FIELD DELIMITER CHARACTER(EXCEPT EOM IS NEVER SEEN-R1=0).
*   R7 =  NUMBER OF CHARACTERS IN FIELD, EXCLUSIVE OF SEPERATORS.
*   SR1 = DESTROYED.
*   R5 =  INDEX INTO TERMS TABLE(CHARACTER TYPE THAT STOPPED THE SCAN).
*   R1 =  AS ABOVE BUT DECREMENTED BY NUMBER OF CHARACTERS SCANNED.
*   R2 =  AS ABOVE POSITIONED TO START OF NEXT FIELD
*
* NOTE-R1=0 IMPLIES END OF MESSAGE.
*
SCAN     LI,SR1   0
         LI,R6    0                 CLEAR TERMINATOR
         LI,R7    0
         CI,R1    0
         ERR      RME2,BG           INVALID WS ID
LOOP     BDR,R1   %+2               TEST FOR END OF MESSAGE AND SET
         B        *SR4              END OF MESSAGE-RETURN-NO TERM CHAR.
         LB,R6    *R0,R2            PICK UP CHAR FROM MESSAGE
         AI,R2    1                 AND INCREMENT TO NEXT POSITION
         CI,R6    ' '               BLANK TEST
         BE       YBLK
         CI,R6    ','
         BE       YBLK              TREAT COMMA AS BLANK
         CI,R6    X'05'             TAB TEST-SAME AS BLANK
         BNE      TERMTST
YBLK     CI,R7    0                 TEST FOR PREVIOUS DATA
         BEZ      LOOP              IGNORE LEADING BLANKS
         AI,SR1   1                 SET BLANK FLAG
         B        LOOP              SUPPRESS TRAILING BLANKS
TERMTST  EQU      %                 SCAN FOR TERMINATING CHARACTERS
         LI,R5    NTERMS
         CB,R6    TERMS,R5
         BE       *SR4              TERM CHAR ENCOUNTERED SO-RETURN
         BDR,R5   %-2
         CI,SR1   0                 NOT A TERMINATOR-TRAILING BLANK ENCO
         BE       CHAROK            NO-CHAR PART OF FIELD
         AI,R1    1                 RESET POSITION TO START OF NEW FIELD
         AI,R2    -1
         LI,R6    ','               SET TERMINATOR TO COMMA
         B        *SR4              AND RETURN
CHAROK   CI,R7    11                MAX LENGTH
         ERR      RME2,BL           INVALID WS ID
         STB,R6   *R3,R7            YES
         AI,R7    1                 COUNT CHARACTER
         B        LOOP              AND GO FOR NEXT ONE
PATCH    DSECT    0
         RES      100
         USECT    SUPERP
         PAGE
HALT     END      START

