PRCEAU ;WISC/CLH/LDB/BGJ-CREATE/EDIT AUTHORIZATIONS-CONTROL POINTS ; 15 Apr 93 1:20 PM
V ;;5.1;IFCAP;**23,180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
;
;Enter new or edit old authorizations
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
;S PRCF("X")="S" D ^PRCFSITE Q:'%
D EN3^PRCSUT Q:'$D(PRC("CP"))
;look up obligation number
GO S DIC="^PRCS(410," D OROBL^PRCS58OB(DIC,.PRC,.Y) G EXIT:Y<0 S PRCRI(410)=+Y
EN0 K DIR,AMT,PRCF,PODA,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL,BAL1,BAL2,Z,X,Y
D NODE^PRCS58OB(PRCRI(410),.TRNODE) S PODA=$P($G(TRNODE(10)),U,3)
G:'$G(PODA) GO
EN ;when and poda and site variables are defined
S BAL=$$BAL^PRCH58(PODA)
D NOW^%DTC S TIME=% K Y
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'"
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
. 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
. S (AUDA,DA)=+Y,AUDA0=$P(Y,U,2),DIE=DIC
. L +^PRC(424,DA):3 E S X="Another user is editing this entry. Try later." D MSG^PRCFQ Q
. 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),!
. K DIR S DIR(0)="L^1:6",DIR("A",1)=" 1 Edit authorization",DIR("A",2)=" 2 Mark authorization as COMPLETE"
. 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"
. S DIR("A")="Select ACTION",DIR("?")="^D HLP^PRCEAU0" D ^DIR
. Q:'Y
. K FINAL S ACT=Y F JJ=1:1 S I=$P(ACT,",",JJ) Q:I="" D Q:$D(FINAL)
.. Q:I=6
.. 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
.. I I=1 N ACT,I D ADJ^PRCEAU1 Q
.. I "23"[I N ACT,I D ZERO^PRCEAU1 Q
.. I I=4,'$P(^PRC(424,AUDA,0),U,9) W !,"This authorization is not marked as complete yet.",$C(7) H 3 Q
.. I I=4 S FINAL=1 N ACT,I D OPN^PRCEAU1 K FINAL Q
.. S DR="1.1" D ^DIE Q
.. Q
S (X,Z)=PRC("SITE")_"-"_$P($G(TRNODE(4)),U,5)
D WAIT^PRCFYN S PRCE424=1 K MSG D EN1^PRCSUT3 K PRCE424 I $D(MSG),MSG'="" S X=MSG D MSG^PRCFQ K MSG G EXIT ;PRC*5.1*180
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 ;PRC*5.1*180
W !,"This entry has been assigned transaction number: ",$P(X,"-",3),"."
S DIE=DIC,(AUDA,DA)=+Y,AUDA0=Y(0)
D NOW^%DTC S TIME=% K Y
D BALDIS^PRCEAU1
AMT ;looping area for authorization amount
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
I $D(DIRUT)!(Y<.01) D AMTMSG,AMTDEL G EN0
; no MAIL for create authorization
;D BUL^PRCEAU0
I Y>(+BAL-$P(BAL,U,3)) D G EN0
. W $C(7),!,"This amount will EXCEED obligation balances by $",$FN((+BAL-$P(BAL,U,3))-Y,",",2),"."
. W !!?20,"SERVICE BALANCE: $",$FN(+BAL-$P(BAL,U,3),",",2),!! H 3
. W !!,"This authorization cannot be entered until Fiscal has obligated ",!,"the increase adjustment." K DIR,DIC
. D ASK^PRCEADJ,ADJMSG,AMTDEL
EN1 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"
D ^DIE
I $D(Y) D DEL^PRCEAU0 G EN0
Q:'$D(^PRC(424,AUDA,0)) S X(1)=0
D LREC^PRCEAU0 G EN0
EXIT L:$D(AUDA) -^PRC(424,AUDA) K DIK,DIRUT,DIROUT,TRNODE,DTOUT,DUOUT Q
AMTMSG S X="----Amount missing - authorization deleted----" D MSG^PRCFQ Q
ADJMSG S X="Authorization deleted pending adjustment action by Fiscal.." D MSG^PRCFQ Q
AMTDEL S DA=AUDA,DIK="^PRC(424," D ^DIK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEAU 4231 printed Apr 09, 2024@21:00:58 Page 2
PRCEAU ;WISC/CLH/LDB/BGJ-CREATE/EDIT AUTHORIZATIONS-CONTROL POINTS ; 15 Apr 93 1:20 PM
V ;;5.1;IFCAP;**23,180**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
+4 ;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
+5 ;
+6 ;Enter new or edit old authorizations
+7 NEW 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
+8 ;S PRCF("X")="S" D ^PRCFSITE Q:'%
+9 DO EN3^PRCSUT
if '$DATA(PRC("CP"))
QUIT
+10 ;look up obligation number
GO SET DIC="^PRCS(410,"
DO OROBL^PRCS58OB(DIC,.PRC,.Y)
if Y<0
GOTO EXIT
SET PRCRI(410)=+Y
EN0 KILL DIR,AMT,PRCF,PODA,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL,BAL1,BAL2,Z,X,Y
+1 DO NODE^PRCS58OB(PRCRI(410),.TRNODE)
SET PODA=$PIECE($GET(TRNODE(10)),U,3)
+2 if '$GET(PODA)
GOTO GO
EN ;when and poda and site variables are defined
+1 SET BAL=$$BAL^PRCH58(PODA)
+2 DO NOW^%DTC
SET TIME=%
KILL Y
+3 KILL Y
SET DIR("?")=" "
SET DIR(0)="SOA^1:CREATE;2:EDIT"
SET DIR("A")="Would you like to EDIT or CREATE an Authorization: "
SET DIR("?",1)="If you want to EDIT an existing authorization type 'E'"
+4 SET DIR("?",2)="If you want to CREATE a NEW authorization type 'C'"
SET DIR("?",3)="OR press <RETURN>"
DO ^DIR
KILL DIR
if Y["^"!(Y="")
GOTO GO
IF Y=2
Begin DoDot:1
+5 SET DIC="^PRC(424,"
SET DIC(0)="AEMNQ"
SET DIC("S")="I $P($P(^(0),U),""-"",1,2)=(PRC(""SITE"")_""-""_$P($G(TRNODE(4)),U,5)),$P(^(0),U,3)=""AU"""
DO ^DIC
KILL DIC("S")
if Y<0
QUIT
+6 SET (AUDA,DA)=+Y
SET AUDA0=$PIECE(Y,U,2)
SET DIE=DIC
+7 LOCK +^PRC(424,DA):3
IF '$TEST
SET X="Another user is editing this entry. Try later."
DO MSG^PRCFQ
QUIT
+8 DO BALDIS^PRCEAU1
WRITE ?35,"Authorization balance: ","$"
SET Y=$FNUMBER($PIECE($GET(^PRC(424,+AUDA,0)),U,5),",P",2)
WRITE $$LBF1^PRCFU(Y,14),!
+9 KILL DIR
SET DIR(0)="L^1:6"
SET DIR("A",1)=" 1 Edit authorization"
SET DIR("A",2)=" 2 Mark authorization as COMPLETE"
+10 SET DIR("A",3)=" 3 ZERO out authorization"
SET DIR("A",4)=" 4 Reopen Authorization"
SET DIR("A",5)=" 5 Enter/Edit COMMENTS"
SET DIR("A",6)=" 6 QUIT"
+11 SET DIR("A")="Select ACTION"
SET DIR("?")="^D HLP^PRCEAU0"
DO ^DIR
+12 if 'Y
QUIT
+13 KILL FINAL
SET ACT=Y
FOR JJ=1:1
SET I=$PIECE(ACT,",",JJ)
if I=""
QUIT
Begin DoDot:2
+14 if I=6
QUIT
+15 IF I<4
IF $PIECE($GET(^PRC(424,AUDA,0)),U,9)
WRITE !,"This authorization has been marked as completed",!,"and must first be reopened to continue."
SET FINAL=1
QUIT
+16 IF I=1
NEW ACT,I
DO ADJ^PRCEAU1
QUIT
+17 IF "23"[I
NEW ACT,I
DO ZERO^PRCEAU1
QUIT
+18 IF I=4
IF '$PIECE(^PRC(424,AUDA,0),U,9)
WRITE !,"This authorization is not marked as complete yet.",$CHAR(7)
HANG 3
QUIT
+19 IF I=4
SET FINAL=1
NEW ACT,I
DO OPN^PRCEAU1
KILL FINAL
QUIT
+20 SET DR="1.1"
DO ^DIE
QUIT
+21 QUIT
End DoDot:2
if $DATA(FINAL)
QUIT
End DoDot:1
GOTO EN0
+22 SET (X,Z)=PRC("SITE")_"-"_$PIECE($GET(TRNODE(4)),U,5)
+23 ;PRC*5.1*180
DO WAIT^PRCFYN
SET PRCE424=1
KILL MSG
DO EN1^PRCSUT3
KILL PRCE424
IF $DATA(MSG)
IF MSG'=""
SET X=MSG
DO MSG^PRCFQ
KILL MSG
GOTO EXIT
+24 ;PRC*5.1*180
SET DIC="^PRC(424,"
SET DLAYGO=424
SET DIC(0)="LXZ"
DO ^DIC
IF Y<0
SET X="Unable to create an new entry. Contact Application Coordinator.*"
DO MSG^PRCFQ
GOTO EXIT
+25 WRITE !,"This entry has been assigned transaction number: ",$PIECE(X,"-",3),"."
+26 SET DIE=DIC
SET (AUDA,DA)=+Y
SET AUDA0=Y(0)
+27 DO NOW^%DTC
SET TIME=%
KILL Y
+28 DO BALDIS^PRCEAU1
AMT ;looping area for authorization amount
+1 if $DATA(DIRUT)
GOTO EN0
KILL DIR
SET DIR(0)="N^.01:999999999.99:2"
SET DIR("A")="AUTHORIZATION AMOUNT"
SET DIR("?")="enter the amount of this authorization or '^' to QUIT"
DO ^DIR
+2 IF $DATA(DIRUT)!(Y<.01)
DO AMTMSG
DO AMTDEL
GOTO EN0
+3 ; no MAIL for create authorization
+4 ;D BUL^PRCEAU0
+5 IF Y>(+BAL-$PIECE(BAL,U,3))
Begin DoDot:1
+6 WRITE $CHAR(7),!,"This amount will EXCEED obligation balances by $",$FNUMBER((+BAL-$PIECE(BAL,U,3))-Y,",",2),"."
+7 WRITE !!?20,"SERVICE BALANCE: $",$FNUMBER(+BAL-$PIECE(BAL,U,3),",",2),!!
HANG 3
+8 WRITE !!,"This authorization cannot be entered until Fiscal has obligated ",!,"the increase adjustment."
KILL DIR,DIC
+9 DO ASK^PRCEADJ
DO ADJMSG
DO AMTDEL
End DoDot:1
GOTO EN0
EN1 SET BAL1=+Y
SET 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"
+1 DO ^DIE
+2 IF $DATA(Y)
DO DEL^PRCEAU0
GOTO EN0
+3 if '$DATA(^PRC(424,AUDA,0))
QUIT
SET X(1)=0
+4 DO LREC^PRCEAU0
GOTO EN0
EXIT if $DATA(AUDA)
LOCK -^PRC(424,AUDA)
KILL DIK,DIRUT,DIROUT,TRNODE,DTOUT,DUOUT
QUIT
AMTMSG SET X="----Amount missing - authorization deleted----"
DO MSG^PRCFQ
QUIT
ADJMSG SET X="Authorization deleted pending adjustment action by Fiscal.."
DO MSG^PRCFQ
QUIT
AMTDEL SET DA=AUDA
SET DIK="^PRC(424,"
DO ^DIK
QUIT
