- 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 Feb 18, 2025@23:27:40 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