ACRFSS12 ;IHS/OIRM/DSD/THL,AEF - DISPALY AND EDIT SERVICES/SUPPLIES PROCURED; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;CONTINUAITON OF ACRFSS1,25T
DISPLAY ;EP;TO DISPLAY SUPPLIES/SERVICES FOR A REQUEST
Q:$D(ACROUT)
D PHEAD:'$D(ACRORIGF)
S ACRDOCVN=$P(ACRDOCPO,U,5)
I $D(ACRPRT)!$D(ACRREV),ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,$G(ACRAPVT)'=31!($G(ACRAPVT)=6) D
.S D0=ACRDOCDA
.D ^ACRFJS
D PHEAD:'$D(ACRORIGF)
D HEAD^ACRFSSD1:'$D(ACRORIGF)
K ACRSS
S ACRXREF=$S(ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!($P(^ACRDOC(ACRDOCDA,0),U,4)=35&($P($G(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",'$D(ACRPO)&'$D(ACRPPO):"C",1:"J")
S (ACRSSDA,ACRSSTOT,ACRSJ)=0
F S ACRSSDA=$O(^ACRSS(ACRXREF,ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D
.S ACRSSTOT=ACRSSTOT+$P($G(^ACRSS(ACRSSDA,"DT")),U,4)
.S ACRSJ=ACRSJ+1
.N X
.S X=^ACRSS(ACRSSDA,0)
.S ACRSSX(+$P(X,U,2),ACRSJ)=ACRSSDA_U_^ACRSS(ACRSSDA,0)
.I '$D(ACRSCHK),'$D(ACRREV),'$D(ACRPRT),$D(^ACRAPVS("AB",ACRDOCDA)) D SCHK
.D SCHK1:$D(ACRSCHK)
N X,Y,I,J
S (X,I,J)=0
F S X=$O(ACRSSX(X)) Q:'X D
.S Y=0
.F S Y=$O(ACRSSX(X,Y)) Q:'Y D
..S J=J+1
..S:X'=ACRDOCDA ACRFROMX=1
..I J'=+^ACRSS(+ACRSSX(X,Y),0) D
...S DA=+ACRSSX(X,Y)
...S DIE="^ACRSS("
...S DR=".01///^S X=J"
...S $P(ACRSSX(X,Y),U,2)=J
...N X,Y
...D DIE^ACRFDIC
..S ACRSS(+$P(ACRSSX(X,Y),U,2))=ACRSSX(X,Y)
K ACRQUIT,ACRSSX
N ACRX
S (ACRX,ACRSSDA,ACRJ)=0
F S ACRX=$O(ACRSS(ACRX)) Q:'ACRX!$D(ACRQUIT)!$D(ACROUT) D
.I $G(ACRFROMX) D
..Q:$P(ACRSS(ACRX),U,3)=$G(ACRFROMX)
..S ACRFROMX=$P(ACRSS(ACRX),U,3)
..W !?3,$S('$D(ACRORIGF):"|",1:" ")
..D W^ACRFSSD
..W !?3,$S('$D(ACRORIGF):"|",1:" "),"(From Request NO: ",$P(^ACRDOC(ACRFROMX,0),U),")"
..D W^ACRFSSD
..W !?3,$S('$D(ACRORIGF):"|",1:" ")
..D W^ACRFSSD
.S ACRSSDA=+ACRSS(ACRX)
.D ^ACRFSSD
D ASC
K ACRQUIT,ACRFROMX
I ACRJ=0 D
.W !?5,"NO ITEMS ON FILE FOR THIS PROCUREMENT"
.I $D(^ACRSS("C",ACRDOCDA)),'$D(^ACRSS("J",ACRDOCDA)) D
..S ACRSSDA=$O(^ACRSS("C",ACRDOCDA,0))
..I ACRSSDA,+$G(^ACRSS(ACRSSDA,"PO")) D
...W !?5,"ITEMS TRANSFERRED TO PO: "
...W $P(^ACRDOC(+^ACRSS(ACRSSDA,"PO"),0),U,2)," (",$P(^ACRDOC(+^ACRSS(ACRSSDA,"PO"),0),U),")"
I ACRJ>0 D
.I ACRREFX=116,'$P(^ACRDOC(ACRDOCDA,0),U,19),$L($P(^ACRSYS(1,"DT"),U,19,20))>3 D EXCEED
.S:ACRSSTOT'["." ACRSSTOT=ACRSSTOT_".00"
.I $E(DT,4,5)<10,($E(DT,1,3)+1700)<$P($G(^ACRLOCB(+$P(ACRDOC0,U,6),"DT")),U) D I 1
..S ACRAPVTX="SUBJECT TO AVAILABILITY OF FUNDS"
.E I $E($P(ACRDOC0,U,3),5,7)>600,'$D(ACRPRT),'$D(ACRINV),$E(IOST,1,2)="P-" D
..W !,"THIS IS TO CERTIFY THAT THIS OBLIGATION IS WITHIN THE 30% FOURTH QUARTER"
..W !,"SPENDING LIMITATION AND THE 12% LIMITATION FOR THE MONTH."
.I '$D(ACRORIGF) D
..W $$DASH^ACRFMENU
..W !?47,"TOTAL |"
..W:'$D(ACRPQT) ?57,$J($FN(ACRSSTOT-$G(ACRQD),"P",2),10)
..W ?67,"|"
.S ACGRDA=$P(ACRDOC0,U,16)
.I ACGRDA,$D(^ACGS(ACGRDA,0)),$D(^("DT1")),(ACRSSTOT-$G(ACRQD))'=$P(^("DT1"),U,5) D
..S DR="26////"_(ACRSSTOT-$G(ACRQD))
..S DIE="^ACGS("
..S DA=ACGRDA
..D DIE^ACRFDIC
..K ACGRDA
D QUAN
I $E(IOST,1,2)="C-",($D(ACRPRT)!$D(ACRREV)),$G(ACRAPVT)'=31&($G(ACRAPVT)'=6) D
.D PAUSE^ACRFWARN
.W @IOF
Q
SCHK K ACRSCHK
N X
S X=0
F S X=$O(^ACRAPVS("AB",ACRDOCDA,X)) Q:'X!$D(ACRSCHK) I $D(^ACRAPVS(X,0)),$E($G(^ACRAPVS(X,"DT")))="A",$P(^ACRDOC(ACRDOCDA,0),U,13)=$P(^ACRAPVS(X,0),U,6) S ACRSCHK=""
Q
SCHK1 K ^TMP("ACRSS",$J,ACRSSDA)
S %X="^ACRSS("_ACRSSDA_","
S %Y="^TMP(""ACRSS"","_$J_","_ACRSSDA_","
D %XY^%RCR
Q
PHEAD ;EP;TO PRINT HEADER ON ADDITIONAL DOCUMENT PAGES
Q:$D(ACROUT)
S:'$D(ACRPHEAD) ACRPHEAD=$S('$D(ACRPQT):13,$G(ACRDC)=1:16,1:5)
I $E(IOST,1,2)="P-",IOSL-ACRPHEAD<$Y D
.I $G(ACRZIS(2))]"" S IOP=ACRZIS(2) D ^%ZIS G:POP>0 PHEAD U IO
.N DXS,DIP,DC,DN
.S D0=ACRDOCDA
.S ACRREFDA=$P(ACRDOC0,U,13)
.S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
.S:'$D(ACRREFX) ACRREFX=ACRREF
.W @IOF
.I $D(ACRPQT) D ^ACRPQH I 1
.I '$D(ACRPQT) D
..D ^ACRPRQH:ACRREFX=116!(ACRREFX=101)
..D ^ACRPTOH:ACRREFX=130
..D ^ACRPSH:ACRREFX=103
..I ACRREFX=349!(ACRREFX=326),$D(ACRORIGF),+$G(ACRPSC) D
...N X
...S X="HEAD^ACRF"_+ACRPSC_2
...D @X
K ACRPHEAD
Q
QUAN ;EP;TO PRINT QUANTITY DISCOUNT
I $P(ACRDOCPO,U,19),$P(ACRDOCPO,U,20)]"" D
.S ACRQDP=$P(ACRDOCPO,U,19)
.S ACRQD=$P(ACRDOCPO,U,20)
.S ACRQDT=$S(ACRSSTOT<ACRQDP:0,1:ACRQDP/100*ACRSSTOT)
.I ACRQDT'=$P($G(^ACRDOC(ACRDOCDA,13)),U,8) D
..S DA=ACRDOCDA
..S DIE="^ACRDOC("
..S DR="103921////"_ACRQDT
..D DIE^ACRFDIC
.W !,"QUANTITY DISCOUNT: ",$P(ACRQDP,U),"% if TOTAL > ",$FN(ACRQD,"P",2)
.W !?39,"DISCOUNT AMOUNT"
.W ?57,$J($FN(ACRQDT,"P",2),10)
.W !?40,"ADJUSTED TOTAL"
.W ?57,$J($FN(ACRSSTOT-ACRQDT,"P",2),10)
.K ACRQUIT,ACRQD,ACRQDP,ACRQDT
Q
EXCEED ;EP;PRINT EXCEED ESTIMATE MESSAGE
N ACRPER,ACRMAX
S ACRPER=$P(^ACRSYS(1,"DT"),U,19)
S ACRMAX=$P(^ACRSYS(1,"DT"),U,20)
W !?3,"|"
D W^ACRFSSD
W !?3,"|The purchasing department is hereby authorized to exceed the"
D W^ACRFSSD
W !?3,"|estimate shown hereon by"
W:ACRPER " ",ACRPER," percent "
I ACRPER,ACRMAX W "but "
I ACRMAX D
.W "not more than $",$FN(ACRMAX,"P",2)
.D W^ACRFSSD
.W !?3,"|"
W "without additional funding."
D W^ACRFSSD
Q
ASC ;EP;ADD ASC SURCHARGE
Q
Q:$P(^ACRDOC(ACRDOCDA,0),U,4)=35!($P(^(0),U,12))
Q:$D(ACRREV)
N X,Y,Z,ACRSURC,ACRQUIT
Q:'$P($G(^ACRSYS(+$G(ACRADA),"DT1")),U,7) S ACRSURC=$P(^("DT1"),U,7)
S (X,Z)=0
F S X=$O(^ACRSS("C",ACRDOCDA,X)) Q:'X D
.S Y=$G(^ACRSS(X,"DESC"))
.S Z=Z+$P(^ACRSS(X,"DT"),U,4)
.I +^ACRSS(X,0)=999!(Y["ASC SURCHARGE") S ACRQUIT=X_U_$P(^ACRSS(X,"DT"),U,4)
I $G(ACRQUIT) D Q
.S DA=+ACRQUIT
.S DIE="^ACRSS("
.S DR=(Z-$G(ACRQD)-$P(ACRQUIT,U,2))*(ACRSURC/100)
.S DR="12////"_DR
.D DIE^ACRFDIC
S X=999
S DIC="^ACRSS("
S DIC(0)="L"
S DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRDOCDA_";.04///"_ACROBJ_";.05////"_ACRCANDA_";.06////"_ACRLBDA_";.07////"_ACRDOCDA_";.2////"_ACRDOCDA_";5////SURCHARGE;10////1;11///EACH"
S DIC("DR")=DIC("DR")_";12////"_(Z-$G(ACRQD)-$P($G(ACRQUIT),U,2))*(ACRSURC/100)_";100////ASC SURCHARGE"
D FILE^ACRFDIC
K ACRSURC
Q
ACRFSS12 ;IHS/OIRM/DSD/THL,AEF - DISPALY AND EDIT SERVICES/SUPPLIES PROCURED; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;CONTINUAITON OF ACRFSS1,25T
DISPLAY ;EP;TO DISPLAY SUPPLIES/SERVICES FOR A REQUEST
+1 IF $DATA(ACROUT)
QUIT
+2 IF '$DATA(ACRORIGF)
DO PHEAD
+3 SET ACRDOCVN=$PIECE(ACRDOCPO,U,5)
+4 IF $DATA(ACRPRT)!$DATA(ACRREV)
IF ACRREFX'=103
IF ACRREFX'=349
IF ACRREFX'=326
IF $GET(ACRAPVT)'=31!($GET(ACRAPVT)=6)
Begin DoDot:1
+5 SET D0=ACRDOCDA
+6 DO ^ACRFJS
End DoDot:1
+7 IF '$DATA(ACRORIGF)
DO PHEAD
+8 IF '$DATA(ACRORIGF)
DO HEAD^ACRFSSD1
+9 KILL ACRSS
+10 SET ACRXREF=$SELECT(ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",'$DATA(ACRPO)&'$DATA(ACRPPO):"C",1:"J")
+11 SET (ACRSSDA,ACRSSTOT,ACRSJ)=0
+12 FOR
SET ACRSSDA=$ORDER(^ACRSS(ACRXREF,ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
Begin DoDot:1
+13 SET ACRSSTOT=ACRSSTOT+$PIECE($GET(^ACRSS(ACRSSDA,"DT")),U,4)
+14 SET ACRSJ=ACRSJ+1
+15 NEW X
+16 SET X=^ACRSS(ACRSSDA,0)
+17 SET ACRSSX(+$PIECE(X,U,2),ACRSJ)=ACRSSDA_U_^ACRSS(ACRSSDA,0)
+18 IF '$DATA(ACRSCHK)
IF '$DATA(ACRREV)
IF '$DATA(ACRPRT)
IF $DATA(^ACRAPVS("AB",ACRDOCDA))
DO SCHK
+19 IF $DATA(ACRSCHK)
DO SCHK1
End DoDot:1
+20 NEW X,Y,I,J
+21 SET (X,I,J)=0
+22 FOR
SET X=$ORDER(ACRSSX(X))
IF 'X
QUIT
Begin DoDot:1
+23 SET Y=0
+24 FOR
SET Y=$ORDER(ACRSSX(X,Y))
IF 'Y
QUIT
Begin DoDot:2
+25 SET J=J+1
+26 IF X'=ACRDOCDA
SET ACRFROMX=1
+27 IF J'=+^ACRSS(+ACRSSX(X,Y),0)
Begin DoDot:3
+28 SET DA=+ACRSSX(X,Y)
+29 SET DIE="^ACRSS("
+30 SET DR=".01///^S X=J"
+31 SET $PIECE(ACRSSX(X,Y),U,2)=J
+32 NEW X,Y
+33 DO DIE^ACRFDIC
End DoDot:3
+34 SET ACRSS(+$PIECE(ACRSSX(X,Y),U,2))=ACRSSX(X,Y)
End DoDot:2
End DoDot:1
+35 KILL ACRQUIT,ACRSSX
+36 NEW ACRX
+37 SET (ACRX,ACRSSDA,ACRJ)=0
+38 FOR
SET ACRX=$ORDER(ACRSS(ACRX))
IF 'ACRX!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
Begin DoDot:1
+39 IF $GET(ACRFROMX)
Begin DoDot:2
+40 IF $PIECE(ACRSS(ACRX),U,3)=$GET(ACRFROMX)
QUIT
+41 SET ACRFROMX=$PIECE(ACRSS(ACRX),U,3)
+42 WRITE !?3,$SELECT('$DATA(ACRORIGF):"|",1:" ")
+43 DO W^ACRFSSD
+44 WRITE !?3,$SELECT('$DATA(ACRORIGF):"|",1:" "),"(From Request NO: ",$PIECE(^ACRDOC(ACRFROMX,0),U),")"
+45 DO W^ACRFSSD
+46 WRITE !?3,$SELECT('$DATA(ACRORIGF):"|",1:" ")
+47 DO W^ACRFSSD
End DoDot:2
+48 SET ACRSSDA=+ACRSS(ACRX)
+49 DO ^ACRFSSD
End DoDot:1
+50 DO ASC
+51 KILL ACRQUIT,ACRFROMX
+52 IF ACRJ=0
Begin DoDot:1
+53 WRITE !?5,"NO ITEMS ON FILE FOR THIS PROCUREMENT"
+54 IF $DATA(^ACRSS("C",ACRDOCDA))
IF '$DATA(^ACRSS("J",ACRDOCDA))
Begin DoDot:2
+55 SET ACRSSDA=$ORDER(^ACRSS("C",ACRDOCDA,0))
+56 IF ACRSSDA
IF +$GET(^ACRSS(ACRSSDA,"PO"))
Begin DoDot:3
+57 WRITE !?5,"ITEMS TRANSFERRED TO PO: "
+58 WRITE $PIECE(^ACRDOC(+^ACRSS(ACRSSDA,"PO"),0),U,2)," (",$PIECE(^ACRDOC(+^ACRSS(ACRSSDA,"PO"),0),U),")"
End DoDot:3
End DoDot:2
End DoDot:1
+59 IF ACRJ>0
Begin DoDot:1
+60 IF ACRREFX=116
IF '$PIECE(^ACRDOC(ACRDOCDA,0),U,19)
IF $LENGTH($PIECE(^ACRSYS(1,"DT"),U,19,20))>3
DO EXCEED
+61 IF ACRSSTOT'["."
SET ACRSSTOT=ACRSSTOT_".00"
+62 IF $EXTRACT(DT,4,5)<10
IF ($EXTRACT(DT,1,3)+1700)<$PIECE($GET(^ACRLOCB(+$PIECE(ACRDOC0,U,6),"DT")),U)
Begin DoDot:2
+63 SET ACRAPVTX="SUBJECT TO AVAILABILITY OF FUNDS"
End DoDot:2
IF 1
+64 IF '$TEST
IF $EXTRACT($PIECE(ACRDOC0,U,3),5,7)>600
IF '$DATA(ACRPRT)
IF '$DATA(ACRINV)
IF $EXTRACT(IOST,1,2)="P-"
Begin DoDot:2
+65 WRITE !,"THIS IS TO CERTIFY THAT THIS OBLIGATION IS WITHIN THE 30% FOURTH QUARTER"
+66 WRITE !,"SPENDING LIMITATION AND THE 12% LIMITATION FOR THE MONTH."
End DoDot:2
+67 IF '$DATA(ACRORIGF)
Begin DoDot:2
+68 WRITE $$DASH^ACRFMENU
+69 WRITE !?47,"TOTAL |"
+70 IF '$DATA(ACRPQT)
WRITE ?57,$JUSTIFY($FNUMBER(ACRSSTOT-$GET(ACRQD),"P",2),10)
+71 WRITE ?67,"|"
End DoDot:2
+72 SET ACGRDA=$PIECE(ACRDOC0,U,16)
+73 IF ACGRDA
IF $DATA(^ACGS(ACGRDA,0))
IF $DATA(^("DT1"))
IF (ACRSSTOT-$GET(ACRQD))'=$PIECE(^("DT1"),U,5)
Begin DoDot:2
+74 SET DR="26////"_(ACRSSTOT-$GET(ACRQD))
+75 SET DIE="^ACGS("
+76 SET DA=ACGRDA
+77 DO DIE^ACRFDIC
+78 KILL ACGRDA
End DoDot:2
End DoDot:1
+79 DO QUAN
+80 IF $EXTRACT(IOST,1,2)="C-"
IF ($DATA(ACRPRT)!$DATA(ACRREV))
IF $GET(ACRAPVT)'=31&($GET(ACRAPVT)'=6)
Begin DoDot:1
+81 DO PAUSE^ACRFWARN
+82 WRITE @IOF
End DoDot:1
+83 QUIT
SCHK KILL ACRSCHK
+1 NEW X
+2 SET X=0
+3 FOR
SET X=$ORDER(^ACRAPVS("AB",ACRDOCDA,X))
IF 'X!$DATA(ACRSCHK)
QUIT
IF $DATA(^ACRAPVS(X,0))
IF $EXTRACT($GET(^ACRAPVS(X,"DT")))="A"
IF $PIECE(^ACRDOC(ACRDOCDA,0),U,13)=$PIECE(^ACRAPVS(X,0),U,6)
SET ACRSCHK=""
+4 QUIT
SCHK1 KILL ^TMP("ACRSS",$JOB,ACRSSDA)
+1 SET %X="^ACRSS("_ACRSSDA_","
+2 SET %Y="^TMP(""ACRSS"","_$JOB_","_ACRSSDA_","
+3 DO %XY^%RCR
+4 QUIT
PHEAD ;EP;TO PRINT HEADER ON ADDITIONAL DOCUMENT PAGES
+1 IF $DATA(ACROUT)
QUIT
+2 IF '$DATA(ACRPHEAD)
SET ACRPHEAD=$SELECT('$DATA(ACRPQT):13,$GET(ACRDC)=1:16,1:5)
+3 IF $EXTRACT(IOST,1,2)="P-"
IF IOSL-ACRPHEAD<$Y
Begin DoDot:1
+4 IF $GET(ACRZIS(2))]""
SET IOP=ACRZIS(2)
DO ^%ZIS
IF POP>0
GOTO PHEAD
USE IO
+5 NEW DXS,DIP,DC,DN
+6 SET D0=ACRDOCDA
+7 SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+8 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+9 IF '$DATA(ACRREFX)
SET ACRREFX=ACRREF
+10 WRITE @IOF
+11 IF $DATA(ACRPQT)
DO ^ACRPQH
IF 1
+12 IF '$DATA(ACRPQT)
Begin DoDot:2
+13 IF ACRREFX=116!(ACRREFX=101)
DO ^ACRPRQH
+14 IF ACRREFX=130
DO ^ACRPTOH
+15 IF ACRREFX=103
DO ^ACRPSH
+16 IF ACRREFX=349!(ACRREFX=326)
IF $DATA(ACRORIGF)
IF +$GET(ACRPSC)
Begin DoDot:3
+17 NEW X
+18 SET X="HEAD^ACRF"_+ACRPSC_2
+19 DO @X
End DoDot:3
End DoDot:2
End DoDot:1
+20 KILL ACRPHEAD
+21 QUIT
QUAN ;EP;TO PRINT QUANTITY DISCOUNT
+1 IF $PIECE(ACRDOCPO,U,19)
IF $PIECE(ACRDOCPO,U,20)]""
Begin DoDot:1
+2 SET ACRQDP=$PIECE(ACRDOCPO,U,19)
+3 SET ACRQD=$PIECE(ACRDOCPO,U,20)
+4 SET ACRQDT=$SELECT(ACRSSTOT<ACRQDP:0,1:ACRQDP/100*ACRSSTOT)
+5 IF ACRQDT'=$PIECE($GET(^ACRDOC(ACRDOCDA,13)),U,8)
Begin DoDot:2
+6 SET DA=ACRDOCDA
+7 SET DIE="^ACRDOC("
+8 SET DR="103921////"_ACRQDT
+9 DO DIE^ACRFDIC
End DoDot:2
+10 WRITE !,"QUANTITY DISCOUNT: ",$PIECE(ACRQDP,U),"% if TOTAL > ",$FNUMBER(ACRQD,"P",2)
+11 WRITE !?39,"DISCOUNT AMOUNT"
+12 WRITE ?57,$JUSTIFY($FNUMBER(ACRQDT,"P",2),10)
+13 WRITE !?40,"ADJUSTED TOTAL"
+14 WRITE ?57,$JUSTIFY($FNUMBER(ACRSSTOT-ACRQDT,"P",2),10)
+15 KILL ACRQUIT,ACRQD,ACRQDP,ACRQDT
End DoDot:1
+16 QUIT
EXCEED ;EP;PRINT EXCEED ESTIMATE MESSAGE
+1 NEW ACRPER,ACRMAX
+2 SET ACRPER=$PIECE(^ACRSYS(1,"DT"),U,19)
+3 SET ACRMAX=$PIECE(^ACRSYS(1,"DT"),U,20)
+4 WRITE !?3,"|"
+5 DO W^ACRFSSD
+6 WRITE !?3,"|The purchasing department is hereby authorized to exceed the"
+7 DO W^ACRFSSD
+8 WRITE !?3,"|estimate shown hereon by"
+9 IF ACRPER
WRITE " ",ACRPER," percent "
+10 IF ACRPER
IF ACRMAX
WRITE "but "
+11 IF ACRMAX
Begin DoDot:1
+12 WRITE "not more than $",$FNUMBER(ACRMAX,"P",2)
+13 DO W^ACRFSSD
+14 WRITE !?3,"|"
End DoDot:1
+15 WRITE "without additional funding."
+16 DO W^ACRFSSD
+17 QUIT
ASC ;EP;ADD ASC SURCHARGE
+1 QUIT
+2 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35!($PIECE(^(0),U,12))
QUIT
+3 IF $DATA(ACRREV)
QUIT
+4 NEW X,Y,Z,ACRSURC,ACRQUIT
+5 IF '$PIECE($GET(^ACRSYS(+$GET(ACRADA),"DT1")),U,7)
QUIT
SET ACRSURC=$PIECE(^("DT1"),U,7)
+6 SET (X,Z)=0
+7 FOR
SET X=$ORDER(^ACRSS("C",ACRDOCDA,X))
IF 'X
QUIT
Begin DoDot:1
+8 SET Y=$GET(^ACRSS(X,"DESC"))
+9 SET Z=Z+$PIECE(^ACRSS(X,"DT"),U,4)
+10 IF +^ACRSS(X,0)=999!(Y["ASC SURCHARGE")
SET ACRQUIT=X_U_$PIECE(^ACRSS(X,"DT"),U,4)
End DoDot:1
+11 IF $GET(ACRQUIT)
Begin DoDot:1
+12 SET DA=+ACRQUIT
+13 SET DIE="^ACRSS("
+14 SET DR=(Z-$GET(ACRQD)-$PIECE(ACRQUIT,U,2))*(ACRSURC/100)
+15 SET DR="12////"_DR
+16 DO DIE^ACRFDIC
End DoDot:1
QUIT
+17 SET X=999
+18 SET DIC="^ACRSS("
+19 SET DIC(0)="L"
+20 SET DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRDOCDA_";.04///"_ACROBJ_";.05////"_ACRCANDA_";.06////"_ACRLBDA_";.07////"_ACRDOCDA_";.2////"_ACRDOCDA_";5////SURCHARGE;10////1;11///EACH"
+21 SET DIC("DR")=DIC("DR")_";12////"_(Z-$GET(ACRQD)-$PIECE($GET(ACRQUIT),U,2))*(ACRSURC/100)_";100////ASC SURCHARGE"
+22 DO FILE^ACRFDIC
+23 KILL ACRSURC
+24 QUIT
