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

IBCEF74A.m

Go to the documentation of this file.
  1. IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
  1. ;;2.0;INTEGRATED BILLING;**320,343,349,395,400,432,516,592**;21-MAR-94;Build 58
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. EN(IBIFN,IBQUIT,IBID) ; Display billing provider and service provider IDs as part
  1. ; of the ?ID display/help in the billing screens.
  1. ; Called from DISPID^IBCEF74.
  1. NEW IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,ORGNPI,BPZ,BPNAME,BPNPI,BPTAX,SFNPI,SFTAX
  1. ;
  1. ;D ALLIDS^IBCEF75(IBIFN,.IBID)
  1. ;
  1. ; Re-sort array by insurance sequence (P/S/T)
  1. K IBX
  1. F Z="BILLING PRV","LAB/FAC" F ZI="C","O" S ZN=0 F S ZN=$O(IBID(Z,IBIFN,ZI,ZN)) Q:'ZN D
  1. . S SEQ=$P($G(IBID(Z,IBIFN,ZI,ZN)),U,1) Q:SEQ=""
  1. . S IBX(Z,SEQ,ZI,ZN)=""
  1. . Q
  1. ;
  1. ; Display billing provider information - IB*2*400
  1. S BPZ=$$B^IBCEF79(IBIFN)
  1. D GETBP^IBCEF79(IBIFN,"",+BPZ,"?ID",.IBZ)
  1. S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !!,"Billing Provider Name and ID Information"
  1. S BPNAME=$G(IBZ("?ID","NAME"))
  1. I BPNAME="" S BPNAME="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !,"Billing Provider: ",BPNAME
  1. ;
  1. S BPNPI=$P(ORGNPI,U,3)
  1. I BPNPI="" S BPNPI="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Billing Provider NPI: ",BPNPI
  1. ;
  1. S BPTAX=$$NOPUNCT^IBCEF($P($G(^IBE(350.9,1,1)),U,5),1)
  1. I BPTAX="" S BPTAX="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Billing Provider Tax ID (VistA Record PRV): ",BPTAX
  1. ;
  1. ; Display billing provider secondary ID's (current ins only)
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Billing Provider Secondary IDs (VistA Record CI1A):"
  1. S Z="BILLING PRV"
  1. D SECID(Z,.IBQUIT)
  1. I IBQUIT G EX
  1. ;
  1. ; Now display the lab or facility primary and secondary IDs
  1. ; This is the service facility information
  1. ; IB*2*400 - check to make sure there is a service facility
  1. ;
  1. I $P(BPZ,U,3)="" G LPRV ; no service facility information to display
  1. ;
  1. ; Service facility name, similar code as found in SUB-2
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !!,"Service Facility Name and ID Information"
  1. ;
  1. ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
  1. ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
  1. ; that function and INSFLGS^IBCEF79 for more information.
  1. ;
  1. ; Display note if ins co flag to suppress lab/fac data is set (only applies in switchback mode)
  1. ;I '$$SENDSF^IBCEF79(IBIFN) D I IBQUIT G EX
  1. ;. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
  1. ;. W !!,"Note: Service Facility Data not sent for Current Insurance"
  1. ;. W !," 'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",!
  1. ;. Q
  1. ;
  1. S FACNAME=$$GETFAC^IBCEP8(+$P(BPZ,U,4),$P(BPZ,U,3),0)
  1. I FACNAME="" S FACNAME="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Facility: ",FACNAME
  1. ;
  1. S SFNPI=$P(ORGNPI,U,1)
  1. I SFNPI="" S SFNPI="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Lab or Facility NPI: ",SFNPI
  1. ;
  1. S SFTAX=$$NOPUNCT^IBCEF($$EIN^IBCEP8A(IBIFN),1)
  1. I SFTAX="" S SFTAX="***MISSING***"
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Lab or Facility Tax ID (VistA Record SUB): ",SFTAX
  1. ;
  1. ; lab/fac secondary IDs
  1. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  1. W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):"
  1. S Z="LAB/FAC"
  1. D SECID(Z,.IBQUIT)
  1. I IBQUIT G EX
  1. ;
  1. LPRV ;Service Line Providers
  1. I '$D(IBID("L-PROV")) G EX ; No Line Level Providers
  1. N IBSLC,IBN,CO,IBCODE,IBTYP,IBPRTYP,Z0
  1. S IBSLC=0
  1. W !!,"Service Line Providers"
  1. F S IBSLC=$O(IBID("L-PROV",IBIFN,IBSLC)) Q:'IBSLC D I IBQUIT Q
  1. . I ($Y+6)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT Q
  1. . W !!?5,"Service Line: ",IBSLC
  1. . ;JWS;IB*2.0*592; 6 - Assistant Surgeon
  1. . F IBPRTYP=4,3,1,2,5,6,9 I $D(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP)) D ; Process providers in order: Attending, Rendering, Referring, Operating, Supervising, Assistant Surgeon and Other Operating if they exist
  1. .. I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT Q
  1. .. W !?5,$$EXTERNAL^DILFD(399.0404,.01,"",IBPRTYP),": ",$$EXTERNAL^DILFD(399.0404,.02,"",$P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP),U,1))
  1. .. W !?8,"NPI:",?40,$S($P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4)]"":$P(IBID("L-PROV",IBIFN,IBSLC,"C",1,IBPRTYP,0),U,4),1:"***MISSING***")
  1. .. K IBTYP
  1. .. F CO="C","O" D
  1. ... F IBN=1,2 D
  1. .... F Z0=1:1 Q:'$D(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0))!IBQUIT D
  1. ..... S IBCODE=$P(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,9)
  1. ..... Q:$D(IBTYP(IBCODE)) ; 1st of each type transmits
  1. ..... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
  1. ..... S IBTYP(IBCODE)=""
  1. ..... W !,?8,"(",IBID("L-PROV",IBIFN,IBSLC,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$P(IBID("L-PROV",IBIFN,IBSLC,CO,IBN,IBPRTYP,Z0),U,4)
  1. ;
  1. EX ;
  1. Q
  1. ;
  1. QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description
  1. NEW QUAL,IEN
  1. S QUAL=""
  1. I $G(Z)="" G QUALX
  1. I Z="1C" D G QUALX ; qualifier for Medicare Part ?
  1. . I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B" ; 1500
  1. . I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A" ; ub
  1. . Q
  1. I Z=34 S Z="SY" ; qualifier for SSN
  1. S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX
  1. S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1)
  1. QUALX ;
  1. Q QUAL
  1. ;
  1. SECID(Z,IBQUIT) ; Display secondary ID and qualifier information
  1. ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC
  1. ; IBQUIT is returned if passed by reference
  1. NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA
  1. S IBQUIT=0,NODATA=1
  1. F SEQ="P","S","T" D Q:IBQUIT
  1. . ;
  1. . ; current ins only for billing provider secondary IDs
  1. . I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q
  1. . S ZI=""
  1. . F S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI="" D Q:IBQUIT
  1. .. S ZN=0
  1. .. F S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN D Q:IBQUIT
  1. ... S PSIN=0 ; start at 0 to skip primary IDs
  1. ... ;*432/TAZ - Changed Q:PSIN="" to Q:'PSIN to prevent "CONTACTS" node from printing as secondary ID
  1. ... F S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:'PSIN D Q:IBQUIT
  1. .... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN))
  1. .... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
  1. .... S IDNUM=$P(DATA,U,2)
  1. .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
  1. .... S NODATA=0
  1. .... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM
  1. .... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<<Current Ins"
  1. .... I Z="BILLING PRV",PSIN=1 W ?54,"<<<System Generated ID"
  1. .... Q
  1. ... Q
  1. .. Q
  1. . Q
  1. I NODATA,'IBQUIT W !?8,"(-) None Found"
  1. SECIDX ;
  1. Q
  1. ;