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