PRCAX ;WASH-ISC@ALTOONA,PA/TJK-MEDICATION COPAY EXEMPTION ;7/20/93 1:09 PM
V ;;4.5;Accounts Receivable;**68,371**;Mar 20, 1995;Build 29
;;Per VHA Directive 6402, this routine should not be modified.
EN1(DFN,BEG,END,ERR) ;ENTRY POINT FROM IB
I 'DFN!($G(^DPT(DFN,0))="") S ERR="INVALID PATIENT DFN" Q
I '$O(^RCD(340,"B",DFN_";DPT(",0)) S ERR="NO PATIENT ACCOUNT" Q
I 'BEG S ERR="NO BEGINNING DATE" Q
I BEG>DT S ERR="BEGINNING DATE IS IN FUTURE" Q
I BEG'?7N S ERR="BEGINNING DATE IN IMPROPER FORMAT" Q
I END,END'?7N S ERR="ENDING DATE IN IMPROPER FORMAT" Q
I END,BEG>END S ERR="BEGINNING DATE GREATER THAN ENDING DATE" Q
S:'END END=9999999
K ^TMP($J)
N ACCT,BILL,BUCKET,B0,DATE,NEWBAL,OLDBAL,PREPAY,TRAN,TDATE,T0,T1,TRAMT,X,TTYPE,DURING,STATUS,BN7,DECAMT,EXTOT,I,PRCAEN,DIC,DIE,DA,DR,MSG,PERROR,NBILL,NTRAN,MSGCNTS
S PREPAY=$O(^PRCA(430.2,"B","PREPAYMENT",0))
S ACCT=$O(^RCD(340,"B",DFN_";DPT(",0))
S (BILL,BUCKET)=0
F S BILL=$O(^PRCA(430,"C",ACCT,BILL)) Q:'BILL S B0=$G(^PRCA(430,BILL,0)) I $S($P(B0,U,2)=22:1,$P(B0,U,2)=23:1,1:0) D PROC
I $O(^TMP($J,0)),BUCKET S BILL=0 F S BILL=$O(^TMP($J,BILL)) Q:'BILL Q:'BUCKET S OLDBAL=^(BILL) D APPLY
D REFUND:BUCKET
S ERR=$G(PERROR) K ^TMP($J) Q
PROC ;PROCESS BILLS
S DATE=$P(B0,U,10),(OLDBAL,NEWBAL)=$P(B0,U,3),STATUS=$P(B0,U,8)
I DATE'<BEG,DATE'>END S NEWBAL=0
S TRAN=0 F S TRAN=$O(^PRCA(433,"C",BILL,TRAN)) Q:'TRAN S T0=$G(^PRCA(433,TRAN,0)),T1=$G(^(1)),TDATE=+T1,TTYPE=$P(T1,U,2),TRAMT=$P(T1,U,5) I $P(T0,U,4)=2,TDATE,TTYPE,TRAMT D CNT
;SET BUCKET HERE
I NEWBAL'=OLDBAL S BUCKET=BUCKET+$S(OLDBAL:OLDBAL-NEWBAL,NEWBAL<0:-NEWBAL,1:NEWBAL),^TMP($J,"BUCKET",BILL)=$S(OLDBAL:OLDBAL-NEWBAL,NEWBAL<0:-NEWBAL,1:NEWBAL)
K TRAMT
I OLDBAL,",16,42,"[(","_STATUS_",") D:BUCKET APPLY S:OLDBAL ^TMP($J,BILL)=OLDBAL
Q
CNT ;PROCESS TRANSACTIONS
S:(TTYPE'=12)&(TRAMT<0) TRAMT=-TRAMT
S DURING=0 I TDATE'<BEG,TDATE'>END S DURING=1
I ",1,12,13,24,43,"[(","_TTYPE_",") S OLDBAL=OLDBAL+TRAMT S:'DURING NEWBAL=NEWBAL+TRAMT Q
I "^2^34^"[("^"_TTYPE_"^") S OLDBAL=OLDBAL-TRAMT,NEWBAL=NEWBAL-TRAMT Q
I ",8,9,10,11,14,29,35,"[(","_TTYPE_",") S OLDBAL=OLDBAL-TRAMT D
.I NEWBAL<0 Q
.I NEWBAL-TRAMT<0 S NEWBAL=0 Q
.S NEWBAL=NEWBAL-TRAMT
.Q
Q
APPLY ;APPLY OUTSTANDING DECREASES TO ACTIVE OR OPEN CO-PAY BILLS
S EXTOT=0,BN7=$G(^PRCA(430,BILL,7)) F I=2:1:5 S EXTOT=EXTOT+$P(BN7,U,I)
G DEC:'EXTOT S TRAMT=0 S:EXTOT'<BUCKET EXTOT=BUCKET
INT F I=5:-1:2 Q:'EXTOT I $P(BN7,U,I) S X=$P(BN7,U,I),DECAMT=$S(X>BUCKET:BUCKET,1:X),$P(BN7,U,I)=$P(BN7,U,I)-DECAMT,BUCKET=BUCKET-DECAMT,EXTOT=EXTOT-DECAMT,TRAMT=TRAMT+DECAMT
S OLDBAL=OLDBAL-TRAMT
;SET EXEMPTION TRANSACTION HERE
D SETTR^PRCAUTL
S TTYPE=14,DIE="^PRCA(433,",DA=PRCAEN,MSG="INTEREST/ADMIN EXEMPTION APPLIED DUE TO CO-PAY EXEMPTION"
S DR=".03////"_BILL_";11////"_DT_";12////"_TTYPE_";15////"_TRAMT_";41////"_MSG_";89////1;4////2"
S DIC=DIE D ^DIE,AUDIT^PRCAX1
K DA,DIC,DIE,DR,TRAMT
; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
N PRCFDA S PRCFDA(430,BILL_",",72)=$P(BN7,U,2),PRCFDA(430,BILL_",",73)=$P(BN7,U,3),PRCFDA(430,BILL_",",74)=$P(BN7,U,4),PRCFDA(430,BILL_",",75)=$P(BN7,U,5)
D FILE^DIE(,"PRCFDA")
I 'OLDBAL S STATUS=39,NBILL=BILL D UPDTST Q
Q:'BUCKET
DEC ;SET DECREASE TRANSACTION HERE
S PRCAEN=0,DECAMT=BUCKET D DEC^PRCASER1(BILL,.DECAMT,DUZ,"DECREASE ADJUSTMENT APPLIED DUE TO CO-PAY EXEMPTION","",.PRCAEN)
I $G(PRCAEN) S ^PRCA(433,"ACE",DT,PRCAEN)="",$P(^PRCA(433,PRCAEN,1),U,10)=1,DA=PRCAEN,DIE=433
S OLDBAL=OLDBAL-(BUCKET-DECAMT),DECAMT1=BUCKET-DECAMT,BUCKET=DECAMT
I $G(PRCAEN) S DECAMT=DECAMT1 D AUDIT^PRCAX1 K DECAMT
K DECAMT1 Q
REFUND ;SETS UP PREPAYMENT BILL WITH REFUND REVIEW STATUS
S PERROR="" D EN^PRCAPAY3(DFN_";DPT(",BUCKET,DT,DUZ,"","","",.PERROR)
Q:PERROR]""
S NBILL=0 F S NBILL=$O(^PRCA(430,"AS",ACCT,$O(^PRCA(430.3,"AC",112,0)),NBILL)) Q:'NBILL I $P(^PRCA(430,NBILL,0),U,2)=PREPAY Q
Q:'NBILL S (TRAN,NTRAN)=0 F S NTRAN=TRAN,TRAN=$O(^PRCA(433,"C",NBILL,NTRAN)) Q:'TRAN
I NTRAN S ^PRCA(433,"ACE",DT,NTRAN)="",$P(^PRCA(433,NTRAN,1),U,10)=1
S MSG="REFUND DUE TO CO-PAY EXEMPTION",STATUS=44
UPDTST ;UPDATES STATUS TO CANCELLED OR REFUND REVIEW
S (DIC,DIE)="^PRCA(430,",DA=NBILL,DR="8///"_STATUS
I STATUS=44 D RR
S:NBILL'=BILL DR=DR_";98///"_MSG
D ^DIE K DR,DIC D AUDIT^PRCAX1 Q
;
RR ;REFUND REVIEW BILL FIELDS UPDATED
K RA F X=1:1:5 S RA=$G(RA)+$P($G(^PRCA(430,NBILL,7)),"^",X)
S DR=DR_";79.18////"_RA_";90///@;79.21///@;91///@;111///@;112///@"
K RA Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAX 4547 printed Nov 22, 2024@16:52:21 Page 2
PRCAX ;WASH-ISC@ALTOONA,PA/TJK-MEDICATION COPAY EXEMPTION ;7/20/93 1:09 PM
V ;;4.5;Accounts Receivable;**68,371**;Mar 20, 1995;Build 29
+1 ;;Per VHA Directive 6402, this routine should not be modified.
EN1(DFN,BEG,END,ERR) ;ENTRY POINT FROM IB
+1 IF 'DFN!($GET(^DPT(DFN,0))="")
SET ERR="INVALID PATIENT DFN"
QUIT
+2 IF '$ORDER(^RCD(340,"B",DFN_";DPT(",0))
SET ERR="NO PATIENT ACCOUNT"
QUIT
+3 IF 'BEG
SET ERR="NO BEGINNING DATE"
QUIT
+4 IF BEG>DT
SET ERR="BEGINNING DATE IS IN FUTURE"
QUIT
+5 IF BEG'?7N
SET ERR="BEGINNING DATE IN IMPROPER FORMAT"
QUIT
+6 IF END
IF END'?7N
SET ERR="ENDING DATE IN IMPROPER FORMAT"
QUIT
+7 IF END
IF BEG>END
SET ERR="BEGINNING DATE GREATER THAN ENDING DATE"
QUIT
+8 if 'END
SET END=9999999
+9 KILL ^TMP($JOB)
+10 NEW ACCT,BILL,BUCKET,B0,DATE,NEWBAL,OLDBAL,PREPAY,TRAN,TDATE,T0,T1,TRAMT,X,TTYPE,DURING,STATUS,BN7,DECAMT,EXTOT,I,PRCAEN,DIC,DIE,DA,DR,MSG,PERROR,NBILL,NTRAN,MSGCNTS
+11 SET PREPAY=$ORDER(^PRCA(430.2,"B","PREPAYMENT",0))
+12 SET ACCT=$ORDER(^RCD(340,"B",DFN_";DPT(",0))
+13 SET (BILL,BUCKET)=0
+14 FOR
SET BILL=$ORDER(^PRCA(430,"C",ACCT,BILL))
if 'BILL
QUIT
SET B0=$GET(^PRCA(430,BILL,0))
IF $SELECT($PIECE(B0,U,2)=22:1,$PIECE(B0,U,2)=23:1,1:0)
DO PROC
+15 IF $ORDER(^TMP($JOB,0))
IF BUCKET
SET BILL=0
FOR
SET BILL=$ORDER(^TMP($JOB,BILL))
if 'BILL
QUIT
if 'BUCKET
QUIT
SET OLDBAL=^(BILL)
DO APPLY
+16 if BUCKET
DO REFUND
+17 SET ERR=$GET(PERROR)
KILL ^TMP($JOB)
QUIT
PROC ;PROCESS BILLS
+1 SET DATE=$PIECE(B0,U,10)
SET (OLDBAL,NEWBAL)=$PIECE(B0,U,3)
SET STATUS=$PIECE(B0,U,8)
+2 IF DATE'<BEG
IF DATE'>END
SET NEWBAL=0
+3 SET TRAN=0
FOR
SET TRAN=$ORDER(^PRCA(433,"C",BILL,TRAN))
if 'TRAN
QUIT
SET T0=$GET(^PRCA(433,TRAN,0))
SET T1=$GET(^(1))
SET TDATE=+T1
SET TTYPE=$PIECE(T1,U,2)
SET TRAMT=$PIECE(T1,U,5)
IF $PIECE(T0,U,4)=2
IF TDATE
IF TTYPE
IF TRAMT
DO CNT
+4 ;SET BUCKET HERE
+5 IF NEWBAL'=OLDBAL
SET BUCKET=BUCKET+$SELECT(OLDBAL:OLDBAL-NEWBAL,NEWBAL<0:-NEWBAL,1:NEWBAL)
SET ^TMP($JOB,"BUCKET",BILL)=$SELECT(OLDBAL:OLDBAL-NEWBAL,NEWBAL<0:-NEWBAL,1:NEWBAL)
+6 KILL TRAMT
+7 IF OLDBAL
IF ",16,42,"[(","_STATUS_",")
if BUCKET
DO APPLY
if OLDBAL
SET ^TMP($JOB,BILL)=OLDBAL
+8 QUIT
CNT ;PROCESS TRANSACTIONS
+1 if (TTYPE'=12)&(TRAMT<0)
SET TRAMT=-TRAMT
+2 SET DURING=0
IF TDATE'<BEG
IF TDATE'>END
SET DURING=1
+3 IF ",1,12,13,24,43,"[(","_TTYPE_",")
SET OLDBAL=OLDBAL+TRAMT
if 'DURING
SET NEWBAL=NEWBAL+TRAMT
QUIT
+4 IF "^2^34^"[("^"_TTYPE_"^")
SET OLDBAL=OLDBAL-TRAMT
SET NEWBAL=NEWBAL-TRAMT
QUIT
+5 IF ",8,9,10,11,14,29,35,"[(","_TTYPE_",")
SET OLDBAL=OLDBAL-TRAMT
Begin DoDot:1
+6 IF NEWBAL<0
QUIT
+7 IF NEWBAL-TRAMT<0
SET NEWBAL=0
QUIT
+8 SET NEWBAL=NEWBAL-TRAMT
+9 QUIT
End DoDot:1
+10 QUIT
APPLY ;APPLY OUTSTANDING DECREASES TO ACTIVE OR OPEN CO-PAY BILLS
+1 SET EXTOT=0
SET BN7=$GET(^PRCA(430,BILL,7))
FOR I=2:1:5
SET EXTOT=EXTOT+$PIECE(BN7,U,I)
+2 if 'EXTOT
GOTO DEC
SET TRAMT=0
if EXTOT'<BUCKET
SET EXTOT=BUCKET
INT FOR I=5:-1:2
if 'EXTOT
QUIT
IF $PIECE(BN7,U,I)
SET X=$PIECE(BN7,U,I)
SET DECAMT=$SELECT(X>BUCKET:BUCKET,1:X)
SET $PIECE(BN7,U,I)=$PIECE(BN7,U,I)-DECAMT
SET BUCKET=BUCKET-DECAMT
SET EXTOT=EXTOT-DECAMT
SET TRAMT=TRAMT+DECAMT
+1 SET OLDBAL=OLDBAL-TRAMT
+2 ;SET EXEMPTION TRANSACTION HERE
+3 DO SETTR^PRCAUTL
+4 SET TTYPE=14
SET DIE="^PRCA(433,"
SET DA=PRCAEN
SET MSG="INTEREST/ADMIN EXEMPTION APPLIED DUE TO CO-PAY EXEMPTION"
+5 SET DR=".03////"_BILL_";11////"_DT_";12////"_TTYPE_";15////"_TRAMT_";41////"_MSG_";89////1;4////2"
+6 SET DIC=DIE
DO ^DIE
DO AUDIT^PRCAX1
+7 KILL DA,DIC,DIE,DR,TRAMT
+8 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+9 NEW PRCFDA
SET PRCFDA(430,BILL_",",72)=$PIECE(BN7,U,2)
SET PRCFDA(430,BILL_",",73)=$PIECE(BN7,U,3)
SET PRCFDA(430,BILL_",",74)=$PIECE(BN7,U,4)
SET PRCFDA(430,BILL_",",75)=$PIECE(BN7,U,5)
+10 DO FILE^DIE(,"PRCFDA")
+11 IF 'OLDBAL
SET STATUS=39
SET NBILL=BILL
DO UPDTST
QUIT
+12 if 'BUCKET
QUIT
DEC ;SET DECREASE TRANSACTION HERE
+1 SET PRCAEN=0
SET DECAMT=BUCKET
DO DEC^PRCASER1(BILL,.DECAMT,DUZ,"DECREASE ADJUSTMENT APPLIED DUE TO CO-PAY EXEMPTION","",.PRCAEN)
+2 IF $GET(PRCAEN)
SET ^PRCA(433,"ACE",DT,PRCAEN)=""
SET $PIECE(^PRCA(433,PRCAEN,1),U,10)=1
SET DA=PRCAEN
SET DIE=433
+3 SET OLDBAL=OLDBAL-(BUCKET-DECAMT)
SET DECAMT1=BUCKET-DECAMT
SET BUCKET=DECAMT
+4 IF $GET(PRCAEN)
SET DECAMT=DECAMT1
DO AUDIT^PRCAX1
KILL DECAMT
+5 KILL DECAMT1
QUIT
REFUND ;SETS UP PREPAYMENT BILL WITH REFUND REVIEW STATUS
+1 SET PERROR=""
DO EN^PRCAPAY3(DFN_";DPT(",BUCKET,DT,DUZ,"","","",.PERROR)
+2 if PERROR]""
QUIT
+3 SET NBILL=0
FOR
SET NBILL=$ORDER(^PRCA(430,"AS",ACCT,$ORDER(^PRCA(430.3,"AC",112,0)),NBILL))
if 'NBILL
QUIT
IF $PIECE(^PRCA(430,NBILL,0),U,2)=PREPAY
QUIT
+4 if 'NBILL
QUIT
SET (TRAN,NTRAN)=0
FOR
SET NTRAN=TRAN
SET TRAN=$ORDER(^PRCA(433,"C",NBILL,NTRAN))
if 'TRAN
QUIT
+5 IF NTRAN
SET ^PRCA(433,"ACE",DT,NTRAN)=""
SET $PIECE(^PRCA(433,NTRAN,1),U,10)=1
+6 SET MSG="REFUND DUE TO CO-PAY EXEMPTION"
SET STATUS=44
UPDTST ;UPDATES STATUS TO CANCELLED OR REFUND REVIEW
+1 SET (DIC,DIE)="^PRCA(430,"
SET DA=NBILL
SET DR="8///"_STATUS
+2 IF STATUS=44
DO RR
+3 if NBILL'=BILL
SET DR=DR_";98///"_MSG
+4 DO ^DIE
KILL DR,DIC
DO AUDIT^PRCAX1
QUIT
+5 ;
RR ;REFUND REVIEW BILL FIELDS UPDATED
+1 KILL RA
FOR X=1:1:5
SET RA=$GET(RA)+$PIECE($GET(^PRCA(430,NBILL,7)),"^",X)
+2 SET DR=DR_";79.18////"_RA_";90///@;79.21///@;91///@;111///@;112///@"
+3 KILL RA
QUIT
+4 ;
