IBCEP2B ;ALB/TMP - EDI UTILITIES for provider ID ;18-MAY-04
;;2.0;INTEGRATED BILLING;**232,320,400,432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
PROVID(IBIFN,IBPRIEN,IBCOBN,DIPA) ; Provider id entry on billing screen 10, and line level provider input on billing screens 4&5.
; IBIFN = ien file 399
; IBPRIEN = ien file 399.0222, or ien file 399.0404.
; IBCOBN = the COB number of the id being edited
; DIPA = passed by ref, returned with id data
; DIPA("EDIT")=-1 if no id editing = 1 if edit id = 2 if stuff id
; DIPA("PRID")= id to stuff DIPA("PRIDT")= id type to stuff
N PRN0,Z
Q:'$G(^DGCR(399,IBIFN,"I1"))
I $G(IBLNPRV),'$G(IBLNPRV("LNPRVIEN")),'$G(IBLNPRV("PROCIEN")) Q ; DEM;432 - If line provider user input.
; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
S PRN0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
S DIPA("EDIT")=1,(DIPA("PRID"),DIPA("PRIDT"))=""
W @IOF
W !,?19,"**** SECONDARY PERFORMING PROVIDER IDs ****"
W !!,$P("PRIMARY^SECONDARY^TERTIARY",U,IBCOBN)_" INSURANCE CO: "_$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_IBCOBN)),0)),U)
; DEM;432 - Added line and conditions if line level provider user input.
I '$G(IBLNPRV) W !,"PROVIDER: "_$$EXTERNAL^DILFD(399.0222,.02,"",$P(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0222,.01,"",+PRN0)_")",!
I $G(IBLNPRV) W !,"Line Level Provider: "_$$EXTERNAL^DILFD(399.0404,.02,"",$P(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0404,.01,"",+PRN0)_")",!
;
I $P(PRN0,U,4+IBCOBN)="" K DIPA("PRID"),DIPA("PRIDT") D NEWID(IBIFN,IBPRIEN,IBCOBN,.DIPA) ; No id currently exists for the ins seq/prov
;
Q
;
NEWID(IBIFN,IBPRIEN,IBCOBN,DIPA) ;
N IBDEF,IBCT,IBNUM,IBINS,IBFRM,IBCAR,IBARR,IBARRS,IB0,IBM,IBQUIT,IBSEL,PRN,PRT,PRN,PRN0,DIR,X,Y,Z,Z0,IBZ,IBZ1,IBTYP,IBREQ,IBREQT,IBTYPN,IBID,IBUSED
S IBREQ=0,IBREQT=""
Q:($G(IBLNPRV))&('$G(IBLNPRV("LNPRVIEN"))&'$G(IBLNPRV("PROCIEN"))) ; DEM;432 - If line provider user input.
; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
S PRN0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
S Z(IBCOBN)=$S($G(DIPA("I"_IBCOBN)):$$GETTYP^IBCEP2A(IBIFN,IBCOBN,$P(PRN0,U)),1:"")
S IBINS=+$G(^DGCR(399,IBIFN,"I"_IBCOBN)),IB0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
S IBCAR=$$INPAT^IBCEF(IBIFN),IBCAR=$S('IBCAR:2,1:1)
;JRA IB*2.0*592 Dental Form 7
;S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=2:2,1:1) ;JRA IB*2.0*592 ';'
S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=2:2,IBFRM=7:7,1:1) ;JWS;JRA IB*2.0*592
I $P(Z(IBCOBN),U) D
. W !,"INS. COMPANY'S DEFAULT SECONDARY ID TYPE IS: "_$$EXTERNAL^DILFD(36,4.01,"",$P(Z(IBCOBN),U)) S IBREQT=+Z(IBCOBN)
. I $P(Z(IBCOBN),U,2) W !,?2," AND IS REQUIRED TO BE ENTERED FOR THIS CLAIM" S IBREQ=1
I $$CUNEED^IBCEP3(IBIFN,IBCOBN) W !,"CARE UNITS ARE DEFINED"_$S($P($G(^DIC(36,IBINS,4)),U,9)'="":" AS "_$P(^(4),U,9),1:"")_" FOR THESE IDs"
D PRACT^IBCEF71(IBINS,IBFRM,IBCAR,$P(IB0,U,2),.IBARR,$P(IB0,U),$S($$COBN^IBCEF(IBIFN)=IBCOBN:"C",1:"O"),355.9,1)
S (IBNUM,IBCT)=0,IBDEF=""
I $O(IBARR(""))="" S IBCT=IBCT+1,DIR("A",IBCT)="NO SECONDARY IDS ARE DEFINED FOR THIS PROV THAT ARE VALID FOR THIS CLAIM"
S IBCT=IBCT+1,DIR("A",IBCT)="SELECT A SECONDARY ID OR ACTION FROM THE LIST BELOW: ",IBCT=IBCT+1,DIR("A",IBCT)=" "
;
S IBCT=IBCT+1,IBNUM=IBNUM+1,DIR("A",IBCT)=" "_$E(IBNUM_$J("",3),1,3)_" - NO SECONDARY ID NEEDED",IBNUM=IBNUM+1,IBCT=IBCT+1,DIR("A",IBCT)=" "_$E(IBNUM_$J("",3),1,3)_" - ADD AN ID FOR THIS CLAIM ONLY"
I $O(IBARR(""))="" S IBDEF=1,DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM) Q
;
S PRN=$$GETID^IBCEP2(IBIFN,2,$P(PRN0,U,2),IBCOBN,.PRT,,$P(PRN0,U)),IBDEF=""
;
I PRN'="",PRT D
. N PRT1
. S PRT1=$P($G(^IBE(355.97,+PRT,0)),U)
. I $P($G(^IBE(355.97,+PRT,1)),U,3) S PRT1="ST LIC("_$P($G(^DIC(5,+$$CAREST^IBCEP2A(IBIFN),0)),U,2)_")"
. S IBCT=IBCT+1,IBNUM=IBNUM+1
. S DIR("A",IBCT)=" "_$E(IBNUM_$J("",3),1,3)_" - "_$E("<DEFAULT> "_PRN_$J("",29),1,29)_" "_$E(PRT1_$J("",15),1,15)
. S DIR("A",IBCT)=DIR("A",IBCT)_" "_$S($P(PRT,U,3)'["355.9":"",$P($G(^IBA(+$P(PRT,U,3),+$P(PRT,U,2),0)),U,3)'="":$$EXTERNAL^DILFD(355.9,.03,"",$P($G(^IBA(+$P(PRT,U,3),+$P(PRT,U,2),0)),U,3)),1:"")
. S IBID(IBNUM)=PRN_U_+PRT,IBDEF=IBNUM,IBID(IBNUM,1)=DIR("A",IBCT),IBDEF=IBNUM,IBDEF("IEN")=$P(PRT,U,2,3)
. S IBUSED(PRT,PRN,0)=""
;
S IBQUIT=0,IBSEL=1
; Sort ids by id type
S IBZ="" F S IBZ=$O(IBARR(IBZ)) Q:IBZ="" S IBZ1="" F S IBZ1=$O(IBARR(IBZ,IBZ1)) Q:IBZ1="" D
. S IBTYP=+$P(IBARR(IBZ,IBZ1),U,9)
. I $P(IBARR(IBZ,IBZ1),U,4)]"" Q:$D(IBUSED(IBTYP,$P(IBARR(IBZ,IBZ1),U,4),+$P(IBARR(IBZ,IBZ1),U,7)))
. I $P($G(IBDEF("IEN")),U,2)["355.9",$P(IBARR(IBZ,IBZ1),U,8),$P(IBARR(IBZ,IBZ1),U,8)=+$G(IBDEF("IEN")) Q:$S($P(IBZ1,U)'["INS DEF":$P($G(IBDEF("IEN")),U,2)=355.9,1:$P($G(IBDEF("IEN")),U,2)=355.91)
. S IBARRS(IBTYP,IBZ,IBZ1)=IBARR(IBZ,IBZ1)
. I $P(IBARR(IBZ,IBZ1),U,4)]"" S IBUSED(IBTYP,$P(IBARR(IBZ,IBZ1),U,4),+$P(IBARR(IBZ,IBZ1),U,7))=""
S IBTYP="" F S IBTYP=$O(IBARRS(IBTYP)) Q:IBTYP="" S IBZ="" F S IBZ=$O(IBARRS(IBTYP,IBZ)) Q:IBZ="" D Q:IBQUIT
. S IBZ1="" F S IBZ1=$O(IBARRS(IBTYP,IBZ,IBZ1)) Q:IBZ1="" S IBCT=IBCT+1,IBNUM=IBNUM+1 D Q:IBQUIT
.. S Z0=IBARRS(IBTYP,IBZ,IBZ1)
.. S IBARR=$S($P(Z0,U,8)&(IBZ1'["LIC"):$G(^IBA("355.9"_$S($P(IBZ1,U)'="INS DEF":"",1:1),+$P(Z0,U,8),0)),1:"")
.. S IBTYPN=$S(IBTYP=+$$STLIC^IBCEP8():"ST LIC ("_$P($G(^DIC(5,+$P(Z0,U,7),0)),U,2)_")",1:$P($G(^IBE(355.97,IBTYP,0)),U))
.. S DIR("A",IBCT)=" "_$E(IBNUM_$J("",3),1,3)_" - "_$E($S($P(IBZ1,U)="INS DEF":"<INS DEF> ",1:"")_$P(Z0,U,4)_$J("",29),1,29)_" "_$E(IBTYPN_$J("",15),1,15)_" "_$S($P(IBARR,U,3):$$EXTERNAL^DILFD(355.9,.03,"",$P(IBARR,U,3)),1:"")
.. S IBID(IBNUM,1)=DIR("A",IBCT),IBID(IBNUM)=$P(Z0,U,4)_U_IBTYP
.. I (IBNUM#15)=0 S IBM=$$MORE(.DIR) D Q:IBQUIT
... I IBM<0 S IBQUIT=1,IBSEL=0 Q ; User aborted list
... I 'IBM S IBQUIT=1 Q ; User wants to select
... W ! K DIR S IBCT=1
I 'IBSEL S DIPA("EDIT")=-1
I IBSEL S:IBDEF=""&$G(IBREQ) IBDEF=2 S DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM)
Q
;
SELID(DIR,IBDEF,IBID,DIPA,IBNUM) ; Returns the selection from the array of possible IDs/ID actions
N IDACT,IDSEL,X,Y
S IDACT=""
S DIR("B")=$S('$G(IBDEF):1,1:IBDEF),DIR("A",+$O(DIR("A",""),-1)+1)=" "
S DIR(0)="NA^1:"_IBNUM,DIR("A")="Selection: " W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y=1) S IDACT=-1 G SELIDQ
I Y=2 S IDACT=1 G SELIDQ
S IDSEL=Y
S DIR("A",1)="ID SELECTED:",DIR("A",2)=" "_$G(IBID(+Y,1)),DIR("A")="IS THIS CORRECT?: ",DIR("B")="YES",DIR(0)="YA" W ! D ^DIR K DIR
I Y'=1 S IDACT=-1 G SELIDQ
S DIPA("PRID")=$P(IBID(IDSEL),U),DIPA("PRIDT")=$P(IBID(IDSEL),U,2),IDACT=2
;
SELIDQ Q IDACT
;
MORE(DIR) ;
N DIR,X,Y,DUOUT,DTOUT
S DIR(0)="YA",DIR("A")="MORE?: ",DIR("B")="NO" W ! D ^DIR K DIR("B")
Q $S($D(DTOUT)!$D(DUOUT):-1,1:Y)
;
; IBFIDFL = E = Electronic Form Type
; A = Additional ID's
; LF - VA Lab/Facility
FACID(IBINS,IBFIDFL) ; Enter/edit billing facility ids
; IBINS = ien of ins co (file 36)
N IBID,Z,Z0,Y
K ^TMP($J,"IBBF_ID")
W @IOF
D GETBPNUM(IBINS)
K ^TMP("IBCE_PRVFAC_MAINT_INS",$J)
S ^TMP("IBCE_PRVFAC_MAINT_INS",$J)=IBFIDFL_U_IBINS_U_"1"
D EN^VALM("IBCE PRVFAC MAINT")
K ^TMP("IBCE_PRVFAC_MAINT_INS",$J)
W @IOF
D FULL^VALM1
Q
;
GETBPNUM(IBINS) ;
N Z,Z0,IBID,IBMAIN
S IBMAIN=$$MAIN(),^TMP($J,"IBBF_ID")=IBMAIN
S IBID=$$BF^IBCU()
S Z=0 F S Z=$O(^IBA(355.92,"B",IBINS,Z)) Q:'Z D
. S Z0=$G(^IBA(355.92,Z,0))
. Q:$P(Z0,U,8)'="E" ; WCJ 1/13/06 There are several ID types in this file
. Q:$P(Z0,U,3)]""
. S ^TMP($J,"IBBF_ID",$S($P(Z0,U,5)=IBMAIN:0,1:+$P(Z0,U,5)),+$P(Z0,U,4))=$P(Z0,U,7)
. S ^TMP($J,"IBBF_ID",$S($P(Z0,U,5)=IBMAIN:0,1:+$P(Z0,U,5)),+$P(Z0,U,4),"QUAL")=$P(Z0,U,6)
Q
;
MAIN() ; Returns ien of main division of the database
Q +$$PRIM^VASITE()
;
FACNUM(IBIFN,IBCOB,IBQF) ; Function returns the current division's fac billing
; prov id for the COB insurance sequence from file 355.92
; IBIFN = ien file 399
; IBCOB = # of COB ins seq or if "", current assumed
; IBQF - 1 if qualifier is to be returned instead of ID
N Z,IBDIV,IBFT,X,BPZ
S X="",IBDIV=0
S:'$G(IBCOB) IBCOB=+$$COBN^IBCEF(IBIFN)
;
; IB*2*400 - esg - 11/7/08 - Determine the division associated with the billing provider first
S BPZ=+$$B^IBCEF79(IBIFN,IBCOB) ; Inst file pointer as the billing provider for payer seq IBCOB
I BPZ S IBDIV=+$O(^DG(40.8,"AD",BPZ,0)) ; Billing Provider division (may not exist)
;
I 'IBDIV S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22) ; Division on claim
I 'IBDIV S IBDIV=$$MAIN() ; main division
;JWS;IB*2.0*592;
S IBFT=$$FT^IBCEF(IBIFN),IBFT=$S(IBFT=3:1,IBFT=7:7,1:2)
K ^TMP($J,"IBBF_ID")
D GETBPNUM(+$P($G(^DGCR(399,IBIFN,"M")),U,IBCOB))
I IBDIV=+$G(^TMP($J,"IBBF_ID")) S IBDIV=0
I '$G(IBQF) S X=$S($D(^TMP($J,"IBBF_ID",IBDIV,IBFT)):^(IBFT),1:$G(^TMP($J,"IBBF_ID",0,IBFT)))
I $G(IBQF) S X=$S($D(^TMP($J,"IBBF_ID",IBDIV,IBFT,"QUAL")):^("QUAL"),1:$G(^TMP($J,"IBBF_ID",0,IBFT,"QUAL")))
K ^TMP($J,"IBBF_ID")
Q X
;
SOP(IBIFN,IBZD) ; Returns X12 current source of pay code for bill ien IBIFN
; IBZD = the current ins policy type, if known
N IBZ,IBFT ;JRA IB*2.0*592 Added 'IBFT'
S IBZ=""
I $G(IBZD)="" D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZD",,IBIFN)
S IBFT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592
;S IBZ=$S($G(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$S($$FT^IBCEF(IBIFN)=2:"1B",1:"1A"),1:"G2") ;JRA IB*2.0*592 ';'
S IBZ=$S($G(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$S((IBFT=2!(IBFT=7)):"1B",1:"1A"),1:"G2") ;JRA IB*2.0*592
Q IBZ
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP2B 10095 printed Oct 16, 2024@18:12:15 Page 2
IBCEP2B ;ALB/TMP - EDI UTILITIES for provider ID ;18-MAY-04
+1 ;;2.0;INTEGRATED BILLING;**232,320,400,432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
PROVID(IBIFN,IBPRIEN,IBCOBN,DIPA) ; Provider id entry on billing screen 10, and line level provider input on billing screens 4&5.
+1 ; IBIFN = ien file 399
+2 ; IBPRIEN = ien file 399.0222, or ien file 399.0404.
+3 ; IBCOBN = the COB number of the id being edited
+4 ; DIPA = passed by ref, returned with id data
+5 ; DIPA("EDIT")=-1 if no id editing = 1 if edit id = 2 if stuff id
+6 ; DIPA("PRID")= id to stuff DIPA("PRIDT")= id type to stuff
+7 NEW PRN0,Z
+8 if '$GET(^DGCR(399,IBIFN,"I1"))
QUIT
+9 ; DEM;432 - If line provider user input.
IF $GET(IBLNPRV)
IF '$GET(IBLNPRV("LNPRVIEN"))
IF '$GET(IBLNPRV("PROCIEN"))
QUIT
+10 ; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
+11 SET PRN0=$SELECT($GET(IBLNPRV):$GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$GET(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
+12 SET DIPA("EDIT")=1
SET (DIPA("PRID"),DIPA("PRIDT"))=""
+13 WRITE @IOF
+14 WRITE !,?19,"**** SECONDARY PERFORMING PROVIDER IDs ****"
+15 WRITE !!,$PIECE("PRIMARY^SECONDARY^TERTIARY",U,IBCOBN)_" INSURANCE CO: "_$PIECE($GET(^DIC(36,+$GET(^DGCR(399,IBIFN,"I"_IBCOBN)),0)),U)
+16 ; DEM;432 - Added line and conditions if line level provider user input.
+17 IF '$GET(IBLNPRV)
WRITE !,"PROVIDER: "_$$EXTERNAL^DILFD(399.0222,.02,"",$PIECE(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0222,.01,"",+PRN0)_")",!
+18 IF $GET(IBLNPRV)
WRITE !,"Line Level Provider: "_$$EXTERNAL^DILFD(399.0404,.02,"",$PIECE(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0404,.01,"",+PRN0)_")",!
+19 ;
+20 ; No id currently exists for the ins seq/prov
IF $PIECE(PRN0,U,4+IBCOBN)=""
KILL DIPA("PRID"),DIPA("PRIDT")
DO NEWID(IBIFN,IBPRIEN,IBCOBN,.DIPA)
+21 ;
+22 QUIT
+23 ;
NEWID(IBIFN,IBPRIEN,IBCOBN,DIPA) ;
+1 NEW IBDEF,IBCT,IBNUM,IBINS,IBFRM,IBCAR,IBARR,IBARRS,IB0,IBM,IBQUIT,IBSEL,PRN,PRT,PRN,PRN0,DIR,X,Y,Z,Z0,IBZ,IBZ1,IBTYP,IBREQ,IBREQT,IBTYPN,IBID,IBUSED
+2 SET IBREQ=0
SET IBREQT=""
+3 ; DEM;432 - If line provider user input.
if ($GET(IBLNPRV))&('$GET(IBLNPRV("LNPRVIEN"))&'$GET(IBLNPRV("PROCIEN")))
QUIT
+4 ; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
+5 SET PRN0=$SELECT($GET(IBLNPRV):$GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$GET(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
+6 SET Z(IBCOBN)=$SELECT($GET(DIPA("I"_IBCOBN)):$$GETTYP^IBCEP2A(IBIFN,IBCOBN,$PIECE(PRN0,U)),1:"")
+7 SET IBINS=+$GET(^DGCR(399,IBIFN,"I"_IBCOBN))
SET IB0=$SELECT($GET(IBLNPRV):$GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$GET(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
+8 SET IBCAR=$$INPAT^IBCEF(IBIFN)
SET IBCAR=$SELECT('IBCAR:2,1:1)
+9 ;JRA IB*2.0*592 Dental Form 7
+10 ;S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=2:2,1:1) ;JRA IB*2.0*592 ';'
+11 ;JWS;JRA IB*2.0*592
SET IBFRM=$$FT^IBCEF(IBIFN)
SET IBFRM=$SELECT(IBFRM=2:2,IBFRM=7:7,1:1)
+12 IF $PIECE(Z(IBCOBN),U)
Begin DoDot:1
+13 WRITE !,"INS. COMPANY'S DEFAULT SECONDARY ID TYPE IS: "_$$EXTERNAL^DILFD(36,4.01,"",$PIECE(Z(IBCOBN),U))
SET IBREQT=+Z(IBCOBN)
+14 IF $PIECE(Z(IBCOBN),U,2)
WRITE !,?2," AND IS REQUIRED TO BE ENTERED FOR THIS CLAIM"
SET IBREQ=1
End DoDot:1
+15 IF $$CUNEED^IBCEP3(IBIFN,IBCOBN)
WRITE !,"CARE UNITS ARE DEFINED"_$SELECT($PIECE($GET(^DIC(36,IBINS,4)),U,9)'="":" AS "_$PIECE(^(4),U,9),1:"")_" FOR THESE IDs"
+16 DO PRACT^IBCEF71(IBINS,IBFRM,IBCAR,$PIECE(IB0,U,2),.IBARR,$PIECE(IB0,U),$SELECT($$COBN^IBCEF(IBIFN)=IBCOBN:"C",1:"O"),355.9,1)
+17 SET (IBNUM,IBCT)=0
SET IBDEF=""
+18 IF $ORDER(IBARR(""))=""
SET IBCT=IBCT+1
SET DIR("A",IBCT)="NO SECONDARY IDS ARE DEFINED FOR THIS PROV THAT ARE VALID FOR THIS CLAIM"
+19 SET IBCT=IBCT+1
SET DIR("A",IBCT)="SELECT A SECONDARY ID OR ACTION FROM THE LIST BELOW: "
SET IBCT=IBCT+1
SET DIR("A",IBCT)=" "
+20 ;
+21 SET IBCT=IBCT+1
SET IBNUM=IBNUM+1
SET DIR("A",IBCT)=" "_$EXTRACT(IBNUM_$JUSTIFY("",3),1,3)_" - NO SECONDARY ID NEEDED"
SET IBNUM=IBNUM+1
SET IBCT=IBCT+1
SET DIR("A",IBCT)=" "_$EXTRACT(IBNUM_$JUSTIFY("",3),1,3)_" - ADD AN ID FOR THIS CLAIM ONLY"
+22 IF $ORDER(IBARR(""))=""
SET IBDEF=1
SET DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM)
QUIT
+23 ;
+24 SET PRN=$$GETID^IBCEP2(IBIFN,2,$PIECE(PRN0,U,2),IBCOBN,.PRT,,$PIECE(PRN0,U))
SET IBDEF=""
+25 ;
+26 IF PRN'=""
IF PRT
Begin DoDot:1
+27 NEW PRT1
+28 SET PRT1=$PIECE($GET(^IBE(355.97,+PRT,0)),U)
+29 IF $PIECE($GET(^IBE(355.97,+PRT,1)),U,3)
SET PRT1="ST LIC("_$PIECE($GET(^DIC(5,+$$CAREST^IBCEP2A(IBIFN),0)),U,2)_")"
+30 SET IBCT=IBCT+1
SET IBNUM=IBNUM+1
+31 SET DIR("A",IBCT)=" "_$EXTRACT(IBNUM_$JUSTIFY("",3),1,3)_" - "_$EXTRACT("<DEFAULT> "_PRN_$JUSTIFY("",29),1,29)_" "_$EXTRACT(PRT1_$JUSTIFY("",15),1,15)
+32 SET DIR("A",IBCT)=DIR("A",IBCT)_" "_$SELECT($PIECE(PRT,U,3)'["355.9":"",$PIECE($GET(^IBA(+$PIECE(PRT,U,3),+$PIECE(PRT,U,2),0)),U,3)'="":$$EXTERNAL^DILFD(355.9,.03,"",$PIECE($GET(^IBA(+$PIECE(PRT,U,3),+$PIECE(PRT,U,2),0)),U,3)),1:""
)
+33 SET IBID(IBNUM)=PRN_U_+PRT
SET IBDEF=IBNUM
SET IBID(IBNUM,1)=DIR("A",IBCT)
SET IBDEF=IBNUM
SET IBDEF("IEN")=$PIECE(PRT,U,2,3)
+34 SET IBUSED(PRT,PRN,0)=""
End DoDot:1
+35 ;
+36 SET IBQUIT=0
SET IBSEL=1
+37 ; Sort ids by id type
+38 SET IBZ=""
FOR
SET IBZ=$ORDER(IBARR(IBZ))
if IBZ=""
QUIT
SET IBZ1=""
FOR
SET IBZ1=$ORDER(IBARR(IBZ,IBZ1))
if IBZ1=""
QUIT
Begin DoDot:1
+39 SET IBTYP=+$PIECE(IBARR(IBZ,IBZ1),U,9)
+40 IF $PIECE(IBARR(IBZ,IBZ1),U,4)]""
if $DATA(IBUSED(IBTYP,$PIECE(IBARR(IBZ,IBZ1),U,4),+$PIECE(IBARR(IBZ,IBZ1),U,7)))
QUIT
+41 IF $PIECE($GET(IBDEF("IEN")),U,2)["355.9"
IF $PIECE(IBARR(IBZ,IBZ1),U,8)
IF $PIECE(IBARR(IBZ,IBZ1),U,8)=+$GET(IBDEF("IEN"))
if $SELECT($PIECE(IBZ1,U)'["INS DEF"
QUIT
+42 SET IBARRS(IBTYP,IBZ,IBZ1)=IBARR(IBZ,IBZ1)
+43 IF $PIECE(IBARR(IBZ,IBZ1),U,4)]""
SET IBUSED(IBTYP,$PIECE(IBARR(IBZ,IBZ1),U,4),+$PIECE(IBARR(IBZ,IBZ1),U,7))=""
End DoDot:1
+44 SET IBTYP=""
FOR
SET IBTYP=$ORDER(IBARRS(IBTYP))
if IBTYP=""
QUIT
SET IBZ=""
FOR
SET IBZ=$ORDER(IBARRS(IBTYP,IBZ))
if IBZ=""
QUIT
Begin DoDot:1
+45 SET IBZ1=""
FOR
SET IBZ1=$ORDER(IBARRS(IBTYP,IBZ,IBZ1))
if IBZ1=""
QUIT
SET IBCT=IBCT+1
SET IBNUM=IBNUM+1
Begin DoDot:2
+46 SET Z0=IBARRS(IBTYP,IBZ,IBZ1)
+47 SET IBARR=$SELECT($PIECE(Z0,U,8)&(IBZ1'["LIC"):$GET(^IBA("355.9"_$SELECT($PIECE(IBZ1,U)'="INS DEF":"",1:1),+$PIECE(Z0,U,8),0)),1:"")
+48 SET IBTYPN=$SELECT(IBTYP=+$$STLIC^IBCEP8():"ST LIC ("_$PIECE($GET(^DIC(5,+$PIECE(Z0,U,7),0)),U,2)_")",1:$PIECE($GET(^IBE(355.97,IBTYP,0)),U))
+49 SET DIR("A",IBCT)=" "_$EXTRACT(IBNUM_$JUSTIFY("",3),1,3)_" - "_$EXTRACT($SELECT(...
... $PIECE(IBZ1,U)="INS DEF":"<INS DEF> ",1:"")_$PIECE(Z0,U,4)_$JUSTIFY("",29),1,29)_" "_$EXTRACT(IBTYPN_$JUSTIFY("",15),1,15)_" "_$SELECT($PIECE(IBARR,U,3):$$EXTERNAL^DILFD(355.9,.03,"",$PIECE(IBARR,U,3)),1:"")
+50 SET IBID(IBNUM,1)=DIR("A",IBCT)
SET IBID(IBNUM)=$PIECE(Z0,U,4)_U_IBTYP
+51 IF (IBNUM#15)=0
SET IBM=$$MORE(.DIR)
Begin DoDot:3
+52 ; User aborted list
IF IBM<0
SET IBQUIT=1
SET IBSEL=0
QUIT
+53 ; User wants to select
IF 'IBM
SET IBQUIT=1
QUIT
+54 WRITE !
KILL DIR
SET IBCT=1
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+55 IF 'IBSEL
SET DIPA("EDIT")=-1
+56 IF IBSEL
if IBDEF=""&$GET(IBREQ)
SET IBDEF=2
SET DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM)
+57 QUIT
+58 ;
SELID(DIR,IBDEF,IBID,DIPA,IBNUM) ; Returns the selection from the array of possible IDs/ID actions
+1 NEW IDACT,IDSEL,X,Y
+2 SET IDACT=""
+3 SET DIR("B")=$SELECT('$GET(IBDEF):1,1:IBDEF)
SET DIR("A",+$ORDER(DIR("A",""),-1)+1)=" "
+4 SET DIR(0)="NA^1:"_IBNUM
SET DIR("A")="Selection: "
WRITE !
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=1)
SET IDACT=-1
GOTO SELIDQ
+6 IF Y=2
SET IDACT=1
GOTO SELIDQ
+7 SET IDSEL=Y
+8 SET DIR("A",1)="ID SELECTED:"
SET DIR("A",2)=" "_$GET(IBID(+Y,1))
SET DIR("A")="IS THIS CORRECT?: "
SET DIR("B")="YES"
SET DIR(0)="YA"
WRITE !
DO ^DIR
KILL DIR
+9 IF Y'=1
SET IDACT=-1
GOTO SELIDQ
+10 SET DIPA("PRID")=$PIECE(IBID(IDSEL),U)
SET DIPA("PRIDT")=$PIECE(IBID(IDSEL),U,2)
SET IDACT=2
+11 ;
SELIDQ QUIT IDACT
+1 ;
MORE(DIR) ;
+1 NEW DIR,X,Y,DUOUT,DTOUT
+2 SET DIR(0)="YA"
SET DIR("A")="MORE?: "
SET DIR("B")="NO"
WRITE !
DO ^DIR
KILL DIR("B")
+3 QUIT $SELECT($DATA(DTOUT)!$DATA(DUOUT):-1,1:Y)
+4 ;
+5 ; IBFIDFL = E = Electronic Form Type
+6 ; A = Additional ID's
+7 ; LF - VA Lab/Facility
FACID(IBINS,IBFIDFL) ; Enter/edit billing facility ids
+1 ; IBINS = ien of ins co (file 36)
+2 NEW IBID,Z,Z0,Y
+3 KILL ^TMP($JOB,"IBBF_ID")
+4 WRITE @IOF
+5 DO GETBPNUM(IBINS)
+6 KILL ^TMP("IBCE_PRVFAC_MAINT_INS",$JOB)
+7 SET ^TMP("IBCE_PRVFAC_MAINT_INS",$JOB)=IBFIDFL_U_IBINS_U_"1"
+8 DO EN^VALM("IBCE PRVFAC MAINT")
+9 KILL ^TMP("IBCE_PRVFAC_MAINT_INS",$JOB)
+10 WRITE @IOF
+11 DO FULL^VALM1
+12 QUIT
+13 ;
GETBPNUM(IBINS) ;
+1 NEW Z,Z0,IBID,IBMAIN
+2 SET IBMAIN=$$MAIN()
SET ^TMP($JOB,"IBBF_ID")=IBMAIN
+3 SET IBID=$$BF^IBCU()
+4 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",IBINS,Z))
if 'Z
QUIT
Begin DoDot:1
+5 SET Z0=$GET(^IBA(355.92,Z,0))
+6 ; WCJ 1/13/06 There are several ID types in this file
if $PIECE(Z0,U,8)'="E"
QUIT
+7 if $PIECE(Z0,U,3)]""
QUIT
+8 SET ^TMP($JOB,"IBBF_ID",$SELECT($PIECE(Z0,U,5)=IBMAIN:0,1:+$PIECE(Z0,U,5)),+$PIECE(Z0,U,4))=$PIECE(Z0,U,7)
+9 SET ^TMP($JOB,"IBBF_ID",$SELECT($PIECE(Z0,U,5)=IBMAIN:0,1:+$PIECE(Z0,U,5)),+$PIECE(Z0,U,4),"QUAL")=$PIECE(Z0,U,6)
End DoDot:1
+10 QUIT
+11 ;
MAIN() ; Returns ien of main division of the database
+1 QUIT +$$PRIM^VASITE()
+2 ;
FACNUM(IBIFN,IBCOB,IBQF) ; Function returns the current division's fac billing
+1 ; prov id for the COB insurance sequence from file 355.92
+2 ; IBIFN = ien file 399
+3 ; IBCOB = # of COB ins seq or if "", current assumed
+4 ; IBQF - 1 if qualifier is to be returned instead of ID
+5 NEW Z,IBDIV,IBFT,X,BPZ
+6 SET X=""
SET IBDIV=0
+7 if '$GET(IBCOB)
SET IBCOB=+$$COBN^IBCEF(IBIFN)
+8 ;
+9 ; IB*2*400 - esg - 11/7/08 - Determine the division associated with the billing provider first
+10 ; Inst file pointer as the billing provider for payer seq IBCOB
SET BPZ=+$$B^IBCEF79(IBIFN,IBCOB)
+11 ; Billing Provider division (may not exist)
IF BPZ
SET IBDIV=+$ORDER(^DG(40.8,"AD",BPZ,0))
+12 ;
+13 ; Division on claim
IF 'IBDIV
SET IBDIV=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,22)
+14 ; main division
IF 'IBDIV
SET IBDIV=$$MAIN()
+15 ;JWS;IB*2.0*592;
+16 SET IBFT=$$FT^IBCEF(IBIFN)
SET IBFT=$SELECT(IBFT=3:1,IBFT=7:7,1:2)
+17 KILL ^TMP($JOB,"IBBF_ID")
+18 DO GETBPNUM(+$PIECE($GET(^DGCR(399,IBIFN,"M")),U,IBCOB))
+19 IF IBDIV=+$GET(^TMP($JOB,"IBBF_ID"))
SET IBDIV=0
+20 IF '$GET(IBQF)
SET X=$SELECT($DATA(^TMP($JOB,"IBBF_ID",IBDIV,IBFT)):^(IBFT),1:$GET(^TMP($JOB,"IBBF_ID",0,IBFT)))
+21 IF $GET(IBQF)
SET X=$SELECT($DATA(^TMP($JOB,"IBBF_ID",IBDIV,IBFT,"QUAL")):^("QUAL"),1:$GET(^TMP($JOB,"IBBF_ID",0,IBFT,"QUAL")))
+22 KILL ^TMP($JOB,"IBBF_ID")
+23 QUIT X
+24 ;
SOP(IBIFN,IBZD) ; Returns X12 current source of pay code for bill ien IBIFN
+1 ; IBZD = the current ins policy type, if known
+2 ;JRA IB*2.0*592 Added 'IBFT'
NEW IBZ,IBFT
+3 SET IBZ=""
+4 IF $GET(IBZD)=""
DO F^IBCEF("N-CURRENT INS POLICY TYPE","IBZD",,IBIFN)
+5 ;JRA IB*2.0*592
SET IBFT=$$FT^IBCEF(IBIFN)
+6 ;S IBZ=$S($G(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$S($$FT^IBCEF(IBIFN)=2:"1B",1:"1A"),1:"G2") ;JRA IB*2.0*592 ';'
+7 ;JRA IB*2.0*592
SET IBZ=$SELECT($GET(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$SELECT((IBFT=2!(IBFT=7)):"1B",1:"1A"),1:"G2")
+8 QUIT IBZ
+9 ;
