IBCEPCID ;ALB/WCJ - Provider ID functions ;13 Feb 2006
;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
;; Per VHA Directive 10-93-142, this routine should not be modified.
;
G AWAY
AWAY Q
;
COPY(IBINS) ; The purpose of this routine is to sync up insurance company IDs
; It is passed an insurance company. If the insurance company is a stand alone company,
; it quits. If it is passed a child, it synchs up with the parent. If it is passed a parent, it syncs
; up with all it's children.
;
; The IDs that synched up are Provider ID's defined for providers by an insurance company, default IDs for all
; Providers for and an insurance company, and additonal billing providers IDs for an insuracne company.
;
;
N TYPE,PARENT,CHILD,COPYINS
Q:$G(IBINS)=""
S TYPE=$$TYPE(IBINS)
Q:TYPE=""
I TYPE="P" S PARENT=IBINS,CHILD=""
I TYPE="C" S CHILD=IBINS,PARENT=$P($G(^DIC(36,IBINS,3)),U,14) Q:PARENT=""
D COPYTO(PARENT,CHILD,.COPYINS)
D LOOPTRNS(.COPYINS)
Q
;
TYPE(IBINS) ;
Q $P($G(^DIC(36,+IBINS,3)),U,13)
;
COPYTO(PARENT,CHILD,COPYINS) ; Figure out who to copy to:
I CHILD]"" S COPYINS(PARENT,CHILD)="" Q
F S CHILD=$O(^DIC(36,"APC",PARENT,CHILD)) Q:'CHILD S COPYINS(PARENT,CHILD)=""
Q
;
LOOPTRNS(COPYINS) ;
N PARENT,CHILD,IBFILE
S PARENT=$O(COPYINS(""))
Q:PARENT="" ; just in case
;
S CHILD="" F S CHILD=$O(COPYINS(PARENT,CHILD)) Q:CHILD="" D
.F IBFILE=355.9,355.91,355.92 D
.. I IBFILE=355.9 D Q
... N IBPRV,CU,FT,CT,QUAL,CDA,PDA
... ;
... ; File 355.9
... ; Delete IDs in child but not parent
... ; Edit IDs that are in both
... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
.... Q:IBPRV'[";VA(200," ; only copying VA providers
.... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD))
.... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU)) Q:CU="" D
..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT)) Q:FT="" D
...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT)) Q:CT="" D
....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) Q:QUAL="" D
........ S CDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL,0))
........ Q:'CDA
........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) D DEL(IBFILE,CDA) Q
........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
........ Q:PDA=""
........ D MOD(IBFILE,CDA,PDA) Q
... ;
... ; File 355.9
... ; Add IDs in parent but not child
... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
.... Q:IBPRV'[";VA(200," ; only copying VA providers
.... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT))
.... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU)) Q:CU="" D
..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT)) Q:FT="" D
...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT)) Q:CT="" D
....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) Q:QUAL="" D
........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
........ Q:'PDA
........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) D ADD(IBFILE,PDA,CHILD) Q
.. ;
.. ; Files 355.91 and 355.92
.. ; Delete IDs in Child but not parent
.. ; Edit IDs that are in both
.. I $D(^IBA(IBFILE,"AUNIQ",CHILD)) D
... N CU,FT,CTORD,QUAL,PDA,CDA,DELFL
... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU)) Q:CU="" D
.... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT)) Q:FT="" D
..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD)) Q:CTORD="" D
...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL)) Q:QUAL="" D
....... S CDA="" F S CDA=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,CDA)) Q:CDA="" D
........ S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,0))
........ S DELFL=1
........ I PDA,IBFILE=355.91,$D(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) S DELFL=0
........ I PDA,IBFILE=355.92 S DELFL=0
........ D:DELFL DEL(IBFILE,CDA)
........ D:'DELFL MOD(IBFILE,CDA,PDA)
.. ;
.. ; Files 355.91 and 355.92
.. ; Add IDs that are in parent but not child
.. I $D(^IBA(IBFILE,"AUNIQ",PARENT)) D
... N CU,FT,CTORD,QUAL,PDA
... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU)) Q:CU="" D
.... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT)) Q:FT="" D
..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD)) Q:CTORD="" D
...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) Q:QUAL="" D
....... S PDA="" F S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,PDA)) Q:PDA="" D
........ Q:$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,0))
........ D ADD(IBFILE,PDA,CHILD) Q
Q
;
ADD(IBFILE,IEN,INS) ; Add a provider ID
N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT
N ZERO,CU,FT,CTORD,QUAL,ID
S ZERO=$G(^IBA(IBFILE,IEN,0))
Q:ZERO=""
S CU=$P(ZERO,U,3)
S FT=$P(ZERO,U,4)
S CTORD=$P(ZERO,U,5)
S QUAL=$P(ZERO,U,6)
S ID=$P(ZERO,U,7)
;
I IBFILE=355.91!(IBFILE=355.92) D
. S X=INS
. S DIC("DR")=".03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
. I IBFILE=355.92 S DIC("DR")=DIC("DR")_";.08////A"
;
I IBFILE=355.9 D
. S DIC("DR")=".02////"_INS_";.03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
. S X=$P(ZERO,U)
;
S DIC(0)="L",(DIC,DLAYGO)=IBFILE
D FILE^DICN
Q
;
DEL(IBFILE,DA) ; Delete a Provider ID
N DIK,DIR,X,Y,Z,I
S DIK="^IBA("_IBFILE_","
F I=1:1 L +^IBA(IBFILE,DA):5 I Q
D ^DIK
L -^IBA(IBFILE,DA)
Q
;
MOD(IBFILE,IEN,PIEN) ; Modify an existing Provider ID
N I,ZERO,ID,PID,PZERO,FDAROOT
S ZERO=$G(^IBA(IBFILE,IEN,0))
Q:ZERO=""
S PZERO=$G(^IBA(IBFILE,PIEN,0))
Q:PZERO=""
S ID=$P(ZERO,U,7)
S PID=$P(PZERO,U,7)
Q:ID=PID
S FDAROOT(IBFILE,IEN_",",.07)=PID
F I=1:1 L +^IBA(IBFILE,IEN):5 I Q
D FILE^DIE(,"FDAROOT")
L -^IBA(IBFILE,IEN)
Q
;
RESYNCH() ; Resynch everything
L +^DIC(36):5 E W *7,!!,"Can not lock insurance company file, please try later.",!! Q
N INS
S INS="" F S INS=$O(^DIC(36,"APC",INS)) Q:INS="" D COPY(INS)
L -^DIC(36)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEPCID 6166 printed Sep 23, 2025@19:48:14 Page 2
IBCEPCID ;ALB/WCJ - Provider ID functions ;13 Feb 2006
+1 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 GOTO AWAY
AWAY QUIT
+1 ;
COPY(IBINS) ; The purpose of this routine is to sync up insurance company IDs
+1 ; It is passed an insurance company. If the insurance company is a stand alone company,
+2 ; it quits. If it is passed a child, it synchs up with the parent. If it is passed a parent, it syncs
+3 ; up with all it's children.
+4 ;
+5 ; The IDs that synched up are Provider ID's defined for providers by an insurance company, default IDs for all
+6 ; Providers for and an insurance company, and additonal billing providers IDs for an insuracne company.
+7 ;
+8 ;
+9 NEW TYPE,PARENT,CHILD,COPYINS
+10 if $GET(IBINS)=""
QUIT
+11 SET TYPE=$$TYPE(IBINS)
+12 if TYPE=""
QUIT
+13 IF TYPE="P"
SET PARENT=IBINS
SET CHILD=""
+14 IF TYPE="C"
SET CHILD=IBINS
SET PARENT=$PIECE($GET(^DIC(36,IBINS,3)),U,14)
if PARENT=""
QUIT
+15 DO COPYTO(PARENT,CHILD,.COPYINS)
+16 DO LOOPTRNS(.COPYINS)
+17 QUIT
+18 ;
TYPE(IBINS) ;
+1 QUIT $PIECE($GET(^DIC(36,+IBINS,3)),U,13)
+2 ;
COPYTO(PARENT,CHILD,COPYINS) ; Figure out who to copy to:
+1 IF CHILD]""
SET COPYINS(PARENT,CHILD)=""
QUIT
+2 FOR
SET CHILD=$ORDER(^DIC(36,"APC",PARENT,CHILD))
if 'CHILD
QUIT
SET COPYINS(PARENT,CHILD)=""
+3 QUIT
+4 ;
LOOPTRNS(COPYINS) ;
+1 NEW PARENT,CHILD,IBFILE
+2 SET PARENT=$ORDER(COPYINS(""))
+3 ; just in case
if PARENT=""
QUIT
+4 ;
+5 SET CHILD=""
FOR
SET CHILD=$ORDER(COPYINS(PARENT,CHILD))
if CHILD=""
QUIT
Begin DoDot:1
+6 FOR IBFILE=355.9,355.91,355.92
Begin DoDot:2
+7 IF IBFILE=355.9
Begin DoDot:3
+8 NEW IBPRV,CU,FT,CT,QUAL,CDA,PDA
+9 ;
+10 ; File 355.9
+11 ; Delete IDs in child but not parent
+12 ; Edit IDs that are in both
+13 SET IBPRV=""
FOR
SET IBPRV=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV))
if IBPRV=""
QUIT
Begin DoDot:4
+14 ; only copying VA providers
if IBPRV'[";VA(200,"
QUIT
+15 if '$DATA(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD))
QUIT
+16 SET CU=""
FOR
SET CU=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU))
if CU=""
QUIT
Begin DoDot:5
+17 SET FT=""
FOR
SET FT=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT))
if FT=""
QUIT
Begin DoDot:6
+18 SET CT=""
FOR
SET CT=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT))
if CT=""
QUIT
Begin DoDot:7
+19 SET QUAL=""
FOR
SET QUAL=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL))
if QUAL=""
QUIT
Begin DoDot:8
+20 SET CDA=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL,0))
+21 if 'CDA
QUIT
+22 IF '$DATA(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL))
DO DEL(IBFILE,CDA)
QUIT
+23 SET PDA=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
+24 if PDA=""
QUIT
+25 DO MOD(IBFILE,CDA,PDA)
QUIT
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
+26 ;
+27 ; File 355.9
+28 ; Add IDs in parent but not child
+29 SET IBPRV=""
FOR
SET IBPRV=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV))
if IBPRV=""
QUIT
Begin DoDot:4
+30 ; only copying VA providers
if IBPRV'[";VA(200,"
QUIT
+31 if '$DATA(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT))
QUIT
+32 SET CU=""
FOR
SET CU=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU))
if CU=""
QUIT
Begin DoDot:5
+33 SET FT=""
FOR
SET FT=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT))
if FT=""
QUIT
Begin DoDot:6
+34 SET CT=""
FOR
SET CT=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT))
if CT=""
QUIT
Begin DoDot:7
+35 SET QUAL=""
FOR
SET QUAL=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL))
if QUAL=""
QUIT
Begin DoDot:8
+36 SET PDA=$ORDER(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
+37 if 'PDA
QUIT
+38 IF '$DATA(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL))
DO ADD(IBFILE,PDA,CHILD)
QUIT
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
QUIT
+39 ;
+40 ; Files 355.91 and 355.92
+41 ; Delete IDs in Child but not parent
+42 ; Edit IDs that are in both
+43 IF $DATA(^IBA(IBFILE,"AUNIQ",CHILD))
Begin DoDot:3
+44 NEW CU,FT,CTORD,QUAL,PDA,CDA,DELFL
+45 SET CU=""
FOR
SET CU=$ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU))
if CU=""
QUIT
Begin DoDot:4
+46 SET FT=""
FOR
SET FT=$ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT))
if FT=""
QUIT
Begin DoDot:5
+47 SET CTORD=""
FOR
SET CTORD=$ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD))
if CTORD=""
QUIT
Begin DoDot:6
+48 SET QUAL=""
FOR
SET QUAL=$ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL))
if QUAL=""
QUIT
Begin DoDot:7
+49 SET CDA=""
FOR
SET CDA=$ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,CDA))
if CDA=""
QUIT
Begin DoDot:8
+50 SET PDA=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,0))
+51 SET DELFL=1
+52 IF PDA
IF IBFILE=355.91
IF $DATA(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL))
SET DELFL=0
+53 IF PDA
IF IBFILE=355.92
SET DELFL=0
+54 if DELFL
DO DEL(IBFILE,CDA)
+55 if 'DELFL
DO MOD(IBFILE,CDA,PDA)
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+56 ;
+57 ; Files 355.91 and 355.92
+58 ; Add IDs that are in parent but not child
+59 IF $DATA(^IBA(IBFILE,"AUNIQ",PARENT))
Begin DoDot:3
+60 NEW CU,FT,CTORD,QUAL,PDA
+61 SET CU=""
FOR
SET CU=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU))
if CU=""
QUIT
Begin DoDot:4
+62 SET FT=""
FOR
SET FT=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT))
if FT=""
QUIT
Begin DoDot:5
+63 SET CTORD=""
FOR
SET CTORD=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD))
if CTORD=""
QUIT
Begin DoDot:6
+64 SET QUAL=""
FOR
SET QUAL=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL))
if QUAL=""
QUIT
Begin DoDot:7
+65 SET PDA=""
FOR
SET PDA=$ORDER(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,PDA))
if PDA=""
QUIT
Begin DoDot:8
+66 if $ORDER(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,0))
QUIT
+67 DO ADD(IBFILE,PDA,CHILD)
QUIT
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+68 QUIT
+69 ;
ADD(IBFILE,IEN,INS) ; Add a provider ID
+1 NEW DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT
+2 NEW ZERO,CU,FT,CTORD,QUAL,ID
+3 SET ZERO=$GET(^IBA(IBFILE,IEN,0))
+4 if ZERO=""
QUIT
+5 SET CU=$PIECE(ZERO,U,3)
+6 SET FT=$PIECE(ZERO,U,4)
+7 SET CTORD=$PIECE(ZERO,U,5)
+8 SET QUAL=$PIECE(ZERO,U,6)
+9 SET ID=$PIECE(ZERO,U,7)
+10 ;
+11 IF IBFILE=355.91!(IBFILE=355.92)
Begin DoDot:1
+12 SET X=INS
+13 SET DIC("DR")=".03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
+14 IF IBFILE=355.92
SET DIC("DR")=DIC("DR")_";.08////A"
End DoDot:1
+15 ;
+16 IF IBFILE=355.9
Begin DoDot:1
+17 SET DIC("DR")=".02////"_INS_";.03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
+18 SET X=$PIECE(ZERO,U)
End DoDot:1
+19 ;
+20 SET DIC(0)="L"
SET (DIC,DLAYGO)=IBFILE
+21 DO FILE^DICN
+22 QUIT
+23 ;
DEL(IBFILE,DA) ; Delete a Provider ID
+1 NEW DIK,DIR,X,Y,Z,I
+2 SET DIK="^IBA("_IBFILE_","
+3 FOR I=1:1
LOCK +^IBA(IBFILE,DA):5
IF $TEST
QUIT
+4 DO ^DIK
+5 LOCK -^IBA(IBFILE,DA)
+6 QUIT
+7 ;
MOD(IBFILE,IEN,PIEN) ; Modify an existing Provider ID
+1 NEW I,ZERO,ID,PID,PZERO,FDAROOT
+2 SET ZERO=$GET(^IBA(IBFILE,IEN,0))
+3 if ZERO=""
QUIT
+4 SET PZERO=$GET(^IBA(IBFILE,PIEN,0))
+5 if PZERO=""
QUIT
+6 SET ID=$PIECE(ZERO,U,7)
+7 SET PID=$PIECE(PZERO,U,7)
+8 if ID=PID
QUIT
+9 SET FDAROOT(IBFILE,IEN_",",.07)=PID
+10 FOR I=1:1
LOCK +^IBA(IBFILE,IEN):5
IF $TEST
QUIT
+11 DO FILE^DIE(,"FDAROOT")
+12 LOCK -^IBA(IBFILE,IEN)
+13 QUIT
+14 ;
RESYNCH() ; Resynch everything
+1 LOCK +^DIC(36):5
IF '$TEST
WRITE *7,!!,"Can not lock insurance company file, please try later.",!!
QUIT
+2 NEW INS
+3 SET INS=""
FOR
SET INS=$ORDER(^DIC(36,"APC",INS))
if INS=""
QUIT
DO COPY(INS)
+4 LOCK -^DIC(36)
+5 QUIT
