| [613] | 1 | IBCEF71 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;31-JUL-03
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**232,155,288,320,349**;21-MAR-94;Build 46
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;---------
|
|---|
| 6 | ;OTHPAYC - from FORMAT code for OP1,OP2 ...
|
|---|
| 7 | ;Input:
|
|---|
| 8 | ;IBXIEN - ien #399
|
|---|
| 9 | ;IBSAVE - "in" array (i.e. IBXSAVE)
|
|---|
| 10 | ;IBDATA - "out" array (i.e. IBXDATA)
|
|---|
| 11 | ;IBFUNC - FUNCTION from #399 (1-refering,2-operating,etc)
|
|---|
| 12 | ;IBVAL - output value
|
|---|
| 13 | ;Output:
|
|---|
| 14 | ; IBDATA with formatted output
|
|---|
| 15 | OTHPAYC(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBVAL) ;
|
|---|
| 16 | N IB1,IB2,IBINS,IBFL
|
|---|
| 17 | S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
|
|---|
| 18 | F IB1=1,2 D
|
|---|
| 19 | . Q:'$$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) ;don't create anything if no such insurance
|
|---|
| 20 | . I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4)
|
|---|
| 21 | . S:$O(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,0)) IBDATA(IB1)=IBVAL
|
|---|
| 22 | Q
|
|---|
| 23 | ;----
|
|---|
| 24 | ;OTHPAYV - called from FORMAT code for OP1,OP2 ...
|
|---|
| 25 | ;Input:
|
|---|
| 26 | ;IBXIEN - ien #399
|
|---|
| 27 | ;IBSAVE - "in" array (i.e. IBXSAVE)
|
|---|
| 28 | ;IBDATA - "out" array (i.e. IBXDATA)
|
|---|
| 29 | ;IBFUNC - FUNCTION from #399 (1-refering, 2-operating, etc)
|
|---|
| 30 | ;IBSEQN - seq # of ID/QUAL
|
|---|
| 31 | ;IBFLDTYP
|
|---|
| 32 | ; "I" - ID "Q" - ID QUAL
|
|---|
| 33 | ;Output:
|
|---|
| 34 | ; IBDATA with formatted output
|
|---|
| 35 | OTHPAYV(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBFLDTYP,IBSEQN) ;
|
|---|
| 36 | N IB1,IB2,IBPIECE,IBINS,IBFL
|
|---|
| 37 | S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
|
|---|
| 38 | S IBPIECE=$S(IBFLDTYP="I":4,IBFLDTYP="Q":3,1:3)
|
|---|
| 39 | F IB1=1,2 D
|
|---|
| 40 | . Q:'$$ISINSUR($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) ;don't create anything if there is no such insurance
|
|---|
| 41 | . I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4),IBFL=0
|
|---|
| 42 | . S IBDATA(IB1)=$P($G(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,IBSEQN)),"^",IBPIECE)
|
|---|
| 43 | Q
|
|---|
| 44 | ;
|
|---|
| 45 | ;chk for ins
|
|---|
| 46 | ;Input:
|
|---|
| 47 | ; IBINS = "P","S","T"
|
|---|
| 48 | ; IBXIEN - ien file #399
|
|---|
| 49 | ;Output:
|
|---|
| 50 | ; returns 1-exists , 0-doesn't
|
|---|
| 51 | ISINSUR(IBINS,IBXIEN) ;
|
|---|
| 52 | N IBINSNOD
|
|---|
| 53 | S IBINSNOD=$S(IBINS="P":"I1",IBINS="S":"I2",IBINS="T":"I3",1:"")
|
|---|
| 54 | I IBINSNOD="" Q 0
|
|---|
| 55 | Q $D(^DGCR(399,IBXIEN,IBINSNOD))
|
|---|
| 56 | ;
|
|---|
| 57 | ;---PRACT----
|
|---|
| 58 | ;Get list of all 355.9 or 355.93 records for prov
|
|---|
| 59 | ;Input:
|
|---|
| 60 | ;IB399INS - ins co for bill to match PRACTIONER from 355.9
|
|---|
| 61 | ;IB399FRM - form type (0=unknwn/both,1=UB,2=1500) to
|
|---|
| 62 | ; match PRACTIONER from 355.9
|
|---|
| 63 | ;IB399CAR - BILL CARE (0=unknwn or both inp/outp,1=inpatient,
|
|---|
| 64 | ; 2=outpatient/3=Rx) to match PROV from 355.9
|
|---|
| 65 | ; OR - DIVISION PTR to file 40.8 for entries in file 355.92
|
|---|
| 66 | ;IBPROV - VARIABLE PTR VA prov
|
|---|
| 67 | ;IBARR - array by reference for result
|
|---|
| 68 | ;IBPROVTP- function (2-operating, 3-RENDERING,etc 0-facility)
|
|---|
| 69 | ;IBINSTP - "C" -current ins , "O"-other
|
|---|
| 70 | ;IBFILE - 355.92 for facility ids or 355.9 (default) for provider ids
|
|---|
| 71 | ;IBINS - 1 if to include ids for the ins co for all provs
|
|---|
| 72 | ;Ouput:
|
|---|
| 73 | ;IBARR - array by ref for result
|
|---|
| 74 | ; prov var ptr^ins ptr^X12 id cd^ID^form typ^care typ or division ptr^st ptr^id rec ptr^id type ptr
|
|---|
| 75 | PRACT(IB399INS,IB399FRM,IB399CAR,IBPROV,IBARR,IBPROVTP,IBINSTP,IBFILE,IBINS) ;
|
|---|
| 76 | N IB1,IB2,IBDAT,IBF,IBFX,IB3559,IBINSCO,IBFRMTYP,IBIDTYP,IBID,IBIDT,IBDIV,IBQ,IBS1,IBS2,IBARRX,Z,Z1,Z2,IBCARE
|
|---|
| 77 | I $G(IBFILE)="" S IBFILE=355.9
|
|---|
| 78 | S IBINS=$G(IBINS)
|
|---|
| 79 | S (IBARR,IB3559,IB1)=0
|
|---|
| 80 | 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
|
|---|
| 81 | . S IBINSCO=$P($G(^IBA(IBFX,IB3559,0)),"^",$S(IBFILE=355.9&(IBF=""):2,1:1)) ;ins co. ptr
|
|---|
| 82 | . I IBINSCO'="" I IBINSCO'=IB399INS Q ;exclude if different ins
|
|---|
| 83 | . S:IBINSCO="" IBINSCO="NONE" ;NONE will be included in the array
|
|---|
| 84 | . S IBFRMTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",4) ;form type (0=both,1=UB,2=1500)
|
|---|
| 85 | . I '(IBFRMTYP=0!(IB399FRM=0)) Q:IBFRMTYP'=IB399FRM ;exclude if not "both" and different
|
|---|
| 86 | . S IBCARE=+$P($G(^IBA(IBFX,IB3559,0)),"^",5) ;0=both(inp and outp),1=inp,2=outp,3=prescr -- OR -- division ptr
|
|---|
| 87 | . I $S(IBFILE=355.92:0,1:IBCARE=3) I IB399CAR'=3 Q ; Id is only for Rx
|
|---|
| 88 | . I $S(IBFILE=355.92:0,1:IBCARE=1!(IBCARE=2)) I IB399CAR=1!(IB399CAR=2) Q:IBCARE'=IB399CAR ;both is OK
|
|---|
| 89 | . I IBFILE=355.92,IBCARE Q:IB399CAR'=IBCARE ; Division doesn't match
|
|---|
| 90 | . S IBIDTYP=+$P($G(^IBA(IBFX,IB3559,0)),"^",6) ;prov ID type
|
|---|
| 91 | . 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
|
|---|
| 92 | . S IBIDT=IBIDTYP
|
|---|
| 93 | . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
|
|---|
| 94 | . Q:$P($G(^IBE(355.97,+IBIDT,1)),U,9)
|
|---|
| 95 | . Q:IBFILE=355.9&(IBIDTYP="X4") ;exclude CLIA #
|
|---|
| 96 | . S IBID=$P($G(^IBA(IBFX,IB3559,0)),"^",7) ;prov ID value
|
|---|
| 97 | . I $G(IBPROVTP)'="",$G(IBINSTP)'="",IBPROVTP'=0 I '$$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) Q ; No qualifier chk for fac
|
|---|
| 98 | . I IBID'="" S IBDAT=IBPROV_"^"_IBINSCO_"^"_IBIDTYP_"^"_IBID_"^"_IBFRMTYP_"^"_IBCARE_"^"_"^"_IB3559_U_IBIDT,IBS2=$S(IBFX'=355.91:"",1:"INS DEF^")_IB3559
|
|---|
| 99 | . I IBFILE'=355.92,IBID'="",IB399CAR=3 S IBQ=0 D Q:IBQ
|
|---|
| 100 | .. I $G(IBARRX(IBIDT))!(IBCARE=1) S IBQ=1 Q
|
|---|
| 101 | .. I IBCARE=3&(IB399CAR=3) S IBARRX(IBIDT)=1 Q ; Rx match
|
|---|
| 102 | .. I IBCARE=0!(IBCARE=2) S IBARRX(IBIDT,IBINSCO,IBS2)=IBDAT,IBQ=1 Q
|
|---|
| 103 | . I IBID'="" S IBARR(IBINSCO,IBS2)=IBDAT
|
|---|
| 104 | ;
|
|---|
| 105 | I IB399CAR=3 S Z=0 F S Z=$O(IBARRX(Z)) Q:'Z I '$G(IBARRX(Z)) D
|
|---|
| 106 | . 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)
|
|---|
| 107 | ;
|
|---|
| 108 | I IBPROV["VA(200," D ; Get lic #s from file 2 for VA providers
|
|---|
| 109 | . N Z,IBLIC
|
|---|
| 110 | . S IBLIC=+IBPROV,IBLIC=$$GETLIC^IBCEP5D(.IBLIC)
|
|---|
| 111 | . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
|
|---|
| 112 | . 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()
|
|---|
| 113 | I IBPROV["IBA(355.93" D
|
|---|
| 114 | . Q:$P($G(^IBA(355.93,+IBPROV,0)),U,12)=""
|
|---|
| 115 | . S IBIDTYP=$P($G(^IBE(355.97,+$$STLIC^IBCEP8(),0)),U,3)
|
|---|
| 116 | . I $$CHCKSEC^IBCEF73(IB399FRM,IBPROVTP,IBINSTP,IBIDTYP) D
|
|---|
| 117 | . . 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
|
|---|
| 118 | Q
|
|---|
| 119 | ;
|
|---|
| 120 | ALLPRFAC(IBXIEN,IBXSAVE) ; Return all non-VA/outside facility prov ids
|
|---|
| 121 | ; and all VA alternate prov ids
|
|---|
| 122 | ; IBXIEN = ien file 399
|
|---|
| 123 | ; IBXSAVE = subscripted array returned
|
|---|
| 124 | N IBPROV,IBFRMTYP,IBCARE,IBRETARR,IBRET1,IBCOBN,Z,Z0,Z1,ZZ
|
|---|
| 125 | K IBXSAVE("PROVINF_FAC",IBXIEN) ; Always rebuild this
|
|---|
| 126 | S IBCOBN=+$$COBN^IBCEF(IBXIEN)
|
|---|
| 127 | S IBFRMTYP=$$FT^IBCEF(IBXIEN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
|
|---|
| 128 | S IBPROV=$P($G(^DGCR(399,IBXIEN,"U2")),U,10)
|
|---|
| 129 | ; IB patch 320 - Build IBPROV variable better when a non-VA facility exists
|
|---|
| 130 | I IBPROV S IBPROV=IBPROV_";IBA(355.93,"
|
|---|
| 131 | I 'IBPROV S IBCARE=$P($G(^DGCR(399,IBXIEN,0)),U,22)
|
|---|
| 132 | I IBPROV D
|
|---|
| 133 | . S IBCARE=$S($$ISRX^IBCEF1(IBXIEN):3,1:0) ;if Rx refill bill
|
|---|
| 134 | . S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBXIEN,1) S:'IBCARE IBCARE=2 ;1-inp, 2-out
|
|---|
| 135 | F Z=1:1:3 K IBRETARR I $G(^DGCR(399,IBXIEN,"I"_Z)) D
|
|---|
| 136 | . 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))
|
|---|
| 137 | . K IBRET1
|
|---|
| 138 | . S Z0="" F S Z0=$O(IBRETARR(Z0)) Q:Z0="" S Z1="" F S Z1=$O(IBRETARR(Z0,Z1)) Q:Z1="" D
|
|---|
| 139 | .. ; Sort by div/id type
|
|---|
| 140 | .. S IBRET1($S(IBPROV:0,1:+$P(IBRETARR(Z0,Z1),U,6)),+$P(IBRETARR(Z0,Z1),U,9))=IBRETARR(Z0,Z1)
|
|---|
| 141 | .. Q
|
|---|
| 142 | . ;
|
|---|
| 143 | . S Z0=$O(IBRET1(""),-1) Q:Z0="" D
|
|---|
| 144 | .. ; IB patch 320 - loop thru all ID's
|
|---|
| 145 | .. S Z1="" F S Z1=$O(IBRET1(Z0,Z1)) Q:Z1="" D
|
|---|
| 146 | ... 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
|
|---|
| 147 | ... S ZZ=$S(Z=1:1,Z=2:(IBCOBN=3)+1,1:2)
|
|---|
| 148 | ... 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)
|
|---|
| 149 | ... Q
|
|---|
| 150 | .. Q
|
|---|
| 151 | . Q
|
|---|
| 152 | ;
|
|---|
| 153 | S IBXSAVE("PROVINF_FAC",IBXIEN)=IBXIEN,IBXSAVE("PROVINF_FAC",IBXIEN,"C",1)=$E("PST",IBCOBN)
|
|---|
| 154 | Q
|
|---|
| 155 | ;
|
|---|
| 156 | OTHID(IBXSAVE,IBXDATA,IBXIEN,PRIDSEQ,PRTYP,IBQ,IBFAC) ; From data in IBXSAVE,
|
|---|
| 157 | ; determine id or qualifier to output in the 837 records OP*
|
|---|
| 158 | ; Returns IBXDATA array IBXDATA(n)=data
|
|---|
| 159 | ; IBXIEN = ien of the bill-file 399
|
|---|
| 160 | ; PRIDSEQ = sequence of the payer id needed
|
|---|
| 161 | ; PRTYP = provider type to check for data
|
|---|
| 162 | ; IBQ = 1 if qualifier needed, 0/null if id needed
|
|---|
| 163 | ; IBFAC = 1 if facility id, 0 for individual provider id
|
|---|
| 164 | ;
|
|---|
| 165 | N Z,Z0,Z1
|
|---|
| 166 | S Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC"),Z1=$S($G(IBQ):3,1:4)
|
|---|
| 167 | S Z=0 F S Z=$O(IBXSAVE("OSQ",Z)) Q:'Z D
|
|---|
| 168 | . 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)
|
|---|
| 169 | Q
|
|---|
| 170 | ;
|
|---|
| 171 | SETSEQ(IBXIEN,IBXSAVE,IBXDATA,PRTYP,IBFAC,IBOP) ; Sets up IBXSAVE("OSQ")
|
|---|
| 172 | ; array for other id seq in 837 records OP*
|
|---|
| 173 | ; Returns IBXDATA(n)=cob seq indicator for ids
|
|---|
| 174 | ; IBXIEN = ien of bill-399
|
|---|
| 175 | ; PRTYP = the provider type to check for data for indiv provider
|
|---|
| 176 | ; IBFAC = 1 if facility id, 0 for individual provider id
|
|---|
| 177 | ; IBOP = segement # in OP being output
|
|---|
| 178 | N C,Z,Z0,Z1,OK
|
|---|
| 179 | S C=0,Z0="PROVINF"_$S('$G(IBFAC):"",1:"_FAC")
|
|---|
| 180 | S:$G(IBFAC) PRTYP=0
|
|---|
| 181 | S Z=0 F S Z=$O(IBXSAVE(Z0,IBXIEN,"O",Z)) Q:'Z S OK=0 D
|
|---|
| 182 | . 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
|
|---|
| 183 | . I OK S C=C+1,IBXSAVE("OSQ",Z)=C
|
|---|
| 184 | 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)_" ")
|
|---|
| 185 | Q
|
|---|
| 186 | ;
|
|---|
| 187 | PSPRV(IBIFN) ;
|
|---|
| 188 | Q $$PSPRV^IBCEF7(IBIFN) ; Moved
|
|---|
| 189 | ;
|
|---|
