RCBEADJ ;WISC/RFJ-adjustment ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**169,172,204,173,208,233,298,301,315,326,338,371,420**;Mar 20, 1995;Build 1
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
DECREASE ; menu option: create a decrease adjustment
D ADJUST("DECREASE")
Q
;
;
INCREASE ; menu option: create an increase adjustment
D ADJUST("INCREASE")
Q
;
ADJUST(RCBETYPE,RCEDI) ; create an adjustment
; rcbetype = INCREASE for increase or DECREASE for decrease
; rcedi = the ien of the bill selected via the EDI Worklist;ien of
; XX the ERA entry or null/undefined if bill should be selected
I '$G(GOTBILL) N RCBILLDA ;PRCA*4.5*315 If entering from worklist
F D Q:RCBILLDA<0!$G(RCEDI)!$G(GOTBILL)
. K RCTRANDA,RCLIST,RCTRREV
. ;
. ; select a bill
. I '$G(GOTBILL) S RCBILLDA=$S('$G(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI) ;PRCA*4.5*315
. I RCBILLDA<1 Q
. I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="INCREASE") D ;PRCA*4.5*315/DRF
.. S RCTRREV=$$ASKREV()
.. W !
. I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="DECREASE") S %=$$ASKCM Q:(%'=1) ; prca*4.5*301 & *315
. ;
. ; adjust the bill
. D ADJBILL(RCBETYPE,RCBILLDA,$P($G(RCEDI),";",2))
Q
;
ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ; adjust a bill
; RCEDIWL = ien of ERA entry if called from worklist
N RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y,RCFDA
; lock the bill
L +^PRCA(430,RCBILLDA):5 E W !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS BILL." Q
;
; show data for the bill
D SHOWBILL^RCWROFF1(RCBILLDA)
;
; check the balance of the bill
W !!,"Checking the bill's balance ..."
S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
I RCBALANC="" W " IN Balance!"
;
; out of balance, ask to fix it
I RCBALANC'="" D I RCBILLDA<1 D UNLOCK Q
. S TOTALCAL=$P(RCBALANC,"^")+$P(RCBALANC,"^",2)+$P(RCBALANC,"^",3)+$P(RCBALANC,"^",4)+$P(RCBALANC,"^",5)
. S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
. S TOTALSTO=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,"^",4)+$P(RCDATA7,"^",5)
. W " OUT of Balance!"
. W !!," BALANCE:",$J("Calculated",12),$J("Stored",12)
. W !," ------- ",$J("------------",12),$J("------------",12)
. W !," Principal Balance:",$J($P(RCBALANC,"^",1),12,2),$J($P(RCDATA7,"^",1),12,2)
. I +$P(RCBALANC,"^",1)'=+$P(RCDATA7,"^",1) W " <<-- OUT OF BALANCE"
. W !," Interest Balance:",$J($P(RCBALANC,"^",2),12,2),$J($P(RCDATA7,"^",2),12,2)
. I +$P(RCBALANC,"^",2)'=+$P(RCDATA7,"^",2) W " <<-- OUT OF BALANCE"
. W !," Admin Balance:",$J($P(RCBALANC,"^",3),12,2),$J($P(RCDATA7,"^",3),12,2)
. I +$P(RCBALANC,"^",3)'=+$P(RCDATA7,"^",3) W " <<-- OUT OF BALANCE"
. W !," MF Balance:",$J($P(RCBALANC,"^",4),12,2),$J($P(RCDATA7,"^",4),12,2)
. I +$P(RCBALANC,"^",4)'=+$P(RCDATA7,"^",4) W " <<-- OUT OF BALANCE"
. W !," CC Balance:",$J($P(RCBALANC,"^",5),12,2),$J($P(RCDATA7,"^",5),12,2)
. I +$P(RCBALANC,"^",5)'=+$P(RCDATA7,"^",5) W " <<-- OUT OF BALANCE"
. W !," ------- ",$J("-------------",12),$J("-------------",12)
. W !," TOTAL:",$J(TOTALCAL,12,2),$J(TOTALSTO,12,2)
. I +TOTALCAL'=+TOTALSTO W " <<-- OUT OF BALANCE"
. ;
. ; ask to fix the balances
. S Y=$$ASKFIX I Y'=1 W !," NOTE: You must fix the Balance Discrepancy before processing an adjustment!" S RCBILLDA=0 Q
. ;
. ; fix it
. ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
. S RCFDA(430,RCBILLDA_",",71)=+$P(RCBALANC,"^",1) ; principal
. S RCFDA(430,RCBILLDA_",",72)=+$P(RCBALANC,"^",2) ; interest
. S RCFDA(430,RCBILLDA_",",73)=+$P(RCBALANC,"^",3) ; admin
. S RCFDA(430,RCBILLDA_",",74)=+$P(RCBALANC,"^",4) ; marshal fee
. S RCFDA(430,RCBILLDA_",",75)=+$P(RCBALANC,"^",5) ; court cost
. D FILE^DIE(,"RCFDA")
. ;
. W !," Balance Discrepancy FIXED!"
;
; if the principal balance is zero, do not allow it to be adjusted
; ask to close/cancel it
I RCBETYPE="DECREASE",'$G(^PRCA(430,RCBILLDA,7)) W !!,"Note: This bill has NO PRINCIPAL BALANCE to decrease !" D INTADMIN(RCBILLDA),UNLOCK Q
;
; If entry is from EDI Lockbox worklist, display total adjustments in ERA
N AP D
.N BILL,EOB,ERA,SEQ S ERA="",AP=0
.F S ERA=$O(^RCY(344.4,"AP",1,ERA)) Q:'ERA D Q:AP
..S SEQ=0
..F S SEQ=$O(^RCY(344.4,"AP",1,ERA,SEQ)) Q:'SEQ D Q:AP
...S EOB=$P($G(^RCY(344.4,ERA,1,SEQ,0)),U,2) Q:'EOB
...S:$P($G(^IBM(361.1,EOB,0)),U)=RCBILLDA AP=1 ;IA #4051
;
; Ask to enter transaction even though it is marked for autopost PRCA*4.5*298
I RCBETYPE="DECREASE",AP S Y=$$ASKAUPO() I Y'=1 W !,"Exiting bill adjustment." D UNLOCK Q
;
; Display warning for decrease adjustment if pending payments exist
I RCBETYPE="DECREASE" D WARN^RCBEADJ1(RCBILLDA) ; PRCA*4.5*326
;
; ask to enter adjustment amount
S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
I RCAMOUNT<0 D UNLOCK Q
;
; if decrease, make negative
I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
;
; ask if it is a contract adjustment (Community Care added check for all 3rd party categories PRCA*4.5*338)
I RCBETYPE="DECREASE",$$THRDPRTY(RCBILLDA) S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
;
; show what the new transaction will look like
S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
W !!,"If you process the transaction, the bill will look like:"
W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),11,2)
W !," NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,11,2)
W !," -----------"
W !," NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,11,2)
;
; ask to enter transaction
S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
;
ADDADJ ; add adjustment
N BILL
S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
S BILL=RCBILLDA ; used in ^RCTCSPD5 PRCA*4.5*420
I 'RCTRANDA W !," *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK Q
I RCTRANDA W !," Adjustment Transaction: ",RCTRANDA," has been added."
I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs decrease adjustment
I RCTRANDA,$G(RCTRREV)=0 S PRCABN=RCBILLDA D CSITRN^RCTCSPD5
I RCTRANDA,$G(RCTRREV)=0,'$G(RCEDIWL),(RCBETYPE="INCREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) S PRCABN=RCBILLDA D INCADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;PRCA*4.5*315/DRF add cs increase adjustment
I $G(RCTRREV)=1 S PRCABN=RCBILLDA D CSITRY^RCTCSPD5
I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!," * * * * Transmission will be held until "_Y_" * * * *"
;
; ask to enter a comment
W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
;
; ask to exempt interest and admin charges
I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
;
; notification of subsequent payer bulletin
S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
I RCDATA7'="",'X D
. N PRCABN,PRCAEN,PRCAMT
. S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
. D EOB^PRCADJ
;
; unlock and ask the next bill to adjust
D UNLOCK
Q
;
;
UNLOCK ; unlock bill and transaction
L -^PRCA(430,RCBILLDA)
I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
Q
;
;
INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
N RCAMOUNT,RCTRANDA,Y
;
; check to see if there is interest and admin charges
S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q
;
; only ask if there is no principal
I RCAMOUNT Q
;
W !!,"You have the option to automatically EXEMPT the interest"
W !,"and administrative charges. This will close the bill."
S Y=$$ASKEXEMP I Y'=1 Q
;
W !!,"Creating an EXEMPT transaction ..."
S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
I 'RCTRANDA W !," *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
I RCTRANDA W !," Exempt Transaction: ",RCTRANDA," has been added."
INTC35B ;Check if CS5B entry needed for exempt transaction
I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs exempt
I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!," * * * * Transmission will be held until "_Y_" * * * *"
;
W !," Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
Q
;
ASKOK(RCBETYPE) ; ask record decrease or increase transaction
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="YES"
S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
ASKAUPO() ; ask record even though marked for auto post PRCA*4.5*298
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YOA",DIR("B")="NO"
S DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;PATCH 313
ASKFIX() ; ask to fix bill's balance
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="YES"
;S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Do you want to FIX the balance discrepancy "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;
ASKEXEMP() ; ask to record an exempt transaction
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Would you like to EXEMPT the interest and admin charges "
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;
ASKCONT() ; ask if contract adjustment
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="YES"
S DIR("A")=" Is this a CONTRACT adjustment "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;
ASKREV() ; Ask if Treasury reversal *315/DRF
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Is this a TREASURY reversal "
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;
ADJNUM(RCBILLDA) ; get next adjustment number for a bill
N %,ADJUST,DATA1,RCTRANDA
S RCTRANDA=0
F S RCTRANDA=$O(^PRCA(433,"C",RCBILLDA,RCTRANDA)) Q:'RCTRANDA S DATA1=$G(^PRCA(433,RCTRANDA,1)) I $P(DATA1,"^",4),$P(DATA1,"^",2)=1!($P(DATA1,"^",2)=35) S ADJUST=$P(DATA1,"^",4)+1
Q ADJUST
;
;
AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
I RCBETYPE="INCREASE" S PRINBAL=9999999.99
W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),"."
S DIR(0)="NAO^.01:"_PRINBAL_":2"
S DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q $S(Y'="":Y,1:-1)
;
ASKCM() ; ask if the action is being performed due to the claims matching process *315
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Is this action being performed due to the CLAIMS MATCHING process "
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
Q Y
;
;
THRDPRTY(RCBILLDA) ; check whether or not bill is THIRD PARTY
N CAT
S CAT=$$GET1^DIQ(430,RCBILLDA,2,"I") ; get account receivable category
I $$GET1^DIQ(430.2,CAT,5,"I")="T" Q 1 ; return true if AR Category is THIRD PARTY
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEADJ 12066 printed Dec 13, 2024@01:42:36 Page 2
RCBEADJ ;WISC/RFJ-adjustment ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**169,172,204,173,208,233,298,301,315,326,338,371,420**;Mar 20, 1995;Build 1
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DECREASE ; menu option: create a decrease adjustment
+1 DO ADJUST("DECREASE")
+2 QUIT
+3 ;
+4 ;
INCREASE ; menu option: create an increase adjustment
+1 DO ADJUST("INCREASE")
+2 QUIT
+3 ;
ADJUST(RCBETYPE,RCEDI) ; create an adjustment
+1 ; rcbetype = INCREASE for increase or DECREASE for decrease
+2 ; rcedi = the ien of the bill selected via the EDI Worklist;ien of
+3 ; XX the ERA entry or null/undefined if bill should be selected
+4 ;PRCA*4.5*315 If entering from worklist
IF '$GET(GOTBILL)
NEW RCBILLDA
+5 FOR
Begin DoDot:1
+6 KILL RCTRANDA,RCLIST,RCTRREV
+7 ;
+8 ; select a bill
+9 ;PRCA*4.5*315
IF '$GET(GOTBILL)
SET RCBILLDA=$SELECT('$GET(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI)
+10 IF RCBILLDA<1
QUIT
+11 ;PRCA*4.5*315/DRF
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
IF (RCBETYPE="INCREASE")
Begin DoDot:2
+12 SET RCTRREV=$$ASKREV()
+13 WRITE !
End DoDot:2
+14 ; prca*4.5*301 & *315
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
IF (RCBETYPE="DECREASE")
SET %=$$ASKCM
if (%'=1)
QUIT
+15 ;
+16 ; adjust the bill
+17 DO ADJBILL(RCBETYPE,RCBILLDA,$PIECE($GET(RCEDI),";",2))
End DoDot:1
if RCBILLDA<0!$GET(RCEDI)!$GET(GOTBILL)
QUIT
+18 QUIT
+19 ;
ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ; adjust a bill
+1 ; RCEDIWL = ien of ERA entry if called from worklist
+2 NEW RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y,RCFDA
+3 ; lock the bill
+4 LOCK +^PRCA(430,RCBILLDA):5
IF '$TEST
WRITE !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS BILL."
QUIT
+5 ;
+6 ; show data for the bill
+7 DO SHOWBILL^RCWROFF1(RCBILLDA)
+8 ;
+9 ; check the balance of the bill
+10 WRITE !!,"Checking the bill's balance ..."
+11 SET RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
+12 IF RCBALANC=""
WRITE " IN Balance!"
+13 ;
+14 ; out of balance, ask to fix it
+15 IF RCBALANC'=""
Begin DoDot:1
+16 SET TOTALCAL=$PIECE(RCBALANC,"^")+$PIECE(RCBALANC,"^",2)+$PIECE(RCBALANC,"^",3)+$PIECE(RCBALANC,"^",4)+$PIECE(RCBALANC,"^",5)
+17 SET RCDATA7=$GET(^PRCA(430,RCBILLDA,7))
+18 SET TOTALSTO=$PIECE(RCDATA7,"^")+$PIECE(RCDATA7,"^",2)+$PIECE(RCDATA7,"^",3)+$PIECE(RCDATA7,"^",4)+$PIECE(RCDATA7,"^",5)
+19 WRITE " OUT of Balance!"
+20 WRITE !!," BALANCE:",$JUSTIFY("Calculated",12),$JUSTIFY("Stored",12)
+21 WRITE !," ------- ",$JUSTIFY("------------",12),$JUSTIFY("------------",12)
+22 WRITE !," Principal Balance:",$JUSTIFY($PIECE(RCBALANC,"^",1),12,2),$JUSTIFY($PIECE(RCDATA7,"^",1),12,2)
+23 IF +$PIECE(RCBALANC,"^",1)'=+$PIECE(RCDATA7,"^",1)
WRITE " <<-- OUT OF BALANCE"
+24 WRITE !," Interest Balance:",$JUSTIFY($PIECE(RCBALANC,"^",2),12,2),$JUSTIFY($PIECE(RCDATA7,"^",2),12,2)
+25 IF +$PIECE(RCBALANC,"^",2)'=+$PIECE(RCDATA7,"^",2)
WRITE " <<-- OUT OF BALANCE"
+26 WRITE !," Admin Balance:",$JUSTIFY($PIECE(RCBALANC,"^",3),12,2),$JUSTIFY($PIECE(RCDATA7,"^",3),12,2)
+27 IF +$PIECE(RCBALANC,"^",3)'=+$PIECE(RCDATA7,"^",3)
WRITE " <<-- OUT OF BALANCE"
+28 WRITE !," MF Balance:",$JUSTIFY($PIECE(RCBALANC,"^",4),12,2),$JUSTIFY($PIECE(RCDATA7,"^",4),12,2)
+29 IF +$PIECE(RCBALANC,"^",4)'=+$PIECE(RCDATA7,"^",4)
WRITE " <<-- OUT OF BALANCE"
+30 WRITE !," CC Balance:",$JUSTIFY($PIECE(RCBALANC,"^",5),12,2),$JUSTIFY($PIECE(RCDATA7,"^",5),12,2)
+31 IF +$PIECE(RCBALANC,"^",5)'=+$PIECE(RCDATA7,"^",5)
WRITE " <<-- OUT OF BALANCE"
+32 WRITE !," ------- ",$JUSTIFY("-------------",12),$JUSTIFY("-------------",12)
+33 WRITE !," TOTAL:",$JUSTIFY(TOTALCAL,12,2),$JUSTIFY(TOTALSTO,12,2)
+34 IF +TOTALCAL'=+TOTALSTO
WRITE " <<-- OUT OF BALANCE"
+35 ;
+36 ; ask to fix the balances
+37 SET Y=$$ASKFIX
IF Y'=1
WRITE !," NOTE: You must fix the Balance Discrepancy before processing an adjustment!"
SET RCBILLDA=0
QUIT
+38 ;
+39 ; fix it
+40 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+41 ; principal
SET RCFDA(430,RCBILLDA_",",71)=+$PIECE(RCBALANC,"^",1)
+42 ; interest
SET RCFDA(430,RCBILLDA_",",72)=+$PIECE(RCBALANC,"^",2)
+43 ; admin
SET RCFDA(430,RCBILLDA_",",73)=+$PIECE(RCBALANC,"^",3)
+44 ; marshal fee
SET RCFDA(430,RCBILLDA_",",74)=+$PIECE(RCBALANC,"^",4)
+45 ; court cost
SET RCFDA(430,RCBILLDA_",",75)=+$PIECE(RCBALANC,"^",5)
+46 DO FILE^DIE(,"RCFDA")
+47 ;
+48 WRITE !," Balance Discrepancy FIXED!"
End DoDot:1
IF RCBILLDA<1
DO UNLOCK
QUIT
+49 ;
+50 ; if the principal balance is zero, do not allow it to be adjusted
+51 ; ask to close/cancel it
+52 IF RCBETYPE="DECREASE"
IF '$GET(^PRCA(430,RCBILLDA,7))
WRITE !!,"Note: This bill has NO PRINCIPAL BALANCE to decrease !"
DO INTADMIN(RCBILLDA)
DO UNLOCK
QUIT
+53 ;
+54 ; If entry is from EDI Lockbox worklist, display total adjustments in ERA
+55 NEW AP
Begin DoDot:1
+56 NEW BILL,EOB,ERA,SEQ
SET ERA=""
SET AP=0
+57 FOR
SET ERA=$ORDER(^RCY(344.4,"AP",1,ERA))
if 'ERA
QUIT
Begin DoDot:2
+58 SET SEQ=0
+59 FOR
SET SEQ=$ORDER(^RCY(344.4,"AP",1,ERA,SEQ))
if 'SEQ
QUIT
Begin DoDot:3
+60 SET EOB=$PIECE($GET(^RCY(344.4,ERA,1,SEQ,0)),U,2)
if 'EOB
QUIT
+61 ;IA #4051
if $PIECE($GET(^IBM(361.1,EOB,0)),U)=RCBILLDA
SET AP=1
End DoDot:3
if AP
QUIT
End DoDot:2
if AP
QUIT
End DoDot:1
+62 ;
+63 ; Ask to enter transaction even though it is marked for autopost PRCA*4.5*298
+64 IF RCBETYPE="DECREASE"
IF AP
SET Y=$$ASKAUPO()
IF Y'=1
WRITE !,"Exiting bill adjustment."
DO UNLOCK
QUIT
+65 ;
+66 ; Display warning for decrease adjustment if pending payments exist
+67 ; PRCA*4.5*326
IF RCBETYPE="DECREASE"
DO WARN^RCBEADJ1(RCBILLDA)
+68 ;
+69 ; ask to enter adjustment amount
+70 SET RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
+71 IF RCAMOUNT<0
DO UNLOCK
QUIT
+72 ;
+73 ; if decrease, make negative
+74 IF RCBETYPE="DECREASE"
SET RCAMOUNT=-RCAMOUNT
+75 ;
+76 ; ask if it is a contract adjustment (Community Care added check for all 3rd party categories PRCA*4.5*338)
+77 IF RCBETYPE="DECREASE"
IF $$THRDPRTY(RCBILLDA)
SET RCONTADJ=$$ASKCONT
IF RCONTADJ<0
DO UNLOCK
QUIT
+78 ;
+79 ; show what the new transaction will look like
+80 SET RCDATA7=$GET(^PRCA(430,RCBILLDA,7))
+81 WRITE !!,"If you process the transaction, the bill will look like:"
+82 WRITE !,"Current Principal Balance: ",$JUSTIFY($PIECE(RCDATA7,"^"),11,2)
+83 WRITE !," NEW ",RCBETYPE," Adjustment: ",$JUSTIFY(RCAMOUNT,11,2)
+84 WRITE !," -----------"
+85 WRITE !," NEW Principal Balance: ",$JUSTIFY($PIECE(RCDATA7,"^")+RCAMOUNT,11,2)
+86 ;
+87 ; ask to enter transaction
+88 SET Y=$$ASKOK(RCBETYPE)
IF Y'=1
DO UNLOCK
QUIT
+89 ;
ADDADJ ; add adjustment
+1 NEW BILL
+2 SET RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$GET(RCONTADJ))
+3 ; used in ^RCTCSPD5 PRCA*4.5*420
SET BILL=RCBILLDA
+4 IF 'RCTRANDA
WRITE !," *** W A R N I N G: Adjustment NOT Processed! ***"
DO UNLOCK
QUIT
+5 IF RCTRANDA
WRITE !," Adjustment Transaction: ",RCTRANDA," has been added."
+6 ;prca*4.5*301 add cs decrease adjustment
IF RCTRANDA
IF '$GET(RCEDIWL)
IF (RCBETYPE="DECREASE")
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
DO DECADJ^RCTCSPU(RCBILLDA,RCTRANDA)
+7 IF RCTRANDA
IF $GET(RCTRREV)=0
SET PRCABN=RCBILLDA
DO CSITRN^RCTCSPD5
+8 ;PRCA*4.5*315/DRF add cs increase adjustment
IF RCTRANDA
IF $GET(RCTRREV)=0
IF '$GET(RCEDIWL)
IF (RCBETYPE="INCREASE")
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
SET PRCABN=RCBILLDA
DO INCADJ^RCTCSPU(RCBILLDA,RCTRANDA)
+9 IF $GET(RCTRREV)=1
SET PRCABN=RCBILLDA
DO CSITRY^RCTCSPD5
+10 IF '$GET(REFMS)&(DT>$$LDATE^RCRJR(DT))
SET Y=$EXTRACT($$FPS^RCAMFN01(DT,1),1,5)_"01"
DO DD^%DT
WRITE !!," * * * * Transmission will be held until "_Y_" * * * *"
+11 ;
+12 ; ask to enter a comment
+13 WRITE !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
+14 SET Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
+15 ;
+16 ; ask to exempt interest and admin charges
+17 IF RCBETYPE="DECREASE"
DO INTADMIN(RCBILLDA)
+18 ;
+19 ; notification of subsequent payer bulletin
+20 SET RCDATA7=$GET(^PRCA(430,RCBILLDA,7))
SET X=0
+21 FOR I=1:1:5
SET X=X+$PIECE(RCDATA7,"^",I)
+22 IF RCDATA7'=""
IF 'X
Begin DoDot:1
+23 NEW PRCABN,PRCAEN,PRCAMT
+24 SET PRCABN=RCBILLDA
SET PRCAEN=RCTRANDA
SET PRCAMT=+$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",5)
+25 DO EOB^PRCADJ
End DoDot:1
+26 ;
+27 ; unlock and ask the next bill to adjust
+28 DO UNLOCK
+29 QUIT
+30 ;
+31 ;
UNLOCK ; unlock bill and transaction
+1 LOCK -^PRCA(430,RCBILLDA)
+2 IF $GET(RCTRANDA)
LOCK -^PRCA(433,RCTRANDA)
+3 QUIT
+4 ;
+5 ;
INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
+1 NEW RCAMOUNT,RCTRANDA,Y
+2 ;
+3 ; check to see if there is interest and admin charges
+4 SET RCAMOUNT=$GET(^PRCA(430,RCBILLDA,7))
+5 IF '$PIECE(RCAMOUNT,"^",2)
IF '$PIECE(RCAMOUNT,"^",3)
IF '$PIECE(RCAMOUNT,"^",4)
IF '$PIECE(RCAMOUNT,"^",5)
QUIT
+6 ;
+7 ; only ask if there is no principal
+8 IF RCAMOUNT
QUIT
+9 ;
+10 WRITE !!,"You have the option to automatically EXEMPT the interest"
+11 WRITE !,"and administrative charges. This will close the bill."
+12 SET Y=$$ASKEXEMP
IF Y'=1
QUIT
+13 ;
+14 WRITE !!,"Creating an EXEMPT transaction ..."
+15 SET RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$PIECE(RCAMOUNT,"^",2)_"^"_$PIECE(RCAMOUNT,"^",3)_"^^"_$PIECE(RCAMOUNT,"^",4)_"^"_$PIECE(RCAMOUNT,"^",5))
+16 IF 'RCTRANDA
WRITE !," *** W A R N I N G: EXEMPTION NOT Processed! ***"
QUIT
+17 IF RCTRANDA
WRITE !," Exempt Transaction: ",RCTRANDA," has been added."
INTC35B ;Check if CS5B entry needed for exempt transaction
+1 ;prca*4.5*301 add cs exempt
IF RCTRANDA
IF '$GET(RCEDIWL)
IF (RCBETYPE="DECREASE")
IF $DATA(^PRCA(430,"TCSP",RCBILLDA))
DO DECADJ^RCTCSPU(RCBILLDA,RCTRANDA)
+2 IF '$GET(REFMS)&(DT>$$LDATE^RCRJR(DT))
SET Y=$EXTRACT($$FPS^RCAMFN01(DT,1),1,5)_"01"
DO DD^%DT
WRITE !!," * * * * Transmission will be held until "_Y_" * * * *"
+3 ;
+4 WRITE !," Current Bill Status: ",$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
+5 QUIT
+6 ;
ASKOK(RCBETYPE) ; ask record decrease or increase transaction
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="YES"
+3 SET DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
+4 WRITE !
DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
ASKAUPO() ; ask record even though marked for auto post PRCA*4.5*298
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YOA"
SET DIR("B")="NO"
+3 SET DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
+4 WRITE !
DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
+8 ;PATCH 313
ASKFIX() ; ask to fix bill's balance
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="YES"
+3 ;S DIR(0)="YO",DIR("B")="NO"
+4 SET DIR("A")=" Do you want to FIX the balance discrepancy "
+5 WRITE !
DO ^DIR
+6 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+7 QUIT Y
+8 ;
+9 ;
ASKEXEMP() ; ask to record an exempt transaction
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="NO"
+3 SET DIR("A")=" Would you like to EXEMPT the interest and admin charges "
+4 DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
+8 ;
ASKCONT() ; ask if contract adjustment
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="YES"
+3 SET DIR("A")=" Is this a CONTRACT adjustment "
+4 WRITE !
DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
+8 ;
ASKREV() ; Ask if Treasury reversal *315/DRF
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="NO"
+3 SET DIR("A")=" Is this a TREASURY reversal "
+4 WRITE !
DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
+8 ;
ADJNUM(RCBILLDA) ; get next adjustment number for a bill
+1 NEW %,ADJUST,DATA1,RCTRANDA
+2 SET RCTRANDA=0
+3 FOR
SET RCTRANDA=$ORDER(^PRCA(433,"C",RCBILLDA,RCTRANDA))
if 'RCTRANDA
QUIT
SET DATA1=$GET(^PRCA(433,RCTRANDA,1))
IF $PIECE(DATA1,"^",4)
IF $PIECE(DATA1,"^",2)=1!($PIECE(DATA1,"^",2)=35)
SET ADJUST=$PIECE(DATA1,"^",4)+1
+4 QUIT ADJUST
+5 ;
+6 ;
AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
+1 NEW DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
+2 SET PRINBAL=+$PIECE($GET(^PRCA(430,RCBILLDA,7)),"^")
+3 IF RCBETYPE="INCREASE"
SET PRINBAL=9999999.99
+4 WRITE !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$JUSTIFY(PRINBAL,0,2),"."
+5 SET DIR(0)="NAO^.01:"_PRINBAL_":2"
+6 SET DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
+7 DO ^DIR
+8 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+9 QUIT $SELECT(Y'="":Y,1:-1)
+10 ;
ASKCM() ; ask if the action is being performed due to the claims matching process *315
+1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YO"
SET DIR("B")="NO"
+3 SET DIR("A")="Is this action being performed due to the CLAIMS MATCHING process "
+4 DO ^DIR
+5 ; account profile listman quit flag *315
IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
IF $GET(GOTBILL)
SET RCDPGQ=1
+6 QUIT Y
+7 ;
+8 ;
THRDPRTY(RCBILLDA) ; check whether or not bill is THIRD PARTY
+1 NEW CAT
+2 ; get account receivable category
SET CAT=$$GET1^DIQ(430,RCBILLDA,2,"I")
+3 ; return true if AR Category is THIRD PARTY
IF $$GET1^DIQ(430.2,CAT,5,"I")="T"
QUIT 1
+4 QUIT 0
