- 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
