IBCEP7 ;ALB/TMP - Functions for fac level PROVIDER ID MAINT ;11-07-00
;;2.0;INTEGRATED BILLING;**137,232,320,348,349,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
HDR ; -- hdr code
I '$D(^TMP("IBCE_PRVFAC_MAINT",$J)) D INIT
N IBINS,PCF,PCDISP,IBPARAM,IBEFTFL
K VALMHDR
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
S IBINS=+$P(IBPARAM,U,2) ; Insurance co
S PCF=$P($G(^DIC(36,+IBINS,3)),U,13),PCDISP=$S(PCF="P":"(Parent)",1:"")
S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_PCDISP
S VALMHDR(1)=VALMHDR(1)_$S(IBEFTFL="E":" Billing Provider Secondary IDs",IBEFTFL="A":" Additional Billing Provider Sec. IDs",IBEFTFL="LF":" VA-Lab/Facility Secondary IDs",1:"")
I IBEFTFL="LF" S VALMHDR(2)="VA-Lab/Facility Primary ID: Federal Tax ID"
Q
;
INIT ; Initialize
N IBCT,IBD,Z,Z0,Z00,Z1,IBS,IBX,IBDIV,IBEFTFL,IBINS,IBPARAM,IBLCT,IBCU
K ^TMP("IBCE_PRVFAC_MAINT",$J)
S (IBLCT,IBCT)=0
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
S IBINS=+$P(IBPARAM,U,2) ; Insurance co
;
I IBEFTFL="A" D
. K VALM("PROTOCOL")
. S Y=$$FIND1^DIC(101,,,"IBCE PRVFAC ADDIDS MAINT")
. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
;
I IBEFTFL="LF" D
. S VALM("TITLE")="VA-Lab/Facility IDs"
. K VALM("PROTOCOL")
. S Y=$$FIND1^DIC(101,,,"IBCE PRVFAC VALF MAINT")
. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
;
; Compile the appropriate list of IDs
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,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
. Q:'($P(Z0,U,8)=IBEFTFL)
. ;Q:$S($P(IBPARAM,U,3)=1:'$P($G(^IBE(355.97,+$P(Z0,U,6),1)),U,9),1:$P($G(^IBE(355.97,+$P(Z0,U,6),1)),U,9))
. S Z1=$G(^IBE(355.97,+$P(Z0,U,6),0))
. S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z1,U,2)_";"_Z,$P(Z1,U))=+$P(Z0,U,6)_U_$P(Z0,U,7)_U_Z
;
S IBD="" F S IBD=$O(IBS(IBD)) Q:IBD="" D
. D:IBCT SET1(.IBLCT," ",IBCT+1)
. D SET1(.IBLCT,"Division: "_$$DIV(IBD),IBCT+1)
. S IBCU="" F S IBCU=$O(IBS(IBD,IBCU)) Q:IBCU="" D
.. I IBCU D SET1(.IBLCT," Care Unit: "_$$EXTERNAL^DILFD(355.92,.03,"",IBCU),IBCT+1)
.. S Z="" F S Z=$O(IBS(IBD,IBCU,Z),-1) Q:Z="" D
... S Z0="" F S Z0=$O(IBS(IBD,IBCU,Z,Z0)) Q:Z0="" S IBX=IBS(IBD,IBCU,Z,Z0) D
.... S IBCT=IBCT+1
.... I $P(Z,";",2) D Q
..... S Z00=$G(^IBA(355.92,+$P(Z,";",2),0))
..... S Z1=$E(IBCT_$J("",3),1,3)_" "_$E(Z0_$J("",25),1,25)_" "_$E($S($P(IBX,U,2)'="":$P(IBX,U,2),1:$$IDNUM^IBCEP7A(+IBX))_$J("",15),1,15)_" "_$P("BOTH^UB04^1500^RX",U,$P(Z00,U,4)+1)
..... D SET1(.IBLCT,Z1,IBCT)
..... S ^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",IBCT)=+$P(Z,";",2)
;
I 'IBLCT D
. D SET1(1," ")
. N TEXT
. I IBEFTFL="E" S TEXT="No Billing Provider Secondary IDs found"
. I IBEFTFL="A" S TEXT="No Billing Provider Additional IDs found"
. I IBEFTFL="LF" S TEXT="No VA Lab/Facility IDs found"
. D SET1(2,TEXT)
. S IBLCT=2
S VALMBG=1,VALMCNT=IBLCT
Q
;
SET1(IBLCT,TEXT,IBCT) ;
S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
Q
;
DIV(IBD) ; Returns 'ALL/DEFAULT' or div NAME whose ien=IBD
N MAIN
I IBD Q $$EXTERNAL^DILFD(355.92,.05,"",IBD)
S MAIN=$$MAIN^IBCEP2B()
S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
S MAIN=MAIN_"/Default for All Divisions"
Q MAIN
;
EDIT1 ;
N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL
D FULL^VALM1
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
S IBINS=+$P(IBPARAM,U,2) ; Insurance co
S IBFUNC="E"
D SEL
I $G(IBDA) S Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL) I Z D INIT
;
EDIT1Q S VALMBCK="R"
Q
EXPND ;
Q
HELP ;
Q
EXIT ;
N IBPARAM,IBEFTFL
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
I IBEFTFL="A" D COPYPROV^IBCEP5A(0)
;
S (IBLCT,IBCT)=0
K ^TMP("IBCE_PRVFAC_MAINT",$J),^TMP("IBCE_PRVFAC_MAINT_INS",$J)
D CLEAN^VALM10
Q
SEL ;
N Z
K IBDA
D FULL^VALM1,EN^VALM2($G(XQORNOD(0)),"OS")
S Z=+$O(VALMY(0)) Q:'Z
; fac/ins co default
S IBDA=$G(^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",Z))
Q
;
EDITFAC(IBDA,IBFUNC,IBEFTFL) ; edits ins co facility id (355.92), entry IBDA
N IBRBLD,Z,Z0,DIK,DIE,DP,DA,DR,DIR,X,Y,IBDA0,IBDIV,IBITYP,IBFORM,IBCAREUN,NEXTONE
S IBRBLD=0 S:$G(IBDA) IBDA0=$G(^IBA(355.92,+IBDA,0))
; "E"diting 355.92 entry
I IBFUNC="E" D
. S Z0=$TR(IBDA0,U)
. Q:'$$FACFLDS^IBCEP7C(IBDA,IBINS,.IBITYP,.IBFORM,.IBDIV,"E",.IBCAREUN,IBEFTFL)
. S DIE="^IBA(355.92,",DA=IBDA
. S DR=".03////"_$S($G(IBCAREUN)]""&($G(IBCAREUN)'="*N/A*"):IBCAREUN,1:"")_";.04////"_IBFORM_$S(IBDIV:";.05////"_IBDIV,1:"")_";.06////"_IBITYP_";"
. S DR=DR_".07"_$S(IBEFTFL="E"!(IBEFTFL="A"):"Billing Provider Secondary ID",1:"VA Lab or Facility Secondary ID")
. I IBEFTFL="A" D
.. S NEXTONE=$$NEXTONE()
.. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"MOD"_U_355.92
.. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,"OLD0")=^IBA(355.92,IBDA,0)
. D ^DIE
. I IBEFTFL="A" S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=^IBA(355.92,IBDA,0)
. I $TR($G(^IBA(355.92,IBDA,0)),U)'=Z0 S IBRBLD=1
;
; "D"eleting 355.92 entry
I IBFUNC="D" D
. W !!," Insurance Co: ",$P($G(^DIC(36,+IBDA0,0)),U)
. W !," Division: ",$$DIV($P(IBDA0,U,5))
. W:$P(IBDA0,U,3)]"" !," Care Unit: ",$$EXTERNAL^DILFD(355.92,.03,"",$P(IBDA0,U,3))
. W !," ID Qualifier: ",$$EXTERNAL^DILFD(355.92,.06,"",$P(IBDA0,U,6))
. W !," Form Type: ",$$EXTERNAL^DILFD(355.92,.04,"",$P(IBDA0,U,4))
. W !," ID: ",$P(IBDA0,U,7),!
. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS ID RECORD?: ",DIR("B")="NO" D ^DIR K DIR
. S DIR("A")="NOTHING DELETED - PRESS RETURN TO CONTINUE: "
. I Y=1 D
.. S DIK="^IBA(355.92,",DA=IBDA
.. D ^DIK
.. I IBEFTFL="A" D
... N NEXTONE
... S NEXTONE=$$NEXTONE()
... S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"DEL"_U_355.92
... S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=IBDA0
.. S DIR("A")="ID DELETED - PRESS RETURN TO CONTINUE: ",IBRBLD=1
.. S DIR(0)="EA" W ! D ^DIR K DIR
;
Q IBRBLD
;
FACID(Y) ;
N Z,Z1,Z2
S Z=U_$P($G(^IBE(355.97,+Y,0)),U,3)_U,Z1=$$SUB2^IBCEF73(1),Z2=$$SUB2^IBCEF73(2)
I Z1[Z!(Z2[Z) Q 1
Q 0
;
ADD1 ;
N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL,IBINS
D FULL^VALM1
;
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
S IBINS=+$P(IBPARAM,U,2) ; Insurance co ;
;
S Z=$$ADDFAC^IBCEP7A(IBINS,IBEFTFL) I Z D INIT
;
ADD1Q S VALMBCK="R"
Q
;
DEL1 ;
N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTDL,IBINS
D FULL^VALM1
;
S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
S IBEFTFL=$P(IBPARAM,U) ; Electronic Form type flag
S IBINS=+$P(IBPARAM,U,2) ; Insurance co
;
S IBFUNC="D"
D SEL
I $G(IBDA) S Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL) I Z D INIT
;
DEL1Q S VALMBCK="R"
Q
;
; Get the next number so that the edits can be replicated in order for other providers/insurance companies
NEXTONE() ;
Q $O(^TMP("IB_EDITED_IDS",$J,""),-1)+1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP7 7139 printed Oct 16, 2024@18:12:24 Page 2
IBCEP7 ;ALB/TMP - Functions for fac level PROVIDER ID MAINT ;11-07-00
+1 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
HDR ; -- hdr code
+1 IF '$DATA(^TMP("IBCE_PRVFAC_MAINT",$JOB))
DO INIT
+2 NEW IBINS,PCF,PCDISP,IBPARAM,IBEFTFL
+3 KILL VALMHDR
+4 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+5 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+6 ; Insurance co
SET IBINS=+$PIECE(IBPARAM,U,2)
+7 SET PCF=$PIECE($GET(^DIC(36,+IBINS,3)),U,13)
SET PCDISP=$SELECT(PCF="P":"(Parent)",1:"")
+8 SET VALMHDR(1)="Insurance Co: "_$PIECE($GET(^DIC(36,+IBINS,0)),U)_PCDISP
+9 SET VALMHDR(1)=VALMHDR(1)_$SELECT(IBEFTFL="E":" Billing Provider Secondary IDs",IBEFTFL="A":" Additional Billing Provider Sec. IDs",IBEFTFL="LF":" VA-Lab/Facility Secondary IDs",1:"")
+10 IF IBEFTFL="LF"
SET VALMHDR(2)="VA-Lab/Facility Primary ID: Federal Tax ID"
+11 QUIT
+12 ;
INIT ; Initialize
+1 NEW IBCT,IBD,Z,Z0,Z00,Z1,IBS,IBX,IBDIV,IBEFTFL,IBINS,IBPARAM,IBLCT,IBCU
+2 KILL ^TMP("IBCE_PRVFAC_MAINT",$JOB)
+3 SET (IBLCT,IBCT)=0
+4 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+5 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+6 ; Insurance co
SET IBINS=+$PIECE(IBPARAM,U,2)
+7 ;
+8 IF IBEFTFL="A"
Begin DoDot:1
+9 KILL VALM("PROTOCOL")
+10 SET Y=$$FIND1^DIC(101,,,"IBCE PRVFAC ADDIDS MAINT")
+11 IF Y
SET VALM("PROTOCOL")=+Y_";ORD(101,"
End DoDot:1
+12 ;
+13 IF IBEFTFL="LF"
Begin DoDot:1
+14 SET VALM("TITLE")="VA-Lab/Facility IDs"
+15 KILL VALM("PROTOCOL")
+16 SET Y=$$FIND1^DIC(101,,,"IBCE PRVFAC VALF MAINT")
+17 IF Y
SET VALM("PROTOCOL")=+Y_";ORD(101,"
End DoDot:1
+18 ;
+19 ; Compile the appropriate list of IDs
+20 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",IBINS,Z))
if 'Z
QUIT
Begin DoDot:1
+21 SET Z0=$GET(^IBA(355.92,Z,0))
+22 ; Quit if no provider id or id type
if '$PIECE(Z0,U,6)!($PIECE(Z0,U,7)="")
QUIT
+23 if '($PIECE(Z0,U,8)=IBEFTFL)
QUIT
+24 ;Q:$S($P(IBPARAM,U,3)=1:'$P($G(^IBE(355.97,+$P(Z0,U,6),1)),U,9),1:$P($G(^IBE(355.97,+$P(Z0,U,6),1)),U,9))
+25 SET Z1=$GET(^IBE(355.97,+$PIECE(Z0,U,6),0))
+26 SET IBS(+$PIECE(Z0,U,5),+$PIECE(Z0,U,3),+$PIECE(Z1,U,2)_";"_Z,$PIECE(Z1,U))=+$PIECE(Z0,U,6)_U_$PIECE(Z0,U,7)_U_Z
End DoDot:1
+27 ;
+28 SET IBD=""
FOR
SET IBD=$ORDER(IBS(IBD))
if IBD=""
QUIT
Begin DoDot:1
+29 if IBCT
DO SET1(.IBLCT," ",IBCT+1)
+30 DO SET1(.IBLCT,"Division: "_$$DIV(IBD),IBCT+1)
+31 SET IBCU=""
FOR
SET IBCU=$ORDER(IBS(IBD,IBCU))
if IBCU=""
QUIT
Begin DoDot:2
+32 IF IBCU
DO SET1(.IBLCT," Care Unit: "_$$EXTERNAL^DILFD(355.92,.03,"",IBCU),IBCT+1)
+33 SET Z=""
FOR
SET Z=$ORDER(IBS(IBD,IBCU,Z),-1)
if Z=""
QUIT
Begin DoDot:3
+34 SET Z0=""
FOR
SET Z0=$ORDER(IBS(IBD,IBCU,Z,Z0))
if Z0=""
QUIT
SET IBX=IBS(IBD,IBCU,Z,Z0)
Begin DoDot:4
+35 SET IBCT=IBCT+1
+36 IF $PIECE(Z,";",2)
Begin DoDot:5
+37 SET Z00=$GET(^IBA(355.92,+$PIECE(Z,";",2),0))
+38 SET Z1=$EXTRACT(IBCT_$JUSTIFY("",3),1,3)_" "_$EXTRACT(Z0_$JUSTIFY("",25),1,25)_" "_$EXTRACT($SELECT($PIECE(IBX,U,2)'="":$PIECE(IBX,U,2),1:$$IDNUM^IBCEP7A(+IBX))_$JUSTIFY("",15),1,15)_" "_$PIECE("BOTH^
UB04^1500^RX",U,$PIECE(Z00,U,4)+1)
+39 DO SET1(.IBLCT,Z1,IBCT)
+40 SET ^TMP("IBCE_PRVFAC_MAINT",$JOB,"ZIDX",IBCT)=+$PIECE(Z,";",2)
End DoDot:5
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 IF 'IBLCT
Begin DoDot:1
+43 DO SET1(1," ")
+44 NEW TEXT
+45 IF IBEFTFL="E"
SET TEXT="No Billing Provider Secondary IDs found"
+46 IF IBEFTFL="A"
SET TEXT="No Billing Provider Additional IDs found"
+47 IF IBEFTFL="LF"
SET TEXT="No VA Lab/Facility IDs found"
+48 DO SET1(2,TEXT)
+49 SET IBLCT=2
End DoDot:1
+50 SET VALMBG=1
SET VALMCNT=IBLCT
+51 QUIT
+52 ;
SET1(IBLCT,TEXT,IBCT) ;
+1 SET IBLCT=IBLCT+1
DO SET^VALM10(IBLCT,TEXT,$GET(IBCT))
+2 QUIT
+3 ;
DIV(IBD) ; Returns 'ALL/DEFAULT' or div NAME whose ien=IBD
+1 NEW MAIN
+2 IF IBD
QUIT $$EXTERNAL^DILFD(355.92,.05,"",IBD)
+3 SET MAIN=$$MAIN^IBCEP2B()
+4 SET MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
+5 SET MAIN=MAIN_"/Default for All Divisions"
+6 QUIT MAIN
+7 ;
EDIT1 ;
+1 NEW IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL
+2 DO FULL^VALM1
+3 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+4 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+5 ; Insurance co
SET IBINS=+$PIECE(IBPARAM,U,2)
+6 SET IBFUNC="E"
+7 DO SEL
+8 IF $GET(IBDA)
SET Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL)
IF Z
DO INIT
+9 ;
EDIT1Q SET VALMBCK="R"
+1 QUIT
EXPND ;
+1 QUIT
HELP ;
+1 QUIT
EXIT ;
+1 NEW IBPARAM,IBEFTFL
+2 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+3 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+4 IF IBEFTFL="A"
DO COPYPROV^IBCEP5A(0)
+5 ;
+6 SET (IBLCT,IBCT)=0
+7 KILL ^TMP("IBCE_PRVFAC_MAINT",$JOB),^TMP("IBCE_PRVFAC_MAINT_INS",$JOB)
+8 DO CLEAN^VALM10
+9 QUIT
SEL ;
+1 NEW Z
+2 KILL IBDA
+3 DO FULL^VALM1
DO EN^VALM2($GET(XQORNOD(0)),"OS")
+4 SET Z=+$ORDER(VALMY(0))
if 'Z
QUIT
+5 ; fac/ins co default
+6 SET IBDA=$GET(^TMP("IBCE_PRVFAC_MAINT",$JOB,"ZIDX",Z))
+7 QUIT
+8 ;
EDITFAC(IBDA,IBFUNC,IBEFTFL) ; edits ins co facility id (355.92), entry IBDA
+1 NEW IBRBLD,Z,Z0,DIK,DIE,DP,DA,DR,DIR,X,Y,IBDA0,IBDIV,IBITYP,IBFORM,IBCAREUN,NEXTONE
+2 SET IBRBLD=0
if $GET(IBDA)
SET IBDA0=$GET(^IBA(355.92,+IBDA,0))
+3 ; "E"diting 355.92 entry
+4 IF IBFUNC="E"
Begin DoDot:1
+5 SET Z0=$TRANSLATE(IBDA0,U)
+6 if '$$FACFLDS^IBCEP7C(IBDA,IBINS,.IBITYP,.IBFORM,.IBDIV,"E",.IBCAREUN,IBEFTFL)
QUIT
+7 SET DIE="^IBA(355.92,"
SET DA=IBDA
+8 SET DR=".03////"_$SELECT($GET(IBCAREUN)]""&($GET(IBCAREUN)'="*N/A*"):IBCAREUN,1:"")_";.04////"_IBFORM_$SELECT(IBDIV:";.05////"_IBDIV,1:"")_";.06////"_IBITYP_";"
+9 SET DR=DR_".07"_$SELECT(IBEFTFL="E"!(IBEFTFL="A"):"Billing Provider Secondary ID",1:"VA Lab or Facility Secondary ID")
+10 IF IBEFTFL="A"
Begin DoDot:2
+11 SET NEXTONE=$$NEXTONE()
+12 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE)=IBDA_U_"MOD"_U_355.92
+13 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE,"OLD0")=^IBA(355.92,IBDA,0)
End DoDot:2
+14 DO ^DIE
+15 IF IBEFTFL="A"
SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE,0)=^IBA(355.92,IBDA,0)
+16 IF $TRANSLATE($GET(^IBA(355.92,IBDA,0)),U)'=Z0
SET IBRBLD=1
End DoDot:1
+17 ;
+18 ; "D"eleting 355.92 entry
+19 IF IBFUNC="D"
Begin DoDot:1
+20 WRITE !!," Insurance Co: ",$PIECE($GET(^DIC(36,+IBDA0,0)),U)
+21 WRITE !," Division: ",$$DIV($PIECE(IBDA0,U,5))
+22 if $PIECE(IBDA0,U,3)]""
WRITE !," Care Unit: ",$$EXTERNAL^DILFD(355.92,.03,"",$PIECE(IBDA0,U,3))
+23 WRITE !," ID Qualifier: ",$$EXTERNAL^DILFD(355.92,.06,"",$PIECE(IBDA0,U,6))
+24 WRITE !," Form Type: ",$$EXTERNAL^DILFD(355.92,.04,"",$PIECE(IBDA0,U,4))
+25 WRITE !," ID: ",$PIECE(IBDA0,U,7),!
+26 SET DIR(0)="YA"
SET DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS ID RECORD?: "
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+27 SET DIR("A")="NOTHING DELETED - PRESS RETURN TO CONTINUE: "
+28 IF Y=1
Begin DoDot:2
+29 SET DIK="^IBA(355.92,"
SET DA=IBDA
+30 DO ^DIK
+31 IF IBEFTFL="A"
Begin DoDot:3
+32 NEW NEXTONE
+33 SET NEXTONE=$$NEXTONE()
+34 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE)=IBDA_U_"DEL"_U_355.92
+35 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE,0)=IBDA0
End DoDot:3
+36 SET DIR("A")="ID DELETED - PRESS RETURN TO CONTINUE: "
SET IBRBLD=1
+37 SET DIR(0)="EA"
WRITE !
DO ^DIR
KILL DIR
End DoDot:2
End DoDot:1
+38 ;
+39 QUIT IBRBLD
+40 ;
FACID(Y) ;
+1 NEW Z,Z1,Z2
+2 SET Z=U_$PIECE($GET(^IBE(355.97,+Y,0)),U,3)_U
SET Z1=$$SUB2^IBCEF73(1)
SET Z2=$$SUB2^IBCEF73(2)
+3 IF Z1[Z!(Z2[Z)
QUIT 1
+4 QUIT 0
+5 ;
ADD1 ;
+1 NEW IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL,IBINS
+2 DO FULL^VALM1
+3 ;
+4 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+5 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+6 ; Insurance co ;
SET IBINS=+$PIECE(IBPARAM,U,2)
+7 ;
+8 SET Z=$$ADDFAC^IBCEP7A(IBINS,IBEFTFL)
IF Z
DO INIT
+9 ;
ADD1Q SET VALMBCK="R"
+1 QUIT
+2 ;
DEL1 ;
+1 NEW IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTDL,IBINS
+2 DO FULL^VALM1
+3 ;
+4 SET IBPARAM=$GET(^TMP("IBCE_PRVFAC_MAINT_INS",$JOB))
+5 ; Electronic Form type flag
SET IBEFTFL=$PIECE(IBPARAM,U)
+6 ; Insurance co
SET IBINS=+$PIECE(IBPARAM,U,2)
+7 ;
+8 SET IBFUNC="D"
+9 DO SEL
+10 IF $GET(IBDA)
SET Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL)
IF Z
DO INIT
+11 ;
DEL1Q SET VALMBCK="R"
+1 QUIT
+2 ;
+3 ; Get the next number so that the edits can be replicated in order for other providers/insurance companies
NEXTONE() ;
+1 QUIT $ORDER(^TMP("IB_EDITED_IDS",$JOB,""),-1)+1
