IBCEF80 ;ALB/TAZ - Provider ID functions ;13 Feb 2006
;;2.0;INTEGRATED BILLING;**432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
G AWAY
AWAY Q
;
LPRV(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return array of Line Providers
N IBCARE,IBCURR,IBFRMTYP,IBINSCO,IBLIMIT,IBPRTYP,IBXIEN,IBXDATA,IBZ,Z,SLC,CPLNK
;
I '$D(IBSTRIP) S IBSTRIP=0
I '$D(SEG) S SEG=""
S IBXIEN=IBIFN
;JWS;IB*2.0*592;add J430D form #7
S IBFRMTYP=$$FT^IBCEF(IBXIEN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=7:7,IBFRMTYP=3:1,1:0)
I 'IBFRMTYP G LPRVX
I IBFRMTYP=2 D OUTPT^IBCEF11(IBXIEN,0)
I IBFRMTYP=1 D HOS^IBCEF22(IBXIEN)
S IBCURR=$$COB^IBCEF(IBXIEN) ;current bill payer sequence
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
. K IBZ
. D PROVIDER(IBXIEN,CPLNK,"C",.IBZ,IBCURR),PROVIDER(IBXIEN,CPLNK,"O",.IBZ,IBCURR)
. M IBXSAVE("L-PROV",IBXIEN,SLC)=IBZ
D EN^IBCEF81(.IBXSAVE)
S SLC=0 F S SLC=$O(IBXSAVE("L-PROV",IBXIEN,SLC)) Q:'SLC D
. F Z="C","O" I '$O(IBXSAVE("L-PROV",IBXIEN,SLC,Z,"")) K IBXSAVE("L-PROV",IBXIEN,SLC,Z)
;
LPRVX ;Exit Line Provider Setup
Q
;
PROVIDER(IB399,IBCPIEN,IBPROV,IBRES,IBCURR) ;
N IBZ,IBRESARR
S IBRESARR=""
Q:IBPROV="A" ;PATIENT's bill
I IBPROV="C" D
. D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBCPIEN)
I IBPROV="O" D
. I IBCURR="P" D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBCPIEN) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBCPIEN)
. I IBCURR="S" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBCPIEN) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBCPIEN)
. I IBCURR="T" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBCPIEN) D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBCPIEN)
M IBRES(IBPROV)=IBRESARR
Q
;
;-- PROVINF --
;Create array with prov info
;Input:
; IB399 - ien #399
; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
; IBRES - for results (IBRESARR passed by reference)
; 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
;IBCPPTR - Pointer to the Procedure Global
;Output:
; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
; where:(see PROVIDER)
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBCPPTR) ;
I $G(IB399)="" Q
I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
N IBPRTYP,IBINSCO,IBPRVPTR,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBALLSSN,IBSSNIEN,IBLIMIT,IBSSN,I
S IBN=0
S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM) ;Current insurance company ien
S IBCARE=$S($$ISRX^IBCEF1(IB399):3,1:0) ;if an Rx refill bill
S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IB399,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
S IBLIMIT=$S($G(IBINSTP)="C":5,1:3) ; Limits on secondary IDs
S IBCURR=$$COB^IBCEF(IB399) ; current insurance company position (P,S,T)
F IBPRTYP=1:1:9 D
. N Z,IB355OV,IBNPI,IBSSN,IBTAXID
. S IBPRVPTR=$$PROVPTR(IB399,IBPRTYP,IBCPPTR) Q:'+IBPRVPTR
. S $P(IBSSN,U,IBPRTYP)=$$GETSSN^IBCEF72(IBPRVPTR) I '$P(IBSSN,U,IBPRTYP)="" S $P(IBSSN,U,IBPRTYP)=$$TAX3559^IBCEF73(IBPRVPTR)
. N IBRETARR S IBRETARR=0
. ;params: ins co ien, form type, inpt/outpt/rx, prov ptr, return array, provider type, Current/Other
. D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPRVPTR,.IBRETARR,IBPRTYP,$G(IBINSTP))
. S IB355OV="",IBEXC=""
. S Z=$O(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV","B",IBPRTYP,0))
. I Z S Z=$G(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV",Z,0)) D
.. I $P(Z,U,IBPRNUM+4)'="",$P(Z,U,IBPRNUM+11)'="" S IB355OV=$P(Z,U,IBPRNUM+4)_U_$P(Z,U,IBPRNUM+11)
. S IBN=0,IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
. I $G(IBINSTP)="C",$G(IBPRNUM)=1,"34"[$G(IBPRTYP),"P"[$G(IBCURR),$G(IBFRMTYP)=2,$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
. I $G(IBINSTP)="O","34"[$G(IBPRTYP),"ST"[$G(IBCURR),$G(IBFRMTYP)=2,$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12" ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
. I $P(IB355OV,U,2) D
.. ;params: form type, provider type, current/other
.. 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) S:$$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
. D SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT,IBSSN,IBCPPTR)
. S IBRES(IBSORT,IBPRTYP)=IBPRVPTR
. S IBNPI=$$GETNPI^IBCEF73A(IBPRVPTR)
. S IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
. F I=1:1 Q:'$D(IBRES(IBSORT,IBPRTYP,I)) D
.. S $P(IBRES(IBSORT,IBPRTYP,I),U,3,4)=$$STRIP^IBCEF76($P(IBRES(IBSORT,IBPRTYP,I),U,3,4),1,U,IBSTRIP)
I $O(IBRES(IBSORT,"")) S IBRES(IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
Q
;
PROVPTR(IBIEN399,IBFUNC,IBCP) ;
N IBN
S IBN=$O(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
I +IBN=0 Q 0
Q $P($G(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
;
;SORT
; Input
; IBPRNUM - 1 or 2
; IBPRTYP - Provide Type
; IB399 - IEN of Bill/Claim file
; IBSRC - Source Array - IBRETARR passed by reference
; IBDST - Destination Array - IBRES passed by reference
; IBN -
; IBEXC - Override the ID
; IBSEQ -
; IBLIMIT - Limits on secondary ID's
; IBZ - String containing SSN/EIN for the line providers
; IBCPPTR - Pointer to the Procedure Global
SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT,IBZ,IBCPPTR) ;
N IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ1,IBSVP
S (IB1,IB2,IBZ1,IBTRI)=""
;IBZ1=All policy types on Bill
S IBZ1=$$ALLPTYP^IBCEF3(IB399)
F Z=1:1:3 S $P(IBZ1,U,Z)=$S($P(IBZ1,U,Z)="CH":1,1:"") S:$P(IBZ1,U,Z) IBTRI=1
S IBNET=$$NETID^IBCEP() ; netwrk id type
I $G(IBN) D
. S Z=0 F S Z=$O(IBDST(IBPRNUM,IBPRTYP,Z)) Q:'Z S IBID(+$P(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
F S IB1=$O(IBSRC(IB1)) Q:IB1="" D Q:IBN=IBLIMIT
. N OK,IBSTLIC
. S IBSTLIC=""
. F S IB2=$O(IBSRC(IB1,IB2)) Q:IB2="" D Q:IBN=IBLIMIT
. . S IBSVP=$P(IBSRC(IB1,IB2),U)
. . ; If ID overridden, output no others of this type
. . I $G(IBEXC),$P($G(IBSRC(IB1,IB2)),U,9)=IBEXC Q
. . ; Ck state of care/lic match if st lic#
. . I $P($G(IBSRC(IB1,IB2)),U,3)="0B" S OK=1 D Q:'OK
. . . I +$$CAREST^IBCEP2A(IB399)'=$P(IBSRC(IB1,IB2),U,7) S IBSTLIC=1 Q
. . . I $G(IBSTLIC(0))'="" S OK=0 Q
. . . S IBSTLIC(0)=$G(IBSRC(IB1,IB2)),OK=0
. . ; Exclude SSN from sec ids unless required
. . I $P($G(IBSRC(IB1,IB2)),U,3)="SY" Q
. . ; Only 1 of each prov id type
. . Q:$D(IBID(+$P($G(IBSRC(IB1,IB2)),U,9)))
. . S IBN=IBN+1,IBID(+$P($G(IBSRC(IB1,IB2)),U,9))=""
. . S IBDST(IBPRNUM,IBPRTYP,IBN)=$G(IBSRC(IB1,IB2))
. I IBN'=IBLIMIT,'$G(IBSTLIC),$G(IBSTLIC(0))'="" S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006
. Q:$P(IBZ,U,IBPRTYP)=""
. ; here, no network id & TRICARE ins co.
. N Z
. S Z=+$O(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV","B",IBPRTYP,0)),Z=$P($G(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV",Z,0)),U,2)
. S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$P($G(^IBE(355.97,IBNET,0)),U,3)_U_$P(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF80 7967 printed Nov 22, 2024@17:20:27 Page 2
IBCEF80 ;ALB/TAZ - Provider ID functions ;13 Feb 2006
+1 ;;2.0;INTEGRATED BILLING;**432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 GOTO AWAY
AWAY QUIT
+1 ;
LPRV(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return array of Line Providers
+1 NEW IBCARE,IBCURR,IBFRMTYP,IBINSCO,IBLIMIT,IBPRTYP,IBXIEN,IBXDATA,IBZ,Z,SLC,CPLNK
+2 ;
+3 IF '$DATA(IBSTRIP)
SET IBSTRIP=0
+4 IF '$DATA(SEG)
SET SEG=""
+5 SET IBXIEN=IBIFN
+6 ;JWS;IB*2.0*592;add J430D form #7
+7 SET IBFRMTYP=$$FT^IBCEF(IBXIEN)
SET IBFRMTYP=$SELECT(IBFRMTYP=2:2,IBFRMTYP=7:7,IBFRMTYP=3:1,1:0)
+8 IF 'IBFRMTYP
GOTO LPRVX
+9 IF IBFRMTYP=2
DO OUTPT^IBCEF11(IBXIEN,0)
+10 IF IBFRMTYP=1
DO HOS^IBCEF22(IBXIEN)
+11 ;current bill payer sequence
SET IBCURR=$$COB^IBCEF(IBXIEN)
+12 SET SLC=0
+13 FOR
SET SLC=$ORDER(IBXDATA(SLC))
if 'SLC
QUIT
SET IBXSAVE("SLC")=+SLC
Begin DoDot:1
+14 SET CPLNK=$GET(IBXDATA(SLC,"CPLNK"))
IF 'CPLNK
QUIT
+15 KILL IBZ
+16 DO PROVIDER(IBXIEN,CPLNK,"C",.IBZ,IBCURR)
DO PROVIDER(IBXIEN,CPLNK,"O",.IBZ,IBCURR)
+17 MERGE IBXSAVE("L-PROV",IBXIEN,SLC)=IBZ
End DoDot:1
+18 DO EN^IBCEF81(.IBXSAVE)
+19 SET SLC=0
FOR
SET SLC=$ORDER(IBXSAVE("L-PROV",IBXIEN,SLC))
if 'SLC
QUIT
Begin DoDot:1
+20 FOR Z="C","O"
IF '$ORDER(IBXSAVE("L-PROV",IBXIEN,SLC,Z,""))
KILL IBXSAVE("L-PROV",IBXIEN,SLC,Z)
End DoDot:1
+21 ;
LPRVX ;Exit Line Provider Setup
+1 QUIT
+2 ;
PROVIDER(IB399,IBCPIEN,IBPROV,IBRES,IBCURR) ;
+1 NEW IBZ,IBRESARR
+2 SET IBRESARR=""
+3 ;PATIENT's bill
if IBPROV="A"
QUIT
+4 IF IBPROV="C"
Begin DoDot:1
+5 if $$ISINSUR^IBCEF71(IBCURR,IB399)
DO PROVINF(IB399,$SELECT(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBCPIEN)
End DoDot:1
+6 IF IBPROV="O"
Begin DoDot:1
+7 IF IBCURR="P"
if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBCPIEN)
if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBCPIEN)
+8 IF IBCURR="S"
if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBCPIEN)
if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBCPIEN)
+9 IF IBCURR="T"
if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBCPIEN)
if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBCPIEN)
End DoDot:1
+10 MERGE IBRES(IBPROV)=IBRESARR
+11 QUIT
+12 ;
+13 ;-- PROVINF --
+14 ;Create array with prov info
+15 ;Input:
+16 ; IB399 - ien #399
+17 ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
+18 ; IBRES - for results (IBRESARR passed by reference)
+19 ; IBSORT - to sort OTHER INSURANCE data
+20 ; if PROVINF is called for "C" mode of PROVIDER subroutine then
+21 ; IBSORT can be any (say 1)
+22 ; if PROVINF is called for "O" mode then can be more than set of data
+23 ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
+24 ; for mode "O" it should be 1 or 2 (see PROVIDER section)
+25 ;IBINSTP - "C" -current ins, "O"-other
+26 ;IBCPPTR - Pointer to the Procedure Global
+27 ;Output:
+28 ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
+29 ; where:(see PROVIDER)
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBCPPTR) ;
+1 IF $GET(IB399)=""
QUIT
+2 IF +$GET(IBSORT)=0
SET IBSORT=$GET(IBPRNUM)
+3 NEW IBPRTYP,IBINSCO,IBPRVPTR,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBALLSSN,IBSSNIEN,IBLIMIT,IBSSN,I
+4 SET IBN=0
+5 ;Current insurance company ien
SET IBINSCO=+$PIECE($GET(^DGCR(399,IB399,"M")),"^",IBPRNUM)
+6 ;if an Rx refill bill
SET IBCARE=$SELECT($$ISRX^IBCEF1(IB399):3,1:0)
+7 ;1-inp,2-out
if IBCARE=0
SET IBCARE=$$INPAT^IBCEF(IB399,1)
if 'IBCARE
SET IBCARE=2
+8 ; Limits on secondary IDs
SET IBLIMIT=$SELECT($GET(IBINSTP)="C":5,1:3)
+9 ; current insurance company position (P,S,T)
SET IBCURR=$$COB^IBCEF(IB399)
+10 FOR IBPRTYP=1:1:9
Begin DoDot:1
+11 NEW Z,IB355OV,IBNPI,IBSSN,IBTAXID
+12 SET IBPRVPTR=$$PROVPTR(IB399,IBPRTYP,IBCPPTR)
if '+IBPRVPTR
QUIT
+13 SET $PIECE(IBSSN,U,IBPRTYP)=$$GETSSN^IBCEF72(IBPRVPTR)
IF '$PIECE(IBSSN,U,IBPRTYP)=""
SET $PIECE(IBSSN,U,IBPRTYP)=$$TAX3559^IBCEF73(IBPRVPTR)
+14 NEW IBRETARR
SET IBRETARR=0
+15 ;params: ins co ien, form type, inpt/outpt/rx, prov ptr, return array, provider type, Current/Other
+16 DO PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPRVPTR,.IBRETARR,IBPRTYP,$GET(IBINSTP))
+17 SET IB355OV=""
SET IBEXC=""
+18 SET Z=$ORDER(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV","B",IBPRTYP,0))
+19 IF Z
SET Z=$GET(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV",Z,0))
Begin DoDot:2
+20 IF $PIECE(Z,U,IBPRNUM+4)'=""
IF $PIECE(Z,U,IBPRNUM+11)'=""
SET IB355OV=$PIECE(Z,U,IBPRNUM+4)_U_$PIECE(Z,U,IBPRNUM+11)
End DoDot:2
+21 SET IBN=0
SET IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
+22 IF $GET(IBINSTP)="C"
IF $GET(IBPRNUM)=1
IF "34"[$GET(IBPRTYP)
IF "P"[$GET(IBCURR)
IF $GET(IBFRMTYP)=2
IF $$MCRONBIL^IBEFUNC(IB399)
SET IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
+23 ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
IF $GET(IBINSTP)="O"
IF "34"[$GET(IBPRTYP)
IF "ST"[$GET(IBCURR)
IF $GET(IBFRMTYP)=2
IF $$MCRONBIL^IBEFUNC(IB399)
SET IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
+24 IF $PIECE(IB355OV,U,2)
Begin DoDot:2
+25 ;params: form type, provider type, current/other
+26 IF $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE($GET(^IBE(355.97,+$PIECE(IB355OV,U,2),0)),U,3))
Begin DoDot:3
+27 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:3
End DoDot:2
+28 IF IB35591'=""
IF IBEXC'=$PIECE(IB35591,U,3)
if $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE(IB35591,"^"))
SET IBN=IBN+1
SET IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^"
SET $PIECE(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$PIECE(IB35591,U,3)
+29 DO SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT,IBSSN,IBCPPTR)
+30 SET IBRES(IBSORT,IBPRTYP)=IBPRVPTR
+31 SET IBNPI=$$GETNPI^IBCEF73A(IBPRVPTR)
+32 SET IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($SELECT(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
+33 FOR I=1:1
if '$DATA(IBRES(IBSORT,IBPRTYP,I))
QUIT
Begin DoDot:2
+34 SET $PIECE(IBRES(IBSORT,IBPRTYP,I),U,3,4)=$$STRIP^IBCEF76($PIECE(IBRES(IBSORT,IBPRTYP,I),U,3,4),1,U,IBSTRIP)
End DoDot:2
End DoDot:1
+35 IF $ORDER(IBRES(IBSORT,""))
SET IBRES(IBSORT)=$SELECT(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
+36 QUIT
+37 ;
PROVPTR(IBIEN399,IBFUNC,IBCP) ;
+1 NEW IBN
+2 SET IBN=$ORDER(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
+3 IF +IBN=0
QUIT 0
+4 QUIT $PIECE($GET(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
+5 ;
+6 ;SORT
+7 ; Input
+8 ; IBPRNUM - 1 or 2
+9 ; IBPRTYP - Provide Type
+10 ; IB399 - IEN of Bill/Claim file
+11 ; IBSRC - Source Array - IBRETARR passed by reference
+12 ; IBDST - Destination Array - IBRES passed by reference
+13 ; IBN -
+14 ; IBEXC - Override the ID
+15 ; IBSEQ -
+16 ; IBLIMIT - Limits on secondary ID's
+17 ; IBZ - String containing SSN/EIN for the line providers
+18 ; IBCPPTR - Pointer to the Procedure Global
SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT,IBZ,IBCPPTR) ;
+1 NEW IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ1,IBSVP
+2 SET (IB1,IB2,IBZ1,IBTRI)=""
+3 ;IBZ1=All policy types on Bill
+4 SET IBZ1=$$ALLPTYP^IBCEF3(IB399)
+5 FOR Z=1:1:3
SET $PIECE(IBZ1,U,Z)=$SELECT($PIECE(IBZ1,U,Z)="CH":1,1:"")
if $PIECE(IBZ1,U,Z)
SET IBTRI=1
+6 ; netwrk id type
SET IBNET=$$NETID^IBCEP()
+7 IF $GET(IBN)
Begin DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(IBDST(IBPRNUM,IBPRTYP,Z))
if 'Z
QUIT
SET IBID(+$PIECE(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
End DoDot:1
+9 FOR
SET IB1=$ORDER(IBSRC(IB1))
if IB1=""
QUIT
Begin DoDot:1
+10 NEW OK,IBSTLIC
+11 SET IBSTLIC=""
+12 FOR
SET IB2=$ORDER(IBSRC(IB1,IB2))
if IB2=""
QUIT
Begin DoDot:2
+13 SET IBSVP=$PIECE(IBSRC(IB1,IB2),U)
+14 ; If ID overridden, output no others of this type
+15 IF $GET(IBEXC)
IF $PIECE($GET(IBSRC(IB1,IB2)),U,9)=IBEXC
QUIT
+16 ; Ck state of care/lic match if st lic#
+17 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="0B"
SET OK=1
Begin DoDot:3
+18 IF +$$CAREST^IBCEP2A(IB399)'=$PIECE(IBSRC(IB1,IB2),U,7)
SET IBSTLIC=1
QUIT
+19 IF $GET(IBSTLIC(0))'=""
SET OK=0
QUIT
+20 SET IBSTLIC(0)=$GET(IBSRC(IB1,IB2))
SET OK=0
End DoDot:3
if 'OK
QUIT
+21 ; Exclude SSN from sec ids unless required
+22 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="SY"
QUIT
+23 ; Only 1 of each prov id type
+24 if $DATA(IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9)))
QUIT
+25 SET IBN=IBN+1
SET IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9))=""
+26 SET IBDST(IBPRNUM,IBPRTYP,IBN)=$GET(IBSRC(IB1,IB2))
End DoDot:2
if IBN=IBLIMIT
QUIT
+27 IF IBN'=IBLIMIT
IF '$GET(IBSTLIC)
IF $GET(IBSTLIC(0))'=""
SET IBN=IBN+1
SET IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
End DoDot:1
if IBN=IBLIMIT
QUIT
+28 ; WCJ 02/13/2006
IF $$FT^IBCEF(IB399)=2
IF $GET(IBID(IBNET))=""
IF IBTRI
IF $PIECE(IBZ1,U,IBSEQ)
Begin DoDot:1
+29 if $PIECE(IBZ,U,IBPRTYP)=""
QUIT
+30 ; here, no network id & TRICARE ins co.
+31 NEW Z
+32 SET Z=+$ORDER(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV","B",IBPRTYP,0))
SET Z=$PIECE($GET(^DGCR(399,IB399,"CP",IBCPPTR,"LNPRV",Z,0)),U,2)
+33 SET IBN=IBN+1
SET IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$PIECE($GET(^IBE(355.97,IBNET,0)),U,3)_U_$PIECE(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
End DoDot:1
+34 QUIT
