IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am
;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371,400,432,488,519,592,608**;21-MAR-94;Build 90
;;Per VA Directive 6402, this routine should not be modified.
;
BOX19(IBIFN) ; New Box 19 added for patch 488. This is for workman's comp?
; This returns the Paperwork Attachment
; Information in the following format:
; PWKNNFX12348907CHEY<3 Spaces>Next set if more than one on claim
; PWK is the qualifier for data, followed by the appropriate Report Type
;Code, the appropriate Transmission Type Code, then the Attachment Control
;Number. Do not enter spaces between qualifiers and data.
;
; This information can be at either the Line Level or the Claim Level.
; Check all Lines first and print as many as possible - 71 characters
; maximum. Then check the Claim Level
N IBRTP,LN,U8,IBBX19,IB19,DATA,I,DEL
;JWS;IB*2.0*592;add Dental Claim Note field to EDI 837D trans, rec UB1, field 19
;IA# 2056
I $$FT^IBCEF(IBIFN)=7 Q $$GET1^DIQ(399,IBIFN_",",97)
S IB19="",DEL=" ",LN=0
; Get rate type
S IBRTP=$P($G(^DGCR(399,IBIFN,0)),U,7)
; Get data entered for box 19
S IBBX19=$P($G(^DGCR(399,IBIFN,"UF31")),U,3)
; check the line Level first
I IBRTP=11 D
.F S LN=$O(^DGCR(399,IBIFN,"CP",LN)) Q:LN="" Q:LN'?.N D
..S DATA=$G(^DGCR(399,IBIFN,"CP",LN,1))
..I $P(DATA,U,2)'="" S IB19=IB19_$S(IB19="":"",1:DEL)_$$FORMAT(DATA)
.; check the Claim Level next
.S DATA=""
.S DATA=$G(^DGCR(399,IBIFN,"U8"))
.I DATA'="" S IB19=IB19_$S(IB19="":"",1:DEL)_$$FORMAT(DATA)
; If any room left add user entered box 19 info
I IBBX19'="",IB19'="",$L(IB19)<84 D
.F I=1:1:$L(IBBX19,DEL) S DATA=$P(IBBX19,DEL,I) I DATA'="" D
..I $L(IB19_DEL_DATA)<84 S IB19=IB19_$S(IB19="":"",1:DEL)_DATA
I IB19="",IBBX19'="" S IB19=IBBX19
;
Q IB19
;
FORMAT(DATA) ; format data for ouput
N ART,OUT
S ART=$P(DATA,U,2)
S ART=$P(^IBE(353.3,ART,0),U,1)
S OUT="PWK"_ART_$P(DATA,U,3)_$P(DATA,U,1)
Q OUT
;
; BELOW NO LONGER USED -> BAA *488*
OBOX19(IBIFN) ; THIS IS NOLONGER USED. IT WAS REPLACE WITH ABOVE.
; Returns the text that should print in box 19 of the CMS-1500
; for bill ien IBIFN
; Data is derived from a combo of data throughout
; the system and is limited to 80 characters. The hierarchy for
; including data is as follows (until 80 characters have been used):
; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
; specialty codes = 025,065,073,067,048
; LAST X-RAY DATE (chiropractic) specialty code = 35
; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
; a specimen from a homebound patient)
; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
; Hearing aid testing (if applicable)
; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
; SPECIAL PROGRAM indicator if Medicare demonstration project for
; lung volume reduction surgery study is set
; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
; DETAIL
;
N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM,IBSPI
S IB19="",IBGO=1
S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
I $D(IBXSAVE(IBSUB)) N IBXSAVE
S IBPRT=(IBSUB["24")
;
S IBSPEC=$$BILLSPEC(IBIFN)
G:'IBPRT NPRT
; Check for chiropractic services
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)
G:'IBGO BOX19Q
;
I "^25^65^73^67^48^"[(U_IBSPEC_U) D
. K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
. I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
.. ; Only print if specialty is OT or PT or proc for routine foot care
.. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA
;
G:'IBGO BOX19Q
K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN)
I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q
;
K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q
;
I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1))
;
S (IBHAID,IBHOSP,IBXRAY)=0
;
S Z=0 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D G:'IBGO BOX19Q
. 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)
. ;
. Q:'IBGO
. I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D Q
.. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q
. ;
. Q:'IBGO
. I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q
G:'IBGO BOX19Q
K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q
;
; SPECIAL PROGRAM INDICATOR field code.
S IBSPI=$$GET1^DIQ(399,IBIFN_",",238,"E")
I IBSPI'="" S IBGO=$$LENOK(IBSPI,.IB19)
;
G:'IBGO BOX19Q
NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
S IBREM=0
I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1
K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN)
I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q
;
BOX19Q Q IB19
; ALL OF THE ABOVE TO OBOX19 IS NO LONGER USED *488*
;
LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref)
; Check length of box 19 data - truncate at 71 (max length)
; Returns 0 if max length reached or exceeded, otherwise, 1
; Changed 96 to 71 for new 1500 form
N OK
S OK=1
S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA)
I $L(IB19)'<83 S OK=0,IB19=$E(IB19,1,71) G LENOKQ
LENOKQ Q OK
;
ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN
; changed to 71 length.
N DIR,DIC,X,Y,DIE,DR,Z
S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
D ^DIR
K DIR("B")
I Y=1 D
.S Z=$$BOX19(IBIFN) W !!,?4,"19",?45,$E(Z,1,23) W:$L(Z)>23 !,?4,$E(Z,24,71),!
.S DIR(0)="E",DIR("A")="Enter <RET> to Continue " W ! D ^DIR K DIR
Q
;
ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab
N IBP,IBPUR
S IBP=0
S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
I IBPUR,"13"[IBPUR S IBP=1
Q IBP
;
TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld
; INPUT:
; FLD = the letter of the field in box 24 (A-J)
; IBXSAVE = passed by reference = extracted data for the box 24 lines
; IBSUB = the subscript of the IBXSAVE array to use.
; If null, use "BOX24"
; OUTPUT:
; IBXDATA = passed by reference, set to the correct part of the
; text that will print in the field's positions
;
; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
;
N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
K IBXDATA
S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24"
;
I FLD="I"!(FLD="J") D ; extract the Rendering provider data
. I '$G(IBXIEN) Q ; assume that the claim# exists
. S IBREN=$$CFIDS^IBCEF77(IBXIEN)
. S IBRENQ=$P(IBREN,U,1) ; qual
. S IBRENSID=$P(IBREN,U,2) ; id
. S IBRENNPI=$P(IBREN,U,3) ; npi
. Q
;
F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D
. S IBDAT=$G(IBXSAVE(IBSUB,Z))
. S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX"))
. S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT"))
. S IBZ=$P(IBAUX,U,9)
. I IBZ="" S IBZ=" "
. S IBTEXT=IBZ_IBTEXT
. ;
. 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=""
. ;
. I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D ; From date of service
.. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
.. Q
. ;
. 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
.. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
.. Q
. ;
. I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21 ; place of service
. I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24 ; emergency indicator
. I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D ; procedures and modifiers
.. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10)) ; modifier list
.. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" " ; procedure code
.. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3) ; mod#1
.. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3) ; mod#2
.. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3) ; mod#3
.. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3) ; mod#4
.. Q
. ;
. I FLD="E" D
.. N NUM,IN,OUT,LET
.. S IN="1,2,3,4,5,6,7,8,9"
.. S OUT="A,B,C,D,E,F,G,H,I"
.. S IBVAL=$P(IBDAT,U,7)
.. F I=1:1:4 S NUM=$P(IBVAL,",",I) D
... I NUM<10 S $P(LET,",",I)=$TR(NUM,IN,OUT)
... I NUM=10 S $P(LET,",",I)="J"
... I NUM=11 S $P(LET,",",I)="K"
... I NUM=12 S $P(LET,",",I)="L"
.. S IBVAL=$TR(LET,","),IBS=45,IBE=48 ; diagnosis pointer
. I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D
.. ; total charges **519 returned field length back to 8, 9 is too long for BOX24F
.. S IBVAL=$$DOL^IBCEF77(IBVAL,8)
.. I $L(IBVAL)>8 S IBVAL=$E(IBVAL,$L(IBVAL)-7,$L(IBVAL))
.. Q
. ;
. I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D
.. ; days or units or anesthesia minutes
.. S IBVAL=$J(+IBVAL,4)
.. Q
. ;
. ; columns H,I,J don't have any free text supplemental information
. ;
. I FLD="H" D ; epsdt family plan
.. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT="" ; line 1 blank
.. I IBVAL S IBVAL="Y"
.. Q
. I FLD="I" D ; ID qualifier for rendering provider
.. S IBVAL="",IBS=1,IBE=2 ; line 2 blank
.. S IBTEXT=$G(IBRENQ) ; qualifier on line 1
.. Q
. I FLD="J" D ; rendering provider ID and NPI
.. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11 ; secondary ID line 1
.. S IBVAL=$G(IBRENNPI) ; NPI# line 2
.. Q
. ;
. S IBLINE=IBLINE+1 ; top line
. S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE) ; text in shaded area (top)
. S IBLINE=IBLINE+1 ; bottom line
. S IBXDATA(IBLINE)=IBVAL ; field value in unshaded area (bottom)
. Q
;
Q
;
LINSPEC(IBIFN) ; Checks the specialities of line and claim level providers
; called from IBCBB2 to check for Chiro codes & IBCBB9 to check for 99's on Medicare
; Default = 99 if no valid SPEC code found for line and claim level provider
; Get rendering for professional, attending for institutional
; If multiple lines w/ rendering or attending, returns a string of spec codes
N Z,IBSPEC,IBINS,IBDT,IBCP,IBSPC
S IBSPC=""
S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
S IBINS=($$FT^IBCEF(IBIFN)=3)
D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
S Z=$S('IBINS:3,1:4)
; check claim level
I $G(IBPRV(Z,1))'="" D
. I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) I IBSPEC'="" S IBSPC=IBSPC_U_IBSPEC Q
. S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
. I Z0 S IBSPEC=$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8) S:IBSPEC="" IBSPEC=99 S IBSPC=IBSPC_U_IBSPEC
; Check line level
S IBCP=0 F S IBCP=$O(^DGCR(399,IBIFN,"CP",IBCP)) Q:'IBCP D
.S Z0=+$O(^DGCR(399,IBIFN,"CP",IBCP,"LNPRV","B",Z,0))
.I Z0 S IBSPEC=$P($G(^DGCR(399,IBIFN,"CP",IBCP,"LNPRV",Z0,0)),U,8) S:IBSPEC="" IBSPEC="99" S IBSPC=IBSPC_U_IBSPEC
;/IB*2*608 - vd (US3214) - modified the following line to allow for No Rendering Provider.
;S:IBSPC="" IBSPC=99
I $$FT^IBCEF(IBIFN)'=2 S:IBSPC="" IBSPC=99
Q IBSPC
;
BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN
; If IBPRV is supplied, returns the data for that provider, otherwise,
; returns the specialty of the 'main/required' provider on the bill.
; Default = 99 if no valid code found
; IBPRV = vp of provider (file 200 or 355.93)
N Z,IBSPEC,IBINS,IBDT
S IBSPEC="",IBPRV=$G(IBPRV)
S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
;
I $G(IBPRV) D G SPECQ
. S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
;
;Get rendering for professional, attending for institutional,
S IBINS=($$FT^IBCEF(IBIFN)=3)
D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
S Z=$S('IBINS:3,1:4)
I $G(IBPRV(Z,1))'="" D
. I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'=""
. S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
. I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8)
;
SPECQ I IBSPEC="" S IBSPEC="99"
Q IBSPEC
;
CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
;
FAC(IBIFN) ; Obsolete function. Used by old output formatter field and data element N-RENDERING INSTITUTION
Q ""
;
MCR24K(IBIFN,IBPRV) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate
;*432/TAZ - Added IBPRV to allow circumvent the call to F^IBCEF("N-SPECIALTY CODE","IBZ",,IBIFN) in MCRSPEC^IBCEU4
;JWS;IB*2.0*592:Added dental form to check for compatibility
;Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1,$G(IBPRV))_$P($$SITE^VASITE,U,3),1:"")
Q $S(($$FT^IBCEF(IBIFN)=2)!($$FT^IBCEF(IBIFN)=7)&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1,$G(IBPRV))_$P($$SITE^VASITE,U,3),1:"")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEU3 13665 printed Oct 16, 2024@18:13:15 Page 2
IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am
+1 ;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371,400,432,488,519,592,608**;21-MAR-94;Build 90
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BOX19(IBIFN) ; New Box 19 added for patch 488. This is for workman's comp?
+1 ; This returns the Paperwork Attachment
+2 ; Information in the following format:
+3 ; PWKNNFX12348907CHEY<3 Spaces>Next set if more than one on claim
+4 ; PWK is the qualifier for data, followed by the appropriate Report Type
+5 ;Code, the appropriate Transmission Type Code, then the Attachment Control
+6 ;Number. Do not enter spaces between qualifiers and data.
+7 ;
+8 ; This information can be at either the Line Level or the Claim Level.
+9 ; Check all Lines first and print as many as possible - 71 characters
+10 ; maximum. Then check the Claim Level
+11 NEW IBRTP,LN,U8,IBBX19,IB19,DATA,I,DEL
+12 ;JWS;IB*2.0*592;add Dental Claim Note field to EDI 837D trans, rec UB1, field 19
+13 ;IA# 2056
+14 IF $$FT^IBCEF(IBIFN)=7
QUIT $$GET1^DIQ(399,IBIFN_",",97)
+15 SET IB19=""
SET DEL=" "
SET LN=0
+16 ; Get rate type
+17 SET IBRTP=$PIECE($GET(^DGCR(399,IBIFN,0)),U,7)
+18 ; Get data entered for box 19
+19 SET IBBX19=$PIECE($GET(^DGCR(399,IBIFN,"UF31")),U,3)
+20 ; check the line Level first
+21 IF IBRTP=11
Begin DoDot:1
+22 FOR
SET LN=$ORDER(^DGCR(399,IBIFN,"CP",LN))
if LN=""
QUIT
if LN'?.N
QUIT
Begin DoDot:2
+23 SET DATA=$GET(^DGCR(399,IBIFN,"CP",LN,1))
+24 IF $PIECE(DATA,U,2)'=""
SET IB19=IB19_$SELECT(IB19="":"",1:DEL)_$$FORMAT(DATA)
End DoDot:2
+25 ; check the Claim Level next
+26 SET DATA=""
+27 SET DATA=$GET(^DGCR(399,IBIFN,"U8"))
+28 IF DATA'=""
SET IB19=IB19_$SELECT(IB19="":"",1:DEL)_$$FORMAT(DATA)
End DoDot:1
+29 ; If any room left add user entered box 19 info
+30 IF IBBX19'=""
IF IB19'=""
IF $LENGTH(IB19)<84
Begin DoDot:1
+31 FOR I=1:1:$LENGTH(IBBX19,DEL)
SET DATA=$PIECE(IBBX19,DEL,I)
IF DATA'=""
Begin DoDot:2
+32 IF $LENGTH(IB19_DEL_DATA)<84
SET IB19=IB19_$SELECT(IB19="":"",1:DEL)_DATA
End DoDot:2
End DoDot:1
+33 IF IB19=""
IF IBBX19'=""
SET IB19=IBBX19
+34 ;
+35 QUIT IB19
+36 ;
FORMAT(DATA) ; format data for ouput
+1 NEW ART,OUT
+2 SET ART=$PIECE(DATA,U,2)
+3 SET ART=$PIECE(^IBE(353.3,ART,0),U,1)
+4 SET OUT="PWK"_ART_$PIECE(DATA,U,3)_$PIECE(DATA,U,1)
+5 QUIT OUT
+6 ;
+7 ; BELOW NO LONGER USED -> BAA *488*
OBOX19(IBIFN) ; THIS IS NOLONGER USED. IT WAS REPLACE WITH ABOVE.
+1 ; Returns the text that should print in box 19 of the CMS-1500
+2 ; for bill ien IBIFN
+3 ; Data is derived from a combo of data throughout
+4 ; the system and is limited to 80 characters. The hierarchy for
+5 ; including data is as follows (until 80 characters have been used):
+6 ; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
+7 ; specialty codes = 025,065,073,067,048
+8 ; LAST X-RAY DATE (chiropractic) specialty code = 35
+9 ; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
+10 ; a specimen from a homebound patient)
+11 ; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
+12 ; Hearing aid testing (if applicable)
+13 ; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
+14 ; SPECIAL PROGRAM indicator if Medicare demonstration project for
+15 ; lung volume reduction surgery study is set
+16 ; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
+17 ; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
+18 ; DETAIL
+19 ;
+20 NEW IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM,IBSPI
+21 SET IB19=""
SET IBGO=1
+22 SET IBSUB=$SELECT('$GET(^TMP("IBTX",$JOB,IBIFN)):"BOX24",1:"OUTPT")
+23 IF $DATA(IBXSAVE(IBSUB))
NEW IBXSAVE
+24 SET IBPRT=(IBSUB["24")
+25 ;
+26 SET IBSPEC=$$BILLSPEC(IBIFN)
+27 if 'IBPRT
GOTO NPRT
+28 ; Check for chiropractic services
+29 IF $PIECE($GET(^DGCR(399,IBIFN,"U3")),U,5)'=""
if $PIECE($GET(^DGCR(399,IBIFN,"U3")),U,4)'=""
SET IBGO=$$LENOK("Last X-ray: "_$TRANSLATE($$DATE^IBCF2($PIECE(^DGCR(399,IBIFN,"U3"),U,4))," ","/"),.IB19)
+30 if 'IBGO
GOTO BOX19Q
+31 ;
+32 IF "^25^65^73^67^48^"[(U_IBSPEC_U)
Begin DoDot:1
+33 KILL IBXDATA
DO F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
+34 IF IBXDATA'=""
SET IBID=""
SET IBLSDT=$$DATE^IBCF2(IBXDATA,0,1)
Begin DoDot:2
+35 ; Only print if specialty is OT or PT or proc for routine foot care
+36 DO F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN)
IF IBXDATA'=""
SET IBID=" By:"_IBXDATA
End DoDot:2
IF IBLSDT'=""
SET IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
End DoDot:1
+37 ;
+38 if 'IBGO
GOTO BOX19Q
+39 KILL IBXDATA
DO F^IBCEF("N-HOMEBOUND",,,IBIFN)
+40 IF IBXDATA
if '$$LENOK("Homebound",.IB19)
GOTO BOX19Q
+41 ;
+42 KILL IBXDATA
DO F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
+43 IF "Nn0"[IBXDATA&(IBXDATA'="")
if '$$LENOK("Patient refuses to assign benefits",.IB19)
GOTO BOX19Q
+44 ;
+45 IF '$DATA(IBXSAVE(IBSUB))
DO B24^IBCEF3(.IBXSAVE,IBIFN,$SELECT($GET(IBNOSHOW)=0:0,1:1))
+46 ;
+47 SET (IBHAID,IBHOSP,IBXRAY)=0
+48 ;
+49 SET Z=0
FOR
SET Z=$ORDER(IBXSAVE(IBSUB,Z))
if 'Z
QUIT
Begin DoDot:1
+50 IF $DATA(IBXSAVE(IBSUB,Z,"RX"))
IF $PIECE(IBXSAVE(IBSUB,Z,"RX"),U,3)=""
SET IBGO=$$LENOK("NOC Drug:"_$PIECE(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$PIECE(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19)
+51 ;
+52 if 'IBGO
QUIT
+53 IF 'IBHAID
IF $PIECE(IBXSAVE(IBSUB,Z),U,5)="V5010"
IF $$COBCT^IBCEF(IBIFN)>1
Begin DoDot:2
+54 SET IBHAID=1
SET IBGO=$$LENOK("Testing for hearing aid",.IB19)
QUIT
End DoDot:2
QUIT
+55 ;
+56 if 'IBGO
QUIT
+57 IF 'IBHOSP
IF $PIECE($GET(IBXSAVE(IBSUB,Z,"AUX")),U,3)
SET IBHOSP=1
SET IBGO=$$LENOK("Attending physician,not hospice employee",.IB19)
QUIT
End DoDot:1
if 'IBGO
GOTO BOX19Q
+58 if 'IBGO
GOTO BOX19Q
+59 KILL IBXDATA
DO F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
+60 IF IBXDATA=30
if '$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19)
GOTO BOX19Q
+61 ;
+62 ; SPECIAL PROGRAM INDICATOR field code.
+63 SET IBSPI=$$GET1^DIQ(399,IBIFN_",",238,"E")
+64 IF IBSPI'=""
SET IBGO=$$LENOK(IBSPI,.IB19)
+65 ;
+66 if 'IBGO
GOTO BOX19Q
NPRT KILL IBXDATA
DO F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
+1 SET IBREM=0
+2 IF IBXDATA'=""
if '$$LENOK("Remarks
GOTO BOX19Q
SET IBREM=1
+3 KILL IBXDATA
DO F^IBCEF("N-BILL REMARKS",,,IBIFN)
+4 IF IBXDATA'=""
if '$$LENOK($SELECT('IBREM
GOTO BOX19Q
+5 ;
BOX19Q QUIT IB19
+1 ; ALL OF THE ABOVE TO OBOX19 IS NO LONGER USED *488*
+2 ;
LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref)
+1 ; Check length of box 19 data - truncate at 71 (max length)
+2 ; Returns 0 if max length reached or exceeded, otherwise, 1
+3 ; Changed 96 to 71 for new 1500 form
+4 NEW OK
+5 SET OK=1
+6 SET IB19=IB19_$SELECT(IB19'="":" ",1:"")_$GET(IBDATA)
+7 IF $LENGTH(IB19)'<83
SET OK=0
SET IB19=$EXTRACT(IB19,1,71)
GOTO LENOKQ
LENOKQ QUIT OK
+1 ;
ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN
+1 ; changed to 71 length.
+2 NEW DIR,DIC,X,Y,DIE,DR,Z
+3 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
+4 DO ^DIR
+5 KILL DIR("B")
+6 IF Y=1
Begin DoDot:1
+7 SET Z=$$BOX19(IBIFN)
WRITE !!,?4,"19",?45,$EXTRACT(Z,1,23)
if $LENGTH(Z)>23
WRITE !,?4,$EXTRACT(Z,24,71),!
+8 SET DIR(0)="E"
SET DIR("A")="Enter <RET> to Continue "
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+9 QUIT
+10 ;
ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab
+1 NEW IBP,IBPUR
+2 SET IBP=0
+3 SET IBPUR=$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,11)
+4 IF IBPUR
IF "13"[IBPUR
SET IBP=1
+5 QUIT IBP
+6 ;
TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld
+1 ; INPUT:
+2 ; FLD = the letter of the field in box 24 (A-J)
+3 ; IBXSAVE = passed by reference = extracted data for the box 24 lines
+4 ; IBSUB = the subscript of the IBXSAVE array to use.
+5 ; If null, use "BOX24"
+6 ; OUTPUT:
+7 ; IBXDATA = passed by reference, set to the correct part of the
+8 ; text that will print in the field's positions
+9 ;
+10 ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
+11 ;
+12 NEW Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
+13 KILL IBXDATA
+14 SET (IBLINE,Z)=0
if $GET(IBSUB)=""
SET IBSUB="BOX24"
+15 ;
+16 ; extract the Rendering provider data
IF FLD="I"!(FLD="J")
Begin DoDot:1
+17 ; assume that the claim# exists
IF '$GET(IBXIEN)
QUIT
+18 SET IBREN=$$CFIDS^IBCEF77(IBXIEN)
+19 ; qual
SET IBRENQ=$PIECE(IBREN,U,1)
+20 ; id
SET IBRENSID=$PIECE(IBREN,U,2)
+21 ; npi
SET IBRENNPI=$PIECE(IBREN,U,3)
+22 QUIT
End DoDot:1
+23 ;
+24 FOR
SET Z=$ORDER(IBXSAVE(IBSUB,Z))
if 'Z
QUIT
Begin DoDot:1
+25 SET IBDAT=$GET(IBXSAVE(IBSUB,Z))
+26 SET IBAUX=$GET(IBXSAVE(IBSUB,Z,"AUX"))
+27 SET IBTEXT=$GET(IBXSAVE(IBSUB,Z,"TEXT"))
+28 SET IBZ=$PIECE(IBAUX,U,9)
+29 IF IBZ=""
SET IBZ=" "
+30 SET IBTEXT=IBZ_IBTEXT
+31 ;
+32 IF $SELECT($GET(IBAC)=4:$SELECT($DATA(IBXSAVE(IBSUB,Z,"ARX")):1,1:$DATA(IBXSAVE(IBSUB,Z,"A"))),$DATA(IBXSAVE(IBSUB,Z,"RX")):0,1:$GET(IBNOSHOW))
SET IBTEXT=""
+33 ;
+34 ; From date of service
IF FLD="AF"
SET IBVAL=$PIECE(IBDAT,U)
SET IBS=1
SET IBE=9
Begin DoDot:2
+35 SET IBVAL=$EXTRACT(IBVAL,1,2)_" "_$EXTRACT(IBVAL,3,4)_" "_$EXTRACT(IBVAL,7,8)
+36 QUIT
End DoDot:2
+37 ;
+38 ; To date of service
IF FLD="AT"
SET IBVAL=$SELECT($PIECE(IBDAT,U,2):$PIECE(IBDAT,U,2),1:$PIECE(IBDAT,U))
SET IBS=10
SET IBE=18
Begin DoDot:2
+39 SET IBVAL=$EXTRACT(IBVAL,1,2)_" "_$EXTRACT(IBVAL,3,4)_" "_$EXTRACT(IBVAL,7,8)
+40 QUIT
End DoDot:2
+41 ;
+42 ; place of service
IF FLD="B"
SET IBVAL=$PIECE(IBDAT,U,3)
SET IBS=19
SET IBE=21
+43 ; emergency indicator
IF FLD="C"
SET IBVAL=$SELECT($PIECE(IBDAT,U,13)=1:"Y",1:"")
SET IBS=22
SET IBE=24
+44 ; procedures and modifiers
IF FLD="D"
SET IBVAL=$PIECE(IBDAT,U,5)
SET IBS=25
SET IBE=44
Begin DoDot:2
+45 ; modifier list
NEW M
SET M=$$MODLST^IBEFUNC($PIECE(IBDAT,U,10))
+46 ; procedure code
SET IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" "
+47 ; mod#1
SET IBVAL=IBVAL_$$FO^IBCNEUT1($PIECE(M,",",1),3)
+48 ; mod#2
SET IBVAL=IBVAL_$$FO^IBCNEUT1($PIECE(M,",",2),3)
+49 ; mod#3
SET IBVAL=IBVAL_$$FO^IBCNEUT1($PIECE(M,",",3),3)
+50 ; mod#4
SET IBVAL=IBVAL_$$FO^IBCNEUT1($PIECE(M,",",4),3)
+51 QUIT
End DoDot:2
+52 ;
+53 IF FLD="E"
Begin DoDot:2
+54 NEW NUM,IN,OUT,LET
+55 SET IN="1,2,3,4,5,6,7,8,9"
+56 SET OUT="A,B,C,D,E,F,G,H,I"
+57 SET IBVAL=$PIECE(IBDAT,U,7)
+58 FOR I=1:1:4
SET NUM=$PIECE(IBVAL,",",I)
Begin DoDot:3
+59 IF NUM<10
SET $PIECE(LET,",",I)=$TRANSLATE(NUM,IN,OUT)
+60 IF NUM=10
SET $PIECE(LET,",",I)="J"
+61 IF NUM=11
SET $PIECE(LET,",",I)="K"
+62 IF NUM=12
SET $PIECE(LET,",",I)="L"
End DoDot:3
+63 ; diagnosis pointer
SET IBVAL=$TRANSLATE(LET,",")
SET IBS=45
SET IBE=48
End DoDot:2
+64 IF FLD="F"
SET IBVAL=$PIECE(IBDAT,U,8)*$PIECE(IBDAT,U,9)
SET IBS=49
SET IBE=57
Begin DoDot:2
+65 ; total charges **519 returned field length back to 8, 9 is too long for BOX24F
+66 SET IBVAL=$$DOL^IBCEF77(IBVAL,8)
+67 IF $LENGTH(IBVAL)>8
SET IBVAL=$EXTRACT(IBVAL,$LENGTH(IBVAL)-7,$LENGTH(IBVAL))
+68 QUIT
End DoDot:2
+69 ;
+70 IF FLD="G"
SET IBVAL=$SELECT($PIECE(IBDAT,U,12):$PIECE(IBDAT,U,12),1:$PIECE(IBDAT,U,9))
SET IBS=58
SET IBE=61
Begin DoDot:2
+71 ; days or units or anesthesia minutes
+72 SET IBVAL=$JUSTIFY(+IBVAL,4)
+73 QUIT
End DoDot:2
+74 ;
+75 ; columns H,I,J don't have any free text supplemental information
+76 ;
+77 ; epsdt family plan
IF FLD="H"
Begin DoDot:2
+78 ; line 1 blank
SET IBVAL=$PIECE(IBAUX,U,7)
SET IBS=0
SET IBE=0
SET IBTEXT=""
+79 IF IBVAL
SET IBVAL="Y"
+80 QUIT
End DoDot:2
+81 ; ID qualifier for rendering provider
IF FLD="I"
Begin DoDot:2
+82 ; line 2 blank
SET IBVAL=""
SET IBS=1
SET IBE=2
+83 ; qualifier on line 1
SET IBTEXT=$GET(IBRENQ)
+84 QUIT
End DoDot:2
+85 ; rendering provider ID and NPI
IF FLD="J"
Begin DoDot:2
+86 ; secondary ID line 1
SET IBTEXT=$GET(IBRENSID)
SET IBS=1
SET IBE=11
+87 ; NPI# line 2
SET IBVAL=$GET(IBRENNPI)
+88 QUIT
End DoDot:2
+89 ;
+90 ; top line
SET IBLINE=IBLINE+1
+91 ; text in shaded area (top)
SET IBXDATA(IBLINE)=$EXTRACT(IBTEXT,IBS,IBE)
+92 ; bottom line
SET IBLINE=IBLINE+1
+93 ; field value in unshaded area (bottom)
SET IBXDATA(IBLINE)=IBVAL
+94 QUIT
End DoDot:1
+95 ;
+96 QUIT
+97 ;
LINSPEC(IBIFN) ; Checks the specialities of line and claim level providers
+1 ; called from IBCBB2 to check for Chiro codes & IBCBB9 to check for 99's on Medicare
+2 ; Default = 99 if no valid SPEC code found for line and claim level provider
+3 ; Get rendering for professional, attending for institutional
+4 ; If multiple lines w/ rendering or attending, returns a string of spec codes
+5 NEW Z,IBSPEC,IBINS,IBDT,IBCP,IBSPC
+6 SET IBSPC=""
+7 ; use statement from date
SET IBDT=$PIECE($GET(^DGCR(399,+IBIFN,"U")),U,1)
+8 SET IBINS=($$FT^IBCEF(IBIFN)=3)
+9 DO GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
+10 SET Z=$SELECT('IBINS:3,1:4)
+11 ; check claim level
+12 IF $GET(IBPRV(Z,1))'=""
Begin DoDot:1
+13 IF $PIECE(IBPRV(Z,1),U,3)
SET IBSPEC=$$SPEC^IBCEU($PIECE($GET(IBPRV(Z,1)),U,3),IBDT)
IF IBSPEC'=""
SET IBSPC=IBSPC_U_IBSPEC
QUIT
+14 SET Z0=+$ORDER(^DGCR(399,IBIFN,"PRV","B",Z,0))
+15 IF Z0
SET IBSPEC=$PIECE($GET(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)
if IBSPEC=""
SET IBSPEC=99
SET IBSPC=IBSPC_U_IBSPEC
End DoDot:1
+16 ; Check line level
+17 SET IBCP=0
FOR
SET IBCP=$ORDER(^DGCR(399,IBIFN,"CP",IBCP))
if 'IBCP
QUIT
Begin DoDot:1
+18 SET Z0=+$ORDER(^DGCR(399,IBIFN,"CP",IBCP,"LNPRV","B",Z,0))
+19 IF Z0
SET IBSPEC=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBCP,"LNPRV",Z0,0)),U,8)
if IBSPEC=""
SET IBSPEC="99"
SET IBSPC=IBSPC_U_IBSPEC
End DoDot:1
+20 ;/IB*2*608 - vd (US3214) - modified the following line to allow for No Rendering Provider.
+21 ;S:IBSPC="" IBSPC=99
+22 IF $$FT^IBCEF(IBIFN)'=2
if IBSPC=""
SET IBSPC=99
+23 QUIT IBSPC
+24 ;
BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN
+1 ; If IBPRV is supplied, returns the data for that provider, otherwise,
+2 ; returns the specialty of the 'main/required' provider on the bill.
+3 ; Default = 99 if no valid code found
+4 ; IBPRV = vp of provider (file 200 or 355.93)
+5 NEW Z,IBSPEC,IBINS,IBDT
+6 SET IBSPEC=""
SET IBPRV=$GET(IBPRV)
+7 ; use statement from date
SET IBDT=$PIECE($GET(^DGCR(399,+IBIFN,"U")),U,1)
+8 ;
+9 IF $GET(IBPRV)
Begin DoDot:1
+10 SET IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
End DoDot:1
GOTO SPECQ
+11 ;
+12 ;Get rendering for professional, attending for institutional,
+13 SET IBINS=($$FT^IBCEF(IBIFN)=3)
+14 DO GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
+15 SET Z=$SELECT('IBINS:3,1:4)
+16 IF $GET(IBPRV(Z,1))'=""
Begin DoDot:1
+17 IF $PIECE(IBPRV(Z,1),U,3)
SET IBSPEC=$$SPEC^IBCEU($PIECE($GET(IBPRV(Z,1)),U,3),IBDT)
if IBSPEC'=""
QUIT
+18 SET Z0=+$ORDER(^DGCR(399,IBIFN,"PRV","B",Z,0))
+19 IF Z0
IF $PIECE($GET(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'=""
SET IBSPEC=$PIECE(^(0),U,8)
End DoDot:1
+20 ;
SPECQ IF IBSPEC=""
SET IBSPEC="99"
+1 QUIT IBSPEC
+2 ;
CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
+1 QUIT $EXTRACT($PIECE($GET(^DGCR(399.3,+$PIECE($GET(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
+2 ;
FAC(IBIFN) ; Obsolete function. Used by old output formatter field and data element N-RENDERING INSTITUTION
+1 QUIT ""
+2 ;
MCR24K(IBIFN,IBPRV) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate
+1 ;*432/TAZ - Added IBPRV to allow circumvent the call to F^IBCEF("N-SPECIALTY CODE","IBZ",,IBIFN) in MCRSPEC^IBCEU4
+2 ;JWS;IB*2.0*592:Added dental form to check for compatibility
+3 ;Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1,$G(IBPRV))_$P($$SITE^VASITE,U,3),1:"")
+4 QUIT $SELECT(($$FT^IBCEF(IBIFN)=2)!($$FT^IBCEF(IBIFN)=7)&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1,$GET(IBPRV))_$PIECE($$SITE^VASITE,U,3),1:"")
+5 ;
