- 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 Dec 13, 2024@02:10:11 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 ;