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

IBCEFP.m

Go to the documentation of this file.
  1. IBCEFP ;ALB/TAZ - Provider ID functions ;28-OCT-10
  1. ;;2.0;INTEGRATED BILLING;**432,447,473,516,592,623**;21-MAR-94;Build 70
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
  1. I '$D(IBSTRIP) S IBSTRIP=0
  1. I '$D(SEG) S SEG=""
  1. N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB,IBCARE,IBCURR,IBXDATA,NPI,CUROTH
  1. ;JWS;IB*2.0*592;US131
  1. S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
  1. S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
  1. S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
  1. S IBCURR=$$COB^IBCEF(IBIFN) ;current bill payer sequence
  1. ;don't create anything if form type not CMS-1500 or UB or J430D
  1. I IBFRMTYP,'+$G(IBXSAVE("PROVINF",IBIFN)) D
  1. . N IBZ,CUROTH
  1. . ;JWS;IB*2.0*592;US131
  1. . I IBFRMTYP=2!(IBFRMTYP=7) D OUTPT^IBCEF11(IBIFN,0)
  1. . I IBFRMTYP=1 D HOS^IBCEF22(IBIFN)
  1. . ; START IB*2.0*447 BI
  1. . I IBCURR="A" D Q
  1. .. N IBRESARR
  1. .. S IBLIMIT=5
  1. .. D PROVINF(IBIFN,1,.IBRESARR,1,"C",IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. .. M IBXSAVE=IBRESARR
  1. .. S IBXSAVE("PROVINF",IBIFN)=IBIFN
  1. . ; END IB*2.0*447 BI
  1. . F CUROTH="C","O" D PROVIDER(IBIFN,CUROTH,.IBZ,IBFRMTYP,IBCARE,IBCURR,.IBXDATA) M IBXSAVE=IBZ
  1. . S IBXSAVE("PROVINF",IBIFN)=IBIFN
  1. . Q
  1. ;
  1. D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs
  1. S NPI=$P($$ORGNPI^IBCEF73A(IBIFN),U,1)
  1. F CUROTH="C","O" D
  1. . S IBXSAVE("LAB/FAC",IBIFN,CUROTH,1,0)=$S(NPI]"":"XX",1:"")_U_NPI
  1. ;
  1. S IBFRMTYP=$$FT^IBCEF(IBIFN)
  1. S ARIEN=$S(IBFRMTYP=2:3,1:4)
  1. S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
  1. F COB=1:1:3 D
  1. . S SORT1=$S(COB=IBCCOB:"C",1:"O")
  1. . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
  1. . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
  1. . ;
  1. . D BPIDS^IBCEF75(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
  1. ;
  1. D EN^IBCEF81(.IBXSAVE)
  1. ;
  1. I SEG="OPR1" D
  1. . I '$D(IBXSAVE("PROVINF",IBIFN,"C",1,3)) D G ALLIDSQ
  1. .. N SLC,CRED S SLC=0
  1. .. F S SLC=$O(IBXSAVE("L-PROV",IBIFN,SLC)) Q:'SLC D I $D(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME")) Q
  1. ... S CRED=$P($G(IBXSAVE("L-PROV",IBIFN,SLC,"C",1,3,"NAME")),U,4)
  1. ... I CRED]"" S $P(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME"),U,4)=CRED
  1. ;
  1. I SEG="LPUR"!(SEG="LPUR1"),$$SUB1OK^IBCEP8A(IBIFN),$G(IBXSAVE("SLC")) D G ALLIDSQ
  1. . N IBCNT,OUT
  1. . ;IB*2.0*473/TAZ - Moved ID lookup into seperate function.
  1. . D PSID(IBIFN,.IBXSAVE,.IDS)
  1. . ;IB*2.0*473/TAZ - END
  1. . ;JWS;IB*2.0*623;$G in the event IDS is not defined.
  1. . S $P(OUT,U,6)=$G(IDS(0))
  1. . S $P(OUT,U,7,8)=$G(IDS(1)) ; secondary id (1) ^ secondary id qualifier(1)
  1. . F IBCNT=1:1:IBXSAVE("SLC") S IBXSAVE("SLPRV",IBCNT)=OUT,IBXSAVE("SLPRV",IBCNT,"SLC")=IBCNT
  1. ;
  1. I SEG="LOPE" D SLPRV(IBIFN,.IBXSAVE,2) G ALLIDSQ
  1. I SEG="LOP1" D SLPRV(IBIFN,.IBXSAVE,9) G ALLIDSQ
  1. I SEG="LREN" D SLPRV(IBIFN,.IBXSAVE,3) G ALLIDSQ
  1. I SEG="LSUP" D SLPRV(IBIFN,.IBXSAVE,5) G ALLIDSQ
  1. I SEG="LREF" D SLPRV(IBIFN,.IBXSAVE,1) G ALLIDSQ
  1. ;JWS;IB*2.0*592;US131
  1. I SEG="LSUR" D SLPRV(IBIFN,.IBXSAVE,6) G ALLIDSQ
  1. I SEG="LSR1" D SLPRV(IBIFN,.IBXSAVE,6) G ALLIDSQ
  1. ;
  1. ALLIDSQ ;
  1. Q
  1. ;
  1. PSID(IBIFN,IBXPROV,IBXIDS) ; Build array of either the Fac/Lab ID or Rendering Provider IDs
  1. ;IB*2.0*473/TAZ - Created a function to standardize IDs in LDAT and LPUR
  1. ; Input:
  1. ; IBXIEN - Internal Entry Number of claim
  1. ; IBXPROV - Provider Array
  1. ; IBXIDS - Array for IDs
  1. ; Output:
  1. ; IBXIDS(0) - Primary ID
  1. ; IBXIDS(1) - Secondary ID
  1. ;
  1. N LINE,PLINE,PID,SID,SIDQ
  1. K IBXIDS
  1. ; Get Lab/Facility IDs
  1. S (PID,SID,SIDQ)=""
  1. S PID=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,0)),U,2)
  1. F LINE=1:1 Q:'$D(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)) D I SID'="" Q
  1. . S SIDQ=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
  1. . S SID=$P($G(IBXPROV("LAB/FAC",IBIFN,"C",1,LINE)),U,2)
  1. I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ G PSIDQ
  1. ; Get Claim Level Rendering Provider IDs
  1. S PID=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,0)),U,4) ; Get claim level Rendering Provider NPI
  1. F LINE=1:1 Q:'$D(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)) D I SID'="" Q
  1. . S SIDQ=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,3) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
  1. . S SID=$P($G(IBXPROV("PROVINF",IBIFN,"C",1,3,LINE)),U,4)
  1. I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ G PSIDQ
  1. ; Get Line Level Rendering Provider IDs
  1. F PLINE=1:1 Q:'$D(IBXPROV("L-PROV",IBIFN,PLINE)) D I $L(PID)!$L(SID) Q
  1. . S PID=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,0)),U,4)
  1. . F LINE=1:1 Q:'$D(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)) D I SID'="" Q
  1. .. S SIDQ=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,3) I ",0B,1G,G2,"'[(","_SIDQ_",") S SIDQ="" Q
  1. .. S SID=$P($G(IBXPROV("L-PROV",IBIFN,PLINE,"C",1,3,LINE)),U,4)
  1. I $L(PID)!$L(SID) S IBXIDS(0)=PID,IBXIDS(1)=SID_U_SIDQ
  1. PSIDQ ;
  1. Q
  1. ;
  1. SLPRV(IBXIEN,IBX,PRTYPE) ;Build SLPRV nodes for the line provider type record
  1. N SLC,DATA,IBCNT,NAME,OUT
  1. S (SLC,IBCNT)=0
  1. F S SLC=$O(IBX("L-PROV",IBXIEN,SLC)) Q:'SLC D
  1. . I '$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE)) Q
  1. . S NAME=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"NAME"))
  1. . S OUT=$P(NAME,U,1,3)_U_$P(NAME,U,5)_U_$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"TAXONOMY"))_U_$P($G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,0)),U,4)
  1. . F IBN=1:1 Q:'$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN)) D
  1. .. S DATA=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
  1. .. I ",0B,1G,G2,LU,"[(","_$P(DATA,U,3)_",") S OUT=OUT_U_$P(DATA,U,4)_U_$P(DATA,U,3)
  1. . S IBCNT=IBCNT+1
  1. . S IBX("SLPRV",IBCNT)=OUT
  1. . S IBX("SLPRV",IBCNT,"SLC")=SLC
  1. SLPRVQ ;
  1. Q
  1. ;
  1. ;PROVIDER
  1. ;Input:
  1. ; IB399 - ien of #399
  1. ; IBPROV:
  1. ; "C"- to get info for CURRENT provider
  1. ; "O"- to get info for all others (in this case the array will contain info fot two providers
  1. ; IBRES - array for results (by reference)
  1. ; IBFRMTYP - Form Type
  1. ; IBCARE - Care Type
  1. ; IBCURR - current bill payer sequence
  1. ;
  1. ;Output:
  1. ; IBRES - array to get back info (by reference)
  1. ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
  1. ; where:
  1. ; IBPROV - see input parameter
  1. ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
  1. ; PRTYPE: Provider type(FUNCTION)
  1. ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
  1. ; PROV : provider/VARIABLEPTR
  1. ; INSUR: Insurance PTR #36 or NONE
  1. ; IDTYPE: ID type
  1. ; ID: ID
  1. ; FORMTYP: Form type 1=UB,2=1500
  1. ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
  1. PROVIDER(IB399,IBPROV,IBRES,IBFRMTYP,IBCARE,IBCURR,IBXDATA) ;
  1. N IBZ,IBRESARR,IBLIMIT
  1. S IBRESARR=""
  1. Q:IBCURR="A" ;PATIENT's bill IB*2.0*447 BI Changes IBPROV to IBCURR
  1. I IBPROV="C" D
  1. . S IBLIMIT=5
  1. . D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. I IBPROV="O" D
  1. . S IBLIMIT=3
  1. . I IBCURR="P" D
  1. .. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. .. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. . I IBCURR="S" D
  1. .. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. .. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. . I IBCURR="T" D
  1. .. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. .. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
  1. M IBRES=IBRESARR
  1. Q
  1. ;
  1. ;-- PROVINF --
  1. ;Create array with prov info
  1. ;Input:
  1. ; IB399 - ien #399
  1. ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
  1. ; IBRES - for results
  1. ; IBSORT - to sort OTHER INSURANCE data
  1. ; if PROVINF is called for "C" mode of PROVIDER subroutine then
  1. ; IBSORT can be any (say 1)
  1. ; if PROVINF is called for "O" mode then can be more than set of data
  1. ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
  1. ; for mode "O" it should be 1 or 2 (see PROVIDER section)
  1. ;IBINSTP - "C" -current ins, "O"-other
  1. ;IBFRMTYP - Form Type
  1. ;IBCARE - Care Type
  1. ;IBLIMIT - Limits on Secondary
  1. ;IBCURR - Current Insurance
  1. ;IBXDAYA - Revenue Code Array
  1. ;Output:
  1. ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
  1. ; where:(see PROVIDER)
  1. PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,IBXDATA) ;
  1. I $G(IB399)="" G PROVINFQ
  1. I $G(IBINSTP)="" G PROVINFQ
  1. I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
  1. N IBPRTYP,IBINSCO,IBPROV,IB35591,IBN,IBEXC
  1. S IBN=0
  1. S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
  1. S IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
  1. S IBPRTYP=0
  1. F S IBPRTYP=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP)) Q:'IBPRTYP D
  1. . N Z,IB355OV,IBPROV,IBARR
  1. . S IBPROV=$$PROVPTR(IB399,IBPRTYP,0),IBEXC=""
  1. . Q:+IBPROV=0
  1. . S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0))
  1. . D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
  1. . M IBRES("PROVINF",IB399,IBINSTP)=IBARR
  1. I $D(IBRES("PROVINF",IB399,IBINSTP,IBSORT))>1 S IBRES("PROVINF",IB399,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
  1. N SLC,CPLNK
  1. S SLC=0
  1. F S SLC=$O(IBXDATA(SLC)) Q:'SLC S IBXSAVE("SLC")=+SLC D
  1. . S CPLNK=$G(IBXDATA(SLC,"CPLNK")) I 'CPLNK Q
  1. . S IBPRTYP=0
  1. . F S IBPRTYP=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP)) Q:'IBPRTYP D
  1. .. N Z,IBPROV,IBARR
  1. .. S IBPROV=$$PROVPTR(IB399,IBPRTYP,CPLNK),IBEXC=""
  1. .. Q:'+IBPROV
  1. .. S Z=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"CP",CPLNK,"LNPRV",Z,0))
  1. .. D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
  1. .. M IBRES("L-PROV",IB399,SLC,IBINSTP)=IBARR
  1. . I $D(IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT))>1 S IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
  1. ;
  1. PROVINFQ ;Exit PROVINF
  1. Q
  1. ;
  1. GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,IBRES,IBPRTYP,IBINSTP,IBD) ;
  1. I "CO"'[$G(IBINSTP) G GETPRVQ
  1. N IBRETARR,IBNPI,IBN,IBMRAND,IB355OV S IBRETARR=0,IB355OV=""
  1. D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
  1. I $P(IBD,U,IBPRNUM+4)'="",$P(IBD,U,IBPRNUM+11)'="" S IB355OV=$P(IBD,U,IBPRNUM+4)_U_$P(IBD,U,IBPRNUM+11)
  1. S IBN=0,IBMRAND=$$MCRONBIL^IBEFUNC(IB399)
  1. ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
  1. I "34"[$G(IBPRTYP),$G(IBFRMTYP)=2,IBMRAND S IB355OV=$$MCR24K^IBCEU3(IB399,IBPROV)_"^12"
  1. I $P(IB355OV,U,2) D
  1. . I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
  1. .. S IBEXC=$P(IB355OV,U,2),IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$P($G(^IBE(355.97,+IBEXC,0)),U,3)_U_$P(IB355OV,U)_"^^^^^"_+IBEXC
  1. I IB35591'="",IBEXC'=$P(IB35591,U,3) I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) D
  1. . S IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
  1. S IBNPI=$$NPI^IBCEFP1(IBPROV)
  1. D SORT^IBCEF77(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
  1. S IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
  1. F IBN=1:1 Q:'$D(IBRES(IBSORT,IBPRTYP,IBN)) S $P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4)=$$STRIP^IBCEF76($P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4),1,U,IBSTRIP)
  1. S IBRES(IBSORT,IBPRTYP,"NAME")=$$NAME^IBCEFP1(IBPROV,IBIFN,$P(IBD,U,3),$P(IBD,U,8))
  1. S IBRES(IBSORT,IBPRTYP,"ENTITY TYPE")=$S(IBPROV'["355.93,":1,$P($G(^IBA(355.93,+IBPROV,0)),U,2)=2:1,1:2)
  1. S IBRES(IBSORT,IBPRTYP,"TAXONOMY")=$$TAXON^IBCEFP1(IBPROV,$P(IBD,U,15))
  1. S IBRES(IBSORT,IBPRTYP,"COBID")=$$COBID^IBCEFP1(IB399,IBPRTYP,IBMRAND,IBD)
  1. S IBRES(IBSORT,IBPRTYP)=IBPROV
  1. GETPRVQ ;
  1. Q
  1. ;
  1. PROVPTR(IBIEN399,IBFUNC,IBCP) ; Retrieve Provider Pointer from appropriate file
  1. N IBN,RSLT
  1. S IBCP=+$G(IBCP)
  1. I 'IBCP D
  1. . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
  1. . I +IBN=0 S RSLT=0 Q
  1. . S RSLT=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),U,2)
  1. I IBCP D
  1. . S IBN=$O(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
  1. . I +IBN=0 S RSLT=0 Q
  1. . S RSLT=$P($G(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
  1. Q RSLT
  1. ;
  1. ;Input:
  1. ;IBXIEN - Internal Entry Number for the current bill/claim
  1. ;IBXSAVE - Array for returning the data
  1. ;
  1. ;Output:
  1. ;IBXSAVE - Data Array
  1. AMB(IBXIEN,IBXSAVE) ; Gather Ambulance Data for AMB Record(s) - IB*2.0*447/TAZ
  1. N NODE,CODE,CNT,IBXDATA
  1. K IBXSAVE("AMB")
  1. F NODE="U5","U6","U7" S IBXDATA=$G(^DGCR(399,IBXIEN,NODE)) I $TR(IBXDATA,U)'="" S IBXSAVE("AMB",NODE)=IBXDATA
  1. S CODE="",CNT=0
  1. F S CODE=$O(^DGCR(399,IBXIEN,"U9","B",CODE)) Q:'CODE D
  1. . S IBXDATA=$P($G(^IBE(353.5,CODE,0)),U,1) I IBXDATA="" Q
  1. . S CNT=CNT+1,IBXSAVE("AMB","U9",CNT)=IBXDATA
  1. Q
  1. ;
  1. SNDS2(IBXDATA,PIECE) ;Determine if a SUB2 record is necessary.
  1. ; Input: IBXDATA
  1. ; May contain data from field 232 of file 399.
  1. ; Output: IBXDATA
  1. ; Returns Output for piece 2 or 3 or 1 for any other piece (like 1.5)
  1. ;Any time that ONE of the following criteria is met we should send a SUB2 record
  1. ; 1. Incoming IBXDATA is not null SEND - Non-VA facility in field 232 of file 399
  1. ; 2. If the service facility is a VA Institution in file 4 or a non-VA facility in file 355.93 SEND
  1. ; 3. Not a switchback payer $$SENDSF^IBCEF79(IBXIEN)'=0 SEND
  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. I IBXDATA="" D
  1. . N Z
  1. . S Z=$P($$B^IBCEF79(IBXIEN),U,3)
  1. . ;S Z1=$$SENDSF^IBCEF79(IBXIEN)
  1. . ;S IBXDATA=$S(Z="":0,'Z1:0,1:1)
  1. . S IBXDATA=$S(Z="":0,1:1)
  1. . Q
  1. I 'IBXDATA S IBXDATA=""
  1. I IBXDATA'="" S IBXDATA=$S(PIECE=2:77,PIECE=3:2,1:1)
  1. Q IBXDATA