- 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 Feb 18, 2025@23:38:24 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
