IBCEFP ;ALB/TAZ - Provider ID functions ;28-OCT-10
;;2.0;INTEGRATED BILLING;**432,447,473,516,592,623**;21-MAR-94;Build 70
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
I '$D(IBSTRIP) S IBSTRIP=0
I '$D(SEG) S SEG=""
N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB,IBCARE,IBCURR,IBXDATA,NPI,CUROTH
;JWS;IB*2.0*592;US131
S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
S IBCURR=$$COB^IBCEF(IBIFN) ;current bill payer sequence
;don't create anything if form type not CMS-1500 or UB or J430D
I IBFRMTYP,'+$G(IBXSAVE("PROVINF",IBIFN)) D
. N IBZ,CUROTH
. ;JWS;IB*2.0*592;US131
. I IBFRMTYP=2!(IBFRMTYP=7) D OUTPT^IBCEF11(IBIFN,0)
. I IBFRMTYP=1 D HOS^IBCEF22(IBIFN)
. ; START IB*2.0*447 BI
. I IBCURR="A" D Q
.. N IBRESARR
.. S IBLIMIT=5
.. D PROVINF(IBIFN,1,.IBRESARR,1,"C",IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
.. M IBXSAVE=IBRESARR
.. S IBXSAVE("PROVINF",IBIFN)=IBIFN
. ; END IB*2.0*447 BI
. F CUROTH="C","O" D PROVIDER(IBIFN,CUROTH,.IBZ,IBFRMTYP,IBCARE,IBCURR,.IBXDATA) M IBXSAVE=IBZ
. S IBXSAVE("PROVINF",IBIFN)=IBIFN
. Q
;
D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs
S NPI=$P($$ORGNPI^IBCEF73A(IBIFN),U,1)
F CUROTH="C","O" D
. S IBXSAVE("LAB/FAC",IBIFN,CUROTH,1,0)=$S(NPI]"":"XX",1:"")_U_NPI
;
S IBFRMTYP=$$FT^IBCEF(IBIFN)
S ARIEN=$S(IBFRMTYP=2:3,1:4)
S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
F COB=1:1:3 D
. S SORT1=$S(COB=IBCCOB:"C",1:"O")
. S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
. S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
. ;
. D BPIDS^IBCEF75(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
;
D EN^IBCEF81(.IBXSAVE)
;
I SEG="OPR1" D
. I '$D(IBXSAVE("PROVINF",IBIFN,"C",1,3)) D G ALLIDSQ
.. N SLC,CRED S SLC=0
.. F S SLC=$O(IBXSAVE("L-PROV",IBIFN,SLC)) Q:'SLC D I $D(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME")) Q
... S CRED=$P($G(IBXSAVE("L-PROV",IBIFN,SLC,"C",1,3,"NAME")),U,4)
... I CRED]"" S $P(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME"),U,4)=CRED
;
I SEG="LPUR"!(SEG="LPUR1"),$$SUB1OK^IBCEP8A(IBIFN),$G(IBXSAVE("SLC")) D G ALLIDSQ
. N IBCNT,OUT
. ;IB*2.0*473/TAZ - Moved ID lookup into seperate function.
. D PSID(IBIFN,.IBXSAVE,.IDS)
. ;IB*2.0*473/TAZ - END
. ;JWS;IB*2.0*623;$G in the event IDS is not defined.
. S $P(OUT,U,6)=$G(IDS(0))
. S $P(OUT,U,7,8)=$G(IDS(1)) ; secondary id (1) ^ secondary id qualifier(1)
. F IBCNT=1:1:IBXSAVE("SLC") S IBXSAVE("SLPRV",IBCNT)=OUT,IBXSAVE("SLPRV",IBCNT,"SLC")=IBCNT
;
I SEG="LOPE" D SLPRV(IBIFN,.IBXSAVE,2) G ALLIDSQ
I SEG="LOP1" D SLPRV(IBIFN,.IBXSAVE,9) G ALLIDSQ
I SEG="LREN" D SLPRV(IBIFN,.IBXSAVE,3) G ALLIDSQ
I SEG="LSUP" D SLPRV(IBIFN,.IBXSAVE,5) G ALLIDSQ
I SEG="LREF" D SLPRV(IBIFN,.IBXSAVE,1) G ALLIDSQ
;JWS;IB*2.0*592;US131
I SEG="LSUR" D SLPRV(IBIFN,.IBXSAVE,6) G ALLIDSQ
I SEG="LSR1" D SLPRV(IBIFN,.IBXSAVE,6) G ALLIDSQ
;
ALLIDSQ ;
Q
;
PSID(IBIFN,IBXPROV,IBXIDS) ; Build array of either the Fac/Lab ID or Rendering Provider IDs
;IB*2.0*473/TAZ - Created a function to standardize IDs in LDAT and LPUR
; Input:
; IBXIEN - Internal Entry Number of claim
; IBXPROV - Provider Array
; IBXIDS - Array for IDs
; Output:
; IBXIDS(0) - Primary ID
; IBXIDS(1) - Secondary ID
;
N LINE,PLINE,PID,SID,SIDQ
K IBXIDS
; Get Lab/Facility IDs
S (PID,SID,SIDQ)=""
S PID=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,0)),U,2)
F LINE=1:1 Q:'$D(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)) D I SID'="" Q
. S SIDQ=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
. S SID=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U,2)
I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ G PSIDQ
; Get Claim Level Rendering Provider IDs
S PID=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,0)),U,4) ; Get claim level Rendering Provider NPI
F LINE=1:1 Q:'$D(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)) D I SID'="" Q
. S SIDQ=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,3) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
. S SID=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,4)
I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ G PSIDQ
; Get Line Level Rendering Provider IDs
F PLINE=1:1 Q:'$D(IBXPROV("L-PROV",IBIFN,PLINE)) D I $L(PID)!$L(SID) Q
. S PID=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,0)),U,4)
. F LINE=1:1 Q:'$D(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)) D I SID'="" Q
.. S SIDQ=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,3) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
.. S SID=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,4)
I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ
PSIDQ ;
Q
;
SLPRV(IBXIEN,IBX,PRTYPE) ;Build SLPRV nodes for the line provider type record
N SLC,DATA,IBCNT,NAME,OUT
S (SLC,IBCNT)=0
F S SLC=$O(IBX("L-PROV",IBXIEN,SLC)) Q:'SLC D
. I '$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE)) Q
. S NAME=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"NAME"))
. S OUT=$P(NAME,U,1,3)_U_$P(NAME,U,5)_U_$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"TAXONOMY"))_U_$P($G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,0)),U,4)
. F IBN=1:1 Q:'$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN)) D
.. S DATA=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
.. I ",0B,1G,G2,LU,"[(","_$P(DATA,U,3)_",") S OUT=OUT_U_$P(DATA,U,4)_U_$P(DATA,U,3)
. S IBCNT=IBCNT+1
. S IBX("SLPRV",IBCNT)=OUT
. S IBX("SLPRV",IBCNT,"SLC")=SLC
SLPRVQ ;
Q
;
;PROVIDER
;Input:
; IB399 - ien of #399
; IBPROV:
; "C"- to get info for CURRENT provider
; "O"- to get info for all others (in this case the array will contain info fot two providers
; IBRES - array for results (by reference)
; IBFRMTYP - Form Type
; IBCARE - Care Type
; IBCURR - current bill payer sequence
;
;Output:
; IBRES - array to get back info (by reference)
; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
; where:
; IBPROV - see input parameter
; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
; PRTYPE: Provider type(FUNCTION)
; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
; PROV : provider/VARIABLEPTR
; INSUR: Insurance PTR #36 or NONE
; IDTYPE: ID type
; ID: ID
; FORMTYP: Form type 1=UB,2=1500
; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
PROVIDER(IB399,IBPROV,IBRES,IBFRMTYP,IBCARE,IBCURR,IBXDATA) ;
N IBZ,IBRESARR,IBLIMIT
S IBRESARR=""
Q:IBCURR="A" ;PATIENT's bill IB*2.0*447 BI Changes IBPROV to IBCURR
I IBPROV="C" D
. S IBLIMIT=5
. D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
I IBPROV="O" D
. S IBLIMIT=3
. I IBCURR="P" D
.. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
.. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
. I IBCURR="S" D
.. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
.. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
. I IBCURR="T" D
.. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
.. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
M IBRES=IBRESARR
Q
;
;-- PROVINF --
;Create array with prov info
;Input:
; IB399 - ien #399
; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
; IBRES - for results
; IBSORT - to sort OTHER INSURANCE data
; if PROVINF is called for "C" mode of PROVIDER subroutine then
; IBSORT can be any (say 1)
; if PROVINF is called for "O" mode then can be more than set of data
; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
; for mode "O" it should be 1 or 2 (see PROVIDER section)
;IBINSTP - "C" -current ins, "O"-other
;IBFRMTYP - Form Type
;IBCARE - Care Type
;IBLIMIT - Limits on Secondary
;IBCURR - Current Insurance
;IBXDAYA - Revenue Code Array
;Output:
; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
; where:(see PROVIDER)
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,IBXDATA) ;
I $G(IB399)="" G PROVINFQ
I $G(IBINSTP)="" G PROVINFQ
I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
N IBPRTYP,IBINSCO,IBPROV,IB35591,IBN,IBEXC
S IBN=0
S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
S IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
S IBPRTYP=0
F S IBPRTYP=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP)) Q:'IBPRTYP D
. N Z,IB355OV,IBPROV,IBARR
. S IBPROV=$$PROVPTR(IB399,IBPRTYP,0),IBEXC=""
. Q:+IBPROV=0
. S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0))
. D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
. M IBRES("PROVINF",IB399,IBINSTP)=IBARR
I $D(IBRES("PROVINF",IB399,IBINSTP,IBSORT))>1 S IBRES("PROVINF",IB399,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
N SLC,CPLNK
S SLC=0
F S SLC=$O(IBXDATA(SLC)) Q:'SLC S IBXSAVE("SLC")=+SLC D
. S CPLNK=$G(IBXDATA(SLC,"CPLNK")) I 'CPLNK Q
. S IBPRTYP=0
. F S IBPRTYP=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP)) Q:'IBPRTYP D
.. N Z,IBPROV,IBARR
.. S IBPROV=$$PROVPTR(IB399,IBPRTYP,CPLNK),IBEXC=""
.. Q:'+IBPROV
.. S Z=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"CP",CPLNK,"LNPRV",Z,0))
.. D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
.. M IBRES("L-PROV",IB399,SLC,IBINSTP)=IBARR
. I $D(IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT))>1 S IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
;
PROVINFQ ;Exit PROVINF
Q
;
GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,IBRES,IBPRTYP,IBINSTP,IBD) ;
I "CO"'[$G(IBINSTP) G GETPRVQ
N IBRETARR,IBNPI,IBN,IBMRAND,IB355OV S IBRETARR=0,IB355OV=""
D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
I $P(IBD,U,IBPRNUM+4)'="",$P(IBD,U,IBPRNUM+11)'="" S IB355OV=$P(IBD,U,IBPRNUM+4)_U_$P(IBD,U,IBPRNUM+11)
S IBN=0,IBMRAND=$$MCRONBIL^IBEFUNC(IB399)
;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
I "34"[$G(IBPRTYP),$G(IBFRMTYP)=2,IBMRAND S IB355OV=$$MCR24K^IBCEU3(IB399,IBPROV)_"^12"
I $P(IB355OV,U,2) D
. I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
.. S IBEXC=$P(IB355OV,U,2),IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$P($G(^IBE(355.97,+IBEXC,0)),U,3)_U_$P(IB355OV,U)_"^^^^^"_+IBEXC
I IB35591'="",IBEXC'=$P(IB35591,U,3) I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) D
. S IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
S IBNPI=$$NPI^IBCEFP1(IBPROV)
D SORT^IBCEF77(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
S IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
F IBN=1:1 Q:'$D(IBRES(IBSORT,IBPRTYP,IBN)) S $P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4)=$$STRIP^IBCEF76($P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4),1,U,IBSTRIP)
S IBRES(IBSORT,IBPRTYP,"NAME")=$$NAME^IBCEFP1(IBPROV,IBIFN,$P(IBD,U,3),$P(IBD,U,8))
S IBRES(IBSORT,IBPRTYP,"ENTITY TYPE")=$S(IBPROV'["355.93,":1,$P($G(^IBA(355.93,+IBPROV,0)),U,2)=2:1,1:2)
S IBRES(IBSORT,IBPRTYP,"TAXONOMY")=$$TAXON^IBCEFP1(IBPROV,$P(IBD,U,15))
S IBRES(IBSORT,IBPRTYP,"COBID")=$$COBID^IBCEFP1(IB399,IBPRTYP,IBMRAND,IBD)
S IBRES(IBSORT,IBPRTYP)=IBPROV
GETPRVQ ;
Q
;
PROVPTR(IBIEN399,IBFUNC,IBCP) ; Retrieve Provider Pointer from appropriate file
N IBN,RSLT
S IBCP=+$G(IBCP)
I 'IBCP D
. S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
. I +IBN=0 S RSLT=0 Q
. S RSLT=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),U,2)
I IBCP D
. S IBN=$O(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
. I +IBN=0 S RSLT=0 Q
. S RSLT=$P($G(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
Q RSLT
;
;Input:
;IBXIEN - Internal Entry Number for the current bill/claim
;IBXSAVE - Array for returning the data
;
;Output:
;IBXSAVE - Data Array
AMB(IBXIEN,IBXSAVE) ; Gather Ambulance Data for AMB Record(s) - IB*2.0*447/TAZ
N NODE,CODE,CNT,IBXDATA
K IBXSAVE("AMB")
F NODE="U5","U6","U7" S IBXDATA=$G(^DGCR(399,IBXIEN,NODE)) I $TR(IBXDATA,U)'="" S IBXSAVE("AMB",NODE)=IBXDATA
S CODE="",CNT=0
F S CODE=$O(^DGCR(399,IBXIEN,"U9","B",CODE)) Q:'CODE D
. S IBXDATA=$P($G(^IBE(353.5,CODE,0)),U,1) I IBXDATA="" Q
. S CNT=CNT+1,IBXSAVE("AMB","U9",CNT)=IBXDATA
Q
;
SNDS2(IBXDATA,PIECE) ;Determine if a SUB2 record is necessary.
; Input: IBXDATA
; May contain data from field 232 of file 399.
; Output: IBXDATA
; Returns Output for piece 2 or 3 or 1 for any other piece (like 1.5)
;Any time that ONE of the following criteria is met we should send a SUB2 record
; 1. Incoming IBXDATA is not null SEND - Non-VA facility in field 232 of file 399
; 2. If the service facility is a VA Institution in file 4 or a non-VA facility in file 355.93 SEND
; 3. Not a switchback payer $$SENDSF^IBCEF79(IBXIEN)'=0 SEND
;
; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
; function $$SENDSF^IBCEF79 will always return '1'. Refer to
; that function and INSFLGS^^IBCEF79 for more information.
;
I IBXDATA="" D
. N Z
. S Z=$P($$B^IBCEF79(IBXIEN),U,3)
. ;S Z1=$$SENDSF^IBCEF79(IBXIEN)
. ;S IBXDATA=$S(Z="":0,'Z1:0,1:1)
. S IBXDATA=$S(Z="":0,1:1)
. Q
I 'IBXDATA S IBXDATA=""
I IBXDATA'="" S IBXDATA=$S(PIECE=2:77,PIECE=3:2,1:1)
Q IBXDATA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFP 14015 printed Dec 13, 2024@02:10:39 Page 2
IBCEFP ;ALB/TAZ - Provider ID functions ;28-OCT-10
+1 ;;2.0;INTEGRATED BILLING;**432,447,473,516,592,623**;21-MAR-94;Build 70
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
+1 IF '$DATA(IBSTRIP)
SET IBSTRIP=0
+2 IF '$DATA(SEG)
SET SEG=""
+3 NEW IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB,IBCARE,IBCURR,IBXDATA,NPI,CUROTH
+4 ;JWS;IB*2.0*592;US131
+5 SET IBFRMTYP=$$FT^IBCEF(IBIFN)
SET IBFRMTYP=$SELECT(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
+6 ;if an Rx refill bill
SET IBCARE=$SELECT($$ISRX^IBCEF1(IBIFN):3,1:0)
+7 ;1-inp,2-out
if IBCARE=0
SET IBCARE=$$INPAT^IBCEF(IBIFN,1)
if 'IBCARE
SET IBCARE=2
+8 ;current bill payer sequence
SET IBCURR=$$COB^IBCEF(IBIFN)
+9 ;don't create anything if form type not CMS-1500 or UB or J430D
+10 IF IBFRMTYP
IF '+$GET(IBXSAVE("PROVINF",IBIFN))
Begin DoDot:1
+11 NEW IBZ,CUROTH
+12 ;JWS;IB*2.0*592;US131
+13 IF IBFRMTYP=2!(IBFRMTYP=7)
DO OUTPT^IBCEF11(IBIFN,0)
+14 IF IBFRMTYP=1
DO HOS^IBCEF22(IBIFN)
+15 ; START IB*2.0*447 BI
+16 IF IBCURR="A"
Begin DoDot:2
+17 NEW IBRESARR
+18 SET IBLIMIT=5
+19 DO PROVINF(IBIFN,1,.IBRESARR,1,"C",IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
+20 MERGE IBXSAVE=IBRESARR
+21 SET IBXSAVE("PROVINF",IBIFN)=IBIFN
End DoDot:2
QUIT
+22 ; END IB*2.0*447 BI
+23 FOR CUROTH="C","O"
DO PROVIDER(IBIFN,CUROTH,.IBZ,IBFRMTYP,IBCARE,IBCURR,.IBXDATA)
MERGE IBXSAVE=IBZ
+24 SET IBXSAVE("PROVINF",IBIFN)=IBIFN
+25 QUIT
End DoDot:1
+26 ;
+27 ; Get the Lab/Facility IDs
DO LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)
+28 SET NPI=$PIECE($$ORGNPI^IBCEF73A(IBIFN),U,1)
+29 FOR CUROTH="C","O"
Begin DoDot:1
+30 SET IBXSAVE("LAB/FAC",IBIFN,CUROTH,1,0)=$SELECT(NPI]"":"XX",1:"")_U_NPI
End DoDot:1
+31 ;
+32 SET IBFRMTYP=$$FT^IBCEF(IBIFN)
+33 SET ARIEN=$SELECT(IBFRMTYP=2:3,1:4)
+34 ; Current Insurance
SET IBCCOB=$$COBN^IBCEF(IBIFN)
+35 FOR COB=1:1:3
Begin DoDot:1
+36 SET SORT1=$SELECT(COB=IBCCOB:"C",1:"O")
+37 SET SORT2=$SELECT(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
+38 SET ARINFO=$GET(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
+39 ;
+40 DO BPIDS^IBCEF75(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
End DoDot:1
+41 ;
+42 DO EN^IBCEF81(.IBXSAVE)
+43 ;
+44 IF SEG="OPR1"
Begin DoDot:1
+45 IF '$DATA(IBXSAVE("PROVINF",IBIFN,"C",1,3))
Begin DoDot:2
+46 NEW SLC,CRED
SET SLC=0
+47 FOR
SET SLC=$ORDER(IBXSAVE("L-PROV",IBIFN,SLC))
if 'SLC
QUIT
Begin DoDot:3
+48 SET CRED=$PIECE($GET(IBXSAVE("L-PROV",IBIFN,SLC,"C",1,3,"NAME")),U,4)
+49 IF CRED]""
SET $PIECE(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME"),U,4)=CRED
End DoDot:3
IF $DATA(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME"))
QUIT
End DoDot:2
GOTO ALLIDSQ
End DoDot:1
+50 ;
+51 IF SEG="LPUR"!(SEG="LPUR1")
IF $$SUB1OK^IBCEP8A(IBIFN)
IF $GET(IBXSAVE("SLC"))
Begin DoDot:1
+52 NEW IBCNT,OUT
+53 ;IB*2.0*473/TAZ - Moved ID lookup into seperate function.
+54 DO PSID(IBIFN,.IBXSAVE,.IDS)
+55 ;IB*2.0*473/TAZ - END
+56 ;JWS;IB*2.0*623;$G in the event IDS is not defined.
+57 SET $PIECE(OUT,U,6)=$GET(IDS(0))
+58 ; secondary id (1) ^ secondary id qualifier(1)
SET $PIECE(OUT,U,7,8)=$GET(IDS(1))
+59 FOR IBCNT=1:1:IBXSAVE("SLC")
SET IBXSAVE("SLPRV",IBCNT)=OUT
SET IBXSAVE("SLPRV",IBCNT,"SLC")=IBCNT
End DoDot:1
GOTO ALLIDSQ
+60 ;
+61 IF SEG="LOPE"
DO SLPRV(IBIFN,.IBXSAVE,2)
GOTO ALLIDSQ
+62 IF SEG="LOP1"
DO SLPRV(IBIFN,.IBXSAVE,9)
GOTO ALLIDSQ
+63 IF SEG="LREN"
DO SLPRV(IBIFN,.IBXSAVE,3)
GOTO ALLIDSQ
+64 IF SEG="LSUP"
DO SLPRV(IBIFN,.IBXSAVE,5)
GOTO ALLIDSQ
+65 IF SEG="LREF"
DO SLPRV(IBIFN,.IBXSAVE,1)
GOTO ALLIDSQ
+66 ;JWS;IB*2.0*592;US131
+67 IF SEG="LSUR"
DO SLPRV(IBIFN,.IBXSAVE,6)
GOTO ALLIDSQ
+68 IF SEG="LSR1"
DO SLPRV(IBIFN,.IBXSAVE,6)
GOTO ALLIDSQ
+69 ;
ALLIDSQ ;
+1 QUIT
+2 ;
PSID(IBIFN,IBXPROV,IBXIDS) ; Build array of either the Fac/Lab ID or Rendering Provider IDs
+1 ;IB*2.0*473/TAZ - Created a function to standardize IDs in LDAT and LPUR
+2 ; Input:
+3 ; IBXIEN - Internal Entry Number of claim
+4 ; IBXPROV - Provider Array
+5 ; IBXIDS - Array for IDs
+6 ; Output:
+7 ; IBXIDS(0) - Primary ID
+8 ; IBXIDS(1) - Secondary ID
+9 ;
+10 NEW LINE,PLINE,PID,SID,SIDQ
+11 KILL IBXIDS
+12 ; Get Lab/Facility IDs
+13 SET (PID,SID,SIDQ)=""
+14 SET PID=$PIECE($GET(IBXPROV("LAB/FAC",IBIFN,"C",1,0)),U,2)
+15 FOR LINE=1:1
if '$DATA(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE))
QUIT
Begin DoDot:1
+16 SET SIDQ=$PIECE($GET(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U)
IF ",0B,1G,G2,"'[(","_SIDQ_",")
SET SIDQ=""
QUIT
+17 SET SID=$PIECE($GET(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U,2)
End DoDot:1
IF SID'=""
QUIT
+18 IF $LENGTH(PID)!$LENGTH(SID)
SET IBXIDS(0)=PID
SET IBXIDS(1)=SID_U_SIDQ
GOTO PSIDQ
+19 ; Get Claim Level Rendering Provider IDs
+20 ; Get claim level Rendering Provider NPI
SET PID=$PIECE($GET(IBXPROV("PROVINF",IBIFN,"C",1,3,0)),U,4)
+21 FOR LINE=1:1
if '$DATA(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE))
QUIT
Begin DoDot:1
+22 SET SIDQ=$PIECE($GET(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,3)
IF ",0B,1G,G2,"'[(","_SIDQ_",")
SET SIDQ=""
QUIT
+23 SET SID=$PIECE($GET(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,4)
End DoDot:1
IF SID'=""
QUIT
+24 IF $LENGTH(PID)!$LENGTH(SID)
SET IBXIDS(0)=PID
SET IBXIDS(1)=SID_U_SIDQ
GOTO PSIDQ
+25 ; Get Line Level Rendering Provider IDs
+26 FOR PLINE=1:1
if '$DATA(IBXPROV("L-PROV",IBIFN,PLINE))
QUIT
Begin DoDot:1
+27 SET PID=$PIECE($GET(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,0)),U,4)
+28 FOR LINE=1:1
if '$DATA(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE))
QUIT
Begin DoDot:2
+29 SET SIDQ=$PIECE($GET(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,3)
IF ",0B,1G,G2,"'[(","_SIDQ_",")
SET SIDQ=""
QUIT
+30 SET SID=$PIECE($GET(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,4)
End DoDot:2
IF SID'=""
QUIT
End DoDot:1
IF $LENGTH(PID)!$LENGTH(SID)
QUIT
+31 IF $LENGTH(PID)!$LENGTH(SID)
SET IBXIDS(0)=PID
SET IBXIDS(1)=SID_U_SIDQ
PSIDQ ;
+1 QUIT
+2 ;
SLPRV(IBXIEN,IBX,PRTYPE) ;Build SLPRV nodes for the line provider type record
+1 NEW SLC,DATA,IBCNT,NAME,OUT
+2 SET (SLC,IBCNT)=0
+3 FOR
SET SLC=$ORDER(IBX("L-PROV",IBXIEN,SLC))
if 'SLC
QUIT
Begin DoDot:1
+4 IF '$DATA(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE))
QUIT
+5 SET NAME=$GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"NAME"))
+6 SET OUT=$PIECE(NAME,U,1,3)_U_$PIECE(NAME,U,5)_U_$GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"TAXONOMY"))_U_$PIECE($GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,0)),U,4)
+7 FOR IBN=1:1
if '$DATA(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
QUIT
Begin DoDot:2
+8 SET DATA=$GET(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
+9 IF ",0B,1G,G2,LU,"[(","_$PIECE(DATA,U,3)_",")
SET OUT=OUT_U_$PIECE(DATA,U,4)_U_$PIECE(DATA,U,3)
End DoDot:2
+10 SET IBCNT=IBCNT+1
+11 SET IBX("SLPRV",IBCNT)=OUT
+12 SET IBX("SLPRV",IBCNT,"SLC")=SLC
End DoDot:1
SLPRVQ ;
+1 QUIT
+2 ;
+3 ;PROVIDER
+4 ;Input:
+5 ; IB399 - ien of #399
+6 ; IBPROV:
+7 ; "C"- to get info for CURRENT provider
+8 ; "O"- to get info for all others (in this case the array will contain info fot two providers
+9 ; IBRES - array for results (by reference)
+10 ; IBFRMTYP - Form Type
+11 ; IBCARE - Care Type
+12 ; IBCURR - current bill payer sequence
+13 ;
+14 ;Output:
+15 ; IBRES - array to get back info (by reference)
+16 ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
+17 ; where:
+18 ; IBPROV - see input parameter
+19 ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
+20 ; PRTYPE: Provider type(FUNCTION)
+21 ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
+22 ; PROV : provider/VARIABLEPTR
+23 ; INSUR: Insurance PTR #36 or NONE
+24 ; IDTYPE: ID type
+25 ; ID: ID
+26 ; FORMTYP: Form type 1=UB,2=1500
+27 ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
PROVIDER(IB399,IBPROV,IBRES,IBFRMTYP,IBCARE,IBCURR,IBXDATA) ;
+1 NEW IBZ,IBRESARR,IBLIMIT
+2 SET IBRESARR=""
+3 ;PATIENT's bill IB*2.0*447 BI Changes IBPROV to IBCURR
if IBCURR="A"
QUIT
+4 IF IBPROV="C"
Begin DoDot:1
+5 SET IBLIMIT=5
+6 if $$ISINSUR^IBCEF71(IBCURR,IB399)
DO PROVINF(IB399,$SELECT(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
End DoDot:1
+7 IF IBPROV="O"
Begin DoDot:1
+8 SET IBLIMIT=3
+9 IF IBCURR="P"
Begin DoDot:2
+10 if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
+11 if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
End DoDot:2
+12 IF IBCURR="S"
Begin DoDot:2
+13 if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
+14 if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
End DoDot:2
+15 IF IBCURR="T"
Begin DoDot:2
+16 if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
+17 if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
End DoDot:2
End DoDot:1
+18 MERGE IBRES=IBRESARR
+19 QUIT
+20 ;
+21 ;-- PROVINF --
+22 ;Create array with prov info
+23 ;Input:
+24 ; IB399 - ien #399
+25 ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
+26 ; IBRES - for results
+27 ; IBSORT - to sort OTHER INSURANCE data
+28 ; if PROVINF is called for "C" mode of PROVIDER subroutine then
+29 ; IBSORT can be any (say 1)
+30 ; if PROVINF is called for "O" mode then can be more than set of data
+31 ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
+32 ; for mode "O" it should be 1 or 2 (see PROVIDER section)
+33 ;IBINSTP - "C" -current ins, "O"-other
+34 ;IBFRMTYP - Form Type
+35 ;IBCARE - Care Type
+36 ;IBLIMIT - Limits on Secondary
+37 ;IBCURR - Current Insurance
+38 ;IBXDAYA - Revenue Code Array
+39 ;Output:
+40 ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
+41 ; where:(see PROVIDER)
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,IBXDATA) ;
+1 IF $GET(IB399)=""
GOTO PROVINFQ
+2 IF $GET(IBINSTP)=""
GOTO PROVINFQ
+3 IF +$GET(IBSORT)=0
SET IBSORT=$GET(IBPRNUM)
+4 NEW IBPRTYP,IBINSCO,IBPROV,IB35591,IBN,IBEXC
+5 SET IBN=0
+6 SET IBINSCO=+$PIECE($GET(^DGCR(399,IB399,"M")),"^",IBPRNUM)
+7 SET IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
+8 SET IBPRTYP=0
+9 FOR
SET IBPRTYP=$ORDER(^DGCR(399,IB399,"PRV","B",IBPRTYP))
if 'IBPRTYP
QUIT
Begin DoDot:1
+10 NEW Z,IB355OV,IBPROV,IBARR
+11 SET IBPROV=$$PROVPTR(IB399,IBPRTYP,0)
SET IBEXC=""
+12 if +IBPROV=0
QUIT
+13 SET Z=$ORDER(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
IF Z
SET Z=$GET(^DGCR(399,IB399,"PRV",Z,0))
+14 DO GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
+15 MERGE IBRES("PROVINF",IB399,IBINSTP)=IBARR
End DoDot:1
+16 IF $DATA(IBRES("PROVINF",IB399,IBINSTP,IBSORT))>1
SET IBRES("PROVINF",IB399,IBINSTP,IBSORT)=$SELECT(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
+17 NEW SLC,CPLNK
+18 SET SLC=0
+19 FOR
SET SLC=$ORDER(IBXDATA(SLC))
if 'SLC
QUIT
SET IBXSAVE("SLC")=+SLC
Begin DoDot:1
+20 SET CPLNK=$GET(IBXDATA(SLC,"CPLNK"))
IF 'CPLNK
QUIT
+21 SET IBPRTYP=0
+22 FOR
SET IBPRTYP=$ORDER(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP))
if 'IBPRTYP
QUIT
Begin DoDot:2
+23 NEW Z,IBPROV,IBARR
+24 SET IBPROV=$$PROVPTR(IB399,IBPRTYP,CPLNK)
SET IBEXC=""
+25 if '+IBPROV
QUIT
+26 SET Z=$ORDER(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP,0))
IF Z
SET Z=$GET(^DGCR(399,IB399,"CP",CPLNK,"LNPRV",Z,0))
+27 DO GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
+28 MERGE IBRES("L-PROV",IB399,SLC,IBINSTP)=IBARR
End DoDot:2
+29 IF $DATA(IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT))>1
SET IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT)=$SELECT(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
End DoDot:1
+30 ;
PROVINFQ ;Exit PROVINF
+1 QUIT
+2 ;
GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,IBRES,IBPRTYP,IBINSTP,IBD) ;
+1 IF "CO"'[$GET(IBINSTP)
GOTO GETPRVQ
+2 NEW IBRETARR,IBNPI,IBN,IBMRAND,IB355OV
SET IBRETARR=0
SET IB355OV=""
+3 DO PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$GET(IBINSTP))
+4 IF $PIECE(IBD,U,IBPRNUM+4)'=""
IF $PIECE(IBD,U,IBPRNUM+11)'=""
SET IB355OV=$PIECE(IBD,U,IBPRNUM+4)_U_$PIECE(IBD,U,IBPRNUM+11)
+5 SET IBN=0
SET IBMRAND=$$MCRONBIL^IBEFUNC(IB399)
+6 ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
+7 IF "34"[$GET(IBPRTYP)
IF $GET(IBFRMTYP)=2
IF IBMRAND
SET IB355OV=$$MCR24K^IBCEU3(IB399,IBPROV)_"^12"
+8 IF $PIECE(IB355OV,U,2)
Begin DoDot:1
+9 IF $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE($GET(^IBE(355.97,+$PIECE(IB355OV,U,2),0)),U,3))
Begin DoDot:2
+10 SET IBEXC=$PIECE(IB355OV,U,2)
SET IBN=IBN+1
SET IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$PIECE($GET(^IBE(355.97,+IBEXC,0)),U,3)_U_$PIECE(IB355OV,U)_"^^^^^"_+IBEXC
End DoDot:2
End DoDot:1
+11 IF IB35591'=""
IF IBEXC'=$PIECE(IB35591,U,3)
IF $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE(IB35591,"^"))
Begin DoDot:1
+12 SET IBN=IBN+1
SET IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^"
SET $PIECE(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$PIECE(IB35591,U,3)
End DoDot:1
+13 SET IBNPI=$$NPI^IBCEFP1(IBPROV)
+14 DO SORT^IBCEF77(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
+15 SET IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($SELECT(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
+16 FOR IBN=1:1
if '$DATA(IBRES(IBSORT,IBPRTYP,IBN))
QUIT
SET $PIECE(IBRES(IBSORT,IBPRTYP,IBN),U,3,4)=$$STRIP^IBCEF76($PIECE(IBRES(IBSORT,IBPRTYP,IBN),U,3,4),1,U,IBSTRIP)
+17 SET IBRES(IBSORT,IBPRTYP,"NAME")=$$NAME^IBCEFP1(IBPROV,IBIFN,$PIECE(IBD,U,3),$PIECE(IBD,U,8))
+18 SET IBRES(IBSORT,IBPRTYP,"ENTITY TYPE")=$SELECT(IBPROV'["355.93,":1,$PIECE($GET(^IBA(355.93,+IBPROV,0)),U,2)=2:1,1:2)
+19 SET IBRES(IBSORT,IBPRTYP,"TAXONOMY")=$$TAXON^IBCEFP1(IBPROV,$PIECE(IBD,U,15))
+20 SET IBRES(IBSORT,IBPRTYP,"COBID")=$$COBID^IBCEFP1(IB399,IBPRTYP,IBMRAND,IBD)
+21 SET IBRES(IBSORT,IBPRTYP)=IBPROV
GETPRVQ ;
+1 QUIT
+2 ;
PROVPTR(IBIEN399,IBFUNC,IBCP) ; Retrieve Provider Pointer from appropriate file
+1 NEW IBN,RSLT
+2 SET IBCP=+$GET(IBCP)
+3 IF 'IBCP
Begin DoDot:1
+4 SET IBN=$ORDER(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
+5 IF +IBN=0
SET RSLT=0
QUIT
+6 SET RSLT=$PIECE($GET(^DGCR(399,IBIEN399,"PRV",+IBN,0)),U,2)
End DoDot:1
+7 IF IBCP
Begin DoDot:1
+8 SET IBN=$ORDER(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
+9 IF +IBN=0
SET RSLT=0
QUIT
+10 SET RSLT=$PIECE($GET(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
End DoDot:1
+11 QUIT RSLT
+12 ;
+13 ;Input:
+14 ;IBXIEN - Internal Entry Number for the current bill/claim
+15 ;IBXSAVE - Array for returning the data
+16 ;
+17 ;Output:
+18 ;IBXSAVE - Data Array
AMB(IBXIEN,IBXSAVE) ; Gather Ambulance Data for AMB Record(s) - IB*2.0*447/TAZ
+1 NEW NODE,CODE,CNT,IBXDATA
+2 KILL IBXSAVE("AMB")
+3 FOR NODE="U5","U6","U7"
SET IBXDATA=$GET(^DGCR(399,IBXIEN,NODE))
IF $TRANSLATE(IBXDATA,U)'=""
SET IBXSAVE("AMB",NODE)=IBXDATA
+4 SET CODE=""
SET CNT=0
+5 FOR
SET CODE=$ORDER(^DGCR(399,IBXIEN,"U9","B",CODE))
if 'CODE
QUIT
Begin DoDot:1
+6 SET IBXDATA=$PIECE($GET(^IBE(353.5,CODE,0)),U,1)
IF IBXDATA=""
QUIT
+7 SET CNT=CNT+1
SET IBXSAVE("AMB","U9",CNT)=IBXDATA
End DoDot:1
+8 QUIT
+9 ;
SNDS2(IBXDATA,PIECE) ;Determine if a SUB2 record is necessary.
+1 ; Input: IBXDATA
+2 ; May contain data from field 232 of file 399.
+3 ; Output: IBXDATA
+4 ; Returns Output for piece 2 or 3 or 1 for any other piece (like 1.5)
+5 ;Any time that ONE of the following criteria is met we should send a SUB2 record
+6 ; 1. Incoming IBXDATA is not null SEND - Non-VA facility in field 232 of file 399
+7 ; 2. If the service facility is a VA Institution in file 4 or a non-VA facility in file 355.93 SEND
+8 ; 3. Not a switchback payer $$SENDSF^IBCEF79(IBXIEN)'=0 SEND
+9 ;
+10 ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
+11 ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
+12 ; that function and INSFLGS^^IBCEF79 for more information.
+13 ;
+14 IF IBXDATA=""
Begin DoDot:1
+15 NEW Z
+16 SET Z=$PIECE($$B^IBCEF79(IBXIEN),U,3)
+17 ;S Z1=$$SENDSF^IBCEF79(IBXIEN)
+18 ;S IBXDATA=$S(Z="":0,'Z1:0,1:1)
+19 SET IBXDATA=$SELECT(Z="":0,1:1)
+20 QUIT
End DoDot:1
+21 IF 'IBXDATA
SET IBXDATA=""
+22 IF IBXDATA'=""
SET IBXDATA=$SELECT(PIECE=2:77,PIECE=3:2,1:1)
+23 QUIT IBXDATA
