(George Source)
Macros used: BC, BUDGPAR, BUDGUSE, BUDGWRITE, CHECKOWNER, CLOSE, COMBRKIN, COMERR, COMERRX, DICTJL, DICTWELL, ENDCOM, GEOERR, HUNT, JBC, MENDAREA, MFREE, MHUNT, MONOUT, NAME, OPEN, OUTBLOCK, OUTNUM, OUTPARAM, READDICT, REPLACE, SEGENTRY, SETUPCORE, TESTERR, TESTREP, TESTREP2, TRACE, UNIFREE, VFREE, WRONG
22FL #LIS K0ALLOW>K0BUDGES>K0COMMAND>K0GREATGEO>K0ALLGEO 22^= #SEG ALLOW1 [M.B.KINGHAM 23DW 8HALLOW1 23YG SEGENTRY K1ALLOW,QK1ALLOW 24D6 # 1 THE ALLOWANCE COMMAND INCREASES A TRANSIENT BUDGET ALLOWANCE 24XQ # 1 OF A NAMED USER OR REDUCES A TRANSIENT BUDGET ALLOWANCE 25CB # 1 OF AN IMMEDIATE INFERIOR OF THE PROPER USER 25X2 # 26BL # THE REQUIRED BLOCKS OF CORE ARE SET UP; THE DICTIONARY IS OPENED; 26W= # AND THE PARAMETERS ARE CHECKED. IF THERE ARE NO ERRORS, THE 27*W # CHANGES CAUSED BY THE TRANSACTION ARE MADE; THE DICTIONARY IS 27TG # CLOSED; A MESSAGE IS SENT TO THE MONITORING FILE, AND CONTROL 28*6 # RETURNS TO THE COMMAND PROCESSOR 28SQ # 29#B # MESSAGES FOR THE MONITORING FILE 29S2 YERB7 +ERB7 [PSEUDO USER 2=?L YERB20 +ERB20 [YOU MAY REDUCE ALLOWANCES OF ONLY YOUR 2=R= [IMMEDIATE INFERIORS 2?=W YERB21 +ERB21 [YOU MAY NOT CHANGE YOUR OWN ALLOWANCES 2?*F ...#UNSET FTS1 2?D4 ...( 2?GM ...YERB29 +ERB29 [YOU MAY NOT REDUCE MANAGER'S 2?K= ... [ALLOWANCE 2?MT ...) 2?QG YERB3 +ERB3 2#=6 YERB5 +ERB5 2#PQ MAN 12HMANAGER 2*9B # 2*P2 # MASKS FOR STANDARD BUDGETARY CLASSIFICATIONS FROM BUDGET TYPE WORDS 2B8L MGWORDS +GWORDS [GENERAL- NO. OF INFORMATION WORDS 2BN= MGMASK +GMASK [UNIQUE PART OF BIT PATTERN 2C7W MGCLASS +GCLASS [BUDGET CLASSIFICATION BITS 2CMG MGPAND +GPAND [PRIVILEGES 2D76 MGPOR +GPOR 2DLQ MGSAND +GSAND [STABLE BUDGETS 2F6B MGSOR +GSOR 2FL2 MGTAND +GTAND [TRANSIENT BUDGETS 2G5L MGTOR +GTOR 2GK= # DEFINITIONS FOR THE ADATA,CSTORE BLOCK 2H4W #DEF UNAMED=A1 [USERNAME OF NAMED USER 2HJG #DEF UCURRENT=UNAMED+3 [USERNAME OF CURRENT PROPER USER 2J46 #DEF UTYPE=UCURRENT+3 [BUDGET TYPE BIT PATTERN 2JHQ #DEF UCHANGE=UTYPE+1 [CHANGE AMOUNT 2K3B #DEF UCMARK=UCHANGE+1 [INCREASE MARKER FOR CURRENT USER 2KH2 #DEF UNMARK=UCMARK+1 [INCREASE MARKER FOR NAMED USER 2L2L #DEF UCREMAINS=UNMARK+1 [CURRENT USER'S REMAINDER 2LG= #DEF UNREMAINS=UCREMAINS+1 [NAMED USER'S REMAINDER 2L^W #DEF UNUIS=UNREMAINS+1 [1 IF NU=IS ; 0 OTHERWISE 2MFG #DEF URCMARK=UNUIS+1 [0 OR CURRENT USER'S OVERDRAFT 2M^6 #DEF URNMARK=URCMARK+1 [0 OR NAMED USER'S OVERDRAFT(BUDGETS ONLY 2NDQ QK1ALLOW 2NKY ... STOZ AWORK1(2) [CLEAR 'PROPER/NAMED' USER IS... 2NR6 ... [ ...MANAGER' FLAG 2NYB BUDGPAR AW,MBREAK,QR 2PD2 OPEN MBREAK,GENERAL,QUERY 2PXL TESTREPN OK,OPENERR 2QC= READDICT [FOR NAMED USER 2QWW TESTERR NOUSER,WOE3 [IF NOT FOUND,NO SUCH USER EXISTS 2RBG # THE NAMED USER'S DICTIONARY ENTRY IS NOW IN A FILE,ADICTENT BLOCK 2RW6 HUNT 2,FILE,ADICTENT 2S*Q LDX 0 CPSEU(2) 2STB LDX 6 YERB7(1) [IF THE NAMED USER IS A PSEUDO USER, HE 2T*2 BNG 0 WRONG [HAS NO BUDGETS,SO THERE IS AN ERROR 2TSL # THE BUDGET DESCRIPTION LIST IS IN THE FIRST RECORD OF THE DICTIONARY 2W#= # THE SECOND PARAMETER IS THE BUDGET TYPE AS AN EIGHT CHARACTER STRING 2WRW HUNT 2,ADATA,CSTORE 2X?G HUNT 3,FILE,ADICTENT 2X#R ... LDX 4 CUSER(3) 2XB4 ... LDX 5 CUSER+1(3) 2XC* ... LDX 6 CUSER+2(3) 2XDL ... TXU 4 MAN(1) 2XFX ... TXU 5 MAN+1(1) 2XH8 ... TXU 6 MAN+2(1) 2XJF ... BCS NMANNU 2XKQ ... LDN 7 1 2XM3 ... SMO FX2 2XN# ... NGS 7 AWORK1 [NAMED USER IS MANAGER 2XPK ...NMANNU 2XR6 LDX 4 UCURRENT(2) 2Y=Q LDX 5 UCURRENT+1(2) [IS THE NAMED USER EQUAL TO THE 2YQB LDX 6 UCURRENT+2(2) [CURRENT PROPER USER? 2^=2 TXU 4 CUSER(3) 2^PL TXU 5 CUSER+1(3) 329= TXU 6 CUSER+2(3) [IF SO, THE TRANSACTION IS ILLEGAL 32NW BCS Q0 338G LDX 6 YERB21(1) [IF SO,SEND MESSAGE "YOU MAY NOT 33N6 BRN WRONG [TO CHANGE YOUR OWN ALLOWANCES" 347Q Q0 36KW TXU 4 MAN(1) 375G TXU 5 MAN+1(1) 37K6 TXU 6 MAN+2(1) 37LF ... BCS NINFERIOR [J IF PROPER USER NOT MANAGER 37MS ... LDN 7 1 37P7 ... SMO FX2 37QG ... STO 7 AWORK1 [PROPER USER IS MANAGER 37RT ... BRN Q001 37T8 ...NINFERIOR 37WH ... TXU 4 CSUPUSER(3) 37XW ... TXU 5 CSUPUSER+1(3) 37^9 ... TXU 6 CSUPUSER+2(3) [OK IF NAMED USER IS AN IMMEDIATE 382J ... BCC Q001 [INFERIOR OF PROPER USER 383X ...NMANPU 385H ...#UNSET FTS1 386# ...( 3875 ... MFREE FILE,FABSNB [FREE MASTERS' FABSNB 387W ... CHECKOWNER [OR HAS ACCESS VIA ALLACC OR 388M ... HUNT 2,ADATA,CSTORE 389D ... HUNT 3,FILE,ADICTENT 38=9 ... TESTREPN OK,M405 [INFACC PRIVILEGE 38?2 ... LDX 4 CUSER(3) 38?R ... LDX 5 CUSER+1(3) 38#J ... LDX 6 CUSER+2(3) 38** ... TXU 4 MAN(1) 38B6 ... TXU 5 MAN+1(1) 38BX ... TXU 6 MAN+2(1) 38CN ... BCS Q001 [J IF NAMED USER NOT MANAGER 38DF ... LDX 6 YERB29(1) 38F= ... LDX 7 UCHANGE(2) 38G3 ... BNG 7 WRONG [CANNAT REDUCE MANAGER'S ALLOWANCE 38GS ... BRN Q001 38HK ...) 38JB M405 3942 #SKI K6BUDGET>9999-9999 39HL TRACE UCURRENT(2),BUDUC=IS 3=3= LDN 0 1 [SET MARKER- NAMED USER IS IMMEDIATE 3=GW STO 0 UNUIS(2) [INFERIOR OF PROPER USER IF UNUIS=0 3?2G # (AND THUS INFORMATION ABOUT THE NAMED USER'S BUDGETS 3?G6 # MAY BE DISCLOSED IF UNUIS=0) 3?^Q #SKI K6BUDGET>9999-9999 3#FB TRACE CUSER(3),BUNV=IS? 3#^2 LDX 6 YERB20(1) 3*DL LDX 7 UCHANGE(2) 3*Y= BNG 7 WRONG [ILLEGAL IF THE CHANGE IS NEGATIVE 3BCW # MESSAGE: "YOW MAY REDUCE ALLOWANCES OF ONLY YOUR IMMEDIATE INFERIORS 3BXG Q001 READDICT [READ THE CURRENT USER'S ENTRY 3CC6 # THIS SECTION DEALS WITH QUANTITATIVE BUDGETS 3CWQ # THE CURRENT PROPER USER'S DICTIONARY ENTRY IS IN THE FIRST 3DBB # FILE,ADICTENT IN THE CHAIN; THE NAMED USER'S ENTRY IN IN THE NEXT 3DW2 HUNT 3,ADATA,CSTORE 3F*L NGX 4 UCHANGE(3) 3FT= LDX 5 UTYPE(3) [FOR CURRENT USER 3G#W BUDGUSE UTYPE(3) [READ APPROPRIATE BUDGET RECORD 3GSG TESTREP2 OK,QF 3H#6 # IF THE CURRENT USER HAS NO SUCH BUDGET RECORD 3HRQ CALL 7 QSRN [X5=BUDGET TYPE,X4= -IVE CHANGE 3J?B # QSRN SETS UP THE REQ'D BUDGET RECORD,AND WRITES IT TO THE 3JR2 # FILE,ADICTENT,UNLESS THE CHANGE IS PESITIVE. 3K=L STO 4 UCREMAINS(3) [STORE CHANGE AMOUNT AS REMAINDER 3KQ= #SKI K6BUDGET>9999-9999 3L9W TRACE UCREMAINS(3),BUDGQN 3LPG HUNT 2,FILE,ADICTENT 3M96 NAME 2,FILE,FWB 3MNQ BRN Q2 3N8B # IF THE QUANTITATIVE BUDGET RECORD WAS FOUND: 3NN2 QF CALL 7 QSRF [X5=BUDGET TYPE,X4=-VE CHANGE 3P7L # QSRF MAKES THE NECESSARY CHECKS AND ALTERATIONS TO THE BUDGET RECORD 3PM= # AND WRITES IT BACK TO THE FILE,ADICTENT. 3Q6W STO 6 URCMARK(3) [OVERDRAFT(IF NOT 0). 3QLG STO 5 UCREMAINS(3) [CURRENT USER'S REMAINING RATION 3R66 #SKI K6BUDGET>9999-9999 3RKQ TRACE UCREMAINS(3),BUDGQF 3S5B HUNT 2,FILE,ADICTENT 3SK2 NAME 2,FILE,FWB [RENAME BLOCK FOR REWRITING IN SITU 3T4L # AT THIS POINT THE CURRENT USER'S ENTRY HAS BEEN CHECKED AND ALTERED, 3TJ= # BUT THE FILE HAS NOT BEEN CHANGED 3W3W # THE DICTIONARY ENTRY FOR THE NAMED USER IS NOW IN THE 3WHG # FIRST FILE,ADICTENT. 3X36 Q2 LDX 5 UTYPE(3) 3XGQ LDX 4 UCHANGE(3) 3Y2B BUDGUSE 5 3YG2 TESTREP2 OK,Q2F 3Y^L # IF THE NAMED USER HAS NO SUCH RECORD: 3^F= CALL 7 QSRN 3^YW #SKI K6BUDGET>9999-9999 42DG TRACE 4,BUDGQ2N 42Y6 BRN Q3 43CQ # IF THE NAMED USER'S RECORD HAS BEEN FOUND 43XB Q2F CALL 7 QSRF 44C2 STO 6 URNMARK(3) [OVERDRAFT (IF NOT NOUGHT) 44WL STO 5 UNREMAINS(3) [REMAINDER OF NAMED USER'S RATION 45B= #SKI K6BUDGET>9999-9999 45TW TRACE URNMARK(3),BUDGQ2F 46*G Q3 46FC ... SMO FX2 [AWORK1 => 1 IF MANAGER IS PROPER US 46K# ... LDX 0 AWORK1 [ => 0 IF NOT MANAGER 46P9 ... SBN 0 1 [ => -1 IF MANAGER IS NAMED USE 46T6 ... BZE 0 Q3MISS [J IF PROPER USER IS MANAGER 46^3 ...Q3DO 474Y ... REPLACE [REPLACE PROPER USER'S DICTIONARY ENT 478T ...Q3MISS 47#Q MFREE FILE,FWB 47SB #SKI K6BUDGET>9999-9999 48#2 TRACE 1,BUDGQ3 48RL READDICT 49?= VFREE FILE,ADICTENT [NAMED USER'S DICTIONARY ENTRY 49QW HUNT 2,FILE,ADICTENT 4==G NAME 2,FILE,FWB 4=#D ...#SKI JWPHASE2 4=BB ...( 4=D# ... JBC NDW,2,BMONCS 4=G= ... BC 2,BMONCS 4=J8 ... DICTWELL CUSER(2),MONEY,2 4=L6 ...NDW 4=N4 ...) 4=Q= ... SMO FX2 [AWORK1 => 1 IF MANAGER IS PROPER US 4=SD ... LDX 0 AWORK1 [ => 0 IF NOT MANAGER 4=WL ... ADN 0 1 [ => -1 IF MANAGER IS NAMED USE 4=YS ... BZE 0 Q5MISS [J IF NAMED USER IS MANAGER 4?32 ...Q5DO 4?58 ... REPLACE [REPLACE NAMED USER'S DICTIONARY ENTR 4?7B ...Q5MISS 4?9Q MFREE FILE,FWB 4?PB #SKI K6BUDGET>9999-9999 4#92 TRACE 1,BUDGQ4 4#NL Q5 CLOSE [CLOSE DICTIONARY 4#TS ...#UNSET FTS1 4*32 ... DICTJL [UPDATE JOBLIST FILES 4*8= # SET UP MESSAGES FOR MONITORING FILE 4*MW HUNT 2,ADATA,CSTORE 4B7G LDX 7 URCMARK(2) [IS THE CURRENT USER OVERDRAWN? 4BM6 BPZ 7 Q501 4C6Q NGX 7 7 4CLB # IF THE CURRENT USER IS OVERDRAWN -SEND MESSAGE 4D62 # "%A OVERDRAWN BY %B;REMAINING ALLOWANCE%C" 4DKL LDX 6 UCREMAINS(2) [SELECT C.U. REMAINDER 4F5= LDN 5 12 4FJW LDN 0 10 4G4G OUTBLOCK 0 4GJ6 OUTPARAM 5,UCURRENT,ADATA,CSTORE 4H3Q OUTNUM 7,0 4HHB OUTNUM 6,0 4J32 MONOUT ERBOK4 4JGL HUNT 2,ADATA,CSTORE 4K2= LDX 7 URNMARK(2) [IS THE NAMED USER OVERDRAWN? 4KFW BNG 7 Q502 4K^G Q500 4LF6 #SKI K6BUDGET>999-999 4LYQ ( 4MDB TRACE 6,BUDGEND1 4MY2 TRACE 7,BUDGEND2 4NCL TRACE UNAMED(2),BUDGEND3 4NX= ) 4PBW BRN QR 4PWG Q501 LDX 7 URNMARK(2) 4QB6 BPZ 7 Q503 [IS THE NAMED USER OVERDRAWN? 4QTQ Q502 NGX 7 7 4R*B LDX 4 UNUIS(2) [NO INFORMATION MUST BE OUTPUT ABOUT 4RT2 BNZ 4 Q503 [THE NAMED USER'S ENTRY IF THE NAMED USER 4S#L LDX 6 UNREMAINS(2) [IS A SUPERIOR OF THE CURRENT USER 4SS= LDN 5 12 4T?W LDN 0 10 4TRG OUTBLOCK 0 4W?6 OUTPARAM 5,UNAMED,ADATA,CSTORE 4WQQ OUTNUM 7,0 4X=B OUTNUM 6,0 4XQ2 MONOUT ERBOK4 4Y9L HUNT 2,ADATA,CSTORE 4YP= Q503 LDX 7 URCMARK(2) [IF PROPER USER NOT OVERDRAWN 4^8W BNG 7 Q500 [THEN OUTPUT OK METSAGE 4^NG NGX 7 7 4^RL ... SMO FX2 [AWORK1 => 1 IF MANAGER IS PROPER US 4^WQ ... LDX 0 AWORK1 [ => 0 IF USER IS NOT MANAGER 4^^W ... SBN 0 1 [ => -1 IF MANAGER IS NAMED USE 5252 ... BZE 0 QMANOK [J IF PROPER USER IS MANAGER 5286 LDX 6 UCREMAINS(2) [X6=NEW ALLOWANCE 52MQ ADX 7 6 [X7=AMOUNT CONSUMED 537B LDN 0 6 53M2 OUTBLOCK 0 546L OUTNUM 6,0 54L= OUTNUM 7,0 555W MONOUT JOKAL [OK:YOUR AW IS:CONSUMED: 55KG BRN Q500 55PC ...QMANOK 55T# ... MONOUT ERBOK3 [OUTPUT MESSAGE 'OK' - PROPER USER IS 55^9 ... BRN Q500 [J TO 'ENDCOM' 5656 WRONG LDX 1 FX1 567P ...#UNSET FTS1 56=# ...( 56#X ... TXU 6 YERB29(1) 56CG ... BCC WOE1 56G5 ...) 56JQ TXU 6 YERB20(1) 574B BCC WOE1 57J2 TXU 6 YERB21(1) [FOR MESSAGES WHICH DO NOT USE A 583L BCC WOE1 [PARAMETER BLOCK, ALL CPB,CUNI BLOCKS 58H= TXU 6 YERB5(1) [ARE FREED 592W BCS WOE2 59GG WOE1 UNIFREE 5=26 WOE2 CLOSE 5=FQ COMERRX 6 5=^B WOE3 CLOSE 5?F2 QR ENDCOM 5?YL OPENERR 5#D= TESTREP CLUDGE,OP1 5#XW GEOERR 1,OPENREP 5*CG OP1 5*X6 UNIFREE 5BBQ COMERR ERSYSCLUDG,FDIC 5BWB # 5CB2 # THIS SUBROUTINE ALTERS THE BUDGET RECORD,WHICH HAS BEEN FOUND 5CTL QSRF MHUNT 2,JBUDGET,JBUDGUSER 5D*= ADS 4 JALLOWED(2) 5DSW LDX 5 JALLOWED(2) 5F#G LDX 6 YERB3(1) 5FS6 BNG 5 WRONG [ERROR IF NEW ALLOWANCE IS NEGATIVE 5G?Q NGX 6 JCONSUMED(2) 5GRB ADX 6 5 5H?2 BPZ 6 QSRF1 [ERROR IF NEW AW-CONSUMED IS NEGATIVE 5HQL BPZ 4 QSRF1 [AND THE CHANGE AMOUNT WAS ALSO -VE 5J== LDX 6 YERB3(1) 5JPW BRN WRONG 5K9G QSRF1 SBX 7 FX1 5KP6 BUDGWRITE 5L8Q ADX 7 FX1 5LNB MHUNT 3,ADATA,CSTORE 5M82 EXIT 7 0 5MML # IF THE BUDGET RECORD WAS NOT FOUND,QSRN IS CALLED. 5N7= # THIS SUBROUTINE SETS UP A NEW BUDGET RECORD 5NLW QSRN SBX 7 FX1 5P6G SMO FX1 5PL6 LDX 6 YERB3 5Q5Q BNG 4 WRONG [ IS CORRECTLY SIGNED 5QKB LDX 6 5 5R52 ANDX 6 MGWORDS(1) [FIND NO. OF INFORMATION WORDS REQ'D 5RJL ADN 6 1 [BY THIS BUDGET TYPE 5S4= SETUPCORE 6,3,JBUDGET,JBUDGUSER 5SHW SBN 6 1 5T3G STO 6 A1(3) [SET UP BUDGET RECORD 5TH6 STO 5 JBITS(3) 5W2Q STOZ JRATION(3) 5WGB STO 4 JALLOWED(3) 5X22 SBN 6 3 5XFL QSRN1 SMO 6 [CLEARING THE NON-STANDARD WORDS 5X^= STOZ JALLOWED(3) [AS WELL AS JRATION AND JCONSUMED 5YDW BCT 6 QSRN1 5YYG BUDGWRITE [WRITE BUDGET RECORD TO FILE,ADICTENT 5^D6 HUNT 3,ADATA,CSTORE 5^XQ ADX 7 FX1 62CB EXIT 7 0 62X2 # 63BL MBREAK 63W= COMBRKIN [IF BROKEN IN 64*W # 64TG MENDAREA 50,K99ALLOW 65*6 #END ^^^^ ...43447173000300000000