RCKATPD ;ALB/CPM/TJK - ADJUST ACCOUNTS FOR KATRINA VETS (CON'T);Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**241,371**;Mar 20, 1995;Build 29
;;Per VHA Directive 6402, this routine should not be modified.
Q
;
;
EN(ACCT,BUCKET,RCMSG) ; Entry point to credit an account for a Katrina vet
; Input: ACCT -- value of .01 field for debtor in file 340
; BUCKET -- Amount to credit the account
; RCMSG -- Bill or transaction comment
;
N DFN,RCDEBTDA,RCCOM
S DFN=+ACCT,RCDEBTDA=$$DEBT^RCEVUTL(ACCT)
I 'DFN!($G(^DPT(DFN,0))="") Q
K ^TMP($J)
N BILL,B0,OLDBAL,PREPAY,TRAN,TDATE,T0,T1,TRAMT,X,TTYPE,STATUS,BN7
N DECAMT,EXTOT,I,PRCAEN,DIC,DIE,DA,DR,MSG,PERROR,NBILL,NTRAN,MSGCNTS,ERR
S PREPAY=$O(^PRCA(430.2,"B","PREPAYMENT",0)),RCCOM(1)=RCMSG
F STATUS=16,42 S BILL=0 F S BILL=$O(^PRCA(430,"AS",RCDEBTDA,STATUS,BILL)) Q:'BILL!'BUCKET D PROC,APPLY:OLDBAL
D REFUND:BUCKET
S ERR=$G(PERROR) K ^TMP($J)
Q
;
PROC ; Determine the bill's balance
S B0=$G(^PRCA(430,BILL,0)),BN7=$G(^(7))
S OLDBAL=0 F I=1:1:5 S OLDBAL=OLDBAL+$P(BN7,U,I)
Q
;
APPLY ; Exempt interest and decrease a bill
S EXTOT=0 F I=2:1:5 S EXTOT=EXTOT+$P(BN7,U,I)
;
; - interest balance is zero - do a decrease
G DEC:'EXTOT
;
S TRAMT=0 S:EXTOT'<BUCKET EXTOT=BUCKET
INT F I=5:-1:2 Q:'EXTOT I $P(BN7,U,I) D
.S X=$P(BN7,U,I),DECAMT=$S(X>BUCKET:BUCKET,1:X)
.S $P(BN7,U,I)=$P(BN7,U,I)-DECAMT,BUCKET=BUCKET-DECAMT
.S EXTOT=EXTOT-DECAMT,TRAMT=TRAMT+DECAMT
S OLDBAL=OLDBAL-TRAMT
;
; - create exemption transaction
D SETTR^PRCAUTL
S TTYPE=14,DIE="^PRCA(433,",DA=PRCAEN
S DR=".03////"_BILL_";11////"_DT_";12////"_TTYPE_";15///"_TRAMT_";41///"_RCMSG_";89///1;4///2"
S DIC=DIE D ^DIE
K DA,DIC,DIE,DR,TRAMT
;
; - update the balance of the bill
; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
N RCFDA S RCFDA(430,BILL_",",72)=$P(BN7,U,2),RCFDA(430,BILL_",",73)=$P(BN7,U,3),RCFDA(430,BILL_",",74)=$P(BN7,U,4),RCFDA(430,BILL_",",75)=$P(BN7,U,5)
D FILE^DIE(,"RCFDA")
;
; - if the bill was decreased by its entire balance, set the
; bill status to Cancellation
I 'OLDBAL D CHGSTAT^RCBEUBIL(BILL,39),ADDCOMM^RCBEUBIL(BILL,.RCCOM) Q
;
; - no need for decrease if the amount to credit the account is zero
Q:'BUCKET
;
DEC ; - create a decrease adjustment
S PRCAEN=0,DECAMT=BUCKET
D DEC^PRCASER1(BILL,.DECAMT,DUZ,RCMSG,"",.PRCAEN)
S BUCKET=DECAMT
Q
;
;
REFUND ; Create a prepayment in an Open status
S PERROR="" D EN^PRCAPAY3(DFN_";DPT(",BUCKET,DT,DUZ,"","","",.PERROR)
Q:PERROR]""
;
; - find the Open prepayment just increased to add a comment
S NBILL=0 F S NBILL=$O(^PRCA(430,"AS",RCDEBTDA,$O(^PRCA(430.3,"AC",112,0)),NBILL)) Q:'NBILL I $P(^PRCA(430,NBILL,0),U,2)=PREPAY Q
I NBILL D ADDCOMM^RCBEUBIL(NBILL,.RCCOM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCKATPD 2869 printed Apr 09, 2024@20:44:52 Page 2
RCKATPD ;ALB/CPM/TJK - ADJUST ACCOUNTS FOR KATRINA VETS (CON'T);Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**241,371**;Mar 20, 1995;Build 29
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
EN(ACCT,BUCKET,RCMSG) ; Entry point to credit an account for a Katrina vet
+1 ; Input: ACCT -- value of .01 field for debtor in file 340
+2 ; BUCKET -- Amount to credit the account
+3 ; RCMSG -- Bill or transaction comment
+4 ;
+5 NEW DFN,RCDEBTDA,RCCOM
+6 SET DFN=+ACCT
SET RCDEBTDA=$$DEBT^RCEVUTL(ACCT)
+7 IF 'DFN!($GET(^DPT(DFN,0))="")
QUIT
+8 KILL ^TMP($JOB)
+9 NEW BILL,B0,OLDBAL,PREPAY,TRAN,TDATE,T0,T1,TRAMT,X,TTYPE,STATUS,BN7
+10 NEW DECAMT,EXTOT,I,PRCAEN,DIC,DIE,DA,DR,MSG,PERROR,NBILL,NTRAN,MSGCNTS,ERR
+11 SET PREPAY=$ORDER(^PRCA(430.2,"B","PREPAYMENT",0))
SET RCCOM(1)=RCMSG
+12 FOR STATUS=16,42
SET BILL=0
FOR
SET BILL=$ORDER(^PRCA(430,"AS",RCDEBTDA,STATUS,BILL))
if 'BILL!'BUCKET
QUIT
DO PROC
if OLDBAL
DO APPLY
+13 if BUCKET
DO REFUND
+14 SET ERR=$GET(PERROR)
KILL ^TMP($JOB)
+15 QUIT
+16 ;
PROC ; Determine the bill's balance
+1 SET B0=$GET(^PRCA(430,BILL,0))
SET BN7=$GET(^(7))
+2 SET OLDBAL=0
FOR I=1:1:5
SET OLDBAL=OLDBAL+$PIECE(BN7,U,I)
+3 QUIT
+4 ;
APPLY ; Exempt interest and decrease a bill
+1 SET EXTOT=0
FOR I=2:1:5
SET EXTOT=EXTOT+$PIECE(BN7,U,I)
+2 ;
+3 ; - interest balance is zero - do a decrease
+4 if 'EXTOT
GOTO DEC
+5 ;
+6 SET TRAMT=0
if EXTOT'<BUCKET
SET EXTOT=BUCKET
INT FOR I=5:-1:2
if 'EXTOT
QUIT
IF $PIECE(BN7,U,I)
Begin DoDot:1
+1 SET X=$PIECE(BN7,U,I)
SET DECAMT=$SELECT(X>BUCKET:BUCKET,1:X)
+2 SET $PIECE(BN7,U,I)=$PIECE(BN7,U,I)-DECAMT
SET BUCKET=BUCKET-DECAMT
+3 SET EXTOT=EXTOT-DECAMT
SET TRAMT=TRAMT+DECAMT
End DoDot:1
+4 SET OLDBAL=OLDBAL-TRAMT
+5 ;
+6 ; - create exemption transaction
+7 DO SETTR^PRCAUTL
+8 SET TTYPE=14
SET DIE="^PRCA(433,"
SET DA=PRCAEN
+9 SET DR=".03////"_BILL_";11////"_DT_";12////"_TTYPE_";15///"_TRAMT_";41///"_RCMSG_";89///1;4///2"
+10 SET DIC=DIE
DO ^DIE
+11 KILL DA,DIC,DIE,DR,TRAMT
+12 ;
+13 ; - update the balance of the bill
+14 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+15 NEW RCFDA
SET RCFDA(430,BILL_",",72)=$PIECE(BN7,U,2)
SET RCFDA(430,BILL_",",73)=$PIECE(BN7,U,3)
SET RCFDA(430,BILL_",",74)=$PIECE(BN7,U,4)
SET RCFDA(430,BILL_",",75)=$PIECE(BN7,U,5)
+16 DO FILE^DIE(,"RCFDA")
+17 ;
+18 ; - if the bill was decreased by its entire balance, set the
+19 ; bill status to Cancellation
+20 IF 'OLDBAL
DO CHGSTAT^RCBEUBIL(BILL,39)
DO ADDCOMM^RCBEUBIL(BILL,.RCCOM)
QUIT
+21 ;
+22 ; - no need for decrease if the amount to credit the account is zero
+23 if 'BUCKET
QUIT
+24 ;
DEC ; - create a decrease adjustment
+1 SET PRCAEN=0
SET DECAMT=BUCKET
+2 DO DEC^PRCASER1(BILL,.DECAMT,DUZ,RCMSG,"",.PRCAEN)
+3 SET BUCKET=DECAMT
+4 QUIT
+5 ;
+6 ;
REFUND ; Create a prepayment in an Open status
+1 SET PERROR=""
DO EN^PRCAPAY3(DFN_";DPT(",BUCKET,DT,DUZ,"","","",.PERROR)
+2 if PERROR]""
QUIT
+3 ;
+4 ; - find the Open prepayment just increased to add a comment
+5 SET NBILL=0
FOR
SET NBILL=$ORDER(^PRCA(430,"AS",RCDEBTDA,$ORDER(^PRCA(430.3,"AC",112,0)),NBILL))
if 'NBILL
QUIT
IF $PIECE(^PRCA(430,NBILL,0),U,2)=PREPAY
QUIT
+6 IF NBILL
DO ADDCOMM^RCBEUBIL(NBILL,.RCCOM)
+7 QUIT
