source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCEAU.m@ 767

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PRCEAU ;WISC/CLH/LDB/BGJ-CREATE/EDIT AUTHORIZATIONS-CONTROL POINTS ; 15 Apr 93 1:20 PM
2V ;;5.1;IFCAP;**23**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;Enter new or edit old authorizations
5 N AMT,PRC,PRCF,DIC,DIR,DLAYGO,DIE,DA,DR,Y,X,PODA,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL,BAL1,BAL2,Z,X,Y
6 ;S PRCF("X")="S" D ^PRCFSITE Q:'%
7 D EN3^PRCSUT Q:'$D(PRC("CP"))
8 ;look up obligation number
9GO S DIC="^PRCS(410," D OROBL^PRCS58OB(DIC,.PRC,.Y) G EXIT:Y<0 S PRCRI(410)=+Y
10EN0 K DIR,AMT,PRCF,PODA,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL,BAL1,BAL2,Z,X,Y
11 D NODE^PRCS58OB(PRCRI(410),.TRNODE) S PODA=$P($G(TRNODE(10)),U,3)
12 G:'$G(PODA) GO
13EN ;when and poda and site variables are defined
14 S BAL=$$BAL^PRCH58(PODA)
15 D NOW^%DTC S TIME=% K Y
16 K Y S DIR("?")=" ",DIR(0)="SOA^1:CREATE;2:EDIT",DIR("A")="Would you like to EDIT or CREATE an Authorization: ",DIR("?",1)="If you want to EDIT an existing authorization type 'E'"
17 S DIR("?",2)="If you want to CREATE a NEW authorization type 'C'",DIR("?",3)="OR press <RETURN>" D ^DIR K DIR G:Y["^"!(Y="") GO I Y=2 D G EN0
18 . S DIC="^PRC(424," S DIC(0)="AEMNQ" S DIC("S")="I $P($P(^(0),U),""-"",1,2)=(PRC(""SITE"")_""-""_$P($G(TRNODE(4)),U,5)),$P(^(0),U,3)=""AU""" D ^DIC K DIC("S") Q:Y<0
19 . S (AUDA,DA)=+Y,AUDA0=$P(Y,U,2),DIE=DIC
20 . L +^PRC(424,DA):3 E S X="Another user is editing this entry. Try later." D MSG^PRCFQ Q
21 . D BALDIS^PRCEAU1 W ?35,"Authorization balance: ","$" S Y=$FN($P($G(^PRC(424,+AUDA,0)),U,5),",P",2) W $$LBF1^PRCFU(Y,14),!
22 . K DIR S DIR(0)="L^1:6",DIR("A",1)=" 1 Edit authorization",DIR("A",2)=" 2 Mark authorization as COMPLETE"
23 . S DIR("A",3)=" 3 ZERO out authorization",DIR("A",4)=" 4 Reopen Authorization",DIR("A",5)=" 5 Enter/Edit COMMENTS",DIR("A",6)=" 6 QUIT"
24 . S DIR("A")="Select ACTION",DIR("?")="^D HLP^PRCEAU0" D ^DIR
25 . Q:'Y
26 . K FINAL S ACT=Y F JJ=1:1 S I=$P(ACT,",",JJ) Q:I="" D Q:$D(FINAL)
27 .. Q:I=6
28 .. I I<4,$P($G(^PRC(424,AUDA,0)),U,9) W !,"This authorization has been marked as completed",!,"and must first be reopened to continue." S FINAL=1 Q
29 .. I I=1 N ACT,I D ADJ^PRCEAU1 Q
30 .. I "23"[I N ACT,I D ZERO^PRCEAU1 Q
31 .. I I=4,'$P(^PRC(424,AUDA,0),U,9) W !,"This authorization is not marked as complete yet.",$C(7) H 3 Q
32 .. I I=4 S FINAL=1 N ACT,I D OPN^PRCEAU1 K FINAL Q
33 .. S DR="1.1" D ^DIE Q
34 .. Q
35 S (X,Z)=PRC("SITE")_"-"_$P($G(TRNODE(4)),U,5)
36 D WAIT^PRCFYN,EN1^PRCSUT3 S DIC="^PRC(424,",DLAYGO=424,DIC(0)="LXZ" D ^DIC I Y<0 S X="Unable to create an new entry. Contact Application Coordinator.*" D MSG^PRCFQ G EXIT
37 W !,"This entry has been assigned transaction number: ",$P(X,"-",3),"."
38 S DIE=DIC,(AUDA,DA)=+Y,AUDA0=Y(0)
39 D NOW^%DTC S TIME=% K Y
40 D BALDIS^PRCEAU1
41AMT ;looping area for authorization amount
42 G:$D(DIRUT) EN0 K DIR S DIR(0)="N^.01:999999999.99:2",DIR("A")="AUTHORIZATION AMOUNT",DIR("?")="enter the amount of this authorization or '^' to QUIT" D ^DIR
43 I $D(DIRUT)!(Y<.01) D AMTMSG,AMTDEL G EN0
44 ; no MAIL for create authorization
45 ;D BUL^PRCEAU0
46 I Y>(+BAL-$P(BAL,U,3)) D G EN0
47 . W $C(7),!,"This amount will EXCEED obligation balances by $",$FN((+BAL-$P(BAL,U,3))-Y,",",2),"."
48 . W !!?20,"SERVICE BALANCE: $",$FN(+BAL-$P(BAL,U,3),",",2),!! H 3
49 . W !!,"This authorization cannot be entered until Fiscal has obligated ",!,"the increase adjustment." K DIR,DIC
50 . D ASK^PRCEADJ,ADJMSG,AMTDEL
51EN1 S BAL1=+Y,DR=".02////^S X=PODA;.03////^S X=""AU"";.07////^S X=TIME;.08////^S X=DUZ;.05////^S X=BAL1;.12////^S X=BAL1;.13////^S X=BAL1;.1;1.1"
52 D ^DIE
53 I $D(Y) D DEL^PRCEAU0 G EN0
54 Q:'$D(^PRC(424,AUDA,0)) S X(1)=0
55 D LREC^PRCEAU0 G EN0
56EXIT L:$D(AUDA) -^PRC(424,AUDA) K DIK,DIRUT,DIROUT,TRNODE,DTOUT,DUOUT Q
57AMTMSG S X="----Amount missing - authorization deleted----" D MSG^PRCFQ Q
58ADJMSG S X="Authorization deleted pending adjustment action by Fiscal.." D MSG^PRCFQ Q
59AMTDEL S DA=AUDA,DIK="^PRC(424," D ^DIK Q
Note: See TracBrowser for help on using the repository browser.