source: FOIAVistA/tag/r/FEE_BASIS-FB/FBUTL2.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1FBUTL2 ;WOIFO/SAB-FEE BASIS UTILITY ;7/1/2003
2 ;;3.5;FEE BASIS;**61,73**;JAN 30, 1995
3 Q
4ADJ(FBTAS,FBADJ,FBMAX,FBDT,FBADJD,FBNOOUT) ; Prompt for adjustments
5 ;
6 ; Input
7 ; FBTAS - required, total amount suspended, number, may be negative
8 ; the sum of all adjustment amounts must equal this value
9 ; FBADJ - required, array passed by reference
10 ; will be initialized (killed)
11 ; array of any entered adjustments
12 ; format
13 ; FBADJ(#)=FBADJR^FBADJG^FBADJA
14 ; where
15 ; # = sequentially assigned number starting with 1
16 ; FBADJR = adjustment reason (internal value file 162.91)
17 ; FBADJG = adjustment group (inernal value file 162.92)
18 ; FBADJA = adjustment amount (dollar value)
19 ; FBMAX - optional, number, default to 1
20 ; maximum number of adjustments that may be entered by user
21 ; FBDT - optional, effective date, FileMan internal format
22 ; default to current date, used to determine available codes
23 ; FBADJD - optional, array passed by reference
24 ; same format as FBADJ
25 ; if passed, it will be used to supply default values
26 ; normally only used when editing an existing payment
27 ; FBNOOUT- optional, boolean value, default 0, set =1 if user
28 ; should not be allowed to exit using an uparrow
29 ; Result (value of $$ADJ extrinsic function)
30 ; FBRET - boulean value (0 or 1)
31 ; = 1 when valid adjustments entered
32 ; = 0 when processed ended due to time-out or entry of '^'
33 ; Output
34 ; FBADJ - the FBADJ input array passed by reference will be modified
35 ; if the result = 1 then it will contain entered adjustments
36 ; if the result = 0 then it will be undefined
37 ;
38 N FBADJR,FBCAS,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET
39 N DIR,DIRUT,DTOUT,DUOUT,X,Y
40 S FBRET=1
41 S FBMAX=$G(FBMAX,1)
42 S FBDT=$G(FBDT,DT)
43 S FBNOOUT=$G(FBNOOUT,0)
44 S FBTAS=+FBTAS
45 K FBADJ
46 ;
47 I +FBTAS=0 G EXIT ; no adjustment since total amount susp. is 0
48 ;
49 ; if default adjustments exist then load them into array
50 I $D(FBADJD) M FBADJ=FBADJD
51 S (FBCNT,FBCAS)=0
52 I $D(FBADJ) S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
53 . S FBCNT=FBCNT+1
54 . S FBCAS=FBCAS+$P(FBADJ(FBI),U,3)
55 ;
56 ; if more than one adjustment can be entered then display number
57 ;
58 ;
59ASKADJ ; multiply prompt for adjustments
60 ;
61 ; display current list of adjustments when more than 1 allowed
62 I FBMAX>1!(FBCNT>1) D
63 . W !!,"Current list of Adjustments: "
64 . I '$O(FBADJ(0)) W "none"
65 . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
66 . . W ?30,"Code: "
67 . . W:$P(FBADJ(FBI),U)]"" $P($G(^FB(161.91,$P(FBADJ(FBI),U),0)),U)
68 . . W ?44,"Group: "
69 . . W:$P(FBADJ(FBI),U,2)]"" $P($G(^FB(161.92,$P(FBADJ(FBI),U,2),0)),U)
70 . . W ?56,"Amount: "
71 . . W "$",$FN($P(FBADJ(FBI),U,3),"",2),!
72 ;
73 ; prompt for adjustment reason
74 ; if max is 1 and reason already on list then automatically select it
75 I FBMAX=1,FBCNT=1 D
76 . N FBI,FBADJR
77 . S FBI=$O(FBADJ(0))
78 . S:FBI FBADJR=$P(FBADJ(FBI),U)
79 . I FBADJR S Y=FBADJR_U_$P($G(^FB(161.91,FBADJR,0)),U)
80 E D I $D(DTOUT)!$D(DUOUT) S FBRET=0 G EXIT ; prompt user
81 . S DIR(0)="PO^161.91:EMZ"
82 . S DIR("A")="Select ADJUSTMENT REASON"
83 . S DIR("S")="I $P($$AR^FBUTL1(Y,,FBDT),U,4)=1"
84 . S DIR("?")="Select a HIPAA Adjustment (suspense) Reason Code"
85 . S DIR("?",1)="Adjustment reason codes explain why the amount paid differs"
86 . S DIR("?",2)="from the amount claimed."
87 . D ^DIR K DIR
88 ; if value was entered then process it and ask another if not max and
89 ; total amount suspended has not been accounted for
90 I +Y>0 D G:FBRET=0 EXIT I FBCNT<FBMAX,FBCAS'=FBTAS G ASKADJ
91 . S FBADJR=+Y
92 . ; if specified adj. reason already in list set FBEDIT = it's number
93 . S (FBI,FBEDIT)=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBEDIT
94 . . I $P(FBADJ(FBI),U)=FBADJR S FBEDIT=FBI
95 . S FBNEW=$S(FBEDIT:0,1:1) ; flag as new if not on list
96 . ; if in list then edit the existing adj. reason
97 . I FBEDIT D Q:$D(DIRUT) Q:FBADJR=""
98 . . S DIR(0)="162.558,.01"
99 . . ;S DIR(0)="PO^161.91:EMZ"
100 . . ;S DIR("S")="I $P($$AR^FBUTL1(Y,,FBDT),U,4)=1"
101 . . ;S DIR("A")=" ADJUSTMENT REASON"
102 . . S DIR("B")=$P($G(^FB(161.91,FBADJR,0)),U)
103 . . ;S DIR("?")="Enter a HIPAA Adjustment (suspense) Reason Code"
104 . . ;S DIR("?",1)="Adjustment reason codes explain why the amount paid differs"
105 . . ;S DIR("?",2)="from the amount claimed."
106 . . D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S:FBMAX=1 FBRET=0 Q
107 . . I X="@" D Q ; "@" removes from list
108 . . . D DEL(FBEDIT)
109 . . . S FBADJR=""
110 . . . W " (deleted)"
111 . . I +Y>0 S FBADJR=+Y
112 . . ; ensure new value of edited reason is not already on list
113 . . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBADJR=""
114 . . . I $P(FBADJ(FBI),U)=FBADJR,FBI'=FBEDIT S FBADJR="" W !,$C(7)," Change was not accepted because the new value is already on the list."
115 . . Q:FBADJR=""
116 . . ; upate the existing reason
117 . . S $P(FBADJ(FBEDIT),U)=FBADJR
118 . ;
119 . ; if new reason then add to list
120 . I 'FBEDIT D Q:FBADJR=""
121 . . I (FBCNT+1)>FBMAX D Q
122 . . . S FBADJR=""
123 . . . W !,$C(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
124 . . . W !," Select a reason code on the current list instead."
125 . . S FBEDIT=$O(FBADJ(" "),-1)+1
126 . . S $P(FBADJ(FBEDIT),U)=FBADJR,FBCNT=FBCNT+1
127 . ;
128 . ; ask for adjustment group
129 . S DIR(0)="162.558,1"
130 . ;S DIR(0)="P^161.92:EMZ"
131 . ;S DIR("S")="I $P($$AG^FBUTL1(Y,,FBDT),U,4)=1"
132 . ;S DIR("A")=" ADJUSTMENT GROUP"
133 . I $P(FBADJ(FBEDIT),U,2)]"" S DIR("B")=$P($G(^FB(161.92,$P(FBADJ(FBEDIT),U,2),0)),U)
134 . D ^DIR K DIR I $D(DIRUT) D:FBNEW DEL(FBEDIT) Q
135 . S $P(FBADJ(FBEDIT),U,2)=+Y
136 . ;
137 . ; ask for adjustment amount
138 . S DIR(0)="162.558,2"
139 . ;S DIR(0)="NA^-9999999.99:9999999.99:2^K:+X=0 X"
140 . ;S DIR("A")=" ADJUSTMENT AMOUNT: "
141 . S DIR("B")=$FN(FBTAS-FBCAS+$P(FBADJ(FBEDIT),U,3),"",2)
142 . D ^DIR K DIR I $D(DIRUT) D:FBNEW DEL(FBEDIT) Q
143 . S FBCAS=FBCAS-$P($G(FBADJ(FBEDIT)),U,3)+Y
144 . S $P(FBADJ(FBEDIT),U,3)=+Y
145 ;
146VAL ; validate
147 S FBERR=0
148 I FBCAS'=FBTAS D
149 . S FBERR=1
150 . W !,$C(7),"ERROR: Must account for $",$FN(FBTAS-FBCAS,"",2)," more to cover the total amount suspended."
151 . W !," The current sum of adjustments is $",$FN(FBCAS,"",2),"."
152 . W !," The total amount suspended is $",$FN(FBTAS,"",2),"."
153 I FBCNT>FBMAX D
154 . S FBERR=1
155 . W !,$C(7),"ERROR: Maximum number of adjustment reasons (",FBMAX,") have been exceeded."
156 I FBERR G ASKADJ
157 ;
158EXIT ;
159 ; if time-out or uparrow and total amount not covered then check if
160 ; exit is allowed by the calling routine. (not allowed during edit)
161 I FBRET=0,FBNOOUT S FBRET=1 I FBTAS'=FBCAS G VAL
162 I FBRET=0 K FBADJ
163 ;
164 Q FBRET
165 ;
166DEL(FBI) ; delete adjustment reason from list
167 S FBCAS=FBCAS-$P($G(FBADJ(FBI)),U,3)
168 S FBCNT=FBCNT-1
169 K FBADJ(FBI)
170 S FBADJR=""
171 W " (reason deleted)"
172 Q
173 ;
174ADJL(FBADJ) ; build list of adjustments extrinsic function
175 ; Input
176 ; FBADJ - required, array passed by reference
177 ; array adjustments
178 ; format
179 ; FBADJ(#)=FBADJR^FBADJG^FBADJA
180 ; where
181 ; # = integer number greater than 0
182 ; FBADJR = adjustment reason (internal value file 162.91)
183 ; FBADJG = adjustment group (inernal value file 162.92)
184 ; FBADJA = adjustment amount (dollar value)
185 ; Result
186 ; string containing sorted list (by external reason) of adjustments
187 ; format
188 ; FBADJRE 1^FBADJGE 1^FBADJAE 1^FBADJRE 2^FBADJGE 2^FBADJAE 2
189 ; where
190 ; FBADJRE = adjustment reason (external value)
191 ; FBADJGE = adjustment group (external value)
192 ; FBADJAE = adjustment amount (with cents)
193 N FBRET
194 N FBARJR,FBADJRE,FBADJG,FBADJGE,FBADJA,FBADJAE
195 N FBI,FBADJS
196 S FBRET=""
197 ;
198 ; build sorted array containing external values
199 S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
200 . ; obtain internal values
201 . S FBADJR=$P(FBADJ(FBI),U)
202 . S FBADJG=$P(FBADJ(FBI),U,2)
203 . S FBADJA=$P(FBADJ(FBI),U,3)
204 . ; convert to external values
205 . S FBADJRE=$S(FBADJR:$P($G(^FB(161.91,FBADJR,0)),U),1:"")
206 . S FBADJGE=$S(FBADJG:$P($G(^FB(161.92,FBADJG,0)),U),1:"")
207 . S FBADJAE=$FN(FBADJA,"",2)
208 . ; store in sorted array
209 . S FBADJS(FBADJRE_U_FBI)=FBADJRE_U_FBADJGE_U_FBADJAE_U
210 ;
211 ; build list from sorted array
212 S FBI="" F S FBI=$O(FBADJS(FBI)) Q:FBI="" D
213 . S FBRET=FBRET_FBADJS(FBI)
214 ; strip trailing "^" from list
215 I $E(FBRET,$L(FBRET))="^" S FBRET=$E(FBRET,1,$L(FBRET)-1)
216 ;
217 Q FBRET
218 ;
219ADJLR(FBADJL) ; build list of adjustment reasons extrinsic function
220 ; Input
221 ; FBADJL - required, string containing sorted list
222 ; (by external reason) of adjustments (see $$ADJL result)
223 ; Result
224 ; sting of adjustment reasons delimited by commas
225 ;
226 N FBRET,FBADJRE
227 N FBI
228 S FBRET=""
229 F FBI=1:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
230 ; strip trailing "," from list
231 I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
232 ;
233 Q FBRET
234 ;
235ADJLA(FBADJL) ; build list of adjustment amounts extrinsic function
236 ; Input
237 ; FBADJL - required, string containing sorted list
238 ; (by external reason) of adjustments (see $$ADJL result)
239 ; Result
240 ; sting of adjustment reasons delimited by commas
241 ;
242 N FBRET,FBADJRE
243 N FBI
244 S FBRET=""
245 F FBI=3:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
246 ; strip trailing "," from list
247 I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
248 ;
249 Q FBRET
250 ;
251 ;FBUTL2
Note: See TracBrowser for help on using the repository browser.