PRCAWO1 ;SF-ISC/YJK-ADMIN.COST CHARGE,TRANSACTION SUBROUTINES ;7/9/93 12:18 PM
V ;;4.5;Accounts Receivable;**67,68,153,315,377,371,420**;Mar 20, 1995;Build 1
;;Per VA Directive 6402, this routine should not be modified.
;Administrative cost charge transaction
; and subroutines called by ^PRCAWO.
;
EN1 ;Administrative cost charge
D BEGIN^PRCAWO G:('$D(PRCAEN))!('$D(PRCABN)) END1 D DIEEN,KILLV G EN1
DIEEN ;Loop through edit
I $D(^PRCA(430,"TCSP",PRCABN)) S RCTRREV=$$ASKREV() W ! ;315/DRF
S DIC="^PRCA(433,",DIE=DIC,DR="[PRCAE ADMIN]",DA=PRCAEN
S DIC=DIE,PRCA("LOCK")=0 D LOCKF Q:PRCA("LOCK")=1 D ^DIE
I '$D(^PRCA(433,PRCAEN,2)) D DELETE Q
S PRCADM=+$P(^PRCA(433,PRCAEN,2),U,1)+$P(^(2),U,2)+$P(^(2),U,3)+$P(^(2),U,4)+$P(^(2),U,8)+$P(^(2),U,9),$P(^PRCA(433,PRCAEN,1),U,5)=PRCADM+$P(^(2),U,5)+$P(^(2),U,6)+$P(^(2),U,7)
D DIP S PRCAOK=0 D ASK1 I $D(PRCA("EXIT")) D DELETE Q
I $D(PRCASUP),PRCAOK=1,$G(^PRCA(433,PRCAEN,2))["-" D I $D(PRCA("EXIT")) D DELETE Q
.N ND2,ND7,I,J,K
.S ND2=$G(^PRCA(433,PRCAEN,2)),ND7=$G(^PRCA(430,PRCABN,7))
.I PRCADM<0,-PRCADM>$P(ND7,U,3) D MSG Q
.F I=5:1:7 I $P(ND2,U,I)<0 D I $D(PRCA("EXIT")) Q
..S J=$P(ND2,U,I)
..S K=$S(I=5:4,I=6:5,1:2)
..I -J>$P(ND7,U,K) D MSG
..Q
.Q
I PRCAOK=1 D UPD W ?40,"*** DONE***",! Q
D ASK2 G:PRCAOK=1 DIEEN D DELETE Q
UPD ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
N BILL,PRCFDA
S PRCAMF=$S($P(^PRCA(433,PRCAEN,2),U,5)]"":+$P(^(2),U,5),1:0)
S PRCFDA(430,PRCABN_",",74)=PRCAMF+$P(^PRCA(430,PRCABN,7),U,4)
S PRCACC=$S(+$P(^PRCA(433,PRCAEN,2),U,6)]"":+$P(^(2),U,6),1:0)
S PRCFDA(430,PRCABN_",",75)=PRCACC+$P(^PRCA(430,PRCABN,7),U,5)
S PRCFDA(430,PRCABN_",",73)=+PRCADM+$P(^PRCA(430,PRCABN,7),U,3)
S PRCFDA(430,PRCABN_",",72)=+$P(^PRCA(433,PRCAEN,2),U,7)+$P(^PRCA(430,PRCABN,7),U,2)
D FILE^DIE(,"PRCFDA"),TRANST
;
;PRCA*4.5*377
; Update the Repayment Plan if the bill is associated with an active plan
D UPDBAL^RCRPU1(PRCABN,PRCAEN)
;
I $D(^PRCA(430,"TCSP",PRCABN)),PRCAEN D ;PRCA*4.5*315/DRF add cs increase adjustment
. S BILL=PRCABN ; used in ^RCTCSPD5 PRCA*4.5*420
. I $G(RCTRREV)=0 D CSATRN^RCTCSPD5
. I $G(RCTRREV)=0 D INCADJ^RCTCSPU(PRCABN,PRCAEN)
. I $G(RCTRREV)=1 D CSATRY^RCTCSPD5
;
KILLV ;
END1 K PRCA,PRCADM,PRCAOK,%,PRCACC,PRCAMF,PRCA1,PRCA2,PRCAEN,PRCABN,PRCATYPE,PRCATY,RCTRREV Q
;
MSG W !!,*7,"INVALID AMOUNTS ENTERED."
S PRCA("EXIT")="" Q
DIP K DXS S D0=PRCAEN D ^PRCATO3 K DXS Q
ASK1 S %=2 W !!,"Is this correct" D YN^DICN I %<0 S PRCA("EXIT")="" Q
I %=0 W !,"Answer 'Y' or 'YES' if the data is correct, answer 'N' or 'NO' if not",! G ASK1
S:%=1 PRCAOK=1 Q
ASK2 S %=2 W !!,"Do you want to edit" D YN^DICN I %<0 S PRCA("EXIT")="" Q
I %=0 W !,"Answer 'Y' or 'YES' if you want to edit the data, answer 'N' or 'NO' if you do not want to edit the data",! G ASK2
S:%=1 PRCAOK=1 Q
;======================SUBROUTINE DIE=============================
;this is called by ^PRCAWO.
DIE1 ;update the current status in the file 430.
S DIE="^PRCA(430,",DA=PRCABN,DR="8///"_PRCA("STATUS")_";" D ^DIE
K DIC,DA,DR Q ;end of DIE1
;
TRANST Q:'$D(PRCAEN) S $P(^PRCA(433,PRCAEN,0),U,4)=2 Q
;========================SUBROUTINE DELETE============================
DELETE ;Deletes an entry but leaves an audit trail
; Requires PRCABN=Bill #
; PRCAEN=Transaction to Delete
; PRCAARC=True if archiving this trans
; PRCANOPR=True if no message should be printed to screen
; PRCACOMM=Reason why this transaction is being deleted
; PRCAMAN=True if IRM is manually calling this API
NEW X,DINUM,DD,DIC,DLAYGO,DO,DIK,DIE,DA,T0,T5,FLAG
S FLAG=0
;Check for previous audit trail
S T0=$G(^PRCA(433,PRCAEN,0)),T5=$G(^PRCA(433,PRCAEN,5)) I 'T0 Q
I $P(T0,U,4)=1,$P(T0,U,10)=1,($P(T5,U,2)["SYSTEM INACTIVATED"!($P(T5,U,2)["SYSTEM ARCHIVED")) S FLAG=1 D
.I $G(PRCAMAN) W !,"You are attempting to delete a record that already appears to have been deleted and contains an audit trail. Delete failed!"
I FLAG Q
S PRCATYPE=$P($G(^PRCA(433,PRCAEN,1)),U,2)
S:'$D(PRCACOMM) PRCACOMM="USER CANCELED"
S:'$D(PRCABN) PRCABN=$P($G(^PRCA(433,PRCAEN,0)),U,2)
S DIK="^PRCA(433,",DA=PRCAEN D ^DIK K DIK
;
; Now Create the stub full of audit trails...
; Trans#(.01), Trans Status(4), Brief Comment(5.02), Comments(41),
; Inc. Trans Flag(10), Trans Date(11), Trans Type(12), Proc. By(42)
S (X,DINUM)=PRCAEN,DIC="^PRCA(433,",DIC(0)="L",DLAYGO=433
K DD,DO D FILE^DICN K DIC,DLAYGO,DO
;
; Ensure the 'last transaction' counter is accurate
S $P(^PRCA(433,0),U,3)=$O(^PRCA(433,"A"),-1)
;
S DIE="^PRCA(433,",DR="[PRCA CREATE TRANS STUB]",DA=PRCAEN D ^DIE
W:'$G(PRCANOPR) !,*7," NOTHING CHANGED !",!!
S PRCAD("DELETE")="" K PRCANOPR,%,%DT,%X,%Y
Q
;======================SUBROUTINE LOCKF================================
LOCKF L @("+"_DIC_DA_"):1") I '$T W !,*7,"ANOTHER USER IS EDITING THIS ENTRY , TRY LATER.",! S PRCA("LOCK")=1
Q ;end of LOCKF
END K PRCA,PRCABN,PRCAEN,PRCAPREV,PRCATYPE,DIE,DIC,PRCAMF,PRCACC,A Q
;
ASKREV() ; Ask if Treasury reversal 315/DRF
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Is this a TREASURY reversal "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAWO1 5434 printed Dec 13, 2024@01:42:05 Page 2
PRCAWO1 ;SF-ISC/YJK-ADMIN.COST CHARGE,TRANSACTION SUBROUTINES ;7/9/93 12:18 PM
V ;;4.5;Accounts Receivable;**67,68,153,315,377,371,420**;Mar 20, 1995;Build 1
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;Administrative cost charge transaction
+3 ; and subroutines called by ^PRCAWO.
+4 ;
EN1 ;Administrative cost charge
+1 DO BEGIN^PRCAWO
if ('$DATA(PRCAEN))!('$DATA(PRCABN))
GOTO END1
DO DIEEN
DO KILLV
GOTO EN1
DIEEN ;Loop through edit
+1 ;315/DRF
IF $DATA(^PRCA(430,"TCSP",PRCABN))
SET RCTRREV=$$ASKREV()
WRITE !
+2 SET DIC="^PRCA(433,"
SET DIE=DIC
SET DR="[PRCAE ADMIN]"
SET DA=PRCAEN
+3 SET DIC=DIE
SET PRCA("LOCK")=0
DO LOCKF
if PRCA("LOCK")=1
QUIT
DO ^DIE
+4 IF '$DATA(^PRCA(433,PRCAEN,2))
DO DELETE
QUIT
+5 SET PRCADM=+$PIECE(^PRCA(433,PRCAEN,2),U,1)+$PIECE(^(2),U,2)+$PIECE(^(2),U,3)+$PIECE(^(2),U,4)+$PIECE(^(2),U,8)+$PIECE(^(2),U,9)
SET $PIECE(^PRCA(433,PRCAEN,1),U,5)=PRCADM+$PIECE(^(2),U,5)+$PIECE(^(2),U,6)+$PIECE(^(2),U,7)
+6 DO DIP
SET PRCAOK=0
DO ASK1
IF $DATA(PRCA("EXIT"))
DO DELETE
QUIT
+7 IF $DATA(PRCASUP)
IF PRCAOK=1
IF $GET(^PRCA(433,PRCAEN,2))["-"
Begin DoDot:1
+8 NEW ND2,ND7,I,J,K
+9 SET ND2=$GET(^PRCA(433,PRCAEN,2))
SET ND7=$GET(^PRCA(430,PRCABN,7))
+10 IF PRCADM<0
IF -PRCADM>$PIECE(ND7,U,3)
DO MSG
QUIT
+11 FOR I=5:1:7
IF $PIECE(ND2,U,I)<0
Begin DoDot:2
+12 SET J=$PIECE(ND2,U,I)
+13 SET K=$SELECT(I=5:4,I=6:5,1:2)
+14 IF -J>$PIECE(ND7,U,K)
DO MSG
+15 QUIT
End DoDot:2
IF $DATA(PRCA("EXIT"))
QUIT
+16 QUIT
End DoDot:1
IF $DATA(PRCA("EXIT"))
DO DELETE
QUIT
+17 IF PRCAOK=1
DO UPD
WRITE ?40,"*** DONE***",!
QUIT
+18 DO ASK2
if PRCAOK=1
GOTO DIEEN
DO DELETE
QUIT
UPD ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+1 NEW BILL,PRCFDA
+2 SET PRCAMF=$SELECT($PIECE(^PRCA(433,PRCAEN,2),U,5)]"":+$PIECE(^(2),U,5),1:0)
+3 SET PRCFDA(430,PRCABN_",",74)=PRCAMF+$PIECE(^PRCA(430,PRCABN,7),U,4)
+4 SET PRCACC=$SELECT(+$PIECE(^PRCA(433,PRCAEN,2),U,6)]"":+$PIECE(^(2),U,6),1:0)
+5 SET PRCFDA(430,PRCABN_",",75)=PRCACC+$PIECE(^PRCA(430,PRCABN,7),U,5)
+6 SET PRCFDA(430,PRCABN_",",73)=+PRCADM+$PIECE(^PRCA(430,PRCABN,7),U,3)
+7 SET PRCFDA(430,PRCABN_",",72)=+$PIECE(^PRCA(433,PRCAEN,2),U,7)+$PIECE(^PRCA(430,PRCABN,7),U,2)
+8 DO FILE^DIE(,"PRCFDA")
DO TRANST
+9 ;
+10 ;PRCA*4.5*377
+11 ; Update the Repayment Plan if the bill is associated with an active plan
+12 DO UPDBAL^RCRPU1(PRCABN,PRCAEN)
+13 ;
+14 ;PRCA*4.5*315/DRF add cs increase adjustment
IF $DATA(^PRCA(430,"TCSP",PRCABN))
IF PRCAEN
Begin DoDot:1
+15 ; used in ^RCTCSPD5 PRCA*4.5*420
SET BILL=PRCABN
+16 IF $GET(RCTRREV)=0
DO CSATRN^RCTCSPD5
+17 IF $GET(RCTRREV)=0
DO INCADJ^RCTCSPU(PRCABN,PRCAEN)
+18 IF $GET(RCTRREV)=1
DO CSATRY^RCTCSPD5
End DoDot:1
+19 ;
KILLV ;
END1 KILL PRCA,PRCADM,PRCAOK,%,PRCACC,PRCAMF,PRCA1,PRCA2,PRCAEN,PRCABN,PRCATYPE,PRCATY,RCTRREV
QUIT
+1 ;
MSG WRITE !!,*7,"INVALID AMOUNTS ENTERED."
+1 SET PRCA("EXIT")=""
QUIT
DIP KILL DXS
SET D0=PRCAEN
DO ^PRCATO3
KILL DXS
QUIT
ASK1 SET %=2
WRITE !!,"Is this correct"
DO YN^DICN
IF %<0
SET PRCA("EXIT")=""
QUIT
+1 IF %=0
WRITE !,"Answer 'Y' or 'YES' if the data is correct, answer 'N' or 'NO' if not",!
GOTO ASK1
+2 if %=1
SET PRCAOK=1
QUIT
ASK2 SET %=2
WRITE !!,"Do you want to edit"
DO YN^DICN
IF %<0
SET PRCA("EXIT")=""
QUIT
+1 IF %=0
WRITE !,"Answer 'Y' or 'YES' if you want to edit the data, answer 'N' or 'NO' if you do not want to edit the data",!
GOTO ASK2
+2 if %=1
SET PRCAOK=1
QUIT
+3 ;======================SUBROUTINE DIE=============================
+4 ;this is called by ^PRCAWO.
DIE1 ;update the current status in the file 430.
+1 SET DIE="^PRCA(430,"
SET DA=PRCABN
SET DR="8///"_PRCA("STATUS")_";"
DO ^DIE
+2 ;end of DIE1
KILL DIC,DA,DR
QUIT
+3 ;
TRANST if '$DATA(PRCAEN)
QUIT
SET $PIECE(^PRCA(433,PRCAEN,0),U,4)=2
QUIT
+1 ;========================SUBROUTINE DELETE============================
DELETE ;Deletes an entry but leaves an audit trail
+1 ; Requires PRCABN=Bill #
+2 ; PRCAEN=Transaction to Delete
+3 ; PRCAARC=True if archiving this trans
+4 ; PRCANOPR=True if no message should be printed to screen
+5 ; PRCACOMM=Reason why this transaction is being deleted
+6 ; PRCAMAN=True if IRM is manually calling this API
+7 NEW X,DINUM,DD,DIC,DLAYGO,DO,DIK,DIE,DA,T0,T5,FLAG
+8 SET FLAG=0
+9 ;Check for previous audit trail
+10 SET T0=$GET(^PRCA(433,PRCAEN,0))
SET T5=$GET(^PRCA(433,PRCAEN,5))
IF 'T0
QUIT
+11 IF $PIECE(T0,U,4)=1
IF $PIECE(T0,U,10)=1
IF ($PIECE(T5,U,2)["SYSTEM INACTIVATED"!($PIECE(T5,U,2)["SYSTEM ARCHIVED"))
SET FLAG=1
Begin DoDot:1
+12 IF $GET(PRCAMAN)
WRITE !,"You are attempting to delete a record that already appears to have been deleted and contains an audit trail. Delete failed!"
End DoDot:1
+13 IF FLAG
QUIT
+14 SET PRCATYPE=$PIECE($GET(^PRCA(433,PRCAEN,1)),U,2)
+15 if '$DATA(PRCACOMM)
SET PRCACOMM="USER CANCELED"
+16 if '$DATA(PRCABN)
SET PRCABN=$PIECE($GET(^PRCA(433,PRCAEN,0)),U,2)
+17 SET DIK="^PRCA(433,"
SET DA=PRCAEN
DO ^DIK
KILL DIK
+18 ;
+19 ; Now Create the stub full of audit trails...
+20 ; Trans#(.01), Trans Status(4), Brief Comment(5.02), Comments(41),
+21 ; Inc. Trans Flag(10), Trans Date(11), Trans Type(12), Proc. By(42)
+22 SET (X,DINUM)=PRCAEN
SET DIC="^PRCA(433,"
SET DIC(0)="L"
SET DLAYGO=433
+23 KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO,DO
+24 ;
+25 ; Ensure the 'last transaction' counter is accurate
+26 SET $PIECE(^PRCA(433,0),U,3)=$ORDER(^PRCA(433,"A"),-1)
+27 ;
+28 SET DIE="^PRCA(433,"
SET DR="[PRCA CREATE TRANS STUB]"
SET DA=PRCAEN
DO ^DIE
+29 if '$GET(PRCANOPR)
WRITE !,*7," NOTHING CHANGED !",!!
+30 SET PRCAD("DELETE")=""
KILL PRCANOPR,%,%DT,%X,%Y
+31 QUIT
+32 ;======================SUBROUTINE LOCKF================================
LOCKF LOCK @("+"_DIC_DA_"):1")
IF '$TEST
WRITE !,*7,"ANOTHER USER IS EDITING THIS ENTRY , TRY LATER.",!
SET PRCA("LOCK")=1
+1 ;end of LOCKF
QUIT
END KILL PRCA,PRCABN,PRCAEN,PRCAPREV,PRCATYPE,DIE,DIC,PRCAMF,PRCACC,A
QUIT
+1 ;
ASKREV() ; Ask if Treasury reversal 315/DRF
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="NO"
+3 SET DIR("A")=" Is this a TREASURY reversal "
+4 WRITE !
DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
