PRCASER1 ;WASH-ISC@ALTOONA,PA/RGY - Accept transaction from billing engine ;9/8/93 2:21 PM
V ;;4.5;Accounts Receivable;**48,104,165,233,301,307,337,353,364,377,402,425**;Mar 20, 1995;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*337 Added a bill lock to insure that decreases are stacked
; instead of slamming bill simultaneously.
;
;PRCA*4.5*353 Add check to clear (exempt) any interest and admin
; fees when a decrease makes principle balance zero
; In addition, added modification that will allow
; decreases to post to 'Suspended' bills to avoid
; further billing issues if the bill is re-opened.
;PRCA*4.5*364 Ensure exempt transaction has date/time stamp
;PRCA*4.5*402 Add new category TRICARE PHARMACY
;PRCA*4.5*425 Add category CHAMPVA THIRD PARTY (28)
;
NEW AMT,AMT1,PRCAERR,PRCABN,PRCADJ,X1,XMDUZ,XMSUB,XMTEXT,XMY,DEBT
I '$D(X) S Y="-1^PRCA020" G Q
I $O(^PRCA(430.3,"AC",+X,0))'?1N.N,$P($G(^PRCA(430.3,+X,0)),"^",3)'=21 S Y="-1^PRCA021" G Q
I +X'=21,$P($G(^PRCA(430.3,+X,0)),"^",3)'=21 S Y="-1^PRCA022" G Q
I $P(X,"^",2)'?.N.1".".2N S Y="-1^PRCA023" G Q
I $P(X,"^",2)'>0 S Y="-1^PRCA017" G Q
I $P(X,"^",3)="" S Y="-1^PRCA006" G Q
S PRCABN=$O(^PRCA(430,"B",$P(X,"^",3),0)) I $G(^PRCA(430,+PRCABN,0))="" S Y="-1^PRCA007" G Q
I '$D(^VA(200,+$P(X,"^",4),0)) S Y="-1^PRCA013" G Q
I $P(X,"^",5)'?7N S Y="-1^PRCA024" G Q
S (AMT1,AMT)=$P(X,"^",2)
D DEC(PRCABN,.AMT,$P(X,"^",4),$P(X,U,6),$P(X,U,5))
S XMDUZ="AR Package",XMTEXT="X1(",DEBT=$P($G(^PRCA(430,PRCABN,0)),"^",9),DEBT=$E($$NAM^RCFN01(DEBT),1)_" ("_$E($$SSN^RCFN01(DEBT),6,9)_")"
I AMT'=AMT1 S X1(1)="A decrease adjustment for bill/Pt name (SSN) #"_$P(X,"^",3)_"/"_DEBT_" has been",XMSUB="Automatic Adj: "_$P(X,"^",3)
I AMT=AMT1 S X1(1)="**** NOTICE: A decrease adjustment for bill/Pt name (SSN) #"_$P(X,U,3)_"/"_DEBT,XMSUB="Manual Adj: "_$P(X,U,3),X1(3)=" "
S Y=DT X ^DD("DD") S X1(2)=$S(AMT'=AMT1:"automatically",1:"needs to be manually")_" applied in the amount of $"_$J($S(AMT1=AMT:AMT1,1:AMT1-AMT),0,2)_" on "_Y_"."
I AMT,AMT'=AMT1 S X1(3)="Please review bill for proper application of the unapplied amount of $"_$J(AMT,0,2)_"."
S X1(4)=" ",X1(5)="Data sent from Service"
S X1(6)=" Amount: $"_$J(AMT1,0,2)
S Y=$P(X,U,5) X ^DD("DD") S X1(7)=" Date: "_Y
S X1(8)=" Reason: "_$S($P(X,"^",6)]"":$P(X,"^",6),1:"N/A")
S X1(9)=" Adjustment by: "_$P($G(^VA(200,+$P(X,"^",4),0)),"^")
S AMT=0 F X=1:1:5 S AMT=AMT+$P($G(^PRCA(430,PRCABN,7)),U,X)
S AMT1=AMT-+$G(^PRCA(430,PRCABN,7))
S X=$P(^PRCA(430.3,+$P($G(^PRCA(430,PRCABN,0)),U,8),0),U,1)
S X1(10)=" ",X1(12)=" ",X1(13)="Bill status is "_$S(XMSUB["Auto":"now ",1:"")_X_" with a balance of $"_$J(AMT,0,2)_".",X1(14)=" "
I AMT1>0 S X1(15)=" *WARNING* There is outstanding administrative charges of $"_$J(AMT1,0,2)_".",X1(16)=" An adjustment of administrative charges MAY need to be done."
S XMY("G.PRCA ADJUSTMENT TRANS")=""
D ^XMD
Q S Y=$S($G(Y)<0:Y,1:1) Q
;
DEC(PRCABN,AMT,APR,REA,BDT,PRCAEN) ;Auto decrease from service Bill#,Tran amt,person,reason,Tran date
N BAL,DA,DIC,DIE,DR,ERR,PRCA,PRCAA2,PRCAMT,PRCASV,X,PRCAAMT,PRCATRAN,RCRPIEN
S Y=1
L +^PRCA(430,PRCABN,"PRCASER1"):$S(DILOCKTM>30:DILOCKTM,1:30) I '$T S Y="-1^PRCA004^AR Package 'busy' while trying to add transaction." Q
S PRCAEN="",BAL=+$G(^PRCA(430,PRCABN,7)) I 'BAL S Y="-1^Bill balance less than decrease" G Q1
I $P(^PRCA(430,PRCABN,0),U,8)'=$O(^PRCA(430.3,"AC",102,"")),$P(^PRCA(430,PRCABN,0),U,8)'=$O(^PRCA(430.3,"AC",112,"")),$P(^PRCA(430,PRCABN,0),U,8)'=$O(^PRCA(430.3,"AC",240,"")) S Y="-1^Invalid status for posting" G Q1 ;PRCA*4.5*353
I $P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) S Y="-1^Cannot post against pre-pay bill" G Q1
S BAL=$S(AMT>BAL:BAL,1:AMT)
S PRCA("ADJ")=$O(^PRCA(430.3,"AC",21,0)),PRCASV("FY")=$$FY^RCFN01(DT)_U_BAL,PRCASV("APR")=APR,PRCASV("BDT")=$S($G(BDT)>0:BDT,1:DT)
D SETTR^PRCAUTL,PATTR^PRCAUTL S DIE="^PRCA(433,",DR="[PRCA FY ADJ2 BATCH]",DA=PRCAEN D ^DIE
S PRCAA2=$P(^PRCA(433,PRCAEN,4,0),U,3) D UPFY^PRCADJ,TRANUP^PRCAUTL
;PRCA*4.5*402 - add category TRICARE PHARMACY
;PRCA*4.5*425 - add category CHAMPVA THIRD PARTY (28)
I ("^28^30^31^80^")[("^"_$P($G(^PRCA(430,PRCABN,0)),"^",2)_"^") D EN^PRCAFBDM(PRCABN,BAL,PRCA("ADJ"),$G(PRCADJ("BDT")),PRCAEN,.ERR)
D UPPRIN^PRCADJ
I "AutoAUTO"'[$E(REA,1,4) S REA="Auto Dec.: "_REA
S DA=PRCAEN,DIE="^PRCA(433,",DR="41///"_REA D ^DIE
S AMT=AMT-+$P($G(^PRCA(433,PRCAEN,1)),U,5)
;PRCA*4.5*377 - update Repayment Plan with as a decrease adjustment
D UPDBAL^RCRPU1(PRCABN,PRCAEN)
; ;End PRCE*4.5*377
I PRCAEN,$D(^PRCA(430,"TCSP",PRCABN)) D DECADJ^RCTCSPU(PRCABN,PRCAEN) ;prca*4.5*301 add cs decrease adjustment 5B
S PRCAAMT=$G(^PRCA(430,PRCABN,7)) I $P(PRCAAMT,U)=0,($P(PRCAAMT,U,2)+$P(PRCAAMT,"^",3)+$P(PRCAAMT,"^",4)+$P(PRCAAMT,"^",5)'=0) D ;PRCA*4.5*353
. S PRCATRAN=$$EXEMPT^RCBEUTR2(PRCABN,$P(PRCAAMT,"^",2)_"^"_$P(PRCAAMT,"^",3)_"^^"_$P(PRCAAMT,"^",4)_"^"_$P(PRCAAMT,"^",5),"PRINCIPAL BAL EQUALS ZERO",0,1)
. I PRCATRAN,$D(^PRCA(430,"TCSP",PRCABN)) D DECADJ^RCTCSPU(PRCABN,PRCATRAN)
Q1 L -^PRCA(430,PRCABN,"PRCASER1") S Y=$S($G(Y)<0:Y,1:1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCASER1 5273 printed Nov 22, 2024@16:51:31 Page 2
PRCASER1 ;WASH-ISC@ALTOONA,PA/RGY - Accept transaction from billing engine ;9/8/93 2:21 PM
V ;;4.5;Accounts Receivable;**48,104,165,233,301,307,337,353,364,377,402,425**;Mar 20, 1995;Build 8
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*337 Added a bill lock to insure that decreases are stacked
+4 ; instead of slamming bill simultaneously.
+5 ;
+6 ;PRCA*4.5*353 Add check to clear (exempt) any interest and admin
+7 ; fees when a decrease makes principle balance zero
+8 ; In addition, added modification that will allow
+9 ; decreases to post to 'Suspended' bills to avoid
+10 ; further billing issues if the bill is re-opened.
+11 ;PRCA*4.5*364 Ensure exempt transaction has date/time stamp
+12 ;PRCA*4.5*402 Add new category TRICARE PHARMACY
+13 ;PRCA*4.5*425 Add category CHAMPVA THIRD PARTY (28)
+14 ;
+15 NEW AMT,AMT1,PRCAERR,PRCABN,PRCADJ,X1,XMDUZ,XMSUB,XMTEXT,XMY,DEBT
+16 IF '$DATA(X)
SET Y="-1^PRCA020"
GOTO Q
+17 IF $ORDER(^PRCA(430.3,"AC",+X,0))'?1N.N
IF $PIECE($GET(^PRCA(430.3,+X,0)),"^",3)'=21
SET Y="-1^PRCA021"
GOTO Q
+18 IF +X'=21
IF $PIECE($GET(^PRCA(430.3,+X,0)),"^",3)'=21
SET Y="-1^PRCA022"
GOTO Q
+19 IF $PIECE(X,"^",2)'?.N.1".".2N
SET Y="-1^PRCA023"
GOTO Q
+20 IF $PIECE(X,"^",2)'>0
SET Y="-1^PRCA017"
GOTO Q
+21 IF $PIECE(X,"^",3)=""
SET Y="-1^PRCA006"
GOTO Q
+22 SET PRCABN=$ORDER(^PRCA(430,"B",$PIECE(X,"^",3),0))
IF $GET(^PRCA(430,+PRCABN,0))=""
SET Y="-1^PRCA007"
GOTO Q
+23 IF '$DATA(^VA(200,+$PIECE(X,"^",4),0))
SET Y="-1^PRCA013"
GOTO Q
+24 IF $PIECE(X,"^",5)'?7N
SET Y="-1^PRCA024"
GOTO Q
+25 SET (AMT1,AMT)=$PIECE(X,"^",2)
+26 DO DEC(PRCABN,.AMT,$PIECE(X,"^",4),$PIECE(X,U,6),$PIECE(X,U,5))
+27 SET XMDUZ="AR Package"
SET XMTEXT="X1("
SET DEBT=$PIECE($GET(^PRCA(430,PRCABN,0)),"^",9)
SET DEBT=$EXTRACT($$NAM^RCFN01(DEBT),1)_" ("_$EXTRACT($$SSN^RCFN01(DEBT),6,9)_")"
+28 IF AMT'=AMT1
SET X1(1)="A decrease adjustment for bill/Pt name (SSN) #"_$PIECE(X,"^",3)_"/"_DEBT_" has been"
SET XMSUB="Automatic Adj: "_$PIECE(X,"^",3)
+29 IF AMT=AMT1
SET X1(1)="**** NOTICE: A decrease adjustment for bill/Pt name (SSN) #"_$PIECE(X,U,3)_"/"_DEBT
SET XMSUB="Manual Adj: "_$PIECE(X,U,3)
SET X1(3)=" "
+30 SET Y=DT
XECUTE ^DD("DD")
SET X1(2)=$SELECT(AMT'=AMT1:"automatically",1:"needs to be manually")_" applied in the amount of $"_$JUSTIFY($SELECT(AMT1=AMT:AMT1,1:AMT1-AMT),0,2)_" on "_Y_"."
+31 IF AMT
IF AMT'=AMT1
SET X1(3)="Please review bill for proper application of the unapplied amount of $"_$JUSTIFY(AMT,0,2)_"."
+32 SET X1(4)=" "
SET X1(5)="Data sent from Service"
+33 SET X1(6)=" Amount: $"_$JUSTIFY(AMT1,0,2)
+34 SET Y=$PIECE(X,U,5)
XECUTE ^DD("DD")
SET X1(7)=" Date: "_Y
+35 SET X1(8)=" Reason: "_$SELECT($PIECE(X,"^",6)]"":$PIECE(X,"^",6),1:"N/A")
+36 SET X1(9)=" Adjustment by: "_$PIECE($GET(^VA(200,+$PIECE(X,"^",4),0)),"^")
+37 SET AMT=0
FOR X=1:1:5
SET AMT=AMT+$PIECE($GET(^PRCA(430,PRCABN,7)),U,X)
+38 SET AMT1=AMT-+$GET(^PRCA(430,PRCABN,7))
+39 SET X=$PIECE(^PRCA(430.3,+$PIECE($GET(^PRCA(430,PRCABN,0)),U,8),0),U,1)
+40 SET X1(10)=" "
SET X1(12)=" "
SET X1(13)="Bill status is "_$SELECT(XMSUB["Auto":"now ",1:"")_X_" with a balance of $"_$JUSTIFY(AMT,0,2)_"."
SET X1(14)=" "
+41 IF AMT1>0
SET X1(15)=" *WARNING* There is outstanding administrative charges of $"_$JUSTIFY(AMT1,0,2)_"."
SET X1(16)=" An adjustment of administrative charges MAY need to be done."
+42 SET XMY("G.PRCA ADJUSTMENT TRANS")=""
+43 DO ^XMD
Q SET Y=$SELECT($GET(Y)<0:Y,1:1)
QUIT
+1 ;
DEC(PRCABN,AMT,APR,REA,BDT,PRCAEN) ;Auto decrease from service Bill#,Tran amt,person,reason,Tran date
+1 NEW BAL,DA,DIC,DIE,DR,ERR,PRCA,PRCAA2,PRCAMT,PRCASV,X,PRCAAMT,PRCATRAN,RCRPIEN
+2 SET Y=1
+3 LOCK +^PRCA(430,PRCABN,"PRCASER1"):$SELECT(DILOCKTM>30:DILOCKTM,1:30)
IF '$TEST
SET Y="-1^PRCA004^AR Package 'busy' while trying to add transaction."
QUIT
+4 SET PRCAEN=""
SET BAL=+$GET(^PRCA(430,PRCABN,7))
IF 'BAL
SET Y="-1^Bill balance less than decrease"
GOTO Q1
+5 ;PRCA*4.5*353
IF $PIECE(^PRCA(430,PRCABN,0),U,8)'=$ORDER(^PRCA(430.3,"AC",102,""))
IF $PIECE(^PRCA(430,PRCABN,0),U,8)'=$ORDER(^PRCA(430.3,"AC",112,""))
IF $PIECE(^PRCA(430,PRCABN,0),U,8)'=$ORDER(^PRCA(430.3,"AC",240,""))
SET Y="-1^Invalid status for posting"
GOTO Q1
+6 IF $PIECE(^PRCA(430,PRCABN,0),U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
SET Y="-1^Cannot post against pre-pay bill"
GOTO Q1
+7 SET BAL=$SELECT(AMT>BAL:BAL,1:AMT)
+8 SET PRCA("ADJ")=$ORDER(^PRCA(430.3,"AC",21,0))
SET PRCASV("FY")=$$FY^RCFN01(DT)_U_BAL
SET PRCASV("APR")=APR
SET PRCASV("BDT")=$SELECT($GET(BDT)>0:BDT,1:DT)
+9 DO SETTR^PRCAUTL
DO PATTR^PRCAUTL
SET DIE="^PRCA(433,"
SET DR="[PRCA FY ADJ2 BATCH]"
SET DA=PRCAEN
DO ^DIE
+10 SET PRCAA2=$PIECE(^PRCA(433,PRCAEN,4,0),U,3)
DO UPFY^PRCADJ
DO TRANUP^PRCAUTL
+11 ;PRCA*4.5*402 - add category TRICARE PHARMACY
+12 ;PRCA*4.5*425 - add category CHAMPVA THIRD PARTY (28)
+13 IF ("^28^30^31^80^")[("^"_$PIECE($GET(^PRCA(430,PRCABN,0)),"^",2)_"^")
DO EN^PRCAFBDM(PRCABN,BAL,PRCA("ADJ"),$GET(PRCADJ("BDT")),PRCAEN,.ERR)
+14 DO UPPRIN^PRCADJ
+15 IF "AutoAUTO"'[$EXTRACT(REA,1,4)
SET REA="Auto Dec.: "_REA
+16 SET DA=PRCAEN
SET DIE="^PRCA(433,"
SET DR="41///"_REA
DO ^DIE
+17 SET AMT=AMT-+$PIECE($GET(^PRCA(433,PRCAEN,1)),U,5)
+18 ;PRCA*4.5*377 - update Repayment Plan with as a decrease adjustment
+19 DO UPDBAL^RCRPU1(PRCABN,PRCAEN)
+20 ; ;End PRCE*4.5*377
+21 ;prca*4.5*301 add cs decrease adjustment 5B
IF PRCAEN
IF $DATA(^PRCA(430,"TCSP",PRCABN))
DO DECADJ^RCTCSPU(PRCABN,PRCAEN)
+22 ;PRCA*4.5*353
SET PRCAAMT=$GET(^PRCA(430,PRCABN,7))
IF $PIECE(PRCAAMT,U)=0
IF ($PIECE(PRCAAMT,U,2)+$PIECE(PRCAAMT,"^",3)+$PIECE(PRCAAMT,"^",4)+$PIECE(PRCAAMT,"^",5)'=0)
Begin DoDot:1
+23 SET PRCATRAN=$$EXEMPT^RCBEUTR2(PRCABN,$PIECE(PRCAAMT,"^",2)_"^"_$PIECE(PRCAAMT,"^",3)_"^^"_$PIECE(PRCAAMT,"^",4)_"^"_$PIECE(PRCAAMT,"^",5),"PRINCIPAL BAL EQUALS ZERO",0,1)
+24 IF PRCATRAN
IF $DATA(^PRCA(430,"TCSP",PRCABN))
DO DECADJ^RCTCSPU(PRCABN,PRCATRAN)
End DoDot:1
Q1 LOCK -^PRCA(430,PRCABN,"PRCASER1")
SET Y=$SELECT($GET(Y)<0:Y,1:1)
+1 QUIT
