RCBEADJI ;LL/ELZ-API FOR IB IN SETTLEMENT ;25-APR-2002
;;4.5;Accounts Receivable;**180**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
DECREASE(RCBN,RCTEST,RCAMT) ; create a decrease adjustment for a bill
; this will decreace the full balance and return info.
;
; input: RCBN = bill number
; RCTEST = optional flag to indicate test mode only
; RCAMT = optional specific amount to adjust
;
; output: -(error number) ^ error message
; OR
; decrease adjust DA ^ decrease amt ^ int amout ^ admin amt
; ^ marshal amt ^ court amt
;
;
N RCBILLDA,RCBETYPE,RCTRANDA,STATUS,RCCAT,RCCATEG,RCRESP
S RCBETYPE="DECREASE",RCTEST=+$G(RCTEST)
;
; get bill ien
S RCBILLDA=$O(^PRCA(430,"D",RCBN,0))
I RCBILLDA<1 S RCRESP="-3^Bill Number Not Found" G DECQ
;
; bill must be active
S STATUS=$P($G(^PRCA(430,RCBILLDA,0)),"^",8)
I STATUS'=16,STATUS'=42 S RCRESP="-4^Bill Not Active" G DECQ
;
; determine if bill can be adjusted based on category
D RCCAT^RCRCUTL(.RCCAT) ;returns rccat(category) array
S RCCATEG=+$P(^PRCA(430,RCBILLDA,0),"^",2)
I +$G(RCCAT(RCCATEG))=1,$$REFST^RCRCUTL(RCBILLDA) S RCRESP="-5^Bill is Referred" G DECQ
I RCCATEG=26 S RCRESP="-6^No Pre-Payment Bills" G DECQ
;
;
; adjust the bill
S RCRESP=$$ADJBILL(RCBETYPE,RCBILLDA,$G(RCAMT))
;
DECQ Q RCRESP
;
;
ADJBILL(RCBETYPE,RCBILLDA,RCAMT) ; adjust a bill
N RCAMOUNT,RCBALANC,RCDATA7,RCONTADJ,RCTRANDA,I,X,Y,RCINT,RCCOM,RCERR
; lock the bill
L +^PRCA(430,RCBILLDA):5 I '$T Q "-7^Bill is Locked"
;
;
; check the balance of the bill
S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
;
; out of balance
I RCBALANC'="" D UNLOCK Q "-8^Bill is Out of Balance"
;
; if the principal balance is zero, do not allow it to be adjusted
; close/cancel it
I '$G(^PRCA(430,RCBILLDA,7)) S RCINT=$$INTADMIN(RCBILLDA,RCTEST) D UNLOCK Q "-9^No Principal to Decrease^"_RCINT
;
; adjustment amount
S RCAMOUNT=$$AMOUNT(RCBILLDA)
S RCAMOUNT=$S(RCAMT&(RCAMT'>RCAMOUNT):RCAMT,1:RCAMOUNT)
I RCAMOUNT<.01 D UNLOCK Q "-10^No Amount Returned"
;
; make negative
S RCAMOUNT=-RCAMOUNT
;
; if it is a contract adjustment
I "^9^28^29^30^32^"[("^"_$P($G(^PRCA(430,RCBILLDA,0)),"^",2)_"^") S RCONTADJ=1
;
;
S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
;
; add adjustment
I 'RCTEST S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
I 'RCTEST,'RCTRANDA D UNLOCK Q "-11^Adjustment NOT Processed"
;
; mark flag for settlement
I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
;
; enter a comment
S RCCOM(1,0)="Hartford/USAA Litigation Settlement."
I 'RCTEST D WP^DIE(433,RCTRANDA_",",41,"","RCCOM","RCERR")
I $D(RCERR) D UNLOCK Q "-12^Comment Error"
;
; exempt interest and admin charges
S RCINT=$S(RCTEST:$$INTADMIN(RCBILLDA,RCTEST),$$AMOUNT(RCBILLDA):"0^0^0^0",1:$$INTADMIN(RCBILLDA,RCTEST))
;
;
D UNLOCK
Q $G(RCTRANDA)_"^"_(-$G(RCAMOUNT))_"^"_$G(RCINT)
;
;
UNLOCK ; unlock bill and transaction
L -^PRCA(430,RCBILLDA)
I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
Q
;
;
INTADMIN(RCBILLDA,RCTEST) ; adjust the interest and admin
;
; Return is the amounts adjusted:
; interest ^ admin ^ marshal ^ court
;
; OR if error: - (error number) ^ error message
;
N RCAMOUNT,RCTRANDA,Y,X
;
; 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 "0^0^0^0"
;
; only if there is no principal
I 'RCTEST,RCAMOUNT Q "-13^balance still there"
;
;
I 'RCTEST S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
I 'RCTEST,'RCTRANDA Q "-14^Error processing exemption"
;
; flag transaction for settlement
I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
;
Q $P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5)
;
;
;
;
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) ; adjustment amount for a bill
;
Q +$P($G(^PRCA(430,RCBILLDA,7)),"^")
;
TEST ; This entry point is only to be used for testing and NEVER in a
; production system. This will make all the referred bills in the
; 430 file that are referred appear to no longer be referred.
N IBA,IBB,DIE,DA,DR
S IBA=0 F S IBA=$O(^PRCA(430,"AD",IBA)) Q:IBA<1 S IBB=0 F S IBB=$O(^PRCA(430,"AD",IBA,IBB)) Q:IBB<1 S DIE="^PRCA(430,",DA=IBB,DR="64///@" D ^DIE W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEADJI 4881 printed Apr 09, 2024@20:52:45 Page 2
RCBEADJI ;LL/ELZ-API FOR IB IN SETTLEMENT ;25-APR-2002
+1 ;;4.5;Accounts Receivable;**180**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
DECREASE(RCBN,RCTEST,RCAMT) ; create a decrease adjustment for a bill
+1 ; this will decreace the full balance and return info.
+2 ;
+3 ; input: RCBN = bill number
+4 ; RCTEST = optional flag to indicate test mode only
+5 ; RCAMT = optional specific amount to adjust
+6 ;
+7 ; output: -(error number) ^ error message
+8 ; OR
+9 ; decrease adjust DA ^ decrease amt ^ int amout ^ admin amt
+10 ; ^ marshal amt ^ court amt
+11 ;
+12 ;
+13 NEW RCBILLDA,RCBETYPE,RCTRANDA,STATUS,RCCAT,RCCATEG,RCRESP
+14 SET RCBETYPE="DECREASE"
SET RCTEST=+$GET(RCTEST)
+15 ;
+16 ; get bill ien
+17 SET RCBILLDA=$ORDER(^PRCA(430,"D",RCBN,0))
+18 IF RCBILLDA<1
SET RCRESP="-3^Bill Number Not Found"
GOTO DECQ
+19 ;
+20 ; bill must be active
+21 SET STATUS=$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",8)
+22 IF STATUS'=16
IF STATUS'=42
SET RCRESP="-4^Bill Not Active"
GOTO DECQ
+23 ;
+24 ; determine if bill can be adjusted based on category
+25 ;returns rccat(category) array
DO RCCAT^RCRCUTL(.RCCAT)
+26 SET RCCATEG=+$PIECE(^PRCA(430,RCBILLDA,0),"^",2)
+27 IF +$GET(RCCAT(RCCATEG))=1
IF $$REFST^RCRCUTL(RCBILLDA)
SET RCRESP="-5^Bill is Referred"
GOTO DECQ
+28 IF RCCATEG=26
SET RCRESP="-6^No Pre-Payment Bills"
GOTO DECQ
+29 ;
+30 ;
+31 ; adjust the bill
+32 SET RCRESP=$$ADJBILL(RCBETYPE,RCBILLDA,$GET(RCAMT))
+33 ;
DECQ QUIT RCRESP
+1 ;
+2 ;
ADJBILL(RCBETYPE,RCBILLDA,RCAMT) ; adjust a bill
+1 NEW RCAMOUNT,RCBALANC,RCDATA7,RCONTADJ,RCTRANDA,I,X,Y,RCINT,RCCOM,RCERR
+2 ; lock the bill
+3 LOCK +^PRCA(430,RCBILLDA):5
IF '$TEST
QUIT "-7^Bill is Locked"
+4 ;
+5 ;
+6 ; check the balance of the bill
+7 SET RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
+8 ;
+9 ; out of balance
+10 IF RCBALANC'=""
DO UNLOCK
QUIT "-8^Bill is Out of Balance"
+11 ;
+12 ; if the principal balance is zero, do not allow it to be adjusted
+13 ; close/cancel it
+14 IF '$GET(^PRCA(430,RCBILLDA,7))
SET RCINT=$$INTADMIN(RCBILLDA,RCTEST)
DO UNLOCK
QUIT "-9^No Principal to Decrease^"_RCINT
+15 ;
+16 ; adjustment amount
+17 SET RCAMOUNT=$$AMOUNT(RCBILLDA)
+18 SET RCAMOUNT=$SELECT(RCAMT&(RCAMT'>RCAMOUNT):RCAMT,1:RCAMOUNT)
+19 IF RCAMOUNT<.01
DO UNLOCK
QUIT "-10^No Amount Returned"
+20 ;
+21 ; make negative
+22 SET RCAMOUNT=-RCAMOUNT
+23 ;
+24 ; if it is a contract adjustment
+25 IF "^9^28^29^30^32^"[("^"_$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",2)_"^")
SET RCONTADJ=1
+26 ;
+27 ;
+28 SET RCDATA7=$GET(^PRCA(430,RCBILLDA,7))
+29 ;
+30 ; add adjustment
+31 IF 'RCTEST
SET RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$GET(RCONTADJ))
+32 IF 'RCTEST
IF 'RCTRANDA
DO UNLOCK
QUIT "-11^Adjustment NOT Processed"
+33 ;
+34 ; mark flag for settlement
+35 IF 'RCTEST
SET $PIECE(^PRCA(433,RCTRANDA,9),"^",3)=1
+36 ;
+37 ; enter a comment
+38 SET RCCOM(1,0)="Hartford/USAA Litigation Settlement."
+39 IF 'RCTEST
DO WP^DIE(433,RCTRANDA_",",41,"","RCCOM","RCERR")
+40 IF $DATA(RCERR)
DO UNLOCK
QUIT "-12^Comment Error"
+41 ;
+42 ; exempt interest and admin charges
+43 SET RCINT=$SELECT(RCTEST:$$INTADMIN(RCBILLDA,RCTEST),$$AMOUNT(RCBILLDA):"0^0^0^0",1:$$INTADMIN(RCBILLDA,RCTEST))
+44 ;
+45 ;
+46 DO UNLOCK
+47 QUIT $GET(RCTRANDA)_"^"_(-$GET(RCAMOUNT))_"^"_$GET(RCINT)
+48 ;
+49 ;
UNLOCK ; unlock bill and transaction
+1 LOCK -^PRCA(430,RCBILLDA)
+2 IF $GET(RCTRANDA)
LOCK -^PRCA(433,RCTRANDA)
+3 QUIT
+4 ;
+5 ;
INTADMIN(RCBILLDA,RCTEST) ; adjust the interest and admin
+1 ;
+2 ; Return is the amounts adjusted:
+3 ; interest ^ admin ^ marshal ^ court
+4 ;
+5 ; OR if error: - (error number) ^ error message
+6 ;
+7 NEW RCAMOUNT,RCTRANDA,Y,X
+8 ;
+9 ; check to see if there is interest and admin charges
+10 SET RCAMOUNT=$GET(^PRCA(430,RCBILLDA,7))
+11 IF '$PIECE(RCAMOUNT,"^",2)
IF '$PIECE(RCAMOUNT,"^",3)
IF '$PIECE(RCAMOUNT,"^",4)
IF '$PIECE(RCAMOUNT,"^",5)
QUIT "0^0^0^0"
+12 ;
+13 ; only if there is no principal
+14 IF 'RCTEST
IF RCAMOUNT
QUIT "-13^balance still there"
+15 ;
+16 ;
+17 IF 'RCTEST
SET RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$PIECE(RCAMOUNT,"^",2)_"^"_$PIECE(RCAMOUNT,"^",3)_"^^"_$PIECE(RCAMOUNT,"^",4)_"^"_$PIECE(RCAMOUNT,"^",5))
+18 IF 'RCTEST
IF 'RCTRANDA
QUIT "-14^Error processing exemption"
+19 ;
+20 ; flag transaction for settlement
+21 IF 'RCTEST
SET $PIECE(^PRCA(433,RCTRANDA,9),"^",3)=1
+22 ;
+23 QUIT $PIECE(RCAMOUNT,"^",2)_"^"_$PIECE(RCAMOUNT,"^",3)_"^^"_$PIECE(RCAMOUNT,"^",4)_"^"_$PIECE(RCAMOUNT,"^",5)
+24 ;
+25 ;
+26 ;
+27 ;
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) ; adjustment amount for a bill
+1 ;
+2 QUIT +$PIECE($GET(^PRCA(430,RCBILLDA,7)),"^")
+3 ;
TEST ; This entry point is only to be used for testing and NEVER in a
+1 ; production system. This will make all the referred bills in the
+2 ; 430 file that are referred appear to no longer be referred.
+3 NEW IBA,IBB,DIE,DA,DR
+4 SET IBA=0
FOR
SET IBA=$ORDER(^PRCA(430,"AD",IBA))
if IBA<1
QUIT
SET IBB=0
FOR
SET IBB=$ORDER(^PRCA(430,"AD",IBA,IBB))
if IBB<1
QUIT
SET DIE="^PRCA(430,"
SET DA=IBB
SET DR="64///@"
DO ^DIE
WRITE "."
+5 QUIT
