source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 9.0 KB
Line 
1IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ; 12/29/05 9:58am
2 ;;2.0;INTEGRATED BILLING;**51,137,155,323,348**;21-MAR-94;Build 5
3 ;
4BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500
5 ; for bill ien IBIFN
6 ; Data is derived from a combo of data throughout
7 ; the system and is limited to 80 characters. The hierarchy for
8 ; including data is as follows (until 80 characters have been used):
9 ; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
10 ; specialty codes = 025,065,073,067,048
11 ; LAST X-RAY DATE (chiropractic) specialty code = 35
12 ; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
13 ; a specimen from a homebound patient)
14 ; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
15 ; Hearing aid testing (if applicable)
16 ; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
17 ; SPECIAL PROGRAM indicator if Medicare demonstration project for
18 ; lung volume reduction surgery study is set
19 ; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
20 ; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
21 ; DETAIL
22 ;
23 N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM
24 S IB19="",IBGO=1
25 S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
26 I $D(IBXSAVE(IBSUB)) N IBXSAVE
27 S IBPRT=(IBSUB["24")
28 ;
29 S IBSPEC=$$BILLSPEC(IBIFN)
30 G:'IBPRT NPRT
31 I "^25^65^73^67^48^"[(U_IBSPEC_U) D
32 . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
33 . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
34 .. ; Only print if specialty is OT or PT or proc for routine foot care
35 .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA
36 ;
37 G:'IBGO BOX19Q
38 K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN)
39 I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q
40 ;
41 K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
42 I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q
43 ;
44 I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1))
45 ;
46 S (IBHAID,IBHOSP,IBXRAY)=0
47 ;
48 S Z=0 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D G:'IBGO BOX19Q
49 . I $D(IBXSAVE(IBSUB,Z,"RX")),$P(IBXSAVE(IBSUB,Z,"RX"),U,3)="" S IBGO=$$LENOK("NOC Drug:"_$P(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$P(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19)
50 . ;
51 . Q:'IBGO
52 . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D Q
53 .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q
54 . ;
55 . Q:'IBGO
56 . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) D Q
57 .. S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19)
58 . ;
59 . Q:'IBGO
60 . I 'IBXRAY,IBSPEC=35,$G(IBXSAVE(IBSUB,Z,"AUX"))'="" D Q
61 .. ; Check for chiropratic services in claim type or specialty
62 .. S IBXRAY=1
63 .. S IBGO=$$LENOK($S($P(IBXSAVE(IBSUB,Z,"AUX"),U,2):"Last Xray:"_$$DATE^IBCF2($P(IBXSAVE(IBSUB,Z,"AUX"),U,2),0,1)_" ",1:"")_$S($P(IBXSAVE(IBSUB,Z,"AUX"),U,4)'="":"Level of Sublux:"_$P(IBXSAVE(IBSUB,Z,"AUX"),U,4),1:""),.IB19)
64 ;
65 G:'IBGO BOX19Q
66 K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
67 I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q
68 ;
69 G:'IBGO BOX19Q
70NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
71 S IBREM=0
72 I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1
73 K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN)
74 I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q
75 ;
76BOX19Q Q IB19
77 ;
78LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref)
79 ; Check length of box 19 data - truncate at 96 (max length)
80 ; Returns 0 if max length reached or exceeded, otherwise, 1
81 N OK
82 S OK=1
83 S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA)
84 I $L(IB19)'<96 S OK=0,IB19=$E(IB19,1,96) G LENOKQ
85LENOKQ Q OK
86 ;
87ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN
88 N DIR,DIC,X,Y,DIE,DR,Z
89 S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
90 D ^DIR
91 I Y=1 S Z=$$BOX19(IBIFN) W !!,?4,"19",?20,$E(Z,1,32) W:$L(Z)>32 !,?4,$E(Z,33,80),!
92 Q
93 ;
94ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab
95 N IBP,IBPUR
96 S IBP=0
97 S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
98 I IBPUR,"13"[IBPUR S IBP=1
99 Q IBP
100 ;
101TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld
102 ; INPUT:
103 ; FLD = the letter of the field in box 24 (A-J)
104 ; IBXSAVE = passed by reference = extracted data for the box 24 lines
105 ; IBSUB = the subscript of the IBXSAVE array to use.
106 ; If null, use "BOX24"
107 ; OUTPUT:
108 ; IBXDATA = passed by reference, set to the correct part of the
109 ; text that will print in the field's positions
110 ;
111 ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
112 ;
113 N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
114 K IBXDATA
115 S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24"
116 ;
117 I FLD="I"!(FLD="J") D ; extract the Rendering provider data
118 . I '$G(IBXIEN) Q ; assume that the claim# exists
119 . S IBREN=$$CFIDS^IBCEF77(IBXIEN)
120 . S IBRENQ=$P(IBREN,U,1) ; qual
121 . S IBRENSID=$P(IBREN,U,2) ; id
122 . S IBRENNPI=$P(IBREN,U,3) ; npi
123 . Q
124 ;
125 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D
126 . S IBDAT=$G(IBXSAVE(IBSUB,Z))
127 . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX"))
128 . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT"))
129 . S IBZ=$P(IBAUX,U,9)
130 . I IBZ="" S IBZ=" "
131 . S IBTEXT=IBZ_IBTEXT
132 . ;
133 . I $S($G(IBAC)=4:$S($D(IBXSAVE(IBSUB,Z,"ARX")):1,1:$D(IBXSAVE(IBSUB,Z,"A"))),$D(IBXSAVE(IBSUB,Z,"RX")):0,1:$G(IBNOSHOW)) S IBTEXT=""
134 . ;
135 . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D ; From date of service
136 .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
137 .. Q
138 . ;
139 . I FLD="AT" S IBVAL=$S($P(IBDAT,U,2):$P(IBDAT,U,2),1:$P(IBDAT,U)),IBS=10,IBE=18 D ; To date of service
140 .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
141 .. Q
142 . ;
143 . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21 ; place of service
144 . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24 ; emergency indicator
145 . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D ; procedures and modifiers
146 .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10)) ; modifier list
147 .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" " ; procedure code
148 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3) ; mod#1
149 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3) ; mod#2
150 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3) ; mod#3
151 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3) ; mod#4
152 .. Q
153 . ;
154 . I FLD="E" S IBVAL=$TR($P(IBDAT,U,7),","),IBS=45,IBE=48 ; diagnosis pointer
155 . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D
156 .. ; total charges
157 .. S IBVAL=$$DOL^IBCEF77(IBVAL,9)
158 .. Q
159 . ;
160 . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D
161 .. ; days or units or anesthesia minutes
162 .. S IBVAL=$J(+IBVAL,4)
163 .. Q
164 . ;
165 . ; columns H,I,J don't have any free text supplemental information
166 . ;
167 . I FLD="H" D ; epsdt family plan
168 .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT="" ; line 1 blank
169 .. I IBVAL S IBVAL="Y"
170 .. Q
171 . I FLD="I" D ; ID qualifier for rendering provider
172 .. S IBVAL="",IBS=1,IBE=2 ; line 2 blank
173 .. S IBTEXT=$G(IBRENQ) ; qualifier on line 1
174 .. Q
175 . I FLD="J" D ; rendering provider ID and NPI
176 .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11 ; secondary ID line 1
177 .. S IBVAL=$G(IBRENNPI) ; NPI# line 2
178 .. Q
179 . ;
180 . S IBLINE=IBLINE+1 ; top line
181 . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE) ; text in shaded area (top)
182 . S IBLINE=IBLINE+1 ; bottom line
183 . S IBXDATA(IBLINE)=IBVAL ; field value in unshaded area (bottom)
184 . Q
185 ;
186 Q
187 ;
188BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN
189 ; If IBPRV is supplied, returns the data for that provider, otherwise,
190 ; returns the specialty of the 'main/required' provider on the bill.
191 ; Default = 99 if no valid code found
192 ; IBPRV = vp of provider (file 200 or 355.93)
193 N Z,IBSPEC,IBINS,IBDT
194 S IBSPEC="",IBPRV=$G(IBPRV)
195 S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
196 ;
197 I $G(IBPRV) D G SPECQ
198 . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
199 ;
200 ;Get rendering for professional, attending for institutional,
201 S IBINS=($$FT^IBCEF(IBIFN)=3)
202 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
203 S Z=$S('IBINS:3,1:4)
204 I $G(IBPRV(Z,1))'="" D
205 . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'=""
206 . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
207 . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8)
208 ;
209SPECQ I IBSPEC="" S IBSPEC="99"
210 Q IBSPEC
211 ;
212CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
213 Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
214 ;
215FAC(IBIFN) ; Is facility always to print in box 32 for bill ien IBIFN?
216 ; Returns 1 if yes, 0 if no
217 Q $S($P($G(^DGCR(399,IBIFN,"UF2")),U,2):1,1:$P($G(^IBE(350.9,1,2)),U,12))
218 ;
219MCR24K(IBIFN) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate
220 Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3),1:"")
Note: See TracBrowser for help on using the repository browser.