- 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 Jan 18, 2025@02:43:19 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