IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ; 3/9/11 1:12pm
;;2.0;INTEGRATED BILLING;**51,296,371,389,448,516,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
COID(IBIFN) ; Claim office ID
N IBCOID,IBCOID1,IBIN
S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11)
;
I IBIN D
. I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q ;Rx
. I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q ;Inpt
. I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q ;Outpt
. ;JWS;IB*2.0*592;Dental insurance mailing address info
. I $$FT^IBCEF(IBIFN)=7 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.19,11),U,11) Q ;Dental
;
Q $S(IBCOID1'="":IBCOID1,1:IBCOID)
;
ESGHPST(IBIFN,COB) ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan
; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11)
;
N PPOL,DFN,X,Y S Y=""
S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11)
Q Y
;
ESGHPNL(IBIFN,COB) ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan
; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05)
; ^ employer state abbr (2.312,2.06) ^ employer state ifn (2.312,2.06)
;
N PPOL,DFN,X,Y S Y=""
S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,9)_U_$P(X,U,5)_U_$P($G(^DIC(5,+$P(X,U,6),0)),U,2)_U_$P(X,U,6)
Q Y
;
;IBIFN = bill ien
N Z,Z0,Z1,IBARRAY,IBSM
S Z=0
;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2)
S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill
S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0))
D SET^IBCSC5B(IBIFN,.IBARRAY)
I $P($G(IBARRAY),U,2) D ;Prosthetics
. S Z0=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
Q
;
CREM(IBIFN) ; Compile array of bill remarks common to every bill
;IBIFN = bill ien
N Z
S Z=0
S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment
Q
;
ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
; IBIFN = bill ien
; NOOUTCK = flag that will:
; (1) no check for inpt episode overlap for outpt
; (0 or null) performs check for inpt episode overlap for outpt
;
; Returns IBXDATA = fileman date format
N Z,Z0,Z1
;JWS;IB*2.0*592;send Event Date for Admission Date for Dental claims; IA# 2056
I $$FT^IBCEF(IBIFN)=7 S IBXDATA=$$GET1^DIQ(399,IBIFN_",",.03,"I") Q
S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1)
S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"")
S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"")
; Check to see if outpt episode (date in event date) overlaps inpt
; episode - use admit date if it does
I 'Z0,IBXDATA,'$G(NOOUTCK) D
. N VAINDT,VAIN,DFN
. S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
. D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA=""
I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2)
Q
;
DISDT(IBIFN) ; Calculate discharge date
; IBIFN = bill ien
N Z,Z0
;JWS;IB*2.0*592;do not send for Discharge Date for Dental claims
I $$FT^IBCEF(IBIFN)=7 S IBXDATA="" Q
S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0))
I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16)
I 'Z N VAINDT,VAIN,DFN S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D INP^VADPT I VAIN(1) S IBXDATA=+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
Q
;
INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's
; IBIFN required
; TYPE is either "PAT" or "SUB" to indicate we need to extract either
; patient or subscriber ID information. Default="SUB".
; SEQ is the insurance sequence# (1,2,3). Default is current ins seq#.
;
; Output:
; Function returns an 8-piece string as follows.
; [1] primary qualifier
; [2] primary ID
; [3] secondary qual(1)
; [4] secondary ID(1)
; [5] secondary qual(2)
; [6] secondary ID(2)
; [7] secondary qual(3)
; [8] secondary ID(3)
;
NEW DATA,DFN,POL,IB0,IB5,REL
S DATA=""
S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX
I $G(TYPE)="" S TYPE="SUB" ; default type of ID's to get
I '$F(".PAT.SUB.","."_TYPE_".") G INSSX
I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN) ; default current ins seq#
I '$F(".1.2.3.","."_SEQ_".") G INSSX
S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX
S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX
;IB*2.0*516/baa - Use HIPAA compliant fields
;S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX ;516 - baa
S IB0=$$ZND^IBCNS1(DFN,POL) I IB0="" G INSSX ;516 - baa
S IB5=$G(^DPT(DFN,.312,POL,5))
S REL=+$P(IB0,U,16) ; pat rel to insured
S $P(DATA,U,1)="MI"
S $P(DATA,U,2)=$P(IB0,U,2) ; subscriber primary ID
S $P(DATA,U,3,8)=$P(IB5,U,2,7) ; subscriber secondary data
I TYPE="PAT",REL'=1 D
. S $P(DATA,U,2)=$P(IB5,U,1) ; patient primary ID
. S $P(DATA,U,3,8)=$P(IB5,U,8,13) ; patient secondary data
. Q
;
S DATA=$$SCRUB(DATA) ; scrub the data
INSSX ;
Q DATA
;
SCRUB(DATA) ; Scrub the 8-piece string gathered above
NEW PCE
;
; make sure you can't have an ID without a qualifier or a qualifier
; without an ID. Check all 4 pairs.
F PCE=1,3,5,7 D
. I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
. S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
. Q
;
; fill in secondary gaps. If Set1 and Set2 are blank, but Set3 exists
; then move Set3 to Set1 and delete Set3.
I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D
. S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8)
. S ($P(DATA,U,7),$P(DATA,U,8))=""
. Q
;
; fill in secondary gaps more generically.
; If Set(n) is blank, but Set(n+1) exists, then move it up.
F PCE=3,5 D
. I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D
.. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2)
.. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3)
.. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))=""
.. Q
. Q
;
Q DATA
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF21 6788 printed Oct 16, 2024@18:10:41 Page 2
IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ; 3/9/11 1:12pm
+1 ;;2.0;INTEGRATED BILLING;**51,296,371,389,448,516,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
COID(IBIFN) ; Claim office ID
+1 NEW IBCOID,IBCOID1,IBIN
+2 SET IBIN=$$CURR^IBCEF2(IBIFN)
SET IBCOID1=""
SET IBCOID=$PIECE($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11)
+3 ;
+4 IF IBIN
Begin DoDot:1
+5 ;Rx
IF $DATA(^IBA(364.2,"C",IBIFN))
SET IBCOID1=$PIECE($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11)
QUIT
+6 ;Inpt
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,5)<3
SET IBCOID1=$PIECE($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11)
QUIT
+7 ;Outpt
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,5)'<3
SET IBCOID1=$PIECE($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11)
QUIT
+8 ;JWS;IB*2.0*592;Dental insurance mailing address info
+9 ;Dental
IF $$FT^IBCEF(IBIFN)=7
SET IBCOID1=$PIECE($$ADDRESS^IBCNSC0(IBIN,.19,11),U,11)
QUIT
End DoDot:1
+10 ;
+11 QUIT $SELECT(IBCOID1'="":IBCOID1,1:IBCOID)
+12 ;
ESGHPST(IBIFN,COB) ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan
+1 ; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11)
+2 ;
+3 NEW PPOL,DFN,X,Y
SET Y=""
+4 SET PPOL=$$PPOL^IBCEF2($GET(IBIFN),$GET(COB))
SET DFN=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,2)
+5 IF +PPOL
IF +DFN
SET X=$GET(^DPT(DFN,.312,+PPOL,2))
SET Y=+$PIECE(X,U,10)_U_$PIECE(X,U,11)
+6 QUIT Y
+7 ;
ESGHPNL(IBIFN,COB) ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan
+1 ; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05)
+2 ; ^ employer state abbr (2.312,2.06) ^ employer state ifn (2.312,2.06)
+3 ;
+4 NEW PPOL,DFN,X,Y
SET Y=""
+5 SET PPOL=$$PPOL^IBCEF2($GET(IBIFN),$GET(COB))
SET DFN=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,2)
+6 IF +PPOL
IF +DFN
SET X=$GET(^DPT(DFN,.312,+PPOL,2))
SET Y=+$PIECE(X,U,10)_U_$PIECE(X,U,9)_U_$PIECE(X,U,5)_U_$PIECE($GET(^DIC(5,+$PIECE(X,U,6),0)),U,2)_U_$PIECE(X,U,6)
+7 QUIT Y
+8 ;
+1 ;IBIFN = bill ien
+2 NEW Z,Z0,Z1,IBARRAY,IBSM
+3 SET Z=0
+4 ;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2)
+5 ;Bill comment on bill
if $PIECE($GET(^DGCR(399,IBIFN,"U1")),U,8)'=""
SET Z=Z+1
SET IBXDATA(Z)=$PIECE(^("U1"),U,8)
+6 SET Z0=$GET(^DGCR(399,IBIFN,0))
SET Z1=$GET(^DGCR(399.3,+$PIECE(Z0,U,7),0))
+7 DO SET^IBCSC5B(IBIFN,.IBARRAY)
+8 ;Prosthetics
IF $PIECE($GET(IBARRAY),U,2)
Begin DoDot:1
+9 SET Z0=0
FOR
SET Z0=$ORDER(IBARRAY(Z0))
if Z0=""
QUIT
SET Z1=0
FOR
SET Z1=$ORDER(IBARRAY(Z0,Z1))
if 'Z1
QUIT
SET Z=Z+1
SET IBXDATA(Z)="Prosthetic: "_$EXTRACT($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$EXTRACT(Z0,4,5)_"/"_$EXTRACT(Z0,6,7)_"/"_$EXTRACT(Z0,1,2)
End DoDot:1
+10 QUIT
+11 ;
CREM(IBIFN) ; Compile array of bill remarks common to every bill
+1 ;IBIFN = bill ien
+2 NEW Z
+3 SET Z=0
+4 ;Site specific 'every bill' comment
if $PIECE($GET(^IBE(350.9,1,1)),U,4)'=""
SET Z=Z+1
SET IBXDATA(Z)=$PIECE(^(1),U,4)
+5 QUIT
+6 ;
ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
+1 ; IBIFN = bill ien
+2 ; NOOUTCK = flag that will:
+3 ; (1) no check for inpt episode overlap for outpt
+4 ; (0 or null) performs check for inpt episode overlap for outpt
+5 ;
+6 ; Returns IBXDATA = fileman date format
+7 NEW Z,Z0,Z1
+8 ;JWS;IB*2.0*592;send Event Date for Admission Date for Dental claims; IA# 2056
+9 IF $$FT^IBCEF(IBIFN)=7
SET IBXDATA=$$GET1^DIQ(399,IBIFN_",",.03,"I")
QUIT
+10 SET Z=$GET(^DGCR(399,IBIFN,0))
SET Z1=$PIECE($GET(^("U")),U,20)
SET Z0=$$INPAT^IBCEF(IBIFN,1)
+11 SET IBXDATA=$SELECT(Z0&$PIECE(Z,U,8):$PIECE($GET(^DGPT(+$PIECE(Z,U,8),0)),U,2),1:"")
+12 if 'IBXDATA
SET IBXDATA=$PIECE(Z,U,3)_$SELECT(Z0&(Z1<25):"."_$EXTRACT("0",$LENGTH(Z1))_Z1,1:"")
+13 ; Check to see if outpt episode (date in event date) overlaps inpt
+14 ; episode - use admit date if it does
+15 IF 'Z0
IF IBXDATA
IF '$GET(NOOUTCK)
Begin DoDot:1
+16 NEW VAINDT,VAIN,DFN
+17 SET VAINDT=IBXDATA
SET DFN=$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+18 DO INP^VADPT
SET IBXDATA=+VAIN(7)
if 'IBXDATA
SET IBXDATA=""
End DoDot:1
+19 IF 'IBXDATA
IF 'Z0
SET IBXDATA=$$SERVDT^IBCEF(IBIFN,,2)
+20 QUIT
+21 ;
DISDT(IBIFN) ; Calculate discharge date
+1 ; IBIFN = bill ien
+2 NEW Z,Z0
+3 ;JWS;IB*2.0*592;do not send for Discharge Date for Dental claims
+4 IF $$FT^IBCEF(IBIFN)=7
SET IBXDATA=""
QUIT
+5 SET Z=$$INPAT^IBCEF(IBIFN,1)
SET Z0=$GET(^DGCR(399,IBIFN,0))
+6 IF Z
SET IBXDATA=+$GET(^DGPT(+$PIECE(Z0,U,8),70))
if 'IBXDATA
SET IBXDATA=$PIECE(Z0,U,16)
+7 IF 'Z
NEW VAINDT,VAIN,DFN
SET DFN=$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
DO INP^VADPT
IF VAIN(1)
SET IBXDATA=+$GET(^DGPM(+$PIECE($GET(^DGPM(+VAIN(1),0)),U,17),0))
+8 QUIT
+9 ;
INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's
+1 ; IBIFN required
+2 ; TYPE is either "PAT" or "SUB" to indicate we need to extract either
+3 ; patient or subscriber ID information. Default="SUB".
+4 ; SEQ is the insurance sequence# (1,2,3). Default is current ins seq#.
+5 ;
+6 ; Output:
+7 ; Function returns an 8-piece string as follows.
+8 ; [1] primary qualifier
+9 ; [2] primary ID
+10 ; [3] secondary qual(1)
+11 ; [4] secondary ID(1)
+12 ; [5] secondary qual(2)
+13 ; [6] secondary ID(2)
+14 ; [7] secondary qual(3)
+15 ; [8] secondary ID(3)
+16 ;
+17 NEW DATA,DFN,POL,IB0,IB5,REL
+18 SET DATA=""
+19 SET IBIFN=+$GET(IBIFN)
IF 'IBIFN
GOTO INSSX
+20 ; default type of ID's to get
IF $GET(TYPE)=""
SET TYPE="SUB"
+21 IF '$FIND(".PAT.SUB.","."_TYPE_".")
GOTO INSSX
+22 ; default current ins seq#
IF '$GET(SEQ)
SET SEQ=$$COBN^IBCEF(IBIFN)
+23 IF '$FIND(".1.2.3.","."_SEQ_".")
GOTO INSSX
+24 SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
IF 'DFN
GOTO INSSX
+25 SET POL=+$PIECE($GET(^DGCR(399,IBIFN,"M")),U,SEQ+11)
IF 'POL
GOTO INSSX
+26 ;IB*2.0*516/baa - Use HIPAA compliant fields
+27 ;S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX ;516 - baa
+28 ;516 - baa
SET IB0=$$ZND^IBCNS1(DFN,POL)
IF IB0=""
GOTO INSSX
+29 SET IB5=$GET(^DPT(DFN,.312,POL,5))
+30 ; pat rel to insured
SET REL=+$PIECE(IB0,U,16)
+31 SET $PIECE(DATA,U,1)="MI"
+32 ; subscriber primary ID
SET $PIECE(DATA,U,2)=$PIECE(IB0,U,2)
+33 ; subscriber secondary data
SET $PIECE(DATA,U,3,8)=$PIECE(IB5,U,2,7)
+34 IF TYPE="PAT"
IF REL'=1
Begin DoDot:1
+35 ; patient primary ID
SET $PIECE(DATA,U,2)=$PIECE(IB5,U,1)
+36 ; patient secondary data
SET $PIECE(DATA,U,3,8)=$PIECE(IB5,U,8,13)
+37 QUIT
End DoDot:1
+38 ;
+39 ; scrub the data
SET DATA=$$SCRUB(DATA)
INSSX ;
+1 QUIT DATA
+2 ;
SCRUB(DATA) ; Scrub the 8-piece string gathered above
+1 NEW PCE
+2 ;
+3 ; make sure you can't have an ID without a qualifier or a qualifier
+4 ; without an ID. Check all 4 pairs.
+5 FOR PCE=1,3,5,7
Begin DoDot:1
+6 IF $PIECE(DATA,U,PCE)'=""
IF $PIECE(DATA,U,PCE+1)'=""
QUIT
+7 SET ($PIECE(DATA,U,PCE),$PIECE(DATA,U,PCE+1))=""
+8 QUIT
End DoDot:1
+9 ;
+10 ; fill in secondary gaps. If Set1 and Set2 are blank, but Set3 exists
+11 ; then move Set3 to Set1 and delete Set3.
+12 IF $PIECE(DATA,U,3)=""
IF $PIECE(DATA,U,5)=""
IF $PIECE(DATA,U,7)'=""
Begin DoDot:1
+13 SET $PIECE(DATA,U,3)=$PIECE(DATA,U,7)
SET $PIECE(DATA,U,4)=$PIECE(DATA,U,8)
+14 SET ($PIECE(DATA,U,7),$PIECE(DATA,U,8))=""
+15 QUIT
End DoDot:1
+16 ;
+17 ; fill in secondary gaps more generically.
+18 ; If Set(n) is blank, but Set(n+1) exists, then move it up.
+19 FOR PCE=3,5
Begin DoDot:1
+20 IF $PIECE(DATA,U,PCE)=""
IF $PIECE(DATA,U,PCE+2)'=""
Begin DoDot:2
+21 SET $PIECE(DATA,U,PCE)=$PIECE(DATA,U,PCE+2)
+22 SET $PIECE(DATA,U,PCE+1)=$PIECE(DATA,U,PCE+3)
+23 SET ($PIECE(DATA,U,PCE+2),$PIECE(DATA,U,PCE+3))=""
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
+27 QUIT DATA
+28 ;
