Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEU3

IBCEU3.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. BOX19(IBIFN) ; New Box 19 added for patch 488. This is for workman's comp?
  1. ; This returns the Paperwork Attachment
  1. ; Information in the following format:
  1. ; PWKNNFX12348907CHEY<3 Spaces>Next set if more than one on claim
  1. ; PWK is the qualifier for data, followed by the appropriate Report Type
  1. ;Code, the appropriate Transmission Type Code, then the Attachment Control
  1. ;Number. Do not enter spaces between qualifiers and data.
  1. ;
  1. ; This information can be at either the Line Level or the Claim Level.
  1. ; Check all Lines first and print as many as possible - 71 characters
  1. ; maximum. Then check the Claim Level
  1. N IBRTP,LN,U8,IBBX19,IB19,DATA,I,DEL
  1. ;JWS;IB*2.0*592;add Dental Claim Note field to EDI 837D trans, rec UB1, field 19
  1. ;IA# 2056
  1. I $$FT^IBCEF(IBIFN)=7 Q $$GET1^DIQ(399,IBIFN_",",97)
  1. S IB19="",DEL=" ",LN=0
  1. ; Get rate type
  1. S IBRTP=$P($G(^DGCR(399,IBIFN,0)),U,7)
  1. ; Get data entered for box 19
  1. S IBBX19=$P($G(^DGCR(399,IBIFN,"UF31")),U,3)
  1. ; check the line Level first
  1. I IBRTP=11 D
  1. .F S LN=$O(^DGCR(399,IBIFN,"CP",LN)) Q:LN="" Q:LN'?.N D
  1. ..S DATA=$G(^DGCR(399,IBIFN,"CP",LN,1))
  1. ..I $P(DATA,U,2)'="" S IB19=IB19_$S(IB19="":"",1:DEL)_$$FORMAT(DATA)
  1. .; check the Claim Level next
  1. .S DATA=""
  1. .S DATA=$G(^DGCR(399,IBIFN,"U8"))
  1. .I DATA'="" S IB19=IB19_$S(IB19="":"",1:DEL)_$$FORMAT(DATA)
  1. ; If any room left add user entered box 19 info
  1. I IBBX19'="",IB19'="",$L(IB19)<84 D
  1. .F I=1:1:$L(IBBX19,DEL) S DATA=$P(IBBX19,DEL,I) I DATA'="" D
  1. ..I $L(IB19_DEL_DATA)<84 S IB19=IB19_$S(IB19="":"",1:DEL)_DATA
  1. I IB19="",IBBX19'="" S IB19=IBBX19
  1. ;
  1. Q IB19
  1. ;
  1. FORMAT(DATA) ; format data for ouput
  1. N ART,OUT
  1. S ART=$P(DATA,U,2)
  1. S ART=$P(^IBE(353.3,ART,0),U,1)
  1. S OUT="PWK"_ART_$P(DATA,U,3)_$P(DATA,U,1)
  1. Q OUT
  1. ;
  1. ; BELOW NO LONGER USED -> BAA *488*
  1. 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
  1. ; for bill ien IBIFN
  1. ; Data is derived from a combo of data throughout
  1. ; the system and is limited to 80 characters. The hierarchy for
  1. ; including data is as follows (until 80 characters have been used):
  1. ; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
  1. ; specialty codes = 025,065,073,067,048
  1. ; LAST X-RAY DATE (chiropractic) specialty code = 35
  1. ; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
  1. ; a specimen from a homebound patient)
  1. ; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
  1. ; Hearing aid testing (if applicable)
  1. ; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
  1. ; SPECIAL PROGRAM indicator if Medicare demonstration project for
  1. ; lung volume reduction surgery study is set
  1. ; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
  1. ; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
  1. ; DETAIL
  1. ;
  1. N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM,IBSPI
  1. S IB19="",IBGO=1
  1. S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
  1. I $D(IBXSAVE(IBSUB)) N IBXSAVE
  1. S IBPRT=(IBSUB["24")
  1. ;
  1. S IBSPEC=$$BILLSPEC(IBIFN)
  1. G:'IBPRT NPRT
  1. ; Check for chiropractic services
  1. 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)
  1. G:'IBGO BOX19Q
  1. ;
  1. I "^25^65^73^67^48^"[(U_IBSPEC_U) D
  1. . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
  1. . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
  1. .. ; Only print if specialty is OT or PT or proc for routine foot care
  1. .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA
  1. ;
  1. G:'IBGO BOX19Q
  1. K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN)
  1. I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q
  1. ;
  1. K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
  1. I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q
  1. ;
  1. I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1))
  1. ;
  1. S (IBHAID,IBHOSP,IBXRAY)=0
  1. ;
  1. S Z=0 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D G:'IBGO BOX19Q
  1. . 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)
  1. . ;
  1. . Q:'IBGO
  1. . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D Q
  1. .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q
  1. . ;
  1. . Q:'IBGO
  1. . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q
  1. G:'IBGO BOX19Q
  1. K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
  1. I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q
  1. ;
  1. ; SPECIAL PROGRAM INDICATOR field code.
  1. S IBSPI=$$GET1^DIQ(399,IBIFN_",",238,"E")
  1. I IBSPI'="" S IBGO=$$LENOK(IBSPI,.IB19)
  1. ;
  1. G:'IBGO BOX19Q
  1. NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
  1. S IBREM=0
  1. I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1
  1. K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN)
  1. I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q
  1. ;
  1. BOX19Q Q IB19
  1. ; ALL OF THE ABOVE TO OBOX19 IS NO LONGER USED *488*
  1. ;
  1. 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)
  1. ; Returns 0 if max length reached or exceeded, otherwise, 1
  1. ; Changed 96 to 71 for new 1500 form
  1. N OK
  1. S OK=1
  1. S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA)
  1. I $L(IB19)'<83 S OK=0,IB19=$E(IB19,1,71) G LENOKQ
  1. LENOKQ Q OK
  1. ;
  1. ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN
  1. ; changed to 71 length.
  1. N DIR,DIC,X,Y,DIE,DR,Z
  1. S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
  1. D ^DIR
  1. K DIR("B")
  1. I Y=1 D
  1. .S Z=$$BOX19(IBIFN) W !!,?4,"19",?45,$E(Z,1,23) W:$L(Z)>23 !,?4,$E(Z,24,71),!
  1. .S DIR(0)="E",DIR("A")="Enter <RET> to Continue " W ! D ^DIR K DIR
  1. Q
  1. ;
  1. ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab
  1. N IBP,IBPUR
  1. S IBP=0
  1. S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
  1. I IBPUR,"13"[IBPUR S IBP=1
  1. Q IBP
  1. ;
  1. TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld
  1. ; INPUT:
  1. ; FLD = the letter of the field in box 24 (A-J)
  1. ; IBXSAVE = passed by reference = extracted data for the box 24 lines
  1. ; IBSUB = the subscript of the IBXSAVE array to use.
  1. ; If null, use "BOX24"
  1. ; OUTPUT:
  1. ; IBXDATA = passed by reference, set to the correct part of the
  1. ; text that will print in the field's positions
  1. ;
  1. ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
  1. ;
  1. N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
  1. K IBXDATA
  1. S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24"
  1. ;
  1. I FLD="I"!(FLD="J") D ; extract the Rendering provider data
  1. . I '$G(IBXIEN) Q ; assume that the claim# exists
  1. . S IBREN=$$CFIDS^IBCEF77(IBXIEN)
  1. . S IBRENQ=$P(IBREN,U,1) ; qual
  1. . S IBRENSID=$P(IBREN,U,2) ; id
  1. . S IBRENNPI=$P(IBREN,U,3) ; npi
  1. . Q
  1. ;
  1. F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D
  1. . S IBDAT=$G(IBXSAVE(IBSUB,Z))
  1. . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX"))
  1. . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT"))
  1. . S IBZ=$P(IBAUX,U,9)
  1. . I IBZ="" S IBZ=" "
  1. . S IBTEXT=IBZ_IBTEXT
  1. . ;
  1. . 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=""
  1. . ;
  1. . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D ; From date of service
  1. .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
  1. .. Q
  1. . ;
  1. . 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
  1. .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
  1. .. Q
  1. . ;
  1. . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21 ; place of service
  1. . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24 ; emergency indicator
  1. . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D ; procedures and modifiers
  1. .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10)) ; modifier list
  1. .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" " ; procedure code
  1. .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3) ; mod#1
  1. .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3) ; mod#2
  1. .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3) ; mod#3
  1. .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3) ; mod#4
  1. .. Q
  1. . ;
  1. . I FLD="E" D
  1. .. N NUM,IN,OUT,LET
  1. .. S IN="1,2,3,4,5,6,7,8,9"
  1. .. S OUT="A,B,C,D,E,F,G,H,I"
  1. .. S IBVAL=$P(IBDAT,U,7)
  1. .. F I=1:1:4 S NUM=$P(IBVAL,",",I) D
  1. ... I NUM<10 S $P(LET,",",I)=$TR(NUM,IN,OUT)
  1. ... I NUM=10 S $P(LET,",",I)="J"
  1. ... I NUM=11 S $P(LET,",",I)="K"
  1. ... I NUM=12 S $P(LET,",",I)="L"
  1. .. S IBVAL=$TR(LET,","),IBS=45,IBE=48 ; diagnosis pointer
  1. . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D
  1. .. ; total charges **519 returned field length back to 8, 9 is too long for BOX24F
  1. .. S IBVAL=$$DOL^IBCEF77(IBVAL,8)
  1. .. I $L(IBVAL)>8 S IBVAL=$E(IBVAL,$L(IBVAL)-7,$L(IBVAL))
  1. .. Q
  1. . ;
  1. . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D
  1. .. ; days or units or anesthesia minutes
  1. .. S IBVAL=$J(+IBVAL,4)
  1. .. Q
  1. . ;
  1. . ; columns H,I,J don't have any free text supplemental information
  1. . ;
  1. . I FLD="H" D ; epsdt family plan
  1. .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT="" ; line 1 blank
  1. .. I IBVAL S IBVAL="Y"
  1. .. Q
  1. . I FLD="I" D ; ID qualifier for rendering provider
  1. .. S IBVAL="",IBS=1,IBE=2 ; line 2 blank
  1. .. S IBTEXT=$G(IBRENQ) ; qualifier on line 1
  1. .. Q
  1. . I FLD="J" D ; rendering provider ID and NPI
  1. .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11 ; secondary ID line 1
  1. .. S IBVAL=$G(IBRENNPI) ; NPI# line 2
  1. .. Q
  1. . ;
  1. . S IBLINE=IBLINE+1 ; top line
  1. . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE) ; text in shaded area (top)
  1. . S IBLINE=IBLINE+1 ; bottom line
  1. . S IBXDATA(IBLINE)=IBVAL ; field value in unshaded area (bottom)
  1. . Q
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; Default = 99 if no valid SPEC code found for line and claim level provider
  1. ; Get rendering for professional, attending for institutional
  1. ; If multiple lines w/ rendering or attending, returns a string of spec codes
  1. N Z,IBSPEC,IBINS,IBDT,IBCP,IBSPC
  1. S IBSPC=""
  1. S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
  1. S IBINS=($$FT^IBCEF(IBIFN)=3)
  1. D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
  1. S Z=$S('IBINS:3,1:4)
  1. ; check claim level
  1. I $G(IBPRV(Z,1))'="" D
  1. . 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
  1. . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
  1. . I Z0 S IBSPEC=$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8) S:IBSPEC="" IBSPEC=99 S IBSPC=IBSPC_U_IBSPEC
  1. ; Check line level
  1. S IBCP=0 F S IBCP=$O(^DGCR(399,IBIFN,"CP",IBCP)) Q:'IBCP D
  1. .S Z0=+$O(^DGCR(399,IBIFN,"CP",IBCP,"LNPRV","B",Z,0))
  1. .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
  1. ;/IB*2*608 - vd (US3214) - modified the following line to allow for No Rendering Provider.
  1. ;S:IBSPC="" IBSPC=99
  1. I $$FT^IBCEF(IBIFN)'=2 S:IBSPC="" IBSPC=99
  1. Q IBSPC
  1. ;
  1. BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN
  1. ; If IBPRV is supplied, returns the data for that provider, otherwise,
  1. ; returns the specialty of the 'main/required' provider on the bill.
  1. ; Default = 99 if no valid code found
  1. ; IBPRV = vp of provider (file 200 or 355.93)
  1. N Z,IBSPEC,IBINS,IBDT
  1. S IBSPEC="",IBPRV=$G(IBPRV)
  1. S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
  1. ;
  1. I $G(IBPRV) D G SPECQ
  1. . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
  1. ;
  1. ;Get rendering for professional, attending for institutional,
  1. S IBINS=($$FT^IBCEF(IBIFN)=3)
  1. D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
  1. S Z=$S('IBINS:3,1:4)
  1. I $G(IBPRV(Z,1))'="" D
  1. . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'=""
  1. . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
  1. . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8)
  1. ;
  1. SPECQ I IBSPEC="" S IBSPEC="99"
  1. Q IBSPEC
  1. ;
  1. CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
  1. Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
  1. ;
  1. FAC(IBIFN) ; Obsolete function. Used by old output formatter field and data element N-RENDERING INSTITUTION
  1. Q ""
  1. ;
  1. 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
  1. ;JWS;IB*2.0*592:Added dental form to check for compatibility
  1. ;Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1,$G(IBPRV))_$P($$SITE^VASITE,U,3),1:"")
  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:"")
  1. ;