source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCBEADJI.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1RCBEADJI ;LL/ELZ-API FOR IB IN SETTLEMENT ;25-APR-2002
2 ;;4.5;Accounts Receivable;**180**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6DECREASE(RCBN,RCTEST,RCAMT) ; create a decrease adjustment for a bill
7 ; this will decreace the full balance and return info.
8 ;
9 ; input: RCBN = bill number
10 ; RCTEST = optional flag to indicate test mode only
11 ; RCAMT = optional specific amount to adjust
12 ;
13 ; output: -(error number) ^ error message
14 ; OR
15 ; decrease adjust DA ^ decrease amt ^ int amout ^ admin amt
16 ; ^ marshal amt ^ court amt
17 ;
18 ;
19 N RCBILLDA,RCBETYPE,RCTRANDA,STATUS,RCCAT,RCCATEG,RCRESP
20 S RCBETYPE="DECREASE",RCTEST=+$G(RCTEST)
21 ;
22 ; get bill ien
23 S RCBILLDA=$O(^PRCA(430,"D",RCBN,0))
24 I RCBILLDA<1 S RCRESP="-3^Bill Number Not Found" G DECQ
25 ;
26 ; bill must be active
27 S STATUS=$P($G(^PRCA(430,RCBILLDA,0)),"^",8)
28 I STATUS'=16,STATUS'=42 S RCRESP="-4^Bill Not Active" G DECQ
29 ;
30 ; determine if bill can be adjusted based on category
31 D RCCAT^RCRCUTL(.RCCAT) ;returns rccat(category) array
32 S RCCATEG=+$P(^PRCA(430,RCBILLDA,0),"^",2)
33 I +$G(RCCAT(RCCATEG))=1,$$REFST^RCRCUTL(RCBILLDA) S RCRESP="-5^Bill is Referred" G DECQ
34 I RCCATEG=26 S RCRESP="-6^No Pre-Payment Bills" G DECQ
35 ;
36 ;
37 ; adjust the bill
38 S RCRESP=$$ADJBILL(RCBETYPE,RCBILLDA,$G(RCAMT))
39 ;
40DECQ Q RCRESP
41 ;
42 ;
43ADJBILL(RCBETYPE,RCBILLDA,RCAMT) ; adjust a bill
44 N RCAMOUNT,RCBALANC,RCDATA7,RCONTADJ,RCTRANDA,I,X,Y,RCINT,RCCOM,RCERR
45 ; lock the bill
46 L +^PRCA(430,RCBILLDA):5 I '$T Q "-7^Bill is Locked"
47 ;
48 ;
49 ; check the balance of the bill
50 S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
51 ;
52 ; out of balance
53 I RCBALANC'="" D UNLOCK Q "-8^Bill is Out of Balance"
54 ;
55 ; if the principal balance is zero, do not allow it to be adjusted
56 ; close/cancel it
57 I '$G(^PRCA(430,RCBILLDA,7)) S RCINT=$$INTADMIN(RCBILLDA,RCTEST) D UNLOCK Q "-9^No Principal to Decrease^"_RCINT
58 ;
59 ; adjustment amount
60 S RCAMOUNT=$$AMOUNT(RCBILLDA)
61 S RCAMOUNT=$S(RCAMT&(RCAMT'>RCAMOUNT):RCAMT,1:RCAMOUNT)
62 I RCAMOUNT<.01 D UNLOCK Q "-10^No Amount Returned"
63 ;
64 ; make negative
65 S RCAMOUNT=-RCAMOUNT
66 ;
67 ; if it is a contract adjustment
68 I "^9^28^29^30^32^"[("^"_$P($G(^PRCA(430,RCBILLDA,0)),"^",2)_"^") S RCONTADJ=1
69 ;
70 ;
71 S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
72 ;
73 ; add adjustment
74 I 'RCTEST S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
75 I 'RCTEST,'RCTRANDA D UNLOCK Q "-11^Adjustment NOT Processed"
76 ;
77 ; mark flag for settlement
78 I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
79 ;
80 ; enter a comment
81 S RCCOM(1,0)="Hartford/USAA Litigation Settlement."
82 I 'RCTEST D WP^DIE(433,RCTRANDA_",",41,"","RCCOM","RCERR")
83 I $D(RCERR) D UNLOCK Q "-12^Comment Error"
84 ;
85 ; exempt interest and admin charges
86 S RCINT=$S(RCTEST:$$INTADMIN(RCBILLDA,RCTEST),$$AMOUNT(RCBILLDA):"0^0^0^0",1:$$INTADMIN(RCBILLDA,RCTEST))
87 ;
88 ;
89 D UNLOCK
90 Q $G(RCTRANDA)_"^"_(-$G(RCAMOUNT))_"^"_$G(RCINT)
91 ;
92 ;
93UNLOCK ; unlock bill and transaction
94 L -^PRCA(430,RCBILLDA)
95 I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
96 Q
97 ;
98 ;
99INTADMIN(RCBILLDA,RCTEST) ; adjust the interest and admin
100 ;
101 ; Return is the amounts adjusted:
102 ; interest ^ admin ^ marshal ^ court
103 ;
104 ; OR if error: - (error number) ^ error message
105 ;
106 N RCAMOUNT,RCTRANDA,Y,X
107 ;
108 ; check to see if there is interest and admin charges
109 S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
110 I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q "0^0^0^0"
111 ;
112 ; only if there is no principal
113 I 'RCTEST,RCAMOUNT Q "-13^balance still there"
114 ;
115 ;
116 I 'RCTEST S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
117 I 'RCTEST,'RCTRANDA Q "-14^Error processing exemption"
118 ;
119 ; flag transaction for settlement
120 I 'RCTEST S $P(^PRCA(433,RCTRANDA,9),"^",3)=1
121 ;
122 Q $P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5)
123 ;
124 ;
125 ;
126 ;
127ADJNUM(RCBILLDA) ; get next adjustment number for a bill
128 N ADJUST,DATA1,RCTRANDA
129 S RCTRANDA=0
130 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
131 Q ADJUST
132 ;
133 ;
134AMOUNT(RCBILLDA) ; adjustment amount for a bill
135 ;
136 Q +$P($G(^PRCA(430,RCBILLDA,7)),"^")
137 ;
138TEST ; This entry point is only to be used for testing and NEVER in a
139 ; production system. This will make all the referred bills in the
140 ; 430 file that are referred appear to no longer be referred.
141 N IBA,IBB,DIE,DA,DR
142 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 "."
143 Q
Note: See TracBrowser for help on using the repository browser.