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

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

initial load of FOIAVistA 6/30/08 version

File size: 8.2 KB
Line 
1IBNCPDPU ;OAK/ELZ - UTILITIES FOR NCPCP ;24-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**223,276,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;NCPDP PHASE III
6 Q
7 ;IA 4702
8 ;
9 ;
10CT(DFN,IBRXN,IBFIL,IBADT,IBRMARK) ; files in claims tracking
11 ; Input:
12 ; DFN - Patient IEN
13 ; IBRXN - Rx IEN
14 ; IBFIL - Fill#
15 ; IBADT - Fill Date
16 ; IBRMARK - Non-billable Reason (.01 from 356.8)
17 ;
18 N DIE,DR,DA,IBRXTYP,IBEABD
19 I IBTRKRN D:$D(IBRMARK) Q
20 . S DIE="^IBT(356,",DA=IBTRKRN,DR=".19///"_IBRMARK D ^DIE
21 ; event type pointer for rx billing
22 S IBRXTYP=$O(^IBE(356.6,"AC",4,0))
23 ; earliest auto-billing date
24 S IBEABD=$$EABD^IBTUTL(IBRXTYP,$$FMADD^XLFDT(IBADT,60))
25 ; space out earliest auto bill date
26 D REFILL^IBTUTL1(DFN,IBRXTYP,IBADT,IBRXN,IBFIL,$G(IBRMARK),IBEABD)
27 Q
28 ;
29NDC(X) ; Massage the NDC as it is stored in Pharmacy
30 ; Input: X -- The NDC as it is stored in Pharmacy
31 ; Output: X -- The NDC in the format 5N 1"-" 4N 1"-" 2N
32 ;
33 I $G(X)="" S X="" G NDCQ
34 ;
35 N LEN,PCE,Y,Z
36 ;
37 S Z(1)=5,Z(2)=4,Z(3)=2
38 S PCE=0 F S PCE=$O(Z(PCE)) Q:'PCE S LEN=Z(PCE) D
39 .S Y=$P(X,"-",PCE)
40 .I $L(Y)>LEN S Y=$E(Y,2,LEN+1)
41 .I $L(+Y)<LEN S Y=$$FILL(Y,LEN)
42 .S $P(X,"-",PCE)=Y
43 ;
44NDCQ Q X
45 ;
46FILL(X,LEN) ; Zero-fill, right justified.
47 N Y
48 S:'$G(LEN) LEN=1
49 S Y=$E($G(X),1,LEN)
50 F Q:$L(Y)>(LEN-1) S Y="0"_Y
51 Q Y
52 ;
53PLANN(DFN,IBX,IBADT) ; returns the ien in the insurance multiple for the given plan
54 ; /patient privided.
55 ; ien in multiple^insurance co ien
56 N IBPOL,IBY,IBR
57 S IBR=""
58 D ALL^IBCNS1(DFN,"IBPOL",3,IBADT)
59 S IBY=0 F S IBY=$O(IBPOL(IBY)) Q:IBY<1!(IBR) I $P(IBPOL(IBY,0),"^",18)=IBX S IBR=$P(IBPOL(IBY,0),"^")_"^"_IBY
60 Q IBR
61 ;
62RT(DFN,IBINS,IBN) ; returns rate type to use for bill
63 ; pass in insurance by ref and which insurance entry to use
64 ; if '$d(ibn) then it loops through to find the first one
65 ; format is RT (ien) ^ Rate Type (Tort or Awp or Cost)
66 N VAEL,VAERR,IBPT,IBRT,IBX
67 D ELIG^VADPT
68 ;
69 ; if primary elig is vet type, use reimbursable
70 S IBPT=$P($G(^DIC(8,+VAEL(1),0)),"^",5) ; = N:NON-VETERAN;Y:VETERAN
71 I IBPT="Y" S IBRT=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0)) Q $S(IBRT:IBRT,1:8)_"^T"
72 ;
73 ;**** temp for initial testing only, we are not doing Tricare or Champva
74 Q $S($D(IBRT):IBRT,1:"0^unable to determine rate type")
75 ;
76 ; if primary elig is TRICARE/CHAMPUS use one of the champus', depending
77 ; on insurance coverage
78 I $P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(3),0)),"^",9),0)),"^")="TRICARE/CHAMPUS" S IBRT=$$UINS("CHAMPUS",.IBINS,.IBN)
79 ;
80 ; if primary elig is CHAMPVA use one of the champva's, depending
81 ; on insurance coverage
82 I $P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(3),0)),"^",9),0)),"^")="CHAMPVA" S IBRT=$$UINS("CHAMPVA",.IBINS,.IBN)
83 ;
84 Q $S($D(IBRT):IBRT,1:"0^unable to determine rate type")
85 ;
86 ;
87UINS(IBT,IBINS,IBN) ; in the case of tricare or champva you may have to use
88 ; insurance different rate types insted of the actual tricare or champva
89 N IBRT
90 S IBN=+$G(IBN,$O(IBINS("S",+$O(IBINS("S",0)),0)))
91 I $P($G(^IBE(355.1,+$P($G(IBINS(IBN,355.3)),"^",9),0)),"^")=IBT S IBRT=$O(^DGCR(399.3,"B",IBT,0)),IBRT=$S(IBRT:IBRT_"^"_$S(IBT="CHAMPUS":"A",1:"C"),1:"0^"_IBT_" Rate type not found")
92 I '$D(IBRT) S IBRT=$O(^DGCR(399.3,"B",IBT_" REIMB. INS.",0)),IBRT=$S(IBRT:IBRT_"^"_$S(IBT="CHAMPUS":"A",1:"C"),1:"0^"_IBT_" REIMB. INS. Rate type not found")
93 Q IBRT
94 ;
95BS() ; returns the mccr utility to use
96 N IBX
97 S IBX=0 F S IBX=$O(^DGCR(399.1,"B","PRESCRIPTION",IBX)) Q:IBX<1 I $P($G(^DGCR(399.1,+$G(IBX),0)),U,5) Q
98 Q IBX
99 ;
100 ; Match IB Bill by the 7-digit ECME number
101RXBIL(IBINP,IBERR) ; Matching NCPDP payments
102 ;Input:
103 ; IBINP("ECME") - the 7-digit ECME number (Reference Number)
104 ; IBINP("FILLDT") - the Rx fill date, YYYYMMDD or FileMan format
105 ; IBINP("PNM") (optional) - the patient's last name
106 ;Returns:
107 ; IBERR (by ref) - the error code, or null string if found
108 ; $$RXBIL - IB Bill IEN, or 0 if not matched
109 N IBKEY,IBECME,BILLDA,IBFOUND,IBMATCH,IBDAT,IBPNAME
110 S IBERR=""
111 S IBECME=$G(IBINP("ECME"))
112 I IBECME'?1.7N S IBERR="Invalid ECME number" Q 0
113 S IBDAT=$G(IBINP("FILLDT")) ; Rx fill date
114 I IBDAT?8N S IBDAT=($E(IBDAT,1,4)-1700)_$E(IBDAT,5,8) ; conv date to FM format
115 I IBDAT'?7N Q $$RXBILND(IBECME) ; date is not correct or null
116 S IBPNAME=$G(IBINP("PNM")) ; patient's name (optional)
117 S IBKEY=+IBECME_";"_IBDAT ; The ECME Number (BC ID)
118 S BILLDA="",IBFOUND=0,IBMATCH=0
119 ; Search backward
120 F S BILLDA=$O(^DGCR(399,"AG",IBKEY,BILLDA),-1) Q:BILLDA="" D Q:IBFOUND
121 . I 'BILLDA Q ; IEN must be numeric
122 . I '$D(^DGCR(399,BILLDA,0)) Q ; Corrupted index
123 . S IBMATCH=1
124 . I IBPNAME'="" I '$$TXMATCH($P(IBPNAME,","),$P($G(^DPT(+$P(^DGCR(399,BILLDA,0),U,2),0)),","),8) Q ; Patient name doesn't match
125 . S IBFOUND=1
126 I 'BILLDA S IBERR=$S(IBMATCH:"Patient's name does not match",1:"Matching bill not found") ; not matched
127 Q +BILLDA
128 ;
129RXBILND(IBECME) ;Match the bill with no date
130 N IBKEY,IBBC,BILLDA,IBY,IBCUT
131 S IBKEY=+IBECME_";"
132 S IBCUT=$$FMADD^XLFDT(DT,-180) ; only 180 days in the past
133 S BILLDA=0
134 ; Search PRNT/TX forward
135 S IBBC=IBKEY_IBCUT
136 F S IBBC=$O(^DGCR(399,"AG",IBBC)) Q:IBBC'[IBKEY D Q:BILLDA
137 . S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY)) Q:'IBY D Q:BILLDA
138 .. I $P($G(^DGCR(399,+IBY,0)),U,13)'=4 Q ; not PRNT/TX
139 .. S BILLDA=+IBY
140 I BILLDA Q BILLDA
141 ; Search ANY backward
142 S IBBC=IBKEY_"8000000"
143 F S IBBC=$O(^DGCR(399,"AG",IBBC),-1) Q:IBBC'[IBKEY Q:$P(IBBC,";",2)<IBCUT D Q:BILLDA
144 . S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY),-1) Q:IBY="" D Q:BILLDA
145 .. ;I $P($G(^DGCR(399,+IBY,0)),U,13)'=7 Q ; not CANCELLED
146 .. S BILLDA=+IBY
147 Q BILLDA
148 ;
149 ;Check matching of two strings - case insensitive, no spaces etc.
150TXMATCH(IBTXT1,IBTXT2,IBMAX) ;
151 N IBTR1,IBTR2,IBT1,IBT2
152 ;Checking only first IBMAX characters (long names may be trancated
153 S IBTR1="ABCDEFGHIJKLMNOPQRSTUVWXYZ:;"",'._()<>/\|@#$%&*-=!`~ "
154 S IBTR2="abcdefghijklmnopqrstuvwxyz"
155 S IBT1=$E($TR(IBTXT1,IBTR1,IBTR2),1,IBMAX)
156 S IBT2=$E($TR(IBTXT2,IBTR1,IBTR2),1,IBMAX)
157 Q IBT1=IBT2
158 ;
159ECMEBIL(DFN,IBADT) ; Is the pat ECME Billable (pharmacy coverage only)
160 ; DFN - ptr to the patient
161 ; IBADT - the date
162 N IBANY,IBERMSG,IBX,IBINS,IBT,IBZ,IBRES,IBCAT,IBCOV,IBPCOV
163 S IBRES=0 ; Not ECME Billable by default
164 S (IBCOV,IBPCOV)=0
165 ; -- look up ins with Rx
166 D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
167 S IBERMSG="" ; Error message
168 S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0))
169 S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES
170 . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES
171 . . N IBZ,IBPIEN,IBY,IBPL
172 . . S IBZ=$G(IBINS(IBT,0))
173 . . S IBPL=+$P(IBZ,U,18) Q:'IBPL
174 . . S IBCOV=1 ; covered
175 . . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q
176 . . S IBPCOV=1
177 . . S IBPIEN=+$G(^IBA(355.3,IBPL,6))
178 . . I 'IBPIEN S IBERMSG="Plan not linked to the Payer" Q ; Not linked
179 . . D STCHK^IBCNRU1(IBPIEN,.IBY)
180 . . I $E($G(IBY(1)))'="A" S:IBERMSG="" IBERMSG=$$ERMSG^IBNCPDP1($P($G(IBY(6)),",")) Q
181 . . S IBRES=1
182 I 'IBCOV Q "0^Not Insured"
183 I 'IBPCOV Q "0^No Pharmacy Coverage"
184 I 'IBRES,IBERMSG'="" Q "0^"_IBERMSG
185 I 'IBRES Q "0^No Insurance ECME billable"
186 ;
187 Q IBRES
188 ;
189SUBMIT(IBRX,IBFIL) ; Submit the Rx claim through ECME
190 ; IBRX - RX ien in file #52
191 ; IBFIL - Fill No (0 for orig fill)
192 N IBDT,IBNDC,IBX
193 I '$G(IBRX)!('$D(IBFIL)) Q "0^Invalid parameters."
194 S IBDT=$S('IBFIL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01))
195 S IBX=$$EN^BPSNCPDP(+IBRX,+IBFIL,IBDT,"BB")
196 I +IBX=0 D ECMEACT^PSOBPSU1(+IBRX,+IBFIL,"Claim submitted to 3rd party payer: IB BACK BILLING")
197 Q IBX
198 ;
199REASON(IBX,EXACT) ; Close Claim Reasons
200 Q $P($G(^IBE(356.8,+IBX,0)),U) ; non-billable reason
201 ;
202NABP(IBIFN) ;NABP Number
203 N IBY,IBTRKN,IBRX,IBFIL,IBZ,IBNABP
204 S IBY=+$O(^IBT(356.399,"C",IBIFN,0)) I 'IBY Q ""
205 S IBTRKN=$P($G(^IBT(356.399,IBY,0)),U) I 'IBTRKN Q ""
206 S IBZ=$G(^IBT(356,IBTRKN,0)) I IBZ="" Q ""
207 S IBRX=$P(IBZ,U,8)
208 S IBFIL=$P(IBZ,U,10)
209 S IBNABP=$$NABP^BPSBUTL(IBRX,IBFIL)
210 Q $S(IBNABP=0:"",1:IBNABP)
211 ;
212 ; Get the K-bill# from CT
213BILL(IBRX,IBFIL) ;
214 N IBTRKN,IBIFN
215 S IBTRKN=+$O(^IBT(356,"ARXFL",+$G(IBRX),+$G(IBFIL),""))
216 S IBIFN=+$P($G(^IBT(356,IBTRKN,0)),U,11)
217 Q $P($G(^DGCR(399,IBIFN,0)),U)
218 ;
219REJECT(IBECME,IBDATE) ; Is the e-claim rejected?
220 N IBINP,IBTRKRN,IBY
221 I IBECME'?1.7N Q 0
222 ;S IBINP("ECME")=IBECME
223 ;S IBINP("FILLDT")=IBDATE
224 ;I $$RXBIL(.IBINP) Q 0 ; bill exists
225 S IBTRKRN=+$O(^IBT(356,"AE",IBECME,0)) I 'IBTRKRN Q 0
226 S IBY=$G(^IBT(356,IBTRKRN,1))
227 I $P(IBY,U,11)>0 Q 1 ; Rejected or closed
228 Q 0
229 ;
230 ;
231 ;IBNCPDPU
Note: See TracBrowser for help on using the repository browser.