ACRFEA2 ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA; [ 09/23/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
;;CONTINUATION OF ACRFEA
EDIE ;EP;TO EDIT DOCUMENT
I '$D(ACRNEW)&'$D(ACRNEWOB) D Q:$D(ACRQUIT)!$D(ACROUT)
.S:'$D(DIR("A")) DIR("A")=" Edit this data? "
.D OUT
I $G(ACRY)=1 D EDIE1
Q
EDIE1 ;EP;
S DA=ACRZDA
S DIE=ACRDIE
S DR=ACRDR
S DIE("NO^")="NO"
I ACRENTRY["OBLAMT" D
.K DIE("NO^")
.S ACRCAN=$P(^ACROBL(ACRDOCDA,0),U,4)
.S DA=ACRDOCDA
.S DIE="^ACROBL("
.S DR=$P(ACRENTRY,";;",5)
.S:ACRREF=130!(ACRREF=600) DR="[ACR TRAVEL INFO]"
W !
D DDS^ACRFDIC
G:'$D(ACRSCREN) EDIEOUT
K ACRSCREN
D DIE^ACRFDIC
EDIEOUT S:ACRENTRY["OBLAMT" ACRCAN=$P(^AUTTCAN(ACRCAN,0),U)
Q
OUT ;EP;FOR FAST OUT CHOICE
S DIR(0)="SOA^1:YES;2:NO;3:OUT"
S:'$D(DIR("B")) DIR("B")="NO"
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)
S ACRY=+Y
I ACRY=3 S (ACRQUIT,ACROUT)=""
I ACRY=2 S ACRQUIT=""
Q
DIC1 ;EP;
K ACRNEW
D ADD
Q:$D(ACRQUIT)
S DIC=ACRDIC
S DIC(0)=ACRDIC(0)
S DIC("A")=ACRDIC("A")
S D=ACRD
W !
I $D(ACRNEW),$G(ACRZDA) S Y=ACRZDA,$P(ACRYY,U,3)=1,X=ACRZDA,Y(0,0)=@(ACRDIC_ACRZDA_",0)")
E D
.I ACRDIC["ACRLOCB",ACRDIC(0)["L" W !,"(NON-Personnel Amount ONLY)"
.D DIC^ACRFDIC
.S ACRYY=Y
.Q:+Y<1
.Q:$P(Y,U,3)'=1
.S DA=+Y
.N Y
.S DIE=ACRDIC
.S DR=".8////O"
.D DIE^ACRFDIC
I U[$E(X)!(X="")!(+Y<1) S ACRQUIT="" Q
I $P($G(ACRYY),U,3)=1,ACRENTRY'["APPAMT",$G(ACRORIG)'="D",(ACRFTOT+Y(0,0))>ACRFDNAM D Q
.S DA=+Y
.S DIK=ACRDIC
.S:DIK'["(" DIK=DIK_"("
.D EXCTOT^ACRFWARN
.S ACRQUIT=""
S:$P(ACRYY,U,3)=1 ACRNEW=""
S ACRZDA=+Y
S ACRZY=Y
I $P(ACRYY,U,3)=1 D
.S ACRNEW=""
.Q:ACRDIC["OBL"
.S (DA(1),DA)=+Y
.S DIC=ACRDIC_DA_",""SC"","
.S DIC(0)="L"
.S:'$D(@(DIC_"0)")) @(DIC_"0)")="^"_$S(ACRDIC["ACRAPP":9002185.01,ACRDIC["ACRALW":9002186.01,ACRDIC["ACRALC":9002187.04,1:9002188.04)_"P"
.D NOW^%DTC
.S DIC("DR")=".17////"_%_";.18////"_DUZ
.S X=DUZ
.D FILE^ACRFDIC
Q
ACRDIE ;EP;
S (ACRDOCDA,DA)=+ACROBLDT
S ACRLBDA=$P(ACROBL0,U,3)
S ACRDOC=$S($P(ACRDOC0,U,2)]""&'$D(ACRREQST):$P(ACRDOC0,U,2),1:$P(ACRDOC0,U))
S ACRREFDA=$P(ACRDOC0,U,13)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
I "^103^349^326^210^"[(U_ACRREF_U)&($D(ACRREQST)!$D(ACRCOMP)) D I 1
.S ACRREFX=116
.S ACRREFDA=$O(^AUTTDOCR("B",116,0))
E I ACRREF=600&($D(ACRREQST)!$D(ACRCOMP)) D I 1
.S ACRREFX=130
.S ACRREFDA=$O(^AUTTDOCR("B",130,0))
E S ACRREFX=$S(ACRREF=210:103,1:ACRREF)
S ACRDATA=$T(@ACRREFX^ACRFCTL1)
S ACRRTN2="^"_$P(ACRDATA,";;",3)
S ACRDIE="^ACRDOC("
S ACRDR="[ACR "_$P(ACRDATA,";;",2)_"]"
D ^ACRFCHK:ACRREF'=103&(ACRREF'=349)&(ACRREF'=326)&(ACRREF'=210)&'$D(ACRREV)
I ACRREFX=349!(ACRREFX=326) D
.N X
.S X=$P(^ACRDOC(ACRDOCDA,0),U,24)
.I X=1 S ACRDR="[ACR CONTRACT ACTION-26]"
.I X=2 S ACRDR="[ACR CONTRACT ACTION-33]"
.I X=3 S ACRDR="[ACR CONTRACT ACTION-1449]"
.I X=4 S ACRDR="[ACR CONTRACT ACTION-TRIBAL]"
S DA=ACRDOCDA
S DIE=ACRDIE
S DR=ACRDR
I $D(ACRREV) S ACRSCREN=""
E D DDS^ACRFDIC
I '$D(ACRSCREN) S ACRQUIT="" Q
K ACRSCREN
D DISP
I $D(ACRREV) D PAUSE^ACRFWARN Q
K ACRQUIT
D ^ACRFEA3
D ^ACRFCHK:'$D(ACRQUIT)
Q
DRAFT ;EP;UTILITY TO FLAG DOCUMENT FOR DRAFT CHECK PAYMENT
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".12 Draft Payment"
D DIE^ACRFDIC
Q
APPROVE1 ;EP;
W !
D WAIT^DICD:$E($G(IOST),1,2)="C-"
D ^ACRFAPVS
Q
TRANS ;EP;FOR ELECTRONIC TRANSMISSION OF FUNDS DISTRIBUTION
W !
S DIR(0)="YO"
S DIR("A")="Transmit this "_ACRY_" now"
S DIR("B")="NO"
D DIR^ACRFDIC
Q:ACRY'=1
D ^%ZIS
Q:$D(DUOUT)!$D(DTOUT)!(POP'=0)
D ^ACRFCAA,^%ZISC
Q
DISP W @IOF
S ACRTXDA=$P(^ACRDOC(ACRDOCDA,0),U,4)
;S ACREB=$P(^VA(200,$P(^ACROBL(ACRDOCDA,0),U,5),0),U) ;ACR*2.1*19.02 IM16848
S ACREB=$$NAME2^ACRFUTL1($P(^ACROBL(ACRDOCDA,0),U,5)) ;ACR*2.1*19.02 IM16848
W !,"DOCUMENT NO: ",@ACRON,ACRDOC,@ACROF," ",$P(^ACRTXTYP(ACRTXDA,0),U)
W !,"PREPARED BY: ",$P($P(ACREB,",",2)," ")," ",$P(ACREB,",")
K ACREB
I $D(ACRPRCS),$D(ACRAPDA) D
.;W ?$X+1,"REVIEW FOR: ",$P(^VA(200,$P(^ACRAPVS(ACRAPDA,0),U,3),0),U) ;ACR*2.1*19.02 IM16848
.W ?$X+1,"REVIEW FOR: ",$$NAME2^ACRFUTL1($P(^ACRAPVS(ACRAPDA,0),U,3)) ;ACR*2.1*19.02 IM16848
N ACRI
W $$DASH^ACRFMENU
N DXS,DIP,DC,DN,D0
S D0=ACRDOCDA
D @ACRRTN2
I $D(ACRDOCDT),$P(ACRDOCDT,U,5)]"" D
.W !,"JUSTIFY PRIORITY:"
.N ACR
.F ACR=5:1:9 I $P(ACRDOCDT,U,ACR)]"" D
..W:ACR'=5 !
..W ?19,$P(ACRDOCDT,U,ACR)
W $$DASH^ACRFMENU
Q
ADD ;ADD OR EDIT ACCOUNT
S DIR(0)="SO^1:ADD New Account;2:INCREASE Existing Account;3:DECREASE Existing Account;4:EDIT Existing Account"
S DIR("A")="Which one"
D DIR^ACRFDIC
Q:$D(ACRQUIT)
I "1234"'[+Y S ACRQUIT="" Q
I Y=1 D Q
.K ACRQUIT,ACRNEW
.S ACRDIC(0)="AELQZ"
.S ACRDIC("A")="New ACCOUNT DOLLAR AMOUNT: "
I Y=2!(Y=3) D Q
.D ORIG
I Y=4 D Q
.S ACRDIC(0)=$TR(ACRDIC(0),"L","")
Q
ORIG ;ID INCREASES AND DECREASES
K ACRORIG
N ACRXX,ACRAMT,ACR0,ACRDT
S ACRORIG=$S(Y=2:"I",Y=3:"D",1:"")
I ACRORIG="" S ACRQUIT="" Q
D AMT
Q:$D(ACRQUIT)
S DIC=ACRDIC
S DIC(0)="AENQZ"
S DIC("A")="ID NO. of Account to be Increased or Decreased: "
S DIC("S")="I $P(^(0),U,8)=""O"""
W !
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
S ACRXX=+Y
S X=ACRAMT
S DIC=ACRDIC
S DIC(0)="L"
S ACR0=@(ACRDIC_ACRXX_",0)"),ACRDT=@(ACRDIC_ACRXX_","_"""DT"""_")")
S DIC("DR")=".02////"_$P(ACR0,U,2)_";.03////"_$P(ACR0,U,3)_";.04////"_$P(ACR0,U,4)_";.05////"_$P(ACR0,U,5)_";.16////N;.17////"_DT_";.18////"_DUZ_";.2////"_$P(ACR0,U,12)_";.21////"_$P(ACR0,U,21)_";.3////"_$P(ACR0,U,13)
S DIC("DR")=DIC("DR")_";.8////"_ACRORIG_";.9////"_ACRXX
D FILE^ACRFDIC
S (ACRZDA,DA)=+Y
S ACRYY=Y
S DIE=ACRDIC
S DR="10////"_$P(ACRDT,U)_";20////"_$P(ACRDT,U,2)_";30////"_$P(ACRDT,U,3)_";40////"_$P(ACRDT,U,4)_";50////"_$P(ACRDT,U,5)_";60////"_$P(ACRDT,U,6)_";70////"_$P(ACRDT,U,7)_";80////"_$P(ACRDT,U,8)_";90////"_$P(ACRDT,U,9)
S DR=DR_";110////"_$P(ACRDT,U,11)_";130////"_$P(ACRDT,U,13)_";150////"_$P(ACRDT,U,15)
D DIE^ACRFDIC
S (ACRQUIT,ACRNEW)=""
S X=DUZ
S DA(1)=ACRZDA
S DIC=ACRDIC_ACRZDA_",""SC"","
S DIC(0)="L"
S:'$D(@(ACRDIC_ACRZDA_",""SC"",0)")) $P(^(0),U,2)=$S(ACRDIC["ACRAPP":9002185.01,ACRDIC["ACRALW":9002186.01,ACRDIC["ACRALC":9002187.04,1:9002188.04)_"P"
D FILE^ACRFDIC
Q
AMT ;ENTER ACCOUNT AMOUNT
S DIR(0)="NOA^0:9999999"
I $G(ACRDIC)["ACRLOCB",$G(ACRDIC(0))["L" S DIR("A",1)="(NON-Personnel Amount ONLY)"
S DIR("A")="Amount of Increase/Decrease: "
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)
S ACRAMT=Y
Q
ACRFEA2 ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA; [ 09/23/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFEA
EDIE ;EP;TO EDIT DOCUMENT
+1 IF '$DATA(ACRNEW)&'$DATA(ACRNEWOB)
Begin DoDot:1
+2 IF '$DATA(DIR("A"))
SET DIR("A")=" Edit this data? "
+3 DO OUT
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+4 IF $GET(ACRY)=1
DO EDIE1
+5 QUIT
EDIE1 ;EP;
+1 SET DA=ACRZDA
+2 SET DIE=ACRDIE
+3 SET DR=ACRDR
+4 SET DIE("NO^")="NO"
+5 IF ACRENTRY["OBLAMT"
Begin DoDot:1
+6 KILL DIE("NO^")
+7 SET ACRCAN=$PIECE(^ACROBL(ACRDOCDA,0),U,4)
+8 SET DA=ACRDOCDA
+9 SET DIE="^ACROBL("
+10 SET DR=$PIECE(ACRENTRY,";;",5)
+11 IF ACRREF=130!(ACRREF=600)
SET DR="[ACR TRAVEL INFO]"
End DoDot:1
+12 WRITE !
+13 DO DDS^ACRFDIC
+14 IF '$DATA(ACRSCREN)
GOTO EDIEOUT
+15 KILL ACRSCREN
+16 DO DIE^ACRFDIC
EDIEOUT IF ACRENTRY["OBLAMT"
SET ACRCAN=$PIECE(^AUTTCAN(ACRCAN,0),U)
+1 QUIT
OUT ;EP;FOR FAST OUT CHOICE
+1 SET DIR(0)="SOA^1:YES;2:NO;3:OUT"
+2 IF '$DATA(DIR("B"))
SET DIR("B")="NO"
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+5 SET ACRY=+Y
+6 IF ACRY=3
SET (ACRQUIT,ACROUT)=""
+7 IF ACRY=2
SET ACRQUIT=""
+8 QUIT
DIC1 ;EP;
+1 KILL ACRNEW
+2 DO ADD
+3 IF $DATA(ACRQUIT)
QUIT
+4 SET DIC=ACRDIC
+5 SET DIC(0)=ACRDIC(0)
+6 SET DIC("A")=ACRDIC("A")
+7 SET D=ACRD
+8 WRITE !
+9 IF $DATA(ACRNEW)
IF $GET(ACRZDA)
SET Y=ACRZDA
SET $PIECE(ACRYY,U,3)=1
SET X=ACRZDA
SET Y(0,0)=@(ACRDIC_ACRZDA_",0)")
+10 IF '$TEST
Begin DoDot:1
+11 IF ACRDIC["ACRLOCB"
IF ACRDIC(0)["L"
WRITE !,"(NON-Personnel Amount ONLY)"
+12 DO DIC^ACRFDIC
+13 SET ACRYY=Y
+14 IF +Y<1
QUIT
+15 IF $PIECE(Y,U,3)'=1
QUIT
+16 SET DA=+Y
+17 NEW Y
+18 SET DIE=ACRDIC
+19 SET DR=".8////O"
+20 DO DIE^ACRFDIC
End DoDot:1
+21 IF U[$EXTRACT(X)!(X="")!(+Y<1)
SET ACRQUIT=""
QUIT
+22 IF $PIECE($GET(ACRYY),U,3)=1
IF ACRENTRY'["APPAMT"
IF $GET(ACRORIG)'="D"
IF (ACRFTOT+Y(0,0))>ACRFDNAM
Begin DoDot:1
+23 SET DA=+Y
+24 SET DIK=ACRDIC
+25 IF DIK'["("
SET DIK=DIK_"("
+26 DO EXCTOT^ACRFWARN
+27 SET ACRQUIT=""
End DoDot:1
QUIT
+28 IF $PIECE(ACRYY,U,3)=1
SET ACRNEW=""
+29 SET ACRZDA=+Y
+30 SET ACRZY=Y
+31 IF $PIECE(ACRYY,U,3)=1
Begin DoDot:1
+32 SET ACRNEW=""
+33 IF ACRDIC["OBL"
QUIT
+34 SET (DA(1),DA)=+Y
+35 SET DIC=ACRDIC_DA_",""SC"","
+36 SET DIC(0)="L"
+37 IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^"_$SELECT(ACRDIC["ACRAPP":9002185.01,ACRDIC["ACRALW":9002186.01,ACRDIC["ACRALC":9002187.04,1:9002188.04)_"P"
+38 DO NOW^%DTC
+39 SET DIC("DR")=".17////"_%_";.18////"_DUZ
+40 SET X=DUZ
+41 DO FILE^ACRFDIC
End DoDot:1
+42 QUIT
ACRDIE ;EP;
+1 SET (ACRDOCDA,DA)=+ACROBLDT
+2 SET ACRLBDA=$PIECE(ACROBL0,U,3)
+3 SET ACRDOC=$SELECT($PIECE(ACRDOC0,U,2)]""&'$DATA(ACRREQST):$PIECE(ACRDOC0,U,2),1:$PIECE(ACRDOC0,U))
+4 SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+5 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+6 IF "^103^349^326^210^"[(U_ACRREF_U)&($DATA(ACRREQST)!$DATA(ACRCOMP))
Begin DoDot:1
+7 SET ACRREFX=116
+8 SET ACRREFDA=$ORDER(^AUTTDOCR("B",116,0))
End DoDot:1
IF 1
+9 IF '$TEST
IF ACRREF=600&($DATA(ACRREQST)!$DATA(ACRCOMP))
Begin DoDot:1
+10 SET ACRREFX=130
+11 SET ACRREFDA=$ORDER(^AUTTDOCR("B",130,0))
End DoDot:1
IF 1
+12 IF '$TEST
SET ACRREFX=$SELECT(ACRREF=210:103,1:ACRREF)
+13 SET ACRDATA=$TEXT(@ACRREFX^ACRFCTL1)
+14 SET ACRRTN2="^"_$PIECE(ACRDATA,";;",3)
+15 SET ACRDIE="^ACRDOC("
+16 SET ACRDR="[ACR "_$PIECE(ACRDATA,";;",2)_"]"
+17 IF ACRREF'=103&(ACRREF'=349)&(ACRREF'=326)&(ACRREF'=210)&'$DATA(ACRREV)
DO ^ACRFCHK
+18 IF ACRREFX=349!(ACRREFX=326)
Begin DoDot:1
+19 NEW X
+20 SET X=$PIECE(^ACRDOC(ACRDOCDA,0),U,24)
+21 IF X=1
SET ACRDR="[ACR CONTRACT ACTION-26]"
+22 IF X=2
SET ACRDR="[ACR CONTRACT ACTION-33]"
+23 IF X=3
SET ACRDR="[ACR CONTRACT ACTION-1449]"
+24 IF X=4
SET ACRDR="[ACR CONTRACT ACTION-TRIBAL]"
End DoDot:1
+25 SET DA=ACRDOCDA
+26 SET DIE=ACRDIE
+27 SET DR=ACRDR
+28 IF $DATA(ACRREV)
SET ACRSCREN=""
+29 IF '$TEST
DO DDS^ACRFDIC
+30 IF '$DATA(ACRSCREN)
SET ACRQUIT=""
QUIT
+31 KILL ACRSCREN
+32 DO DISP
+33 IF $DATA(ACRREV)
DO PAUSE^ACRFWARN
QUIT
+34 KILL ACRQUIT
+35 DO ^ACRFEA3
+36 IF '$DATA(ACRQUIT)
DO ^ACRFCHK
+37 QUIT
DRAFT ;EP;UTILITY TO FLAG DOCUMENT FOR DRAFT CHECK PAYMENT
+1 SET DA=ACRDOCDA
+2 SET DIE="^ACRDOC("
+3 SET DR=".12 Draft Payment"
+4 DO DIE^ACRFDIC
+5 QUIT
APPROVE1 ;EP;
+1 WRITE !
+2 IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
+3 DO ^ACRFAPVS
+4 QUIT
TRANS ;EP;FOR ELECTRONIC TRANSMISSION OF FUNDS DISTRIBUTION
+1 WRITE !
+2 SET DIR(0)="YO"
+3 SET DIR("A")="Transmit this "_ACRY_" now"
+4 SET DIR("B")="NO"
+5 DO DIR^ACRFDIC
+6 IF ACRY'=1
QUIT
+7 DO ^%ZIS
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!(POP'=0)
QUIT
+9 DO ^ACRFCAA
DO ^%ZISC
+10 QUIT
DISP WRITE @IOF
+1 SET ACRTXDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,4)
+2 ;S ACREB=$P(^VA(200,$P(^ACROBL(ACRDOCDA,0),U,5),0),U) ;ACR*2.1*19.02 IM16848
+3 ;ACR*2.1*19.02 IM16848
SET ACREB=$$NAME2^ACRFUTL1($PIECE(^ACROBL(ACRDOCDA,0),U,5))
+4 WRITE !,"DOCUMENT NO: ",@ACRON,ACRDOC,@ACROF," ",$PIECE(^ACRTXTYP(ACRTXDA,0),U)
+5 WRITE !,"PREPARED BY: ",$PIECE($PIECE(ACREB,",",2)," ")," ",$PIECE(ACREB,",")
+6 KILL ACREB
+7 IF $DATA(ACRPRCS)
IF $DATA(ACRAPDA)
Begin DoDot:1
+8 ;W ?$X+1,"REVIEW FOR: ",$P(^VA(200,$P(^ACRAPVS(ACRAPDA,0),U,3),0),U) ;ACR*2.1*19.02 IM16848
+9 ;ACR*2.1*19.02 IM16848
WRITE ?$X+1,"REVIEW FOR: ",$$NAME2^ACRFUTL1($PIECE(^ACRAPVS(ACRAPDA,0),U,3))
End DoDot:1
+10 NEW ACRI
+11 WRITE $$DASH^ACRFMENU
+12 NEW DXS,DIP,DC,DN,D0
+13 SET D0=ACRDOCDA
+14 DO @ACRRTN2
+15 IF $DATA(ACRDOCDT)
IF $PIECE(ACRDOCDT,U,5)]""
Begin DoDot:1
+16 WRITE !,"JUSTIFY PRIORITY:"
+17 NEW ACR
+18 FOR ACR=5:1:9
IF $PIECE(ACRDOCDT,U,ACR)]""
Begin DoDot:2
+19 IF ACR'=5
WRITE !
+20 WRITE ?19,$PIECE(ACRDOCDT,U,ACR)
End DoDot:2
End DoDot:1
+21 WRITE $$DASH^ACRFMENU
+22 QUIT
ADD ;ADD OR EDIT ACCOUNT
+1 SET DIR(0)="SO^1:ADD New Account;2:INCREASE Existing Account;3:DECREASE Existing Account;4:EDIT Existing Account"
+2 SET DIR("A")="Which one"
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)
QUIT
+5 IF "1234"'[+Y
SET ACRQUIT=""
QUIT
+6 IF Y=1
Begin DoDot:1
+7 KILL ACRQUIT,ACRNEW
+8 SET ACRDIC(0)="AELQZ"
+9 SET ACRDIC("A")="New ACCOUNT DOLLAR AMOUNT: "
End DoDot:1
QUIT
+10 IF Y=2!(Y=3)
Begin DoDot:1
+11 DO ORIG
End DoDot:1
QUIT
+12 IF Y=4
Begin DoDot:1
+13 SET ACRDIC(0)=$TRANSLATE(ACRDIC(0),"L","")
End DoDot:1
QUIT
+14 QUIT
ORIG ;ID INCREASES AND DECREASES
+1 KILL ACRORIG
+2 NEW ACRXX,ACRAMT,ACR0,ACRDT
+3 SET ACRORIG=$SELECT(Y=2:"I",Y=3:"D",1:"")
+4 IF ACRORIG=""
SET ACRQUIT=""
QUIT
+5 DO AMT
+6 IF $DATA(ACRQUIT)
QUIT
+7 SET DIC=ACRDIC
+8 SET DIC(0)="AENQZ"
+9 SET DIC("A")="ID NO. of Account to be Increased or Decreased: "
+10 SET DIC("S")="I $P(^(0),U,8)=""O"""
+11 WRITE !
+12 DO DIC^ACRFDIC
+13 IF +Y<1
SET ACRQUIT=""
QUIT
+14 SET ACRXX=+Y
+15 SET X=ACRAMT
+16 SET DIC=ACRDIC
+17 SET DIC(0)="L"
+18 SET ACR0=@(ACRDIC_ACRXX_",0)")
SET ACRDT=@(ACRDIC_ACRXX_","_"""DT"""_")")
+19 SET DIC("DR")=".02////"_$PIECE(ACR0,U,2)_";.03////"_$PIECE(ACR0,U,3)_";.04////"_$PIECE(ACR0,U,4)_";.05////"_$PIECE(ACR0,U,5)_";.16////N;.17////"_DT_";.18////"_DUZ_";.2////"_$PIECE(ACR0,U,12)_";.21////"_$PIECE(ACR0,U,21)_";.3////"_$PIECE(ACR0,U,
13)
+20 SET DIC("DR")=DIC("DR")_";.8////"_ACRORIG_";.9////"_ACRXX
+21 DO FILE^ACRFDIC
+22 SET (ACRZDA,DA)=+Y
+23 SET ACRYY=Y
+24 SET DIE=ACRDIC
+25 SET DR="10////"_$PIECE(ACRDT,U)_";20////"_$PIECE(ACRDT,U,2)_";30////"_$PIECE(ACRDT,U,3)_";40////"_$PIECE(ACRDT,U,4)_";50////"_$PIECE(ACRDT,U,5)_";60////"_$PIECE(ACRDT,U,6)_";70////"_$PIECE(ACRDT,U,7)_";80////"_$PIECE(ACRDT,U,8)_";90////"_...
... $PIECE(ACRDT,U,9)
+26 SET DR=DR_";110////"_$PIECE(ACRDT,U,11)_";130////"_$PIECE(ACRDT,U,13)_";150////"_$PIECE(ACRDT,U,15)
+27 DO DIE^ACRFDIC
+28 SET (ACRQUIT,ACRNEW)=""
+29 SET X=DUZ
+30 SET DA(1)=ACRZDA
+31 SET DIC=ACRDIC_ACRZDA_",""SC"","
+32 SET DIC(0)="L"
+33 IF '$DATA(@(ACRDIC_ACRZDA_",""SC"",0)"))
SET $PIECE(^(0),U,2)=$SELECT(ACRDIC["ACRAPP":9002185.01,ACRDIC["ACRALW":9002186.01,ACRDIC["ACRALC":9002187.04,1:9002188.04)_"P"
+34 DO FILE^ACRFDIC
+35 QUIT
AMT ;ENTER ACCOUNT AMOUNT
+1 SET DIR(0)="NOA^0:9999999"
+2 IF $GET(ACRDIC)["ACRLOCB"
IF $GET(ACRDIC(0))["L"
SET DIR("A",1)="(NON-Personnel Amount ONLY)"
+3 SET DIR("A")="Amount of Increase/Decrease: "
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF $DATA(ACRQUIT)
QUIT
+7 SET ACRAMT=Y
+8 QUIT
