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

IBCEP2B.m

Go to the documentation of this file. 
  1. IBCEP2B ;ALB/TMP - EDI UTILITIES for provider ID ;18-MAY-04
  1.  ;;2.0;INTEGRATED BILLING;**232,320,400,432,592**;21-MAR-94;Build 58
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. PROVID(IBIFN,IBPRIEN,IBCOBN,DIPA) ; Provider id entry on billing screen 10, and line level provider input on billing screens 4&5.
  1.  ; IBIFN = ien file 399
  1.  ; IBPRIEN = ien file 399.0222, or ien file 399.0404.
  1.  ; IBCOBN = the COB number of the id being edited
  1.  ; DIPA = passed by ref, returned with id data
  1.  ; DIPA("EDIT")=-1 if no id editing  = 1 if edit id   = 2 if stuff id
  1.  ; DIPA("PRID")= id to stuff   DIPA("PRIDT")= id type to stuff
  1.  N PRN0,Z
  1.  Q:'$G(^DGCR(399,IBIFN,"I1"))
  1.  I $G(IBLNPRV),'$G(IBLNPRV("LNPRVIEN")),'$G(IBLNPRV("PROCIEN")) Q  ; DEM;432 - If line provider user input.
  1.  ; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
  1.  S PRN0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
  1.  S DIPA("EDIT")=1,(DIPA("PRID"),DIPA("PRIDT"))=""
  1.  W @IOF
  1.  W !,?19,"**** SECONDARY PERFORMING PROVIDER IDs ****"
  1.  W !!,$P("PRIMARY^SECONDARY^TERTIARY",U,IBCOBN)_" INSURANCE CO: "_$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_IBCOBN)),0)),U)
  1.  ; DEM;432 - Added line and conditions if line level provider user input.
  1.  I '$G(IBLNPRV) W !,"PROVIDER: "_$$EXTERNAL^DILFD(399.0222,.02,"",$P(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0222,.01,"",+PRN0)_")",!
  1.  I $G(IBLNPRV) W !,"Line Level Provider: "_$$EXTERNAL^DILFD(399.0404,.02,"",$P(PRN0,U,2))_" ("_$$EXTERNAL^DILFD(399.0404,.01,"",+PRN0)_")",!
  1.  ;
  1.  I $P(PRN0,U,4+IBCOBN)="" K DIPA("PRID"),DIPA("PRIDT") D NEWID(IBIFN,IBPRIEN,IBCOBN,.DIPA) ; No id currently exists for the ins seq/prov
  1.  ;
  1.  Q
  1.  ;
  1. NEWID(IBIFN,IBPRIEN,IBCOBN,DIPA) ;
  1.  N IBDEF,IBCT,IBNUM,IBINS,IBFRM,IBCAR,IBARR,IBARRS,IB0,IBM,IBQUIT,IBSEL,PRN,PRT,PRN,PRN0,DIR,X,Y,Z,Z0,IBZ,IBZ1,IBTYP,IBREQ,IBREQT,IBTYPN,IBID,IBUSED
  1.  S IBREQ=0,IBREQT=""
  1.  Q:($G(IBLNPRV))&('$G(IBLNPRV("LNPRVIEN"))&'$G(IBLNPRV("PROCIEN")))  ; DEM;432 - If line provider user input.
  1.  ; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming from line level provider user input.
  1.  S PRN0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
  1.  S Z(IBCOBN)=$S($G(DIPA("I"_IBCOBN)):$$GETTYP^IBCEP2A(IBIFN,IBCOBN,$P(PRN0,U)),1:"")
  1.  S IBINS=+$G(^DGCR(399,IBIFN,"I"_IBCOBN)),IB0=$S($G(IBLNPRV):$G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0)),1:$G(^DGCR(399,IBIFN,"PRV",IBPRIEN,0)))
  1.  S IBCAR=$$INPAT^IBCEF(IBIFN),IBCAR=$S('IBCAR:2,1:1)
  1.  ;JRA IB*2.0*592 Dental Form 7
  1.  ;S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=2:2,1:1)  ;JRA IB*2.0*592 ';'
  1.  S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=2:2,IBFRM=7:7,1:1)  ;JWS;JRA IB*2.0*592
  1.  I $P(Z(IBCOBN),U) D
  1.  . W !,"INS. COMPANY'S DEFAULT SECONDARY ID TYPE IS: "_$$EXTERNAL^DILFD(36,4.01,"",$P(Z(IBCOBN),U)) S IBREQT=+Z(IBCOBN)
  1.  . I $P(Z(IBCOBN),U,2) W !,?2," AND IS REQUIRED TO BE ENTERED FOR THIS CLAIM" S IBREQ=1
  1.  I $$CUNEED^IBCEP3(IBIFN,IBCOBN) W !,"CARE UNITS ARE DEFINED"_$S($P($G(^DIC(36,IBINS,4)),U,9)'="":" AS "_$P(^(4),U,9),1:"")_" FOR THESE IDs"
  1.  D PRACT^IBCEF71(IBINS,IBFRM,IBCAR,$P(IB0,U,2),.IBARR,$P(IB0,U),$S($$COBN^IBCEF(IBIFN)=IBCOBN:"C",1:"O"),355.9,1)
  1.  S (IBNUM,IBCT)=0,IBDEF=""
  1.  I $O(IBARR(""))="" S IBCT=IBCT+1,DIR("A",IBCT)="NO SECONDARY IDS ARE DEFINED FOR THIS PROV THAT ARE VALID FOR THIS CLAIM"
  1.  S IBCT=IBCT+1,DIR("A",IBCT)="SELECT A SECONDARY ID OR ACTION FROM THE LIST BELOW: ",IBCT=IBCT+1,DIR("A",IBCT)=" "
  1.  ;
  1.  S IBCT=IBCT+1,IBNUM=IBNUM+1,DIR("A",IBCT)="  "_$E(IBNUM_$J("",3),1,3)_" -  NO SECONDARY ID NEEDED",IBNUM=IBNUM+1,IBCT=IBCT+1,DIR("A",IBCT)="  "_$E(IBNUM_$J("",3),1,3)_" -  ADD AN ID FOR THIS CLAIM ONLY"
  1.  I $O(IBARR(""))="" S IBDEF=1,DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM) Q
  1.  ;
  1.  S PRN=$$GETID^IBCEP2(IBIFN,2,$P(PRN0,U,2),IBCOBN,.PRT,,$P(PRN0,U)),IBDEF=""
  1.  ;
  1.  I PRN'="",PRT D
  1.  . N PRT1
  1.  . S PRT1=$P($G(^IBE(355.97,+PRT,0)),U)
  1.  . I $P($G(^IBE(355.97,+PRT,1)),U,3) S PRT1="ST LIC("_$P($G(^DIC(5,+$$CAREST^IBCEP2A(IBIFN),0)),U,2)_")"
  1.  . S IBCT=IBCT+1,IBNUM=IBNUM+1
  1.  . S DIR("A",IBCT)="  "_$E(IBNUM_$J("",3),1,3)_" -  "_$E("<DEFAULT> "_PRN_$J("",29),1,29)_"  "_$E(PRT1_$J("",15),1,15)
  1.  . S DIR("A",IBCT)=DIR("A",IBCT)_"  "_$S($P(PRT,U,3)'["355.9":"",$P($G(^IBA(+$P(PRT,U,3),+$P(PRT,U,2),0)),U,3)'="":$$EXTERNAL^DILFD(355.9,.03,"",$P($G(^IBA(+$P(PRT,U,3),+$P(PRT,U,2),0)),U,3)),1:"")
  1.  . S IBID(IBNUM)=PRN_U_+PRT,IBDEF=IBNUM,IBID(IBNUM,1)=DIR("A",IBCT),IBDEF=IBNUM,IBDEF("IEN")=$P(PRT,U,2,3)
  1.  . S IBUSED(PRT,PRN,0)=""
  1.  ;
  1.  S IBQUIT=0,IBSEL=1
  1.  ; Sort ids by id type
  1.  S IBZ="" F  S IBZ=$O(IBARR(IBZ)) Q:IBZ=""  S IBZ1="" F  S IBZ1=$O(IBARR(IBZ,IBZ1)) Q:IBZ1=""  D
  1.  . S IBTYP=+$P(IBARR(IBZ,IBZ1),U,9)
  1.  . I $P(IBARR(IBZ,IBZ1),U,4)]"" Q:$D(IBUSED(IBTYP,$P(IBARR(IBZ,IBZ1),U,4),+$P(IBARR(IBZ,IBZ1),U,7)))
  1.  . I $P($G(IBDEF("IEN")),U,2)["355.9",$P(IBARR(IBZ,IBZ1),U,8),$P(IBARR(IBZ,IBZ1),U,8)=+$G(IBDEF("IEN")) Q:$S($P(IBZ1,U)'["INS DEF":$P($G(IBDEF("IEN")),U,2)=355.9,1:$P($G(IBDEF("IEN")),U,2)=355.91)
  1.  . S IBARRS(IBTYP,IBZ,IBZ1)=IBARR(IBZ,IBZ1)
  1.  . I $P(IBARR(IBZ,IBZ1),U,4)]"" S IBUSED(IBTYP,$P(IBARR(IBZ,IBZ1),U,4),+$P(IBARR(IBZ,IBZ1),U,7))=""
  1.  S IBTYP="" F  S IBTYP=$O(IBARRS(IBTYP)) Q:IBTYP=""  S IBZ="" F  S IBZ=$O(IBARRS(IBTYP,IBZ)) Q:IBZ=""  D  Q:IBQUIT
  1.  . S IBZ1="" F  S IBZ1=$O(IBARRS(IBTYP,IBZ,IBZ1)) Q:IBZ1=""  S IBCT=IBCT+1,IBNUM=IBNUM+1 D  Q:IBQUIT
  1.  .. S Z0=IBARRS(IBTYP,IBZ,IBZ1)
  1.  .. S IBARR=$S($P(Z0,U,8)&(IBZ1'["LIC"):$G(^IBA("355.9"_$S($P(IBZ1,U)'="INS DEF":"",1:1),+$P(Z0,U,8),0)),1:"")
  1.  .. S IBTYPN=$S(IBTYP=+$$STLIC^IBCEP8():"ST LIC ("_$P($G(^DIC(5,+$P(Z0,U,7),0)),U,2)_")",1:$P($G(^IBE(355.97,IBTYP,0)),U))
  1.  .. S DIR("A",IBCT)="  "_$E(IBNUM_$J("",3),1,3)_" -  "_$E($S($P(IBZ1,U)="INS DEF":"<INS DEF> ",1:"")_$P(Z0,U,4)_$J("",29),1,29)_"  "_$E(IBTYPN_$J("",15),1,15)_"  "_$S($P(IBARR,U,3):$$EXTERNAL^DILFD(355.9,.03,"",$P(IBARR,U,3)),1:"")
  1.  .. S IBID(IBNUM,1)=DIR("A",IBCT),IBID(IBNUM)=$P(Z0,U,4)_U_IBTYP
  1.  .. I (IBNUM#15)=0 S IBM=$$MORE(.DIR) D  Q:IBQUIT
  1.  ... I IBM<0 S IBQUIT=1,IBSEL=0 Q  ; User aborted list
  1.  ... I 'IBM S IBQUIT=1 Q  ; User wants to select
  1.  ... W ! K DIR S IBCT=1
  1.  I 'IBSEL S DIPA("EDIT")=-1
  1.  I IBSEL S:IBDEF=""&$G(IBREQ) IBDEF=2 S DIPA("EDIT")=$$SELID(.DIR,IBDEF,.IBID,.DIPA,IBNUM)
  1.  Q
  1.  ;
  1. SELID(DIR,IBDEF,IBID,DIPA,IBNUM) ; Returns the selection from the array of possible IDs/ID actions
  1.  N IDACT,IDSEL,X,Y
  1.  S IDACT=""
  1.  S DIR("B")=$S('$G(IBDEF):1,1:IBDEF),DIR("A",+$O(DIR("A",""),-1)+1)=" "
  1.  S DIR(0)="NA^1:"_IBNUM,DIR("A")="Selection: " W ! D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!(Y=1) S IDACT=-1 G SELIDQ
  1.  I Y=2 S IDACT=1 G SELIDQ
  1.  S IDSEL=Y
  1.  S DIR("A",1)="ID SELECTED:",DIR("A",2)="  "_$G(IBID(+Y,1)),DIR("A")="IS THIS CORRECT?: ",DIR("B")="YES",DIR(0)="YA" W ! D ^DIR K DIR
  1.  I Y'=1 S IDACT=-1 G SELIDQ
  1.  S DIPA("PRID")=$P(IBID(IDSEL),U),DIPA("PRIDT")=$P(IBID(IDSEL),U,2),IDACT=2
  1.  ;
  1. SELIDQ Q IDACT
  1.  ;
  1. MORE(DIR) ;
  1.  N DIR,X,Y,DUOUT,DTOUT
  1.  S DIR(0)="YA",DIR("A")="MORE?: ",DIR("B")="NO" W ! D ^DIR K DIR("B")
  1.  Q $S($D(DTOUT)!$D(DUOUT):-1,1:Y)
  1.  ;
  1.  ; IBFIDFL = E = Electronic Form Type
  1.  ;           A = Additional ID's
  1.  ;           LF - VA Lab/Facility
  1. FACID(IBINS,IBFIDFL) ; Enter/edit billing facility ids
  1.  ; IBINS = ien of ins co (file 36)
  1.  N IBID,Z,Z0,Y
  1.  K ^TMP($J,"IBBF_ID")
  1.  W @IOF
  1.  D GETBPNUM(IBINS)
  1.  K ^TMP("IBCE_PRVFAC_MAINT_INS",$J)
  1.  S ^TMP("IBCE_PRVFAC_MAINT_INS",$J)=IBFIDFL_U_IBINS_U_"1"
  1.  D EN^VALM("IBCE PRVFAC MAINT")
  1.  K ^TMP("IBCE_PRVFAC_MAINT_INS",$J)
  1.  W @IOF
  1.  D FULL^VALM1
  1.  Q
  1.  ;
  1. GETBPNUM(IBINS) ;
  1.  N Z,Z0,IBID,IBMAIN
  1.  S IBMAIN=$$MAIN(),^TMP($J,"IBBF_ID")=IBMAIN
  1.  S IBID=$$BF^IBCU()
  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,8)'="E"  ; WCJ 1/13/06  There are several ID types in this file 
  1.  . Q:$P(Z0,U,3)]""
  1.  . S ^TMP($J,"IBBF_ID",$S($P(Z0,U,5)=IBMAIN:0,1:+$P(Z0,U,5)),+$P(Z0,U,4))=$P(Z0,U,7)
  1.  . S ^TMP($J,"IBBF_ID",$S($P(Z0,U,5)=IBMAIN:0,1:+$P(Z0,U,5)),+$P(Z0,U,4),"QUAL")=$P(Z0,U,6)
  1.  Q
  1.  ;
  1. MAIN() ; Returns ien of main division of the database
  1.  Q +$$PRIM^VASITE()
  1.  ;
  1. FACNUM(IBIFN,IBCOB,IBQF) ; Function returns the current division's fac billing
  1.  ; prov id for the COB insurance sequence from file 355.92
  1.  ; IBIFN = ien file 399
  1.  ; IBCOB = # of COB ins seq or if "", current assumed
  1.  ; IBQF - 1 if qualifier is to be returned instead of ID
  1.  N Z,IBDIV,IBFT,X,BPZ
  1.  S X="",IBDIV=0
  1.  S:'$G(IBCOB) IBCOB=+$$COBN^IBCEF(IBIFN)
  1.  ;
  1.  ; IB*2*400 - esg - 11/7/08 - Determine the division associated with the billing provider first
  1.  S BPZ=+$$B^IBCEF79(IBIFN,IBCOB)                     ; Inst file pointer as the billing provider for payer seq IBCOB
  1.  I BPZ S IBDIV=+$O(^DG(40.8,"AD",BPZ,0))             ; Billing Provider division (may not exist)
  1.  ;
  1.  I 'IBDIV S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22)   ; Division on claim
  1.  I 'IBDIV S IBDIV=$$MAIN()                           ; main division
  1.  ;JWS;IB*2.0*592;
  1.  S IBFT=$$FT^IBCEF(IBIFN),IBFT=$S(IBFT=3:1,IBFT=7:7,1:2)
  1.  K ^TMP($J,"IBBF_ID")
  1.  D GETBPNUM(+$P($G(^DGCR(399,IBIFN,"M")),U,IBCOB))
  1.  I IBDIV=+$G(^TMP($J,"IBBF_ID")) S IBDIV=0
  1.  I '$G(IBQF) S X=$S($D(^TMP($J,"IBBF_ID",IBDIV,IBFT)):^(IBFT),1:$G(^TMP($J,"IBBF_ID",0,IBFT)))
  1.  I $G(IBQF) S X=$S($D(^TMP($J,"IBBF_ID",IBDIV,IBFT,"QUAL")):^("QUAL"),1:$G(^TMP($J,"IBBF_ID",0,IBFT,"QUAL")))
  1.  K ^TMP($J,"IBBF_ID")
  1.  Q X
  1.  ;
  1. SOP(IBIFN,IBZD) ; Returns X12 current source of pay code for bill ien IBIFN
  1.  ; IBZD = the current ins policy type, if known
  1.  N IBZ,IBFT  ;JRA IB*2.0*592 Added 'IBFT'
  1.  S IBZ=""
  1.  I $G(IBZD)="" D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZD",,IBIFN)
  1.  S IBFT=$$FT^IBCEF(IBIFN)  ;JRA IB*2.0*592
  1.  ;S IBZ=$S($G(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$S($$FT^IBCEF(IBIFN)=2:"1B",1:"1A"),1:"G2")  ;JRA IB*2.0*592 ';'
  1.  S IBZ=$S($G(IBZD)="":"G2","MAMB16"[IBZD:"1C",IBZD="TV"!(IBZD="MC"):"1D",IBZD="CH":"1H",IBZD="BL":$S((IBFT=2!(IBFT=7)):"1B",1:"1A"),1:"G2")  ;JRA IB*2.0*592
  1.  Q IBZ
  1.  ;