PRCEDRE0 ;WISC/LDB-ENTER/EDIT DAILY RECORD CONT ; 06/09/93 1:24 PM
;;5.1;IFCAP;**180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;Called from PRCEDRE and PRCEDRE1 to increase authorization amount
;
;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.
;
AMTOVR W $C(7),!,"This amount exceeds the authorization balance by $",$FN((AAMT-ABAL),",P",2)
W !!,"The available authorization balance is $",$FN(ABAL,",P",2)
W $C(7),!!,"This daily record amount cannot be entered until an",!,"increase has been made to the authorization."
K DIR N X,Y S PRCADJ=0,DIR("A")="Would you like to increase the authorization amount at this time by $"_$FN((ABAL-AAMT),",-",2),DIR(0)="Y0",DIR("B")="NO" D ^DIR I 'Y S PRCADJ=1 Q
W !!,"Checking the available obligation balance . . ."
S BAL=$$BAL^PRCH58(PODA)
I $P(BAL,U,3)+AAMT-ABAL>+BAL D Q
. W !,"This authorization amount will exceed the obligation balance by $",$FN($P(BAL,U,3)+AAMT-ABAL-BAL,",P",2) S PRCADJ=2 D ASK^PRCEADJ
. W !,"This daily record cannot be posted until Fiscal has obligated"
. W !,"the increase adjustment."
S PRCADJ=0,AAMT1=AAMT,AAMT=(AAMT-ABAL) D ADJ S AAMT=AAMT1 Q:PRCADJ
S $P(^PRC(424,AUDA,0),U,5)=ABAL+(AAMT-ABAL),$P(^(0),U,12)=$P(^(0),U,12)+(AAMT-ABAL) D BALUP^PRCH58(PODA,(AAMT-ABAL)) Q
ADJ ;Called to make adjustment entry in 424.1 for authorization adjustment
K DIC S DLAYGO=424.1,DIC="^PRC(424.1,",DIC(0)="L",X=""""_$P(AUDA0,U)_"-"_0_"""",DIC("DR")=".011////^S X=""A"";.02////^S X=AUDA;.03////^S X=AAMT;.04///^S X=""NOW"";05////^S X=DUZ"
D ^DIC S:Y<0 PRCADJ=1 K DIC,X,Y
Q
;WISC/PLT - add authorization from daily actvity option
AU(PRC424) ;add an authorization record called from PRCEDRE
S PRC424=""
D YN^PRC0A(.X,.Y,"Add an authorization","","YES") G EXIT:Y'=1
N AMT,PRCF,DIC,DIR,DLAYGO,DIE,DA,DR,Y,X,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL1,BAL2,Z,X,Y
D NOW^%DTC S TIME=% K Y
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 K MSG 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 ;ask authorization amount
G:$D(DIRUT) EXIT 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 EXIT
;balance alert message
D BUL^PRCEAU0
I Y>(+BAL-$P(BAL,U,3)) D G EXIT
. 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 CP/Fiscal have increased ",!,"and obligated the adjustment." K DIR,DIC
. D 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 EXIT
Q:'$D(^PRC(424,AUDA,0)) S X(1)=0
;add record in file 424.1 and edit balance in file 442
D LREC^PRCEAU0 S:$D(^PRC(424,AUDA,0)) PRC424=AUDA
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 CP/Fiscal.." D MSG^PRCFQ Q
AMTDEL S DA=AUDA,DIK="^PRC(424," D ^DIK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEDRE0 3769 printed Nov 22, 2024@17:11:29 Page 2
PRCEDRE0 ;WISC/LDB-ENTER/EDIT DAILY RECORD CONT ; 06/09/93 1:24 PM
+1 ;;5.1;IFCAP;**180**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Called from PRCEDRE and PRCEDRE1 to increase authorization amount
+4 ;
+5 ;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
+6 ;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
+7 ;
AMTOVR WRITE $CHAR(7),!,"This amount exceeds the authorization balance by $",$FNUMBER((AAMT-ABAL),",P",2)
+1 WRITE !!,"The available authorization balance is $",$FNUMBER(ABAL,",P",2)
+2 WRITE $CHAR(7),!!,"This daily record amount cannot be entered until an",!,"increase has been made to the authorization."
+3 KILL DIR
NEW X,Y
SET PRCADJ=0
SET DIR("A")="Would you like to increase the authorization amount at this time by $"_$FNUMBER((ABAL-AAMT),",-",2)
SET DIR(0)="Y0"
SET DIR("B")="NO"
DO ^DIR
IF 'Y
SET PRCADJ=1
QUIT
+4 WRITE !!,"Checking the available obligation balance . . ."
+5 SET BAL=$$BAL^PRCH58(PODA)
+6 IF $PIECE(BAL,U,3)+AAMT-ABAL>+BAL
Begin DoDot:1
+7 WRITE !,"This authorization amount will exceed the obligation balance by $",$FNUMBER($PIECE(BAL,U,3)+AAMT-ABAL-BAL,",P",2)
SET PRCADJ=2
DO ASK^PRCEADJ
+8 WRITE !,"This daily record cannot be posted until Fiscal has obligated"
+9 WRITE !,"the increase adjustment."
End DoDot:1
QUIT
+10 SET PRCADJ=0
SET AAMT1=AAMT
SET AAMT=(AAMT-ABAL)
DO ADJ
SET AAMT=AAMT1
if PRCADJ
QUIT
+11 SET $PIECE(^PRC(424,AUDA,0),U,5)=ABAL+(AAMT-ABAL)
SET $PIECE(^(0),U,12)=$PIECE(^(0),U,12)+(AAMT-ABAL)
DO BALUP^PRCH58(PODA,(AAMT-ABAL))
QUIT
ADJ ;Called to make adjustment entry in 424.1 for authorization adjustment
+1 KILL DIC
SET DLAYGO=424.1
SET DIC="^PRC(424.1,"
SET DIC(0)="L"
SET X=""""_$PIECE(AUDA0,U)_"-"_0_""""
SET DIC("DR")=".011////^S X=""A"";.02////^S X=AUDA;.03////^S X=AAMT;.04///^S X=""NOW"";05////^S X=DUZ"
+2 DO ^DIC
if Y<0
SET PRCADJ=1
KILL DIC,X,Y
+3 QUIT
+4 ;WISC/PLT - add authorization from daily actvity option
AU(PRC424) ;add an authorization record called from PRCEDRE
+1 SET PRC424=""
+2 DO YN^PRC0A(.X,.Y,"Add an authorization","","YES")
if Y'=1
GOTO EXIT
+3 NEW AMT,PRCF,DIC,DIR,DLAYGO,DIE,DA,DR,Y,X,TRDA,ER,TIME,IN,ABAL,ACT,AUDA,BAL1,BAL2,Z,X,Y
+4 DO NOW^%DTC
SET TIME=%
KILL Y
+5 SET (X,Z)=PRC("SITE")_"-"_$PIECE($GET(TRNODE(4)),U,5)
+6 ;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
+7 ;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
KILL MSG
GOTO EXIT
+8 WRITE !,"This entry has been assigned transaction number: ",$PIECE(X,"-",3),"."
+9 SET DIE=DIC
SET (AUDA,DA)=+Y
SET AUDA0=Y(0)
+10 DO NOW^%DTC
SET TIME=%
KILL Y
+11 DO BALDIS^PRCEAU1
AMT ;ask authorization amount
+1 if $DATA(DIRUT)
GOTO EXIT
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 EXIT
+3 ;balance alert message
+4 DO 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 CP/Fiscal have increased ",!,"and obligated the adjustment."
KILL DIR,DIC
+9 DO ADJMSG
DO AMTDEL
End DoDot:1
GOTO EXIT
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 EXIT
+3 if '$DATA(^PRC(424,AUDA,0))
QUIT
SET X(1)=0
+4 ;add record in file 424.1 and edit balance in file 442
+5 DO LREC^PRCEAU0
if $DATA(^PRC(424,AUDA,0))
SET PRC424=AUDA
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 CP/Fiscal.."
DO MSG^PRCFQ
QUIT
AMTDEL SET DA=AUDA
SET DIK="^PRC(424,"
DO ^DIK
QUIT
