Routine: PRCAX

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

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

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  Feb 18, 2025@23:08:32                                                                                                                                                                                                       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       ;

PRCAX.m