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

RCBEADJI.m

Go to the documentation of this file. 
  1. RCBEADJI ;LL/ELZ-API FOR IB IN SETTLEMENT ;25-APR-2002
  1.  ;;4.5;Accounts Receivable;**180**;Mar 20, 1995
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;
  1. DECREASE(RCBN,RCTEST,RCAMT) ;  create a decrease adjustment for a bill
  1.  ;  this will decreace the full balance and return info.
  1.  ;
  1.  ;  input:  RCBN = bill number
  1.  ;          RCTEST = optional flag to indicate test mode only
  1.  ;          RCAMT = optional specific amount to adjust
  1.  ;
  1.  ; output:  -(error number) ^ error message
  1.  ;              OR
  1.  ;          decrease adjust DA ^ decrease amt ^ int amout ^ admin amt
  1.  ;          ^ marshal amt ^ court amt
  1.  ;
  1.  ;
  1.  N RCBILLDA,RCBETYPE,RCTRANDA,STATUS,RCCAT,RCCATEG,RCRESP
  1.  S RCBETYPE="DECREASE",RCTEST=+$G(RCTEST)
  1.  ;
  1.  ; get bill ien
  1.  S RCBILLDA=$O(^PRCA(430,"D",RCBN,0))
  1.  I RCBILLDA<1 S RCRESP="-3^Bill Number Not Found" G DECQ
  1.  ;
  1.  ;  bill must be active
  1.  S STATUS=$P($G(^PRCA(430,RCBILLDA,0)),"^",8)
  1.  I STATUS'=16,STATUS'=42 S RCRESP="-4^Bill Not Active" G DECQ
  1.  ;
  1.  ;  determine if bill can be adjusted based on category
  1.  D RCCAT^RCRCUTL(.RCCAT)  ;returns rccat(category) array
  1.  S RCCATEG=+$P(^PRCA(430,RCBILLDA,0),"^",2)
  1.  I +$G(RCCAT(RCCATEG))=1,$$REFST^RCRCUTL(RCBILLDA) S RCRESP="-5^Bill is Referred" G DECQ
  1.  I RCCATEG=26 S RCRESP="-6^No Pre-Payment Bills" G DECQ
  1.  ;
  1.  ;
  1.  ;  adjust the bill
  1.  S RCRESP=$$ADJBILL(RCBETYPE,RCBILLDA,$G(RCAMT))
  1.  ;
  1. DECQ Q RCRESP
  1.  ;
  1.  ;
  1. ADJBILL(RCBETYPE,RCBILLDA,RCAMT) ;  adjust a bill
  1.  N RCAMOUNT,RCBALANC,RCDATA7,RCONTADJ,RCTRANDA,I,X,Y,RCINT,RCCOM,RCERR
  1.  ;  lock the bill
  1.  L +^PRCA(430,RCBILLDA):5 I '$T Q "-7^Bill is Locked"
  1.  ;
  1.  ;
  1.  ;  check the balance of the bill
  1.  S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
  1.  ;
  1.  ;  out of balance
  1.  I RCBALANC'="" D UNLOCK Q "-8^Bill is Out of Balance"
  1.  ;
  1.  ;  if the principal balance is zero, do not allow it to be adjusted
  1.  ;  close/cancel it
  1.  I '$G(^PRCA(430,RCBILLDA,7)) S RCINT=$$INTADMIN(RCBILLDA,RCTEST) D UNLOCK Q "-9^No Principal to Decrease^"_RCINT
  1.  ;
  1.  ;  adjustment amount
  1.  S RCAMOUNT=$$AMOUNT(RCBILLDA)
  1.  S RCAMOUNT=$S(RCAMT&(RCAMT'>RCAMOUNT):RCAMT,1:RCAMOUNT)
  1.  I RCAMOUNT<.01 D UNLOCK Q "-10^No Amount Returned"
  1.  ;
  1.  ;  make negative
  1.  S RCAMOUNT=-RCAMOUNT
  1.  ;
  1.  ;  if it is a contract adjustment
  1.  I "^9^28^29^30^32^"[("^"_$P($G(^PRCA(430,RCBILLDA,0)),"^",2)_"^") S RCONTADJ=1
  1.  ;
  1.  ;
  1.  S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
  1.  ;
  1.  ;  add adjustment
  1.  I 'RCTEST S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
  1.  I 'RCTEST,'RCTRANDA D UNLOCK Q "-11^Adjustment NOT Processed"
  1.  ;
  1.  ; mark flag for settlement
  1.  I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
  1.  ;
  1.  ;  enter a comment
  1.  S RCCOM(1,0)="Hartford/USAA Litigation Settlement."
  1.  I 'RCTEST D WP^DIE(433,RCTRANDA_",",41,"","RCCOM","RCERR")
  1.  I $D(RCERR) D UNLOCK Q "-12^Comment Error"
  1.  ;
  1.  ;  exempt interest and admin charges
  1.  S RCINT=$S(RCTEST:$$INTADMIN(RCBILLDA,RCTEST),$$AMOUNT(RCBILLDA):"0^0^0^0",1:$$INTADMIN(RCBILLDA,RCTEST))
  1.  ;
  1.  ;
  1.  D UNLOCK
  1.  Q $G(RCTRANDA)_"^"_(-$G(RCAMOUNT))_"^"_$G(RCINT)
  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,RCTEST) ;  adjust the interest and admin
  1.  ;
  1.  ;   Return is the amounts adjusted:
  1.  ;         interest ^ admin ^ marshal ^ court
  1.  ;
  1.  ;   OR if error: - (error number) ^ error message
  1.  ;
  1.  N RCAMOUNT,RCTRANDA,Y,X
  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 "0^0^0^0"
  1.  ;
  1.  ;  only if there is no principal
  1.  I 'RCTEST,RCAMOUNT Q "-13^balance still there"
  1.  ;
  1.  ;
  1.  I 'RCTEST S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
  1.  I 'RCTEST,'RCTRANDA  Q "-14^Error processing exemption"
  1.  ;
  1.  ; flag transaction for settlement
  1.  I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
  1.  ;
  1.  Q $P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5)
  1.  ;
  1.  ;
  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) ;  adjustment amount for a bill
  1.  ;
  1.  Q +$P($G(^PRCA(430,RCBILLDA,7)),"^")
  1.  ;
  1. 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
  1.  ; 430 file that are referred appear to no longer be referred.
  1.  N IBA,IBB,DIE,DA,DR
  1.  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 "."
  1.  Q