Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEPCID

IBCEPCID.m

Go to the documentation of this file.
  1. IBCEPCID ;ALB/WCJ - Provider ID functions ;13 Feb 2006
  1. ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
  1. ;; Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. G AWAY
  1. AWAY Q
  1. ;
  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,
  1. ; it quits. If it is passed a child, it synchs up with the parent. If it is passed a parent, it syncs
  1. ; up with all it's children.
  1. ;
  1. ; The IDs that synched up are Provider ID's defined for providers by an insurance company, default IDs for all
  1. ; Providers for and an insurance company, and additonal billing providers IDs for an insuracne company.
  1. ;
  1. ;
  1. N TYPE,PARENT,CHILD,COPYINS
  1. Q:$G(IBINS)=""
  1. S TYPE=$$TYPE(IBINS)
  1. Q:TYPE=""
  1. I TYPE="P" S PARENT=IBINS,CHILD=""
  1. I TYPE="C" S CHILD=IBINS,PARENT=$P($G(^DIC(36,IBINS,3)),U,14) Q:PARENT=""
  1. D COPYTO(PARENT,CHILD,.COPYINS)
  1. D LOOPTRNS(.COPYINS)
  1. Q
  1. ;
  1. TYPE(IBINS) ;
  1. Q $P($G(^DIC(36,+IBINS,3)),U,13)
  1. ;
  1. COPYTO(PARENT,CHILD,COPYINS) ; Figure out who to copy to:
  1. I CHILD]"" S COPYINS(PARENT,CHILD)="" Q
  1. F S CHILD=$O(^DIC(36,"APC",PARENT,CHILD)) Q:'CHILD S COPYINS(PARENT,CHILD)=""
  1. Q
  1. ;
  1. LOOPTRNS(COPYINS) ;
  1. N PARENT,CHILD,IBFILE
  1. S PARENT=$O(COPYINS(""))
  1. Q:PARENT="" ; just in case
  1. ;
  1. S CHILD="" F S CHILD=$O(COPYINS(PARENT,CHILD)) Q:CHILD="" D
  1. .F IBFILE=355.9,355.91,355.92 D
  1. .. I IBFILE=355.9 D Q
  1. ... N IBPRV,CU,FT,CT,QUAL,CDA,PDA
  1. ... ;
  1. ... ; File 355.9
  1. ... ; Delete IDs in child but not parent
  1. ... ; Edit IDs that are in both
  1. ... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
  1. .... Q:IBPRV'[";VA(200," ; only copying VA providers
  1. .... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD))
  1. .... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU)) Q:CU="" D
  1. ..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT)) Q:FT="" D
  1. ...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT)) Q:CT="" D
  1. ....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) Q:QUAL="" D
  1. ........ S CDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL,0))
  1. ........ Q:'CDA
  1. ........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) D DEL(IBFILE,CDA) Q
  1. ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
  1. ........ Q:PDA=""
  1. ........ D MOD(IBFILE,CDA,PDA) Q
  1. ... ;
  1. ... ; File 355.9
  1. ... ; Add IDs in parent but not child
  1. ... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
  1. .... Q:IBPRV'[";VA(200," ; only copying VA providers
  1. .... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT))
  1. .... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU)) Q:CU="" D
  1. ..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT)) Q:FT="" D
  1. ...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT)) Q:CT="" D
  1. ....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) Q:QUAL="" D
  1. ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
  1. ........ Q:'PDA
  1. ........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) D ADD(IBFILE,PDA,CHILD) Q
  1. .. ;
  1. .. ; Files 355.91 and 355.92
  1. .. ; Delete IDs in Child but not parent
  1. .. ; Edit IDs that are in both
  1. .. I $D(^IBA(IBFILE,"AUNIQ",CHILD)) D
  1. ... N CU,FT,CTORD,QUAL,PDA,CDA,DELFL
  1. ... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU)) Q:CU="" D
  1. .... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT)) Q:FT="" D
  1. ..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD)) Q:CTORD="" D
  1. ...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL)) Q:QUAL="" D
  1. ....... S CDA="" F S CDA=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,CDA)) Q:CDA="" D
  1. ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,0))
  1. ........ S DELFL=1
  1. ........ I PDA,IBFILE=355.91,$D(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) S DELFL=0
  1. ........ I PDA,IBFILE=355.92 S DELFL=0
  1. ........ D:DELFL DEL(IBFILE,CDA)
  1. ........ D:'DELFL MOD(IBFILE,CDA,PDA)
  1. .. ;
  1. .. ; Files 355.91 and 355.92
  1. .. ; Add IDs that are in parent but not child
  1. .. I $D(^IBA(IBFILE,"AUNIQ",PARENT)) D
  1. ... N CU,FT,CTORD,QUAL,PDA
  1. ... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU)) Q:CU="" D
  1. .... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT)) Q:FT="" D
  1. ..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD)) Q:CTORD="" D
  1. ...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) Q:QUAL="" D
  1. ....... S PDA="" F S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,PDA)) Q:PDA="" D
  1. ........ Q:$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,0))
  1. ........ D ADD(IBFILE,PDA,CHILD) Q
  1. Q
  1. ;
  1. ADD(IBFILE,IEN,INS) ; Add a provider ID
  1. N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT
  1. N ZERO,CU,FT,CTORD,QUAL,ID
  1. S ZERO=$G(^IBA(IBFILE,IEN,0))
  1. Q:ZERO=""
  1. S CU=$P(ZERO,U,3)
  1. S FT=$P(ZERO,U,4)
  1. S CTORD=$P(ZERO,U,5)
  1. S QUAL=$P(ZERO,U,6)
  1. S ID=$P(ZERO,U,7)
  1. ;
  1. I IBFILE=355.91!(IBFILE=355.92) D
  1. . S X=INS
  1. . S DIC("DR")=".03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
  1. . I IBFILE=355.92 S DIC("DR")=DIC("DR")_";.08////A"
  1. ;
  1. I IBFILE=355.9 D
  1. . S DIC("DR")=".02////"_INS_";.03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
  1. . S X=$P(ZERO,U)
  1. ;
  1. S DIC(0)="L",(DIC,DLAYGO)=IBFILE
  1. D FILE^DICN
  1. Q
  1. ;
  1. DEL(IBFILE,DA) ; Delete a Provider ID
  1. N DIK,DIR,X,Y,Z,I
  1. S DIK="^IBA("_IBFILE_","
  1. F I=1:1 L +^IBA(IBFILE,DA):5 I Q
  1. D ^DIK
  1. L -^IBA(IBFILE,DA)
  1. Q
  1. ;
  1. MOD(IBFILE,IEN,PIEN) ; Modify an existing Provider ID
  1. N I,ZERO,ID,PID,PZERO,FDAROOT
  1. S ZERO=$G(^IBA(IBFILE,IEN,0))
  1. Q:ZERO=""
  1. S PZERO=$G(^IBA(IBFILE,PIEN,0))
  1. Q:PZERO=""
  1. S ID=$P(ZERO,U,7)
  1. S PID=$P(PZERO,U,7)
  1. Q:ID=PID
  1. S FDAROOT(IBFILE,IEN_",",.07)=PID
  1. F I=1:1 L +^IBA(IBFILE,IEN):5 I Q
  1. D FILE^DIE(,"FDAROOT")
  1. L -^IBA(IBFILE,IEN)
  1. Q
  1. ;
  1. RESYNCH() ; Resynch everything
  1. L +^DIC(36):5 E W *7,!!,"Can not lock insurance company file, please try later.",!! Q
  1. N INS
  1. S INS="" F S INS=$O(^DIC(36,"APC",INS)) Q:INS="" D COPY(INS)
  1. L -^DIC(36)
  1. Q