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

IBCEF71.m

Go to the documentation of this file.
  1. IBCEF71 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;31-JUL-03
  1. ;;2.0;INTEGRATED BILLING;**232,155,288,320,349,432,592,650**;21-MAR-94;Build 21
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;---------
  1. ;OTHPAYC - from FORMAT code for OP1,OP2 ...
  1. ;Input:
  1. ;IBXIEN - ien #399
  1. ;IBSAVE - "in" array (i.e. IBXSAVE)
  1. ;IBDATA - "out" array (i.e. IBXDATA)
  1. ;IBFUNC - FUNCTION from #399 (1-refering,2-operating,etc)
  1. ;IBVAL - output value
  1. ;Output:
  1. ; IBDATA with formatted output
  1. OTHPAYC(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBVAL) ;
  1. ;OP1-3, OP1-4, OP1A-3, OP1A-4, OP2-3, OP2-4, OP4-3, OP4-4, OP9-3, OP9-4, OP10-3, OP10-4
  1. N IB1,IB2,IBINS,IBFL,XIB1
  1. S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
  1. F IB1=1,2 D
  1. . I $$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) D Q ;don't create anything if no such insurance
  1. .. ;*432/TAZ Attending/Rendering is no longer either/or so there can be both
  1. .. ;I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4)
  1. .. ;JWS;IB*2.0*650;issue with 1st provider having no Insurance Other Payer Operating Phy Sec ID
  1. .. S XIB1=IB1 I $G(IBXPG)=171,IB1=2,'$D(^TMP("IBXDATA",$J,1,171,2,1)) S XIB1=1
  1. .. I $O(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,0)) S IBDATA(XIB1)=IBVAL
  1. Q
  1. ;----
  1. ;OTHPAYV - called from FORMAT code for OP1,OP2 ...
  1. ;Input:
  1. ;IBXIEN - ien #399
  1. ;IBSAVE - "in" array (i.e. IBXSAVE)
  1. ;IBDATA - "out" array (i.e. IBXDATA)
  1. ;IBFUNC - FUNCTION from #399 (1-refering, 2-operating, etc)
  1. ;IBSEQN - seq # of ID/QUAL
  1. ;IBFLDTYP
  1. ; "I" - ID "Q" - ID QUAL
  1. ;Output:
  1. ; IBDATA with formatted output
  1. OTHPAYV(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBFLDTYP,IBSEQN) ;
  1. ;OP1-5, OP1-6, OP1-7, OP1-8, OP1-9, OP1-10, OP1A-5, OP1A-6, OP1A-7, OP1A-8, OP1A-9, OP1-10A, OP2-5, OP2-6,
  1. ;OP2-7, OP2-8, OP2-9, OP2-10, OP4-5, OP4-6, OP4-7, OP4-8, OP4-9, OP4-10, OP9-5, OP9-6, OP9-7, OP9-8, OP9-9, OP9-10
  1. ;OP10-5, OP10-6, OP10-7, OP10-8, OP10-9, OP10-10
  1. N IB1,IB2,IBPIECE,IBINS,IBFL,XIB1
  1. S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
  1. S IBPIECE=$S(IBFLDTYP="I":4,IBFLDTYP="Q":3,1:3)
  1. F IB1=1,2 D
  1. . ;JWS;IB*2.0*592; no sec id for Dental
  1. . I $$FT^IBCEF(IBXIEN)=7 Q
  1. . I $$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) D Q ;don't create anything if there is no such insurance
  1. .. ;*432/TAZ Attending/Rendering is no longer either/or so there can be both
  1. .. ;I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4),IBFL=0
  1. .. ;JWS;IB*2.0*650;issue with 1st provider having no Insurance Other Payer Operating Phy Sec ID
  1. .. S XIB1=IB1 I $G(IBXPG)=171,IB1=2,'$D(^TMP("IBXDATA",$J,1,171,2,1)) S XIB1=1
  1. .. S IBDATA(XIB1)=$P($G(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,IBSEQN)),U,IBPIECE)
  1. Q
  1. ;
  1. ;chk for ins
  1. ;Input:
  1. ; IBINS = "P","S","T"
  1. ; IBXIEN - ien file #399
  1. ;Output:
  1. ; returns 1-exists , 0-doesn't
  1. ISINSUR(IBINS,IBXIEN) ;
  1. N IBINSNOD
  1. S IBINSNOD=$S(IBINS="P":"I1",IBINS="S":"I2",IBINS="T":"I3",1:"")
  1. I IBINSNOD="" Q 0
  1. Q $D(^DGCR(399,IBXIEN,IBINSNOD))
  1. ;
  1. ;---PRACT----
  1. ;Get list of all 355.9 or 355.93 records for prov
  1. ;Input:
  1. ;IB399INS - ins co for bill to match PRACTIONER from 355.9
  1. ;IB399FRM - form type (0=unknwn/both,1=UB,2=1500) to match PRACTIONER from 355.9
  1. ;IB399CAR - BILL CARE (0=unknwn or both inp/outp,1=inpatient,
  1. ; 2=outpatient/3=Rx) to match PROV from 355.9
  1. ; OR - DIVISION PTR to file 40.8 for entries in file 355.92
  1. ;IBPROV - VARIABLE PTR VA prov
  1. ;IBARR - array by reference for result
  1. ;IBPROVTP- function (2-operating, 3-RENDERING,etc 0-facility)
  1. ;IBINSTP - "C" -current ins , "O"-other
  1. ;IBFILE - 355.92 for facility ids or 355.9 (default) for provider ids
  1. ;IBINS - 1 if to include ids for the ins co for all provs
  1. ;Ouput:
  1. ;IBARR - array by ref for result
  1. ; prov var ptr^ins ptr^X12 id cd^ID^form typ^care typ or division ptr^st ptr^id rec ptr^id type ptr
  1. PRACT(IB399INS,IB399FRM,IB399CAR,IBPROV,IBARR,IBPROVTP,IBINSTP,IBFILE,IBINS) ;
  1. N IB1,IB2,IBDAT,IBF,IBFX,IB3559,IBINSCO,IBFRMTYP,IBIDTYP,IBID,IBIDT,IBDIV,IBQ,IBS1,IBS2,IBARRX,Z,Z1,Z2,IBCARE
  1. I $G(IBFILE)="" S IBFILE=355.9
  1. S IBINS=$G(IBINS)
  1. S (IBARR,IB3559,IB1)=0
  1. F IBF="",1 Q:IBF=1&$S(IBFILE'=355.9:1,1:'IBINS) S IBFX=IBFILE_IBF F IB2=1:1 S IB3559=$O(^IBA(IBFX,"B",$S(IBFILE=355.9&(IBF=""):IBPROV,1:IB399INS),IB3559)) Q:IB3559="" D
  1. . S IBINSCO=$P($G(^IBA(IBFX,IB3559,0)),"^",$S(IBFILE=355.9&(IBF=""):2,1:1)) ;ins co. ptr
  1. . I IBINSCO'="" I IBINSCO'=IB399INS Q ;exclude if different ins
  1. . S:IBINSCO="" IBINSCO="NONE" ;NONE will be included in the array
  1. . S IBFRMTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",4) ;form type (0=both,1=UB,2=1500)
  1. . ;JWS;IB*2.0*592 - if dental, no secondary id's
  1. . I IB399FRM=7 Q
  1. . I '(IBFRMTYP=0!(IB399FRM=0)) Q:IBFRMTYP'=IB399FRM ;exclude if not "both" and different
  1. . S IBCARE=+$P($G(^IBA(IBFX,IB3559,0)),"^",5) ;0=both(inp and outp),1=inp,2=outp,3=prescr -- OR -- division ptr
  1. . I $S(IBFILE=355.92:0,1:IBCARE=3) I IB399CAR'=3 Q ; Id is only for Rx
  1. . I $S(IBFILE=355.92:0,1:IBCARE=1!(IBCARE=2)) I IB399CAR=1!(IB399CAR=2) Q:IBCARE'=IB399CAR ;both is OK
  1. . I IBFILE=355.92,IBCARE Q:IB399CAR'=IBCARE ; Division doesn't match
  1. . S IBIDTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",6) ;prov ID type
  1. . I IBFILE=355.9,IBIDTYP=$$TAXID^IBCEP8(),$S(IBPROV["VA(200":1,1:$P($G(^IBA(355.93,+IBPROV,0)),U,2)=2) Q ; Don't extract tax id # id for indiv prov
  1. . S IBIDT=IBIDTYP
  1. . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
  1. . Q:$P($G(^IBE(355.97,+IBIDT,1)),U,9)
  1. . Q:IBFILE=355.9&(IBIDTYP="X4") ;exclude CLIA #
  1. . S IBID=$P($G(^IBA(IBFX,IB3559,0)),"^",7) ;prov ID value
  1. . I $G(IBPROVTP)'="",$G(IBINSTP)'="",IBPROVTP'=0 I '$$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) Q ; No qualifier chk for fac
  1. . I IBID'="" S IBDAT=IBPROV_"^"_IBINSCO_"^"_IBIDTYP_"^"_IBID_"^"_IBFRMTYP_"^"_IBCARE_"^"_"^"_IB3559_U_IBIDT,IBS2=$S(IBFX'=355.91:"",1:"INS DEF^")_IB3559
  1. . I IBFILE'=355.92,IBID'="",IB399CAR=3 S IBQ=0 D Q:IBQ
  1. .. I $G(IBARRX(IBIDT))!(IBCARE=1) S IBQ=1 Q
  1. .. I IBCARE=3&(IB399CAR=3) S IBARRX(IBIDT)=1 Q ; Rx match
  1. .. I IBCARE=0!(IBCARE=2) S IBARRX(IBIDT,IBINSCO,IBS2)=IBDAT,IBQ=1 Q
  1. . I IBID'="" S IBARR(IBINSCO,IBS2)=IBDAT
  1. ;
  1. I IB399CAR=3 S Z=0 F S Z=$O(IBARRX(Z)) Q:'Z I '$G(IBARRX(Z)) D
  1. . S Z1="" F S Z1=$O(IBARRX(Z,Z1)) Q:Z1="" S Z2="" F S Z2=$O(IBARRX(Z,Z1,Z2)) Q:Z2="" S IBARR(Z1,Z2)=IBARRX(Z,Z1,Z2)
  1. ;
  1. I IBPROV["VA(200," D ; Get lic #s from file 2 for VA providers
  1. . N Z,IBLIC
  1. . ;JWS;IB*2.0*592 - if dental, no secondary id's
  1. . I IB399FRM=7 Q
  1. . S IBLIC=+IBPROV,IBLIC=$$GETLIC^IBCEP5D(.IBLIC)
  1. . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
  1. . S Z=0 F S Z=$O(IBLIC(Z)) Q:'Z S:$$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) IBARR("NONE","LIC"_Z_"^"_IBPROV)=IBPROV_U_"NONE"_U_IBIDTYP_U_IBLIC(Z)_U_"0"_U_"0"_U_Z_U_U_+$$STLIC^IBCEP8()
  1. I IBPROV["IBA(355.93" D
  1. . ;JWS;IB*2.0*592 - if dental, no secondary id's
  1. . I IB399FRM=7 Q
  1. . Q:$P($G(^IBA(355.93,+IBPROV,0)),U,12)=""
  1. . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
  1. . I $$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) D
  1. . . S IBARR("NONE","LIC"_$P($G(^DIC(5,+$P(^IBA(355.93,+IBPROV,0),U,7),0)),U,2)_"^"_IBPROV)=IBPROV_U_"NONE"_U_IBIDTYP_U_$P(^IBA(355.93,+IBPROV,0),U,12)_U_"0"_U_"0"_U_$P(^IBA(355.93,+IBPROV,0),U,7)_U_U_+IBPROV
  1. Q
  1. ;
  1. ALLPRFAC(IBXIEN,IBXSAVE) ; Return all non-VA/outside facility prov ids
  1. ; and all VA alternate prov ids
  1. ; IBXIEN = ien file 399
  1. ; IBXSAVE = subscripted array returned
  1. N IBPROV,IBFRMTYP,IBCARE,IBRETARR,IBRET1,IBCOBN,Z,Z0,Z1,ZZ
  1. K IBXSAVE("PROVINF_FAC",IBXIEN) ; Always rebuild this
  1. S IBCOBN=+$$COBN^IBCEF(IBXIEN)
  1. ;JWS;IB*2.0*592;Dental form 7 - no sec provider ids
  1. S IBFRMTYP=$$FT^IBCEF(IBXIEN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
  1. S IBPROV=$P($G(^DGCR(399,IBXIEN,"U2")),U,10)
  1. ; IB patch 320 - Build IBPROV variable better when a non-VA facility exists
  1. I IBPROV S IBPROV=IBPROV_";IBA(355.93,"
  1. I 'IBPROV S IBCARE=$P($G(^DGCR(399,IBXIEN,0)),U,22)
  1. I IBPROV D
  1. . S IBCARE=$S($$ISRX^IBCEF1(IBXIEN):3,1:0) ;if Rx refill bill
  1. . S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBXIEN,1) S:'IBCARE IBCARE=2 ;1-inp, 2-out
  1. F Z=1:1:3 K IBRETARR I $G(^DGCR(399,IBXIEN,"I"_Z)) D
  1. . D PRACT(+^DGCR(399,IBXIEN,"I"_Z),IBFRMTYP,IBCARE,IBPROV,.IBRETARR,0,$S(Z=IBCOBN:"C",1:"O"),$S('IBPROV:355.92,1:355.9))
  1. . K IBRET1
  1. . S Z0="" F S Z0=$O(IBRETARR(Z0)) Q:Z0="" S Z1="" F S Z1=$O(IBRETARR(Z0,Z1)) Q:Z1="" D
  1. .. ; Sort by div/id type
  1. .. S IBRET1($S(IBPROV:0,1:+$P(IBRETARR(Z0,Z1),U,6)),+$P(IBRETARR(Z0,Z1),U,9))=IBRETARR(Z0,Z1)
  1. .. Q
  1. . ;
  1. . S Z0=$O(IBRET1(""),-1) Q:Z0="" D
  1. .. ; IB patch 320 - loop thru all ID's
  1. .. S Z1="" F S Z1=$O(IBRET1(Z0,Z1)) Q:Z1="" D
  1. ... I Z=IBCOBN S IBXSAVE("PROVINF_FAC",IBXIEN,"C",1,0,$O(IBXSAVE("PROVINF_FAC",IBXIEN,"C",1,0," "),-1)+1)=IBRET1(Z0,Z1) Q
  1. ... S ZZ=$S(Z=1:1,Z=2:(IBCOBN=3)+1,1:2)
  1. ... S IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ,0,$O(IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ,0," "),-1)+1)=IBRET1(Z0,Z1),IBXSAVE("PROVINF_FAC",IBXIEN,"O",ZZ)=$E("PST",Z)
  1. ... Q
  1. .. Q
  1. . Q
  1. ;
  1. S IBXSAVE("PROVINF_FAC",IBXIEN)=IBXIEN,IBXSAVE("PROVINF_FAC",IBXIEN,"C",1)=$E("PST",IBCOBN)
  1. Q
  1. ;
  1. OTHID(IBXSAVE,IBXDATA,IBXIEN,PRIDSEQ,PRTYP,IBQ,IBFAC) ; From data in IBXSAVE,
  1. ; determine id or qualifier to output in the 837 records OP*
  1. ; Returns IBXDATA array IBXDATA(n)=data
  1. ; IBXIEN = ien of the bill-file 399
  1. ; PRIDSEQ = sequence of the payer id needed
  1. ; PRTYP = provider type to check for data
  1. ; IBQ = 1 if qualifier needed, 0/null if id needed
  1. ; IBFAC = 1 if facility id, 0 for individual provider id
  1. ;
  1. N Z,Z0,Z1
  1. S Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC"),Z1=$S($G(IBQ):3,1:4)
  1. S Z=0 F S Z=$O(IBXSAVE("OSQ",Z)) Q:'Z D
  1. . I $P($G(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),+$G(PRIDSEQ))),U,4)'="" S IBXDATA(IBXSAVE("OSQ",Z))=$P(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),+$G(PRIDSEQ)),U,Z1)
  1. Q
  1. ;
  1. SETSEQ(IBXIEN,IBXSAVE,IBXDATA,PRTYP,IBFAC,IBOP) ; Sets up IBXSAVE("OSQ")
  1. ; array for other id seq in 837 records OP*
  1. ; Returns IBXDATA(n)=cob seq indicator for ids
  1. ; IBXIEN = ien of bill-399
  1. ; PRTYP = the provider type to check for data for indiv provider
  1. ; IBFAC = 1 if facility id, 0 for individual provider id
  1. ; IBOP = segement # in OP being output
  1. N C,Z,Z0,Z1,OK
  1. S C=0,Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC")
  1. S:$G(IBFAC) PRTYP=0
  1. S Z=0 F S Z=$O(IBXSAVE(Z0,IBXIEN,"O",Z)) Q:'Z S OK=0 D
  1. . N Z1 F Z1=1:1 Q:'$D(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),Z1)) I $P(IBXSAVE(Z0,IBXIEN,"O",Z,+$G(PRTYP),Z1),U,4)'="""" S OK=1 Q
  1. . I OK S C=C+1,IBXSAVE("OSQ",Z)=C
  1. S Z=0 F S Z=$O(IBXSAVE("OSQ",Z)) Q:'Z S IBXDATA(IBXSAVE("OSQ",Z))=$G(IBXSAVE(Z0,IBXIEN,"O",Z)) D:IBXSAVE("OSQ",Z)>1 ID^IBCEF2(IBXSAVE("OSQ",Z),"OP"_$G(IBOP)_" ")
  1. Q
  1. ;
  1. PSPRV(IBIFN) ;
  1. Q $$PSPRV^IBCEF7(IBIFN) ; Moved
  1. ;
  1. OP22 ;Output Formatter 364.7 extract code, OP2-2
  1. ;
  1. K IBXSAVE("OSQ") N C,Z,Q,OK M Q=IBXSAVE("PROVINF",IBXIEN,"O")
  1. S (C,Z)=0 F S Z=$O(Q(Z)) Q:'Z S OK=0 D
  1. . N A F A=1:1 Q:'$D(Q(Z,2,A)) I $P(Q(Z,2,A),U,4)'="" S OK=1 Q
  1. . I OK D
  1. .. I Z>1,'$D(IBXDATA(1))
  1. .. S C=C+1,IBXDATA(C)=$G(Q(Z)),IBXSAVE("OSQ",Z)=C I C>1 D ID^IBCEF2(C,"OP2 ")
  1. . Q
  1. Q
  1. ;