IBCEF79 ;ALB/ESG - Billing Provider functions ;13-Aug-2008
;;2.0;INTEGRATED BILLING;**400,419,432,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
B(IBIFN,COB) ; Determine Billing Provider and Service Facility information
; This function returns a string in the following format:
; [1] billing provider Institution file pointer (IEN to file 4) or "0"
; if the billing provider cannot be determined
; [2] billing provider name (.01 field in file 4) or Error reason why
; the billing provider cannot be determined - used when piece [1]=0
; [3] 0 if the service facility is a VA institution in file 4
; 1 if the service facility is a non-VA facility in file 355.93
; "" if the service facility is blank - when there is no service facility
; [4] service facility IEN - either an IEN to file 4 or to file 355.93
; or "" if the service facility is blank
;
; Input parameters
; IBIFN - claim# required
; COB - payer sequence# - optional - defaults to current payer sequence# if not passed in
;
NEW %,Z,IBU2,NVAFAC,BP,IB0,EVDT,IBDIV,BPDIV,BPDIVCHK,RXFLG,D,D0,DI,DIQ2,X,Y
S Z=""
S IBIFN=+$G(IBIFN)
I 'IBIFN S Z="0^Invalid claim.^^" G BX
I '$D(^DGCR(399,IBIFN,0)) S Z="0^Claim doesn't exist.^^" G BX
I '$G(COB) S COB=$$COBN^IBCEF(IBIFN) ; current payer sequence default
I '$F(".1.2.3.","."_COB_".") S Z="0^Invalid Payer Sequence#: """_COB_"""^^" G BX
;
; set some initial variables for all claims
S IB0=$G(^DGCR(399,IBIFN,0))
S EVDT=$P(IB0,U,3) ; claim event date
I 'EVDT S EVDT=DT ; - default today if undefined
S IBDIV=+$P(IB0,U,22) ; division ptr file 40.8
I 'IBDIV S IBDIV=$$PRIM^VASITE(EVDT) ; - default primary division as of event date
I IBDIV'>0 S $P(Z,U,1,2)="0^Invalid Division for Event Date "_$$FMTE^XLFDT(EVDT,"5Z")_"." G BX
S BPDIV=+$$SITE^VASITE(EVDT,IBDIV) ; division institution ptr file 4
I BPDIV'>0 S $P(Z,U,1,2)="0^Invalid Institution for Event Date "_$$FMTE^XLFDT(EVDT,"5Z")_"." G BX
;
; MRD;IB*2.0*516 - The field used as the switchback flag is being
; marked for deletion, to be deleted after 3/15/2018. That flag
; will now always be null. The following section of code was
; commented out because of this. This section can be deleted in
; the future.
;
;; check ins co switchback flag
;I $$INSFLGS(IBIFN,COB)>0 D G BX
;. N IBZ,SVCIEN,SVCTYP
;. ; revert billing provider and service facility calculation to pre-patch 400 methods
;. ;
;. ; service facility is legacy N-RENDERING INSTITUTION data
;. D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
;. S SVCIEN=+IBZ ; service facility ien
;. S SVCTYP=+$P(IBZ,U,2) ; service facility type - 0=VA inst, 1=non-VA facility
;. ;
;. I 'SVCIEN S $P(Z,U,3)="",$P(Z,U,4)="" ; no svc fac
;. I SVCIEN S $P(Z,U,3)=SVCTYP,$P(Z,U,4)=SVCIEN ; yes svc fac
;. ;
;. ; billing provider = institution of main division in the database
;. S BP=+$$SITE^VASITE
;. I BP,$$BPFACTYP(BP) S $P(Z,U,1,2)=$$CHK(BP) Q
;. S $P(Z,U,1,2)="0^Facility Type of Main Division Institution is invalid."
;. Q
;
S IBU2=$G(^DGCR(399,IBIFN,"U2"))
S NVAFAC=+$P(IBU2,U,10) ; non-VA facility
I NVAFAC D G BX
. S $P(Z,U,3)=1 ; service facility is the non-VA facility
. S $P(Z,U,4)=NVAFAC ; ien to file 355.93
. S BP=BPDIV ; institution of division on claim (IB*2*419)
. I BP,$$BPFACTYP(BP) S $P(Z,U,1,2)=$$CHK(BP) Q
. S $P(Z,U,1,2)="0^Facility Type of Claim's Division is invalid for the Billing Provider."
. Q
;
S BPDIVCHK=0 ; flag indicating if the div inst has been checked
S RXFLG=$$ISRX^IBCEF1(IBIFN) ; pharmacy flag
;
I RXFLG D
. S BP=+$$RXSITE^IBCEF73A(IBIFN) ; dispensing pharmacy ien for pharmacy claims
. I 'BP S BP=BPDIV,BPDIVCHK=1 ; use division institution if pharmacy not found
. Q
;
I 'RXFLG S BP=BPDIV,BPDIVCHK=1 ; non-Rx claims use division institution
;
I BP,$$BPFACTYP(BP) D G BX ; billing provider type is valid
. S $P(Z,U,1,2)=$$CHK(BP)
. ;
. ; 3/27/09 - Special Case
. ; If we are printing the CMS-1500 claim form, then populate the service facility with the billing provider.
. ; For any other calculation, the service facility is blank here.
. ;
. I $G(^TMP("IB 1500 PRINT",$J,IBIFN)) D
.. S $P(Z,U,3)=0 ; service facility is in file 4
.. S $P(Z,U,4)=$P(Z,U,1) ; move billing provider ien over
.. Q
. Q
;
; here, the BP has an invalid billing provider facility type
; move this BP over to the service facility
S $P(Z,U,3)=0 ; service facility is in file 4
S $P(Z,U,4)=BP ; move this BP over to the service facility
;
I BPDIVCHK G B1 ; the division institution has already been checked...skip down to tag B1 to check the parent
;
; check the division institution
S BP=BPDIV,BPDIVCHK=1
I BP,$$BPFACTYP(BP) S $P(Z,U,1,2)=$$CHK(BP) G BX
;
B1 ;
; check the parent
S BP=$$BPPAR(BPDIV) ; institution of the parent of the division
I BP,$$BPFACTYP(BP) S $P(Z,U,1,2)=$$CHK(BP) G BX
;
; here, the facility type of the parent is also not valid, so it is an error
S $P(Z,U,1,2)="0^Facility Type of Division and the Division's Parent Institution are Invalid."
BX ;
Q Z
;
CHK(IEN) ; Perform final billing provider checks on passed in Institution
; file pointer - File 4 ien
; Function returns final pieces 1 and 2 of $$B function as described above
NEW BP
S IEN=+$G(IEN)
I 'IEN S BP="0^Invalid Institution pointer IEN." G CHKX
I '$$BPCHKN(IEN) S BP="0^Not a National Institution." G CHKX
I '$$BPCHKA(IEN) S BP="0^Not an Active Institution." G CHKX
;
S BP=IEN_U_$P($$NS^XUAF4(IEN),U,1) ; ien^name DBIA# 2171
CHKX ;
Q BP
;
BPCHKN(IEN) ; Is this a national Institution?
N Z S Z=0
I $$STATUS^XUAF4(+IEN)="N" S Z=1 ; DBIA# 2171
BPCHKNX ;
Q Z
;
BPCHKA(IEN) ; Is this an active Institution?
N Z S Z=0
I $$ACTIVE^XUAF4(+IEN) S Z=1 ; DBIA# 2171
BPCHKAX ;
Q Z
;
BPFACTYP(IEN) ; Is the facility type of this Institution a valid Billing Provider facility type?
N Z S Z=0
I $D(^IBE(350.9,1,20,"B",+$$GET1^DIQ(4,+IEN_",",13,"I"))) S Z=1
BPFACTPX ;
Q Z
;
BPPAR(IEN) ; Who is the parent for this Institution?
; Function returns the IEN to file 4 of the parent institution as defined in File 4
N Z,PIA
D PARENT^XUAF4($NA(PIA),("`"_+IEN),"PARENT FACILITY") ; DBIA# 2171
S Z=+$O(PIA("P",""))
BPPARX ;
Q Z
;
TAX(IBIFN) ; Update default billing provider and service facility taxonomy codes
; and billing provider secondary IDs and Qualifiers.
; This is called via new style xrefs to update the default value of these fields
;
N BPZ,BPTAX,SFTAX,IENS,IBTAXO,IBU3,IBM1,BPID1,BPQL1,BPID2,BPQL2,BPID3,BPQL3
N D,D0,DI,DIQ2,X,Y
;
I '$G(IBIFN) G TAXQ
I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 G TAXQ ; claim is not editable
;
S BPZ=$$B(IBIFN) ; billing provider/service facility string
;
; billing provider taxonomy
S BPTAX=""
I +BPZ S BPTAX=+$P($$TAXORG^XUSTAX(+BPZ),U,2) ; ien to file 8932.1 for VA billing provider
I 'BPTAX S BPTAX=""
;
; service facility taxonomy
S SFTAX=""
I $P(BPZ,U,3)=0,+$P(BPZ,U,4) S SFTAX=+$P($$TAXORG^XUSTAX(+$P(BPZ,U,4)),U,2) ; ien to file 8932.1 for VA svc fac
I $P(BPZ,U,3)=1,+$P(BPZ,U,4) S SFTAX=+$P($$TAXGET^IBCEP81(+$P(BPZ,U,4)),U,2) ; ien to file 8932.1 for non-VA svc fac
I 'SFTAX S SFTAX=""
;
; billing provider secondary ID#2 and qualifier#2 for each payer on the claim
S BPID1=$$PRVNUM^IBCU(IBIFN,,1) ; #122
S BPQL1=$$PRVQUAL^IBCU(IBIFN,,1) ; #128
S BPID2=$$PRVNUM^IBCU(IBIFN,,2) ; #123
S BPQL2=$$PRVQUAL^IBCU(IBIFN,,2) ; #129
S BPID3=$$PRVNUM^IBCU(IBIFN,,3) ; #124
S BPQL3=$$PRVQUAL^IBCU(IBIFN,,3) ; #130
;
; Use FileMan DBS call to update these fields if changes are necessary
S IENS=IBIFN_","
S IBU3=$G(^DGCR(399,IBIFN,"U3"))
S IBM1=$G(^DGCR(399,IBIFN,"M1"))
I SFTAX'=$P(IBU3,U,2) S IBTAXO(399,IENS,243)=SFTAX ; service facility taxonomy
I BPTAX'=$P(IBU3,U,11) S IBTAXO(399,IENS,252)=BPTAX ; billing provider taxonomy
I BPID1'=$P(IBM1,U,2) S IBTAXO(399,IENS,122)=BPID1 ; primary ID
I BPQL1'=$P(IBM1,U,10) S IBTAXO(399,IENS,128)=BPQL1 ; primary Qual
I BPID2'=$P(IBM1,U,3) S IBTAXO(399,IENS,123)=BPID2 ; secondary ID
I BPQL2'=$P(IBM1,U,11) S IBTAXO(399,IENS,129)=BPQL2 ; secondary Qual
I BPID3'=$P(IBM1,U,4) S IBTAXO(399,IENS,124)=BPID3 ; tertiary ID
I BPQL3'=$P(IBM1,U,12) S IBTAXO(399,IENS,130)=BPQL3 ; tertiary Qual
;
I '$D(IBTAXO) G TAXQ ; no changes necessary
;
D FILE^DIE(,"IBTAXO") ; update fields
TAXQ ;
Q
;
INSFLGS(IBIFN,COB) ; get insurance company flags for a given claim
; returns string of flags in the following format:
; switchback flag ^ send service facility flag ^ institution file address flag ^ error
; switchback flag: field 36/4.11 or 36/4.12, depending on form type. "-1" if error has occurred.
; send service facility flag: field 36/4.07, empty if error has occurred or switchback flag is not set.
; institution file address flag: field 36/4.13, empty if error has occurred or switchback flag is not set.
;
; MRD;IB*2.0*516 - The four flag fields described above (File #36,
; Field #'s 4.07, 4.11, 4.12, 4.13) are all being marked for
; deletion. All references to those fields are being removed
; as part of this patch.
;
Q ""
;
;N FLGS,FT,INSIEN,INS4
;S IBIFN=+$G(IBIFN) I 'IBIFN Q "-1^^^Invalid claim."
;I '$D(^DGCR(399,IBIFN,0)) Q "-1^^^Claim doesn't exist."
;I '$G(COB) S COB=$$COBN^IBCEF(IBIFN) ; current payer sequence default
;I '(".1.2.3."[("."_COB_".")) Q "-1^^^Invalid Payer Sequence#: """_COB_"""."
;S INSIEN=$$POLICY^IBCEF(IBIFN,1,COB) I 'INSIEN Q "-1^^^No insurance company associated with the claim."
;S INS4=$G(^DIC(36,INSIEN,4)),FT=$$FT^IBCEF(IBIFN)
;S FLGS=$P(INS4,U,$S(FT=2:11,1:12)) I '+FLGS Q FLGS ; we are done if switchback flag is not set
;S $P(FLGS,U,2)=$P(INS4,U,7),$P(FLGS,U,3)=$P(INS4,U,13) ; if switchback is set, get the other 2 flags
;Q FLGS
;
GETBP(IBIFN,COB,INST,SUB,IBXSAVE) ; Get billing provider data for claim output
; Used to extract billing provider name, address, and phone# for PRV segment and for CMS-1500, Box 33
; IBIFN - claim ien required
; COB - payer sequence (optional, defaults to current payer seq)
; INST - billing provider VA file 4 ien required
; SUB - subscript to use in IBXSAVE local array required
; IBXSAVE - pass by reference
; Returns IBXSAVE(SUB,"NAME")
; IBXSAVE(SUB,"ADDR1")
; IBXSAVE(SUB,"ADDR2")
; IBXSAVE(SUB,"CITY")
; IBXSAVE(SUB,"ST")
; IBXSAVE(SUB,"ZIP")
; IBXSAVE(SUB,"PHONE")
;
; MRD;IB*2.0*516 - The field used as the switchback flag is being
; marked for deletion, to be deleted after 3/15/2018. That flag
; will now always be null. Several sections of this procedure have
; been commented out because of this. Those sections can be
; deleted in the future.
;
NEW IBZ
K IBXSAVE(SUB)
I '$G(COB) S COB=$$COBN^IBCEF(IBIFN)
;
;S INSFLGS=$$INSFLGS(IBIFN,COB) ; all ins co flags
;S SWBFLG=(+INSFLGS>0) ; main switchback flag
;S (BPTP,MAINPTP)="" ; initialize vars used only in switchback mode
;I SWBFLG D
;. S BPTP=$$MAINPRV^IBJPS3 ; main division pay-to provider data string
;. S MAINPTP=($P(BPTP,U,10)'["IB177") ; flag that says whether main div exists as a pay-to
;. Q
;
; If Switchback is ON and the ins. company parameter Use billing provider VAMC address is not on and
; main div pay-to exists, then use the pay-to provider data for the main division in the database.
; This is the "normal" switchback data.
;I SWBFLG,'$P(INSFLGS,U,3),MAINPTP D G GETBPX ; switchback + billing provider address flag + main ptp exists
;. ; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
;. ;S IBXSAVE(SUB,"NAME")=$P(BPTP,U,1)
;. S IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
;. S:IBXSAVE(SUB,"NAME")="" IBXSAVE(SUB,"NAME")=$P(BPTP,U,1)
;. S IBXSAVE(SUB,"ADDR1")=$P(BPTP,U,5)
;. S IBXSAVE(SUB,"ADDR2")=$P(BPTP,U,6)
;. S IBXSAVE(SUB,"CITY")=$P(BPTP,U,7)
;. S IBXSAVE(SUB,"ST")=$P(BPTP,U,8)
;. S IBXSAVE(SUB,"ZIP")=$P(BPTP,U,9)
;. S IBXSAVE(SUB,"PHONE")=$P(BPTP,U,4)
;. Q
;
; Special Case: Switchback is ON, the ins. company parameter Use billing provider VAMC address
; is not on, but the main division is NOT defined as a Pay-To provider.
; Get the name from the Institution File, but everything else from the claim's Pay-to provider
;I SWBFLG,'$P(INSFLGS,U,3),'MAINPTP D G GETBPX
;. ; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
;. ;S IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
;. S IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
;. S:IBXSAVE(SUB,"NAME")="" IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0) ; Inst name
;. S IBZ=$$PRVDATA^IBJPS3(IBIFN)
;. S IBXSAVE(SUB,"ADDR1")=$P(IBZ,U,5)
;. S IBXSAVE(SUB,"ADDR2")=$P(IBZ,U,6)
;. S IBXSAVE(SUB,"CITY")=$P(IBZ,U,7)
;. S IBXSAVE(SUB,"ST")=$P(IBZ,U,8)
;. S IBXSAVE(SUB,"ZIP")=$P(IBZ,U,9)
;. S IBXSAVE(SUB,"PHONE")=$P(IBZ,U,4)
;. Q
;
; At this point, we want to get the billing provider data from the Institution file
; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
;S IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
S IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
S:IBXSAVE(SUB,"NAME")="" IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
S IBXSAVE(SUB,"ADDR1")=$$GETFAC^IBCEP8(INST,0,1)
S IBXSAVE(SUB,"ADDR2")=$$GETFAC^IBCEP8(INST,0,2)
S IBXSAVE(SUB,"CITY")=$$GETFAC^IBCEP8(INST,0,"3C")
S IBXSAVE(SUB,"ST")=$$GETFAC^IBCEP8(INST,0,"3S")
S IBXSAVE(SUB,"ZIP")=$$GETFAC^IBCEP8(INST,0,"3Z")
S IBXSAVE(SUB,"PHONE")=$$PRVPHONE^IBJPS3(IBIFN) ; pay-to phone for claim
;I SWBFLG,MAINPTP S IBXSAVE(SUB,"PHONE")=$P(BPTP,U,4) ; switchback: pay-to phone for main division
;
; 3/30/09 - new requirement - for locally printed CMS-1500 claims, use the pay-to provider address information - Box 33
;I 'SWBFLG,SUB="BOX33" D
I SUB="BOX33" D
. S IBZ=$$PRVDATA^IBJPS3(IBIFN)
. S IBXSAVE(SUB,"ADDR1")=$P(IBZ,U,5)
. S IBXSAVE(SUB,"ADDR2")=$P(IBZ,U,6)
. S IBXSAVE(SUB,"CITY")=$P(IBZ,U,7)
. S IBXSAVE(SUB,"ST")=$P(IBZ,U,8)
. S IBXSAVE(SUB,"ZIP")=$P(IBZ,U,9)
. Q
;
GETBPX ;
Q
;
SENDSF(IBIFN,COB) ; Send service facility information for the EDI claim?
; Function value returns 1 (send service facility information) or 0 (don't send it)
; The only time this function returns 0 is when the pre-patch 400 switchback flag is set, and
; care was provided at the main division (VAMC) in the database, and the 36,4.07 ins. co. flag is set to NO.
; This function is used in the EDI claim (segments SUB, SUB2, NPI-16, and NPI-17).
; IBIFN required
; COB optional, defaults to current payer sequence
;
; MRD;IB*2.0*516 - The field used as the switchback flag is being
; marked for deletion, to be deleted after 3/15/2018. That flag
; will now always be null. This function will now always return
; '1'.
;
NEW SEND,IBDIV,MAIN
S SEND=1
I '$G(COB) S COB=$$COBN^IBCEF(IBIFN) ; current payer sequence default
;S INSFLGS=$$INSFLGS(IBIFN,COB) ; all ins co flags
;I +INSFLGS'>0 G SENDSFX ; switchback is OFF...get out
G SENDSFX
;
I $P($G(^DGCR(399,IBIFN,"U2")),U,10) G SENDSFX ; if we have a non-VA facility on the claim, always send it
;
S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22) ; division on claim
S MAIN=$$MAIN^IBCEP2B() ; main division in database
I IBDIV'=MAIN G SENDSFX ; care was not provided at the main division - always send it
;
;I $P(INSFLGS,U,2) G SENDSFX ; ins. co. flag is ON so send it
;
S SEND=0 ; otherwise, do not send service facility data
;
SENDSFX ;
Q SEND
;
SLPROV(IBXIEN,TYPE) ; return array of service line provider data
; IBXIEN - ien in file 399
; TYPE: O1 = operating physician, O2 = other operating physician, RE = rendering provider,
; P = purchase service provider, S = supervising provider, RF = referring provider
;
; returns IBXSAVE("SLPRV", counter) = last name ^ first name ^ middle name ^ suffix
; ^ taxonomy code ^ primary id ^ secondary id (1) ^ secondary id qualifier (1) ^ ...
; ^ secondary id (n) ^ secondary id qualifier (n)
; IBXSAVE("SLPRV", counter,"SLC") = service line conter
;
N DATA,IBN,IBX,IENS,MODE,NAME,PRNUM,PRTYPE,OUT,SLC,TMP,IBCNT
I '+IBXIEN Q
D ALLIDS^IBCEFP(IBXIEN,.IBX,1)
S IBCNT=0
;
S SLC="" F S SLC=$O(IBX("L-PROV",IBXIEN,SLC)) Q:'SLC D
. I '$D(IBX("L-PROV",IBXIEN,SLC,"C",1,TYPE)) Q
.I TYPE="O1",PRTYPE'=2 Q ; not operating
.I TYPE="O2",PRTYPE'=9 Q ; not other operating
.I TYPE="RE",PRTYPE'=3 Q ; not rendering
.I TYPE="S",PRTYPE'=5 Q ; not supervising
.I TYPE="RF",PRTYPE'=1 Q ; not referring
.;
.S DATA=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE))
.; name components
.S IENS=$P($P(DATA,U),";")_","
.I $P(DATA,U)["VA(200" S NAME=$$GET1^DIQ(200,IENS,.01)
.I $P(DATA,U)["IBA(355.93" S NAME=$$GET1^DIQ(355.93,IENS,.01)
.S TMP=$P(NAME,",",2),OUT=$P(NAME,",")_U_$P(TMP," ")_U_$P(TMP," ",2)_U_$P(TMP," ",3)
.; taxonomy code
.S $P(OUT,U,5)=$P($$GETTAX^IBCEF73A($P(DATA,U)),U)
.S IBN="" F S IBN=$O(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN)) Q:IBN="" D
..S DATA=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
..; primary id
..I IBN=0 S $P(OUT,U,6)=$P(DATA,U,4) Q
..;
..; secondary ids
..S OUT=OUT_U_$P(DATA,U,4)_U_$P(DATA,U,3)
..Q
.Q
S IBCNT=IBCNT+1
S IBXSAVE("SLPRV",IBCNT)=OUT
S IBXSAVE("SLPRV",IBCNT,"SLC")=SLC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF79 18406 printed Oct 16, 2024@18:11:01 Page 2
IBCEF79 ;ALB/ESG - Billing Provider functions ;13-Aug-2008
+1 ;;2.0;INTEGRATED BILLING;**400,419,432,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
B(IBIFN,COB) ; Determine Billing Provider and Service Facility information
+1 ; This function returns a string in the following format:
+2 ; [1] billing provider Institution file pointer (IEN to file 4) or "0"
+3 ; if the billing provider cannot be determined
+4 ; [2] billing provider name (.01 field in file 4) or Error reason why
+5 ; the billing provider cannot be determined - used when piece [1]=0
+6 ; [3] 0 if the service facility is a VA institution in file 4
+7 ; 1 if the service facility is a non-VA facility in file 355.93
+8 ; "" if the service facility is blank - when there is no service facility
+9 ; [4] service facility IEN - either an IEN to file 4 or to file 355.93
+10 ; or "" if the service facility is blank
+11 ;
+12 ; Input parameters
+13 ; IBIFN - claim# required
+14 ; COB - payer sequence# - optional - defaults to current payer sequence# if not passed in
+15 ;
+16 NEW %,Z,IBU2,NVAFAC,BP,IB0,EVDT,IBDIV,BPDIV,BPDIVCHK,RXFLG,D,D0,DI,DIQ2,X,Y
+17 SET Z=""
+18 SET IBIFN=+$GET(IBIFN)
+19 IF 'IBIFN
SET Z="0^Invalid claim.^^"
GOTO BX
+20 IF '$DATA(^DGCR(399,IBIFN,0))
SET Z="0^Claim doesn't exist.^^"
GOTO BX
+21 ; current payer sequence default
IF '$GET(COB)
SET COB=$$COBN^IBCEF(IBIFN)
+22 IF '$FIND(".1.2.3.","."_COB_".")
SET Z="0^Invalid Payer Sequence#: """_COB_"""^^"
GOTO BX
+23 ;
+24 ; set some initial variables for all claims
+25 SET IB0=$GET(^DGCR(399,IBIFN,0))
+26 ; claim event date
SET EVDT=$PIECE(IB0,U,3)
+27 ; - default today if undefined
IF 'EVDT
SET EVDT=DT
+28 ; division ptr file 40.8
SET IBDIV=+$PIECE(IB0,U,22)
+29 ; - default primary division as of event date
IF 'IBDIV
SET IBDIV=$$PRIM^VASITE(EVDT)
+30 IF IBDIV'>0
SET $PIECE(Z,U,1,2)="0^Invalid Division for Event Date "_$$FMTE^XLFDT(EVDT,"5Z")_"."
GOTO BX
+31 ; division institution ptr file 4
SET BPDIV=+$$SITE^VASITE(EVDT,IBDIV)
+32 IF BPDIV'>0
SET $PIECE(Z,U,1,2)="0^Invalid Institution for Event Date "_$$FMTE^XLFDT(EVDT,"5Z")_"."
GOTO BX
+33 ;
+34 ; MRD;IB*2.0*516 - The field used as the switchback flag is being
+35 ; marked for deletion, to be deleted after 3/15/2018. That flag
+36 ; will now always be null. The following section of code was
+37 ; commented out because of this. This section can be deleted in
+38 ; the future.
+39 ;
+40 ;; check ins co switchback flag
+41 ;I $$INSFLGS(IBIFN,COB)>0 D G BX
+42 ;. N IBZ,SVCIEN,SVCTYP
+43 ;. ; revert billing provider and service facility calculation to pre-patch 400 methods
+44 ;. ;
+45 ;. ; service facility is legacy N-RENDERING INSTITUTION data
+46 ;. D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
+47 ;. S SVCIEN=+IBZ ; service facility ien
+48 ;. S SVCTYP=+$P(IBZ,U,2) ; service facility type - 0=VA inst, 1=non-VA facility
+49 ;. ;
+50 ;. I 'SVCIEN S $P(Z,U,3)="",$P(Z,U,4)="" ; no svc fac
+51 ;. I SVCIEN S $P(Z,U,3)=SVCTYP,$P(Z,U,4)=SVCIEN ; yes svc fac
+52 ;. ;
+53 ;. ; billing provider = institution of main division in the database
+54 ;. S BP=+$$SITE^VASITE
+55 ;. I BP,$$BPFACTYP(BP) S $P(Z,U,1,2)=$$CHK(BP) Q
+56 ;. S $P(Z,U,1,2)="0^Facility Type of Main Division Institution is invalid."
+57 ;. Q
+58 ;
+59 SET IBU2=$GET(^DGCR(399,IBIFN,"U2"))
+60 ; non-VA facility
SET NVAFAC=+$PIECE(IBU2,U,10)
+61 IF NVAFAC
Begin DoDot:1
+62 ; service facility is the non-VA facility
SET $PIECE(Z,U,3)=1
+63 ; ien to file 355.93
SET $PIECE(Z,U,4)=NVAFAC
+64 ; institution of division on claim (IB*2*419)
SET BP=BPDIV
+65 IF BP
IF $$BPFACTYP(BP)
SET $PIECE(Z,U,1,2)=$$CHK(BP)
QUIT
+66 SET $PIECE(Z,U,1,2)="0^Facility Type of Claim's Division is invalid for the Billing Provider."
+67 QUIT
End DoDot:1
GOTO BX
+68 ;
+69 ; flag indicating if the div inst has been checked
SET BPDIVCHK=0
+70 ; pharmacy flag
SET RXFLG=$$ISRX^IBCEF1(IBIFN)
+71 ;
+72 IF RXFLG
Begin DoDot:1
+73 ; dispensing pharmacy ien for pharmacy claims
SET BP=+$$RXSITE^IBCEF73A(IBIFN)
+74 ; use division institution if pharmacy not found
IF 'BP
SET BP=BPDIV
SET BPDIVCHK=1
+75 QUIT
End DoDot:1
+76 ;
+77 ; non-Rx claims use division institution
IF 'RXFLG
SET BP=BPDIV
SET BPDIVCHK=1
+78 ;
+79 ; billing provider type is valid
IF BP
IF $$BPFACTYP(BP)
Begin DoDot:1
+80 SET $PIECE(Z,U,1,2)=$$CHK(BP)
+81 ;
+82 ; 3/27/09 - Special Case
+83 ; If we are printing the CMS-1500 claim form, then populate the service facility with the billing provider.
+84 ; For any other calculation, the service facility is blank here.
+85 ;
+86 IF $GET(^TMP("IB 1500 PRINT",$JOB,IBIFN))
Begin DoDot:2
+87 ; service facility is in file 4
SET $PIECE(Z,U,3)=0
+88 ; move billing provider ien over
SET $PIECE(Z,U,4)=$PIECE(Z,U,1)
+89 QUIT
End DoDot:2
+90 QUIT
End DoDot:1
GOTO BX
+91 ;
+92 ; here, the BP has an invalid billing provider facility type
+93 ; move this BP over to the service facility
+94 ; service facility is in file 4
SET $PIECE(Z,U,3)=0
+95 ; move this BP over to the service facility
SET $PIECE(Z,U,4)=BP
+96 ;
+97 ; the division institution has already been checked...skip down to tag B1 to check the parent
IF BPDIVCHK
GOTO B1
+98 ;
+99 ; check the division institution
+100 SET BP=BPDIV
SET BPDIVCHK=1
+101 IF BP
IF $$BPFACTYP(BP)
SET $PIECE(Z,U,1,2)=$$CHK(BP)
GOTO BX
+102 ;
B1 ;
+1 ; check the parent
+2 ; institution of the parent of the division
SET BP=$$BPPAR(BPDIV)
+3 IF BP
IF $$BPFACTYP(BP)
SET $PIECE(Z,U,1,2)=$$CHK(BP)
GOTO BX
+4 ;
+5 ; here, the facility type of the parent is also not valid, so it is an error
+6 SET $PIECE(Z,U,1,2)="0^Facility Type of Division and the Division's Parent Institution are Invalid."
BX ;
+1 QUIT Z
+2 ;
CHK(IEN) ; Perform final billing provider checks on passed in Institution
+1 ; file pointer - File 4 ien
+2 ; Function returns final pieces 1 and 2 of $$B function as described above
+3 NEW BP
+4 SET IEN=+$GET(IEN)
+5 IF 'IEN
SET BP="0^Invalid Institution pointer IEN."
GOTO CHKX
+6 IF '$$BPCHKN(IEN)
SET BP="0^Not a National Institution."
GOTO CHKX
+7 IF '$$BPCHKA(IEN)
SET BP="0^Not an Active Institution."
GOTO CHKX
+8 ;
+9 ; ien^name DBIA# 2171
SET BP=IEN_U_$PIECE($$NS^XUAF4(IEN),U,1)
CHKX ;
+1 QUIT BP
+2 ;
BPCHKN(IEN) ; Is this a national Institution?
+1 NEW Z
SET Z=0
+2 ; DBIA# 2171
IF $$STATUS^XUAF4(+IEN)="N"
SET Z=1
BPCHKNX ;
+1 QUIT Z
+2 ;
BPCHKA(IEN) ; Is this an active Institution?
+1 NEW Z
SET Z=0
+2 ; DBIA# 2171
IF $$ACTIVE^XUAF4(+IEN)
SET Z=1
BPCHKAX ;
+1 QUIT Z
+2 ;
BPFACTYP(IEN) ; Is the facility type of this Institution a valid Billing Provider facility type?
+1 NEW Z
SET Z=0
+2 IF $DATA(^IBE(350.9,1,20,"B",+$$GET1^DIQ(4,+IEN_",",13,"I")))
SET Z=1
BPFACTPX ;
+1 QUIT Z
+2 ;
BPPAR(IEN) ; Who is the parent for this Institution?
+1 ; Function returns the IEN to file 4 of the parent institution as defined in File 4
+2 NEW Z,PIA
+3 ; DBIA# 2171
DO PARENT^XUAF4($NAME(PIA),("`"_+IEN),"PARENT FACILITY")
+4 SET Z=+$ORDER(PIA("P",""))
BPPARX ;
+1 QUIT Z
+2 ;
TAX(IBIFN) ; Update default billing provider and service facility taxonomy codes
+1 ; and billing provider secondary IDs and Qualifiers.
+2 ; This is called via new style xrefs to update the default value of these fields
+3 ;
+4 NEW BPZ,BPTAX,SFTAX,IENS,IBTAXO,IBU3,IBM1,BPID1,BPQL1,BPID2,BPQL2,BPID3,BPQL3
+5 NEW D,D0,DI,DIQ2,X,Y
+6 ;
+7 IF '$GET(IBIFN)
GOTO TAXQ
+8 ; claim is not editable
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,13)'=1
GOTO TAXQ
+9 ;
+10 ; billing provider/service facility string
SET BPZ=$$B(IBIFN)
+11 ;
+12 ; billing provider taxonomy
+13 SET BPTAX=""
+14 ; ien to file 8932.1 for VA billing provider
IF +BPZ
SET BPTAX=+$PIECE($$TAXORG^XUSTAX(+BPZ),U,2)
+15 IF 'BPTAX
SET BPTAX=""
+16 ;
+17 ; service facility taxonomy
+18 SET SFTAX=""
+19 ; ien to file 8932.1 for VA svc fac
IF $PIECE(BPZ,U,3)=0
IF +$PIECE(BPZ,U,4)
SET SFTAX=+$PIECE($$TAXORG^XUSTAX(+$PIECE(BPZ,U,4)),U,2)
+20 ; ien to file 8932.1 for non-VA svc fac
IF $PIECE(BPZ,U,3)=1
IF +$PIECE(BPZ,U,4)
SET SFTAX=+$PIECE($$TAXGET^IBCEP81(+$PIECE(BPZ,U,4)),U,2)
+21 IF 'SFTAX
SET SFTAX=""
+22 ;
+23 ; billing provider secondary ID#2 and qualifier#2 for each payer on the claim
+24 ; #122
SET BPID1=$$PRVNUM^IBCU(IBIFN,,1)
+25 ; #128
SET BPQL1=$$PRVQUAL^IBCU(IBIFN,,1)
+26 ; #123
SET BPID2=$$PRVNUM^IBCU(IBIFN,,2)
+27 ; #129
SET BPQL2=$$PRVQUAL^IBCU(IBIFN,,2)
+28 ; #124
SET BPID3=$$PRVNUM^IBCU(IBIFN,,3)
+29 ; #130
SET BPQL3=$$PRVQUAL^IBCU(IBIFN,,3)
+30 ;
+31 ; Use FileMan DBS call to update these fields if changes are necessary
+32 SET IENS=IBIFN_","
+33 SET IBU3=$GET(^DGCR(399,IBIFN,"U3"))
+34 SET IBM1=$GET(^DGCR(399,IBIFN,"M1"))
+35 ; service facility taxonomy
IF SFTAX'=$PIECE(IBU3,U,2)
SET IBTAXO(399,IENS,243)=SFTAX
+36 ; billing provider taxonomy
IF BPTAX'=$PIECE(IBU3,U,11)
SET IBTAXO(399,IENS,252)=BPTAX
+37 ; primary ID
IF BPID1'=$PIECE(IBM1,U,2)
SET IBTAXO(399,IENS,122)=BPID1
+38 ; primary Qual
IF BPQL1'=$PIECE(IBM1,U,10)
SET IBTAXO(399,IENS,128)=BPQL1
+39 ; secondary ID
IF BPID2'=$PIECE(IBM1,U,3)
SET IBTAXO(399,IENS,123)=BPID2
+40 ; secondary Qual
IF BPQL2'=$PIECE(IBM1,U,11)
SET IBTAXO(399,IENS,129)=BPQL2
+41 ; tertiary ID
IF BPID3'=$PIECE(IBM1,U,4)
SET IBTAXO(399,IENS,124)=BPID3
+42 ; tertiary Qual
IF BPQL3'=$PIECE(IBM1,U,12)
SET IBTAXO(399,IENS,130)=BPQL3
+43 ;
+44 ; no changes necessary
IF '$DATA(IBTAXO)
GOTO TAXQ
+45 ;
+46 ; update fields
DO FILE^DIE(,"IBTAXO")
TAXQ ;
+1 QUIT
+2 ;
INSFLGS(IBIFN,COB) ; get insurance company flags for a given claim
+1 ; returns string of flags in the following format:
+2 ; switchback flag ^ send service facility flag ^ institution file address flag ^ error
+3 ; switchback flag: field 36/4.11 or 36/4.12, depending on form type. "-1" if error has occurred.
+4 ; send service facility flag: field 36/4.07, empty if error has occurred or switchback flag is not set.
+5 ; institution file address flag: field 36/4.13, empty if error has occurred or switchback flag is not set.
+6 ;
+7 ; MRD;IB*2.0*516 - The four flag fields described above (File #36,
+8 ; Field #'s 4.07, 4.11, 4.12, 4.13) are all being marked for
+9 ; deletion. All references to those fields are being removed
+10 ; as part of this patch.
+11 ;
+12 QUIT ""
+13 ;
+14 ;N FLGS,FT,INSIEN,INS4
+15 ;S IBIFN=+$G(IBIFN) I 'IBIFN Q "-1^^^Invalid claim."
+16 ;I '$D(^DGCR(399,IBIFN,0)) Q "-1^^^Claim doesn't exist."
+17 ;I '$G(COB) S COB=$$COBN^IBCEF(IBIFN) ; current payer sequence default
+18 ;I '(".1.2.3."[("."_COB_".")) Q "-1^^^Invalid Payer Sequence#: """_COB_"""."
+19 ;S INSIEN=$$POLICY^IBCEF(IBIFN,1,COB) I 'INSIEN Q "-1^^^No insurance company associated with the claim."
+20 ;S INS4=$G(^DIC(36,INSIEN,4)),FT=$$FT^IBCEF(IBIFN)
+21 ;S FLGS=$P(INS4,U,$S(FT=2:11,1:12)) I '+FLGS Q FLGS ; we are done if switchback flag is not set
+22 ;S $P(FLGS,U,2)=$P(INS4,U,7),$P(FLGS,U,3)=$P(INS4,U,13) ; if switchback is set, get the other 2 flags
+23 ;Q FLGS
+24 ;
GETBP(IBIFN,COB,INST,SUB,IBXSAVE) ; Get billing provider data for claim output
+1 ; Used to extract billing provider name, address, and phone# for PRV segment and for CMS-1500, Box 33
+2 ; IBIFN - claim ien required
+3 ; COB - payer sequence (optional, defaults to current payer seq)
+4 ; INST - billing provider VA file 4 ien required
+5 ; SUB - subscript to use in IBXSAVE local array required
+6 ; IBXSAVE - pass by reference
+7 ; Returns IBXSAVE(SUB,"NAME")
+8 ; IBXSAVE(SUB,"ADDR1")
+9 ; IBXSAVE(SUB,"ADDR2")
+10 ; IBXSAVE(SUB,"CITY")
+11 ; IBXSAVE(SUB,"ST")
+12 ; IBXSAVE(SUB,"ZIP")
+13 ; IBXSAVE(SUB,"PHONE")
+14 ;
+15 ; MRD;IB*2.0*516 - The field used as the switchback flag is being
+16 ; marked for deletion, to be deleted after 3/15/2018. That flag
+17 ; will now always be null. Several sections of this procedure have
+18 ; been commented out because of this. Those sections can be
+19 ; deleted in the future.
+20 ;
+21 NEW IBZ
+22 KILL IBXSAVE(SUB)
+23 IF '$GET(COB)
SET COB=$$COBN^IBCEF(IBIFN)
+24 ;
+25 ;S INSFLGS=$$INSFLGS(IBIFN,COB) ; all ins co flags
+26 ;S SWBFLG=(+INSFLGS>0) ; main switchback flag
+27 ;S (BPTP,MAINPTP)="" ; initialize vars used only in switchback mode
+28 ;I SWBFLG D
+29 ;. S BPTP=$$MAINPRV^IBJPS3 ; main division pay-to provider data string
+30 ;. S MAINPTP=($P(BPTP,U,10)'["IB177") ; flag that says whether main div exists as a pay-to
+31 ;. Q
+32 ;
+33 ; If Switchback is ON and the ins. company parameter Use billing provider VAMC address is not on and
+34 ; main div pay-to exists, then use the pay-to provider data for the main division in the database.
+35 ; This is the "normal" switchback data.
+36 ;I SWBFLG,'$P(INSFLGS,U,3),MAINPTP D G GETBPX ; switchback + billing provider address flag + main ptp exists
+37 ;. ; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
+38 ;. ;S IBXSAVE(SUB,"NAME")=$P(BPTP,U,1)
+39 ;. S IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
+40 ;. S:IBXSAVE(SUB,"NAME")="" IBXSAVE(SUB,"NAME")=$P(BPTP,U,1)
+41 ;. S IBXSAVE(SUB,"ADDR1")=$P(BPTP,U,5)
+42 ;. S IBXSAVE(SUB,"ADDR2")=$P(BPTP,U,6)
+43 ;. S IBXSAVE(SUB,"CITY")=$P(BPTP,U,7)
+44 ;. S IBXSAVE(SUB,"ST")=$P(BPTP,U,8)
+45 ;. S IBXSAVE(SUB,"ZIP")=$P(BPTP,U,9)
+46 ;. S IBXSAVE(SUB,"PHONE")=$P(BPTP,U,4)
+47 ;. Q
+48 ;
+49 ; Special Case: Switchback is ON, the ins. company parameter Use billing provider VAMC address
+50 ; is not on, but the main division is NOT defined as a Pay-To provider.
+51 ; Get the name from the Institution File, but everything else from the claim's Pay-to provider
+52 ;I SWBFLG,'$P(INSFLGS,U,3),'MAINPTP D G GETBPX
+53 ;. ; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
+54 ;. ;S IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
+55 ;. S IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
+56 ;. S:IBXSAVE(SUB,"NAME")="" IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0) ; Inst name
+57 ;. S IBZ=$$PRVDATA^IBJPS3(IBIFN)
+58 ;. S IBXSAVE(SUB,"ADDR1")=$P(IBZ,U,5)
+59 ;. S IBXSAVE(SUB,"ADDR2")=$P(IBZ,U,6)
+60 ;. S IBXSAVE(SUB,"CITY")=$P(IBZ,U,7)
+61 ;. S IBXSAVE(SUB,"ST")=$P(IBZ,U,8)
+62 ;. S IBXSAVE(SUB,"ZIP")=$P(IBZ,U,9)
+63 ;. S IBXSAVE(SUB,"PHONE")=$P(IBZ,U,4)
+64 ;. Q
+65 ;
+66 ; At this point, we want to get the billing provider data from the Institution file
+67 ; IB*2.0*432 - Retrieve the BP name from "gold standard" name field of file #4 and if not populated, retrieve from .01 field - IA#2171
+68 ;S IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
+69 SET IBXSAVE(SUB,"NAME")=$$BNIEN^XUAF4(INST)
+70 if IBXSAVE(SUB,"NAME")=""
SET IBXSAVE(SUB,"NAME")=$$GETFAC^IBCEP8(INST,0,0)
+71 SET IBXSAVE(SUB,"ADDR1")=$$GETFAC^IBCEP8(INST,0,1)
+72 SET IBXSAVE(SUB,"ADDR2")=$$GETFAC^IBCEP8(INST,0,2)
+73 SET IBXSAVE(SUB,"CITY")=$$GETFAC^IBCEP8(INST,0,"3C")
+74 SET IBXSAVE(SUB,"ST")=$$GETFAC^IBCEP8(INST,0,"3S")
+75 SET IBXSAVE(SUB,"ZIP")=$$GETFAC^IBCEP8(INST,0,"3Z")
+76 ; pay-to phone for claim
SET IBXSAVE(SUB,"PHONE")=$$PRVPHONE^IBJPS3(IBIFN)
+77 ;I SWBFLG,MAINPTP S IBXSAVE(SUB,"PHONE")=$P(BPTP,U,4) ; switchback: pay-to phone for main division
+78 ;
+79 ; 3/30/09 - new requirement - for locally printed CMS-1500 claims, use the pay-to provider address information - Box 33
+80 ;I 'SWBFLG,SUB="BOX33" D
+81 IF SUB="BOX33"
Begin DoDot:1
+82 SET IBZ=$$PRVDATA^IBJPS3(IBIFN)
+83 SET IBXSAVE(SUB,"ADDR1")=$PIECE(IBZ,U,5)
+84 SET IBXSAVE(SUB,"ADDR2")=$PIECE(IBZ,U,6)
+85 SET IBXSAVE(SUB,"CITY")=$PIECE(IBZ,U,7)
+86 SET IBXSAVE(SUB,"ST")=$PIECE(IBZ,U,8)
+87 SET IBXSAVE(SUB,"ZIP")=$PIECE(IBZ,U,9)
+88 QUIT
End DoDot:1
+89 ;
GETBPX ;
+1 QUIT
+2 ;
SENDSF(IBIFN,COB) ; Send service facility information for the EDI claim?
+1 ; Function value returns 1 (send service facility information) or 0 (don't send it)
+2 ; The only time this function returns 0 is when the pre-patch 400 switchback flag is set, and
+3 ; care was provided at the main division (VAMC) in the database, and the 36,4.07 ins. co. flag is set to NO.
+4 ; This function is used in the EDI claim (segments SUB, SUB2, NPI-16, and NPI-17).
+5 ; IBIFN required
+6 ; COB optional, defaults to current payer sequence
+7 ;
+8 ; MRD;IB*2.0*516 - The field used as the switchback flag is being
+9 ; marked for deletion, to be deleted after 3/15/2018. That flag
+10 ; will now always be null. This function will now always return
+11 ; '1'.
+12 ;
+13 NEW SEND,IBDIV,MAIN
+14 SET SEND=1
+15 ; current payer sequence default
IF '$GET(COB)
SET COB=$$COBN^IBCEF(IBIFN)
+16 ;S INSFLGS=$$INSFLGS(IBIFN,COB) ; all ins co flags
+17 ;I +INSFLGS'>0 G SENDSFX ; switchback is OFF...get out
+18 GOTO SENDSFX
+19 ;
+20 ; if we have a non-VA facility on the claim, always send it
IF $PIECE($GET(^DGCR(399,IBIFN,"U2")),U,10)
GOTO SENDSFX
+21 ;
+22 ; division on claim
SET IBDIV=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,22)
+23 ; main division in database
SET MAIN=$$MAIN^IBCEP2B()
+24 ; care was not provided at the main division - always send it
IF IBDIV'=MAIN
GOTO SENDSFX
+25 ;
+26 ;I $P(INSFLGS,U,2) G SENDSFX ; ins. co. flag is ON so send it
+27 ;
+28 ; otherwise, do not send service facility data
SET SEND=0
+29 ;
SENDSFX ;
+1 QUIT SEND
+2 ;
SLPROV(IBXIEN,TYPE) ; return array of service line provider data
+1 ; IBXIEN - ien in file 399
+2 ; TYPE: O1 = operating physician, O2 = other operating physician, RE = rendering provider,
+3 ; P = purchase service provider, S = supervising provider, RF = referring provider
+4 ;
+5 ; returns IBXSAVE("SLPRV", counter) = last name ^ first name ^ middle name ^ suffix
+6 ; ^ taxonomy code ^ primary id ^ secondary id (1) ^ secondary id qualifier (1) ^ ...
+7 ; ^ secondary id (n) ^ secondary id qualifier (n)
+8 ; IBXSAVE("SLPRV", counter,"SLC") = service line conter
+9 ;
+10 NEW DATA,IBN,IBX,IENS,MODE,NAME,PRNUM,PRTYPE,OUT,SLC,TMP,IBCNT
+11 IF '+IBXIEN
QUIT
+12 DO ALLIDS^IBCEFP(IBXIEN,.IBX,1)
+13 SET IBCNT=0
+14 ;
+15 SET SLC=""
FOR
SET SLC=$ORDER(IBX("L-PROV",IBXIEN,SLC))
if 'SLC
QUIT
Begin DoDot:1
+16 IF '$DATA(IBX("L-PROV",IBXIEN,SLC,"C",1,TYPE))
QUIT
+17 ; not operating
IF TYPE="O1"
IF PRTYPE'=2
QUIT
+18 ; not other operating
IF TYPE="O2"
IF PRTYPE'=9
QUIT
+19 ; not rendering
IF TYPE="RE"
IF PRTYPE'=3
QUIT
+20 ; not supervising
IF TYPE="S"
IF PRTYPE'=5
QUIT
+21 ; not referring
IF TYPE="RF"
IF PRTYPE'=1
QUIT
+22 ;
+23 SET DATA=$GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE))
+24 ; name components
+25 SET IENS=$PIECE($PIECE(DATA,U),";")_","
+26 IF $PIECE(DATA,U)["VA(200"
SET NAME=$$GET1^DIQ(200,IENS,.01)
+27 IF $PIECE(DATA,U)["IBA(355.93"
SET NAME=$$GET1^DIQ(355.93,IENS,.01)
+28 SET TMP=$PIECE(NAME,",",2)
SET OUT=$PIECE(NAME,",")_U_$PIECE(TMP," ")_U_$PIECE(TMP," ",2)_U_$PIECE(TMP," ",3)
+29 ; taxonomy code
+30 SET $PIECE(OUT,U,5)=$PIECE($$GETTAX^IBCEF73A($PIECE(DATA,U)),U)
+31 SET IBN=""
FOR
SET IBN=$ORDER(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
if IBN=""
QUIT
Begin DoDot:2
+32 SET DATA=$GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
+33 ; primary id
+34 IF IBN=0
SET $PIECE(OUT,U,6)=$PIECE(DATA,U,4)
QUIT
+35 ;
+36 ; secondary ids
+37 SET OUT=OUT_U_$PIECE(DATA,U,4)_U_$PIECE(DATA,U,3)
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 SET IBCNT=IBCNT+1
+41 SET IBXSAVE("SLPRV",IBCNT)=OUT
+42 SET IBXSAVE("SLPRV",IBCNT,"SLC")=SLC
+43 QUIT
