ASMB,R,L,C
*     NAME:   SM.SB 
*     SOURCE: 92067-18449 
*     RELOC:  92067-16125 
*     PGMR:   R.D.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
      NAM SM.SB,8 92067-16125 REV.2026 800304 
      ENT SM.SB 
      EXT .ENTR     PARAMETER FETCH ROUTINE 
      EXT $SMD#     OFFSET TO DIRECTORY ENTRY # IN SCB
      EXT $SMID     OFFSET TO USER ID WORD IN SCB 
      EXT APOSN     FMP FILE POSITION ROUTINE 
      EXT CLOS.     INTERNAL FMGR CLOSE ROUTINE 
      EXT CLOSE     FMP FILE CLOSE ROUTINE
      EXT CREAT     FMP FILE CREATE ROUTINE 
      EXT FTIME     FORTRAN'S TIME AND DAY ROUTINE
      EXT I.BUF     INTERNAL (FMGR) DCB 
      EXT IPRSN     PACK SESSION USER NAME (INVERSE PARSE)
      EXT ISMVE     MOVE WORDS FROM SESSION CONTROL BLOCK 
      EXT LOCF      FMP FILE LOCATION ROUTINE 
      EXT NAMR      NAMR PARSE ROUTINE
      EXT O.BUF     INTERNAL (FMGR) DCB 
      EXT OPEN      FMP FILE OPEN ROUTINE 
      EXT OPEN.     INTERNAL FMGR OPEN ROUTINE
      EXT OVRD.     SESSION OVERRIDE OPTION WORD
      EXT PARSN     ACCOUNT NAME PARSE ROUTINE
      EXT POSNT     FMP FILE POSITION ROUTINE 
      EXT PURGE     FMP FILE PURGE ROUTINE
      EXT READF     FMP FILE READ ROUTINE 
      EXT RNRQ      EXEC REQUEST FOR RESOURCE NO. 
      EXT SESSN     DETERMINES IF IN SESSION
      EXT WRITF     FMP FILE WRITE ROUTINE
* 
A     EQU 0 
B     EQU 1 
* 
*  PICK UP PARAMETERS 
* 
IBUFR NOP           USER.GROUP,NAMR,MESSAGE 
ILEN  NOP           LENGTH OF BUFFER (POSITIVE # WORDS) 
IERR  NOP           ERROR RETURN WORD 
SM.SB NOP           SM.SB ENTRY POINT 
      JSB .ENTR     GET PARAMETERS
      DEF IBUFR 
* 
      CLA           INITIALIZE
      STA TEXT      TEXT=1 IF TEXT (STRING) SUPPLIED
      STA FILE      FILE=1 IF NAMR SUPPLIED 
      STA EMPTY     EMPTY=1 IF MSG FILE WAS CREATED BY THIS INVOCATION
      STA RWERR 
      STA TEMP1 
      INA 
      STA ICHAR     INITIALIZE ICHAR=1 FOR PARSN
* 
      JSB SESSN     IN SESSION? 
      DEF *+2 
      DEF XEQT      CURRENT PROGRAM 
      SEZ           SKIP IF IN SESSION (E=0)
      JMP ER45      NOT IN SESSION
      STB ADSCB     SAVE SESSION WORD (IDSEG WD 33) 
* 
      JSB ISMVE     MOVE USER ID FROM SESSION CONTROL BLOCK 
      DEF RTN1
      DEF ADSCB     SCB ADDRESS 
      DEF $SMID     OFFSET TO USER ID IN SCB
      DEF USRID     USER ID RETURNED HERE 
      DEF D1        1 WORD TO BE MOVED
RTN1  EQU * 
* 
      LDA ILEN,I    LENGTH OF COMMAND BUFFER
      ALS           CONVERT WORDS TO CHARACTERS 
      STA LENTH     SAVE NBR OF CHARACTERS IN COMMAND STRING
      JSB PARSN     PARSE USER.GROUP NAME 
      DEF RTN2
      DEF DRTIM     PARSE OUTPUT BUFFER 
      DEF IBUFR,I   INPUT BUFFER
      DEF LENTH     LENGTH OF BUFFER (POSITIVE # OF CHARS)
      DEF ICHAR     NEXT CHAR POSITION TO PARSE 
      DEF JERR      ERROR RETURN WORD 
RTN2  EQU * 
* 
      LDB ADRTM     ADDRESS OF FIRST WORD OF DRTIM BUFFER 
      LDA B,I       GET 1ST WORD OF USER.GROUP PARSE (#CHARS) 
      SZA,RSS       CHECK IF NO USER.GROUP NAME SUPPLIED
      JMP ER55      ERROR - NO USER.GROUP NAME
      AND M377      CHECK FOR GROUP 
      SZA           IS GROUP SPECIFIED? 
      JMP LABL1     YES (NON-ZERO GROUP NAME LENGTH)
      LDA B,I       PUT "7" FOR # OF CHARS.IN GROUP NAME
      IOR D7
      STA B,I 
      ADB D6
      LDA DM4 
      STA CNTR1     SET COUNTER TO MOVE 4 WORDS 
LABL2 LDA ADGNL,I   GET "GENERAL" 
      STA B,I       STORE INTO BUFFER LOCATION
      ISZ ADGNL     GET NEXT WORD 
      INB 
      ISZ CNTR1     FINISHED? 
      JMP LABL2     NO, STORE ANOTHER WORD AWAY 
* 
LABL1 JSB NAMR      PARSE NAMR PARAMETER
      DEF *+5 
      DEF INAM      PARSE OUTPUT BUFFER (10 WORDS)
      DEF IBUFR,I   INPUT BUFFER
      DEF LENTH     TOTAL LENGTH OF IBUFR (POSITIVE# CHARS) 
      DEF ICHAR     STARTING CHARACTER NUMBER IN IBUFR
* 
      LDA INAM      CHECK TO SEE IF NAMR WAS SUPPLIED 
      SZA,RSS       WAS NAMR GIVEN? 
      JMP LABL3     NO,DON'T BOTHER TO OPEN ANY FILES 
* 
      ISZ FILE      SET FLAG INDICATING NAMR WAS SUPPLIED 
* 
      LDA INAM+4    SET UP SECURITY CODE
      STA NOPL
      LDA INAM+5    SET UP CARTRIDGE NUMBER 
      STA NOPL+1
* 
      JSB OPEN.     OPEN NAMR TO BE SENT
      DEF RTN3
      DEF O.BUF     NAMR DCB
      DEF INAM      FILE NAMR OR LU 
      DEF NOPL      SECURITY CODE, CRN
      DEF IOPTN 
RTN3  EQU * 
* 
LABL3 LDA ICHAR     CURRENT CHARACTER POSITION
      CLE,ERA       CONVERT CHARACTERS TO WORDS 
      SEZ           TEST IF ODD NUMBER OF CHARACTERS
      ISZ TEMP1     YES, SET BYTE FLAG
      SEZ,RSS       TEST IF ODD NUMBER OF CHARACTERS
      ADA DM1       NO, SUBTRACT ONE
      STA ISTRW     SAVE CURRENT WORD POSITION
      ADA IBUFR 
      STA TEMP
      STA LBUFR 
* 
      JSB NAMR      CHECK FOR TEXT (STRING) 
      DEF *+5 
      DEF INAM2     OUTPUT BUFFER 
      DEF IBUFR,I   INPUT BUFFER
      DEF LENTH     TOTAL LENGTH OF IBUFR (POSITIVE# CHARS) 
      DEF ICHAR     NEXT CHARACTER POSITION TO PARSE
* 
      LDA INAM2     GET FIRST WORD OF OUTPUT BUFFER 
      SZA,RSS       IS THERE ANY TEXT?
      JMP LABL5     NO
      ISZ TEXT      SET FLAG=1 INDICATING TEXT WAS GIVEN
      LDA TEMP1     YES CHECK BYTE POSTION
      SZA           IS THERE ANY REMAINDER
      JMP LABL6     NO
      LDA TEMP,I    1ST WORD OF TEXT (STRING) 
      AND M377      MASK OFF CHARACTER
      IOR M2000     MERGE BLANK IN LEFTMOST BYTE
      STA TEMP,I    STORE BACK IN BUFFER
LABL6 LDA ISTRW     COMPUTE LENGTH OF TEXT
      CMA,INA 
      ADA ILEN,I
      STA WRDCT     LENGTH OF TEXT IN WORDS 
      JMP LAB.5 
* 
*    CALCULATE STRING LENGTH
* 
LABL5 LDA FILE      CHECK TO SEE IF NAMR WAS SUPPLIED 
      SZA 
      JMP LAB.5     YES 
      LDA D50       NO, ERROR - NEITHER NAMR NOR TEXT SUPPLIED
      JMP EXIT      ERROR EXIT - NOT ENOUGH PARAMETERS
* 
LAB.5 LDA SECU
      STA NOPL      SET SECURITY CODE 
      CLA 
      STA NOPL+1    SET CRN 
* 
      LDA OVRD.     OVERRIDE FLAG TO ALLOW SYS DISC WRITE 
      STA TEMP      SAVE IT'S CURRENT STATE 
      IOR M2000     SET TO ALLOW SYS DISC WRITE 
      STA OVRD. 
      JSB OPEN      OPEN THE ACCOUNT FILE 
      DEF RTN4
      DEF I.BUF     DCB(ACCOUNT)
      DEF JERR      ERROR RETURN WORD 
      DEF ACCT      ACCOUNT NAME=+@CCT! 
      DEF D1        NON-EXCLUSIVE OPEN OPTION 
      DEF NOPL      SECURITY CODE 
      DEF NOPL+1    DISC
RTN4  EQU * 
      LDA TEMP      GET SAVED OVERRIDE FLAG 
      STA OVRD.     RESTORE PREVIOUS OVERRIDE VALUE 
      LDA JERR      GET ERROR CODE
      SSA           OPEN ERROR? 
      JMP EXIT      YES 
* 
*  READ ACCOUNT FILE HEADER 
* 
      JSB READF 
      DEF RTN5
      DEF I.BUF     DCB OF ACCOUNT FILE 
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF      BUFFER LOCATION 
      DEF D128      ONE RECORD LENGTH 
      DEF LEN       NUMBER OF WORDS READ
RTN5  EQU * 
* 
      LDA DFIBF     GET LOCATION OF DIRECTORY 
      ADA D24       OFFSET TO RESOURCE NUMBER WORD
      LDA A,I       GET RESOURCE NUMBER TO USE
      STA RESNO 
      JSB RNRQ      LOCK RESOURCE NUMBER FOR ACCT FILE WRITE
      DEF RTN40 
      DEF D1
      DEF RESNO     RESOURCE NUMBER 
      DEF ISTAT     STATUS RETURN 
RTN40 EQU * 
* 
      JSB READF     RE-READ ACCOUNT FILE HEADER 
      DEF RTN7
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF
      DEF D128      NUMBER OF WORDS TO READ 
      DEF LEN       NUMBER OF WORDS READ
      DEF D1        RECORD #1 
RTN7  EQU * 
      LDA DFIBF     START OF BUFFER IBUF
      STA B 
      ADA D4        BUMP TO DIRECTORY LOCATION WORD 
      LDA A,I 
      STA DIRNO     RECORD # OF START OF DIRECTORY
      STA DIR## 
      ADB D5
      LDA B,I 
      STA ADACT     LOCATION OF 1ST ACCOUNT ENTRY 
      ADB D20 
      LDA B,I       LU # OF MESSAGE FILES 
      STA MSGLU 
      SZA,RSS       IF NO LU # SPECIFIED FOR MSG FILES, 
      LDA DM2       DEFAULT TO LU 2 
      STA LUNO.     SAVE LU # OF MSG FILES
* 
*  FINDING USER'S ACCOUNT 
* 
LAB80 LDA DM8 
      STA CNTR1 
      JSB READF     READ IN ACCOUNT FILE DIRECTORY
      DEF RTN.5 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF
      DEF D128      NUMBER OF WORDS TO READ 
      DEF LEN       NUMBER OF WORDS READ
      DEF DIR##     RECORD NUMBER OF DIRECTORY
RTN.5 EQU * 
      LDA D73       SET UP ERROR: ACCOUNT NOT FOUND 
      STA JERR
      LDA DFIBF     KEEP POINTER TO DIRECTORY 
      STA TEMP2 
      STA TEMP      TEMP WILL POINT TO ENTRIES IN DIRECT. 
LABL9 LDA TEMP,I    GET # OF CHARACTERS IN NAME 
      SZA,RSS 
      JMP ERROR 
      CPA DRTIM     IS IT EQUAL TO # OF CHARS. IN PARM. IN NAME 
      JMP LAB85     YES, CHECK LETTER FOR LETTER
LABL8 LDA TEMP2     NO GET NEXT DIRECTORY ENTRY 
      ADA D16       16 WORDS PER DIRECTORY
      STA TEMP2     UPDATE PTR. 
      STA TEMP
      ISZ CNTR1     CNTR1 INITIALIZED TO -8 
      JMP LABL9 
      ISZ DIR## 
      JMP LAB80 
LAB85 LDA DM10
      STA CNTR
      LDA ADRTM     FIRST WORD OF DIR. ENTRY AND BUFFER CONTAINING
      STA TEMP1      NAME ARE = 
LAB95 ISZ TEMP1     INCREMENT BOTH BUFFERS TO THE 
      ISZ TEMP        NEXT WORDS
      LDA TEMP,I    ARE THEY THE SAME 
      CPA TEMP1,I 
      RSS           YES THEY ARE
      JMP LABL8     NO, FIND ANOTHER DIR ENTRY
      ISZ CNTR      DECREMENT COUNTER 
      JMP LAB95     CHECK ANOTHER WORD
* 
* 
*  YES FOUND ENTRY
* 
      LDA TEMP2 
      ADA D14       GET WORD 15(USER ACCT RECORD #) 
      LDA A,I       SEE IF BIT 15 IS SET
      CLB 
      SSA           IS IT SET 
      LDB D64       YES,ACCOUNT IS 2ND 64 WORDS 
      STB OFFST     NO ACCOUNT IS IN FIRST RECORD 
      AND M7777     REMOVE SIGN BIT 
      STA USACT     USER ACCOUNT RECORD # 
* 
* NOW READ IN USER ACCOUNT ENTRY
* 
      JSB READF     READ IN USER ACCOUNT FILE 
      DEF RTN12 
      DEF I.BUF 
      DEF JERR
      DEF UBUF      BUFFER FOR USER ACCOUNT 
      DEF D128      WHILE RECORD IS READ
      DEF LEN 
      DEF USACT 
RTN12 EQU * 
* 
*   GET USER MESSAGE FILE NAME THEN OPEN FILE 
* 
      LDA ADBUF 
      ADA D16       PICK UP ADDRESS OF NAME 
      ADA OFFST     ADD IN OFFSET 
      LDB A,I 
      STB NAME      STORE IN NAME IN 3 WORD ARRAY 
      INA 
      LDB A,I 
      STB NAME+1
      INA 
      LDB A,I 
      STB NAME+2    PUT 3RD CHAR. AWAY
      INA 
      INA 
      LDB A,I 
      SSB,RSS       CHECK IF MESSAGE FILE EXISTS
      JMP CREA1 
LAB10 LDA OVRD. 
      STA TEMP
      IOR M2000 
      STA OVRD. 
      JSB OPEN      OPEN USER MESSAGE FILE
      DEF RTN13 
      DEF FDCB      MESSAGE FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF NAME      MESSAGE FILE NAME 
      DEF D1
      DEF SECU      SECURITY CODE 
RTN13 EQU * 
      LDA TEMP
      STA OVRD. 
* 
      LDA JERR
      SSA,RSS       CHECK FOR ERROR 
      JMP LAB11     NO
      CPA DM6       IF MESSAGE FILE NOT FOUND,
      JMP CREA1     CREATE IT 
      JMP ERROR     ELSE RETURN THE OPEN ERROR
* 
*   IF MESSAGE ISN'T CREATED THEN CREATE IT 
* 
CREA1 LDA OVRD. 
      STA TEMP
      IOR M2000 
      STA OVRD. 
      JSB CREAT     CREATE MESSAGE FILE 
      DEF RTN32 
      DEF FDCB      MESSAGE FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF NAME      MESSAGE FILE NAME 
      DEF DM1       FILE SIZE TO CREATE 
      DEF D3        FILE TYPE 
      DEF SECU      SECURITY CODE 
      DEF LUNO.     LU OF MESSAGE FILES 
      DEF D0
      DEF D0
      DEF D0
      DEF M707      BYPASS LEGAL FILE NAME TEST 
RTN32 EQU * 
      LDA TEMP
      STA OVRD. 
* 
      LDA JERR
      SSA,RSS       CHECK FOR CREATE ERROR
      JMP LAB22     NO ERROR
      CPA DM2       IF FILE ALREADY EXISTS, 
      JMP LAB10     OPEN IT AND POSITION IT TO EOF
      CPA DM33      IF NO ROOM ON LU, 
      RSS           THEN TEST IF LU 2 
      JMP ERROR     ELSE JUST REPORT CREATE ERROR 
      LDA MSGLU     GET LU # OF MESSAGE FILES 
      SZA           SPECIFIED?
      JMP ERROR     YES, REPORT -33 ERROR 
      LDA SECT3     SECTORS/TRACK ON LU 3 
      SZA,RSS       IF 0, NO LU 3 
      JMP ERROR     NO LU 3, REPORT -33 ERROR 
      LDA LUNO. 
      CPA DM3       ALREADY TRIED LU 3? 
      JMP ERROR     YES, RETURN -33 ERROR 
      LDA DM3       LU 3 EXISTS, TRY CREATE ON LU 3 
      STA LUNO. 
      JMP CREA1 
* 
*  FIND EOF OF USER MESSAGE FILE
* 
LAB11 JSB READF     READ MESSAGE FILE UNTIL THE 
      DEF RTN14       IERR WORD HAS A -12 IN IT 
      DEF FDCB
      DEF JERR        OR THE LEN WORD IS -1 
      DEF UBUF      BUFFER FOR READ INPUT 
      DEF D128
      DEF LEN 
RTN14 EQU * 
* 
      LDA JERR      DOES IT =-12
      CPA DM12
      JMP LAB25     YES FOUND END OF FILE 
      LDA LEN 
      CPA DM1       LEN=-1? 
      JMP LAB25     YES, END OF FILE
      SSA,RSS 
      JMP LAB11 
      JMP ERROR     READ ERROR
* 
LAB25 JSB LOCF      FIND POSITION OF EOF
      DEF RTN16 
      DEF FDCB
      DEF JERR
      DEF FIREC     RECORD NUMBER 
      DEF FIRB      NEXT BLOCK
      DEF FIOFF     OFFSET WITHIN BLOCK 
RTN16 EQU * 
* 
      JSB WRITF     PUT ZERO-LENGTH RECD BETWEEN MESSAGES 
      DEF RTN15 
      DEF FDCB
      DEF JERR
      DEF IBUF
RTN15 EQU * 
* 
*  GET TIME OF DAY AND SENDER OF MESSAGE
* 
      RSS 
LAB22 ISZ EMPTY     SET FLAG TO INDICATE FILE WAS CREATED 
      LDA DM30
      STA CNTR
      LDB ADBUF 
      LDA BLNK
UP    STA B,I 
      INB 
      ISZ CNTR
      JMP UP
* 
      JSB FTIME     GET TIME OF DAY 
      DEF RTN18 
      DEF UBUF+15   BUFFER FOR TIME OF DAY
RTN18 EQU * 
* 
*     GET SENDER'S NAME 
* 
      LDA DIRNO     START OF DIRECTORY
      STA DIR## 
* 
      JSB ISMVE     GET DIRECTORY ENTRY # FROM SCB
      DEF RTN55 
      DEF ADSCB     ADDRESS OF SESSION CONTROL BLOCK
      DEF $SMD#     OFFSET TO DIRECTORY ENTRY # WORD IN SCB 
      DEF DNUM      DIRECTORY ENTRY # RETURN WORD 
      DEF D1        1 WORD TO BE MOVED
RTN55 EQU * 
* 
      LDA DNUM      DIRECTORY ENTRY # 
      CLB           COMPUTE ACCT FILE RECORD CONTAINING DIR. ENTRY
      DIV D8
      ADA DIRNO     ADD RECORD NUMBER OF START OF DIRECTORY 
      STA DNUM      SAVE RECORD NUMBER
      BLF           COMPUTE OFFSET INTO RECORD IN WORDS 
      STB TEMP      TEMPORARY SAVE
* 
      JSB READF     READ RECORD CONTAINING DIRECTORY ENTRY
      DEF RTN56 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF IERR,I    ERROR RETURN
      DEF IBUF
      DEF D128      NUMBER OF WORDS TO READ 
      DEF LEN       NUMBER OF WORDS READ
      DEF DNUM      RECORD NUMBER TO READ 
RTN56 EQU * 
* 
      LDA DFIBF     ADDRESS OF 1ST WORD OF IBUF 
      ADA TEMP      OFFSET TO DIRECTORY ENTRY 
      STA TEMP
* 
      JSB IPRSN     INVERSE PARSE TO BUILD SENDER NAME STRING 
      DEF *+4 
      DEF TEMP,I
      DEF UBUF
      DEF D1
* 
*  READ USER ACCOUNT AND SET MESSAGES WAITING BIT 
* 
      JSB READF     READ USER'S ACCOUNT 
      DEF RTN34 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF      BUFFER FOR 128-WORD ACCOUNT FILE RECORD 
      DEF D128      128 WORDS TO BE READ
      DEF LEN       NUMBER OF WORDS ACTUALLY READ 
      DEF USACT     ACCOUNT FILE RECORD NUMBER
RTN34 EQU * 
* 
      LDB DFIBF     ADDRESS OF IBUF 
      ADB OFFST     ADD OFFSET (0 OR 64)
      ADB D20       OFFSET TO "MESSAGE FILE EXISTS" WORD
      LDA B,I 
      IOR M1000     SET MESSAGE WAITING BIT 
      STA B,I       SAVE IT 
* 
      JSB POSNT     RE-POSITION TO USER RECORD NUMBER 
      DEF RTN35 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF USACT     ACCOUNT FILE RECORD NUMBER
      DEF D1        FLAG TO POSNT 
RTN35 EQU * 
* 
      JSB WRITF     WRITE NEW USER ACCOUNT
      DEF RTN41 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF      BUFFER WITH NEW ACCOUNT 
      DEF D128
RTN41 EQU * 
* 
      JSB RNRQ      RELEASE THE RN LOCK 
      DEF RTN42 
      DEF D4
      DEF RESNO     RESOURCE NUMBER 
      DEF ISTAT     STATUS RETURN 
RTN42 EQU * 
* 
      JSB WRITF     WRITE HEADER TO MESSAGE FILE
      DEF RTN19 
      DEF FDCB      MESSAGE FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF UBUF      HEADER BUFFER (SENDER NAME, DATE) 
      DEF D30 
RTN19 EQU * 
* 
      LDA JERR
      CPA DM33      CHECK IF NO ROOM FOR WRITE
      JMP BKUP      NO ROOM, SO PURGE CURRENT MESSAGE 
      CPA DM46      CHECK IF GREATER THAN 255 EXTENTS 
      JMP BKUP      YES, SO PURGE CURRENT MESSAGE 
      LDA TEXT      IF TEXT WAS SUPPLIED (TEXT=1), THEN 
      SZA,RSS       WRITE IT TO MESSAGE FILE
      JMP LAB15     TEXT NOT SUPPLIED 
* 
      JSB WRITF     WRITE TEXT (STRING) TO MESSAGE FILE 
      DEF RTN30 
      DEF FDCB      MESSAGE FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF LBUFR,I   BUFFER CONTAINING TEXT
      DEF WRDCT     LENGTH OF TEXT (WORDS)
RTN30 EQU * 
* 
      LDA JERR
      CPA DM33      CHECK IF NO ROOM FOR WRITE
      JMP BKUP      NO ROOM, SO PURGE CURRENT MESSAGE 
      CPA DM46      CHECK IF GREATER THAN 255 EXTENTS 
      JMP BKUP      YES, SO PURGE CURRENT MESSAGE 
* 
LAB15 LDA FILE      TEST IF NAMR SPECIFIED (FILE=1) 
      SZA,RSS 
      JMP LAB18     NOT SPECIFIED, SKIP NAMR READ-WRITE 
* 
      JSB READF     READF FROM USER SUPPLIED NAMR 
      DEF RTN20 
      DEF O.BUF     DCB 
      DEF KERR      ERROR RETURN WORD 
      DEF UBUF      BUFFER
      DEF D128
      DEF LEN 
RTN20 EQU * 
      LDA KERR
      STA RWERR 
* 
      JSB WRITF     NO, WRITE TO MESSAGE FILE 
      DEF RTN21 
      DEF FDCB      DCB OF MESSAGE FILE 
      DEF JERR
      DEF UBUF
      DEF LEN       NUMBER OF WORDS TO BE WRITTEN 
RTN21 EQU * 
* 
      LDA LEN       END OF FILE?
      CPA DM1 
      JMP LAB16     YES, CLOSE FILE 
* 
      LDA KERR
      CPA DM12      END OF FILE?
      JMP LAB16 
* 
      LDA JERR
      SSA 
      STA RWERR 
      CPA DM33      CHECK IF NO ROOM FOR WRITE
      JMP BKUP      NO ROOM, SO PURGE CURRENT MESSAGE 
      CPA DM46      CHECK IF GREATER THAN 255 EXTENTS 
      JMP BKUP      GREATER THAN 255 EXTENTS, SO PURGE
      LDA RWERR 
      SSA,RSS 
      JMP LAB15 
* 
*  BACK UP MESSAGE FILE TO PREVIOUS MESSAGE, OR PURGE FILE IF NONE
* 
BKUP  LDA EMPTY     EMPTY=1 IF FILE WAS CREATED BY THIS INVOCATION
      SZA,RSS       WAS FILE CREATED BY THIS INVOCATION?
      JMP BKUP2     NO, ALREADY EXISTED - BACK UP TO PREVIOUS MESSAGE 
* 
      LDA OVRD.     OVERRIDE FLAG TO ALLOW SYS DISC WRITE 
      STA TEMP      SAVE IT'S CURRENT STATE 
      IOR M2000     SET TO ALLOW SYS DISC WRITE 
      STA OVRD. 
      JSB PURGE     YES, PURGE MESSAGE FILE 
      DEF RTN72 
      DEF FDCB      MESSAGE FILE DCB
      DEF IERR,I    ERROR RETURN WORD 
      DEF NAME      MESSAGE FILE NAME 
      DEF SECU      SECURITY CODE 
      DEF LUNO. 
RTN72 EQU * 
      LDA TEMP      GET SAVED OVERRIDE FLAG 
      STA OVRD.     RESTORE PREVIOUS OVERRIDE VALUE 
* 
      JSB RNRQ      GET THE RN LOCK AGAIN 
      DEF RTN49 
      DEF D1
      DEF RESNO     RESOURCE NUMBER 
      DEF ISTAT     STATUS RETURN 
RTN49 EQU * 
* 
      JSB READF     READ USER'S ACCT TO CLEAR MESSAGES WAITING BIT
      DEF RTN45 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF      BUFFER FOR 128-WORD ACCOUNT FILE RECORD 
      DEF D128      128 WORDS TO BE READ
      DEF LEN       NUMBER OF WORDS ACTUALLY READ 
      DEF USACT     ACCOUNT FILE RECORD NUMBER
RTN45 EQU * 
* 
      LDB DFIBF     ADDRESS OF IBUF 
      ADB OFFST     ADD OFFSET (0 OR 64 WORDS)
      ADB D20       OFFSET TO "MESSAGE FILE EXISTS" WORD
      CLA           CLEAR THE MESSAGES WAITING BIT
      STA B,I       SAVE IT 
* 
      JSB POSNT     RE-POSITION TO USER RECORD NUMBER 
      DEF RTN46 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF USACT     ACCOUNT FILE RECORD NUMBER
      DEF D1        FLAG TO POSNT 
RTN46 EQU * 
* 
      JSB WRITF     WRITE NEW USER ACCOUNT
      DEF RTN47 
      DEF I.BUF     ACCOUNT FILE DCB
      DEF JERR      ERROR RETURN WORD 
      DEF IBUF      BUFFER WITH NEW ACCOUNT 
      DEF D128
RTN47 EQU * 
* 
      JSB RNRQ      RELEASE THE RN LOCK 
      DEF RTN48 
      DEF D4
      DEF RESNO     RESOURCE NUMBER 
      DEF ISTAT     STATUS RETURN 
RTN48 EQU * 
      JMP ERROR 
* 
BKUP2 JSB APOSN     POSITION TO END OF PREVIOUS MESSAGE 
      DEF RTN73 
      DEF FDCB      MESSAGE FILE DCB
      DEF IERR,I    ERROR RETURN WORD 
      DEF FIREC 
      DEF FIRB
      DEF FIOFF 
RTN73 EQU * 
* 
      JSB WRITF     WRITE EOF 
      DEF RTN74 
      DEF FDCB      MESSAGE FILE DCB
      DEF IERR,I    ERROR RETURN WORD 
      DEF UBUF
      DEF DM1 
RTN74 EQU * 
      JMP ERROR 
* 
LAB16 JSB CLOS.     CLOSE OUT MESSAGE FILE TO CLEAR DCB 
      DEF RTN75 
      DEF O.BUF 
RTN75 EQU * 
* 
*     NOW CLOSE FILE WITH TRUNCATE
* 
LAB18 JSB LOCF      FIND POSITION OF EOF
      DEF RTN22 
      DEF FDCB
      DEF JERR
      DEF IREC      RECORD NUMBER 
      DEF IRB       NEXT BLOCK
      DEF IOFF      OFFSET WITHIN BLOCK 
      DEF JSEC      SECTOR
RTN22 EQU * 
* 
*  CALCULATE THE NUMBER OF BLOCKS TO TRUNCATE 
*  ITRUN=JSEC/2-IRB-1 
* 
      LDA JSEC      GET NUMBER OF SECTORS 
      CLB 
      DIV D2        DIVIDE BY 2  (2 SECTORS/BLOCK)
      LDB IRB       GET BLOCK 
      CMB,INB 
      ADA B         SUBTRACT
      ADA DM1       SUBTRACT 1
      STA ITRUN     NUMBER OF BLOCKS TO TRUNCATE
      CLA           CLEAR ERROR RETURN WORD 
      JMP EXIT
ERROR JSB RNRQ      RELEASE RESOURCE NUMBER 
      DEF RTN43 
      DEF D4        CODE FOR CLEARING RN
      DEF RESNO     RESOURCE NUMBER FOR ACCT FILE WRITE 
      DEF ISTAT     RETURN BUFFER FROM RNRQ 
RTN43 EQU * 
* 
      LDA RWERR 
      SSA,RSS 
      JMP EXITA 
      JMP EXIT
ER45  LDA D45       SESSION COMMAND ONLY
      RSS 
ER55  LDA D55       MISSING PARAMETER 
      RSS 
EXITA LDA JERR
EXIT  STA IERR,I
* 
*  NOW CLOSE WITH TRUNCATE
* 
      JSB CLOS.     CLOSE USER'S NAMR 
      DEF RTN23 
      DEF O.BUF 
RTN23 EQU * 
      JSB CLOSE     CLOSE MESSAGE FILE
      DEF RTN24 
      DEF FDCB
      DEF JERR
      DEF ITRUN 
RTN24 EQU * 
* 
*  CLOSE ACCOUNT FILE 
* 
      JSB CLOSE     CLOSE ACCOUNT 
      DEF RTN25 
      DEF I.BUF 
RTN25 EQU * 
* 
* 
* 
      JMP SM.SB,I 
* 
ACCT  ASC 3,+@CCT!
ADACT BSS 1 
ADBUF DEF UBUF
ADRTM DEF DRTIM 
ADSCB BSS 1 
BLNK  ASC 1,
CNTR  BSS 1 
CNTR1 BSS 1 
XEQT  EQU 1717B     ID SEG ADDR OF CURRENT PROGRAM
DRTIM BSS 11        DIRECTORY IMAGE CONTAINS USER.GROUP NAME
DFIBF DEF IBUF      ADDRESS OF IBUF 
DIR## BSS 1 
DIRNO BSS 1 
DNUM  BSS 1 
DM46  DEC -46 
DM33  DEC -33 
DM30  DEC -30 
DM12  DEC -12 
DM10  DEC -10 
DM8   DEC -8
DM6   DEC -6
DM4   DEC -4
DM3   DEC -3
DM2   DEC -2
DM1   DEC -1
D0    DEC 0 
D1    DEC 1 
D2    DEC 2 
D3    DEC 3 
D4    DEC 4 
D5    DEC 5 
D6    DEC 6 
D7    DEC 7 
D8    DEC 8 
D14   DEC 14
D16   DEC 16
D20   DEC 20
D24   DEC 24
D30   DEC 30
D45   DEC 45
D50   DEC 50
D55   DEC 55
D73   DEC 73
D64   DEC 64
D128  DEC 128 
M377  OCT 377 
M7777 OCT 77777 
M1000 OCT 100000
M2000 OCT 20000 
M707  OCT 70707 
EMPTY BSS 1         EMPTY=1 IF MESSAGE FILE CREATED BY THIS INVOCATION
FDCB  BSS 144 
FILE  BSS 1         FILE=1 IF NAMR SUPPLIED 
FIOFF BSS 1 
FIRB  BSS 1 
FIREC BSS 1 
ADGNL DEF GENRL     ADDRESS OF ASCII "GENERAL"
GENRL ASC 4,GENERAL 
IBUF  BSS 128 
ICHAR BSS 1 
INAM2 BSS 10
INAM  BSS 10        10 WRD OUTPUT BUFFER FOR NAMR ROUTINE 
IOPTN OCT 401       OPEN OPTION WORD
IRB   BSS 1         NEXT BLOCK
IREC  BSS 1         NEXT BLOCK
ISTAT BSS 1 
ISTRW BSS 1 
ITRUN BSS 1 
IOFF  BSS 1         OFFSET WITHIN BLOCK 
JERR  BSS 1 
JSEC  BSS 1         SECTOR WITHIN BLOCK 
KERR  BSS 1 
LBUFR BSS 1 
LEN   BSS 1         NUMBER OF WORDS READ FROM READ CALL 
LENTH BSS 1         LENGTH OF BUFFER TO BE PARSED 
LUNO. BSS 1 
MSGLU BSS 1         LU OF MESSAGE FILES FROM ACCT FILE
NAME  BSS 3 
NOPL  BSS 2         SECURITY CODE, CRN
OFFST BSS 1 
RESNO BSS 1         RESOURCE NO. FROM ACCOUNT FILE
RWERR BSS 1 
SECT3 EQU 1760B 
SECU  DEC -31178
TEMP  BSS 1 
TEMP1 BSS 1 
TEMP2 BSS 2 
TEXT  BSS 1         TEXT=1 IF TEXT (STRING) SUPPLIED
UBUF  BSS 128 
USACT BSS 1         USER ACCOUNT RECORD # 
USRID BSS 1         SENDER'S SESSION ID 
WRDCT BSS 1 
      END