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

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

initial load of FOIAVistA 6/30/08 version

File size: 6.8 KB
Line 
1IBNCPDP2 ;OAK/ELZ - PROCESSING FOR ECME RESP ;20-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**223,276,342,347,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 ;
8ECME(DFN,IBD) ; function called by STORESP^IBNCPDP
9 ; input - DFN - patient IEN for the prescription
10 ; IBD array passed in by reference
11 ; The IBD array is passed to various subroutines depending
12 ; on the ePharmacy event as evaluated by IBD("STATUS")
13 I $G(IBD("EPHARM"))="" S IBD("EPHARM")=$$EPHARM(+$G(IBD("PRESCRIPTION")),+$G(IBD("FILL NUMBER")))
14 I IBD("STATUS")="PAID" Q $$BILL(DFN,.IBD)
15 I IBD("STATUS")="REVERSED" Q $$REVERSE^IBNCPDP3(DFN,.IBD)
16 I IBD("STATUS")="CLOSED" Q $$CLOSE^IBNCPDP4(DFN,.IBD)
17 I IBD("STATUS")="RELEASED" Q $$RELEASE^IBNCPDP4(DFN,.IBD)
18 I IBD("STATUS")="SUBMITTED" Q $$SUBMIT^IBNCPDP4(DFN,.IBD)
19 I IBD("STATUS")="REOPEN" Q $$REOPEN^IBNCPDP4(DFN,.IBD)
20 D LOG("UNKNOWN")
21 Q "0^Cannot determine ECME event status"
22 ;
23MATCH(BCID) ;
24 N IBX,IBHAVE
25 S IBX=0,IBHAVE=0 F S IBX=$O(^DGCR(399,"AG",BCID,IBX)) Q:'IBX S IBHAVE=1 I '$P($G(^DGCR(399,IBX,"S")),U,16) Q
26 I 'IBX,IBHAVE Q ""
27 Q +IBX
28 ;
29 ;
30BILL(DFN,IBD) ; create fi bill
31 N IBRVCD,IBBS,IBUNITS,IBCPT,IBDIV,IBAA,IBTYPE,IBITEM,IBAMT,IBY,IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN,PRCASV,PRCAERR,IBADT,IBRXN,IBFIL,IBTRKRN,DIE,DA,DR,IBRES,IBLOCK,IBLDT,IBNOW,IBDUZ,RCDUZ,IBPREV,IBQUERY,IBPAID,IBACT
32 ;
33 S IBDUZ=.5 ;POSTMASTER
34 ;I $G(IBD("FILLED BY")),$D(^VA(200,+IBD("FILLED BY"))) S IBDUZ=+IBD("FILLED BY")
35 S RCDUZ=IBDUZ
36 ;
37 S IBY=1,IBLOCK=0
38 I 'DFN S IBY="0^Missing DFN" G BILLQ
39 S IBAMT=+$G(IBD("BILLED")) ;FI portion of charge
40 I 'IBAMT S IBY="-1^Zero amount billed" G BILLQ
41 S IBADT=+$G(IBD("FILL DATE"),DT)
42 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^Missing Rx IEN" G BILLQ
43 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G BILLQ
44 S IBDIV=+$G(IBD("DIVISION"))
45 I '$L($G(IBD("CLAIMID"))) S IBY="-1^Missing ECME Number" G BILLQ
46 S IBD("BCID")=(+IBD("CLAIMID"))_";"_IBADT ; The BCID#
47 L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number." G BILLQ
48 S IBLOCK=1
49 S IBLDT=$G(^DGCR(399,"AG",IBD("BCID"))) ;Last time called
50 D NOW^%DTC S IBNOW=%
51 ; 2 calls in 45 sec
52 I $P(IBLDT,"^",2)="B" I $$FMDIFF^XLFDT(IBNOW,+IBLDT,2)<45 S IBY="0^Duplicate billing call" G BILLQ
53 ;
54 I $$MATCH(IBD("BCID")) D ;cancel the previous bill
55 . N IBARR M IBARR=IBD I $$REVERSE^IBNCPDP3(DFN,.IBARR,2)
56 ;
57 ; derive minimal variables
58 I '$$CHECK^IBECEAU(0) S IBY="-1^IB SITE" G BILLQ
59 S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4)
60 I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB SERVICE" G BILLQ
61 I 'IBDIV S IBDIV=$P($$MCDIV^IBNCPEB(IBRXN,IBFIL),U,2)
62 I 'IBDIV S IBDIV=+$P($G(^SC(+$$FILE^IBRXUTL(IBRXN,5),0)),"^",15)
63 I 'IBDIV S IBDIV=+$P($G(^IBE(350.9,1,1)),U,25) ;dflt
64 I IBDIV S IBD("DIVISION")=IBDIV
65 ; - establish a stub claim/receivable
66 D SET^IBR I IBY<0 G BILLQ
67 ;
68 ; set up the following variables for claim establishment:
69 ; .01 BILL #
70 ; .17 ORIG CLAIM
71 ; .2 AUTO?
72 ; .02 DFN
73 ; .06 TIMEFRAME
74 ; .07 RATE TYPE
75 ; .18 SC AT TIME?
76 ; .04 LOCATION
77 ; .22 DIVISION
78 ; .05 BILL CLASSIF (3)
79 ; .03 EVT DATE (FILL DATE)
80 ; 151 BILL FROM
81 ; 152 BILL TO
82 ; 101 PRIMARY INS CARRIER
83 K IB
84 S (IB(.02),IBDFN)=DFN
85 S IB(.07)=+$$RT^IBNCPDPU(DFN)
86 I 'IB(.07) S IBY="-1^IB RATE TYPE" G BILLQ
87 ;
88 S IBIFN=PRCASV("ARREC")
89 S IB(.01)=$P(PRCASV("ARBIL"),"-",2)
90 S IB(.17)=""
91 S IB(.2)=0
92 S IB(.06)=1
93 S IB(.18)=$$SC^IBCU3(DFN)
94 S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1)
95 S:IBDIV IB(.22)=+IBDIV
96 S IB(.05)=3
97 S (IB(.03),IB(151),IB(152))=IBADT
98 S IBINS=$P($G(^IBA(355.3,+$G(IBD("PLAN")),0)),"^") I IBINS S IB(101)=IBINS
99 ;
100 ; set 362.4 node to rx#^p50^days sup^fill date^qty^ndc
101 S IB(362.4,IBRXN,1)=IBD("RX NO")_"^"_IBD("DRUG")_"^"_IBD("DAYS SUPPLY")_"^"_IBD("FILL DATE")_"^"_IBD("QTY")_"^"_IBD("NDC")
102 ;
103 ; call the autobiller module to create the claim with a default
104 ; diagnosis and procedure for prescriptions
105 D EN^IBCD3(.IBQUERY)
106 D CLOSE^IBSDU(.IBQUERY)
107 ;
108 S ^DGCR(399,"AG",IBD("BCID"))=IBNOW_"^B"
109 S DIE="^DGCR(399,",DA=IBIFN
110 ; update the ECME fields
111 S DR="460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")"
112 D ^DIE K DA,DR,DIE
113 D SETCT ; Set Claims Tracking record
114 ;
115 ; IEN to 2.3121
116 S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBADT)
117 I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ
118 ;
119 ; add the payer (fiscal intermediary) to the claim
120 S IBINS=+IBCDFN,IBCDFN=$P(IBCDFN,"^",2)
121 S DIE="^DGCR(399,",DA=IBIFN,DR="112////"_IBCDFN
122 D ^DIE K DA,DR,DIE,DGRVRCAL
123 ;
124 ; need to make sure we have computed charges.
125 D BILL^IBCRBC(IBIFN)
126 ;
127 ; update the authorize/print fields
128 S DIE="^DGCR(399,",DA=IBIFN
129 S DR="9////1;12////"_DT D ^DIE
130 K DA,DR,DIE
131 ;
132 ; pass the claim to AR
133 D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6
134 I 'PRCASV("OKAY") S IBY="-1^Cannot establish receivable in AR." G BILLQ
135 D REL^PRCASVC
136 ;
137 ; update the AR status to Active
138 ; D AUDITX^PRCAUDT(PRCASV("ARREC"))
139 S PRCASV("STATUS")=16
140 D STATUS^PRCASVC1
141 ;
142 ; decrease adjust bill
143 ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
144 S IBAMT=$G(^DGCR(399,IBIFN,"U1"))
145 S IBPAID=IBD("PAID")
146 D:IBAMT-IBPAID>.01
147 . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBPAID,IBDUZ,"Adjust based on ECME amount paid.",IBADT)
148 . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed
149 ;
150 D ; set the user in 399
151 . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ
152 . D FILE^DIE("","IBT")
153 ;
154BILLQ S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBIFN):+IBIFN,1:IBY)
155 I $G(IBIFN) S IBD("BILL")=IBIFN
156 D LOG("BILL",IBRES)
157 I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBIFN))
158 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
159 Q IBRES
160 ;
161 ; update claims tracking saying bill has been billed
162SETCT ;
163 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
164 I IBTRKRN S DIE="^IBT(356,",DA=IBTRKRN,DR=".11////^S X=IBIFN;.17///@" D ^DIE
165 I IBTRKRN,IBIFN D CTB^IBCDC(IBTRKRN,IBIFN)
166 Q
167 ;
168 ;/**
169 ;Log values passed into IB by outside applications
170 ;
171 ;implicit input variables/arrays :
172 ; IBD array with values sent to IB (see calling subroutines)
173 ; DFN - patient's IEN (file #2)
174 ; DUZ - user's IEN(file #200)
175 ;explicit parameters:
176 ; PROC - type of event as string, i.e. BILL, REJECT and so on
177 ; RESULT - result of the event processing, format: return_code^message
178LOG(PROC,RESULT) ;Store the data
179 D LOG^IBNCPLOG(.IBD,DFN,PROC,RESULT,$J,$$NOW^XLFDT(),+DUZ)
180 Q
181 ;
182 ;returns ien of #9002313.56 BPS PHARMACIES associated
183 ;with the prescription specified by:
184 ; IBRX - IEN in file #52
185 ; IBREFILL - zero(0) for the original prescription or the refill
186 ; number for a refill (IEN of REFILL multiple #52.1)
187EPHARM(IBRX,IBREFILL) ;
188 I +$G(IBRX)=0 Q ""
189 I $G(IBREFILL)="" Q ""
190 N IBDIV59
191 S IBDIV59=+$$RXSITE^PSOBPSUT(+IBRX,+IBREFILL)
192 I IBDIV59>0 Q $$GETPHARM^BPSUTIL(IBDIV59)
193 Q ""
194 ;
195 ;IBNCPDP2
Note: See TracBrowser for help on using the repository browser.