- IBCEP2 ;ALB/TMP - EDI UTILITIES for provider ID ;13-DEC-99
- ;;2.0;INTEGRATED BILLING;**137,181,232,280,320,349,432,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ; DBIA for access to fields 53.2,54.1,54.2 in file 200: 224
- ;
- GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1,IBFUNC) ; Extract IBTYPE id for the bill
- ; IBIFN = bill ien (file 399)
- ; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted)
- ; IBSEQ = numeric COB sequence of the insurance on bill
- ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER;
- ; Returns IBT = ien of the provider id type^ien of entry^file # for id
- ;
- S IBT=0
- Q:IBTYPE'=2 ""
- N IBID,IBPTYP
- S IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT,$G(IBFUNC))
- I IBID="" S IBT=""
- ;
- Q IBID
- ;
- IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT,IBFUNC) ;Loop thru source levels
- ; (if id definition allows) to find correct ID
- ; IBIFN = bill ien (file 399)
- ; IBPTYP = ien of the provider id type in file 355.97 or if null,
- ; the default performing provider ID type for the ins co. in
- ; COB sequence IBSEQ will be calculated
- ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- ; IBSEQ = numeric COB sequence of the bill
- ; IBPERF = 1 if the performing provider id is needed
- ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
- ; Returns IBT = ptr to file 355.97^entry #^file #
- ;
- S IBT=+$G(IBPTYP)
- Q:'$G(IBPERF)!'$G(IBPROV) ""
- N IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z
- I $G(IBSEQ)="" S IBSEQ=+$$COBN^IBCEF(IBIFN) ; Default to current COB seq
- S IBINS=+$P($G(^DGCR(399,IBIFN,"I"_IBSEQ)),U),IBINS4=$G(^DIC(36,+IBINS,4))
- ;JRA IB*2.0*592 Same logic for Dental Form 7 as for CMS-1500
- ;S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592 ';'
- N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592 Added 'FT'
- S IBPROF=(FT=2!(FT=7)) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592
- ; form type is CMS-1500 or J430D (prof)=1, UB-04 (inst)=2
- ;JWS;IB*2.0*592; No Dental default ID
- I $G(IBPTYP)="",FT=7,$G(IBFUNC)=1,IBPROF=1 S (IBT,IBPTYP)=0 Q ""
- I $G(IBPTYP)="",$G(IBFUNC)=1,IBPROF=1 S (IBT,IBPTYP)=+$P(IBINS4,U,4) ; Referring Default ID on CMS-1500
- I $G(IBPTYP)="" S (IBT,IBPTYP)=+$P(IBINS4,U,IBPROF) ; Def to perf prv typ for form
- I 'IBPTYP Q "" ; No default id type
- S IBSPEC=$G(^IBE(355.97,IBPTYP,1)),IBSRC=$P($G(^IBE(355.97,+IBPTYP,0)),U,2),IBSRC=$S('IBSRC:5,1:IBSRC),IBUP=1
- S IBALT=0
- ;
- F D Q:'IBUP!($G(IBID)'="") S IBSRC=IBSRC-1 Q:'IBSRC
- . ;
- . I IBSRC=1,$TR($P(IBSPEC,U,1,3),"^0")'="" D Q ; Indiv prov default
- .. N IBSTATE
- .. I $P(IBSPEC,U,2) D Q ; Federal DEA # from field 53.2 file 200
- ... S IBID=$P($G(^VA(200,+IBPROV,"PS")),U,2) ; DBIA224
- ... S $P(IBT,U,2,3)=(IBPROV_U_200)
- .. S IBSTATE=+$$CAREST^IBCEP2A(IBIFN)
- .. I $P(IBSPEC,U) D Q ; State issued DEA # needed
- ... Q:'IBSTATE
- ... ; Extract the state issuing DEA # from field 54.2 file 200
- ... S Z=+$O(^VA(200,+IBPROV,"PS2","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS2",Z,0)),U,2) ; DBIA224
- ... S $P(IBT,U,2,3)=(+IBPROV_";"_Z_U_200)
- .. I $P(IBSPEC,U,3) D Q ; State license # needed
- ... Q:'IBSTATE
- ... ; Extract the state license # from field 54.1 file 200
- ... I IBPROV["VA(200" S Z=+$O(^VA(200,+IBPROV,"PS1","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS1",Z,0)),U,2),$P(IBT,U,2,3)=(+IBPROV_";"_IBSTATE_U_200) ; DBIA224
- ... I IBPROV["IBA(355.93" S IBID=$P($G(^IBA(355.93,+IBPROV,0)),U,12),$P(IBT,U,2,3)=(+IBPROV_U_355.93)
- . ;
- . I IBSRC=2,$P(IBSPEC,U,4) D Q ; FACILITY FED TAX ID #
- .. N IBXDATA
- .. D F^IBCEF("N-FEDERAL TAX ID",,,IBIFN)
- .. S IBID=IBXDATA,$P(IBT,U,2,3)=(U_350.9)
- . ;
- . I IBSRC=1 S IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV,.IBT) Q
- . ;
- . I IBSRC=2 S IBID=$$SRC2(IBPTYP,.IBT) Q
- . ;
- . I IBSRC=3 S IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT) Q
- . ;
- . I IBSRC=4 S IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,.IBT) Q
- . ;
- . I IBSRC=5 S IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.IBT,$G(IBFUNC)) Q
- . ;
- . I IBSRC=6 S IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,.IBT) Q
- ;
- Q $G(IBID)
- ;
- GETALL(IBTYPE,IBIFN,IBPROV,IBPID) ; Extract all performing prov id's for a
- ; provider (IBPROV - vp format) on bill IBIFN
- ; IBTYPE = type of ID to return (see GETID above)
- ;
- ; Returns array IBPID(COB SEQ #)=id (pass by reference) AND
- ; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97)
- ; IBPID = current insurance co's id
- ;
- N Z,COB,Z1,IBT
- S COB=$$COBN^IBCEF(IBIFN)
- F Z=1:1:3 Q:'$D(^DGCR(399,IBIFN,"I"_Z)) S IBPID(Z)=$$GETID(IBTYPE,IBIFN,IBPROV,Z,.IBT),IBPID(Z,1)=IBT I Z=COB S Z1=IBPID(Z)
- Q $G(Z1)
- ;
- SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't issued # - provider specific
- ; Parameter definitions for SRC1, SRC3, SRC4, SRC5, SRC6:
- ; IBIFN = ien of bill (file 399)
- ; IBINS = ien of insurance co (file 36) or *ALL* for all insurance
- ; (always *ALL* for SRC1)
- ; IBPTYP = ien of the provider id type in file 355.97
- ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- ; IBT = returned as type ien^file ien^file #
- ;
- N IBID,IB,IBRX,IBIDSV
- S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
- I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
- . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB)
- . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
- I IBID="",IBIDSV'="" S IBID=IBIDSV
- Q IBID
- ;
- SRC2(IB35597,IBT) ; Facility default - all providers
- ; IB35597 = ien of the provider id type entry in file 355.97
- ; IBT = returned as type ien^file ien^file #
- ;
- S $P(IBT,U,2,3)=(+IB35597_U_355.97)
- Q $P($G(^IBE(355.97,+IB35597,0)),U,4)
- ;
- SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers
- ; See SRC1 for parameter definitions
- N IB,IBID,IBRX,IBIDSV
- S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
- F S IB=$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*",IB)) Q:'IB D Q:IBID'=""
- . S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT)
- . I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
- I IBID="",IBIDSV'="" S IBID=IBIDSV
- Q IBID
- ;
- SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/individual provider
- ; See SRC1 for parameter definitions
- ;
- N IBID,IB,IBRX,IBIDSV
- S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
- I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
- . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT)
- . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
- I IBID="",IBIDSV'="" S IBID=IBIDSV
- Q IBID
- ;
- SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT,IBFUNC) ; Ins co/all providers/care unit
- ; See SRC1 for missing parameter definitions
- ; IBSEQ = the numeric COB sequence of the insurance on the bill
- ;
- Q "" ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
- N IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX
- S IBID="",Z=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
- ; DEM;432 - IBLNPRV variable is a flag to indicate if user input
- ; is claim level provider or line level provider user input.
- ; DEM;432 - Line provider interested in fuction 1 and 3, referring and rendering respectively.
- I '$G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"PRV","B",$S($G(IBFUNC)=1:1,$$FT^IBCEF(IBIFN)=3:4,1:3),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
- I $G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$S($G(IBFUNC)=1:1,1:3),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
- I IBUNIT'="" F S Z=$O(^IBA(355.96,"AC",IBINS,IBPTYP,Z)) Q:'Z D Q:IBID'=""
- . S IB=0 F S IB=$O(^IBA(355.91,"ACARE",Z,IB)) Q:'IB D Q:IBID'=""
- .. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT)
- .. I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
- I IBID="",IBIDSV'="" S IBID=IBIDSV
- Q IBID
- ;
- SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind provider/care unit
- ; See SRC1 for missing parameter definitions
- ; IBSEQ = the numeric COB sequence of the insurance on the bill
- ;
- Q "" ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
- N IBUNIT,IBP,IBID,IB
- S IBID="",IB=0
- I '$G(IBLNPRV) S IBP=+$O(^DGCR(399,"PRV","B",$S($$FT^IBCEF(IBIFN)=3:3,1:4),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
- I $G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$S($$FT^IBCEF(IBIFN)=3:3,1:4),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
- I $G(IBPROV),IBUNIT'="" F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
- . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB,.IBT)
- Q IBID
- ;
- UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
- ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
- ;
- ; Start in file 355.9 (Specific Provider)
- ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- ;
- Q $$UNIQ1^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBPROV),$G(IBUNIT),$G(IBCU),$G(IBT))
- ;
- UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
- ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
- ;
- ; Start in file 355.91 (Specific Insurance)
- ;
- Q $$UNIQ2^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBUNIT),$G(IBCU),$G(IBT))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP2 9529 printed Jan 18, 2025@03:12:45 Page 2
- IBCEP2 ;ALB/TMP - EDI UTILITIES for provider ID ;13-DEC-99
- +1 ;;2.0;INTEGRATED BILLING;**137,181,232,280,320,349,432,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; DBIA for access to fields 53.2,54.1,54.2 in file 200: 224
- +4 ;
- GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1,IBFUNC) ; Extract IBTYPE id for the bill
- +1 ; IBIFN = bill ien (file 399)
- +2 ; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted)
- +3 ; IBSEQ = numeric COB sequence of the insurance on bill
- +4 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER;
- +5 ; Returns IBT = ien of the provider id type^ien of entry^file # for id
- +6 ;
- +7 SET IBT=0
- +8 if IBTYPE'=2
- QUIT ""
- +9 NEW IBID,IBPTYP
- +10 SET IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT,$GET(IBFUNC))
- +11 IF IBID=""
- SET IBT=""
- +12 ;
- +13 QUIT IBID
- +14 ;
- IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT,IBFUNC) ;Loop thru source levels
- +1 ; (if id definition allows) to find correct ID
- +2 ; IBIFN = bill ien (file 399)
- +3 ; IBPTYP = ien of the provider id type in file 355.97 or if null,
- +4 ; the default performing provider ID type for the ins co. in
- +5 ; COB sequence IBSEQ will be calculated
- +6 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- +7 ; IBSEQ = numeric COB sequence of the bill
- +8 ; IBPERF = 1 if the performing provider id is needed
- +9 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
- +10 ; Returns IBT = ptr to file 355.97^entry #^file #
- +11 ;
- +12 SET IBT=+$GET(IBPTYP)
- +13 if '$GET(IBPERF)!'$GET(IBPROV)
- QUIT ""
- +14 NEW IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z
- +15 ; Default to current COB seq
- IF $GET(IBSEQ)=""
- SET IBSEQ=+$$COBN^IBCEF(IBIFN)
- +16 SET IBINS=+$PIECE($GET(^DGCR(399,IBIFN,"I"_IBSEQ)),U)
- SET IBINS4=$GET(^DIC(36,+IBINS,4))
- +17 ;JRA IB*2.0*592 Same logic for Dental Form 7 as for CMS-1500
- +18 ;S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592 ';'
- +19 ;JRA IB*2.0*592 Added 'FT'
- NEW FT
- SET FT=$$FT^IBCEF(IBIFN)
- +20 ;JRA IB*2.0*592
- SET IBPROF=(FT=2!(FT=7))
- if 'IBPROF
- SET IBPROF=2
- +21 ; form type is CMS-1500 or J430D (prof)=1, UB-04 (inst)=2
- +22 ;JWS;IB*2.0*592; No Dental default ID
- +23 IF $GET(IBPTYP)=""
- IF FT=7
- IF $GET(IBFUNC)=1
- IF IBPROF=1
- SET (IBT,IBPTYP)=0
- QUIT ""
- +24 ; Referring Default ID on CMS-1500
- IF $GET(IBPTYP)=""
- IF $GET(IBFUNC)=1
- IF IBPROF=1
- SET (IBT,IBPTYP)=+$PIECE(IBINS4,U,4)
- +25 ; Def to perf prv typ for form
- IF $GET(IBPTYP)=""
- SET (IBT,IBPTYP)=+$PIECE(IBINS4,U,IBPROF)
- +26 ; No default id type
- IF 'IBPTYP
- QUIT ""
- +27 SET IBSPEC=$GET(^IBE(355.97,IBPTYP,1))
- SET IBSRC=$PIECE($GET(^IBE(355.97,+IBPTYP,0)),U,2)
- SET IBSRC=$SELECT('IBSRC:5,1:IBSRC)
- SET IBUP=1
- +28 SET IBALT=0
- +29 ;
- +30 FOR
- Begin DoDot:1
- +31 ;
- +32 ; Indiv prov default
- IF IBSRC=1
- IF $TRANSLATE($PIECE(IBSPEC,U,1,3),"^0")'=""
- Begin DoDot:2
- +33 NEW IBSTATE
- +34 ; Federal DEA # from field 53.2 file 200
- IF $PIECE(IBSPEC,U,2)
- Begin DoDot:3
- +35 ; DBIA224
- SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS")),U,2)
- +36 SET $PIECE(IBT,U,2,3)=(IBPROV_U_200)
- End DoDot:3
- QUIT
- +37 SET IBSTATE=+$$CAREST^IBCEP2A(IBIFN)
- +38 ; State issued DEA # needed
- IF $PIECE(IBSPEC,U)
- Begin DoDot:3
- +39 if 'IBSTATE
- QUIT
- +40 ; Extract the state issuing DEA # from field 54.2 file 200
- +41 ; DBIA224
- SET Z=+$ORDER(^VA(200,+IBPROV,"PS2","B",IBSTATE,0))
- SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS2",Z,0)),U,2)
- +42 SET $PIECE(IBT,U,2,3)=(+IBPROV_";"_Z_U_200)
- End DoDot:3
- QUIT
- +43 ; State license # needed
- IF $PIECE(IBSPEC,U,3)
- Begin DoDot:3
- +44 if 'IBSTATE
- QUIT
- +45 ; Extract the state license # from field 54.1 file 200
- +46 ; DBIA224
- IF IBPROV["VA(200"
- SET Z=+$ORDER(^VA(200,+IBPROV,"PS1","B",IBSTATE,0))
- SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS1",Z,0)),U,2)
- SET $PIECE(IBT,U,2,3)=(+IBPROV_";"_IBSTATE_U_200)
- +47 IF IBPROV["IBA(355.93"
- SET IBID=$PIECE($GET(^IBA(355.93,+IBPROV,0)),U,12)
- SET $PIECE(IBT,U,2,3)=(+IBPROV_U_355.93)
- End DoDot:3
- QUIT
- End DoDot:2
- QUIT
- +48 ;
- +49 ; FACILITY FED TAX ID #
- IF IBSRC=2
- IF $PIECE(IBSPEC,U,4)
- Begin DoDot:2
- +50 NEW IBXDATA
- +51 DO F^IBCEF("N-FEDERAL TAX ID",,,IBIFN)
- +52 SET IBID=IBXDATA
- SET $PIECE(IBT,U,2,3)=(U_350.9)
- End DoDot:2
- QUIT
- +53 ;
- +54 IF IBSRC=1
- SET IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV,.IBT)
- QUIT
- +55 ;
- +56 IF IBSRC=2
- SET IBID=$$SRC2(IBPTYP,.IBT)
- QUIT
- +57 ;
- +58 IF IBSRC=3
- SET IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT)
- QUIT
- +59 ;
- +60 IF IBSRC=4
- SET IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,.IBT)
- QUIT
- +61 ;
- +62 IF IBSRC=5
- SET IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.IBT,$GET(IBFUNC))
- QUIT
- +63 ;
- +64 IF IBSRC=6
- SET IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,.IBT)
- QUIT
- End DoDot:1
- if 'IBUP!($GET(IBID)'="")
- QUIT
- SET IBSRC=IBSRC-1
- if 'IBSRC
- QUIT
- +65 ;
- +66 QUIT $GET(IBID)
- +67 ;
- GETALL(IBTYPE,IBIFN,IBPROV,IBPID) ; Extract all performing prov id's for a
- +1 ; provider (IBPROV - vp format) on bill IBIFN
- +2 ; IBTYPE = type of ID to return (see GETID above)
- +3 ;
- +4 ; Returns array IBPID(COB SEQ #)=id (pass by reference) AND
- +5 ; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97)
- +6 ; IBPID = current insurance co's id
- +7 ;
- +8 NEW Z,COB,Z1,IBT
- +9 SET COB=$$COBN^IBCEF(IBIFN)
- +10 FOR Z=1:1:3
- if '$DATA(^DGCR(399,IBIFN,"I"_Z))
- QUIT
- SET IBPID(Z)=$$GETID(IBTYPE,IBIFN,IBPROV,Z,.IBT)
- SET IBPID(Z,1)=IBT
- IF Z=COB
- SET Z1=IBPID(Z)
- +11 QUIT $GET(Z1)
- +12 ;
- SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't issued # - provider specific
- +1 ; Parameter definitions for SRC1, SRC3, SRC4, SRC5, SRC6:
- +2 ; IBIFN = ien of bill (file 399)
- +3 ; IBINS = ien of insurance co (file 36) or *ALL* for all insurance
- +4 ; (always *ALL* for SRC1)
- +5 ; IBPTYP = ien of the provider id type in file 355.97
- +6 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- +7 ; IBT = returned as type ien^file ien^file #
- +8 ;
- +9 NEW IBID,IB,IBRX,IBIDSV
- +10 SET IBID=""
- SET IB=0
- SET IBRX=$$ISRX^IBCEF1(IBIFN)
- SET IBIDSV=""
- +11 IF $GET(IBPROV)
- FOR
- SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
- if 'IB
- QUIT
- Begin DoDot:1
- +12 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB)
- +13 ; Save 1st 'match' if no rx specific id
- IF IBRX
- IF $PIECE($GET(^IBA(355.9,IB,0)),U,5)'=3
- if IBIDSV=""
- SET IBIDSV=IBID
- SET IBID=""
- End DoDot:1
- if IBID'=""
- QUIT
- +14 IF IBID=""
- IF IBIDSV'=""
- SET IBID=IBIDSV
- +15 QUIT IBID
- +16 ;
- SRC2(IB35597,IBT) ; Facility default - all providers
- +1 ; IB35597 = ien of the provider id type entry in file 355.97
- +2 ; IBT = returned as type ien^file ien^file #
- +3 ;
- +4 SET $PIECE(IBT,U,2,3)=(+IB35597_U_355.97)
- +5 QUIT $PIECE($GET(^IBE(355.97,+IB35597,0)),U,4)
- +6 ;
- SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers
- +1 ; See SRC1 for parameter definitions
- +2 NEW IB,IBID,IBRX,IBIDSV
- +3 SET IBID=""
- SET IB=0
- SET IBRX=$$ISRX^IBCEF1(IBIFN)
- SET IBIDSV=""
- +4 FOR
- SET IB=$ORDER(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*",IB))
- if 'IB
- QUIT
- Begin DoDot:1
- +5 SET IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT)
- +6 ; Save 1st 'match' if no rx specific id
- IF IBRX
- IF $PIECE($GET(^IBA(355.91,IB,0)),U,5)'=3
- if IBIDSV=""
- SET IBIDSV=IBID
- SET IBID=""
- End DoDot:1
- if IBID'=""
- QUIT
- +7 IF IBID=""
- IF IBIDSV'=""
- SET IBID=IBIDSV
- +8 QUIT IBID
- +9 ;
- SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/individual provider
- +1 ; See SRC1 for parameter definitions
- +2 ;
- +3 NEW IBID,IB,IBRX,IBIDSV
- +4 SET IBID=""
- SET IB=0
- SET IBRX=$$ISRX^IBCEF1(IBIFN)
- SET IBIDSV=""
- +5 IF $GET(IBPROV)
- FOR
- SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
- if 'IB
- QUIT
- Begin DoDot:1
- +6 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT)
- +7 ; Save 1st 'match' if no rx specific id
- IF IBRX
- IF $PIECE($GET(^IBA(355.9,IB,0)),U,5)'=3
- if IBIDSV=""
- SET IBIDSV=IBID
- SET IBID=""
- End DoDot:1
- if IBID'=""
- QUIT
- +8 IF IBID=""
- IF IBIDSV'=""
- SET IBID=IBIDSV
- +9 QUIT IBID
- +10 ;
- SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT,IBFUNC) ; Ins co/all providers/care unit
- +1 ; See SRC1 for missing parameter definitions
- +2 ; IBSEQ = the numeric COB sequence of the insurance on the bill
- +3 ;
- +4 ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
- QUIT ""
- +5 NEW IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX
- +6 SET IBID=""
- SET Z=0
- SET IBRX=$$ISRX^IBCEF1(IBIFN)
- SET IBIDSV=""
- +7 ; DEM;432 - IBLNPRV variable is a flag to indicate if user input
- +8 ; is claim level provider or line level provider user input.
- +9 ; DEM;432 - Line provider interested in fuction 1 and 3, referring and rendering respectively.
- +10 IF '$GET(IBLNPRV)
- SET IBP=+$ORDER(^DGCR(399,IBIFN,"PRV","B",$SELECT($GET(IBFUNC)=1:1,$$FT^IBCEF(IBIFN)=3:4,1:3),0))
- SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
- +11 IF $GET(IBLNPRV)
- SET IBP=+$ORDER(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$SELECT($GET(IBFUNC)=1:1,1:3),0))
- SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
- +12 IF IBUNIT'=""
- FOR
- SET Z=$ORDER(^IBA(355.96,"AC",IBINS,IBPTYP,Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +13 SET IB=0
- FOR
- SET IB=$ORDER(^IBA(355.91,"ACARE",Z,IB))
- if 'IB
- QUIT
- Begin DoDot:2
- +14 SET IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT)
- +15 ; Save 1st 'match' if no rx specific id
- IF IBRX
- IF $PIECE($GET(^IBA(355.91,IB,0)),U,5)'=3
- if IBIDSV=""
- SET IBIDSV=IBID
- SET IBID=""
- End DoDot:2
- if IBID'=""
- QUIT
- End DoDot:1
- if IBID'=""
- QUIT
- +16 IF IBID=""
- IF IBIDSV'=""
- SET IBID=IBIDSV
- +17 QUIT IBID
- +18 ;
- SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind provider/care unit
- +1 ; See SRC1 for missing parameter definitions
- +2 ; IBSEQ = the numeric COB sequence of the insurance on the bill
- +3 ;
- +4 ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
- QUIT ""
- +5 NEW IBUNIT,IBP,IBID,IB
- +6 SET IBID=""
- SET IB=0
- +7 IF '$GET(IBLNPRV)
- SET IBP=+$ORDER(^DGCR(399,"PRV","B",$SELECT($$FT^IBCEF(IBIFN)=3:3,1:4),0))
- SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
- +8 IF $GET(IBLNPRV)
- SET IBP=+$ORDER(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$SELECT($$FT^IBCEF(IBIFN)=3:3,1:4),0))
- SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
- +9 IF $GET(IBPROV)
- IF IBUNIT'=""
- FOR
- SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
- if 'IB
- QUIT
- Begin DoDot:1
- +10 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB,.IBT)
- End DoDot:1
- if IBID'=""
- QUIT
- +11 QUIT IBID
- +12 ;
- UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
- +1 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
- +2 ;
- +3 ; Start in file 355.9 (Specific Provider)
- +4 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
- +5 ;
- +6 QUIT $$UNIQ1^IBCEP2A($GET(IBIFN),$GET(IBINS),$GET(IBPTYP),$GET(IBPROV),$GET(IBUNIT),$GET(IBCU),$GET(IBT))
- +7 ;
- UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
- +1 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
- +2 ;
- +3 ; Start in file 355.91 (Specific Insurance)
- +4 ;
- +5 QUIT $$UNIQ2^IBCEP2A($GET(IBIFN),$GET(IBINS),$GET(IBPTYP),$GET(IBUNIT),$GET(IBCU),$GET(IBT))