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