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

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

initial load of FOIAVistA 6/30/08 version

File size: 8.4 KB
Line 
1IBNCPDP1 ;OAK/ELZ - PROCESSING FOR NEW RX REQUESTS ;20-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**223,276,339,363**;21-MAR-94;Build 35
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;NCPDP PHASE III
6 Q
7 ;
8RX(DFN,IBD) ; pharmacy package call, passing in IBD by ref
9 ; this is called by PSO for all prescriptions issued, return is
10 ; a response to bill ECME or not with array for billing data elements
11 ;
12 K IBD("SC/EI NO ANSW") ;clean up the list of non-answered SC/Env.indicators questions
13 ;warning: back-billing flag:
14 ;if passed IBSCRES(IBRXN,IBFIL)=1
15 ; - the the SC Determination is just done by the IB clerk (billable)
16 ;
17 ;retrieve indicators from file #52 and overwrite the indicators in IBD array
18 D GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD)
19 N IBTRKR,IBARR,IBADT,IBRXN,IBFIL,IBTRKRN,IBRMARK,IBANY,IBX,IBT,IBINS,IBSAVE
20 N IBFEE,IBEABD,IBBI,IBIT,IBPRICE,IBRS,IBRT,IBTRN,IBCHG,IBERMSG,IBRES,IBNEEDS
21 S IBRES="0^Error"
22 K IBD("INS")
23 I '$G(DFN) S IBRES="0^No DFN" G RXQ
24 S (IBEABD,IBADT)=+$G(IBD("FILL DATE"),DT)
25 S IBRXN=+$G(IBD("IEN")) I 'IBRXN S IBRES="0^No Rx IEN" G RXQ
26 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RXQ
27 S IBD("QTY")=+$G(IBD("QTY"))
28 I 'IBD("QTY") S IBRES="0^No Quantity" G RXQ
29 ;
30 ; -- claims tracking info
31 S IBTRKR=$G(^IBE(350.9,1,6))
32 ; date can't be before parameters
33 S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
34 ; already in claims tracking
35 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
36 I IBTRKRN,$$PAPERBIL(IBTRKRN) S IBRES="0^Existing IB Bill in CT" G RXQ
37 ;
38 I $G(IBD("DEA"))="" D CT S IBRES="0^Null DEA Special Handling field" G RXQ
39 ;
40 ; -- no pharmacy coverage, update ct if applicable, quit
41 I '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"SERVICE NOT COVERED",1:"NOT INSURED") D:$P(IBTRKR,U,4)=2 CT S IBRES="0^"_IBRMARK G RXQ
42 ;
43 ;
44 ; -- check for compound, NOT BILLABLE
45 I IBD("DEA")["M"!(IBD("DEA")["0") S IBRMARK="DRUG NOT BILLABLE" D CT S IBRES="0^COMPOUND DRUG" G RXQ
46 ; -- check drug (not investigational, supply, or over the counter drug
47 ; "E" means always ecme billable
48 I (IBD("DEA")["I"!(IBD("DEA")["S")!(IBD("DEA")["9")),IBD("DEA")'["E" S IBRMARK="DRUG NOT BILLABLE" D CT S IBRES="0^"_IBRMARK G RXQ
49 ;
50 ; -- process patient exemptions if any (if not already resolved)
51 I $G(IBD("SC/EI OVR"))'=1 D CL^SDCO21(DFN,IBADT,"",.IBARR)
52 ; check out exemptions
53 S IBNEEDS=0 ;flag will be set to 1 if at least one of the questions wasn't answered
54 I $G(IBD("SC/EI OVR"))'=1 I $D(IBARR)>9 F IBX=2:1 S IBT=$P($T(EXEMPT+IBX),";;",2) Q:IBT="" D:$D(IBARR(+IBT))
55 . I $G(IBD($P(IBT,U,2)))=0 Q
56 . I $G(IBD($P(IBT,U,2))) S IBRMARK=$P(IBT,U,3) Q
57 . I '$G(IBSCRES(IBRXN,IBFIL)) S IBNEEDS=1 D
58 . . S IBD("SC/EI NO ANSW")=$S($G(IBD("SC/EI NO ANSW"))="":$P(IBT,U,2),1:$G(IBD("SC/EI NO ANSW"))_","_$P(IBT,U,2))
59 I '$D(IBRMARK),IBNEEDS=1 S IBRMARK="NEEDS SC DETERMINATION"
60 I $D(IBRMARK) D CT S IBRES="0^"_IBRMARK G RXQ
61 ; Clean-up the NEEDS SC DETERMINATION record if resolved
62 ; And check if it is non-billable in CT
63 I IBTRKRN D
64 . N IBNBR,IBNBRT
65 . S IBNBR=$P($G(^IBT(356,+IBTRKRN,0)),U,19) Q:'IBNBR
66 . S IBNBRT=$P($G(^IBE(356.8,IBNBR,0)),U) Q:IBNBRT=""
67 . ; if refill was deleted (not RX) and now the refill is re-entered
68 . ;use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA"))
69 . I IBNBRT="PRESCRIPTION DELETED",$$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13 D Q
70 . . N DIE,DA,DR
71 . . ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT
72 . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
73 . ; Clean up NBR if released
74 . I IBNBRT="PRESCRIPTION NOT RELEASED" D:$G(IBD("RELEASE DATE")) Q
75 . . N DIE,DA,DR
76 . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
77 . ; Clean up 'Needs SC determ'
78 . I IBNBRT="NEEDS SC DETERMINATION" D Q
79 . . N DIE,DA,DR
80 . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
81 . S IBRMARK=IBNBRT
82 I $D(IBRMARK) S IBRES="0^Non-Billable in CT: "_IBRMARK G RXQ
83 ;
84 ; -- look up insurance for patient
85 D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
86 S IBERMSG="" ; Error message
87 S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D
88 . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D
89 .. N IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ
90 .. S IBZ=IBINS(IBT,0)
91 .. S IBPL=$P(IBZ,U,18) ; plan
92 .. Q:'IBPL
93 .. Q:'$$PLCOV^IBCNSU3(IBPL,IBADT,3) ; not covered
94 .. S IBINSN=$P($G(^DIC(36,+$G(^IBA(355.3,+IBPL,0)),0)),U) ; ins name
95 .. S IBPIEN=+$G(^IBA(355.3,+IBPL,6))
96 .. I 'IBPIEN S IBERMSG="Plan not linked to the Payer" Q ; Not linked
97 .. D STCHK^IBCNRU1(IBPIEN,.IBY)
98 .. I $E($G(IBY(1)))'="A" S IBERMSG=$$ERMSG($P($G(IBY(6)),",")) Q ; not active
99 .. S IBDAT=IBPL ; Plan IEN
100 .. S $P(IBDAT,U,2)=$G(IBY(2)) ; BIN
101 .. S $P(IBDAT,U,3)=$G(IBY(3)) ; PCN
102 .. S $P(IBDAT,U,4)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",1),0)),U) ; Payer Sheet B1
103 .. S $P(IBDAT,U,5)=$P($G(IBINS(IBT,355.3)),U,4) ; Group ID
104 .. S $P(IBDAT,U,6)=$P(IBZ,U,2) ; Cardholder ID
105 .. S $P(IBDAT,U,7)=$P(IBZ,U,16) ; Patient Relationship Code
106 .. S $P(IBDAT,U,8)=$P($P($P(IBZ,U,17),",",2)," ") ; Cardholder First Name
107 .. S $P(IBDAT,U,9)=$P($P(IBZ,U,17),",") ; Cardholder Last Name
108 .. S $P(IBDAT,U,10)=$P($G(^DIC(36,+IBZ,.11)),U,5) ; State
109 .. S $P(IBDAT,U,11)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",2),0)),U) ; Payer Sheet B2
110 .. S $P(IBDAT,U,12)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",3),0)),U) ; Payer Sheet B3
111 .. S $P(IBDAT,U,13)=$G(IBY(4)) ; Software/Vendor Cert ID
112 .. S $P(IBDAT,U,14)=IBINSN ; Ins Name
113 .. S IBD("INS",IBX,1)=IBDAT
114 .. S IBD("INS",IBX,3)=$P($G(IBINS(IBT,355.3)),"^",3)_"^"_$$PHONE(+IBZ)_"^"_$$GET1^DIQ(366.03,IBPIEN_",",.01) ;group name^ins co ph 3^plan ID
115 I '$D(IBD("INS")),IBERMSG'="" S IBRES="0^Not ECME billable: "_IBERMSG G RXQ
116 I '$D(IBD("INS")) S IBRES="0^No Insurance ECME billable" G RXQ
117 ;
118 ; determine rates/prices to use
119 S IBRT=$$RT^IBNCPDPU(DFN,.IBINS)
120 I 'IBRT D CT S IBRES="0^Cannot determine Rate type" G RXQ
121 S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS)
122 I 'IBBI D CT S IBRES="0^Cannot find Billable Item" G RXQ
123 ;1;BEDSECTION;1^
124 ;IBRS(1,18,5)=
125 S IBRS=+$O(IBRS(+IBBI,0))
126 S IBIT=$$ITPTR^IBCRU2(+IBBI,$S($P(IBRT,U,2)="A":$$NDC^IBNCPDPU($G(IBD("NDC"))),1:"PRESCRIPTION"))
127 I 'IBIT,$P(IBRT,U,2)'="C" D CT S IBRES="0^Cannot find Item Pointer" G RXQ
128 ;8
129 S IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$S($P(IBRT,U,2)="A":IBD("QTY"),1:1))
130 ;36^2991001
131 ;
132 ; get fees if any, ignore return, don't care about price, just need fees
133 S IBCHG=$$RATECHG^IBCRCC(+IBRS,$S($P(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE)
134 I $P(IBRT,U,2)="C" S IBPRICE=+IBCHG
135 ;
136 I 'IBPRICE D CT S IBRES="0^Cannot find price for Item" G RXQ
137 ;
138 S IBPRICE=(+$G(IBFEE))_U_$S($P(IBRT,U,2)="A":"01",$P(IBRT,U,2)="C":"05",1:"07")_U_$S($P(IBRT,U,2)="C":IBD("QTY")*IBD("COST"),$P(IBRT,U,2)="A":IBPRICE-$G(IBFEE)-$P($G(IBFEE),U,2),1:IBPRICE)_U_IBPRICE_U_(+$P($G(IBFEE),U,2))
139 S IBX=0 F S IBX=$O(IBD("INS",IBX)) Q:IBX<1 S IBD("INS",IBX,2)=IBPRICE ;_U_$P(IBPAYER,U,6)
140 ;
141 S IBRES=$S($D(IBRMARK):"0^"_IBRMARK,1:1)
142 I IBRES,'$G(IBD("RELEASE DATE")) S IBRMARK="PRESCRIPTION NOT RELEASED"
143 D CT
144 ;
145RXQ D LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES)
146 Q IBRES
147 ;
148 ;
149CT ; files in claims tracking
150 I IBTRKR D CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$G(IBRMARK))
151 Q
152 ;
153EXEMPT ; exemption reasons
154 ; variable from SD call ^ variable from PSO ^ reason not billable
155 ;;1^AO^AGENT ORANGE
156 ;;2^IR^IONIZING RADIATION
157 ;;3^SC^SC TREATMENT
158 ;;4^SWA^SOUTHWEST ASIA
159 ;;5^MST^MILITARY SEXUAL TRAUMA
160 ;;6^HNC^HEAD/NECK CANCER
161 ;;7^CV^COMBAT VETERAN
162 ;;8^SHAD^PROJECT 112/SHAD
163 ;;
164 ;
165ERMSG(IBSTL) ; Inactive status reason
166 N IBSTA,IBI,IBARR,IBTXT
167 D STATAR^IBCNRU1(.IBARR)
168 F IBI=1:1:$L(IBSTL,",")+1 S IBSTA=+$P(IBSTL,",",IBI) Q:"^100^200^300^400^"'[(U_IBSTA_U)
169 S IBTXT=$G(IBARR(+IBSTA),"Plan is not active.")
170 Q IBTXT
171 ;
172NEEDSC(IBTXT) ; is the CT NBR one of 'needs sc determination'?
173 I IBTXT="NEEDS SC DETERMINATION" Q 1
174 N I,RES,IBT
175 S RES=0
176 F I=2:1 S IBT=$P($P($T(EXEMPT+I),";;",2),U,3) Q:IBT="" I IBT=IBTXT S RES=1 Q
177 Q RES
178 ;
179PAPERBIL(IBTRKRN) ; 'paper' bill in CT?
180 N IBZ,IBIFN
181 S IBZ=$G(^IBT(356,IBTRKRN,0)) I IBZ="" Q 0
182 S IBIFN=+$P(IBZ,U,11) I 'IBIFN Q 0
183 I $P($G(^DGCR(399,IBIFN,0)),U,13)=7 Q 0 ; cancelled
184 I $P($G(^DGCR(399,IBIFN,"M1")),U,8)'="" Q 0 ; ecme bill
185 Q 1
186 ;
187 ;gets the insurance phone
188 ;input:
189 ; IB36 - ptr to INSURANCE COMPANY File (#36)
190 ;output:
191 ; the phone number
192PHONE(IB36) ;
193 N IB1
194 ;check first CLAIMS (RX) PHONE NUMBER if empty
195 S IB1=$$GET1^DIQ(36,+IB36,.1311,"E")
196 Q:$L(IB1)>0 IB1
197 ;check BILLING PHONE NUMBER if empty - return nothing
198 S IB1=$$GET1^DIQ(36,+IB36,.132,"E")
199 Q IB1
200 ;
201 ;IBNCPDP1
Note: See TracBrowser for help on using the repository browser.