$CONTROL MAP,CODE,USLINIT                                               00010000
<< USER -- MODULE 83 >>                                        <<00762>>00015000
<< HP32002C MPE SOURCE C.00.00 >>                                       00020000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$CONTROL SEGMENT=USER,MAIN=USER << MODULE 83 >>                         00055000
BEGIN                                                                   00060000
                                                                        00065000
                                                                        00070000
<< ERRORS FOR GENMESSAGE PROCEDURES >>                                  00075000
                                                                        00080000
EQUATE                                                                  00085000
   READLABELFAIL     = 1,                                               00090000
   READFAIL          = 2,                                               00095000
   MISSINGSET        = 3,                                               00100000
   MISSINGMSG        = 4,                                               00105000
   DON'T''USE''THIS  = 5,  << SAME AS 6--DOC ERR KLUGE >>      <<01526>>00110000
   BUFFOVERFLOW      = 6,                                               00115000
   WRITEFAIL         = 7,                                      <<01128>>00120000
   BADFILEOPTIONS    = 8,                                      <<01526>>00125000
                                                                        00130000
   NOFILENOPARM      = 11,                                              00135000
   NOSETNOPARM       = 12,                                              00140000
   NOMSGNOPARM       = 13,                                              00145000
   INVSETNO          = 14,                                              00150000
   SETNOTOOBIG       = 15,                                              00155000
   INVMSGNO          = 16,                                              00160000
   INVBUFFSIZE       = 17,                                              00165000
   INVDESTFILE       = 18,                                              00170000
   ZENDOFERRORS      = 0;                                               00175000
                                                                        00180000
<< SIZES & CELLS FOR GENMESSAGE PROCEDURES >>                           00185000
                                                                        00190000
EQUATE                                                                  00195000
   HEADERSIZE        =  2,                                     <<00762>>00200000
   MAXNOSETS         = 62, <<(SECTOR-HEADER-WORKAREA)/2>>      <<00762>>00205000
   MSGDIRSIZE        = MAXNOSETS*2+HEADERSIZE+2<<WORK AREA>>,  <<00762>>00210000
   MAXSETNOCELL      =  0,                                              00215000
   MAXRECELL         =  1,                                              00220000
   CURRENTRECELL     = MSGDIRSIZE-1,                           <<00762>>00225000
   RECSIZE           = 40,                                              00230000
   RECSIZEB          = RECSIZE*2,                                       00235000
   RECSIZEM1         = RECSIZE -1,                                      00240000
   DATASIZE          = 36,                                              00245000
   DATASIZEB         = 72,                                              00250000
   BLKFACTOR         = 16,                                              00255000
   PHYSBLK           = 16*40,                                           00260000
   SECTORPERBLK      = PHYSBLK/128,                                     00265000
   SETNOTPRESENT     = -1,                                              00270000
                                                                        00275000
   ZENDOFSIZES       = 0;                                               00280000
                                                                        00285000
                                                                        00290000
INTEGER                                                                 00295000
   X = X,                                                               00300000
   S6 = S-6;                                                            00305000
                                                                        00310000
BYTE POINTER                                                            00315000
   BPS0 = S-0;                                                          00320000
                                                                        00325000
DOUBLE POINTER                                                          00330000
   DPS0 = S-0;                                                          00335000
                                                                        00340000
EQUATE                                                                  00345000
   CCG = 0,                                                             00350000
   CCL = 1,                                                             00355000
   CCE = 2;                                                             00360000
                                                                        00365000
LOGICAL                                                                 00370000
   STATUS = Q-1;                                                        00375000
                                                                        00380000
DEFINE                                                                  00385000
   CONDCODE = STATUS.(6:2)#;                                            00390000
                                                                        00395000
DEFINE                                                                  00400000
   CCGRETN       = BEGIN                                                00405000
                      CONDCODE := CCG;                                  00410000
                      GO OUTL;                                          00415000
                   END#,                                                00420000
   CCLRETN       = BEGIN                                                00425000
                      CONDCODE := CCL;                                  00430000
                      GO OUTL;                                          00435000
                   END#,                                                00440000
   ZENDOFDEFINES = 0#;                                                  00445000
                                                               << 8208>>00450000
EQUATE                                                         << 8208>>00455000
  INVALID'JOB'TYPE = 5013;                                     << 8208>>00460000
                                                                        00465000
                                                                        00470000
INTRINSIC WHO,ASCII,BINARY,CLOCK,CALENDAR,DASCII,PRINT,                 00475000
   FWRITE,FREADDIR,FREADLABEL;                                          00480000
                                                                        00485000
INTEGER PROCEDURE GETNUM(PTR,NUM); VALUE PTR;                           00490000
   BYTE POINTER PTR;INTEGER NUM;OPTION FORWARD;                         00495000
                                                                        00500000
   << FORWARDS >>                                                       00505000
                                                                        00510000
                                                                        00515000
PROCEDURE FMTDATE(CALENDAR',CLOCK',STRING);                             00520000
   VALUE CALENDAR',CLOCK';                                              00525000
   LOGICAL CALENDAR';                                                   00530000
   DOUBLE CLOCK';                                                       00535000
   BYTE ARRAY STRING;                                                   00540000
   OPTION FORWARD;                                                      00545000
                                                                        00550000
PROCEDURE LENBUF(BUFF,LEN,CRLF,RECNO);                                  00555000
   BYTE ARRAY BUFF;                                                     00560000
  INTEGER LEN;                                                 <<02339>>00565000
  DOUBLE RECNO;                                                <<02339>>00570000
   LOGICAL CRLF;                                                        00575000
   OPTION FORWARD;                                                      00580000
                                                                        00585000
PROCEDURE READCAT(FILENO,RECNO,CURRENTREC,BLOCKBUFF',                   00590000
      BUFFPTR);                                                         00595000
   VALUE FILENO,RECNO;                                                  00600000
   INTEGER FILENO,CURRENTREC;                                  <<02339>>00605000
   DOUBLE RECNO;                                               <<02339>>00610000
   ARRAY BLOCKBUFF';                                                    00615000
   BYTE POINTER BUFFPTR;                                                00620000
   OPTION FORWARD;                                                      00625000
                                                                        00630000
                                                                        00635000
$TITLE "CONVERTDATE"                                                    00640000
LOGICAL PROCEDURE CONVERTDATE(PTR);                                     00645000
   VALUE PTR;                                                           00650000
   BYTE POINTER PTR;                                                    00655000
COMMENT                                                                 00660000
   CONVERTS STRING CONTAINING "MM/DD/YY" INTO A WORD OF THE             00665000
   FOLLOWING FORMAT:                                                    00670000
            CONVERTDATE.(0:7) = YEAR                                    00675000
            CONVERTDATE.(7:9) = DAY OF YEAR                             00680000
   STRING MUST BE TERMINATED BY NON-NUMERIC. ERROR RETURNS CCG.         00685000
   DATE ARRAY MAY CONTAIN LEADING BLANKS AS WELL AS BLANKS              00690000
   BETWEEN SLASHES. ANY SPECIAL CAN BE USED INSTEAD OF "/"              00695000
;                                                                       00700000
BEGIN                                                                   00705000
                                                                        00710000
EQUATE                                                                  00715000
   CCG = 0,                                                             00720000
   CCE = 2;                                                             00725000
                                                                        00730000
LOGICAL STATUS = Q-1;                                                   00735000
                                                                        00740000
INTEGER                                                                 00745000
   MONTH,                                                               00750000
   DAY,                                                                 00755000
   YEAR;                                                                00760000
INTEGER ARRAY FIRSTDAY(*) = PB :=                                       00765000
   0,31,59,90,120,151,181,212,243,273,304,334;                          00770000
INTEGER ARRAY DAYSINMONTH(*) = PB :=                                    00775000
   31,28,31,30,31,30,31,31,30,31,30,31;                                 00780000
                                                                        00785000
STATUS.(6:2) := CCG; << SET BAD >>                                      00790000
@PTR := GETNUM(PTR,MONTH);                                              00795000
IF = AND PTR = "/" THEN                                                 00800000
BEGIN                                                                   00805000
   @PTR := GETNUM(PTR(1),DAY);                                          00810000
   IF = AND PTR = "/" THEN                                              00815000
   BEGIN                                                                00820000
      GETNUM(PTR(1),YEAR);                                              00825000
      IF = AND (1<= MONTH <= 12) AND (1<= DAY <= 31)                    00830000
         AND ( 1 <= YEAR <= 99 ) THEN                          <<01505>>00835000
      BEGIN << RANGE ON MONTH,DAY,YEAR OK >>                            00840000
         IF DAY <= DAYSINMONTH(MONTH -1) +(IF YEAR MOD 4 =              00845000
            0 AND MONTH = 2 THEN 1 ELSE 0) THEN                         00850000
         BEGIN  << VALID NO. DAYS IN MONTH>>                            00855000
            TOS := DAY +FIRSTDAY(MONTH -1) +(IF YEAR MOD 4 =            00860000
               0 AND MONTH > 2 THEN 1 ELSE 0);                          00865000
            TOS.(0:7) := YEAR;                                          00870000
            CONVERTDATE := TOS;                                         00875000
            STATUS.(6:2) := CCE; << PEACHY >>                           00880000
         END;                                                           00885000
      END;                                                              00890000
   END;                                                                 00895000
END;                                                                    00900000
                                                                        00905000
END; << CONVERTDATE >>                                                  00910000
$TITLE "CONVERTTIME"                                                    00915000
DOUBLE PROCEDURE CONVERTTIME(PTR);                                      00920000
   VALUE PTR;                                                           00925000
   BYTE POINTER PTR;                                                    00930000
COMMENT                                                                 00935000
   CONVERTS BUFF CONTAINING "HH:MM" INTO DOUBLE IN                      00940000
   MILLISECONDS. ERROR RETURNS CCG. BUFF MAY CONTAINS BLANKS.           00945000
;                                                                       00950000
BEGIN                                                                   00955000
                                                                        00960000
EQUATE                                                                  00965000
   CCG = 0,                                                             00970000
   CCE = 2;                                                             00975000
                                                                        00980000
INTEGER                                                                 00985000
   HOUR,                                                                00990000
   MIN,                                                                 00995000
   STATUS = Q-1;                                                        01000000
                                                                        01005000
STATUS.(6:2) := CCG; << SET BAD >>                                      01010000
@PTR := GETNUM(PTR,HOUR);                                               01015000
IF = AND PTR = ":" THEN                                                 01020000
BEGIN                                                                   01025000
   GETNUM(PTR(1),MIN);                                                  01030000
   IF = AND (0 <= HOUR <= 23) AND (0 <= MIN <= 59) THEN                 01035000
   BEGIN                                                                01040000
      TOS := 60 *HOUR +MIN;                                             01045000
      TOS := 60000;                                                     01050000
      ASSEMBLE(LMPY);                                                   01055000
      CONVERTTIME := TOS;                                               01060000
      STATUS.(6:2) := CCE; << PEACHY >>                                 01065000
   END;                                                                 01070000
END;                                                                    01075000
                                                                        01080000
END; << CONVERTTIME >>                                                  01085000
$TITLE "DATE'LINE"                                                      01090000
PROCEDURE DATE'LINE(STRING);                                            01095000
   BYTE ARRAY STRING;                                                   01100000
COMMENT USES CLOCK & CALENDAR TO CREATE 27 CHARACTER STRING             01105000
   IN THE FOLLOWING FORMAT:                                             01110000
      "THU, JAN 13, 1977, 10:03 AM"                                     01115000
   STRING(27) CONTAINS A ZERO TO TERMINATE STRING.                      01120000
;                                                                       01125000
BEGIN                                                                   01130000
                                                                        01135000
FMTDATE(CALENDAR,CLOCK,STRING);                                         01140000
STRING(27):=0;                                                 <<02338>>01145000
                                                                        01150000
END; << DATE'LINE >>                                                    01155000
$TITLE "DEBLANK"                                                        01160000
INTEGER PROCEDURE DEBLANK(BUFF,WIDTH);                                  01165000
   VALUE WIDTH; INTEGER WIDTH;                                          01170000
   BYTE ARRAY BUFF;                                                     01175000
COMMENT                                                                 01180000
   DEBLANKS ON RIGHT                                                    01185000
;                                                                       01190000
BEGIN                                                                   01195000
                                                                        01200000
X := WIDTH -1;                                                          01205000
IF BUFF(X) <> " " THEN DEBLANK := WIDTH                                 01210000
ELSE                                                                    01215000
BEGIN                                                                   01220000
   TOS := @BUFF(X);                                                     01225000
   ASSEMBLE(DUP,DECA);                                                  01230000
   TOS := -X;                                                           01235000
   ASSEMBLE(CMPB 0);                                                    01240000
   DEBLANK := -TOS;                                                     01245000
   DDEL;                                                                01250000
END;                                                                    01255000
                                                                        01260000
END; << DEBLANK >>                                                      01265000
$TITLE "FINDMSG"                                                        01270000
DOUBLE PROCEDURE FINDMSG(DIRECTORY,FILENO,SETNO,MSGNO,         <<02339>>01275000
      BLOCKBUFF',BUFFPTR,LEN,CRLF,ERRNO);                               01280000
   VALUE FILENO,SETNO,MSGNO;                                            01285000
   INTEGER FILENO,SETNO,MSGNO,LEN,ERRNO;                                01290000
   ARRAY DIRECTORY,BLOCKBUFF';                                          01295000
   BYTE POINTER BUFFPTR;                                                01300000
   LOGICAL CRLF;                                                        01305000
   OPTION INTERNAL;                                                     01310000
COMMENT                                                                 01315000
   FETCHES ONE LINE OF MESSAGE FROM MSG CATALOG. TRANSFORMS             01320000
   SETNO & MSGNO INTO RECORD NUMBER & CALLS READCAT TO GET              01325000
   MSG.  REC NO. IS CALCULATED BY FINDING STARTING RECORD               01330000
   NUMBER OF FIRST MESSAGE IN DIRECTORY & ADDING IN THE                 01335000
   DIFFERENCE BETWEEN MSGNO & FIRST MSG NO. IN CATALOG                  01340000
   (ALSO IN DIRECTORY). IF THE MSG FOUND IN THE CATALOG                 01345000
   IS NOT THE ONE DESIRED, A BINARY SEARCH IS THEN DONE.                01350000
   BUFF' MUST BE AT LEAST AS LARGE AS RECORD SIZE.                      01355000
PARAMETERS                                                              01360000
   SETNO  = SETNO FROM GENMSG.                                          01365000
   MSGNO  = MSGNO FROM GENMSG.                                          01370000
   BUFF'  = ARRAY FOR MESSAGE. MUST BE "BUFFSIZE".                      01375000
   LEN    = LENGTH OF MESSAGE IN POSITIVE BYTES.                        01380000
   CRLF   = %320 CONTINUE WITH NO CRLF.                                 01385000
          = 0 CONTINUE NEXT MSG. AFTER CRLF.                            01390000
RETURNS                                                                 01395000
   - LEN IS THE LENGTH OF THE MESSAGE.                                  01400000
   - FINDMSG IS THE RECORD NUMBER OF THE CONTINUED MSG. 0               01405000
     INDICATES NO CONTINUATION.                                         01410000
   - CCL File system error.                                             01415000
   - CCG Non-existent set or message.                                   01420000
;                                                                       01425000
BEGIN                                                                   01430000
   INTEGER ARRAY RECNO'ARRAY(0:2)=Q;                                    01435000
   INTEGER ARRAY HEAD'ARRAY(0:1) =Q;                                    01440000
                                                                        01445000
   INTEGER                                                              01450000
      MAXSETNO = HEAD'ARRAY,    << MAXSETNOCELL >>                      01455000
      NUMRECS  = HEAD'ARRAY +1, << MAXRECELL >>                         01460000
      MSGNOLEN = MAXSETNO;      <<MAXSETNO OVERLAID>>          <<02339>>01465000
                                                                        01470000
   INTEGER                                                              01475000
      VECTOR;                                                           01480000
                                                                        01485000
   DOUBLE                                                      <<02339>>01490000
      RECNO'LO,                << SET'ROFFSET >>               <<02339>>01495000
      RECNO,                   << SET'FIRSTMSG >>              <<02339>>01500000
      RECNO'HI,                << NEXT'SET'ROFFSET >>          <<02339>>01505000
      RECBND,                                                  <<02339>>01510000
      DUMRECNO,                                                <<02339>>01515000
      RECNO'NEW;                                               <<02339>>01520000
                                                                        01525000
                                                                        01530000
INTEGER SUBROUTINE CHKMSGNO(RECTEST);                                   01535000
   VALUE RECTEST;                                                       01540000
   DOUBLE RECTEST;                                             <<02339>>01545000
COMMENT                                                                 01550000
   READS CATALOG & CHECKS TO SEE IF LINE CONTAINS MESSAGE NO.           01555000
   SETS MSGNOLEN.                                                       01560000
;                                                                       01565000
BEGIN                                                                   01570000
      << TEST RECNO LIMITS.MISSING MSGNO WILL FAIL, SINCE >>            01575000
      << LO & HI LIMITS CONTRACT >>                                     01580000
                                                                        01585000
IF (RECTEST >= RECNO'LO) AND (RECTEST <= RECNO'HI) THEN        <<02339>>01590000
      BEGIN                                                             01595000
         READCAT(FILENO,RECTEST,DIRECTORY(CURRENTRECELL),               01600000
            BLOCKBUFF',BUFFPTR);                                        01605000
         IF < THEN                                             <<01128>>01610000
         BEGIN                                                          01615000
            ERRNO := READFAIL;                                          01620000
            CCLRETN;                                                    01625000
         END;                                                           01630000
      END                                                               01635000
      ELSE                                                              01640000
      BEGIN                                                             01645000
         ERRNO := MISSINGMSG;                                           01650000
         CCGRETN;                                                       01655000
      END;                                                              01660000
                                                                        01665000
      << NOW FIND MSGNO IN MSG >>                                       01670000
                                                                        01675000
      << EXTRACT MSGNO LEN FOR BINARY >>                                01680000
      TOS := @BUFFPTR;                                                  01685000
      ASSEMBLE(DUP,DUP);                                                01690000
      MOVE * := * WHILE N,1;                                            01695000
      ASSEMBLE(LSUB,NEG);                                      <<00872>>01700000
      MSGNOLEN := TOS;                                         <<00872>>01705000
                                                               <<01321>>01710000
   << MAKE SURE CURRENT LINE ISN'T A CONTINUATION LINE. >>     <<01321>>01715000
      IF MSGNOLEN <> 0  AND  RECTEST > RECNO'LO  THEN          <<01321>>01720000
      BEGIN                                                    <<01321>>01725000
                                                               <<01321>>01730000
         DUMRECNO := RECTEST - 1D;                             <<02339>>01735000
         READCAT( FILENO, DUMRECNO, DIRECTORY(CURRENTRECELL),  <<01321>>01740000
                  BLOCKBUFF', BUFFPTR );                       <<01321>>01745000
         IF < THEN                                             <<01321>>01750000
         BEGIN                                                 <<01321>>01755000
            ERRNO := READFAIL;                                 <<01321>>01760000
            CCLRETN;                                           <<01321>>01765000
         END;                                                  <<01321>>01770000
         LENBUF( BUFFPTR, LEN, CRLF, DUMRECNO );               <<01321>>01775000
         IF DUMRECNO = 0D  THEN                                <<02339>>01780000
         BEGIN                                                 <<01321>>01785000
            READCAT(FILENO,RECTEST,DIRECTORY(CURRENTRECELL),   <<01321>>01790000
                     BLOCKBUFF', BUFFPTR );                    <<01321>>01795000
            IF < THEN                                          <<01321>>01800000
            BEGIN                                              <<01321>>01805000
               ERRNO := READFAIL;                              <<01321>>01810000
               CCLRETN;                                        <<01321>>01815000
            END;                                               <<01321>>01820000
         END                                                   <<01321>>01825000
         ELSE MSGNOLEN := 0;                                   <<01321>>01830000
                                                               <<01321>>01835000
      END;                                                     <<01321>>01840000
                                                               <<01321>>01845000
      CHKMSGNO := MSGNOLEN;                                             01850000
END; << CHKMSGNO >>                                                     01855000
                                                                        01860000
   << PROCEDURE MAIN BODY >>                                            01865000
                                                                        01870000
CONDCODE := CCE;                                                        01875000
VECTOR := 1; << MOVE FORWARD INITIALLY >>                               01880000
                                                                        01885000
                                                                        01890000
   << GET MAXSETNO,NUMRECS FROM DIRECTORY >>                            01895000
MOVE HEAD'ARRAY := DIRECTORY,(2);                                       01900000
                                                                        01905000
                                                                        01910000
   << GET SET'ROFFSET,SET'FIRSTMSG,NEXT'SET'ROFFSET >>                  01915000
MOVE RECNO'ARRAY := DIRECTORY(SETNO*2),(3);                             01920000
                                                                        01925000
   << RECNO'LO = SET'ROFFSET >>                                         01930000
   << RECNO    = SET'FIRSTMSG >>                                        01935000
   << RECNO'HI = NEXT'SET'ROFFSET >>                                    01940000
                                                               <<02339>>01945000
RECNO'LO := DOUBLE(RECNO'ARRAY);                               <<02339>>01950000
RECNO := DOUBLE(RECNO'ARRAY(1));                               <<02339>>01955000
RECNO'HI := DOUBLE(RECNO'ARRAY(2));                            <<02339>>01960000
RECBND := DOUBLE(NUMRECS);                                     <<02339>>01965000
                                                               <<02339>>01970000
IF (SETNO > MAXSETNO) OR (RECNO = DOUBLE(SETNOTPRESENT)) THEN  <<02339>>01975000
BEGIN << SET NOT PRESENT >>                                             01980000
   ERRNO := MISSINGSET;                                                 01985000
   CCGRETN;                                                             01990000
END;                                                                    01995000
                                                                        02000000
   << SET BOUNDS ON REC. NO. FOR THIS SET >>                            02005000
RECNO'HI := IF SETNO=MAXSETNO  THEN DOUBLE(NUMRECS)            <<02339>>02010000
   ELSE  RECNO'HI - 1D;                                        <<02339>>02015000
                                                                        02020000
<< SET RECNO FOR SETNO,MSGNO >>                                         02025000
RECNO := RECNO'LO + DOUBLE(MSGNO) - RECNO;                     <<02339>>02030000
<< SET'ROFFSET +MSGNO -SET'FIRSTMSG >>                                  02035000
IF RECNO >= RECNO'HI THEN << SET AT UPPER BOUNDS >>                     02040000
BEGIN                                                                   02045000
   RECNO := RECNO'HI;                                                   02050000
   VECTOR := -1;                                                        02055000
END;                                                                    02060000
                                                                        02065000
RECBND := -1D;   << FORCES CHKMSGNO CALL 1ST TIME THRU >>      <<02339>>02070000
   << SEARCH FOR CORRECT MSGNO LOOP >>                                  02075000
                                                                        02080000
WHILE TRUE DO                                                           02085000
BEGIN                                                                   02090000
   IF RECBND <> RECNO THEN << GO FETCH A NEW MESSAGE >>                 02095000
      WHILE CHKMSGNO(RECNO) = 0  DO RECNO := RECNO -1D;        <<02339>>02100000
         << IF REC DOESN'T HAVE MSGNO, GO BACKWARDS >>                  02105000
         << NOW HAVE REC CONTAINING MSGNO, FIND IF CORRECT>>            02110000
      TOS := BINARY(BUFFPTR,MSGNOLEN); <<SET IN CHKMSGNO>>              02115000
      TOS := TOS -MSGNO; DEL;                                           02120000
      IF = THEN << FETCHED CORRECT MSG >>                               02125000
      BEGIN << MOVE MSG OVER MSGNO & ADJUST LEN >>                      02130000
                                                                        02135000
            << NOW FIND END OF MSG & IF CONT'D. >>                      02140000
         LENBUF(BUFFPTR,LEN,CRLF,RECNO);                                02145000
         FINDMSG := RECNO;                                              02150000
                                                                        02155000
         LEN := LEN-(MSGNOLEN +1);                                      02160000
         IF LEN < 0 THEN LEN := 0;  << NULL LINE >>            <<01213>>02165000
            << MOVE MSG OVER MSGNO        >>                            02170000
            << MESSAGE STARTS 1 PAST MSGNO>>                            02175000
         MOVE BUFFPTR := BUFFPTR(MSGNOLEN +1),(LEN);                    02180000
                                                                        02185000
         GO OUTL; << ONLY SUCCESSFUL EXIT >>                            02190000
                                                                        02195000
      END;                                                              02200000
                                                                        02205000
         << DIDN'T FIND MSG. NO. NOW BINARY SEARCH >>                   02210000
      IF < THEN VECTOR := +1 ELSE VECTOR := -1;                         02215000
         << IF MSGNO LO, THEN +1.IF HI, THEN -1 >>                      02220000
      RECNO'NEW := (RECNO + DOUBLE(RECNO'ARRAY(1+VECTOR)))/2D; <<02339>>02225000
      << SET BOUND AT RECORD WITH MSGNO >>                              02230000
      RECBND := RECNO;                                                  02235000
         << BOUNDARY RECORD MUST BE A RECORD CONTAINING A >>            02240000
         << MESSAGE NO. RECBND WILL BE EITHER NEW HI OR LO>>            02245000
      DO RECBND := RECBND + DOUBLE(VECTOR)                     <<02339>>02250000
         UNTIL CHKMSGNO(RECBND) <> 0;                          <<02339>>02255000
      RECNO'ARRAY(1-VECTOR):=INTEGER(RECBND);<<NEW HI OR LO>>  <<02339>>02260000
      <<VECTOR=1 THEN WANT RECNO'LO; IF -1 THEN RECNO'HI>>     <<02339>>02265000
      IF VECTOR=1 THEN RECNO'LO:=DOUBLE(RECNO'ARRAY(1-VECTOR)) <<02339>>02270000
       ELSE RECNO'HI:=DOUBLE(RECNO'ARRAY(1-VECTOR));           <<02339>>02275000
                                                               <<02339>>02280000
      RECNO := IF RECNO=RECNO'NEW  THEN RECNO + DOUBLE(VECTOR) <<02339>>02285000
         ELSE IF (RECNO'NEW >= RECNO'LO) AND                   <<02339>>02290000
                 (RECNO'NEW <= RECNO'HI) THEN RECNO'NEW        <<02339>>02295000
              ELSE DOUBLE(RECNO'ARRAY(1-VECTOR));              <<02339>>02300000
                                                                        02305000
       << IF NEW SAME AS OLD, BUMP. IF NEW FALLS OUT OF>>               02310000
       << LIMITS BECAUSE OF MULTIPLE LINES/MSG SET AT  >>               02315000
       << NEW BOUND                                    >>               02320000
                                                                        02325000
END; << FIND MSGNO LOOP >>                                              02330000
                                                                        02335000
OUTL:                                                                   02340000
END; << FINDMSG >>                                                      02345000
$TITLE "FMTCLOCK"                                                       02350000
PROCEDURE FMTCLOCK(CLOCK',STRING);                                      02355000
   VALUE CLOCK';                                                        02360000
   DOUBLE CLOCK';                                                       02365000
   BYTE ARRAY STRING;                                                   02370000
COMMENT USES CLOCK' TO CREATE AN 8 CHARACTER STRING IN THE              02375000
   FOLLOWING FORMAT:                                                    02380000
      "10:03 AM"                                                        02385000
;                                                                       02390000
BEGIN                                                                   02395000
                                                                        02400000
INTEGER                                                                 02405000
   TIME = CLOCK',                                                       02410000
   HOUR;                                                                02415000
                                                                        02420000
EQUATE NOON = 12*256;                                                   02425000
                                                                        02430000
   SUBROUTINE  CONVERT(N, POSITION);                                    02435000
      VALUE  N, POSITION;  INTEGER N, POSITION;                         02440000
      BEGIN                                                             02445000
COMMENT CONVERT N TO 2-DIGIT ASCII AT STRING(POSITION). ;               02450000
         X := POSITION;  TOS := N;  << GET PARAMETERS >>                02455000
         ASSEMBLE( LDI 10;  DIV,XCH ); << GET TWO DIGITS >>             02460000
         STRING(X) := TOS+"0";  X := X+1;  STRING(X) :=                 02465000
            TOS +"0";                                                   02470000
      END;  << CONVERT >>                                               02475000
                                                                        02480000
MOVE STRING := " H:MM AM";                                              02485000
<< DO HOURS >>                                                          02490000
HOUR := (TIME.(0:8) +11) MOD 12 +1;                                     02495000
IF HOUR < 10 THEN STRING(1) := HOUR + "0"                               02500000
ELSE CONVERT(HOUR,0);                                                   02505000
<< DO MINUTES >>                                                        02510000
CONVERT(TIME.(8:8),3);                                                  02515000
<< DO AM/PM >>                                                          02520000
IF TIME >= NOON THEN STRING(6) := "P";                                  02525000
                                                                        02530000
END; << FMTCLOCK >>                                                     02535000
PROCEDURE ABORTSESS(JSID,JSNUM,ERRORSTAT);                     << 8208>>02540000
VALUE JSID,JSNUM;                                              << 8208>>02545000
INTEGER JSID;                                                  << 8208>>02550000
DOUBLE JSNUM;                                                  << 8208>>02555000
INTEGER ARRAY ERRORSTAT;                                       << 8208>>02560000
                                                               << 8208>>02565000
BEGIN                                                          << 8208>>02570000
<<**********************************************************>> << 8208>>02575000
<<                                                          >> << 8208>>02580000
<< Intrinsic ABORTSESS is designed to be the programmatic   >> << 8208>>02585000
<< equivalent of :ABORTJOB.  It follows the new, HPE        >> << 8208>>02590000
<< compatable externals.  To be able to abort a job or      >> << 8208>>02595000
<< session, the user will have to meet one of the criteria  >> << 8208>>02600000
<< listed below:                                            >> << 8208>>02605000
<<                                                          >> << 8208>>02610000
<<     1) The caller has been :ALLOWed the ABORTJOB command.>> << 8208>>02615000
<<                                                          >> << 8208>>02620000
<<     2) :JOBSECURITY is low and  A) Same user.account     >> << 8208>>02625000
<<                                 B) Same Acct. and AM cap.>> << 8208>>02630000
<<                                 C) User has SM cap.      >> << 8208>>02635000
<<                                 D) Caller is a system    >> << 8208>>02640000
<<                                    process.              >> << 8208>>02645000
<<                                                          >> << 8208>>02650000
<<     3) Caller is the MASTER OPERATOR.                    >> << 8208>>02655000
<<                                                          >> << 8208>>02660000
<<  NOTE:  Since the possibility of programmatic UDC's      >> << 8208>>02665000
<<         exist for the near future, it is important that  >> << 8208>>02670000
<<         the call to the Command intrinsic be changed to  >> << 8208>>02675000
<<         whatever the special entry point is which        >> << 8208>>02680000
<<         bypasses the check to see if its a UDC.  Some    >> << 8208>>02685000
<<         new products depend on being able to execute this>> << 8208>>02690000
<<         intrinsic successfully irreguardless of UDC's on >> << 8208>>02695000
<<         the system.                                      >> << 8208>>02700000
<<                                                          >> << 8208>>02705000
<<++++++++++++++++++++++++++++++++++++++++++++++++++++++++++>> << 8208>>02710000
<<                                                          >> << 8208>>02715000
<<  Written by:                Ken Jordan                   >> << 8208>>02720000
<<  Written on:                10/14/83                     >> << 8208>>02725000
<<  Last Modification:         12/01/83                     >> << 8208>>02730000
<<  Target Segment:            USER - Module 83             >> << 8208>>02735000
<<                                                          >> << 8208>>02740000
<<++++++++++++++++++++++++++++++++++++++++++++++++++++++++++>> << 8208>>02745000
<<**********************************************************>> << 8208>>02750000
                                                               << 8208>>02755000
LOGICAL                                                        << 8208>>02760000
  TYPE'IS'SESSION;  << True if Job type is a session. >>       << 8208>>02765000
                                                               << 8208>>02770000
INTEGER                                                        << 8208>>02775000
  JOBNUMBER;  << Holds converted Job Number. >>                << 8208>>02780000
                                                               << 8208>>02785000
BYTE ARRAY                                                     << 8208>>02790000
  PARMARRB(0:19); << Array for COMMAND intrinsic. >>           << 8208>>02795000
                                                               << 8208>>02800000
INTEGER                                                        << 8208>>02805000
  DUMMY;  << Used for the parm number parameter of COMMAND. >> << 8208>>02810000
                                                               << 8208>>02815000
INTEGER                                                        << 8208>>02820000
   STAT,                                                       << 8208>>02825000
  NUMCHAR; << From ASCII intrinsic. >>                         << 8208>>02830000
                                                               << 8208>>02835000
INTRINSIC ASCII,COMMAND;                                       << 8208>>02840000
                                                               << 8208>>02845000
<< The externals conform to all new intrinsic externals. In >> << 8208>>02850000
<< an attempt to conform with the HPE error interface ( so  >> << 8208>>02855000
<< that users will be able to use these intrinsics in both  >> << 8208>>02860000
<< MPE and HPE without a coding change) we end up having to >> << 8208>>02865000
<< convert the input to the old MPE externals.  The old     >> << 8208>>02870000
<< procedures have not changed to the new format.           >> << 8208>>02875000
                                                               << 8208>>02880000
  ERRORSTAT := 0;                                              << 8208>>02885000
  TOS := JSNUM; << Double, jobnum in left 16 bits. >>          << 8208>>02890000
  JOBNUMBER := TOS; << Double, jobnum in low order 16 bits >>  << 8208>>02895000
  ASSEMBLE(DEL);  << High order bits are 0 >>                  << 8208>>02900000
                                                               << 8208>>02905000
  IF JSID = 1                                                  << 8208>>02910000
     THEN TYPE'IS'SESSION := TRUE                              << 8208>>02915000
  ELSE IF JSID = 2                                             << 8208>>02920000
     THEN TYPE'IS'SESSION := FALSE                             << 8208>>02925000
  ELSE ERRORSTAT := INVALID'JOB'TYPE;                          << 8208>>02930000
                                                               << 8208>>02935000
<< At this point, we are back to the old format and can     >> << 8208>>02940000
<< process the parameters like an :ABORTJOB call.           >> << 8208>>02945000
                                                               << 8208>>02950000
IF ERRORSTAT = 0 THEN                                          << 8208>>02955000
BEGIN                                                          << 8208>>02960000
  MOVE PARMARRB(0) := "ABORTJOB #          ";                  << 8208>>02965000
  IF TYPE'IS'SESSION                                           << 8208>>02970000
     THEN MOVE PARMARRB(10) := "S"                             << 8208>>02975000
     ELSE MOVE PARMARRB(10) := "J";                            << 8208>>02980000
                                                               << 8208>>02985000
  NUMCHAR := ASCII(JOBNUMBER,10,PARMARRB(11));                 << 8208>>02990000
  PARMARRB(11+NUMCHAR) := %15;                                 << 8208>>02995000
                                                               << 8208>>03000000
  COMMAND(PARMARRB,STAT,DUMMY);                                << 8208>>03005000
  IF STAT = 3047                                               << 8208>>03010000
     THEN ERRORSTAT := 1                                       << 8208>>03015000
  ELSE IF STAT = 3042                                          << 8208>>03020000
     THEN ERRORSTAT := 2                                       << 8208>>03025000
  ELSE IF STAT = 3083                                          << 8208>>03030000
     THEN ERRORSTAT := 3;                                      << 8208>>03035000
END;                                                           << 8208>>03040000
                                                               << 8208>>03045000
END;  << ABORTSESS >>                                          << 8208>>03050000
$TITLE "FMTCALENDAR"                                                    03055000
PROCEDURE FMTCALENDAR(CALENDAR',STRING);                                03060000
   VALUE CALENDAR';                                                     03065000
   LOGICAL CALENDAR';                                                   03070000
   BYTE ARRAY STRING;                                                   03075000
COMMENT USES CALENDAR' TO CREATE A 17 CHARACTER STRING IN THE           03080000
   FOLLOWING FORMAT:                                                    03085000
      "THU, JAN 13, 1977"                                               03090000
;                                                                       03095000
BEGIN                                                                   03100000
                                                                        03105000
INTEGER                                                                 03110000
   YEAR,                                                                03115000
   DAY;                                                                 03120000
                                                                        03125000
   BYTE ARRAY  DAYS(0:20)=PB := "SUNMONTUEWEDTHUFRISAT";                03130000
   BYTE ARRAY  MONTHS(0:35)=PB :="JANFEBMARAPRMAYJUNJULAUG",            03135000
      "SEPOCTNOVDEC";                                                   03140000
   INTEGER ARRAY  DAYSPERMONTH(0:11)=PB :=                              03145000
     0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335;             03150000
                                                                        03155000
   SUBROUTINE  CONVERT(N, POSITION);                                    03160000
      VALUE  N, POSITION;  INTEGER N, POSITION;                         03165000
      BEGIN                                                             03170000
      COMMENT  CONVERT N TO 2-DIGIT ASCII AT STRING(POSITION).          03175000
;                                                                       03180000
         X := POSITION;  TOS := N;  << GET PARAMETERS >>                03185000
         ASSEMBLE( LDI 10;  DIV,XCH ); << GET TWO DIGITS >>             03190000
         STRING(X) := TOS+"0";  X := X+1;  STRING(X) :=                 03195000
            TOS +"0";                                                   03200000
      END;  << CONVERT >>                                               03205000
                                                                        03210000
YEAR := CALENDAR'.(0:7);                                                03215000
DAY := CALENDAR'.(7:9);                                                 03220000
<< DAY OF WEEK >>                                                       03225000
X := ((YEAR -1) &ASR(2) +YEAR +DAY) MOD 7 *3;                           03230000
MOVE STRING := DAYS(X),(3),2;                                           03235000
MOVE * := ", MMM  D, 19YY";                                             03240000
<< LEAP YEAR >>                                                         03245000
IF (YEAR.(14:2) <> 0 OR YEAR = 0) AND DAY >= 60                <<04499>>03250000
   THEN DAY := DAY + 1;                                        <<04499>>03255000
<< MONTH >>                                                             03260000
TOS := @STRING(5);                                                      03265000
X := 12; << ADDRESS FOR MONTH >>                                        03270000
DO X := X-1 UNTIL DAYSPERMONTH(X) < DAY; <<FIND THE MONTH>>             03275000
DAY := DAY - DAYSPERMONTH(X); << X IS MONTH >>                          03280000
MOVE * := MONTHS(X*3),(3); << NAME OF MONTH >>                          03285000
<< DO DAY >>                                                            03290000
IF DAY < 10 THEN STRING(10) := DAY + "0"                                03295000
ELSE CONVERT(DAY,9);                                                    03300000
<< DO YEAR >>                                                           03305000
CONVERT(YEAR,15);                                                       03310000
                                                                        03315000
END; << FMTCALENDAR >>                                                  03320000
$TITLE "FMTDATE"                                                        03325000
PROCEDURE FMTDATE(CALENDAR',CLOCK',STRING);                             03330000
   VALUE CALENDAR',CLOCK';                                              03335000
   LOGICAL CALENDAR';                                                   03340000
   DOUBLE CLOCK';                                                       03345000
   BYTE ARRAY STRING;                                                   03350000
BEGIN                                                                   03355000
                                                                        03360000
FMTCALENDAR(CALENDAR',STRING);                                          03365000
MOVE STRING(17) := ", "; << COMMA AFTER DAY,MONTH,YEAR >>               03370000
FMTCLOCK(CLOCK',STRING(19));                                            03375000
                                                                        03380000
END; << FMTDATE >>                                                      03385000
$TITLE "FORMNAME"                                                       03390000
INTEGER PROCEDURE FORMNAME(TYPE,TARGET,BA1,BA2,BA3,BA4);                03395000
   VALUE TYPE;INTEGER TYPE;                                             03400000
   BYTE ARRAY TARGET,BA1,BA2,BA3,BA4;                                   03405000
COMMENT                                                                 03410000
   COMPACTS NAMES & SEPARATES THEM WITH COMMAS AND PERIODS.             03415000
   NAMES MUST BE LEFT JUSTIFIED & TERMINATED BY ANY NON-                03420000
   ALPHANUMERIC. ALL FOUR ARRAYS ARE REQUIRED ALTHOUGH ONLY             03425000
   THOSE FORMATTED ARE LOOKED AT. NAMES ARE FORMATTED ACCORD-           03430000
   ING TO TYPE:                                                         03435000
                                                                        03440000
   TYPE   BA1  BA2   BA3   BA4                                          03445000
     1  FILEN.GROUP.ACCTN                                               03450000
     2  [JBN,]USERN.ACCTN                                               03455000
     3  [JBN,]USERN.ACCTN,GROUP                                         03460000
     4  USERN.ACCTN                                                     03465000
     5  {J/S}nnn USERN.ACCTN                                   <<U.RAO>>03470000
                                                                        03475000
   LENGTH IS RETURNED. ALSO TARGET IS TERMINATED BY 0.                  03480000
   IF AN ARRAY IS ALL BLANK, ITS TRAILING DELIM WILL BE                 03485000
   OMITTED.                                                             03490000
;                                                                       03495000
BEGIN                                                                   03500000
                                                                        03505000
BYTE POINTER BPS0 = S-0;                                                03510000
ARRAY NAMEA(*) = TYPE+2;                                                03515000
INTEGER                                                                 03520000
   INDEX,                                                               03525000
   TLEN = INDEX;                                                        03530000
BYTE ARRAY DELIM(0:3);                                                  03535000
                                                                        03540000
DELIM := 0; <<STOPPER IF TYPE BAD >>                                    03545000
CASE TYPE-1 OF                                                          03550000
BEGIN                                                                   03555000
   BEGIN << TYPE 1 >>                                                   03560000
      MOVE DELIM := ("..",0);                                           03565000
      TLEN := 26;                                                       03570000
   END;                                                                 03575000
   BEGIN << TYPE 2 >>                                                   03580000
      MOVE DELIM := (",.",0);                                           03585000
      TLEN := 26;                                                       03590000
   END;                                                                 03595000
   BEGIN << TYPE 3 >>                                                   03600000
      MOVE DELIM := (",.,",0);                                          03605000
      TLEN := 35;                                                       03610000
   END;                                                                 03615000
   BEGIN << TYPE 4 >>                                                   03620000
      MOVE DELIM := (".",0);                                            03625000
      TLEN := 17;                                                       03630000
   END;                                                                 03635000
   BEGIN  <<TYPE 5>>                                           <<U.RAO>>03640000
      MOVE DELIM := (" .",0);                                  <<U.RAO>>03645000
      TLEN := 24;   <<7 FOR J/S NUMBER, 17 FOR USER.ACCT>>     <<U.RAO>>03650000
   END;                                                        <<U.RAO>>03655000
END;                                                                    03660000
TARGET := 0;                                                            03665000
MOVE TARGET(1) := TARGET,(TLEN);                                        03670000
INDEX := -1;                                                            03675000
TOS := @TARGET;                                                         03680000
ASSEMBLE(DUP);                                                          03685000
                                                                        03690000
DO BEGIN << MOVE EACH ARRAY, FIND END,ADD DELIM >>                      03695000
   INDEX := INDEX +1;                                                   03700000
   TOS := NAMEA(INDEX);                                                 03705000
   MOVE * := * ,(8); <<MOVE INPUT NAME>>                                03710000
   MOVE BPS0 := BPS0 WHILE AN,1; << FIND END >>                         03715000
   ASSEMBLE(DUP, STAX); << SAVE END ADR >>                              03720000
   IF TOS = TOS THEN TOS := X << LENGTH = 0, NO DELIM >>                03725000
   ELSE                                                                 03730000
   BEGIN << PUT DELIM ON END >>                                         03735000
      TOS := X; << RESTORE END ADR >>                                   03740000
      BPS0 := DELIM(INDEX); <<ADD DELIM>>                               03745000
      TOS := TOS +1;                                                    03750000
   END;                                                                 03755000
   ASSEMBLE(DUP);                                                       03760000
END UNTIL DELIM(INDEX) = 0;                                             03765000
                                                                        03770000
FORMNAME := TOS -1 -@TARGET;                                            03775000
ASSEMBLE(DEL); <<CLEAN STACK>>                                          03780000
                                                                        03785000
END; << FORMNAME >>                                                     03790000
$TITLE "FORMSG"                                                         03795000
PROCEDURE FORMSG(DIRECTORY,FILENO,SETNO,MSGNO,BUFF,                     03800000
      BUFFSIZE,FILLBUFF,MSGLEN,PARMASK,PARM1,PARM2,PARM3,               03805000
      PARM4,PARM5,DESTFILE,ERRNO);                                      03810000
   VALUE FILENO,SETNO,MSGNO,BUFFSIZE,FILLBUFF,PARMASK,PARM1,            03815000
      PARM2,PARM3,PARM4,PARM5,DESTFILE;                                 03820000
   ARRAY DIRECTORY;                                                     03825000
   INTEGER FILENO,SETNO,MSGNO,BUFFSIZE,MSGLEN,DESTFILE,                 03830000
      ERRNO;                                                            03835000
   BYTE ARRAY BUFF;                                                     03840000
   LOGICAL FILLBUFF,PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5;              03845000
   OPTION INTERNAL;                                                     03850000
COMMENT                                                                 03855000
                                                                        03860000
This procedure assembles and routes messages.  Message is               03865000
fetched from message catalog in a physical block, then moved to         03870000
OUTBUFF as parameters are inserted.  As OUTBUFF is filled it is         03875000
printed.  Also as OUTBUFF fills the message is moved into BUFF          03880000
is FILLBUFF flag is on.                                                 03885000
Note: FORMSG expects the message catalog to be an 80 byte      <<04595>>03890000
standard EDITOR file with valid data in positions 1 through    <<04595>>03895000
72 and line numbers in 73-80.  This is because                 <<04595>>03900000
FORMSG  calls FINDMSG which calls LENBUF to get the            <<04595>>03905000
length of the data in the record.  LENBUF deblanks the record  <<04595>>03910000
from the right beginning in cloumn 72 and stops scanning when  <<04595>>03915000
it reaches the first non-blank character, including the con-   <<04595>>03920000
tinuation characters "&" and "%".                              <<04595>>03925000
                                                                        03930000
DIRECTORY - catalog directory from userlabel in catalog file.           03935000
FILENO    - catalog file number.                                        03940000
SETNO     - same as for GENMESSAGE.                                     03945000
MSGNO     - same as for GENMESSAGE.                                     03950000
BUFF      - output buffer.  Also used as tank for assembled             03955000
            message before it is printed.                               03960000
BUFFSIZE  - size of BUFF in positive bytes.                             03965000
FILLBUFF  - if true then BUFF parameter is present and BUFF             03970000
            will be filled with assembled message.                      03975000
MSGLEN    - size of assembled message in positive bytes.                03980000
PARMASK   - same as for GENMESSAGE.                                     03985000
PARM1 }                                                                 03990000
PARM2 }                                                                 03995000
PARM3 }   - same as for GENMESSAGE.                                     04000000
PARM4 }                                                                 04005000
PARM5 }                                                                 04010000
DESTFILE  - Destination:                                                04015000
            = <-2 - file number.                                        04020000
            = -2  - $STDLIST.                                           04025000
            = -1  - none.                                               04030000
            = >=0 - not used.                                           04035000
ERRNO     - Error number.                                               04040000
                                                                        04045000
RETURNS.                                                                04050000
   CONDITION  CCE = everything OK.                                      04055000
   CODE       CCL = file system error.                                  04060000
              CCG = internal error.  Missing setno or msgno.            04065000
   MSGLEN     - size of assembled message in positive bytes.            04070000
   ERRNO      - error number.                                           04075000
;                                                                       04080000
BEGIN                                                                   04085000
                                                                        04090000
INTEGER                                                                 04095000
   ZEROSTOP,                                                            04100000
   TANKI,                                                               04105000
   INDEX,                                                               04110000
   INLEN,                     <<INPUT BUF: LENGTH  >>                   04115000
   INX,                       <<INPUT BUF: INDEX >>                     04120000
   OUTX,                      <<OUTPUT BUF: INDEX >>                    04125000
  PNUM;                                                        <<02339>>04130000
                                                                        04135000
DOUBLE                                                         <<02339>>04140000
  RECNO;                                                       <<02339>>04145000
                                                               <<02339>>04150000
LOGICAL CRLF,DONE'MSG:=FALSE;                                  <<01214>>04155000
                                                                        04160000
BYTE POINTER BUFFPTR;                                                   04165000
                                                                        04170000
INTEGER ARRAY PARM'IA(*) = PARM1;<<PARM BUF: INPUT >>                   04175000
BYTE ARRAY BUFF1(0:11);       <<PARM BUF: OUTPUT >>                     04180000
ARRAY BLOCKBUFF'(0:RECSIZE*BLKFACTOR);                                  04185000
                                                                        04190000
POINTER OUTBUFF';                                                       04195000
BYTE POINTER OUTBUFF;                                                   04200000
                                                                        04205000
EQUATE                                                         <<04203>>04210000
   AMPERSAND = %320;   << CRLF value for "&" continuation >>   <<04203>>04215000
                                                                        04220000
SUBROUTINE PRINTIT;                                                     04225000
COMMENT                                                                 04230000
   Handles routing of output                                            04235000
;                                                                       04240000
BEGIN                                                                   04245000
                                                                        04250000
IF DESTFILE = -2 THEN                                                   04255000
BEGIN << $STDLIST >>                                                    04260000
   PRINT(OUTBUFF',-OUTX,CRLF);                                          04265000
   IF <> THEN                                                  <<01128>>04270000
      BEGIN                                                    <<01128>>04275000
      ERRNO := WRITEFAIL;                                      <<01128>>04280000
      CCLRETN;                                                 <<01128>>04285000
      END;                                                     <<01128>>04290000
END                                                                     04295000
ELSE                                                                    04300000
IF DESTFILE < -2 THEN                                                   04305000
BEGIN                                                                   04310000
   FWRITE(-DESTFILE,OUTBUFF',-OUTX,CRLF);                               04315000
   IF <> THEN                                                  <<01128>>04320000
      BEGIN                                                    <<01128>>04325000
      ERRNO := WRITEFAIL;                                      <<01128>>04330000
      CCLRETN;                                                 <<01128>>04335000
      END;                                                     <<01128>>04340000
END;                                                                    04345000
                                                                        04350000
IF FILLBUFF THEN                                                        04355000
BEGIN                                                                   04360000
   IF OUTX +MSGLEN > BUFFSIZE THEN                                      04365000
   BEGIN                                                                04370000
      << FILL TO END OF USER'S BUFFER >>                       <<00810>>04375000
      MOVE BUFF(MSGLEN) := OUTBUFF,(BUFFSIZE-MSGLEN);          <<00810>>04380000
      MSGLEN := BUFFSIZE;                                      <<00810>>04385000
      CONDCODE := CCG;                                                  04390000
      ERRNO := BUFFOVERFLOW;                                            04395000
   END                                                                  04400000
   ELSE                                                        <<00810>>04405000
   BEGIN                                                       <<00810>>04410000
      MOVE BUFF(MSGLEN) := OUTBUFF,(OUTX);                     <<00810>>04415000
      MSGLEN := MSGLEN + OUTX;                                 <<00810>>04420000
   END;                                                        <<00810>>04425000
END                                                            <<00810>>04430000
ELSE                                                           <<00810>>04435000
   MSGLEN := MSGLEN + OUTX;                                    <<00810>>04440000
OUTX := 0;  << RESET INDEX TO REFILL OUTBUFF >>                         04445000
                                                                        04450000
END; << SUBROUTINE PRINTIT >>                                           04455000
                                                                        04460000
                                                                        04465000
                                                                        04470000
                                                                        04475000
SUBROUTINE TANK(LENGTH,STRING);                                         04480000
   VALUE LENGTH;                                                        04485000
   INTEGER LENGTH;                                                      04490000
   BYTE ARRAY STRING;                                                   04495000
BEGIN                                                                   04500000
   TANKI := -1;                                                         04505000
   WHILE (TANKI := TANKI+1) < LENGTH DO << TANKING LOOP>>               04510000
   BEGIN                                                                04515000
      IF OUTX >= BUFFSIZE THEN PRINTIT; << PRINT AND FLUSH >>  <<01214>>04520000
      OUTBUFF(OUTX) := STRING(TANKI);   << TANK STRING >>      <<01214>>04525000
      OUTX := OUTX + 1;                 << ADVANCE INDEX >>    <<01214>>04530000
   END; <<TANK LOOP>>                                                   04535000
END; << TANK >>                                                         04540000
                                                                        04545000
SUBROUTINE INSERTPARM;                                                  04550000
BEGIN                                                                   04555000
   << CATCH BOUNDARY CONDITION ON LAST CHAR "!" >>             <<00261>>04560000
   IF PNUM >= 5 THEN RETURN;                                   <<00261>>04565000
   CASE *INTEGER((PARMASK &CSL(4+PNUM*3)) LAND 3) OF                    04570000
   BEGIN  << PARM N >>                                                  04575000
      BEGIN << 0: STRING PARM >>                                        04580000
         TOS := PARM'IA(PNUM);                                          04585000
         ASSEMBLE(DUP,DUP);                                             04590000
         SCAN * UNTIL 0,1;                                              04595000
         ASSEMBLE(XCH,SUB;XCH);                                         04600000
         TANK(*,*);                                                     04605000
      END;                                                              04610000
                                                                        04615000
      << 1: INTEGER BY VALUE >>                                         04620000
      TANK(ASCII(PARM'IA(PNUM),10,BUFF1),BUFF1);                        04625000
                                                                        04630000
      << 2: DOUBLE BY REFERENCE >>                                      04635000
      BEGIN                                                             04640000
         TOS := PARM'IA(PNUM);                                          04645000
         TANK(DASCII(DPS0,10,BUFF1),BUFF1); DEL;                        04650000
      END;                                                              04655000
                                                                        04660000
      ;<< 3 IGNORE PARM >>                                              04665000
                                                                        04670000
   END; << CASE OF PARMS >>                                             04675000
   PNUM := PNUM+1;                                                      04680000
END; <<INSERTPARM>>                                                     04685000
                                                                        04690000
   << MAIN BODY >>                                                      04695000
                                                                        04700000
                                                                        04705000
   << SET UP VARIABLES >>                                               04710000
MSGLEN := CRLF := ZEROSTOP := 0;<<STOPPER FOR INPUT STRING>>            04715000
CONDCODE := CCE;                                                        04720000
                                                                        04725000
   << ALLOCATE OUTPUT BUFFER >>                                         04730000
COMMENT.                                                       <<04595>>04735000
Allocate an S relative array by creating an array on the       <<04595>>04740000
stack.  Looks like:                                            <<04595>>04745000
                  -----------------                            <<04595>>04750000
     OUTBUF ==>   |               | <== Previous S             <<04595>>04755000
                  |               |                            <<04595>>04760000
                  |               |                            <<04595>>04765000
                  \               \                            <<04595>>04770000
                  ~               ~                            <<04595>>04775000
                  \               \                            <<04595>>04780000
                  |               |                            <<04595>>04785000
                  |               | <== S when add S is done   <<04595>>04790000
                  -----------------                            <<04595>>04795000
;                                                              <<04595>>04800000
ASSEMBLE( ZERO; LRA S-0);                                               04805000
@OUTBUFF' := TOS;                                                       04810000
@OUTBUFF := @OUTBUFF'&LSL(1);                                           04815000
TOS := (BUFFSIZE +1)&LSR(1);                                            04820000
ASSEMBLE( ADDS 0 );                                                     04825000
                                                                        04830000
RECNO := FINDMSG(DIRECTORY,FILENO,SETNO,MSGNO,BLOCKBUFF',               04835000
            BUFFPTR,INLEN,CRLF,ERRNO);                                  04840000
IF > THEN CCGRETN;                                                      04845000
IF < THEN CCLRETN;                                                      04850000
                                                                        04855000
<< SET UP LOOP VARIABLES >>                                             04860000
PNUM := INDEX := INX := OUTX := 0;                                      04865000
                                                                        04870000
<< NOW GO TO WORK ON INPUT STRING & FORMAT >>                           04875000
                                                                        04880000
LOOP:                                                                   04885000
WHILE NOT DONE'MSG DO                                          <<01214>>04890000
BEGIN                                                          <<01214>>04895000
   << REFILL BUFF? >>                                                   04900000
   IF INDEX >= INLEN THEN <<END OF LINE>>                               04905000
   BEGIN                                                                04910000
      TANK(INDEX-INX,BUFFPTR(INX));<<EMPTY BUFF>>                       04915000
      PRINTIT;    << FLUSH OUTBUFF >>                          <<01214>>04920000
      INX := INDEX:= 0;                                                 04925000
      IF RECNO <> 0D THEN                                      <<02339>>04930000
      BEGIN                                                             04935000
                                                               <<04203>>04940000
      << When the message is returned to a user buffer, we  >> <<04203>>04945000
      << must ensure there is a blank between the concate-  >> <<04203>>04950000
      << nated lines of a multi-line message.  If the       >> <<04203>>04955000
      << continuation character is an "&", the blank should >> <<04203>>04960000
      << not be inserted since the user has requested that  >> <<04203>>04965000
      << pure concatenation be performed.                   >> <<04203>>04970000
                                                               <<04203>>04975000
         IF FILLBUFF AND CRLF <> AMPERSAND THEN                <<04203>>04980000
            BEGIN                                              <<04203>>04985000
                                                               <<04203>>04990000
         << Make sure there is room for the blank. >>          <<04203>>04995000
            IF MSGLEN + 1 <= BUFFSIZE THEN                     <<04203>>05000000
               BEGIN                                           <<04203>>05005000
               BUFF(MSGLEN) := " ";                            <<04203>>05010000
               MSGLEN := MSGLEN + 1;                           <<04203>>05015000
               END;                                            <<04203>>05020000
                                                               <<04203>>05025000
            END;                                               <<04203>>05030000
                                                               <<04203>>05035000
         READCAT(FILENO,RECNO,DIRECTORY(CURRENTRECELL),                 05040000
            BLOCKBUFF',BUFFPTR);                                        05045000
         IF < THEN                                             <<01128>>05050000
            BEGIN                                              <<01128>>05055000
            ERRNO := READFAIL;                                 <<01128>>05060000
            CCLRETN;                                           <<01128>>05065000
            END;                                               <<01128>>05070000
         << NOW GET LENGTH,CRLF, CONT'D >>                     <<01128>>05075000
         LENBUF(BUFFPTR,INLEN,CRLF,RECNO);                     <<01128>>05080000
         INDEX := -1; << RESET FOR LOOP>>                               05085000
      END                                                               05090000
      ELSE                                                              05095000
      DONE'MSG := TRUE;                                        <<01214>>05100000
   END                                                         <<01214>>05105000
   ELSE       << INSERT PARM? >>                               <<01214>>05110000
   IF BUFFPTR(INDEX) = "!" THEN                                <<01214>>05115000
   BEGIN                                                       <<01214>>05120000
      TANK(INDEX-INX,BUFFPTR(INX));<<DUMP BUFF UP TO !>>       <<01214>>05125000
      IF NOT PARMASK&CSL(1) THEN                               <<01214>>05130000
      BEGIN << PARMS PRESENT >>                                <<01214>>05135000
         INSERTPARM;                                           <<01214>>05140000
         INX := INDEX+1; << ADVANCE PAST ! >>                  <<01214>>05145000
      END                                                      <<01214>>05150000
      ELSE INX := INDEX; <<! WASN'T PARM >>                    <<01214>>05155000
   END;                                                        <<01214>>05160000
                                                               <<01214>>05165000
   INDEX := INDEX+1;                                                    05170000
END;  << END PROCESSING MESSAGE >>                             <<01214>>05175000
                                                                        05180000
OUTL:                                                                   05185000
                                                                        05190000
END; << FORMSG >>                                                       05195000
$TITLE "GENMESSAGE  - MESSAGE SYSTEM INTRINSIC"                         05200000
INTEGER PROCEDURE GENMESSAGE(FILENO,SETNO,MSGNO,BUFF,BUFFSIZE,          05205000
      PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5,DESTFILE,ERRNO);            05210000
   VALUE FILENO,SETNO,MSGNO,BUFFSIZE,PARMASK,PARM1,PARM2,               05215000
      PARM3,PARM4,PARM5,DESTFILE;                                       05220000
   INTEGER FILENO,SETNO,MSGNO,BUFFSIZE,DESTFILE,ERRNO;                  05225000
   BYTE ARRAY BUFF;                                                     05230000
   LOGICAL PARMASK,PARM1,PARM2,PARM3,PARM4,PARM5;                       05235000
   OPTION VARIABLE;                                                     05240000
                                                                        05245000
COMMENT                                                                 05250000
   Callable message system interface.  GENMESSAGE is called             05255000
with a message number.   A message is fetched from the                  05260000
catalog, parameters are inserted, and the assembled                     05265000
message is returned in a buffer.                                        05270000
Note: GENMESSAGE expects the message catalog to be an 80 byte  <<04595>>05275000
standard EDITOR file with valid data in positions 1 through    <<04595>>05280000
72 and line numbers in 73-80.  This is because GENMESSAGE      <<04595>>05285000
calls FORMSG which calls FINDMSG which calls LENBUF to get the <<04595>>05290000
length of the data in the record.  LENBUF deblanks the record  <<04595>>05295000
from the right beginning in column 72 and stops scanning when  <<04595>>05300000
it reaches the first non-blank character, including the con-   <<04595>>05305000
tinuation characters "&" and "%".                              <<04595>>05310000
                                                                        05315000
PARAMETERS.                                                             05320000
   FILENO   - Indicates file for message catalog.  Required             05325000
              parameter.                                                05330000
   SETNO    - Message set number within catalog.  Must be a             05335000
              positive integer.  Required parameter.                    05340000
   MSGNO    - Message number within the message set.  Must be a         05345000
              positive integer or zero.  Required parameter.            05350000
   BUFF     - If present, assembled message is placed in this           05355000
              array.  Message is terminated by ASCII null (0).          05360000
   BUFFSIZE - Passed in to indicate size of BUFF in positive            05365000
              bytes.  If parameter is missing, 72 bytes in used         05370000
              as BUFF size.                                             05375000
   PARMASK  - Indicates parameter type for PARM1, PARM2, PARM3,         05380000
              PARM4, and PARM5.  If parameter is missing then           05385000
              GENMESSAGE ignores parameters.  PARMASK has the           05390000
              following bit definitions:                                05395000
              .(0:1)=1-use rest of word as alternate parameter          05400000
                       control:                                         05405000
                       .(1:15) = 0 - ignore parameters.                 05410000
                    =0-use following partial word designators           05415000
                       for parameters:                                  05420000
                       .(1:3)  = PARM1 TYPE (see below).                05425000
                       .(4:3)  = PARM2 TYPE (see below).                05430000
                       .(7:3)  = PARM3 TYPE (see below).                05435000
                       .(10:3) = PARM4 TYPE (see below).                05440000
                       .(13:3) = PARM5 TYPE (see below).                05445000
                       TYPE- 0 = Parm is a string, terminated           05450000
                                 by an ASCII null (0).  (This           05455000
                                 is passed by @arrayname.)              05460000
                             1 = Parm is integer.                       05465000
                             2 = Parm is double by reference.           05470000
                                 (This is passed by                     05475000
                                 @doublename.)                          05480000
                             3 = Ignore this parm.                      05485000
   PARM1}                                                               05490000
   PARM2}                                                               05495000
   PARM3}   - Parameter(s) to be inserted into message.                 05500000
   PARM4}                                                               05505000
   PARM5}                                                               05510000
   DESTFILE - Destination of assembled message:                         05515000
              missing = If BUFF is missing, send to $STDLIST.           05520000
                        If BUFF is present, nowhere.                    05525000
                  = 0 - $STDLIST.                                       05530000
                  > 2 - file number of destination file.                05535000
   ERRNO    - Indicates error number.  Error not returned if            05540000
              parameter is absent.  ERRNO = 0 - everything OK.          05545000
              ERRNO > 0 - internal error number.                        05550000
RETURNS.                                                                05555000
   CONDITION  CCE = everything OK.                                      05560000
   CODE       CCL = file system error.                                  05565000
              CCG = something wrong with call. May have missing         05570000
                    required parameter, invalid file number or          05575000
                    invalid parameter.                                  05580000
   GENMESSAGE-positive byte count of assembled message.                 05585000
   BUFF     - Assembled message terminated by an ASCII null             05590000
              (0).                                                      05595000
   ERRNO    - ERRNO = 0 - everything OK.  ERRNO > 0 - internal          05600000
              error number.                                             05605000
;                                                                       05610000
BEGIN                                                                   05615000
                                                                        05620000
   << INSERT LOCALS HERE >>                                             05625000
                                                                        05630000
DEFINE                                                                  05635000
   PFILENO    = ( 3:1) #,                                               05640000
   PSETNO     = ( 4:1) #,                                               05645000
   PMSGNO     = ( 5:1) #,                                               05650000
   PBUFF      = ( 6:1) #,                                               05655000
   PBUFFSIZE  = ( 7:1) #,                                               05660000
   PPARMASK   = ( 8:1) #,                                               05665000
   PDESTFILE  = (14:1) #,                                               05670000
   PERRNO     = (15:1) #;                                               05675000
                                                                        05680000
EQUATE                                                                  05685000
   PARM5OFFSET= 2; <<PARM5 IS 2ND TO LAST PARM>>                        05690000
                                                                        05695000
                                                                        05700000
LOGICAL PMASK = Q-4;                                                    05705000
LOGICAL                                                        <<04595>>05710000
   FILLBUFF;     <<USED TO SEND TO FORMSG >>                   <<04595>>05715000
                                                               <<04595>>05720000
                                                                        05725000
INTEGER                                                                 05730000
   MSGLEN = GENMESSAGE,                                                 05735000
   BUFFERSIZE,   <<USED TO SEND TO FORMSG >>                   <<04595>>05740000
   ERRNOLOCAL;                                                          05745000
ARRAY DIRECTORY(0:MSGDIRSIZE);                                          05750000
                                                               <<01526>>05755000
LOGICAL  AOPTS;                                                <<01526>>05760000
INTRINSIC  FGETINFO;                                           <<01526>>05765000
                                                                        05770000
                                                                        05775000
                                                                        05780000
   << SUBROUTINES >>                                                    05785000
<<*********************************************************>>  <<04595>>05790000
<<                                                         >>  <<04595>>05795000
<<                  G O O D B U F F S I Z E                >>  <<04595>>05800000
<<                                                         >>  <<04595>>05805000
<<*********************************************************>>  <<04595>>05810000
                                                                        05815000
LOGICAL SUBROUTINE GOODBUFFSIZE;                                        05820000
BEGIN                                                                   05825000
   IF PMASK.PBUFFSIZE THEN                                              05830000
   BEGIN                                                                05835000
      IF BUFFSIZE >0 THEN GOODBUFFSIZE := TRUE;                         05840000
   END                                                                  05845000
   ELSE GOODBUFFSIZE := TRUE;                                           05850000
END; << SUBROUTINE GOODBUFFSIZE >>                                      05855000
                                                                        05860000
                                                                        05865000
<<*********************************************************>>  <<04595>>05870000
<<                                                         >>  <<04595>>05875000
<<                 G O O D D E S T F I L E                 >>  <<04595>>05880000
<<                                                         >>  <<04595>>05885000
<<*********************************************************>>  <<04595>>05890000
LOGICAL SUBROUTINE GOODDESTFILE;                                        05895000
BEGIN                                                                   05900000
                                                                        05905000
IF PMASK.PDESTFILE THEN                                                 05910000
BEGIN       << user specified a destination file      >>       <<04595>>05915000
   IF DESTFILE >= 0 THEN                                                05920000
   BEGIN                                                                05925000
      DESTFILE := IF DESTFILE = 0 THEN -2 <<$STDLIST>>                  05930000
         ELSE -DESTFILE; << FILE NO. >>                                 05935000
      GOODDESTFILE := TRUE;                                             05940000
   END;                                                                 05945000
END                                                                     05950000
ELSE                                                                    05955000
BEGIN       << user did not specify destination file  >>       <<04595>>05960000
            << set flag for FORMSG call.  -1 for user >>       <<04595>>05965000
            << specified buffer or -2 for $STDLIST.   >>       <<04595>>05970000
   DESTFILE := IF PMASK.PBUFF THEN -1 <<NOWHERE>>                       05975000
      ELSE -2; <<$STDLIST>>                                             05980000
   GOODDESTFILE := TRUE;                                                05985000
END;                                                                    05990000
                                                                        05995000
END; << SUBROUTINE GOODDESTFILE >>                                      06000000
                                                               <<01526>>06005000
LOGICAL SUBROUTINE GOODFILE;                                   <<01526>>06010000
BEGIN                                                          <<01526>>06015000
                                                               <<01526>>06020000
<< CHECKS FILENO TO MAKE SURE IT WAS OPENED CORRECTLY. >>      <<01526>>06025000
   FGETINFO( FILENO, , , AOPTS );                              <<01526>>06030000
   IF <> THEN GOODFILE := FALSE                                <<01526>>06035000
   ELSE                                                        <<01526>>06040000
   BEGIN                                                       <<01526>>06045000
                                                               <<01526>>06050000
      IF   AOPTS.(11:1) <> 1   << NOT MULTI-RECORD >>          <<01526>>06055000
         THEN GOODFILE := FALSE                                <<01526>>06060000
         ELSE GOODFILE := TRUE;                                <<01526>>06065000
                                                               <<01526>>06070000
   END;                                                        <<01526>>06075000
                                                               <<01526>>06080000
END;  << GOODFILE >>                                           <<01526>>06085000
                                                               <<01526>>06090000
LOGICAL SUBROUTINE CHECKPARMS(ERRNOLOCAL);                              06095000
   INTEGER ERRNOLOCAL;                                                  06100000
BEGIN                                                                   06105000
                                                                        06110000
CONDCODE := CCG; << SET BAD >>                                          06115000
IF NOT PMASK.PFILENO THEN ERRNOLOCAL := NOFILENOPARM                    06120000
ELSE IF NOT PMASK.PSETNO THEN ERRNOLOCAL := NOSETNOPARM                 06125000
ELSE IF NOT PMASK.PMSGNO THEN ERRNOLOCAL := NOMSGNOPARM                 06130000
                                                                        06135000
   << REQUIRED PARMS PRESENT >>                                         06140000
ELSE IF SETNO <= 0 THEN ERRNOLOCAL := INVSETNO                          06145000
ELSE IF SETNO > MAXNOSETS THEN ERRNOLOCAL := SETNOTOOBIG                06150000
ELSE IF MSGNO < 0 THEN ERRNOLOCAL := INVMSGNO                           06155000
ELSE IF NOT GOODBUFFSIZE THEN ERRNOLOCAL := INVBUFFSIZE                 06160000
ELSE IF NOT GOODDESTFILE THEN ERRNOLOCAL := INVDESTFILE                 06165000
ELSE                                                                    06170000
BEGIN                                                                   06175000
   CONDCODE := CCE;                                                     06180000
   ERRNOLOCAL := 0;                                                     06185000
   CHECKPARMS := TRUE;                                                  06190000
END;                                                                    06195000
                                                                        06200000
END; << SUBROUTINE CHECKPARMS >>                                        06205000
                                                                        06210000
                                                                        06215000
SUBROUTINE MASKPARMS;                                                   06220000
BEGIN << SETS UP FOR ALL FIVE PARMS >>                                  06225000
                                                                        06230000
IF PMASK.PPARMASK AND NOT PARMASK&CSL(1) THEN                           06235000
BEGIN << PARMASK PRESENT & NOT SET TO IGNORE ALL PARMS>>                06240000
   TOS := PMASK&LSR(PARM5OFFSET);<<RIGHT JUSTIFY P1-P5 MASK>>           06245000
   X := 15; <<P5 IS BIT 15>>                                            06250000
   DO BEGIN                                                             06255000
      ASSEMBLE(TBC 0,X);                                                06260000
      IF = THEN PARMASK.(13:3) := 3; <<IGNORE PARM>>                    06265000
      PARMASK := PARMASK&CSR(3);                                        06270000
   END UNTIL (X := X-1) = 10;                                           06275000
   DEL; << POP PMASK >>                                                 06280000
   PARMASK := PARMASK &CSR(1);                                          06285000
END                                                                     06290000
ELSE PARMASK := -1;<<IGNORE ALL PARMS>>                                 06295000
                                                                        06300000
END; << SUBROUTINE MASKPARMS >>                                         06305000
                                                                        06310000
                                                                        06315000
   << MAIN PROCEDURE BODY >>                                            06320000
                                                                        06325000
IF CHECKPARMS(ERRNOLOCAL) THEN                                          06330000
BEGIN                                                                   06335000
      << GOODDESTFILE IN CHECKPARMS SETS UP DESTFILE >>                 06340000
                                                                        06345000
   MASKPARMS; << SETS UP PARMASK FOR FORMSG >>                          06350000
                                                               <<01526>>06355000
<< CHECK FILE OPTIONS.                                  >>     <<01526>>06360000
IF NOT GOODFILE THEN                                           <<01526>>06365000
BEGIN                                                          <<01526>>06370000
                                                               <<01526>>06375000
   CONDCODE := CCG;                                            <<01526>>06380000
   ERRNOLOCAL := BADFILEOPTIONS;                               <<01526>>06385000
                                                               <<01526>>06390000
END                                                            <<01526>>06395000
ELSE                                                           <<01526>>06400000
BEGIN                                                          <<01526>>06405000
         << GET DIRECTORY >>                                            06410000
   FREADLABEL(FILENO,DIRECTORY,MSGDIRSIZE);                             06415000
   IF = THEN                                                            06420000
   BEGIN                                                       <<04595>>06425000
      IF PMASK.PBUFFSIZE THEN                                  <<04595>>06430000
         BUFFERSIZE := BUFFSIZE                                <<04595>>06435000
      ELSE                                                     <<04595>>06440000
         BUFFERSIZE := DATASIZEB;   <<DATASIZEB = 72 >>        <<04595>>06445000
      IF PMASK.PBUFF THEN                                      <<04595>>06450000
         FILLBUFF := TRUE                                      <<04595>>06455000
      ELSE                                                     <<04595>>06460000
         FILLBUFF := FALSE;                                    <<04595>>06465000
                                                               <<04595>>06470000
      FORMSG(DIRECTORY,FILENO,SETNO,MSGNO,BUFF,                <<04595>>06475000
             BUFFERSIZE,FILLBUFF,MSGLEN,PARMASK,               <<04595>>06480000
             PARM1,PARM2,PARM3,PARM4,PARM5,                    <<04595>>06485000
             DESTFILE,ERRNOLOCAL);                             <<04595>>06490000
                                                               <<04595>>06495000
      IF <> THEN                                               <<01128>>06500000
        IF < THEN                                              <<01128>>06505000
          CONDCODE := CCL                                      <<01128>>06510000
        ELSE IF > THEN                                         <<01128>>06515000
          CONDCODE := CCG                                      <<01128>>06520000
   END                                                                  06525000
   ELSE                                                                 06530000
   BEGIN                                                                06535000
      CONDCODE := CCL;                                                  06540000
      ERRNOLOCAL := READLABELFAIL;                                      06545000
   END;                                                                 06550000
END;                                                                    06555000
                                                                        06560000
END;                                                           <<01526>>06565000
   << CONDCODE & ERRNOLOCAL SET BY CHECKPARMS >>                        06570000
                                                                        06575000
IF PMASK.PERRNO THEN ERRNO := ERRNOLOCAL;                               06580000
                                                                        06585000
END; << GENMESSAGE >>                                                   06590000
$TITLE "GETNUM"                                                         06595000
INTEGER PROCEDURE GETNUM(PTR,NUM);                                      06600000
   VALUE PTR;                                                           06605000
   BYTE POINTER PTR;                                                    06610000
   INTEGER NUM;                                                         06615000
COMMENT                                                                 06620000
   USED BY CONVERTDATE & CONVERTTIME TO DEBLANK PTR &                   06625000
   CONVERT STRING TO BINARY. RETURNS POINTER TO NEXT NON-               06630000
   NUMERIC CHAR. CONDITION CODE CCE IF OK, CCG IF NOT.                  06635000
;                                                                       06640000
BEGIN                                                                   06645000
                                                                        06650000
EQUATE                                                                  06655000
   CCG = 0,                                                             06660000
   CCE = 2;                                                             06665000
                                                                        06670000
INTEGER                                                                 06675000
   STATUS = Q-1,                                                        06680000
   LEN;                                                                 06685000
                                                                        06690000
STATUS.(6:2) := CCE;                                                    06695000
SCAN PTR WHILE " ",1;<<STRIP BLANKS>>                                   06700000
@PTR := TOS;                                                            06705000
MOVE PTR := PTR WHILE N,1;                                              06710000
LEN := TOS -@PTR;                                                       06715000
NUM := BINARY(PTR,LEN);                                                 06720000
IF <>  OR LEN = 0 THEN STATUS.(6:2) := CCG;                             06725000
SCAN PTR(LEN) WHILE " ",1;<<STRIP TRAILING BLANKS>>                     06730000
GETNUM := TOS;                                                          06735000
                                                                        06740000
END; << GETNUM >>                                                       06745000
$TITLE "LENBUF - FINDS LENGTH, CRLF & CONTINUED"                        06750000
PROCEDURE LENBUF(BUFF,LEN,CRLF,RECNO);                                  06755000
   BYTE ARRAY BUFF;                                                     06760000
   INTEGER LEN;                                                <<02339>>06765000
   DOUBLE RECNO;                                               <<02339>>06770000
   LOGICAL CRLF;                                                        06775000
   OPTION INTERNAL;                                                     06780000
BEGIN                                                                   06785000
                                                                        06790000
                                                                        06795000
INTEGER SUBROUTINE DEBLANK(BUFF,WIDTH);                                 06800000
   VALUE WIDTH; INTEGER WIDTH;                                          06805000
   BYTE ARRAY BUFF;                                                     06810000
COMMENT                                                                 06815000
   DEBLANKS ON RIGHT                                                    06820000
;                                                                       06825000
BEGIN                                                                   06830000
                                                                        06835000
X := WIDTH -1;                                                          06840000
IF BUFF(X) <> " " THEN DEBLANK := WIDTH                                 06845000
ELSE                                                                    06850000
BEGIN                                                                   06855000
   TOS := @BUFF(X);                                                     06860000
   ASSEMBLE(DUP,DECA);                                                  06865000
   TOS := -X;                                                           06870000
   ASSEMBLE(CMPB 0);                                                    06875000
   S6 := -TOS;  << DEBLANK := -TOS >>                                   06880000
   DDEL;                                                                06885000
END;                                                                    06890000
                                                                        06895000
END; << DEBLANK >>                                                      06900000
                                                                        06905000
   << FIND LENGTH OF MSG & IF CONTINUED ON NEXT REC >>                  06910000
CRLF := 0;                                                              06915000
LEN := DEBLANK(BUFF,DATASIZEB);                                         06920000
IF LEN=0 THEN     << COMPLETELY BLANK LINE >>                  <<01213>>06925000
BEGIN                                                          <<01213>>06930000
   RECNO := 0D;                                                <<02339>>06935000
   RETURN;                                                     <<01213>>06940000
END;                                                           <<01213>>06945000
IF BUFF(X:=LEN-1) = "&" OR BUFF(X) = "%" THEN                           06950000
BEGIN                                                                   06955000
   IF BUFF(X) = "&" THEN CRLF := %320;                                  06960000
   RECNO := RECNO + 1D;   << CONTINUED ON NEXT RECORD >>       <<02339>>06965000
      << NOW FIND LENGTH WITHOUT % OR & >>                              06970000
   LEN := IF LEN=1 THEN 0                                      <<01213>>06975000
                   ELSE DEBLANK(BUFF,LEN-1);                   <<01213>>06980000
END                                                                     06985000
ELSE  RECNO := 0D;        << NOT CONTINUED >>                  <<02339>>06990000
                                                                        06995000
END; <<  LENBUF >>                                                      07000000
$TITLE "NEXTPARM, FINDPARM"                                             07005000
INTEGER PROCEDURE NEXTPARMD(DELIMS,STRING,PARMPTR,DELIMPTR);            07010000
   BYTE ARRAY DELIMS,STRING;                                            07015000
   BYTE POINTER PARMPTR,DELIMPTR;                                       07020000
   OPTION VARIABLE;                                                     07025000
COMMENT                                                                 07030000
                                                                        07035000
NEXTPARM:                                                               07040000
   STARTS WITH STRING POINTING AT DELIM OR BLANK. RETURNS               07045000
   PARMPTR POINTING TO PARM & 'NEXTPARM' IS LENGTH. DELIMPTR            07050000
   POINTS TO TRAILING DELIMITER. ALL "STRING" IS UPSHIFTED              07055000
                                                                        07060000
   BOTH PARMPTR & DELIMPTR ARE OPTIONAL.                                07065000
                                                                        07070000
   CARRY     = SET IF 0 IS HIT (STRING MUST BE TERM. BY 0).             07075000
   CONDCODE  =    CCG   OK, LENGTH IS RETURNED.                         07080000
                  CCL   NO TRAILING QUOTE.                              07085000
                  CCE   LENGTH IS ZERO.                                 07090000
                                                                        07095000
   DELIMITERS ARE:  BLANK, "," , SEMICOLON , "="                        07100000
                                                                        07105000
FINDPARM:                                                               07110000
   SAME AS NEXTPARM EXCEPT NO LEADING DELIMITER IS SKIPPED.             07115000
                                                                        07120000
   '  ["]PARAMETER["]  ,'                                               07125000
    ^    ^             ^                                                07130000
    \    \             \--RETURNED DELIMPTR                             07135000
     \    \---------------RETURNED PARMPTR                              07140000
      \-------------------STRING AT ENTRY                               07145000
;                                                                       07150000
BEGIN                                                                   07155000
                                                                        07160000
ENTRY FINDPARMD;                                                        07165000
                                                                        07170000
LOGICAL                                                                 07175000
   STOPPER,                                                             07180000
   INDEX, << USED BY SAWDELIM >>                                        07185000
   PMASK = Q-4,                                                         07190000
   STATUS = Q-1;                                                        07195000
BYTE POINTER                                                            07200000
   PTR,                                                                 07205000
   NPTR;                                                                07210000
                                                                        07215000
LOGICAL NEXTPARMENTRY := FALSE;                                         07220000
                                                                        07225000
LOGICAL SUBROUTINE SAWDELIM(PNTR);                                      07230000
   VALUE PNTR; BYTE POINTER PNTR;                                       07235000
BEGIN                                                                   07240000
   INDEX := 0;                                                          07245000
   WHILE (LOGICAL(DELIMS(INDEX) <> PNTR) LAND                           07250000
      LOGICAL(DELIMS(INDEX) <> 0)) DO                                   07255000
      INDEX := INDEX +1;                                                07260000
   IF DELIMS(INDEX) = PNTR THEN SAWDELIM := TRUE;                       07265000
END; << SUBROUTINE SAWDELIM >>                                          07270000
                                                                        07275000
                                                                        07280000
NEXTPARMENTRY := TRUE;                                                  07285000
                                                                        07290000
FINDPARMD:                                                              07295000
                                                                        07300000
STATUS.(5:3) := 6; << CARRY, CCE; FAILURE >>                            07305000
@PTR := @NPTR := @STRING;                                               07310000
STOPPER := 0; << 0 FOR RUNAWAY STOP >>                                  07315000
                                                                        07320000
IF NOT PMASK.(13:1) THEN GO OUTL; << NEED STRING >>                     07325000
                                                                        07330000
                                                                        07335000
SCAN PTR WHILE " ",1; << DEBLANK >>                                     07340000
@PTR := TOS;                                                            07345000
IF CARRY THEN                                                           07350000
BEGIN                                                                   07355000
   @NPTR := @PTR; << POINT DELIMPTR AT STOPPER (0) >>                   07360000
   GO OUTL;                                                             07365000
END;                                                                    07370000
IF NEXTPARMENTRY THEN << NEXTPARM ENTRY POINT >>                        07375000
BEGIN                                                                   07380000
                                                                        07385000
      << DEBLANK AFTER DELIM IF DELIM NOT BLANK >>                      07390000
   IF SAWDELIM(PTR) THEN                                                07395000
   BEGIN                                                                07400000
      SCAN PTR(1) WHILE " ",1; << DEBLANK AFTER DELIM >>                07405000
      @PTR := TOS;                                                      07410000
      IF CARRY THEN                                                     07415000
      BEGIN                                                             07420000
         @NPTR := @PTR; << POINT DELIMPTR AT STOPPER (0) >>             07425000
         GO OUTL;                                                       07430000
      END;                                                              07435000
   END;                                                                 07440000
END;                                                                    07445000
                                                                        07450000
   <<SOMETHING BESIDES BLANKS>>                                         07455000
IF PTR = """" THEN                                                      07460000
BEGIN                                                                   07465000
   @PTR := @PTR(1);                                                     07470000
   SCAN PTR UNTIL """",1;                                               07475000
   @NPTR := TOS;                                                        07480000
   IF CARRY THEN                                                        07485000
   BEGIN                                                                07490000
   STATUS.(6:2) := 1; <<CCL: NO CLOSE QUOTE >>                          07495000
   GO OUTL;                                                             07500000
   END;                                                                 07505000
   NEXTPARMD := @NPTR -@PTR;                                            07510000
   IF > THEN STATUS.(6:2) := CCG;                                       07515000
   @NPTR := @NPTR(1); << SKIP ">>                                       07520000
      << NPTR AFTER END OF PARM & AFTER " >>                            07525000
      << LENGTH IS SET                    >>                            07530000
END                                                                     07535000
ELSE                                                                    07540000
BEGIN                                                                   07545000
   @NPTR := @PTR(-1);                                                   07550000
   DO @NPTR := @NPTR(1) UNTIL                                           07555000
      NPTR = " " OR SAWDELIM(NPTR);                                     07560000
   NEXTPARMD := @NPTR -@PTR;                                            07565000
   IF > THEN CONDCODE := CCG;                                           07570000
      << NPTR AT DELIM. LENGTH IS SET >>                                07575000
END;                                                                    07580000
   << NOW LOOK FOR 1ST NON-BLANK >>                                     07585000
SCAN NPTR WHILE " ",1;                                                  07590000
@NPTR := TOS;                                                           07595000
IF NOCARRY THEN                                                         07600000
BEGIN                                                                   07605000
   STATUS.(5:1) := 0; << CARRY >>                                       07610000
                                                                        07615000
      << SOLVE PROBLEM OF BLANK AS DELIM >>                             07620000
   IF NOT SAWDELIM(NPTR) THEN @NPTR := @NPTR(-1);                       07625000
      << IF POINTING AT NEXT PARM, BACK UP >>                           07630000
END;                                                                    07635000
                                                                        07640000
OUTL:                                                                   07645000
                                                                        07650000
IF PMASK.(14:1) THEN @PARMPTR := @PTR;                                  07655000
IF PMASK.(15:1) THEN @DELIMPTR := @NPTR;                                07660000
END; << FINDPARM,NEXTPARM >>                                            07665000
INTEGER PROCEDURE NEXTPARM(STRING,PARMPTR,DELIMPTR);                    07670000
   BYTE ARRAY STRING;                                                   07675000
   BYTE POINTER PARMPTR,DELIMPTR;                                       07680000
   OPTION VARIABLE;                                                     07685000
BEGIN                                                                   07690000
                                                                        07695000
LOGICAL                                                                 07700000
   STATUS = Q-1,                                                        07705000
   PARMASK = Q-4,                                                       07710000
   NEXTPARMENTRY := FALSE;                                              07715000
                                                                        07720000
BYTE ARRAY DELIMS(0:3);                                                 07725000
                                                                        07730000
ENTRY FINDPARM;                                                         07735000
                                                                        07740000
NEXTPARMENTRY := TRUE;                                                  07745000
                                                                        07750000
FINDPARM:                                                               07755000
                                                                        07760000
MOVE DELIMS := (",;=",0);                                               07765000
TOS :=0;                                                                07770000
TOS := @DELIMS;                                                         07775000
TOS := @STRING;                                                         07780000
ASSEMBLE(LOAD PARMPTR);                                                 07785000
ASSEMBLE(LOAD DELIMPTR);                                                07790000
TOS := PARMASK;                                                         07795000
IF NEXTPARMENTRY THEN ASSEMBLE(PCAL NEXTPARMD) ELSE                     07800000
   ASSEMBLE(PCAL FINDPARMD);                                            07805000
NEXTPARM := TOS;                                                        07810000
PUSH(STATUS);                                                           07815000
TOS := TOS.(5:3);                                                       07820000
STATUS.(5:3) := TOS; << SET CARRY, CC >>                                07825000
                                                                        07830000
END; << PROCEDURE NEXTPARM, FINDPARM >>                                 07835000
$TITLE "QUALIFYFILENAME"                                                07840000
PROCEDURE QUALIFYFILENAME(OLDFNAME,NEWFNAME);                           07845000
   BYTE ARRAY OLDFNAME, <<INPUT FILE NAME>>                             07850000
              NEWFNAME; <<OUTPUT (FULLY QUALIFIED) FILE NAME>>          07855000
COMMENT                                                                 07860000
   THIS PROCEDURE TAKES OLDFNAME AND CONVERTS IT INTO A                 07865000
   FULLY QUALIFIED FILE NAME WITH THE ADDITION OF HOME GROUP            07870000
   AND ACCOUNT AS REQUIRED.  THE NAME IS RETURNED IN NEWFNAME           07875000
   WITH A 0 (ASCII NULL) AS THE TRAILING DELIMITER.  IT ASSUMES         07880000
   OLDFNAME IS A VALID (POSSIBLY FULLY QUALIFIED) FILE NAME.            07885000
   IT ALSO ASSUMES THAT NEWFNAME CAN HOLD THE MAXIMUM FILE              07890000
   NAME (36 CHARACTERS IF LOCKWORD INCLUDED, 27 IF NO LOCKWORD          07895000
;                                                                       07900000
BEGIN                                                                   07905000
BYTE ARRAY HOMEGROUP(0:8);                                              07910000
BYTE ARRAY HOMEACCT(0:8);                                               07915000
IF OLDFNAME = "$" THEN  <<SYSTEM DEFINED FILE, NO GRP OR ACCT>>         07920000
   BEGIN   <<MOVE IN AS IS>>                                            07925000
   NEWFNAME := "$";                                                     07930000
   MOVE NEWFNAME(1) := OLDFNAME(1) WHILE AS,1;                          07935000
   BPS0 := 0;                                                           07940000
   RETURN                                                               07945000
   END;                                                                 07950000
HOMEGROUP := " ";                                              <<02326>>07955000
MOVE HOMEGROUP(1) := HOMEGROUP,(8);                            <<02326>>07960000
MOVE HOMEACCT := HOMEGROUP,(9);                                <<02326>>07965000
IF OLDFNAME = "*" THEN  <<BACK REFERENCED FILE >>              <<02326>>07970000
   BEGIN   <<MOVE IN ASTERISK AND THEN OLDNAME TO NEWNAME >>   <<02326>>07975000
   NEWFNAME := "*";                                            <<02326>>07980000
   MOVE NEWFNAME(1):= OLDFNAME(1) WHILE AN,1;                  <<02326>>07985000
   BPS0 := 0;                                                  <<02326>>07990000
   RETURN;                                                     <<02326>>07995000
   END;                                                        <<02326>>08000000
WHO(,,,,HOMEGROUP,HOMEACCT);                                            08005000
MOVE NEWFNAME := OLDFNAME WHILE ANS,0;                                  08010000
IF BPS0 = "/" THEN   <<MOVE LOCKWORD TOO>>                              08015000
   BEGIN                                                                08020000
   MOVE * := *,(1),1;                                                   08025000
   MOVE * := * WHILE ANS,0;                                             08030000
   END;                                                                 08035000
IF BPS0 = "." THEN   <<GROUP PRESENT AS WELL>>                          08040000
   BEGIN                                                                08045000
   MOVE * := *,(1),1;  <<MOVE ".">>                                     08050000
   MOVE * := * WHILE ANS,0;  <<MOVE GROUP NAME>>                        08055000
   IF BPS0 = "." THEN   <<ACCOUNT NAME PRESENT TOO>>                    08060000
      BEGIN                                                             08065000
      MOVE * := *,(1),1;                                                08070000
      MOVE * := * WHILE ANS,1;                                          08075000
      END                                                               08080000
   ELSE                                                                 08085000
      BEGIN                                                             08090000
      DEL;  <<POP POINTER TO OLDFNAME>>                                08095000
      BPS0 := ".";                                                      08100000
      TOS := TOS+1;                                                     08105000
      MOVE * := HOMEACCT WHILE AN,1;                                    08110000
      END;                                                              08115000
   BPS0 := 0;                                                           08120000
   END                                                                  08125000
ELSE   <<NEITHER GROUP OR ACCOUNT PRESENT>>                             08130000
   BEGIN                                                                08135000
   DEL;  <<POP POINTER TO OLDFNAME>>                                    08140000
   BPS0 := ".";                                                         08145000
   TOS := TOS+1;                                                        08150000
   MOVE * := HOMEGROUP WHILE AN,1;                                      08155000
   BPS0 := ".";                                                         08160000
   TOS := TOS+1;                                                        08165000
   MOVE * := HOMEACCT WHILE AN,1;                                       08170000
   BPS0 := 0;                                                           08175000
   END;                                                                 08180000
END; << QUALIFYFILENAME >>                                              08185000
$TITLE "READCAT"                                                        08190000
PROCEDURE READCAT(FILENO,RECNO,CURRENTREC,BLOCKBUFF',                   08195000
      BUFFPTR);                                                         08200000
   VALUE FILENO,RECNO;                                                  08205000
   INTEGER FILENO,CURRENTREC;                                  <<02339>>08210000
   DOUBLE RECNO;                                               <<02339>>08215000
   ARRAY BLOCKBUFF';                                                    08220000
   BYTE POINTER BUFFPTR;                                                08225000
   OPTION INTERNAL;                                                     08230000
                                                                        08235000
COMMENT -    READS A RECORD FROM THE MESSAGE CATALOG.                   08240000
   FILENO     - CATALOG FILE NUMBER.                                    08245000
   RECNO      - RECORD NUMBER. NO CHECKING DONE ON THIS NO.             08250000
   CURRENTREC - RECORD NUMBER OF FIRST RECORD IN BLOCK                  08255000
                BUFFER.                                                 08260000
   BLOCKBUFF' - DISC BUFFER RECSIZE*BLKFACTOR LONG.                     08265000
   BUFF       - BUFFER AS LARGE AS RECORD SIZE                          08270000
   CCE          EVERYTHING OK.                                          08275000
   CCL          FREADDIR FAILED.                                        08280000
;                                                                       08285000
BEGIN                                                                   08290000
                                                                        08295000
                                                                        08300000
CONDCODE := CCE;                                                        08305000
                                                                        08310000
   << GET CURRENT RECORD, SEE IF RECNO IS IN DSEG >>                    08315000
                                                                        08320000
IF (RECNO >= DOUBLE(CURRENTREC)) AND                           <<02339>>08325000
   (RECNO <= DOUBLE(CURRENTREC + BLKFACTOR-1)) THEN            <<02339>>08330000
ELSE << GO GET IT >>                                                    08335000
BEGIN                                                                   08340000
   FREADDIR(FILENO,BLOCKBUFF',RECSIZE*BLKFACTOR,               <<02339>>08345000
      RECNO/DOUBLE(BLKFACTOR));                                <<02339>>08350000
   IF <> THEN CCLRETN;                                                  08355000
                                                                        08360000
   CURRENTREC:=INTEGER((RECNO//LOGICAL(BLKFACTOR)))*BLKFACTOR; <<02339>>08365000
END;                                                                    08370000
                                                                        08375000
   << DEBLOCK FROM BUFFER >>                                            08380000
@BUFFPTR := @BLOCKBUFF'(INTEGER(RECNO-DOUBLE(CURRENTREC))      <<02339>>08385000
                         *RECSIZE) & LSL(1);                   <<02339>>08390000
                                                                        08395000
                                                                        08400000
OUTL:                                                                   08405000
END; << READCAT >>                                                      08410000
                                                                        08415000
$CONTROL SEGMENT=MAIN                                                   08420000
END. << USER >>                                                         08425000
