source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBNCPBB.m@ 1582

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1IBNCPBB ;DALOI/AAT - ECME BACKBILLING ;24-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**276,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;
6 Q
7EN ;[IB GENERATE ECME RX BILLS] entry
8 N IBMOD1,IBMOD3,IBPAT,IBRX,IBBDT,IBEDT,IBSEL,IBREF,IBPAUSE
9 S IBREF=$NA(^TMP($J,"IBNCPBB"))
10 S IBPAUSE=1
11 K @IBREF D
12 . N IBEXIT
13 . S IBEXIT=0
14 . D MODE I IBEXIT Q
15 . I IBMOD1="P" D SELECT I IBEXIT Q
16 . I IBMOD1="R" D SELECT2 I IBEXIT Q
17 . D CONFIRM I IBEXIT Q
18 . D PROCESS I IBEXIT Q
19 I IBPAUSE W ! D PAUSE()
20 K @IBREF
21 Q
22 ;
23CT(IBTRN) ;CT ENTRY
24 N IBZ,IBRX,IBRXN,IBFL,IBEXIT,IBPAT,IBRDT,IBFDT,IBRES,IBBIL,IBBN,IBQ,IBSCRES
25 S IBQ=0
26 D FULL^VALM1
27 W !!,"This option sends electronic Pharmacy Claims to the Payer"
28 S VALMBCK="R"
29 S IBZ=$G(^IBT(356,IBTRN,0)) Q:IBZ=""
30 S IBRX=$P(IBZ,U,8),IBFL=$P(IBZ,U,10)
31 I 'IBRX D Q
32 . W !!,"This is not a Pharmacy Claims Tracking record",*7,!
33 . D PAUSE("Cannot submit to ECME")
34 ;
35 ;Release date:
36 I IBFL=0 S IBRDT=$$FILE^IBRXUTL(IBRX,31)
37 E S IBRDT=$$SUBFILE^IBRXUTL(IBRX,IBFL,52,17)
38 I 'IBRDT D Q
39 . W !!,"The Prescription is not released.",!
40 . D PAUSE("Cannot submit to ECME")
41 ;
42 S IBPAT=$P(IBZ,U,2)
43 I $$SC($P(IBZ,U,19)) D Q:IBQ
44 . N DIR,DIE,DA,DR,Y
45 . W !!,"The Rx is marked 'non-billable' in CT: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0)),U)
46 . W !,"If you continue, the NON-BILLABLE REASON will be deleted.",!
47 . S DIR(0)="Y",DIR("A")="Are you sure you want to bill this episode"
48 . S DIR("B")="NO"
49 . S DIR("?")="If you want to bill this Rx, enter 'Yes' - otherwise, enter 'No'"
50 . W ! D ^DIR K DIR
51 . I 'Y S IBQ=1 Q
52 . S DIE="^IBT(356,",DA=IBTRN,DR=".19///@" D ^DIE ;clean NB reason
53 . S IBSCRES(IBRX,IBFL)=1 ; sc resolved flag
54 ;
55 S IBZ=$G(^IBT(356,IBTRN,0)) ; refresh
56 I $P(IBZ,U,19) D Q
57 . W !!,"The Prescription is marked 'non-billable' in Claims Tracking",*7
58 . W !,"Reason non-billable: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0),"Unknown"),U),!
59 . D PAUSE("Cannot submit to ECME")
60 ; Fill/Refill Date:
61 S IBFDT=$S('IBFL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFL,52,.01))
62 ; Is the patient billable at the released date?
63 S IBRES=$$ECMEBIL^IBNCPDPU(IBPAT,IBFDT)
64 I 'IBRES D Q
65 . W !!,"The patient is not ECME Billable at the ",$S(IBFL:"re",1:""),"fill date."
66 . W !,"Reason: ",$P(IBRES,U,2,255),!
67 . D PAUSE("Cannot submit to ECME")
68 ;
69 S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
70 S IBBIL=$$BILL(IBRXN,IBRDT)
71 I IBBIL,'$P($G(^DGCR(399,IBBIL,"S")),U,16) D Q
72 . W !!,"Rx# ",IBRXN," was previously billed."
73 . W !,"Please manually cancel the bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," before submitting claim to ECME.",!
74 . D PAUSE("Cannot submit to ECME")
75 I IBBIL W !,"The bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," has been cancelled.",!
76 ;
77 D CONFRX(IBRXN) Q:$G(IBEXIT)
78 ;
79 W !!,"Submitting Rx# ",IBRXN W:IBFL ", Refill# ",IBFL W " ..."
80 S IBRES=$$SUBMIT^IBNCPDPU(IBRX,IBFL) W !," ",$S(+IBRES=0:"S",1:"Not s")_"ent through ECME."
81 I +IBRES'=0 W !," *** ECME returned status: ",$$STAT(IBRES),!
82 I +IBRES=0 W !!,"The Rx have been submitted to ECME for electronic billing",!
83 D PAUSE()
84 Q
85 ;
86MODE ;
87 ; IBMOD1: "P"-Single Patient, "R"-Single Rx
88 ; IBMOD3 (if IBMOD1="P"): "U"-Unbilled, "A"-All Rx
89 ; IBPAT (if IBMOD1="P"): Patient's DFN
90 ; IBBDT,IBEDT (if IBMOD1="P"): From/To dates inclusive
91 N DIR,DIC,DIRUT,DUOUT,Y,PSOFILE
92 S (IBMOD1,IBMOD3)=""
93 S DIR(0)="S^P:SINGLE (P)ATIENT;R:SINGLE (R)X"
94 S DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X"
95 S DIR("B")="P"
96 D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
97 S IBMOD1=Y
98 ; Enter Rx
99 I IBMOD1="R" W ! S PSOFILE=52,DIC="^PSRX(",DIC(0)="AEQMN" D DIC^PSODI(PSOFILE,.DIC) S:$D(DUOUT) IBEXIT=1 S IBRX=$S(Y>0:+Y,1:0) S:'IBRX IBEXIT=1,IBPAUSE=0
100 K PSODIY
101 I IBMOD1="R" Q
102 ;
103 I IBMOD1'="P" W !,"???" S IBEXIT=1 Q ; Invalid mode
104 ;Enter Patient
105 S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC S:$D(DUOUT) IBEXIT=1 S IBPAT=$S(Y>0:+Y,1:0) S:'IBPAT IBEXIT=1,IBPAUSE=0
106 Q:IBEXIT
107 I '$$ECMEBIL^IBNCPDPU(IBPAT,DT) W *7,!!,"Warning! The patient is currently not ECME billable!"
108 ;
109 D DATE I IBEXIT S IBPAUSE=0 Q
110 ;
111 S DIR(0)="S^U:UNBILLED;A:ALL RX"
112 S DIR("A")="(U)NBILLED, (A)LL RX"
113 S DIR("B")="U"
114 D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
115 S IBMOD3=Y
116 Q
117 ;
118 ;begin/end date
119DATE ;
120 N Y,%DT
121 S (IBBDT,IBEDT)=DT
122 W !
123 S %DT="AEX"
124 S %DT("A")="START WITH DATE: ",%DT("B")="TODAY"
125 D ^%DT K %DT
126 I Y'>0 S IBEXIT=1 Q
127 S IBBDT=+Y
128 S %DT="AEX"
129 S %DT("A")="GO TO DATE: ",%DT("B")="TODAY" ;$$DAT2^IBOUTL(IBBDT)
130 D ^%DT K %DT
131 I Y'>0 S IBEXIT=1 Q
132 S IBEDT=+Y
133 Q
134 ;
135SELECT ;Select from patient's list
136 ; (IBPAT,IBBDT,IBEDT,IBMOD3)
137 N IBD,IBRX,IBZ,IBDATA,IBCNT,Y,PDFN,LIST,LIST2,NODE,RXNUMEXT,LIST,IBDATE,CNT1,CNT2,RFNUM
138 S CNT1=0,CNT2=0,IBCNT=0
139 S LIST="IBRXSELARR"
140 S NODE=2
141 D RX^PSO52API(IBPAT,LIST,,,NODE,,)
142 S RXNUMEXT=0 F S RXNUMEXT=$O(^TMP($J,LIST,"B",RXNUMEXT)) Q:'RXNUMEXT D
143 . S IBRX=0 F S IBRX=$O(^TMP($J,LIST,"B",RXNUMEXT,IBRX)) Q:'IBRX D
144 .. S IBDATE=$P(^TMP($J,LIST,IBPAT,IBRX,31),"^",1)
145 .. I (IBDATE>IBBDT)&(IBDATE<IBEDT) D
146 ... S IBZ=$$RXZERO^IBRXUTL(IBPAT,IBRX) Q:IBZ=""
147 ... I $P(IBZ,U,2)'=IBPAT Q
148 ... I '$$FILE^IBRXUTL(IBRX,31) Q ; not released
149 ... S IBDATA=$$RXDATA(IBRX,0)
150 ... I ('$P(IBDATA,U,6))!(IBMOD3="A") S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
151 ... S LIST2="IBCPBBRF"
152 ... S NODE="R"
153 ... D RX^PSO52API(IBPAT,LIST2,IBRX,,NODE,,)
154 ... S RFNUM=0 F S RFNUM=$O(^TMP($J,LIST2,IBPAT,IBRX,"RF",RFNUM)) Q:RFNUM'>0 D:$$SUBFILE^IBRXUTL(IBRX,RFNUM,52,17)
155 .... S IBDATA=$$RXDATA(IBRX,RFNUM)
156 .... I $P(IBDATA,U,6),IBMOD3'="A" Q ; unbilled only
157 .... S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
158 ... K ^TMP($J,LIST2)
159 K ^TMP($J,LIST)
160 D MKCHOICE
161 Q
162SELECT2 ;Select from Rx list
163 ; (IBRX)
164 N IBCNT,Y,PDFN,RIFN,LST
165 S RIFN=0
166 W ! S IBPAUSE=1
167 S PDFN=$$FILE^IBRXUTL(IBRX,2)
168 S LST="SEL2LST"
169 I $$RXZERO^IBRXUTL(PDFN,IBRX)="" W !,"The Rx does not exist. Please try again." S IBEXIT=1 Q
170 I $$FILE^IBRXUTL(IBRX,31)="" W !,"The Rx has not been released. Please try again." S IBEXIT=1 Q
171 S IBCNT=1,@IBREF@(IBCNT)=$$RXDATA(IBRX,0)
172 D RX^PSO52API(PDFN,LST,IBRX,,"R",,)
173 S RIFN=0 F S RIFN=$O(^TMP($J,LST,PDFN,IBRX,"RF",RIFN)) Q:RIFN'>0 D:$$SUBFILE^IBRXUTL(IBRX,RIFN,52,17)
174 .S IBCNT=IBCNT+1,@IBREF@(IBCNT)=$$RXDATA(IBRX,RIFN)
175 K ^TMP($J,LST)
176 D MKCHOICE
177 Q
178 ;
179MKCHOICE ;
180 N Y
181 W !
182 S Y=0 F S Y=$O(@IBREF@(Y)) Q:'Y D DISP(Y)
183 ;
184 I $O(@IBREF@(0))="" S IBEXIT=1 W !!," No Rxs meet the entered criteria. Please try again." Q
185 I $O(@IBREF@(""),-1)=1 S IBSEL(1)="" Q ; one item only
186 F W !!,"Enter Line Item(s) to submit to ECME or (A)LL :" R IBSEL:DTIME S:'$T IBEXIT=1 Q:IBEXIT Q:IBSEL'["?" D
187 . W !?10,"Enter number(s) or item range(s) separated by comma."
188 . W !?10,"Example: 1,3,7-11"
189 Q:IBEXIT
190 I IBSEL'="",$TR(IBSEL,"al","AL")=$E("ALL",1,$L(IBSEL)),$L(IBSEL)<3 W $E("ALL",$L(IBSEL)+1,3) S IBSEL="ALL"
191 I IBSEL="" S IBEXIT=1 W " Nothing selected" Q
192 I IBSEL="^" S IBEXIT=1 W " Cancelled" Q
193 ;Collect the required into the IBSEL(i) local array
194 D PARSE(.IBSEL)
195 I $O(IBSEL(0))="" S IBEXIT=1 W !!,"No item(s) match the selection." Q
196 Q
197 ;
198CONFIRM ;
199 N DIR,Y
200 W !
201 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the selected RX(s) to ECME for electronic billing"
202 D ^DIR I Y'=1 S IBEXIT=1
203 Q
204 ;
205CONFRX(IBRX) ;
206 N DIR,Y
207 W !
208 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the Rx# "_IBRX_" to ECME for electronic billing"
209 D ^DIR I Y'=1 S IBEXIT=1
210 Q
211 ;
212STAT(X) ;
213 I +X<6 Q $P(X,"^",2)
214 Q "Unknown Status"
215 ;
216PROCESS ;
217 N RES,IBY,IBD,IBRX,IBFIL,IBERR,IBBIL
218 S IBERR=0
219 S IBY=0 F S IBY=$O(IBSEL(IBY)) Q:'IBY D
220 . S IBD=$G(@IBREF@(IBY)) Q:IBD=""
221 . S IBRX=$P(IBD,U),IBFIL=+$P(IBD,U,3),IBBIL=$P(IBD,U,6)
222 . W !,"Submitting Rx# ",$P(IBD,U,2) W:IBFIL "Refill# ",IBFIL W:'IBFIL " (original fill)" W " ..."
223 . I IBBIL,'$P($G(^DGCR(399,IBBIL,"S")),U,16) D S IBERR=IBERR+1 Q
224 .. W !," *** Rx# ",$P(IBD,U,2)," was previously billed."
225 .. W !," Please cancel the Bill No ",$P($G(^DGCR(399,IBBIL,0)),U)," before submitting the claim"
226 . S RES=$$SUBMIT^IBNCPDPU(IBRX,IBFIL) W " ",$S(+RES=0:"Sent through ECME",1:"Not sent")
227 . I +RES'=0 W !?5,"*** ECME returned status: ",$$STAT(RES) S IBERR=IBERR+1
228 I 'IBERR W !!,"The selected Rx(s) have been submitted to ECME",!,"for electronic billing"
229 Q
230 ;
231BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
232 N RES,X,IBZ
233 S IBDT=$P(IBDT,".")
234 S RES=""
235 S X="" F S X=$O(^IBA(362.4,"B",IBRXN,X),-1) Q:X="" D:X Q:RES
236 . S IBZ=$G(^IBA(362.4,X,0))
237 . I $P($P(IBZ,U,3),".")=IBDT,$P(IBZ,U,2) S RES=+$P(IBZ,U,2)
238 Q RES
239 ;
240 ;
241RXDATA(IBRX,IBFIL) ;
242 ;RxIEN^Rx#^Fill#^RelDate^DrugIEN^BillIEN
243 N IBRXN,IBDT,IBDRUG,IBBIL,DATRET
244 S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
245 I IBFIL=0 S IBDT=$$FILE^IBRXUTL(IBRX,22)
246 E S IBDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01)
247 S IBDT=$P(IBDT,".")
248 S IBDRUG=$$FILE^IBRXUTL(IBRX,6)
249 S IBBIL=$$BILL(IBRXN,IBDT)
250 S DATRET=IBRX_"^"_IBRXN_"^"_IBFIL_"^"_IBDT_"^"_IBDRUG_"^"_IBBIL
251 Q DATRET
252 ;
253DISP(IBITEM) ;
254 N IBD,IBBILN,IBDRUG,IBBIL
255 S IBD=$G(@IBREF@(IBITEM)) Q:IBD=""
256 W !,IBITEM," ",?4,$P(IBD,U,2)," ",?15,$P(IBD,U,3)," ",?20,$$DAT2^IBOUTL($P(IBD,U,4))," "
257 W ?32,$E($$DRUG^IBRXUTL1(+$P(IBD,U,5)),1,30)
258 S IBBIL=$P(IBD,U,6)
259 I IBBIL W ?64,$P($G(^DGCR(399,+IBBIL,0)),U) I $P($G(^DGCR(399,IBBIL,"S")),U,16) W "(canc)"
260 Q
261 ;
262PARSE(X) ;
263 N I,J,N
264 S X=$TR(X," ")
265 S X=$TR(X,";",",")
266 I $TR(IBSEL,"al","AL")="ALL" D Q
267 . F I=1:1 Q:'$D(@IBREF@(I)) S IBSEL(I)=""
268 F I=1:1:$L(X,",") S N=$P(X,",",I) D:N'=""
269 . I N'["-" D:N Q
270 . . I $D(@IBREF@(N)) S X(N)=""
271 . ; Processing range
272 . N N1,N2
273 . S N1=+$P(N,"-",1),N2=+$P(N,"-",2)
274 . F J=N1:$S(N2<N1:-1,1:1):N2 I $D(@IBREF@(J)) S X(J)=""
275 Q
276 ;
277PAUSE(MESSAGE) ;
278 W !
279 I $G(MESSAGE)'="" W MESSAGE,". "
280 W "Press RETURN to continue: "
281 R %:DTIME
282 Q
283 ;
284SC(IEN) ;Service connected
285 N IBT
286 I 'IEN Q 0
287 S IBT=$P($G(^IBE(356.8,IEN,0)),U)
288 I IBT="NEEDS SC DETERMINATION" Q 1
289 I IBT="OTHER" Q 1
290 ;
291 Q 0
Note: See TracBrowser for help on using the repository browser.