Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCAWO1

PRCAWO1.m

Go to the documentation of this file.
  1. PRCAWO1 ;SF-ISC/YJK-ADMIN.COST CHARGE,TRANSACTION SUBROUTINES ;7/9/93 12:18 PM
  1. 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.
  1. ;Administrative cost charge transaction
  1. ; and subroutines called by ^PRCAWO.
  1. ;
  1. EN1 ;Administrative cost charge
  1. D BEGIN^PRCAWO G:('$D(PRCAEN))!('$D(PRCABN)) END1 D DIEEN,KILLV G EN1
  1. DIEEN ;Loop through edit
  1. I $D(^PRCA(430,"TCSP",PRCABN)) S RCTRREV=$$ASKREV() W ! ;315/DRF
  1. S DIC="^PRCA(433,",DIE=DIC,DR="[PRCAE ADMIN]",DA=PRCAEN
  1. S DIC=DIE,PRCA("LOCK")=0 D LOCKF Q:PRCA("LOCK")=1 D ^DIE
  1. I '$D(^PRCA(433,PRCAEN,2)) D DELETE Q
  1. 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)
  1. D DIP S PRCAOK=0 D ASK1 I $D(PRCA("EXIT")) D DELETE Q
  1. I $D(PRCASUP),PRCAOK=1,$G(^PRCA(433,PRCAEN,2))["-" D I $D(PRCA("EXIT")) D DELETE Q
  1. .N ND2,ND7,I,J,K
  1. .S ND2=$G(^PRCA(433,PRCAEN,2)),ND7=$G(^PRCA(430,PRCABN,7))
  1. .I PRCADM<0,-PRCADM>$P(ND7,U,3) D MSG Q
  1. .F I=5:1:7 I $P(ND2,U,I)<0 D I $D(PRCA("EXIT")) Q
  1. ..S J=$P(ND2,U,I)
  1. ..S K=$S(I=5:4,I=6:5,1:2)
  1. ..I -J>$P(ND7,U,K) D MSG
  1. ..Q
  1. .Q
  1. I PRCAOK=1 D UPD W ?40,"*** DONE***",! Q
  1. D ASK2 G:PRCAOK=1 DIEEN D DELETE Q
  1. UPD ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
  1. N BILL,PRCFDA
  1. S PRCAMF=$S($P(^PRCA(433,PRCAEN,2),U,5)]"":+$P(^(2),U,5),1:0)
  1. S PRCFDA(430,PRCABN_",",74)=PRCAMF+$P(^PRCA(430,PRCABN,7),U,4)
  1. S PRCACC=$S(+$P(^PRCA(433,PRCAEN,2),U,6)]"":+$P(^(2),U,6),1:0)
  1. S PRCFDA(430,PRCABN_",",75)=PRCACC+$P(^PRCA(430,PRCABN,7),U,5)
  1. S PRCFDA(430,PRCABN_",",73)=+PRCADM+$P(^PRCA(430,PRCABN,7),U,3)
  1. S PRCFDA(430,PRCABN_",",72)=+$P(^PRCA(433,PRCAEN,2),U,7)+$P(^PRCA(430,PRCABN,7),U,2)
  1. D FILE^DIE(,"PRCFDA"),TRANST
  1. ;
  1. ;PRCA*4.5*377
  1. ; Update the Repayment Plan if the bill is associated with an active plan
  1. D UPDBAL^RCRPU1(PRCABN,PRCAEN)
  1. ;
  1. I $D(^PRCA(430,"TCSP",PRCABN)),PRCAEN D ;PRCA*4.5*315/DRF add cs increase adjustment
  1. . S BILL=PRCABN ; used in ^RCTCSPD5 PRCA*4.5*420
  1. . I $G(RCTRREV)=0 D CSATRN^RCTCSPD5
  1. . I $G(RCTRREV)=0 D INCADJ^RCTCSPU(PRCABN,PRCAEN)
  1. . I $G(RCTRREV)=1 D CSATRY^RCTCSPD5
  1. ;
  1. KILLV ;
  1. END1 K PRCA,PRCADM,PRCAOK,%,PRCACC,PRCAMF,PRCA1,PRCA2,PRCAEN,PRCABN,PRCATYPE,PRCATY,RCTRREV Q
  1. ;
  1. MSG W !!,*7,"INVALID AMOUNTS ENTERED."
  1. S PRCA("EXIT")="" Q
  1. DIP K DXS S D0=PRCAEN D ^PRCATO3 K DXS Q
  1. ASK1 S %=2 W !!,"Is this correct" D YN^DICN I %<0 S PRCA("EXIT")="" Q
  1. I %=0 W !,"Answer 'Y' or 'YES' if the data is correct, answer 'N' or 'NO' if not",! G ASK1
  1. S:%=1 PRCAOK=1 Q
  1. ASK2 S %=2 W !!,"Do you want to edit" D YN^DICN I %<0 S PRCA("EXIT")="" Q
  1. 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
  1. S:%=1 PRCAOK=1 Q
  1. ;======================SUBROUTINE DIE=============================
  1. ;this is called by ^PRCAWO.
  1. DIE1 ;update the current status in the file 430.
  1. S DIE="^PRCA(430,",DA=PRCABN,DR="8///"_PRCA("STATUS")_";" D ^DIE
  1. K DIC,DA,DR Q ;end of DIE1
  1. ;
  1. TRANST Q:'$D(PRCAEN) S $P(^PRCA(433,PRCAEN,0),U,4)=2 Q
  1. ;========================SUBROUTINE DELETE============================
  1. DELETE ;Deletes an entry but leaves an audit trail
  1. ; Requires PRCABN=Bill #
  1. ; PRCAEN=Transaction to Delete
  1. ; PRCAARC=True if archiving this trans
  1. ; PRCANOPR=True if no message should be printed to screen
  1. ; PRCACOMM=Reason why this transaction is being deleted
  1. ; PRCAMAN=True if IRM is manually calling this API
  1. NEW X,DINUM,DD,DIC,DLAYGO,DO,DIK,DIE,DA,T0,T5,FLAG
  1. S FLAG=0
  1. ;Check for previous audit trail
  1. S T0=$G(^PRCA(433,PRCAEN,0)),T5=$G(^PRCA(433,PRCAEN,5)) I 'T0 Q
  1. 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
  1. .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!"
  1. I FLAG Q
  1. S PRCATYPE=$P($G(^PRCA(433,PRCAEN,1)),U,2)
  1. S:'$D(PRCACOMM) PRCACOMM="USER CANCELED"
  1. S:'$D(PRCABN) PRCABN=$P($G(^PRCA(433,PRCAEN,0)),U,2)
  1. S DIK="^PRCA(433,",DA=PRCAEN D ^DIK K DIK
  1. ;
  1. ; Now Create the stub full of audit trails...
  1. ; Trans#(.01), Trans Status(4), Brief Comment(5.02), Comments(41),
  1. ; Inc. Trans Flag(10), Trans Date(11), Trans Type(12), Proc. By(42)
  1. S (X,DINUM)=PRCAEN,DIC="^PRCA(433,",DIC(0)="L",DLAYGO=433
  1. K DD,DO D FILE^DICN K DIC,DLAYGO,DO
  1. ;
  1. ; Ensure the 'last transaction' counter is accurate
  1. S $P(^PRCA(433,0),U,3)=$O(^PRCA(433,"A"),-1)
  1. ;
  1. S DIE="^PRCA(433,",DR="[PRCA CREATE TRANS STUB]",DA=PRCAEN D ^DIE
  1. W:'$G(PRCANOPR) !,*7," NOTHING CHANGED !",!!
  1. S PRCAD("DELETE")="" K PRCANOPR,%,%DT,%X,%Y
  1. Q
  1. ;======================SUBROUTINE LOCKF================================
  1. LOCKF L @("+"_DIC_DA_"):1") I '$T W !,*7,"ANOTHER USER IS EDITING THIS ENTRY , TRY LATER.",! S PRCA("LOCK")=1
  1. Q ;end of LOCKF
  1. END K PRCA,PRCABN,PRCAEN,PRCAPREV,PRCATYPE,DIE,DIC,PRCAMF,PRCACC,A Q
  1. ;
  1. ASKREV() ; Ask if Treasury reversal 315/DRF
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="NO"
  1. S DIR("A")=" Is this a TREASURY reversal "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y