source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAX.m@ 628

PRCAX ;WASH-ISC@ALTOONA,PA/TJK-MEDICATION COPAY EXEMPTION ;7/20/93  1:09 PM
V ;;4.5;Accounts Receivable;**68**;Mar 20, 1995
 ;;Per VHA Directive 10-93-142, 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
 S $P(^PRCA(430,BILL,7),U,2,5)=$P(BN7,U,2)_U_$P(BN7,U,3)_U_$P(BN7,U,4)_U_$P(BN7,U,5)
 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
 ;