source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSSCRCL.m@ 1450

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

initial load of WorldVistAEHR
File size: 9.5 KB
RevLine 
[613]1BPSSCRCL ;BHAM ISC/SS - ECME SCREEN CLOSE CLAIMS ;05-APR-05
2 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5**;JUN 2004;Build 45
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6CLO ;entry point to close claims
7 N BPRET,BPSARR59
8 I '$D(@(VALMAR)) Q
9 D FULL^VALM1
10 W !,"Enter the line numbers for the claim(s) to be closed."
11 S BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,VALMAR)
12 I BPRET="^" S VALMBCK="R" Q
13 ;close claims
14 ;update the content of the screen
15 ;only if at least one claim was closed
16 I $$CLOSE(.BPSARR59) D REDRAW^BPSSCRUD("Updating screen for closed claims...")
17 E S VALMBCK="R"
18 Q
19 ;
20 ;close claims
21 ;input:
22 ; BP59ARR - array with ptrs to BPS TRANSACTION FILE
23 ; BP59ARR(ien59)="ien in TMP ^ number on the user screen"
24 ;returns:
25 ; BPCLTOT - number of closed claims
26CLOSE(BP59ARR) ;
27 N BPNEWARR,BPRETV,BPREJFLG,X
28 N BPDFN,BP59,BPIFANY,BPQ
29 N BPREAS,BPCOMM,BP90ANSW,BPRCOPAY,BPRXINFO,BPCOP,BPCLTOT,BPINS,BPINSNM,BP59FRST
30 S BPRETV=$$MKNEWARR(.BP59ARR,.BPNEWARR,.BPINS)
31 S BPQ="",BPIFANY=0,BPREJFLG=1
32 S BPDFN=""
33 F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D Q:BPQ="^"
34 . W !!,"You've chosen to close the following prescription(s) for",!,$E($$PATNAME^BPSSCRU2(BPDFN),1,13)_" :"
35 . S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D Q:BPQ="^"
36 . . I $Y>20 D PAUSE^VALM1 W @IOF I X="^" S BPQ="^" Q
37 . . S BPIFANY=1,BPQ=""
38 . . ;I $P($G(BPNEWARR(BPDFN,BP59)),U,3)=1 W:BPREJFLG=0 ! S BPREJFLG=1
39 . . ;E W:BPREJFLG=1 ! S BPREJFLG=0
40 . . S BPREJFLG=+$P($G(BPNEWARR(BPDFN,BP59)),U,3)
41 . . W !,@VALMAR@(+$G(BPNEWARR(BPDFN,BP59)),0)
42 . . D DISPREJ^BPSSCRU6(BP59)
43 . . W:BPREJFLG=0 !,"Claim NOT Rejected and cannot be Closed."
44 I +BPRETV=0 Q $$QUITCL()
45 I BPQ="^" Q $$QUITCL()
46 ;
47 W !!,"ALL Selected Rxs will be CLOSED using the same information gathered in the following prompts.",!
48 S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
49 I BPQ'=1 Q $$QUITCL()
50 ;
51 ; ask questions for all of them
52 W !!
53 I $$ASKQUEST(+$P(BPRETV,U,2),.BPREAS,.BPCOMM,.BP90ANSW,.BPRCOPAY)'=1 Q $$QUITCL()
54 ;
55 ; check 2nd insurance
56 S BPQ=""
57 I BP90ANSW'="D" D
58 . S BPDFN="" F S BPDFN=$O(BPINS(BPDFN)) Q:BPDFN="" D Q:BPQ="^"
59 . . S BPINSNM="" F S BPINSNM=$O(BPINS(BPDFN,BPINSNM)) Q:BPINSNM="" D Q:BPQ="^"
60 . . . S BP59FRST=0
61 . . . S BP59=""
62 . . . K BPRXINFO
63 . . . F S BP59=$O(BPINS(BPDFN,BPINSNM,BP59)) Q:BP59="" D Q:BPQ="^"
64 . . . . S:BP59FRST=0 BP59FRST=BP59
65 . . . . S BPRXINFO(BP59)=$E($G(@VALMAR@(+$G(BP59ARR(BP59)),0)),7,99)
66 . . . ; call CH2NDINS^BPSSCRU5 only once for all claims for this patient and insurance
67 . . . ; you can use one BP59FRST for the group of claims here as a parameter since
68 . . . ; they all are all identical from the "patient-insurance pair" point of view
69 . . . D:BP59FRST>0 CH2NDINS^BPSSCRU5(BP59FRST,$E($$PATNAME^BPSSCRU2(BPDFN),1,13),BPINSNM,.BPRXINFO)
70 ;
71 I BPQ="^" Q $$QUITCL()
72 ;
73 W @IOF
74 ;and finally close all
75 S BPCLTOT=0
76 S BPDFN="" F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D
77 . S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D
78 . . I $P($G(BPNEWARR(BPDFN,BP59)),U,3)=0 Q ;can't be closed
79 . . S BPCOP=0
80 . . I +BPRCOPAY=1,$P($G(BPNEWARR(BPDFN,BP59)),U,4)=1 S BPCOP=1 ;release copay
81 . . I $$CLOSEIT(BP59,$P(BPREAS,U,2),BPCOMM,BP90ANSW,BPCOP)>0 D
82 . . . S BPCLTOT=BPCLTOT+1
83 ;
84 W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been closed.",!
85 D PAUSE^VALM1
86 Q BPCLTOT
87 ;
88QUITCL() ;
89 W !!,"0 claims have been closed."
90 D PAUSE^VALM1
91 Q 0
92 ;/**
93 ;Ask all necessary questions
94 ;Input
95 ; BPRELCOP - ask release copay question
96 ; .BPREAZ - ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG
97 ; .BPCOMZ - close comment (string)
98 ; .BP90ANSZ - "", "D"(drop to paper) or "N" (non-billable)
99 ; .BPRCOPAZ - 1(Yes) or 0(No) , answer to "release copay" question
100 ;Output:
101 ; 0 - cancel process
102 ; ^ - emergency quit (cancel process)
103 ; 1 - ok, can proceed
104ASKQUEST(BPRELCOP,BPREAZ,BPCOMZ,BP90ANSZ,BPRCOPAZ) ;*/
105 S BPCOMZ=""
106 S BP90ANSZ=""
107 S BPRCOPAZ=0
108 ;ask the user to choose the close reason from #356.8
109 ;using set of close reasons in IB file 356.8
110 S BPREAZ=$$REASON()
111 I BPREAZ="^" Q "^"
112 I ($P(BPREAZ,U,4)=1) D ;if has ECME PAPER FLAG
113 . ;ask if the claim is still billable thru paper?
114 . S BP90ANSZ=$$PROMPT^BPSSCRCV("S^N:NON-BILLABLE;D:DROP TO PAPER","Treat as (N)on-Billable Episode or (D)rop Bill to Paper?","")
115 I BP90ANSZ=-1 Q "^"
116 S BPCOMZ=$$COMMENT("Comment ",40)
117 I (BPCOMZ="^") Q "^"
118 I $L(BPCOMZ)>0,BPCOMZ?1" "." " S BPCOMZ=""
119 ;check copay
120 ;ask "release copay?" in all NON-BILLABLE cases, i.e. except user answered "DROP TO PAPER"
121 ;(even in cases when he was not asked about it)
122 I BP90ANSZ'="D",BPRELCOP D
123 . ; Ask user if s/he wants to release a copay
124 . S BPRCOPAZ=$$YESNO^BPSSCRRS("Release Patient CoPay(Y/N)")
125 I BPRCOPAZ=-1 Q "^"
126 ;
127 S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
128 I BPQ=-1 Q "^" ;quit by "^"
129 I BPQ'=1 Q 0 ;doesn't want to proceed
130 Q 1 ; answers can be used
131 ;
132 ;/**
133 ;ask for the close reason
134 ;return:
135 ; ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG
136REASON() ;
137 N DIC,BPREASNM,BP3568,Y
138 ; - Asks for REASON for Closing
139 S DIC="^IBE(356.8,",DIC(0)="AEQMZ"
140 S DIC("S")="I $P(^(0),U,2)=1"
141 D ^DIC
142 I Y=-1 Q "^"
143 Q +Y_U_Y(0)
144 ;/**
145 ;enter the comment
146 ;BPSTR -prompt string
147 ;BPMLEN -maxlen
148COMMENT(BPSTR,BPMLEN) ;*/
149 N DIR,DTOUT,DUOUT,BPQ
150 I '$D(BPSTR) S BPSTR="Comment "
151 I '$D(BPMLEN) S BPMLEN=40
152 S DIR(0)="FO^0:250"
153 S DIR("A")=BPSTR
154 S DIR("?",1)="This response must have at least 0 characters and no more"
155 S DIR("?")="than "_BPMLEN_" characters and must not contain embedded uparrow"
156 S BPQ=0
157 F D Q:+BPQ'=0
158 . D ^DIR
159 . I $D(DUOUT)!($D(DTOUT)) S BPQ=-1 Q
160 . I $L(Y)'>BPMLEN S BPQ=1 Q
161 . W !!,"This response must have at least 0 characters and no more"
162 . W !,"than "_BPMLEN_" characters and must not contain embedded uparrow.",!
163 . S DIR("B")=$E(Y,1,BPMLEN)
164 Q:BPQ<0 "^"
165 Q Y
166 ;/**
167 ;close the claim
168 ;the approach and code partially borrowed from IHS code CLOSE^BPSOS6N
169 ;BPSTRA - ptr to #9002313.59
170 ;REASON - text name of the close reason
171 ;BPSCLCM - comment
172 ;BPDROP:
173 ; "D" - DROP BILL TO PAPER
174 ; "N" - NON-BILLABLE
175 ;BPRELCOP - 1 (Yes) or 0 (No) release copay or not?
176CLOSEIT(BPSTRA,REASON,BPSCLCM,BPDROP,BPRELCOP) ;
177 N BPSCLA,ERROR,DA,DR,BPLCK,DIE
178 S BPSCLA=$$GET1^DIQ(9002313.59,BPSTRA,3,"I")
179 W !,"Closing Claim ",$$GET1^DIQ(9002313.02,BPSCLA,.01),"..."
180 S BPLCK=0
181 L +^BPSC(BPSCLA):0
182 I $T S BPLCK=1
183 E W !," *** CLAIM ",$$GET1^DIQ(9002313.02,BPSCLA,.01)," IN USE ***" Q 0
184 D CLOSE^BPSBUTL(BPSCLA,BPSTRA,REASON,$S($G(BPDROP)="D":1,1:0),BPRELCOP,BPSCLCM,.ERROR)
185 I $D(ERROR) W "NOT OK" D DSPERR(ERROR) D Q 0
186 . I BPLCK=1 L -^BPSC(BPSCLA)
187 S DIE="^BPSC(",DA=BPSCLA,DR="901///1;902///"_$$NOW^XLFDT()_";903///"_$G(DUZ)_";904///"_REASON_";905////"_BPDROP D ^DIE
188 I BPLCK=1 L -^BPSC(BPSCLA)
189 H 1 W "OK"
190 Q 1
191 ;
192DSPERR(MSG) ; Display the ERROR message
193 W !,"Error: *** ",MSG," ***"
194 Q
195 ;
196 ;/**
197 ;ECME has tried to submit the claim to insurance with the name BPINSNAM
198 ;but the claim was rejected and now we need to determine if the patient
199 ;has any other insurance with pharmacy coverage that can be billed for the RX
200 ;Input:
201 ; BP59 - pointer to file #9002313.59
202 ; BPINSNAM - insurance that have already been used by ECME
203 ;Output:
204 ; 0 - not found
205 ; 1 ^ Insurance Name ^ Group Number ^ Date of service
206NEXTINS(BP59,BPINSNAM) ;get insurance info by the pointer of #9002313.59
207 N BPDOS,BPDFN,BPZZ,BP36,BPX,BPHONE,BPY,BPINSNM
208 N BPPHARM,BPCOORD,BPINS,BPFOUND
209 S BPY=0
210 S BPHONE=$P($G(^BPST(BP59,10,+$G(^BPST(BP59,9)),3)),U,2)
211 S BPDOS=+$P($G(^BPST(BP59,12)),U,2)\1
212 I BPDOS=0 S BPDOS=+$P($G(^BPST(BP59,0)),U,8)\1
213 S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
214 ; call INSUR^IBBAPI to get information about:
215 ;1 = Insurance Company Name
216 ;7 = Coordination of Benefits (primary, secondary, tertiary)
217 ;15 = Pharmacy Coverage?
218 ;18 = Group Number
219 S BPX=$$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,7,15,18")
220 S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D
221 . ;get pharmacy coverage
222 . S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15))
223 I BPX<1 Q 0
224 D PROCINS(.BPZZ)
225 ;check pharmacy coverage
226 S BPFOUND=0 ;if found will be set to insurance node in the INSUR^IBBAPI array
227 S BPPHARM=1 ;look only at those with pharmacy coverage
228 S BPCOORD=0
229 F S BPCOORD=+$O(BPZZ("RES",BPPHARM,BPCOORD)) Q:BPCOORD=0!(BPFOUND'=0) D
230 . S BPINS=+$O(BPZZ("RES",BPPHARM,BPCOORD,0))
231 . I BPINS>0 I $P($G(BPZZ("IBBAPI","INSUR",BPINS,1)),U,2)'=BPINSNAM S BPFOUND=BPINS
232 I BPFOUND=0 Q 0
233 Q 1_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,1)),U,2)_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,18)),U)_U_BPDOS
234 ;
235 ;process insurances
236 ;input: local array returned by INSUR^IBBAPI
237 ;output: BPZZ("RES",pharmacy coverage,coordination,insurance element # in BPZZ array)
238PROCINS(BPZZ) ;
239 N BP1,BP2,BP0,BPPHONE,BPPHARM,BPCOORD
240 S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D
241 . ;get pharmacy coverage
242 . S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15))
243 . ;get coordination of benefits
244 . S BPCOORD=+$G(BPZZ("IBBAPI","INSUR",BP1,7))
245 . ;create ^TMP to sort results by pharmacy coverage and coordination of benefits
246 . S BPZZ("RES",BPPHARM,BPCOORD,BP1)=""
247 Q
248 ;
249 ;------------
250MKNEWARR(BPARR,BPNEWARR,BPINSARR) ;
251 N BP59,BPREJ,BPREJCNT,BPRELCNT,BPREL,BPINS
252 S BPREJCNT=0,BPRELCNT=0
253 S BPINS=0
254 S BP59="" F S BP59=$O(BPARR(BP59)) Q:BP59="" D
255 . S BPREJ=0
256 . S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
257 . S BPREJ=$S($P($$CLAIMST^BPSSCRU3(BP59),U)="E REJECTED":1,1:0)
258 . S:BPREJ BPREJCNT=BPREJCNT+1
259 . S BPREL=$S($$RXAPI1^BPSUTIL1(+$P($$RXREF^BPSSCRU2(BP59),U),106,"I"):1,1:0)
260 . S:BPREL BPRELCNT=BPRELCNT+1
261 . S BPNEWARR(BPDFN,BP59)=BPARR(BP59)_U_BPREJ_U_BPREL
262 . S BPINS=$P($$GETINSUR^BPSSCRU2(BP59),U,2)
263 . I BPREJ=1,$L(BPINS)>0 S BPINSARR(BPDFN,BPINS,BP59)=BPARR(BP59)
264 Q BPREJCNT_U_BPRELCNT
265 ;
Note: See TracBrowser for help on using the repository browser.