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