perm filename PNYACT.SAI[PNY,SYS]3 blob sn#138444 filedate 1975-01-02 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00013 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	BEGIN "PONYSY" 
C00006 00003	EXTERNAL PROCEDURE SPOOL(STRING S INTEGER IOCHAN,FLAGS)
C00011 00004	PROCEDURE BILL(INTEGER MAX)
C00013 00005	PROCEDURE MERGE BEGIN "MERG"
C00019 00006	ENTER(OUCH2,MON&".BIL[P,PAW]",FLAG)
C00022 00007	WHILE LENGTH(LIN) > 0 ∨ NME < BMAX DO BEGIN "MAIN"
C00025 00008	IF SUMN ≠ 0 THEN BEGIN "WRITE_BILL"
C00033 00009	OUT(OUCH2,↓)
C00037 00010	outstr("sorting"&↓)
C00039 00011	BEGIN	"HEAPSORT"
C00041 00012	CLOSE(OUCH)
C00044 00013	In case you were wondering, as I was, where this starts, you've found it
C00055 ENDMK
C⊗;
BEGIN "PONYSY" 

REQUIRE "PHONEY.SAI[1,LES]" SOURCE_FILE;

PRELOAD_WITH "January","February","March","April","May","June",
		"July","August","September","October","November","December";
STRING ARRAY BMONTH[1:12];
 
PRELOAD_WITH "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
             "OCT","NOV","DEC";
STRING ARRAY MONTH[1:12];
 

DEFINE ↓ = "'15&'12",
      FF = "'14",
     TAB = "'11",
   INTTY = "1",
     LIM = "10",
  TTYUUO = "'051000000000",
     TOP = "300",
 VMICONO = "'736600000000",
   CALLI = "'47000000000";

LABEL START, RETRY0, RETRY, STOP;

INTEGER ARRAY REC,PPN,KEY[1:TOP],CDE,AMOUNT[1:LIM],CHARGF[0:5],DOOR[1:10];

STRING ARRAY NAME[1:TOP];

STRING  S, MON, GOODS, AMT, S1, S2, SFOO, MONOLD;

INTEGER I, CNT, BRK, EOF, A, B, INCH, OUCH, C, PASS, DAY, N, FLAG, LIMIT,
        NUM, N1, ID, K, NUMT, ZZ, KK, BN, ADR, LNGTH, D;
EXTERNAL PROCEDURE SPOOL(STRING S; INTEGER IOCHAN,FLAGS);

SIMPLE PROCEDURE LOSE(STRING FILE);
	BEGIN
	OUTSTR("CANNOT OPEN FILE "&FILE);
	CALL(0,"EXIT");
	END;

STRING PROCEDURE CENTS(INTEGER P);
	BEGIN STRING S;
 	IF P = 0 THEN RETURN("0");                                      
	S ← IF P < 0 THEN "-" ELSE "";                    
	P ← ABS P;
	IF P ≥ 100 THEN S ← S&CVS(P%100);
	P ← P MOD 100;
	RETURN(S&"."&("0"+P%10)&("0"+P MOD 10));
	END;


SIMPLE PROCEDURE DATE;
	BEGIN INTEGER D;
	D ← CALL(0,"DATE");
	DAY ← 32;          
	D ← (D ← D DIV 31) MOD 12 +1;
	IF D = 1 THEN D ← 12
	ELSE D ← D-1;
	MON ← MONTH[D];                       
	IF D = 1 THEN D ← 12
	ELSE D ← D-1;
	MONOLD ← MONTH[D];
	END;

STRING PROCEDURE LEFT(INTEGER L; STRING Z);
	BEGIN STRING BLANKS;
 	BLANKS ← "                     ";
	RETURN(IF LENGTH(Z) < L THEN Z&BLANKS[1 TO L-LENGTH(Z)] ELSE Z[1 TO L]);
	END;


STRING PROCEDURE RIGHT(INTEGER L; STRING Z);
	BEGIN STRING BLANKS;
	BLANKS ← "                      ";
	RETURN(IF LENGTH(Z) < L THEN BLANKS[1 TO L-LENGTH(Z)]&Z ELSE Z[1 TO L]);
	END;

STRING PROCEDURE CENTER(INTEGER L; STRING Z);
	BEGIN STRING BLANKS;
	BLANKS ← "                        ";
	RETURN(IF LENGTH(Z) < L THEN BLANKS[1 TO (L-LENGTH(Z))DIV 2]&
		Z & BLANKS[1 TO (L-LENGTH(Z)+1)DIV 2] ELSE Z[1 TO L]);
	END;

STRING PROCEDURE ERROR(INTEGER E);
    BEGIN
	IF 0<E<8 THEN CASE E OF BEGIN
	[1] OUT(INTTY,"YOU ARE NOT ON OUR USER LIST. PLEASE SEE THE FRONT OFFICE"&↓&
		"TO GET YOUR NAME ADDED TO THE USER LIST."&↓&↓);
	[2] OUT(INTTY,"WRONG CODE ON ITEM "&GOODS&↓&
		"ALLOWABLE CODES ARE M,C,D,B,V,S,T AND P "&↓&
		"RETYPE CODES AND AMOUNTS = ");
	[3] OUT(INTTY,"TYPOGRAPHICAL ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
		"RETYPE CODES AND AMOUNTS = ");
	[4] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&            
		"AMOUNT IS NOT IN NICKEL INCREMENTS. AMOUNT MUST BE IN "&↓&
		"5 CENT INCREMENTS."&↓&
		"CORRECT CODE AND AMOUNT = ");
	[5] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
		"AMOUNT MUST BE A MULTIPLE OF THE PRICE OF THE GOODS INDICATED."&↓&
		"CORRECT CODE AND AMOUNT = ");
	[6] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
		"DONUTS SELL FOR 20 CENTS."&↓&
		"CORRECT CODE AND AMOUNT = ");
	[7] OUT(INTTY,"ERROR IN ITEM "&CDE[ZZ]&AMT&↓&
		"PRICE DOES NOT MATCH ANY VENDING MACHINE PRICE."&↓&
		"CORRECT CODE AND AMOUNT = ")
	END;
	IF 3<E<8 THEN BEGIN
		GOODS ← INPUT(INTTY,1);
		OUT(INTTY,↓);
		ZZ ← ZZ -1;
		IF LENGTH(GOODS) THEN GO TO RETRY;
	 	END;
	IF 1<E<4 THEN BEGIN        
		S ← INPUT(INTTY,1);
		OUT(INTTY,↓);
		IF LENGTH(S) THEN GO TO RETRY0;
	END;
	GO TO START;
    END;

PROCEDURE BILL(INTEGER MAX);
BEGIN INTEGER ARRAY CHARGES[1:MAX],BILLS[1:TOP+1,0:12];

INTEGER SWAP, II, NME, NME1, OUCH1, INCH1, OUCH2, BMAX, OUCH3, OUCH4;

INTEGER PROCEDURE ADDEM; BEGIN
INTEGER AMT;
COMMENT READ CODE AND DETERMINE ARRAY INDEX;
B ← IF (K ←CVXSTR(CHARGES[II←II+1] LAND '777777000000)) = "C" THEN 1
ELSE IF K = "D" THEN 2
ELSE IF K = "B" THEN 3
ELSE IF K = "S" THEN 4
ELSE IF K = "V" THEN 5
ELSE IF K = "A" THEN 5
ELSE IF K = "M" THEN 6
ELSE IF K = "X" THEN 7
ELSE IF K = "P" THEN 8
ELSE 9;
COMMENT ACCUMULATE CHARGES;
AMT ← 0;
AMT ← (CHARGES[II] LSH 18) DIV 2↑18;
IF AMT < 0 THEN OUT(OUCH3,CVXSTR(BILLS[A,0])&" "&CVXSTR(CHARGES[II] LAND '777777000000)&CVS(AMT)&↓);
BILLS[A,B] ← BILLS[A,B] + AMT;
IF BILLS[A,B] < 0 THEN OUT(OUCH3,"TOTAL "&CVXSTR(BILLS[A,0])&" "&K&CVS(BILLS[A,B])&↓);
END;

SIMPLE PROCEDURE FAILURE(STRING SF); BEGIN
OUTSTR(SF&" MISSING"&↓); CALL(0,"EXIT");
END;

PROCEDURE MERGE; BEGIN "MERG"


LABEL BILL1, BILL2;

STRING LIN,PN,PNAME,LINEOUT, INTSTR, U;
REAL INTEREST, DIVIDEND, REPAY;
INTEGER  SHARES, DIVBAL, SUMO, PRABO, PRAB, SUMINT,REDT,
	SAUNO, SAUN, XERBO, XERB, SUMN, PURBRK, PRAINT,
	SHARETOT, DIVBALTOT, DIVNT, PRABOT, SAUNOT, XERBOT,
	SUMOT, TOBUF, PRABN, SAUNN, XERBN, SAUINT,SUMNT, PRABNT,
	DIVIT, DIVID, REPT, SAUNNT, SHARET, DIVBALT, XERBNT, XERINT,
	END_FLAG, END_ARRY,cond1_flag;

STRING PROCEDURE DATE1;
	BEGIN INTEGER J;
	J ← CALL(0,"DATE");
 	RETURN(CVS(J MOD 31 +1)&" "&BMONTH[(J←J DIV 31)MOD 12 +1]&
			" "&CVS(J DIV 12 + 1964));
	END;

INTEGER PROCEDURE MONEY(REFERENCE STRING S); BEGIN
	INTEGER I,J,N;
	N ← 1;
	IF I←S = "-" THEN BEGIN
		N ← -1;
		I ← LOP(S);
		END;
	I ← SCAN(S,6,BRK);
	I ← CVD(SCAN(S,4,BRK));
	IF BRK ≠ "." THEN J ← 0 ELSE BEGIN
		J ← LOP(S);
		J ← CVD(SCAN(S,4,BRK));
		END;
	RETURN(N*(100*I + (IF I ≥ 0 THEN J ELSE -J)));
END;

STRING PROCEDURE OUT1; BEGIN
	STRING S;
	S ← PN&"/"&PNAME;
	IF LENGTH(S) ≤ 24 THEN S ← S&TAB;
	IF SHARES ≠ 0 ∨ DIVBAL ≠ 0 THEN 
	S ← S&"["¢s(shares)&tab¢s(divbal)&"]";
	IF SUMNT ≠ 0 THEN S ← S&TAB&"("&(IF PRABO ≠ 0 ∨ PRAB ≠ 0 THEN 
		    CENTS(PRABO + PRAB)&"P"&" " ELSE NULL)&(IF SAUNN ≠ 0 THEN
		    CENTS(SAUNN)&"S"&" " ELSE NULL)&(IF XERBO ≠ 0 ∨ XERB ≠ 0 THEN
		    CENTS(XERBO + XERB)&"X"&" " ELSE NULL)&CENTS(SUMNT)&"T)";
	RETURN(S);
END;

STRING PROCEDURE OUT2; BEGIN
	STRING S;
	S ← LEFT(3,CVXSTR(BILLS[NME,0]))&"/"&PNAME;
	IF LENGTH(S) ≤ 24 THEN S ← S&TAB;
	IF SUMNT ≠ 0 THEN
	S ← S&"("&(IF PRAB ≠ 0 THEN CENTS(PRAB)&"P"&TAB ELSE NULL)&
		  (IF SAUNN ≠ 0 THEN CENTS(SAUNN)&"S"&TAB ELSE NULL)&
		  (IF XERB ≠ 0 THEN CENTS(XERB)&"X"&TAB ELSE NULL)&
		  CENTS(SUMNT)&"T)";
	RETURN(S);
END;

STRING PROCEDURE FIND_NAME(INTEGER II); BEGIN
	STRING S;
	FOR A ← 1 STEP 1 UNTIL I DO
       	IF II = PPN[A] THEN DONE;
	IF A > I THEN S ← (IF LENGTH(PNAME) THEN PNAME ELSE CVXSTR(II)) ELSE
	S ← NAME[A];
	RETURN(S);
END;

SIMPLE PROCEDURE PAST_DUE; BEGIN
PNAME ← SCAN(LIN,15,BRK);
COMMENT SCAN FOR SHARES AND DIVIDEND BALANCES;
IF "[" = BRK ∨ "{" = BRK THEN
        BEGIN
	PURBRK ← BRK;
	U ← SCAN(LIN,16,BRK);
	IF "]" ≠ BRK ≠ "}" THEN FAILURE(PNAME&"-]- OR -}-");
	SHARETOT ← SHARETOT + (SHARES ← MONEY(U)); COMMENT TOTAL SHARES;
	DIVBALTOT ← DIVBALTOT + (DIVBAL ← MONEY(U)); COMMENT TOTAL DIVIDENDS;
	DIVBAL ← DIVBAL + (II←(SHARES*DIVIDEND+5000)%10000);
	DIVNT ← DIVNT + II;
	U ← SCAN(LIN,16,BRK);
	END;
IF BRK = "(" THEN BEGIN
	U ← SCAN(LIN,16,BRK);
	IF BRK ≠ ")" THEN FAILURE(PNAME&"-)-");
	LIN ← SCAN(LIN,7,BRK); COMMENT SCAN FOR A * INDICATING PAID BILL;
	IF BRK ≠ "*" THEN BEGIN            
		LIN ← U;
		WHILE LENGTH(LIN) > 0 DO BEGIN
		U ← SCAN(LIN,8,BRK);
		IF BRK = "P" THEN PRABOT ← PRABOT + (PRABO ← MONEY(U))
		ELSE IF BRK = "S" THEN SAUNOT ← SAUNOT + (SAUNO ← MONEY(U))
		ELSE IF BRK = "X" THEN XERBOT ← XERBOT + (XERBO ← MONEY(U))
		ELSE IF BRK = "T" THEN SUMOT ← SUMOT + (SUMO ← MONEY(U))
		ELSE FAILURE(PNAME&"-PSXVT-");
		END;
	END;	
	END;
END;

SIMPLE PROCEDURE COND1; BEGIN
	PAST_DUE;
	PNAME ← FIND_NAME(II← CVSIX(PN));
	COND1_FLAG ← 1;
	SUMN ← SUMO;
	END;

SIMPLE PROCEDURE COND2; BEGIN
	PRAB ← BILLS[NME,9];
	SAUN ← BILLS[NME,8];
	XERB ← BILLS[NME,7];
	SUMN ← PRAB + SAUN + XERB;
	PNAME ← "";
	PNAME ← FIND_NAME(BILLS[NME,0]);
	END;


ENTER(OUCH2,MON&".BIL[P,PAW]",FLAG);
IF FLAG THEN LOSE(MON&".BIL[P,PAW]");

LOOKUP(INCH1,MONOLD&".BIL[P,PAW]",FLAG);
IF FLAG THEN LOSE(MONOLD&".BIL[P,PAW]");

ENTER(OUCH1,"BILL.LST[P,PAW]",FLAG);
IF FLAG THEN LOSE("BILL.LST[P,PAW]");


SETBREAK(6,'15&'12&'40&'11&'14,NULL,"XNR");
SETBREAK(7,"*",NULL,"INS");
SETBREAK(8,"PSXVT",NULL,"INS");
SETBREAK(15,"/()[]{}",'11,"INS");
SETBREAK(16,"/()[]{}",NULL,"INS");
SETBREAK(13,FF,NULL,"INS");
SETBREAK(14,"%",'11&" " ,"INS");
SETFORMAT(0,0);

COND1_FLAG ← END_ARRY ← 0;
NME ← 0;

COMMENT READ TV DIRECTORY;
LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 9],"COMMENT ⊗") THEN
DO INPUT(INCH1,13) UNTIL BRK=FF;

COMMENT READ IN INTEREST;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 8],"INTEREST") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
intstr ← scan(lineout,5,brk);
intstr ← lineout;
INTEREST ←           REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("INTEREST");

COMMENT READ IN DIVIDEND;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 8],"DIVIDEND") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
DIVIDEND ← REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("DIVIDEND");;

COMMENT READ IN REPAY;
LINEOUT ← LIN ← INPUT(INCH1,1);
IF EQU(LIN[1 TO 5],"REPAY") THEN BEGIN
OUT(OUCH2,LINEOUT&↓);
REPAY ←     REALSCAN(LIN,BRK)*100;
END
ELSE FAILURE("REPAY");


COMMENT SET TOTALS TO ZERO;
SHARETOT←DIVBALTOT←DIVNT←PRABOT←SAUNOT←REPT←SUMNT←XERBOT←SUMINT←
SUMOT←SAUNNT←SHARET←DIVBALT←XERBNT←PRABNT←praint←xerint←sauint←divit←0;

NME ← NME +1;

COMMENT READ TO FIRST LINE OF DATA;
DO OUT(OUCH2,(LIN←INPUT(INCH1,1))&↓) UNTIL LENGTH(LIN) = 0;                                     
LIN ← INPUT(INCH1,1); COMMENT READ FIRST DATA LINE;
END_FLAG ← 1;
IF LENGTH(LIN) THEN END_FLAG ← 0;
WHILE LENGTH(LIN) > 0 ∨ NME < BMAX DO BEGIN "MAIN"
PN ← LEFT(3,SCAN(LIN,16,BRK)); COMMENT READ PPN;
IF BRK ≠ "/" THEN FAILURE(PN&"-/-");
COMMENT MERGE WITH CHARGES FILE;

COMMENT IF PN > BILLS[NME,0] AND NME = BMAX THHE END OF NEW CHARGE FILE HAS BEEN
	REACHED AND WE CAN WRITE OUT PAST DUE CHARGES;
BILL1:
COMMENT SET COUNTERS TO ZERO;
SHARES←DIVBAL←PRAB←SAUN←XERB←SUMN←PRABN←SAUNN←SUMNT←
XERBN←DIVID←SUMO←PRABO←SAUNO←XERBO←0;

IF NME > BMAX THEN BEGIN END_ARRY ← 1; NME ← BMAX; END;
IF CVSIX(PN) > BILLS[NME,0] ∧ END_ARRY = 1 THEN COND1 ELSE

COMMENT IF PN < BILLS[NME,0] AND LENGTH OF LIN IS ZERO THEN THE END OF PAST
	DUE FILE HAS BEEN REACHED AND WE CAN WRITE OUT CURRENT CHARGES;

IF CVSIX(PN) < BILLS[NME,0] ∧ END_FLAG = 1  THEN COND2 ELSE

COMMENT IF PN < BILLS[NME,0] AND THE END OF NEW CHARGE FILE HAS NOT BEEN
	REACHED THEN THERE ARE NO NEW CHARGES AND WE CAN WRITE OUT PSAT DUE CHARGES;

IF CVSIX(PN) < BILLS[NME,0] THEN COND1 ELSE

COMMENT IF PN = BILLS[NME,0] THEN MERGE FILES;

IF CVSIX(PN) = BILLS[NME,0] THEN BEGIN
	PRAB ← BILLS[NME,9];
	SAUN ← BILLS[NME,8];
	XERB ← BILLS[NME,7];
	SUMN ← PRAB + SAUN + XERB;
	PAST_DUE;
	PNAME ← FIND_NAME(BILLS[NME,0]);
	COND1_FLAG ← 1;
	SUMN ← SUMN + SUMO;
	END ELSE

COMMENT IF PN IS GREATER THAN BILL[NME,0] THEN THERE IS NO OLD FILE FOR BILL[NME,0]
	AND WE CAN WRITE OUT HIS CHARGES AND RETURN TO BILL1;

IF CVSIX(PN) > BILLS[NME,0] THEN COND2;


COMMENT collect totals write new file and bills;



IF SUMN ≠ 0 THEN BEGIN "WRITE_BILL"

OUT(OUCH1,FF&"Pony Bill of"&CENTER(37,PNAME)&RIGHT(18,DATE1)&↓&↓);
IF PRABO ∨ PRAB THEN BEGIN "PRANCING"
IF PRABO THEN OUT(OUCH4,PNAME&" "&CENTS(PRABO)&" "&CENTS(PRABOT)&↓);
	OUT(OUCH1,"Prancing Pony"&↓);
	IF PRABO > 0 ∧
		 INTEREST THEN BEGIN
			A ← (PRABO*INTEREST+5000)%10000;
			PRABO ← PRABO + A; PRAINT ← PRAINT + A;
		OUT(OUCH1,(if a ≥ 1 then "Past Due: "¢s(prabo - a)&" + interest of "&
				cents(a)&" at "&intstr&" = "¢s(prabo) 
		ELSE IF PRABO > 0 THEN "Past Due: "&CENTS(PRABO) 
		ELSE null)&↓);
	end;
	IF PRABO < 0 THEN OUT(OUCH1,"Credit: "&CENTS(PRABO)&↓);
IF PRAB THEN 
	OUT(OUCH1,"Charges:"&↓&(if bills[nme,1] then TAB&TAB&"Coffee "&
	RIGHT(6,CENTS(BILLS[NME,1]))&↓ ELSE null)&(if bills[nme,2] then TAB&tab&"Donuts "&
	RIGHT(6,CENTS(BILLS[NME,2]))&↓ ELSE NULL)&(IF BILLS[NME,3] THEN TAB&TAB&"Bagels "&
	RIGHT(6,CENTS(BILLS[NME,3]))&↓ else null)&(if bills[nme,4] then TAB&tab&"Snacks "&
	RIGHT(6,CENTS(BILLS[NME,4]))&↓ else null)&(if bills[nme,5] then TAB&tab&"V/M    "&
	RIGHT(6,CENTS(BILLS[NME,5]))&↓ ELSE NULL)&(IF BILLS[NME,6] THEN TAB&TAB&"Money  "&
	RIGHT(6,CENTS(bills[nme,6])) else null)&↓);
OUT(OUCH1,TAB&CENTS(prabn ← PRABO+PRAB)&" TOTAL"&↓&↓);
PRABNT ← PRABNT + PRABN;
END "PRANCING";

IF SAUNO ∨ SAUN ∨ DIVBAL ∨ SHARES THEN BEGIN "SAUNA"
	OUT(OUCH1,↓&"Sauna"&↓);
	IF SAUNO > 0 ∧
		 INTEREST THEN BEGIN
			A ← (SAUNO*INTEREST+5000)%10000;
			SAUNO ← SAUNO + A; SAUINT ← SAUINT + A;
                OUT(OUCH1,(if a ≥ 1 then "Past Due: "&CENTS(SAUNO - a)&" + interest of "
		¢S(A)&" at "&INTSTR&" = "&CENTS(SAUNO)
		ELSE "Past Due: "&CENTS(SAUNO))&↓);
	end;
IF SAUN THEN 
	OUT(OUCH1,"Charges: "&CENTS(SAUN)&↓);
SAUNN ← SAUNO + SAUN;
IF SAUNN ∧ DIVBAL THEN BEGIN
	DIVIT ← DIVIT + (DIVID ← DIVBAL MIN SAUNN);
	DIVBAL ← DIVBAL -DIVID; SAUNN ← SAUNN -DIVID;
	OUT(OUCH1,"Less Dividend: "&CENTS(-DIVID)&↓&"Dividend Balance: "&CENTS(DIVBAL)&↓);
END;
IF REPAY ∧ SHARES THEN BEGIN
	REPT ← REPT + (II ←(SHARES*REPAY+5000)%10000);
	SHARES ← SHARES - II; SAUNN ← SAUNN -II;
	OUT(OUCH1,"Repayment: "&-ii&"("&cvs(repay%100)&"% of share balance)"&↓);
END;
IF SAUNN > 0 ∧ PURBRK = "{" THEN BEGIN "REDUCE"
	SHARES ← SHARES - (II←SHARES MIN SAUNN);
	SAUNN ← SAUNN - II; REDT ← REDT + II;
	OUT(OUCH1,"Reduction: "&-ii&"(Share Balance: "¢s(shares)&")"&↓);
	end "REDUCE";
SAUNNT ← SAUNNT + SAUNN;
if shares then
out(ouch1,"Share Balance: "¢s(shares)&↓);
OUT(OUCH1,TAB&CENTS(SAUNN)&" TOTAL"&↓);
END "SAUNA";


IF XERB ∨ XERBO THEN BEGIN "XEROX"
	OUT(OUCH1,↓&"Xerox/Velo-Bind"&↓);
	IF XERBO > 0 ∧
		INTEREST THEN BEGIN
			A ← (XERBO*INTEREST+5000)%10000;
			XERBO ←XERBO +A; XERINT ← XERINT + A;
		OUT(OUCH1,(if a ≥ 1 then "Past Due: "&CENTS(XERBO - a)&" + interest of "
	        &CENTS(A)&" at "&INTSTR&" = "&CENTS(XERBO)
		ELSE "Past Due: "&CENTS(XERBO))&↓);
	end;
IF XERB THEN
	OUT(OUCH1,"Charges: "&CENTS(XERB)&↓);
XERBNT ←XERBNT + (XERBN ← XERBO+XERB);
OUT(OUCH1,TAB&CENTS(XERBN)&" TOTAL"&↓);
END "XEROX";


IF PRABN ∨ SAUNN ∨ XERBN TH¬n
	OUT(OUCH1,↓&TAB&CENTS(SUMNT ← PRABN+SAUNN+XERBN)&" GRAND TOTAL"&↓);
END "WRITE_BILL";

IF COND1_FLAG = 1 THEN BEGIN
	LINEOUT ← OUT1;
	COND1_FLAG ← 0;
	END ELSE
	LINEOUT ← OUT2;

OUT(OUCH2,LINEOUT&↓); COMMENT WRITE OUTPUT FILE;
OUTSTR(LINEOUT&↓);

SHARET ← SHARET + SHARES;
DIVBALT ← DIVBALT + DIVBAL;

IF CVSIX(PN) > BILLS[NME,0] ∧ END_ARRY = 1 THEN BEGIN
	LIN ← INPUT(INCH1,1);
	IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
	END ELSE
IF CVSIX(PN) < BILLS[NME,0] ∧ END_FLAG = 1 THEN BEGIN
	NME ← NME +1;  
	IF NME ≤ BMAX THEN GO TO BILL1; 
	END ELSE
IF CVSIX(PN) < BILLS[NME,0] THEN BEGIN
	LIN ← INPUT(INCH1,1);
	IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
	END ELSE
IF CVSIX(PN) = BILLS[NME,0] THEN BEGIN
	NME← NME+1;
	LIN ← INPUT(INCH1,1);
	IF LENGTH(LIN) = 0 THEN END_FLAG ← 1;
	END ELSE
IF CVSIX(PN) > BILLS[NME,0] THEN BEGIN
	NME ← NME +1;
	GO TO BILL1;
	END;
IF END_FLAG = 1 ∧ NME < BMAX THEN GO TO BILL1;

END "MAIN";
SUMINT ← PRAINT + SAUINT + XERINT;

OUT(OUCH2,↓);
OUT(OUCH2,"PAST DUE TOTALS - "&↓&TAB&
	"Prancing pony: "¢s(prabot)&"  Interest: "&CENTS(PRAINT)&"  Total: "¢s(prabot+praint)&↓&TAB&
	"Sauna: "¢s(saunot)&"  Interest: "¢s(sauint)&"  Total: "¢s(saunot+sauint)&↓&tab&
	"Xerox/Velo-Bind: "¢s(xerbot)&"  Interest: "¢s(xerint)&"  Total: "¢s(xerbot+xerint)&↓&tab& 
	"TOTAL PAST DUE: "&CENTS(SUMOT)&"  Interest: "¢s(sumint)&"  Total: "¢s(sumot+sumint)&↓);
out(ouch2,"Share Totals - "&↓&
	tab&"Old Share Totals: "¢s(sharetot)&" "&"New Share Totals: "¢s(sharet)&↓&
	tab&"Old Dividend Balances: "¢s(divbaltot)&" "&"New Dividends Paid: "¢s(divnt)&↓&
	tab&"Dividend Reductions: "¢s(-divit)&↓&
	(IF REDT THEN TAB&"Repayments Total: "¢s(-redt)&↓  else null)&
	tab&"TOTAL DIVIDENDS: "&CENTS(DIVBALT)&↓);
Out(ouch2,"New Charges Totals - "&↓&tab&
	"Prancing Pony: "¢s(prabnt-prabot-PRAINT)&↓&tab&
	"Sauna: "¢s(saunnt-saunot-SAUINT+DIVIT)&↓&tab&
	"Dividends Paid: "¢s(-divit)&↓&tab&
	"Xerox/Velo-Bind: "¢s(xerbnt-xerbot-XERINT)&↓&tab&
	"Total New Charges: "¢s(prabnt+saunnt+xerbnt-sumot-sumint)&↓);
out(ouch2,"Total Due - "&↓&tab&
	"Prancing Pony: "¢s(prabnt)&" "&"Sauna: "¢s(saunnt)&↓&tab&
	"Xerox/Velo-Bind: "¢s(xerbnt)&↓&tab&
	"TOTAL DUE: "&CENTS(prabnt+saunnt+xerbnt)&↓);
CLOSE(OUCH2); CLOSE(OUCH1); CLOSE(OUCH3); CLOSE(INCH1); CLOSE(OUCH4);
END "MERG";


OPEN(INCH1←GETCHAN,"DSK",1,4,0,CNT←200,BRK,EOF);
OPEN(OUCH1←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH2←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH3←GETCHAN,"DSK",1,0,4,0,0,0);
OPEN(OUCH4←GETCHAN,"DSK",1,0,4,0,0,0);

ENTER(OUCH4,MON&".OLD[P,PAW]",FLAG);
IF FLAG THEN LOSE(MON&".OLD[P,PAW]");

ENTER(OUCH3,MON&".NEG[P,PAW]",FLAG);
IF FLAG THEN LOSE("CHARGE.NEG[P,PAW]");

LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN ARRYIN(OUCH,CHARGES[1],MAX+1) 
ELSE OUT(INTTY,"CANNOT ENTER FILE "&MON&".PNY[PNY,SYS]. MAX = "&CVS(MAX));
SWAP ← 1;
outstr("sorting"&↓);

BEGIN	"HEAPSORT"
	INTEGER I,J,K,X,Y,Q,N;
	DEFINE A="CHARGES";
	N ← MAX/2;
COMMENT PHASE ONE, PUT 'EM UNDER THE HEAP & BIGGIES TRICKLE UP;
	FOR K←2 STEP 1 UNTIL N DO
	BEGIN
		I←K;
		X←A[2*K-1];
		Y←A[2*K];
		WHILE I>1 ∧ X>A[2*(J←I%2)-1] DO
		BEGIN A[2*I-1]←A[2*J-1];A[2*I]←A[2*J];I←J END;
		A[2*I-1]←X;
		A[2*I]←Y;
	END;

COMMENT PHASE TWO, TAKE 'EM OFF THE TOP & PROMOTE SUBORDINATES;
	FOR K←N STEP -1 UNTIL 2 DO
	BEGIN
		X←A[2*K-1];Y←A[2*K];
		A[2*K-1]←A[1];A[2*K]←A[2];
		I←1;
		WHILE (J←2*I)<K DO
		BEGIN
			IF A[2*(J+1)-1]>A[2*J-1] ∧ (J+1)<K THEN J←J+1;
			IF X≥A[2*J-1] THEN DONE ELSE
			BEGIN A[2*I-1]←A[2*J-1];A[2*I]←A[2*J];I←J;END;
		END;
		A[2*I-1]←X;
		A[2*I]←Y;
	END;
END	"HEAPSORT";
CLOSE(OUCH);

A←0; II←0;
COMMENT READ AND STORE FIRST NAME;
BILLS[A←A+1,0] ← NME ← CHARGES[II←II+1] LAND '777777000000;
ADDEM;
COMMENT CLANK THROUGH FILE AND ACCUMULATE CHARGES UNTIL NEW NAME IS FOUND;
outstr("accumulate charges"&↓);
WHILE II < MAX-1 DO BEGIN
	NME1 ← CHARGES[II←II+1] LAND '777777000000;
	IF NME = NME1 THEN ADDEM ELSE BEGIN
		COMMENT CHARGE $3.00 MAXIMUM FOR COFFEE;
		IF BILLS[A,1] > 300 THEN BILLS[A,1] ← 300;
		COMMENT ACCUMULATE PONY CHARGES;
		FOR B ← 1 STEP 1 UNTIL 6 DO
		BILLS[A,9] ← BILLS[A,9] + BILLS[A,B];
		NME ← NME1;
		BILLS[A←A+1,0] ← NME;
		ADDEM;
		END;
	END;
IF BILLS[A,1] > 300 THEN BILLS[A,1] ← 300;
FOR B ← 1 STEP 1 UNTIL 6 DO
BILLS[A,9] ← BILLS[A,9] + BILLS[A,B];
ENTER(OUCH1,MON&".ACT[P,PAW]",FLAG);
IF ¬FLAG THEN BEGIN
BMAX ← A;
FOR NME ← 1 STEP 1 UNTIL A DO BEGIN
	OUT(OUCH1,CVXSTR(BILLS[NME,0]));                        
FOR NME1 ←1 STEP 1 UNTIL 9 DO BEGIN
	OUT(OUCH1,"  "&CVS(BILLS[NME,NME1]));
	BILLS[A+1,NME1] ← BILLS[A+1,NME1] + BILLS[NME,NME1];
	END;
	OUT(OUCH1,↓);
	END;
OUT(OUCH1,"TOTAL ");
FOR NME1 ← 1 STEP 1 UNTIL 9 DO 
OUT(OUCH1,"  "&CVS(BILLS[A+1,NME1]));
CLOSE(OUCH1);
END;
MERGE;
RELEASE(INCH1); RELEASE(OUCH1); RELEASE(OUCH2); RELEASE(OUCH3); RELEASE(OUCH4);
GO TO STOP;
END;
COMMENT In case you were wondering, as I was, where this starts, you've found it;

DATE;
C ← 0;


Comment INIT the TTY we're using. 400 bit means don't wait for it;
OPEN(INTTY,"TTY",'401,1,1,CNT←200,BRK,EOF);
IF EOF THEN GO TO STOP;  Comment in case open failed;


OPEN(INCH←GETCHAN,"DSK",'10,4,4,CNT←200,BRK,EOF);
IF EOF THEN BEGIN
	OUT(INTTY,"CANNOT OPEN INPUT DISK FILE");
	GO TO STOP;
	END;



OPEN(OUCH←GETCHAN,"DSK",'17,0,0,CNT←200,BRK,EOF);
IF EOF THEN BEGIN
	OUT(INTTY,"CANNOT OPEN OUTPUT DISK FILE");
	GO TO STOP;
	END;


SETBREAK(1,'12,'15,"INS");
SETBREAK(2," ,",NULL,"INS");
SETBREAK(3,"0123456789+-.",NULL,"INS");
SETBREAK(4,"0123456789+-","","XNR");
SETBREAK(5,"0123456789+-.",NULL,"INR");
SETBREAK(18,".",NULL,"INS");
SETBREAK(17,"0123456789",NULL,"XNR");
SETFORMAT(8,6);

	I ← 0;
	PPN[I←1] ← CVSIX("SYS");
	WHILE READ ∧ (I < TOP) DO BEGIN
		PPN[I←I+1] ← CVSIX(LEFT(3,PROG));
		NAME[I] ← FRIENDLY&" "&LAST;
	END;
	IF I ≥ TOP THEN OUT(INTTY,"MAXIMUM NUMBER OF USERS IN SYSTEM. PROGRAM"&↓&
				  "REQUIRES ALTERATION TO ALLOW MORE USER'S."&↓&
				  "(TOP CURRENTLY = "&CVS(TOP)&") PLEASE NOTIFY"&↓&
				  "FRONT OFFICE");


OUT(INTTY,"CODES: X = XEROX/VELO-BIND, P = SAUNA"&↓&
	  "ALL CODES AND AMOUNTS MUST BE ENTERED IN UPPER CASE LETTERS"&↓&
	  "AFTER ALL CHARGES HAVE BEEN ENTERED TYPE `RUN' IN RESPONSE TO `NEXT!'"&↓&↓);


START:
	GOODS←S ← ""; ID ← 0;
	OUT(INTTY,↓&"NEXT! ");
	S ← INPUT(INTTY,1);
	IF EQU(S,"RUN") ∨ EQU(S,"run") THEN BEGIN
		IF LIMIT ≤ 0 THEN BEGIN
			LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
			IF ¬FLAG THEN BEGIN
				FILEINFO(CHARGF);
				LIMIT ← -(CHARGF[3] ROT 18);
				END
			ELSE GO TO STOP;
			CLOSE(OUCH);
			END;
		BILL(LIMIT);
END;
	IF LENGTH(S)=0 THEN GO TO START; Comment flush null commands;
	ID ← CVSIX(LEFT(3,SCAN(S,2,BRK)));
	FOR A ← 1 STEP 1 UNTIL I DO
	IF ID = PPN[A] LAND ('777777000000) THEN DONE;
	IF A > I THEN BEGIN    
        OUT(INTTY,"PPN DOES NOT APPEAR IN A.I. DIRECTORY."&↓&
	  	  "TYPE `Y' IF IT IS CORRECT ELSE CR.");
	SFOO←INCHWL; IF SFOO = "Y" ∨ SFOO = "y" THEN NAME[I] ← CVXSTR(PPN[I])
						ELSE GO TO START;
	END;
RETRY0:
	ZZ ← 0;
	WHILE LENGTH(S) DO BEGIN
		GOODS ← SCAN(S,2,BRK);
RETRY:
		IF(K←GOODS) = "V" ∨
		       K = "A" ∨
		       K = "M" ∨
		       K = "P" ∨
		       K = "C" ∨
		       K = "X" ∨
		       K = "D" ∨
		       K = "S" ∨
		       K = "B" THEN BEGIN 
			CDE[ZZ←ZZ+1] ← LOP(GOODS);       
			AMT ← GOODS;
                        NUM ← 0;                
			N1 ← 1;        
			IF GOODS = "-" THEN N1 ← -1;
			IF GOODS = "+" ∨ GOODS = "-" THEN K ← LOP(GOODS)
			ELSE IF GOODS = "$" THEN K ← LOP(GOODS);           
         		S1 ← SCAN(GOODS,18,BRK); COMMENT SCAN TO A DECIMAL;
			IF BRK = 0 THEN BEGIN
			    S1 ← SCAN(S1,17,NUM);
			    IF NUM = 0 THEN NUM ← CVD(S1)
			  ELSE ERROR(3);
			    IF NUM < 4 THEN NUM ← NUM*100;
			END
		        ELSE IF LENGTH(S1) THEN BEGIN
			    S1 ← SCAN(S1,17,NUM);
			    IF NUM = 0 THEN NUM ← CVD(S1)*100     
			ELSE ERROR(3);
			END;
			IF BRK = "." THEN BEGIN
			    IF LENGTH(GOODS) > 2 THEN ERROR(3);
			    GOODS ← GOODS&"00";
  			    S2 ← GOODS[1 FOR 2];
			    S2 ← SCAN(S2,17,BRK); COMMENT SCAN FOR NUMERIC VALUES ONLY;
			    IF BRK = 0 THEN NUM ← NUM+CVD(S2)
			ELSE ERROR(3);
			END;
			IF  (K←CDE[ZZ]) = "S" ∧ NUM < 15  
						THEN ERROR(5);
			IF K = "B" ∧ (NUM < 15 ∨ NUM MOD 15)
						THEN ERROR(5);
			IF K = "C" ∧ (NUM < 10 ∨ NUM MOD 10) THEN ERROR(5);
			IF K = "D" ∧ NUM < 20 THEN ERROR(6);
			AMOUNT[ZZ] ← NUM*N1;
	        END 
		ELSE ERROR(2);
	END;

BN←1; LNGTH←0;
LOOKUP(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF ¬FLAG THEN BEGIN
    	FILEINFO(CHARGF);
        LNGTH ← -(CHARGF[3] ROT 18);
	LIMIT ← LNGTH;
	OUT(INTTY,CVS(LIMIT)&↓);
        BN ← (LNGTH%128)+1;
	LNGTH ← LNGTH MOD 128;
	IF LNGTH>0 THEN BEGIN
		USETI(OUCH,BN);
		ARRYIN(OUCH,REC[1],LNGTH);
		END;
	Comment Avoid CLOSE(OUCH) because we need to get into r/a mode;
	END;
ENTER(OUCH,MON&".PNY[PNY,SYS]",FLAG);
IF FLAG THEN BEGIN
	OUT(INTTY,"CANNOT ENTER FILE "&MON&".PNY[PNY,SYS]. PLEASE NOTIFY THE FRONT"&↓&
                  "OFFICE OF THIS. YOU WILL BE UNABLE TO USE THE TTY TO ENTER"&↓&
		  "CHARGES. SORRY");
	GO TO STOP;
	END;

FOR K ← 1 STEP 1 UNTIL ZZ DO BEGIN
	IF AMOUNT[K] ≠ 0 THEN BEGIN
		REC[LNGTH←LNGTH+1] ← ID LOR DAY;
		REC[LNGTH←LNGTH+1] ← CVSIX(CDE[K]) LOR (AMOUNT[K] LAND '777777);
		END;
	END;
USETO(OUCH,BN);
ARRYOUT(OUCH,REC[1],LNGTH);
CLOSE(OUCH);  Comment Release accounting file;
FOR K ← 1 STEP 1 UNTIL ZZ DO AMOUNT[K] ← 0;
GO TO START;

STOP:
RELEASE(INTTY);
RELEASE(INCH);
RELEASE(OUCH);

SPOOL(MON&".BIL[P,PAW]",GETCHAN,0);
SPOOL(MONOLD&".BIL[P,PAW]",GETCHAN,0);
SPOOL(MON&".NEG[P,PAW]",GETCHAN,0);
SPOOL(MON&".ACT[P,PAW]",GETCHAN,0);

OUTSTR("DO YOU WANT TO SPOOL THE INDIVIDUAL BILLS? ");
IF K←INCHWL = "Y" THEN
PTOSTR(0,"XSP BILL.LST[P,PAW]/PMAR=0/DEL"&↓);
END;