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