- 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 Jan 18, 2025@03:13:47 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 ;