source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCBEADJ.m@ 1604

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1RCBEADJ ;WISC/RFJ-adjustment ;1 Mar 2001
2 ;;4.5;Accounts Receivable;**169,172,204,173,208**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7DECREASE ; menu option: create a decrease adjustment
8 D ADJUST("DECREASE")
9 Q
10 ;
11 ;
12INCREASE ; menu option: create an increase adjustment
13 D ADJUST("INCREASE")
14 Q
15 ;
16ADJUST(RCBETYPE,RCEDI) ; create an adjustment
17 ; rcbetype = INCREASE for increase or DECREASE for decrease
18 ; rcedi = the ien of the bill selected via the EDI Worklist;ien of
19 ; the ERA entry or null/undefined if bill should be selected
20 N RCBILLDA
21 F D Q:RCBILLDA<0!$G(RCEDI)
22 . K RCTRANDA,RCLIST
23 . ;
24 . ; select a bill
25 . S RCBILLDA=$S('$G(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI)
26 . I RCBILLDA<1 Q
27 . ;
28 . ; adjust the bill
29 . D ADJBILL(RCBETYPE,RCBILLDA,$P($G(RCEDI),";",2))
30 Q
31 ;
32ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ; adjust a bill
33 ; RCEDIWL = ien of ERA entry if called from worklist
34 N RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y
35 ; lock the bill
36 L +^PRCA(430,RCBILLDA):5 I '$T W !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS BILL." Q
37 ;
38 ; show data for the bill
39 D SHOWBILL^RCWROFF1(RCBILLDA)
40 ;
41 ; check the balance of the bill
42 W !!,"Checking the bill's balance ..."
43 S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
44 I RCBALANC="" W " IN Balance!"
45 ;
46 ; out of balance, ask to fix it
47 I RCBALANC'="" D I RCBILLDA<1 D UNLOCK Q
48 . S TOTALCAL=$P(RCBALANC,"^")+$P(RCBALANC,"^",2)+$P(RCBALANC,"^",3)+$P(RCBALANC,"^",4)+$P(RCBALANC,"^",5)
49 . S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
50 . S TOTALSTO=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,"^",4)+$P(RCDATA7,"^",5)
51 . W " OUT of Balance!"
52 . W !!," BALANCE:",$J("Calculated",12),$J("Stored",12)
53 . W !," ------- ",$J("------------",12),$J("------------",12)
54 . W !," Principal Balance:",$J($P(RCBALANC,"^",1),12,2),$J($P(RCDATA7,"^",1),12,2)
55 . I +$P(RCBALANC,"^",1)'=+$P(RCDATA7,"^",1) W " <<-- OUT OF BALANCE"
56 . W !," Interest Balance:",$J($P(RCBALANC,"^",2),12,2),$J($P(RCDATA7,"^",2),12,2)
57 . I +$P(RCBALANC,"^",2)'=+$P(RCDATA7,"^",2) W " <<-- OUT OF BALANCE"
58 . W !," Admin Balance:",$J($P(RCBALANC,"^",3),12,2),$J($P(RCDATA7,"^",3),12,2)
59 . I +$P(RCBALANC,"^",3)'=+$P(RCDATA7,"^",3) W " <<-- OUT OF BALANCE"
60 . W !," MF Balance:",$J($P(RCBALANC,"^",4),12,2),$J($P(RCDATA7,"^",4),12,2)
61 . I +$P(RCBALANC,"^",4)'=+$P(RCDATA7,"^",4) W " <<-- OUT OF BALANCE"
62 . W !," CC Balance:",$J($P(RCBALANC,"^",5),12,2),$J($P(RCDATA7,"^",5),12,2)
63 . I +$P(RCBALANC,"^",5)'=+$P(RCDATA7,"^",5) W " <<-- OUT OF BALANCE"
64 . W !," ------- ",$J("----------",12),$J("----------",12)
65 . W !," TOTAL:",$J(TOTALCAL,12,2),$J(TOTALSTO,12,2)
66 . I +TOTALCAL'=+TOTALSTO W " <<-- OUT OF BALANCE"
67 . ;
68 . ; ask to fix the balances
69 . S Y=$$ASKFIX I Y'=1 W !," NOTE: You must fix the Balance Discrepancy before processing an adjustment!" S RCBILLDA=0 Q
70 . ;
71 . ; fix it
72 . S $P(RCDATA7,"^",1)=+$P(RCBALANC,"^",1) ; principal
73 . S $P(RCDATA7,"^",2)=+$P(RCBALANC,"^",2) ; interest
74 . S $P(RCDATA7,"^",3)=+$P(RCBALANC,"^",3) ; admin
75 . S $P(RCDATA7,"^",4)=+$P(RCBALANC,"^",4) ; marshal fee
76 . S $P(RCDATA7,"^",5)=+$P(RCBALANC,"^",5) ; court cost
77 . S $P(^PRCA(430,RCBILLDA,7),"^",1,5)=$P(RCDATA7,"^",1,5)
78 . ;
79 . W !," Balance Discrepancy FIXED!"
80 ;
81 ; if the principal balance is zero, do not allow it to be adjusted
82 ; ask to close/cancel it
83 I RCBETYPE="DECREASE",'$G(^PRCA(430,RCBILLDA,7)) W !!,"Note: This bill has NO PRINCIPAL BALANCE to decrease !" D INTADMIN(RCBILLDA),UNLOCK Q
84 ;
85 ; if entry is from EDI Lockbox worklist, display total adjusments in ERA
86 I $G(RCEDIWL) D
87 . N X,Y,Z,Z0,Z1
88 . S Z0=$J(+$P($$BILL^RCJIBFN2(RCBILLDA),U,3),"",2),Y=0
89 . S Z=0 F S Z=$O(^TMP("RC_BILL",$J,RCBILLDA,Z)) Q:'Z D
90 .. S X=+$P($G(^TMP("RCDPE-EOB_WLDX",$J,Z)),U,2)
91 .. Q:'X
92 .. S Y=Y+$P($G(^RCY(344.49,RCEDIWL,1,X,0)),U,6)
93 . Q:'Y
94 . W !," TOTAL PAYMENT(s) TO POST FROM THIS ERA: ",$J(Y,"",2)
95 . W !,"EXPECTED CLAIM ADJUSTMENT IF ALL POST SUCCESSFUL: ",$J($G(^PRCA(430,RCBILLDA,7))-Y,"",2)
96 ;
97 ; ask to enter adjustment amount
98 S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
99 I RCAMOUNT<0 D UNLOCK Q
100 ;
101 ; if decrease, make negative
102 I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
103 ;
104 ; ask if it is a contract adjustment
105 I RCBETYPE="DECREASE","^9^28^29^30^32^"[("^"_$P($G(^PRCA(430,RCBILLDA,0)),"^",2)_"^") S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
106 ;
107 ; show what the new transaction will look like
108 S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
109 W !!,"If you process the transaction, the bill will look like:"
110 W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),9,2)
111 W !," NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,9,2)
112 W !," ---------"
113 W !," NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,9,2)
114 ;
115 ; ask to enter transaction
116 S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
117 ;
118 ; add adjustment
119 S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
120 I 'RCTRANDA W !," *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK Q
121 I RCTRANDA W !," Adjustment Transaction: ",RCTRANDA," has been added."
122 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_" * * * *"
123 ;
124 ; ask to enter a comment
125 W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
126 S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
127 ;
128 ; ask to exempt interest and admin charges
129 I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
130 ;
131 ; notification of subsequent payer bulletin
132 S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
133 F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
134 I RCDATA7'="",'X D
135 . N PRCABN,PRCAEN,PRCAMT
136 . S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
137 . D EOB^PRCADJ
138 ;
139 ; unlock and ask the next bill to adjust
140 D UNLOCK
141 Q
142 ;
143 ;
144UNLOCK ; unlock bill and transaction
145 L -^PRCA(430,RCBILLDA)
146 I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
147 Q
148 ;
149 ;
150INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
151 N RCAMOUNT,RCTRANDA,Y
152 ;
153 ; check to see if there is interest and admin charges
154 S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
155 I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q
156 ;
157 ; only ask if there is no principal
158 I RCAMOUNT Q
159 ;
160 W !!,"You have the option to automatically EXEMPT the interest"
161 W !,"and administrative charges. This will close the bill."
162 S Y=$$ASKEXEMP I Y'=1 Q
163 ;
164 W !!,"Creating an EXEMPT transaction ..."
165 S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
166 I 'RCTRANDA W !," *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
167 I RCTRANDA W !," Exempt Transaction: ",RCTRANDA," has been added."
168 ;
169 W !," Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
170 Q
171 ;
172ASKOK(RCBETYPE) ; ask record decrease or increase transaction
173 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
174 S DIR(0)="YO",DIR("B")="YES"
175 S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
176 W ! D ^DIR
177 I $G(DTOUT)!($G(DUOUT)) S Y=-1
178 Q Y
179 ;
180 ;
181ASKFIX() ; ask to fix bill's balance
182 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
183 S DIR(0)="YO",DIR("B")="YES"
184 S DIR("A")=" Do you want to FIX the balance discrepancy "
185 W ! D ^DIR
186 I $G(DTOUT)!($G(DUOUT)) S Y=-1
187 Q Y
188 ;
189 ;
190ASKEXEMP() ; ask to record an exempt transaction
191 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
192 S DIR(0)="YO",DIR("B")="NO"
193 S DIR("A")=" Would you like to EXEMPT the interest and admin charges "
194 D ^DIR
195 I $G(DTOUT)!($G(DUOUT)) S Y=-1
196 Q Y
197 ;
198 ;
199ASKCONT() ; ask if contract adjustment
200 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
201 S DIR(0)="YO",DIR("B")="YES"
202 S DIR("A")=" Is this a CONTRACT adjustment "
203 W ! D ^DIR
204 I $G(DTOUT)!($G(DUOUT)) S Y=-1
205 Q Y
206 ;
207 ;
208ADJNUM(RCBILLDA) ; get next adjustment number for a bill
209 N %,ADJUST,DATA1,RCTRANDA
210 S RCTRANDA=0
211 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
212 Q ADJUST
213 ;
214 ;
215AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
216 N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
217 S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
218 I RCBETYPE="INCREASE" S PRINBAL=99999.99
219 W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),"."
220 S DIR(0)="NAO^.01:"_PRINBAL_":2"
221 S DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
222 D ^DIR
223 I $G(DTOUT)!($G(DUOUT)) S Y=-1
224 Q $S(Y'="":Y,1:-1)
Note: See TracBrowser for help on using the repository browser.