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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1IBECUS2 ;DVAMC/RLM - TRICARE PHARMACY BILL TRANSACTION ;14-AUG-96
2 ;;2.0;INTEGRATED BILLING;**52,89,143,162,240,274,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; Attempt to bill a prescription directly to the FI.
6 ; Input: IBKEY -- 1 ; 2, where
7 ; 1 = Pointer to the prescription in file #52
8 ; 2 = Pointer to the refill in file #52.1, or
9 ; 0 for the original fill
10 ; IBKEYD -- 1 ^ 2 ^ 3 ^ 4 ^ 5, where
11 ; 1 = Rx label printing device
12 ; 2 = Pointer to the Pharmacy in file #59
13 ; 3 = Pointer to the Pharmacy user in file #200
14 ; 4 = Pointer to the billing transaction
15 ; in file #351.5 (cancellations only)
16 ; 5 = Product Selection Reason
17 ; (Resubmissions only)
18 ; IBCHSET -- Pointer to the Charge Set in file #363.1
19 ; IBPRESCR -- Facility Prescriber ID number
20 ;
21 ; - get rx data; make sure there is an NDC
22 K IBDRX,IBERR,IBAWPV,IBRESP
23 N DFN,IBRX,IBITEM,IBAWP
24 N DIQUIET S DIQUIET=1 D DT^DICRW
25 S IBRX=+IBKEY,IBREF=+$P(IBKEY,";",2)
26 I $$TRANS^PSOCPTRI(IBRX,IBREF,.IBDRX)<0 S IBERR=1 G ENQ
27 ;
28 ; - make sure the AWP is available
29 S IBDRX("NDC")=$$NDC(IBDRX("NDC"))
30 S IBITEM=+$$FNDBI^IBCRU2("NDC",IBDRX("NDC"))
31 I 'IBITEM S IBERR=9 G ENQ ; NDC is not in CM
32 D ITMCHG^IBCRCC(IBCHSET,IBITEM,DT,"",.IBAWPV)
33 I +IBAWPV'=1 S IBERR=10 G ENQ ; Not 1 rate for NDC
34 S IBAWP=$P(IBAWPV(+$O(IBAWPV(0))),"^",3)
35 I 'IBAWP S IBERR=11 G ENQ ; NDC has a zero charge
36 ;
37 ; - is patient data intact?
38 S DFN=+$$FILE^IBRXUTL(+IBRX,2)
39 S IBDPT(0)=$G(^DPT(DFN,0)),IBDPT(.11)=$G(^(.11)),IBDPT(.13)=$G(^(.13))
40 I IBDPT(0)="" S IBERR=4 G ENQ
41 ;
42 ; - is patient covered by TRICARE?
43 S IBCDFN=$$CUS^IBACUS(DFN,DT)
44 I 'IBCDFN S IBERR=2 G ENQ
45 ;
46 ; - get the BIN Number for the insurance company
47 S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
48 S IBBIN=$P($G(^DIC(36,+IBCDFND,3)),"^",3)
49 I $L(IBBIN)'=6 S IBERR=5 G ENQ
50 ;
51 ; - build line1:
52 ; o pharmacy division
53 ; o FI identifier (bin number)
54 ; o commercial software package version (32)
55 ; o billing transaction code (01)
56 ; o control #_pharmacy #_group (37 spaces)
57 ; o insured person's ssn
58 ; o person code (3 spaces)
59 ;
60 S IBFS=$C(28),IBGS=$C(29)
61 S IBLINE(1)=$$FILL(IBDRX("DIV"),2)_IBBIN_3201_$J("",37)
62 S IBLINE(1)=IBLINE(1)_$$LJUST($P(IBCDFND,"^",2),18)_$J("",3)
63 ;
64 ; - build line2:
65 ; o patient dob
66 ; o patient sex
67 ; o patient rel. to insured
68 ; o other coverage indicator (0)
69 ; o rx fill date
70 ;
71 S IBLINE(2)=$$DATE($P(IBDPT(0),"^",3))_$P(IBDPT(0),"^",2)
72 S IBLINE(2)=IBLINE(2)_$S($P(IBCDFND,"^",16)>3:4,1:+$P(IBCDFND,"^",16))
73 S IBLINE(2)=IBLINE(2)_"0"_$$DATE(IBDRX("FDT"))
74 ;
75 ; - build line3:
76 ; o patient first name
77 ; o patient last name
78 ; o insured's first name
79 ; o insured's last name
80 ; o address line 1, city, state, zip, phone
81 ;
82 S IBLINE(3)=IBFS_"C700"_IBFS_"C90"
83 S IBLINE(3)=IBLINE(3)_IBFS_"CA"_$$LJUST($P($P(IBDPT(0),"^"),",",2),12)
84 S IBLINE(3)=IBLINE(3)_IBFS_"CB"_$$LJUST($P($P(IBDPT(0),"^"),","),15)
85 S IBLINE(3)=IBLINE(3)_IBFS_"CC"_$$LJUST($P($P(IBCDFND,"^",17),",",2),12)
86 S IBLINE(3)=IBLINE(3)_IBFS_"CD"_$$LJUST($P($P(IBCDFND,"^",17),","),15)
87 S IBLINE(3)=IBLINE(3)_IBFS_"CM"_$$LJUST($P(IBDPT(.11),"^"),30)
88 S IBLINE(3)=IBLINE(3)_IBFS_"CN"_$$LJUST($P(IBDPT(.11),"^",4),20)
89 S IBLINE(3)=IBLINE(3)_IBFS_"CO"_$$LJUST($P($G(^DIC(5,+$P(IBDPT(.11),"^",5),0)),"^",2),2)
90 S IBLINE(3)=IBLINE(3)_IBFS_"CP"_$$LJUST($P(IBDPT(.11),"^",6),9)
91 S IBLINE(3)=IBLINE(3)_IBFS_"CQ"_$$FILL($TR($P(IBDPT(.13),"^"),"-",""),10)
92 ;
93 ; - build line4:
94 ; o prescription number
95 ; o new/refill code
96 ; o quantity
97 ; o days supply
98 ; o compound code (0) or if site param IBDRX("COMP")
99 ; o drug NDC #
100 ; o dispense as written? (0) or if resubmit look at IBKEYD
101 ; o ingredient cost
102 ; o Prescriber ID
103 ; o date prescription written
104 ; o # refills authorized
105 ; o rx origin code (1)
106 ; o rx denial clarification (00)
107 ; o usual and customary charge (currently ingr cost * 5)
108 ;
109 ; - but first, strip trailing alpha characters from the rx number
110 S:$E(IBDRX("RX#"),$L(IBDRX("RX#")))]9 IBDRX("RX#")=$E(IBDRX("RX#"),1,$L(IBDRX("RX#"))-1)
111 S IBLINE(4)=IBGS_$$FILL(IBDRX("RX#"),7)
112 S IBLINE(4)=IBLINE(4)_$$FILL(IBREF,2)
113 S IBLINE(4)=IBLINE(4)_$$FILL($P(IBDRX("QTY"),"."),5)
114 S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("SUP"),3)
115 S IBLINE(4)=IBLINE(4)_$S(+$P($G(^IBE(350.9,1,9)),"^",15):IBDRX("COMP"),1:0)
116 S IBLINE(4)=IBLINE(4)_$$FILL($TR(IBDRX("NDC"),"-",""),11)
117 S IBLINE(4)=IBLINE(4)_$S($P($G(^IBA(351.53,+$P(IBKEYD,"^",5),0)),"^"):$P(^(0),"^"),1:0)
118 ;
119 S IBUAC=$$FILL(+($E($TR($J(IBAWP,0,2),".",""),1,5))*IBDRX("QTY"),6)
120 S IBLINE(4)=IBLINE(4)_IBUAC_$$LJUST($S(+$P($G(^IBE(350.9,1,9)),"^",14)&($L(IBDRX("DEA"))):IBDRX("DEA"),1:IBPRESCR),10)
121 S IBLINE(4)=IBLINE(4)_$$DATE(IBDRX("ISS"))
122 S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("#REF"),2)
123 S IBLINE(4)=IBLINE(4)_"100"_$$FILL(IBUAC*5,6)
124 ;
125 ; - build line5: (not currently used, though must be submitted)
126 S IBLINE(5)=IBFS_"DA000000"_IBFS_"DC000200"_IBFS_"DG000000000000"_IBFS_"DI00"_IBFS_"DL"_$J("",10)
127 S IBLINE(5)=IBLINE(5)_IBFS_"DM00000"_IBFS_"DN01"_IBFS_"DO"_$J("",6)_IBFS_"DU000000"_IBFS_"DX000000"
128 S IBLINE(5)=IBLINE(5)_IBFS_"E4 "_IBFS_"E5 "_IBFS_"E6 "_IBFS_"E700000000"
129 ;
130OUT ; - send transaction to the commercial pos package
131 W $C(2)
132 F I=1:1:5 W IBLINE(I)
133 W $C(3)
134 W !
135 ;
136 ; - receive response
137 R IBRESP(1)#220:120 I '$T S IBERR=6 G ENQ
138 R IBRESP(2)#220:60,IBRESP(3):60 I '$L(IBRESP(3)) S IBERR=7 G ENQ
139 ;
140 S IBRESP(1)=$E(IBRESP(1),2,999)
141 ;
142 S XMCHAN=""
143 I $E(IBRESP(1),1,3)=" " D ERROR^IBECUS22 G ENQ
144 I $E(IBRESP(1),17)="D" D DUP^IBECUS22 G ENQ
145 ;
146 ; - file the billing transaction in file #351.51
147 D ^IBECUS21
148 ;
149 ; - quit if a reject
150 I $E(IBRESP(1),17)="R" G ENQ
151 ;
152 ; - if there was an error, file it and quit
153 I $E(IBRESP(1),1,3) D ERROR^IBECUS22 G ENQ
154 ;
155 ; - Queue tasks to print the label and create charges
156 F IBI="RXLAB;Rx Label print","RXBIL;Rx Billing" D TASK(IBI)
157 ;
158 ; - delete rx from billing queue
159 K ^IBA(351.5,"APOST",IBKEY)
160 ;
161ENQ I $G(IBERR) D ERROR^IBECUS22
162 Q
163 ;
164 ;
165TASK(IBDESC) ; Queue off label print, charge creation and cancellation jobs
166 ; Input: IBDESC -- 1 ; 2 , where
167 ; 1 = routine label to execute
168 ; 2 = task description
169 K ZTSAVE,ZTCPU,ZTSK
170 S ZTRTN=$P(IBDESC,";")_"^IBACUS",ZTDTH=$H,ZTIO=""
171 S ZTDESC="IB - "_$P(IBDESC,";",2)
172 F I="IBKEYD","IBCHTRN" S ZTSAVE(I)=""
173 D ^%ZTLOAD
174 Q
175 ;
176 ;
177DATE(X) ; Set date in the format yyyymmdd, or 8 spaces.
178 N Y
179 S Y=($E($G(X))+17)_$E($G(X),2,7)
180 Q $S($L(Y)=8:Y,1:$J("",8))
181 ;
182FILL(X,LEN) ; Zero-fill, right justified.
183 N Y
184 S:'$G(LEN) LEN=1
185 S Y=$E($G(X),1,LEN)
186 F Q:$L(Y)>(LEN-1) S Y="0"_Y
187 Q Y
188 ;
189LJUST(X,LEN) ; Space-fill, left justified.
190 N Y
191 S:'$G(LEN) LEN=1
192 S Y=$E($G(X),1,LEN)
193 F Q:$L(Y)>(LEN-1) S Y=Y_" "
194 Q Y
195 ;
196STRIPL(X) ; Strip leading spaces.
197 N Y S Y=$G(X)
198 F Q:$E(Y)'=" " S Y=$E(Y,2,999)
199 Q Y
200 ;
201NDC(X) ; Massage the NDC as it is stored in Pharmacy
202 ; Input: X -- The NDC as it is stored in Pharmacy
203 ; Output: X -- The NDC in the format 5N 1"-" 4N 1"-" 2N
204 ;
205 I $G(X)="" S X="" G NDCQ
206 ;
207 N LEN,PCE,Y,Z
208 ;
209 S Z(1)=5,Z(2)=4,Z(3)=2
210 S PCE=0 F S PCE=$O(Z(PCE)) Q:'PCE S LEN=Z(PCE) D
211 .S Y=$P(X,"-",PCE)
212 .I $L(Y)>LEN S Y=$E(Y,2,LEN+1)
213 .I $L(+Y)<LEN S Y=$$FILL(Y,LEN)
214 .S $P(X,"-",PCE)=Y
215 ;
216NDCQ Q X
Note: See TracBrowser for help on using the repository browser.