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

IBCEP7.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. HDR ; -- hdr code
  1.  I '$D(^TMP("IBCE_PRVFAC_MAINT",$J)) D INIT
  1.  N IBINS,PCF,PCDISP,IBPARAM,IBEFTFL
  1.  K VALMHDR
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  S IBINS=+$P(IBPARAM,U,2)  ; Insurance co
  1.  S PCF=$P($G(^DIC(36,+IBINS,3)),U,13),PCDISP=$S(PCF="P":"(Parent)",1:"")
  1.  S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_PCDISP
  1.  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:"")
  1.  I IBEFTFL="LF" S VALMHDR(2)="VA-Lab/Facility Primary ID: Federal Tax ID"
  1.  Q
  1.  ;
  1. INIT ; Initialize
  1.  N IBCT,IBD,Z,Z0,Z00,Z1,IBS,IBX,IBDIV,IBEFTFL,IBINS,IBPARAM,IBLCT,IBCU
  1.  K ^TMP("IBCE_PRVFAC_MAINT",$J)
  1.  S (IBLCT,IBCT)=0
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  S IBINS=+$P(IBPARAM,U,2)  ; Insurance co
  1.  ;
  1.  I IBEFTFL="A" D
  1.  . K VALM("PROTOCOL")
  1.  . S Y=$$FIND1^DIC(101,,,"IBCE PRVFAC ADDIDS MAINT")
  1.  . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
  1.  ;
  1.  I IBEFTFL="LF" D
  1.  . S VALM("TITLE")="VA-Lab/Facility IDs"
  1.  . K VALM("PROTOCOL")
  1.  . S Y=$$FIND1^DIC(101,,,"IBCE PRVFAC VALF MAINT")
  1.  . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
  1.  ;
  1.  ; Compile the appropriate list of IDs
  1.  S Z=0 F  S Z=$O(^IBA(355.92,"B",IBINS,Z)) Q:'Z  D
  1.  . S Z0=$G(^IBA(355.92,Z,0))
  1.  . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
  1.  . Q:'($P(Z0,U,8)=IBEFTFL)
  1.  . ;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))
  1.  . S Z1=$G(^IBE(355.97,+$P(Z0,U,6),0))
  1.  . 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
  1.  ;
  1.  S IBD="" F  S IBD=$O(IBS(IBD)) Q:IBD=""  D
  1.  . D:IBCT SET1(.IBLCT," ",IBCT+1)
  1.  . D SET1(.IBLCT,"Division: "_$$DIV(IBD),IBCT+1)
  1.  . S IBCU="" F  S IBCU=$O(IBS(IBD,IBCU)) Q:IBCU=""  D
  1.  .. I IBCU D SET1(.IBLCT,"  Care Unit: "_$$EXTERNAL^DILFD(355.92,.03,"",IBCU),IBCT+1)
  1.  .. S Z="" F  S Z=$O(IBS(IBD,IBCU,Z),-1) Q:Z=""  D
  1.  ... S Z0="" F  S Z0=$O(IBS(IBD,IBCU,Z,Z0)) Q:Z0=""  S IBX=IBS(IBD,IBCU,Z,Z0) D
  1.  .... S IBCT=IBCT+1
  1.  .... I $P(Z,";",2) D  Q
  1.  ..... S Z00=$G(^IBA(355.92,+$P(Z,";",2),0))
  1.  ..... 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)
  1.  ..... D SET1(.IBLCT,Z1,IBCT)
  1.  ..... S ^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",IBCT)=+$P(Z,";",2)
  1.  ;
  1.  I 'IBLCT D
  1.  . D SET1(1," ")
  1.  . N TEXT
  1.  . I IBEFTFL="E" S TEXT="No Billing Provider Secondary IDs found"
  1.  . I IBEFTFL="A" S TEXT="No Billing Provider Additional IDs found"
  1.  . I IBEFTFL="LF" S TEXT="No VA Lab/Facility IDs found"
  1.  . D SET1(2,TEXT)
  1.  . S IBLCT=2
  1.  S VALMBG=1,VALMCNT=IBLCT
  1.  Q
  1.  ;
  1. SET1(IBLCT,TEXT,IBCT) ;
  1.  S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
  1.  Q
  1.  ;
  1. DIV(IBD) ; Returns 'ALL/DEFAULT' or div NAME whose ien=IBD
  1.  N MAIN
  1.  I IBD Q $$EXTERNAL^DILFD(355.92,.05,"",IBD)
  1.  S MAIN=$$MAIN^IBCEP2B()
  1.  S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
  1.  S MAIN=MAIN_"/Default for All Divisions"
  1.  Q MAIN
  1.  ;
  1. EDIT1 ;
  1.  N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL
  1.  D FULL^VALM1
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  S IBINS=+$P(IBPARAM,U,2)  ; Insurance co
  1.  S IBFUNC="E"
  1.  D SEL
  1.  I $G(IBDA) S Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL) I Z D INIT
  1.  ;
  1. EDIT1Q S VALMBCK="R"
  1.  Q
  1. EXPND ;
  1.  Q
  1. HELP ;
  1.  Q
  1. EXIT ;
  1.  N IBPARAM,IBEFTFL
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  I IBEFTFL="A" D COPYPROV^IBCEP5A(0)
  1.  ;
  1.  S (IBLCT,IBCT)=0
  1.  K ^TMP("IBCE_PRVFAC_MAINT",$J),^TMP("IBCE_PRVFAC_MAINT_INS",$J)
  1.  D CLEAN^VALM10
  1.  Q
  1. SEL ;
  1.  N Z
  1.  K IBDA
  1.  D FULL^VALM1,EN^VALM2($G(XQORNOD(0)),"OS")
  1.  S Z=+$O(VALMY(0)) Q:'Z
  1.  ; fac/ins co default
  1.  S IBDA=$G(^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",Z))
  1.  Q
  1.  ;
  1. EDITFAC(IBDA,IBFUNC,IBEFTFL) ; edits ins co facility id (355.92), entry IBDA
  1.  N IBRBLD,Z,Z0,DIK,DIE,DP,DA,DR,DIR,X,Y,IBDA0,IBDIV,IBITYP,IBFORM,IBCAREUN,NEXTONE
  1.  S IBRBLD=0 S:$G(IBDA) IBDA0=$G(^IBA(355.92,+IBDA,0))
  1.  ; "E"diting 355.92 entry
  1.  I IBFUNC="E" D
  1.  . S Z0=$TR(IBDA0,U)
  1.  . Q:'$$FACFLDS^IBCEP7C(IBDA,IBINS,.IBITYP,.IBFORM,.IBDIV,"E",.IBCAREUN,IBEFTFL)
  1.  . S DIE="^IBA(355.92,",DA=IBDA
  1.  . S DR=".03////"_$S($G(IBCAREUN)]""&($G(IBCAREUN)'="*N/A*"):IBCAREUN,1:"")_";.04////"_IBFORM_$S(IBDIV:";.05////"_IBDIV,1:"")_";.06////"_IBITYP_";"
  1.  . S DR=DR_".07"_$S(IBEFTFL="E"!(IBEFTFL="A"):"Billing Provider Secondary ID",1:"VA Lab or Facility Secondary ID")
  1.  . I IBEFTFL="A" D
  1.  .. S NEXTONE=$$NEXTONE()
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"MOD"_U_355.92
  1.  .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,"OLD0")=^IBA(355.92,IBDA,0)
  1.  . D ^DIE
  1.  . I IBEFTFL="A" S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=^IBA(355.92,IBDA,0)
  1.  . I $TR($G(^IBA(355.92,IBDA,0)),U)'=Z0 S IBRBLD=1
  1.  ;
  1.  ; "D"eleting 355.92 entry
  1.  I IBFUNC="D" D
  1.  . W !!," Insurance Co: ",$P($G(^DIC(36,+IBDA0,0)),U)
  1.  . W !,"     Division: ",$$DIV($P(IBDA0,U,5))
  1.  . W:$P(IBDA0,U,3)]"" !,"    Care Unit: ",$$EXTERNAL^DILFD(355.92,.03,"",$P(IBDA0,U,3))
  1.  . W !," ID Qualifier: ",$$EXTERNAL^DILFD(355.92,.06,"",$P(IBDA0,U,6))
  1.  . W !,"    Form Type: ",$$EXTERNAL^DILFD(355.92,.04,"",$P(IBDA0,U,4))
  1.  . W !,"           ID: ",$P(IBDA0,U,7),!
  1.  . S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS ID RECORD?: ",DIR("B")="NO" D ^DIR K DIR
  1.  . S DIR("A")="NOTHING DELETED - PRESS RETURN TO CONTINUE: "
  1.  . I Y=1 D
  1.  .. S DIK="^IBA(355.92,",DA=IBDA
  1.  .. D ^DIK
  1.  .. I IBEFTFL="A" D
  1.  ... N NEXTONE
  1.  ... S NEXTONE=$$NEXTONE()
  1.  ... S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"DEL"_U_355.92
  1.  ... S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=IBDA0
  1.  .. S DIR("A")="ID DELETED - PRESS RETURN TO CONTINUE: ",IBRBLD=1
  1.  .. S DIR(0)="EA" W ! D ^DIR K DIR
  1.  ;
  1.  Q IBRBLD
  1.  ;
  1. FACID(Y) ;
  1.  N Z,Z1,Z2
  1.  S Z=U_$P($G(^IBE(355.97,+Y,0)),U,3)_U,Z1=$$SUB2^IBCEF73(1),Z2=$$SUB2^IBCEF73(2)
  1.  I Z1[Z!(Z2[Z) Q 1
  1.  Q 0
  1.  ;
  1. ADD1 ;
  1.  N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTFL,IBINS
  1.  D FULL^VALM1
  1.  ;
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  S IBINS=+$P(IBPARAM,U,2)  ; Insurance co        ;
  1.  ;
  1.  S Z=$$ADDFAC^IBCEP7A(IBINS,IBEFTFL) I Z D INIT
  1.  ;
  1. ADD1Q S VALMBCK="R"
  1.  Q
  1.  ;
  1. DEL1 ;
  1.  N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP,IBPARAM,IBEFTDL,IBINS
  1.  D FULL^VALM1
  1.  ;       
  1.  S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
  1.  S IBEFTFL=$P(IBPARAM,U)  ; Electronic Form type flag
  1.  S IBINS=+$P(IBPARAM,U,2)  ; Insurance co
  1.  ;
  1.  S IBFUNC="D"
  1.  D SEL
  1.  I $G(IBDA) S Z=$$EDITFAC(IBDA,IBFUNC,IBEFTFL) I Z D INIT
  1.  ;
  1. DEL1Q S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ; Get the next number so that the edits can be replicated in order for other providers/insurance companies
  1. NEXTONE() ;
  1.  Q $O(^TMP("IB_EDITED_IDS",$J,""),-1)+1