- PRCEAU0 ;WISC/LDB/BGJ-CREATE/EDIT AUTHORIZATION-CONTROL POINTS CONT. ; 07/08/93 12:03 PM
- V ;;5.1;IFCAP;**23**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- BUL ;called from PRCEAU,PRCEDRE/DRE1 to alert control about remaining balance
- Q:$P($G(^PRC(424,+$G(AUDA),0)),"^",5)=""
- ; send bulletin, if remaining balance minus daily entry is
- ; smaller than 5% of the 1358 obligated balance.
- I $P(^PRC(424,+AUDA,0),U,5)-Y<($P(BAL,U)*.05) D EN^PRCEBL
- Q
- DEL ;delete or retain when uparrow entered
- S DIR(0)="YO",DIR("A")="Would you like to DELETE this authorization",DIR("B")="YES",DIR("?")="press <RETURN> to delete this entry, enter NO or '^' to retain entry" D ^DIR
- I Y["^"!(Y=0) Q
- D WAIT^PRCFYN
- S DA=AUDA,DIK="^PRC(424," D ^DIK S X="--- Entry Deleted ---*" D MSG^PRCFQ
- S BAL1=-$G(BAL1) D BALUP^PRCH58(PODA,BAL1) S X="--- Obligation balances updated ---" D MSG^PRCFQ
- Q
- HLP ;help response for the reader
- W !,"Enter the corresponding number for the action you want to take.",!,"You can select one or more items from the list provided."
- W !,"ZEROing out an authorization will mark the authorization as complete and return any monies left over to the obligation."
- W !,"The numbers can be seperated by commas, dashes or combination of",!,"both. i.e. 1,2,3,4 or 1-4 or 1-3,4."
- Q
- LREC ;Called from PRCEAU to enter 424.1 entry
- L +^PRC(424,AUDA,0):3 E S X(1)=X(1)+1 G:(X(1)<4) LREC I X(1)>3 S X="Someone else is editing this authorization. Try later." D MSG^PRCFQ,AMTDEL^PRCEAU Q
- DREC S DIC="^PRC(424.1,",DIC(0)="LX",DLAYGO=424.1,X=AUDA0,X=""""_X_"-"_0_"""" D ^DIC
- I Y<0 S X="The daily record entry cannot be entered. Please see the Application Coordinator." D MSG^PRCFQ,AMTDEL^PRCEAU
- I '$P(Y,U,3) S X1=X1+100 G DREC
- L -^PRC(424,AUDA,0)
- F L +^PRC(424.1,+Y,0):1 I Q
- S DIE="^PRC(424.1,",DA=+Y,DR=".011////^S X=""AU"";.02////^S X=AUDA;.03////^S X=BAL1;.04////^S X=TIME;.05////^S X=DUZ;.08////^S X=""ORIGINAL AMOUNT"";.1////^S X=DUZ" D ^DIE
- L -^PRC(424.1,DA,0)
- D BALUP^PRCH58(PODA,BAL1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEAU0 2069 printed Feb 18, 2025@23:27:39 Page 2
- PRCEAU0 ;WISC/LDB/BGJ-CREATE/EDIT AUTHORIZATION-CONTROL POINTS CONT. ; 07/08/93 12:03 PM
- V ;;5.1;IFCAP;**23**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- BUL ;called from PRCEAU,PRCEDRE/DRE1 to alert control about remaining balance
- +1 if $PIECE($GET(^PRC(424,+$GET(AUDA),0)),"^",5)=""
- QUIT
- +2 ; send bulletin, if remaining balance minus daily entry is
- +3 ; smaller than 5% of the 1358 obligated balance.
- +4 IF $PIECE(^PRC(424,+AUDA,0),U,5)-Y<($PIECE(BAL,U)*.05)
- DO EN^PRCEBL
- +5 QUIT
- DEL ;delete or retain when uparrow entered
- +1 SET DIR(0)="YO"
- SET DIR("A")="Would you like to DELETE this authorization"
- SET DIR("B")="YES"
- SET DIR("?")="press <RETURN> to delete this entry, enter NO or '^' to retain entry"
- DO ^DIR
- +2 IF Y["^"!(Y=0)
- QUIT
- +3 DO WAIT^PRCFYN
- +4 SET DA=AUDA
- SET DIK="^PRC(424,"
- DO ^DIK
- SET X="--- Entry Deleted ---*"
- DO MSG^PRCFQ
- +5 SET BAL1=-$GET(BAL1)
- DO BALUP^PRCH58(PODA,BAL1)
- SET X="--- Obligation balances updated ---"
- DO MSG^PRCFQ
- +6 QUIT
- HLP ;help response for the reader
- +1 WRITE !,"Enter the corresponding number for the action you want to take.",!,"You can select one or more items from the list provided."
- +2 WRITE !,"ZEROing out an authorization will mark the authorization as complete and return any monies left over to the obligation."
- +3 WRITE !,"The numbers can be seperated by commas, dashes or combination of",!,"both. i.e. 1,2,3,4 or 1-4 or 1-3,4."
- +4 QUIT
- LREC ;Called from PRCEAU to enter 424.1 entry
- +1 LOCK +^PRC(424,AUDA,0):3
- IF '$TEST
- SET X(1)=X(1)+1
- if (X(1)<4)
- GOTO LREC
- IF X(1)>3
- SET X="Someone else is editing this authorization. Try later."
- DO MSG^PRCFQ
- DO AMTDEL^PRCEAU
- QUIT
- DREC SET DIC="^PRC(424.1,"
- SET DIC(0)="LX"
- SET DLAYGO=424.1
- SET X=AUDA0
- SET X=""""_X_"-"_0_""""
- DO ^DIC
- +1 IF Y<0
- SET X="The daily record entry cannot be entered. Please see the Application Coordinator."
- DO MSG^PRCFQ
- DO AMTDEL^PRCEAU
- +2 IF '$PIECE(Y,U,3)
- SET X1=X1+100
- GOTO DREC
- +3 LOCK -^PRC(424,AUDA,0)
- +4 FOR
- LOCK +^PRC(424.1,+Y,0):1
- IF $TEST
- QUIT
- +5 SET DIE="^PRC(424.1,"
- SET DA=+Y
- SET DR=".011////^S X=""AU"";.02////^S X=AUDA;.03////^S X=BAL1;.04////^S X=TIME;.05////^S X=DUZ;.08////^S X=""ORIGINAL AMOUNT"";.1////^S X=DUZ"
- DO ^DIE
- +6 LOCK -^PRC(424.1,DA,0)
- +7 DO BALUP^PRCH58(PODA,BAL1)
- +8 QUIT