PRCEAU1 ;WISC/CLH/LDB/BGJ-AUTHORIZATION EDITS ; 07/08/93 12:00 PM
V ;;5.1;IFCAP;**23**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ADJ N DIR,X,Y,ACT,DIFF,UAAMT,IN
AMT S DIR(0)="N^0.01:999999999.99:2",DIR("A")="Change AUTHORIZATION amount",DIR("B")=$P(^PRC(424,DA,0),U,12),DIR("?",1)="Enter NEW amount of the authorization or '^' to quit"
S DIR("?",2)="I will do the calculations to update the authorization and",DIR("?",4)="obligations balances.",DIR("?",5)=" "
D ^DIR S AMT=X G:$D(DIRUT) ZEROQ
S ABAL=$P(^PRC(424,DA,0),U,5)
D G:AMT="" AMT Q
. S DIFF=X-$P($G(^PRC(424,DA,0)),U,12)
. I +BAL-$P(BAL,U,3)-DIFF<0 S PRCADJ=0 D Q:PRCADJ
.. W !,$C(7),"This amount EXCEEDS the balance remaining on this",!,"obligation by ",$FN(+BAL-($P(BAL,U,3)+DIFF),",",2),"."
.. W !!,?20,"AVAILABLE FUNDS: ",$FN((+BAL-$P(BAL,U,3)),",",2),!!,"An increase adjustment to the obligation must be submitted." D ASK^PRCEADJ S PRCADJ=1 Q
. I $P($G(^PRC(424,DA,0)),U,12)-ABAL>AMT W !,$C(7),"This amount will cause a negative balance on this",!,"authorization." S AMT="" Q
. S PRCADJ=0,AAMT=DIFF D ADJ^PRCEDRE0 Q:PRCADJ
. S BAL2=$P($G(^PRC(424,DA,0)),U,12)+DIFF,BAL1=+DIFF,ABAL=ABAL+DIFF,DR=".05////^S X=ABAL;.12////^S X=BAL2;.1;1.1",DIE="^PRC(424," D WAIT^PRCFYN,^DIE,BUPDT
. W !!,"NEW BALANCES: " S BAL=$$BAL^PRCH58(PODA) D BALDIS W !!,?15,"Authorization Amount: $",$FN($P($G(^PRC(424,DA,0)),U,12),",P",2),!,?28,"Balance: $",$FN($P($G(^(0)),U,5),",P",2),!! H 2
. ; if remaining authorized balance is smaller than 5% of obligated
. ; balance, send mail to alert user.
. I $D(^PRC(424,DA,0)),$P(^(0),U,5)<($P(BAL,U)*.05) S IN="EDIT" D ^PRCEBL
. Q
ZERO ;zero out authorization balance, mark authorization as complete and
;and return left over monies to obligation
;PODA MUST be defined and equal to internal obligation nuber
K DIR S DIR(0)="Y",DIR("A",1)="This will zero out the balance on this authorization",DIR("A",2)="and mark this authorization as complete",DIR("A")="Do you want to continue" D ^DIR
I $D(DIRUT)!('Y) S X="" G ZEROQ
S ABAL=0,X=$G(^PRC(424,DA,0)),AAMT=-$P(X,U,5),BAL1=$P(X,U,12)+AAMT,PRCADJ=0 D ADJ^PRCEDRE0 Q:PRCADJ D WAIT^PRCFYN
UPDT ;Called from PRCEDRE when final daily record is entered
S DA=AUDA,DR=".05////^S X="_$S($G(ABAL):ABAL,1:0)_";.1;1.1;.12////^S X=$S($G(BAL2):BAL2,1:BAL1)",DIE="^PRC(424," S:'$G(ABAL) DR=DR_";.09////^S X=1" D ^DIE S BAL1=AAMT D BUPDT
I '$G(ABAL) S X="Authorization balance has been reduced to ZERO, and this authorization has been marked as complete.*",X1=1 W ! D MSG^PRCFQ G ZEROQ
W ! S X="Authorization and obligation balances update" D MSG^PRCFQ
ZEROQ K DIRUT,DIROUT,DUOUT,DTOUT Q
;
OPN ;Called from PRCEAU to reopen an authorization set as completed
K DIR S DIR(0)="YO",DIR("A",1)="Reopening this authorization will allow transferral of funds from the obligation"
S DIR("A",2)="to THIS authorization."
S DIR("A",3)="These funds will remain available only within this authorization",DIR("A",4)="until the authorization is marked as complete."
S DIR("A",5)="At which time the funds will be transferred back to the obligation."
S DIR("A",6)="",DIR("A")="Are you certain that you would like to reopen this authorization",DIR("B")="NO" D ^DIR I $D(DIRUT)!'Y Q
K DIR S ACT="I" D AMT
G:AMT="^" ZEROQ S DIE="^PRC(424,",DA=AUDA,DR=".09////@" D ^DIE,ZEROQ Q
BUPDT ;up date balance in file 442
D BALUP^PRCH58(PODA,BAL1)
Q
BALDIS ;Called from PRCEAU to display balances
S Y=$FN(+$G(BAL),",P",2) W !!,"Obligation amount: $" W $$LBF1^PRCFU(Y,14)
S Y=$FN(+$G(BAL)-$P($G(BAL),U,2),",P",2) W ?42,"Fiscal balance: $" W $$LBF1^PRCFU(Y,14)
S Y=$FN(+$G(BAL)-$P($G(BAL),U,3),",P",2) W !?2,"Service balance: $" W $$LBF1^PRCFU(Y,14)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEAU1 3766 printed Dec 13, 2024@02:01:17 Page 2
PRCEAU1 ;WISC/CLH/LDB/BGJ-AUTHORIZATION EDITS ; 07/08/93 12:00 PM
V ;;5.1;IFCAP;**23**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ADJ NEW DIR,X,Y,ACT,DIFF,UAAMT,IN
AMT SET DIR(0)="N^0.01:999999999.99:2"
SET DIR("A")="Change AUTHORIZATION amount"
SET DIR("B")=$PIECE(^PRC(424,DA,0),U,12)
SET DIR("?",1)="Enter NEW amount of the authorization or '^' to quit"
+1 SET DIR("?",2)="I will do the calculations to update the authorization and"
SET DIR("?",4)="obligations balances."
SET DIR("?",5)=" "
+2 DO ^DIR
SET AMT=X
if $DATA(DIRUT)
GOTO ZEROQ
+3 SET ABAL=$PIECE(^PRC(424,DA,0),U,5)
+4 Begin DoDot:1
+5 SET DIFF=X-$PIECE($GET(^PRC(424,DA,0)),U,12)
+6 IF +BAL-$PIECE(BAL,U,3)-DIFF<0
SET PRCADJ=0
Begin DoDot:2
+7 WRITE !,$CHAR(7),"This amount EXCEEDS the balance remaining on this",!,"obligation by ",$FNUMBER(+BAL-($PIECE(BAL,U,3)+DIFF),",",2),"."
+8 WRITE !!,?20,"AVAILABLE FUNDS: ",$FNUMBER((+BAL-$PIECE(BAL,U,3)),",",2),!!,"An increase adjustment to the obligation must be submitted."
DO ASK^PRCEADJ
SET PRCADJ=1
QUIT
End DoDot:2
if PRCADJ
QUIT
+9 IF $PIECE($GET(^PRC(424,DA,0)),U,12)-ABAL>AMT
WRITE !,$CHAR(7),"This amount will cause a negative balance on this",!,"authorization."
SET AMT=""
QUIT
+10 SET PRCADJ=0
SET AAMT=DIFF
DO ADJ^PRCEDRE0
if PRCADJ
QUIT
+11 SET BAL2=$PIECE($GET(^PRC(424,DA,0)),U,12)+DIFF
SET BAL1=+DIFF
SET ABAL=ABAL+DIFF
SET DR=".05////^S X=ABAL;.12////^S X=BAL2;.1;1.1"
SET DIE="^PRC(424,"
DO WAIT^PRCFYN
DO ^DIE
DO BUPDT
+12 WRITE !!,"NEW BALANCES: "
SET BAL=$$BAL^PRCH58(PODA)
DO BALDIS
WRITE !!,?15,"Authorization Amount: $",$FNUMBER($PIECE($GET(^PRC(424,DA,0)),U,12),",P",2),!,?28,"Balance: $",$FNUMBER($PIECE($GET(^(0)),U,5),",P",2),!!
HANG 2
+13 ; if remaining authorized balance is smaller than 5% of obligated
+14 ; balance, send mail to alert user.
+15 IF $DATA(^PRC(424,DA,0))
IF $PIECE(^(0),U,5)<($PIECE(BAL,U)*.05)
SET IN="EDIT"
DO ^PRCEBL
+16 QUIT
End DoDot:1
if AMT=""
GOTO AMT
QUIT
ZERO ;zero out authorization balance, mark authorization as complete and
+1 ;and return left over monies to obligation
+2 ;PODA MUST be defined and equal to internal obligation nuber
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("A",1)="This will zero out the balance on this authorization"
SET DIR("A",2)="and mark this authorization as complete"
SET DIR("A")="Do you want to continue"
DO ^DIR
+4 IF $DATA(DIRUT)!('Y)
SET X=""
GOTO ZEROQ
+5 SET ABAL=0
SET X=$GET(^PRC(424,DA,0))
SET AAMT=-$PIECE(X,U,5)
SET BAL1=$PIECE(X,U,12)+AAMT
SET PRCADJ=0
DO ADJ^PRCEDRE0
if PRCADJ
QUIT
DO WAIT^PRCFYN
UPDT ;Called from PRCEDRE when final daily record is entered
+1 SET DA=AUDA
SET DR=".05////^S X="_$SELECT($GET(ABAL):ABAL,1:0)_";.1;1.1;.12////^S X=$S($G(BAL2):BAL2,1:BAL1)"
SET DIE="^PRC(424,"
if '$GET(ABAL)
SET DR=DR_";.09////^S X=1"
DO ^DIE
SET BAL1=AAMT
DO BUPDT
+2 IF '$GET(ABAL)
SET X="Authorization balance has been reduced to ZERO, and this authorization has been marked as complete.*"
SET X1=1
WRITE !
DO MSG^PRCFQ
GOTO ZEROQ
+3 WRITE !
SET X="Authorization and obligation balances update"
DO MSG^PRCFQ
ZEROQ KILL DIRUT,DIROUT,DUOUT,DTOUT
QUIT
+1 ;
OPN ;Called from PRCEAU to reopen an authorization set as completed
+1 KILL DIR
SET DIR(0)="YO"
SET DIR("A",1)="Reopening this authorization will allow transferral of funds from the obligation"
+2 SET DIR("A",2)="to THIS authorization."
+3 SET DIR("A",3)="These funds will remain available only within this authorization"
SET DIR("A",4)="until the authorization is marked as complete."
+4 SET DIR("A",5)="At which time the funds will be transferred back to the obligation."
+5 SET DIR("A",6)=""
SET DIR("A")="Are you certain that you would like to reopen this authorization"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DIRUT)!'Y
QUIT
+6 KILL DIR
SET ACT="I"
DO AMT
+7 if AMT="^"
GOTO ZEROQ
SET DIE="^PRC(424,"
SET DA=AUDA
SET DR=".09////@"
DO ^DIE
DO ZEROQ
QUIT
BUPDT ;up date balance in file 442
+1 DO BALUP^PRCH58(PODA,BAL1)
+2 QUIT
BALDIS ;Called from PRCEAU to display balances
+1 SET Y=$FNUMBER(+$GET(BAL),",P",2)
WRITE !!,"Obligation amount: $"
WRITE $$LBF1^PRCFU(Y,14)
+2 SET Y=$FNUMBER(+$GET(BAL)-$PIECE($GET(BAL),U,2),",P",2)
WRITE ?42,"Fiscal balance: $"
WRITE $$LBF1^PRCFU(Y,14)
+3 SET Y=$FNUMBER(+$GET(BAL)-$PIECE($GET(BAL),U,3),",P",2)
WRITE !?2,"Service balance: $"
WRITE $$LBF1^PRCFU(Y,14)
+4 QUIT
