source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCEAU1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1PRCEAU1 ;WISC/CLH/LDB/BGJ-AUTHORIZATION EDITS ; 07/08/93 12:00 PM
2V ;;5.1;IFCAP;**23**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ADJ N DIR,X,Y,ACT,DIFF,UAAMT,IN
5AMT 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"
6 S DIR("?",2)="I will do the calculations to update the authorization and",DIR("?",4)="obligations balances.",DIR("?",5)=" "
7 D ^DIR S AMT=X G:$D(DIRUT) ZEROQ
8 S ABAL=$P(^PRC(424,DA,0),U,5)
9 D G:AMT="" AMT Q
10 . S DIFF=X-$P($G(^PRC(424,DA,0)),U,12)
11 . I +BAL-$P(BAL,U,3)-DIFF<0 S PRCADJ=0 D Q:PRCADJ
12 .. W !,$C(7),"This amount EXCEEDS the balance remaining on this",!,"obligation by ",$FN(+BAL-($P(BAL,U,3)+DIFF),",",2),"."
13 .. 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
14 . 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
15 . S PRCADJ=0,AAMT=DIFF D ADJ^PRCEDRE0 Q:PRCADJ
16 . 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
17 . 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
18 . ; if remaining authorized balance is smaller than 5% of obligated
19 . ; balance, send mail to alert user.
20 . I $D(^PRC(424,DA,0)),$P(^(0),U,5)<($P(BAL,U)*.05) S IN="EDIT" D ^PRCEBL
21 . Q
22ZERO ;zero out authorization balance, mark authorization as complete and
23 ;and return left over monies to obligation
24 ;PODA MUST be defined and equal to internal obligation nuber
25 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
26 I $D(DIRUT)!('Y) S X="" G ZEROQ
27 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
28UPDT ;Called from PRCEDRE when final daily record is entered
29 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
30 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
31 W ! S X="Authorization and obligation balances update" D MSG^PRCFQ
32ZEROQ K DIRUT,DIROUT,DUOUT,DTOUT Q
33 ;
34OPN ;Called from PRCEAU to reopen an authorization set as completed
35 K DIR S DIR(0)="YO",DIR("A",1)="Reopening this authorization will allow transferral of funds from the obligation"
36 S DIR("A",2)="to THIS authorization."
37 S DIR("A",3)="These funds will remain available only within this authorization",DIR("A",4)="until the authorization is marked as complete."
38 S DIR("A",5)="At which time the funds will be transferred back to the obligation."
39 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
40 K DIR S ACT="I" D AMT
41 G:AMT="^" ZEROQ S DIE="^PRC(424,",DA=AUDA,DR=".09////@" D ^DIE,ZEROQ Q
42BUPDT ;up date balance in file 442
43 D BALUP^PRCH58(PODA,BAL1)
44 Q
45BALDIS ;Called from PRCEAU to display balances
46 S Y=$FN(+$G(BAL),",P",2) W !!,"Obligation amount: $" W $$LBF1^PRCFU(Y,14)
47 S Y=$FN(+$G(BAL)-$P($G(BAL),U,2),",P",2) W ?42,"Fiscal balance: $" W $$LBF1^PRCFU(Y,14)
48 S Y=$FN(+$G(BAL)-$P($G(BAL),U,3),",P",2) W !?2,"Service balance: $" W $$LBF1^PRCFU(Y,14)
49 Q
Note: See TracBrowser for help on using the repository browser.