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

IBCEF21.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. COID(IBIFN) ; Claim office ID
  1. N IBCOID,IBCOID1,IBIN
  1. S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11)
  1. ;
  1. I IBIN D
  1. . I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q ;Rx
  1. . I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q ;Inpt
  1. . I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q ;Outpt
  1. . ;JWS;IB*2.0*592;Dental insurance mailing address info
  1. . I $$FT^IBCEF(IBIFN)=7 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.19,11),U,11) Q ;Dental
  1. ;
  1. Q $S(IBCOID1'="":IBCOID1,1:IBCOID)
  1. ;
  1. 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)
  1. ;
  1. N PPOL,DFN,X,Y S Y=""
  1. S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
  1. I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11)
  1. Q Y
  1. ;
  1. 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)
  1. ; ^ employer state abbr (2.312,2.06) ^ employer state ifn (2.312,2.06)
  1. ;
  1. N PPOL,DFN,X,Y S Y=""
  1. S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
  1. 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)
  1. Q Y
  1. ;
  1. REMARKS(IBIFN) ; Compile array of bill remarks
  1. ;IBIFN = bill ien
  1. N Z,Z0,Z1,IBARRAY,IBSM
  1. S Z=0
  1. ;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)
  1. S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill
  1. S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0))
  1. D SET^IBCSC5B(IBIFN,.IBARRAY)
  1. I $P($G(IBARRAY),U,2) D ;Prosthetics
  1. . 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)
  1. Q
  1. ;
  1. CREM(IBIFN) ; Compile array of bill remarks common to every bill
  1. ;IBIFN = bill ien
  1. N Z
  1. S Z=0
  1. S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment
  1. Q
  1. ;
  1. ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
  1. ; IBIFN = bill ien
  1. ; NOOUTCK = flag that will:
  1. ; (1) no check for inpt episode overlap for outpt
  1. ; (0 or null) performs check for inpt episode overlap for outpt
  1. ;
  1. ; Returns IBXDATA = fileman date format
  1. N Z,Z0,Z1
  1. ;JWS;IB*2.0*592;send Event Date for Admission Date for Dental claims; IA# 2056
  1. I $$FT^IBCEF(IBIFN)=7 S IBXDATA=$$GET1^DIQ(399,IBIFN_",",.03,"I") Q
  1. S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1)
  1. S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"")
  1. S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"")
  1. ; Check to see if outpt episode (date in event date) overlaps inpt
  1. ; episode - use admit date if it does
  1. I 'Z0,IBXDATA,'$G(NOOUTCK) D
  1. . N VAINDT,VAIN,DFN
  1. . S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
  1. . D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA=""
  1. I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2)
  1. Q
  1. ;
  1. DISDT(IBIFN) ; Calculate discharge date
  1. ; IBIFN = bill ien
  1. N Z,Z0
  1. ;JWS;IB*2.0*592;do not send for Discharge Date for Dental claims
  1. I $$FT^IBCEF(IBIFN)=7 S IBXDATA="" Q
  1. S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0))
  1. I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16)
  1. 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))
  1. Q
  1. ;
  1. INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's
  1. ; IBIFN required
  1. ; TYPE is either "PAT" or "SUB" to indicate we need to extract either
  1. ; patient or subscriber ID information. Default="SUB".
  1. ; SEQ is the insurance sequence# (1,2,3). Default is current ins seq#.
  1. ;
  1. ; Output:
  1. ; Function returns an 8-piece string as follows.
  1. ; [1] primary qualifier
  1. ; [2] primary ID
  1. ; [3] secondary qual(1)
  1. ; [4] secondary ID(1)
  1. ; [5] secondary qual(2)
  1. ; [6] secondary ID(2)
  1. ; [7] secondary qual(3)
  1. ; [8] secondary ID(3)
  1. ;
  1. NEW DATA,DFN,POL,IB0,IB5,REL
  1. S DATA=""
  1. S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX
  1. I $G(TYPE)="" S TYPE="SUB" ; default type of ID's to get
  1. I '$F(".PAT.SUB.","."_TYPE_".") G INSSX
  1. I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN) ; default current ins seq#
  1. I '$F(".1.2.3.","."_SEQ_".") G INSSX
  1. S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX
  1. S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX
  1. ;IB*2.0*516/baa - Use HIPAA compliant fields
  1. ;S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX ;516 - baa
  1. S IB0=$$ZND^IBCNS1(DFN,POL) I IB0="" G INSSX ;516 - baa
  1. S IB5=$G(^DPT(DFN,.312,POL,5))
  1. S REL=+$P(IB0,U,16) ; pat rel to insured
  1. S $P(DATA,U,1)="MI"
  1. S $P(DATA,U,2)=$P(IB0,U,2) ; subscriber primary ID
  1. S $P(DATA,U,3,8)=$P(IB5,U,2,7) ; subscriber secondary data
  1. I TYPE="PAT",REL'=1 D
  1. . S $P(DATA,U,2)=$P(IB5,U,1) ; patient primary ID
  1. . S $P(DATA,U,3,8)=$P(IB5,U,8,13) ; patient secondary data
  1. . Q
  1. ;
  1. S DATA=$$SCRUB(DATA) ; scrub the data
  1. INSSX ;
  1. Q DATA
  1. ;
  1. SCRUB(DATA) ; Scrub the 8-piece string gathered above
  1. NEW PCE
  1. ;
  1. ; make sure you can't have an ID without a qualifier or a qualifier
  1. ; without an ID. Check all 4 pairs.
  1. F PCE=1,3,5,7 D
  1. . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
  1. . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
  1. . Q
  1. ;
  1. ; fill in secondary gaps. If Set1 and Set2 are blank, but Set3 exists
  1. ; then move Set3 to Set1 and delete Set3.
  1. I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D
  1. . S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8)
  1. . S ($P(DATA,U,7),$P(DATA,U,8))=""
  1. . Q
  1. ;
  1. ; fill in secondary gaps more generically.
  1. ; If Set(n) is blank, but Set(n+1) exists, then move it up.
  1. F PCE=3,5 D
  1. . I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D
  1. .. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2)
  1. .. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3)
  1. .. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))=""
  1. .. Q
  1. . Q
  1. ;
  1. Q DATA
  1. ;