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

IBCEP2A.m

Go to the documentation of this file.
  1. IBCEP2A ;ALB/TMP - EDI UTILITIES for provider ID ;25-APR-01
  1. ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,400,592**;21-MAR-94;Build 58
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ALT(IBPERF,IBSRC,IBALT,IBINS4,IBPTYP) ; set source level to next higher level
  1. ; or set the alternate type and source if performing provider id
  1. ; alternate type and source exist
  1. ; IBPERF = 1 if performing provider id is requested
  1. ; IBINS4 = '4' node of insurance co (file 36)
  1. ; Pass IBPTYP by reference to get alternate provider id type
  1. ; Pass IBALT by reference. Set to 1 if alternate id is to be used next
  1. ;
  1. I '$G(IBPERF)!($P(IBINS4,U,3)=1) S IBSRC=IBSRC-1 G ALTQ
  1. S IBSRC=""
  1. I '$G(IBALT),$P(IBINS4,U,3)=2,$P(IBINS4,U,10),$P(IBINS4,U,11) S IBALT=1,IBSRC=$P(IBINS4,U,11),IBPTYP=$P(IBINS4,U,10) S:IBPTYP="" IBPTYP=$P(IBINS4,U)
  1. ;
  1. ALTQ Q IBSRC
  1. ;
  1. IDSET(IBPTYP,IBINS4,IBPERF,IBSPEC,IBSRC,IBUP) ; set variables for provider id type search
  1. N Z
  1. S IBSPEC=$G(^IBE(355.97,+IBPTYP,1))
  1. S Z=$S($G(IBPERF):2,$P(IBSPEC,U,5):6,$P(IBSPEC,U,6):4,1:2)
  1. S IBSRC=$P(IBINS4,U,Z),IBUP=$P(IBINS4,U,$S(IBSRC:Z+1,1:0))
  1. Q
  1. ;
  1. CAREST(IBIFN) ; Return state file ien of state where care was performed
  1. ; IBIFN = ien of bill in file 399
  1. N STATE,IBU2,NVAFAC,IB0,EVDT,IBDIV,INST
  1. S STATE=""
  1. ;
  1. ; non-VA care
  1. S IBU2=$G(^DGCR(399,IBIFN,"U2"))
  1. S NVAFAC=+$P(IBU2,U,10) ; non-VA facility
  1. I NVAFAC S STATE=+$P($G(^IBA(355.93,NVAFAC,0)),U,7) G CARESTX
  1. ;
  1. ; VA care
  1. S IB0=$G(^DGCR(399,IBIFN,0))
  1. S EVDT=$P(IB0,U,3) ; claim event date
  1. I 'EVDT S EVDT=DT ; - default today if undefined
  1. S IBDIV=+$P(IB0,U,22) ; division ptr file 40.8
  1. I 'IBDIV S IBDIV=$$PRIM^VASITE(EVDT) ; - default primary division as of event date
  1. I IBDIV'>0 S IBDIV=$$PRIM^VASITE() ; - default main division as of today's date
  1. S INST=+$$SITE^VASITE(EVDT,IBDIV) ; division institution ptr file 4
  1. I INST'>0 S INST=+$$SITE^VASITE(DT,IBDIV) ; - default div as of today's date
  1. I INST'>0 S INST=+$$SITE^VASITE ; - default main institution
  1. S STATE=+$P($G(^DIC(4,INST,0)),U,2) ; state file ien from Institution file
  1. ;
  1. CARESTX ;
  1. Q STATE
  1. ;
  1. RECALCA(IBIFN) ; Recalculate all performing provider id's on bill IBIFN
  1. ; IBIFN = ien of bill entry (file 399)
  1. N IBZ,IBZ0,IBX,IBP,IBSEQ,DA,DIE,DR,DIR,X,Y
  1. ;
  1. D EN^DDIOL("THIS FUNCTION HAS BEEN DISABLED",,"!") Q
  1. ;
  1. S DA(1)=IBIFN
  1. I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D EN^DDIOL("YOU ARE NOT AUTHORIZED TO PERFORM THIS FUNCTION",,"!")
  1. S IBZ=0 F S IBZ=$O(^DGCR(399,IBIFN,"PRV",IBZ)) Q:'IBZ S IBP=$G(^(IBZ,0)) I $P(IBP,U,2)'="" D
  1. . S DA=IBZ
  1. . F IBZ0=5:1:7 Q:'$G(^DGCR(399,IBIFN,"I"_(IBZ0-4))) D
  1. .. S IBSEQ=$$EXPAND^IBTRE(399.0222,.01,+IBP)_" "_$P("PRIMARY^SECONDARY^TERTIARY",U,IBZ0-4)_" PROVIDER ID "
  1. .. S IBX=$$RECALC(.DA,IBZ0-4,$P(IBP,U,IBZ0),1)
  1. .. I IBX'="",IBX=$P(IBP,U,IBZ0) D EN^DDIOL(IBSEQ_"NO CHANGE NEEDED",,"!") Q
  1. .. I IBX'="",IBX'=$P(IBP,U,IBZ0) D Q
  1. ... S DR=(IBZ0/100)_"////"_IBX,DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE
  1. ... D EN^DDIOL(IBSEQ_"CHANGED TO "_IBX,,"!")
  1. .. D EN^DDIOL(IBSEQ_"NOT FOUND",,"!")
  1. Q
  1. ;
  1. RECALC(IBDA,IBSEQ,IBX,IBD) ; Recalculate id #, if possible - called
  1. ; from input transforms in subfile 399.0222, fields .05-.07
  1. ; IBDA = DA array of the provider entry (file 399.0222)
  1. ; IBSEQ = the numeric COB sequence of the provider id (1-3)
  1. ; IBX = the current value of the id in the subfile
  1. ; IBD = flag that if set to 1 will suppress the display text
  1. ;
  1. N IBPN,IBZ
  1. S IBPN=$P($G(^DGCR(399,IBDA(1),"PRV",IBDA,0)),U,2)
  1. I IBPN="" D:'$G(IBD) EN^DDIOL(" CAN'T CALCULATE WITHOUT A PROVIDER NAME","","?0") G RECALCQ
  1. S IBZ=$$GETID^IBCEP2(IBDA(1),2,IBPN,IBSEQ)
  1. I IBZ="" D:'$G(IBD) EN^DDIOL(" ID COULD NOT BE DETERMINED","","?0") G RECALCQ
  1. D:'$G(IBD) EN^DDIOL(" "_IBZ_$S(IBZ'=IBX:"",1:" (no change)"),"","?0")
  1. S IBX=IBZ
  1. ;
  1. RECALCQ Q IBX
  1. ;
  1. PERFPRV(IBIFN) ; Returns the variable pointer of the 'performing provider'
  1. ; (attending or rendering) for a bill IBIFN
  1. N IBP,IBPT,IBQ,Z
  1. S Z=$$FT^IBCEF(IBIFN),IBPT=$S(Z=2:3,Z=3:4,1:0)
  1. D GETPRV^IBCEU(IBIFN,IBPT,.IBP)
  1. Q $P($G(IBP(IBPT,1)),U,3)
  1. ;
  1. INSPAR(IBIFN,SEQ) ;
  1. N Z,Z4,Z0
  1. Q:$G(X)'="??"
  1. S:'$G(SEQ) SEQ=$$COBN^IBCEF(IBIFN)
  1. S Z=+$G(^DGCR(399,IBIFN,"I"_SEQ)),Z4=$G(^DIC(36,Z,4))
  1. I Z D
  1. . D EN^DDIOL(">"_$J("",20)_"-- PERFORMING PROVIDER ID PARAMETERS --",,"!")
  1. . S Z0=$P(" PRIMARY^SECONDARY^ TERTIARY",U,SEQ)_" INSURANCE: "_$P($G(^DIC(36,Z,0)),U)
  1. . D EN^DDIOL(">"_$J("",(80-$L(Z0))\2)_Z0,,"!")
  1. . D EN^DDIOL("> Secondary Perf Prov ID Type (1500): "_$$EXPAND^IBTRE(36,4.01,+Z4),,"!")
  1. . D EN^DDIOL("> Secondary Perf Prov ID Type (UB04): "_$$EXPAND^IBTRE(36,4.02,$P(Z4,U,2)),,"!")
  1. . D EN^DDIOL("> Secondary Perf Prov IDs Required: "_$$EXPAND^IBTRE(36,4.03,$P(Z4,U,3)),,"!")
  1. . D EN^DDIOL(" ",,"!")
  1. Q
  1. ;
  1. GETTYP(IBXIEN,IBCOBN,IBFUNC) ; Function returns provider id type for insurance co
  1. ; with COB of IBCOBN on claim ien IBXIEN in first ^ pc and 1 in second
  1. ; ^ piece if the id is required
  1. ;
  1. ; IBFUNC=1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER
  1. ;
  1. N A,R,Z,Z0
  1. S A="",R=0
  1. S:'$G(IBCOBN)!(IBCOBN>3) IBCOBN=$$COBN^IBCEF(IBXIEN)
  1. S Z=+$G(^DGCR(399,IBXIEN,"I"_+IBCOBN))
  1. I Z D
  1. . S Z0=$$FT^IBCEF(IBXIEN)
  1. . ;JWS;IB*2.0*592;no secondary provider ID's for Dental
  1. . I Z0=7 Q
  1. . S A=+$P($G(^DIC(36,Z,4)),U,$S(Z0=2&($G(IBFUNC)=1):4,Z0=2:1,1:2))
  1. . I A,$G(IBFUNC)'=1 S R=$P($G(^DIC(36,Z,4)),U,3),R=$S('R:0,R=3:1,R=1:Z0=2,R=2:Z0=3,1:0)
  1. . I A,$G(IBFUNC)=1 S R=+$P($G(^DIC(36,Z,4)),U,5),R=$S('R:0,Z0'=2:0,1:1)
  1. Q A_U_R
  1. ;
  1. UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
  1. ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
  1. ;
  1. ; Start in file 355.9 (Specific Provider)
  1. ; IBPROV = (variable pointer syntax) provider on bill IBIFN
  1. ;
  1. N Q,Z0,Z1,Z2,IBID,IBX
  1. S IBID=""
  1. S IBX=$P($G(^IBA(355.9,+IBCU,0)),U,3) S:"0"[IBX IBX="*N/A*"
  1. S Z0=$$FT^IBCEF(IBIFN)
  1. ;JWS;IB*2.0*592;If Dental quit
  1. I Z0=7 G UNIQ1Q
  1. S Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
  1. ;
  1. ; Match all elements
  1. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
  1. G:IBID'="" UNIQ1Q
  1. ;
  1. ; Match both form types,specific I/O element
  1. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
  1. G:IBID'="" UNIQ1Q
  1. ;
  1. ; Match specific form type, both I/O element or Rx
  1. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
  1. G:IBID'="" UNIQ1Q
  1. ;
  1. ; Match both form types, both I/O element or Rx
  1. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
  1. ;
  1. UNIQ1Q Q IBID
  1. ;
  1. UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
  1. ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
  1. ;
  1. ; Start in file 355.91 (Specific Insurance)
  1. ;
  1. N Q,Z0,Z1,Z2,IBID,IBX
  1. S IBID="" S:"0"[$G(IBUNIT) IBUNIT="*N/A*"
  1. S Z0=$$FT^IBCEF(IBIFN)
  1. ;JWS;IB*2.0*592;If Dental quit
  1. I Z0=7 G UNIQ2Q
  1. S Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
  1. ;
  1. ; Match all elements
  1. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
  1. G:IBID'="" UNIQ2Q
  1. ;
  1. ; Match both form types,specific I/O element
  1. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
  1. G:IBID'="" UNIQ2Q
  1. ;
  1. ; Match specific form type, both I/O element or Rx
  1. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
  1. G:IBID'="" UNIQ2Q
  1. ;
  1. ; Match both form types, both I/O elements or Rx
  1. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
  1. ;
  1. UNIQ2Q Q IBID
  1. ;