Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCBEADJ

RCBEADJ.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. DECREASE ; menu option: create a decrease adjustment
  1. D ADJUST("DECREASE")
  1. Q
  1. ;
  1. ;
  1. INCREASE ; menu option: create an increase adjustment
  1. D ADJUST("INCREASE")
  1. Q
  1. ;
  1. ADJUST(RCBETYPE,RCEDI) ; create an adjustment
  1. ; rcbetype = INCREASE for increase or DECREASE for decrease
  1. ; rcedi = the ien of the bill selected via the EDI Worklist;ien of
  1. ; XX the ERA entry or null/undefined if bill should be selected
  1. I '$G(GOTBILL) N RCBILLDA ;PRCA*4.5*315 If entering from worklist
  1. F D Q:RCBILLDA<0!$G(RCEDI)!$G(GOTBILL)
  1. . K RCTRANDA,RCLIST,RCTRREV
  1. . ;
  1. . ; select a bill
  1. . I '$G(GOTBILL) S RCBILLDA=$S('$G(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI) ;PRCA*4.5*315
  1. . I RCBILLDA<1 Q
  1. . I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="INCREASE") D ;PRCA*4.5*315/DRF
  1. .. S RCTRREV=$$ASKREV()
  1. .. W !
  1. . I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="DECREASE") S %=$$ASKCM Q:(%'=1) ; prca*4.5*301 & *315
  1. . ;
  1. . ; adjust the bill
  1. . D ADJBILL(RCBETYPE,RCBILLDA,$P($G(RCEDI),";",2))
  1. Q
  1. ;
  1. ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ; adjust a bill
  1. ; RCEDIWL = ien of ERA entry if called from worklist
  1. N RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y,RCFDA
  1. ; lock the bill
  1. L +^PRCA(430,RCBILLDA):5 E W !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS BILL." Q
  1. ;
  1. ; show data for the bill
  1. D SHOWBILL^RCWROFF1(RCBILLDA)
  1. ;
  1. ; check the balance of the bill
  1. W !!,"Checking the bill's balance ..."
  1. S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
  1. I RCBALANC="" W " IN Balance!"
  1. ;
  1. ; out of balance, ask to fix it
  1. I RCBALANC'="" D I RCBILLDA<1 D UNLOCK Q
  1. . S TOTALCAL=$P(RCBALANC,"^")+$P(RCBALANC,"^",2)+$P(RCBALANC,"^",3)+$P(RCBALANC,"^",4)+$P(RCBALANC,"^",5)
  1. . S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
  1. . S TOTALSTO=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,"^",4)+$P(RCDATA7,"^",5)
  1. . W " OUT of Balance!"
  1. . W !!," BALANCE:",$J("Calculated",12),$J("Stored",12)
  1. . W !," ------- ",$J("------------",12),$J("------------",12)
  1. . W !," Principal Balance:",$J($P(RCBALANC,"^",1),12,2),$J($P(RCDATA7,"^",1),12,2)
  1. . I +$P(RCBALANC,"^",1)'=+$P(RCDATA7,"^",1) W " <<-- OUT OF BALANCE"
  1. . W !," Interest Balance:",$J($P(RCBALANC,"^",2),12,2),$J($P(RCDATA7,"^",2),12,2)
  1. . I +$P(RCBALANC,"^",2)'=+$P(RCDATA7,"^",2) W " <<-- OUT OF BALANCE"
  1. . W !," Admin Balance:",$J($P(RCBALANC,"^",3),12,2),$J($P(RCDATA7,"^",3),12,2)
  1. . I +$P(RCBALANC,"^",3)'=+$P(RCDATA7,"^",3) W " <<-- OUT OF BALANCE"
  1. . W !," MF Balance:",$J($P(RCBALANC,"^",4),12,2),$J($P(RCDATA7,"^",4),12,2)
  1. . I +$P(RCBALANC,"^",4)'=+$P(RCDATA7,"^",4) W " <<-- OUT OF BALANCE"
  1. . W !," CC Balance:",$J($P(RCBALANC,"^",5),12,2),$J($P(RCDATA7,"^",5),12,2)
  1. . I +$P(RCBALANC,"^",5)'=+$P(RCDATA7,"^",5) W " <<-- OUT OF BALANCE"
  1. . W !," ------- ",$J("-------------",12),$J("-------------",12)
  1. . W !," TOTAL:",$J(TOTALCAL,12,2),$J(TOTALSTO,12,2)
  1. . I +TOTALCAL'=+TOTALSTO W " <<-- OUT OF BALANCE"
  1. . ;
  1. . ; ask to fix the balances
  1. . S Y=$$ASKFIX I Y'=1 W !," NOTE: You must fix the Balance Discrepancy before processing an adjustment!" S RCBILLDA=0 Q
  1. . ;
  1. . ; fix it
  1. . ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
  1. . S RCFDA(430,RCBILLDA_",",71)=+$P(RCBALANC,"^",1) ; principal
  1. . S RCFDA(430,RCBILLDA_",",72)=+$P(RCBALANC,"^",2) ; interest
  1. . S RCFDA(430,RCBILLDA_",",73)=+$P(RCBALANC,"^",3) ; admin
  1. . S RCFDA(430,RCBILLDA_",",74)=+$P(RCBALANC,"^",4) ; marshal fee
  1. . S RCFDA(430,RCBILLDA_",",75)=+$P(RCBALANC,"^",5) ; court cost
  1. . D FILE^DIE(,"RCFDA")
  1. . ;
  1. . W !," Balance Discrepancy FIXED!"
  1. ;
  1. ; if the principal balance is zero, do not allow it to be adjusted
  1. ; ask to close/cancel it
  1. I RCBETYPE="DECREASE",'$G(^PRCA(430,RCBILLDA,7)) W !!,"Note: This bill has NO PRINCIPAL BALANCE to decrease !" D INTADMIN(RCBILLDA),UNLOCK Q
  1. ;
  1. ; If entry is from EDI Lockbox worklist, display total adjustments in ERA
  1. N AP D
  1. .N BILL,EOB,ERA,SEQ S ERA="",AP=0
  1. .F S ERA=$O(^RCY(344.4,"AP",1,ERA)) Q:'ERA D Q:AP
  1. ..S SEQ=0
  1. ..F S SEQ=$O(^RCY(344.4,"AP",1,ERA,SEQ)) Q:'SEQ D Q:AP
  1. ...S EOB=$P($G(^RCY(344.4,ERA,1,SEQ,0)),U,2) Q:'EOB
  1. ...S:$P($G(^IBM(361.1,EOB,0)),U)=RCBILLDA AP=1 ;IA #4051
  1. ;
  1. ; Ask to enter transaction even though it is marked for autopost PRCA*4.5*298
  1. I RCBETYPE="DECREASE",AP S Y=$$ASKAUPO() I Y'=1 W !,"Exiting bill adjustment." D UNLOCK Q
  1. ;
  1. ; Display warning for decrease adjustment if pending payments exist
  1. I RCBETYPE="DECREASE" D WARN^RCBEADJ1(RCBILLDA) ; PRCA*4.5*326
  1. ;
  1. ; ask to enter adjustment amount
  1. S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
  1. I RCAMOUNT<0 D UNLOCK Q
  1. ;
  1. ; if decrease, make negative
  1. I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
  1. ;
  1. ; ask if it is a contract adjustment (Community Care added check for all 3rd party categories PRCA*4.5*338)
  1. I RCBETYPE="DECREASE",$$THRDPRTY(RCBILLDA) S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
  1. ;
  1. ; show what the new transaction will look like
  1. S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
  1. W !!,"If you process the transaction, the bill will look like:"
  1. W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),11,2)
  1. W !," NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,11,2)
  1. W !," -----------"
  1. W !," NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,11,2)
  1. ;
  1. ; ask to enter transaction
  1. S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
  1. ;
  1. ADDADJ ; add adjustment
  1. N BILL
  1. S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
  1. S BILL=RCBILLDA ; used in ^RCTCSPD5 PRCA*4.5*420
  1. I 'RCTRANDA W !," *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK Q
  1. I RCTRANDA W !," Adjustment Transaction: ",RCTRANDA," has been added."
  1. I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs decrease adjustment
  1. I RCTRANDA,$G(RCTRREV)=0 S PRCABN=RCBILLDA D CSITRN^RCTCSPD5
  1. 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
  1. I $G(RCTRREV)=1 S PRCABN=RCBILLDA D CSITRY^RCTCSPD5
  1. 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_" * * * *"
  1. ;
  1. ; ask to enter a comment
  1. W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
  1. S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
  1. ;
  1. ; ask to exempt interest and admin charges
  1. I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
  1. ;
  1. ; notification of subsequent payer bulletin
  1. S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
  1. F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
  1. I RCDATA7'="",'X D
  1. . N PRCABN,PRCAEN,PRCAMT
  1. . S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
  1. . D EOB^PRCADJ
  1. ;
  1. ; unlock and ask the next bill to adjust
  1. D UNLOCK
  1. Q
  1. ;
  1. ;
  1. UNLOCK ; unlock bill and transaction
  1. L -^PRCA(430,RCBILLDA)
  1. I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
  1. Q
  1. ;
  1. ;
  1. INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
  1. N RCAMOUNT,RCTRANDA,Y
  1. ;
  1. ; check to see if there is interest and admin charges
  1. S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
  1. I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q
  1. ;
  1. ; only ask if there is no principal
  1. I RCAMOUNT Q
  1. ;
  1. W !!,"You have the option to automatically EXEMPT the interest"
  1. W !,"and administrative charges. This will close the bill."
  1. S Y=$$ASKEXEMP I Y'=1 Q
  1. ;
  1. W !!,"Creating an EXEMPT transaction ..."
  1. S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
  1. I 'RCTRANDA W !," *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
  1. I RCTRANDA W !," Exempt Transaction: ",RCTRANDA," has been added."
  1. INTC35B ;Check if CS5B entry needed for exempt transaction
  1. I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs exempt
  1. 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_" * * * *"
  1. ;
  1. W !," Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
  1. Q
  1. ;
  1. ASKOK(RCBETYPE) ; ask record decrease or increase transaction
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="YES"
  1. S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ASKAUPO() ; ask record even though marked for auto post PRCA*4.5*298
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YOA",DIR("B")="NO"
  1. S DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;PATCH 313
  1. ASKFIX() ; ask to fix bill's balance
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="YES"
  1. ;S DIR(0)="YO",DIR("B")="NO"
  1. S DIR("A")=" Do you want to FIX the balance discrepancy "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;
  1. ASKEXEMP() ; ask to record an exempt transaction
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="NO"
  1. S DIR("A")=" Would you like to EXEMPT the interest and admin charges "
  1. D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;
  1. ASKCONT() ; ask if contract adjustment
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="YES"
  1. S DIR("A")=" Is this a CONTRACT adjustment "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;
  1. ASKREV() ; Ask if Treasury reversal *315/DRF
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="NO"
  1. S DIR("A")=" Is this a TREASURY reversal "
  1. W ! D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;
  1. ADJNUM(RCBILLDA) ; get next adjustment number for a bill
  1. N %,ADJUST,DATA1,RCTRANDA
  1. S RCTRANDA=0
  1. 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
  1. Q ADJUST
  1. ;
  1. ;
  1. AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
  1. N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
  1. S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
  1. I RCBETYPE="INCREASE" S PRINBAL=9999999.99
  1. W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),"."
  1. S DIR(0)="NAO^.01:"_PRINBAL_":2"
  1. S DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
  1. D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q $S(Y'="":Y,1:-1)
  1. ;
  1. ASKCM() ; ask if the action is being performed due to the claims matching process *315
  1. N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="YO",DIR("B")="NO"
  1. S DIR("A")="Is this action being performed due to the CLAIMS MATCHING process "
  1. D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
  1. Q Y
  1. ;
  1. ;
  1. THRDPRTY(RCBILLDA) ; check whether or not bill is THIRD PARTY
  1. N CAT
  1. S CAT=$$GET1^DIQ(430,RCBILLDA,2,"I") ; get account receivable category
  1. I $$GET1^DIQ(430.2,CAT,5,"I")="T" Q 1 ; return true if AR Category is THIRD PARTY
  1. Q 0