IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ;30 Aug 2006 10:38 AM
;;2.0;INTEGRATED BILLING;**343,374,395,391,400,432,516,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
Q
;
PROVNPI(IBIEN399,IBNONPI) ;
;Retrieves NPIs from #200 or 355.93
; Input:
; IBIEN399 - IEN of record in BILL/CLAIMS file 399
; IBNONPI - variable to pass info on missing NPI to calling routine. Pass by reference
; Output:
; NPI codes for all providers
; IBNONPI - U-delimited list of provider types with missing NPIs
N IBRETVAL,IBPTR,IBFT
S IBRETVAL="",IBNONPI=""
F IBFT=1:1:9 D
. S IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT)
. I IBPTR S $P(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR)
Q IBRETVAL
GETNPI(IBPTR) ;look for NPI in #200 or #355.93
;Input: IBPTR from 399.0222, field .02
;Output: NPI
;if in file #200
N NPI
S NPI=""
;if in 200 then get it from 200
I $P(IBPTR,";",2)="VA(200," S NPI=$P($$NPI^XUSNPI("Individual_ID",$P(IBPTR,";")),U) S:NPI<1 NPI=""
;if in 355.93 then use 355.93
I $P(IBPTR,";",2)="IBA(355.93," S NPI=$$NPIGET^IBCEP81($P(IBPTR,";"))
I NPI="",$D(IBNONPI) S IBNONPI=$S(IBNONPI="":IBFT,1:IBNONPI_U_IBFT)
Q NPI
;
SPECTAX(IBIEN399,IBNOSPEC) ;
;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399
; Input:
; IBIEN399 - IEN of record in BILL/CLAIMS file 399
; IBNOSPEC - variable to pass info on missing taxonomies to calling routine. Pass by reference
; Output:
; Taxonomy Specialty Codes for all providers
; IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes
N IBRETVAL,IBN,IBFT,IBSPEC,SPEC
S IBRETVAL="",IBNOSPEC=""
I $G(IBIEN399)="" Q ""
F IBFT=1:1:9 D
. S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
. I +IBN=0 Q
. S IBSPEC=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
. S SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE")
. S $P(IBRETVAL,"^",IBFT)=SPEC
. I SPEC="",$D(IBNOSPEC) S IBNOSPEC=$S(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT)
Q IBRETVAL
;
PROVTAX(IBIEN399,IBNOTAX) ;
;Retrieves Current Taxonomy entries for a claim from #399
; Input:
; IBIEN399 - IEN of record in BILL/CLAIMS file 399
; IBNOTAX - variable to pass info on missing taxonomies to calling routine. Pass by reference
; Output:
; Taxonomy X12 codes for all providers
; IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes
N IBRETVAL,IBN,IBFT,IBTAX,TAX
S IBRETVAL="",IBNOTAX=""
I $G(IBIEN399)="" Q ""
F IBFT=1:1:9 D
. S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
. I +IBN=0 Q
. S IBTAX=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
. S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
. S $P(IBRETVAL,"^",IBFT)=TAX
. I TAX="",$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT)
Q IBRETVAL
GETTAX(IBPTR,IBDTEV) ;look for Taxonomy in #200 or #355.93
;Input: IBPTR from 399.0222, field .02, IBDTEV from 399, field .03
; IBPTR can be from 399.0404, field .02, as well (DEM;432)
;Output: Taxonomy X12 code_"^"_IEN
N TAX,IBX12
S TAX="^",IBX12=""
S:'$G(IBDTEV) IBDTEV=DT
;if in 200 then get it from 200
I $P(IBPTR,";",2)="VA(200," S IBX12=$P($$GET^XUA4A72($P(IBPTR,";"),IBDTEV),U,1),TAX=$S(IBX12'>0:TAX,1:$$GET1^DIQ(8932.1,IBX12,6)_U_IBX12)
;if in 355.93 then use 355.93
I $P(IBPTR,";",2)="IBA(355.93," S TAX=$$TAXGET^IBCEP81($P(IBPTR,";"))
Q TAX
;
ORGNPI(IBIEN399,IBNONPI) ; Extract NPIs for organizations on this claim
; Input
; IBIEN399 - Claim IEN in file 399
; IBNONPI - Variable to pass info on missing NPI back to calling routine. Pass by reference.
; Output - NPI codes for facilities
; Piece 1) Service Facility NPI code (with IB patch 400, a claim may not have a service facility)
; Piece 2) Non-VA Service Facility NPI code
; Piece 3) Billing Provider NPI code (IB patch 400 definition)
;
N IBRETVAL,IBORG,IBEVDT,IBDIV,NPI,BSZ
S IBNONPI=""
I $G(IBIEN399)="" Q ""
S IBRETVAL=""
S BSZ=$$B^IBCEF79(IBIEN399) ; get billing provider/service facility information
;
; MRD;IB*2.0*516 - The field used as the switchback flag is being
; marked for deletion, to be deleted after 3/15/2018. That flag
; will now always be null. The following section of code was
; commented out because of this. This section can be deleted in
; the future.
;
;S SWBCK=(+$$INSFLGS^IBCEF79(IBIEN399)>0) ; pre-patch 400 switchback flag & processing
;I SWBCK D G ORGNPIX
;. N PHARM,DPORG,PHARMNPI
;. S PHARM=+$$ISRX^IBCEF1(IBIEN399) ; pharmacy claim flag switchback
;. S PHARMNPI=""
;. I PHARM S DPORG=$$RXSITE(IBIEN399) I DPORG S PHARMNPI=$P($$NPI^XUSNPI("Organization_ID",DPORG),U,1)
;. ;
;. ; service facility NPI switchback
;. S NPI=""
;. S IBORG=+$P(BSZ,U,4) ; service facility ien (either ptr file 4 or 355.93)
;. I $P(BSZ,U,3)=0,IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1) ; file 4
;. I $P(BSZ,U,3)=1,IBORG S NPI=$$NPIGET^IBCEP81(IBORG) ; file 355.93
;. I PHARM S NPI=PHARMNPI ; in switchback mode for pharmacy claims, use the pharmacy NPI
;. I NPI>0 S $P(IBRETVAL,U,1)=NPI
;. I NPI<1 S IBNONPI=1
;. ;
;. ; non-VA facility NPI switchback
;. S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
;. I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2)
;. ;
;. ; billing provider NPI switchback
;. S IBORG=+$P(BSZ,U,1),NPI=""
;. I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
;. I PHARM S NPI=PHARMNPI ; in switchback mode for pharmacy claims, use the pharmacy NPI
;. I NPI>0 S $P(IBRETVAL,U,3)=NPI
;. I NPI<1 S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
;. ;
;. Q
;
; service facility NPI regular
S NPI=""
S IBORG=+$P(BSZ,U,4) ; service facility ien (either ptr file 4 or 355.93)
I $P(BSZ,U,3)=0,IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1) ; file 4
I $P(BSZ,U,3)=1,IBORG S NPI=$$NPIGET^IBCEP81(IBORG) ; file 355.93
I NPI>0 S $P(IBRETVAL,U,1)=NPI
I NPI<1,$P(BSZ,U,3)=1 S IBNONPI=1 ; only report missing service facility NPI for non-VA facilities
;
; non-VA facility NPI regular
S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
; Let this one (#2) override #1 if both #1 and #2 are missing
I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI S IBNONPI=2
;
; billing provider NPI regular
S IBORG=+$P(BSZ,U,1),NPI=""
I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1) S:NPI>0 $P(IBRETVAL,U,3)=NPI
I NPI<1 S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
;
;ORGNPIX ; MRD;IB*2.0*516 - Delete this label when deleting
; above code commented out.
;
Q IBRETVAL
;
ORGTAX(IBIEN399,IBNOTAX) ; Extract Taxonomies for organizations on this claim
; Input
; IBIEN399 - Claim IEN in file 399
; IBNOTAX - Variable to pass info on missing taxonomies back to calling routine. Pass by reference.
; Output - Taxonomy X12 codes for facilities
; Piece 1) Service Facility Taxonomy X12 code (with IB patch 400, a claim may not have a service facility)
; Piece 2) Non-VA Service Facility Taxonomy X12 code
; Piece 3) Billing Provider Taxonomy X12 code (IB patch 400 definition)
N IBRETVAL,IBTAX,TAX,BSZ
;
S BSZ=$$B^IBCEF79(IBIEN399) ; get billing provider/service facility information
;
; claim field# 243 - service facility taxonomy code
I $P(BSZ,U,3)="" S (IBTAX,TAX)="" ; no service facility
I $P(BSZ,U,3)'="" S IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I"),TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
S $P(IBRETVAL,U,1)=TAX
; only record service facility taxonomy code missing if there is a service facility
I '$L(TAX),$D(IBNOTAX),$P(BSZ,U,3)'="" S IBNOTAX=1
;
; claim field# 244 - non-VA facility taxonomy code
S IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I")
S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
S $P(IBRETVAL,U,2)=TAX
I '$L(TAX),$$GET1^DIQ(399,IBIEN399_",",232,"I"),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":2,1:IBNOTAX_U_2)
;
; claim field# 252 - billing provider taxonomy code
S IBTAX=$$GET1^DIQ(399,IBIEN399_",",252,"I")
S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
;JWS;IB*2.0*592; if a Dental Claim, never send Billing Provider Taxonomy, since different from Rendering/Assistant Surgeon
I $$FT^IBCEF(IBIEN399)=7 S TAX=""
S $P(IBRETVAL,U,3)=TAX
I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3)
;JWS;IB*2.0*592; if a Dental Claim, never send Billing Provider Taxonomy, since different from Rendering/Assistant Surgeon
I $$FT^IBCEF(IBIEN399)=7 S IBNOTAX=""
Q IBRETVAL
;
RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer
; for the given bill. If IBLIST passed by reference, then a list of
; the possible organizations are returned for a bill, since a bill may
; have more than one prescription. If more than one rx on the bill, the
; $$ return is the pointer of the last prescription found.
; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer)
;
N IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN
K ^TMP($J,"IBCEF73A")
S IBORG=0,DFN=$P($G(^DGCR(399,IBIEN399,0)),"^",2),IBLIST="IBCEF73A"
S IBRXN=0 F S IBRXN=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN)) Q:'IBRXN S IBX=0 F S IBX=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX)) Q:'IBX D
. S IBDATA=$G(^IBA(362.4,IBX,0))
. S IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) Q:'IBRX!('IBDT)
. D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
. I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,22)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,20))) Q
. S IBY=0 F S IBY=$O(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY)) Q:'IBY I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,.01)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,8))) Q
K ^TMP($J,"IBCEF73A")
Q IBORG
;
PSONPI(IB59IEN) ; returns institution ien for a file 59 ien
N IB4IEN
K ^TMP($J,"IBCEF59")
D PSS^PSO59(IB59IEN,,"IBCEF59")
S IB4IEN=+$G(^TMP($J,"IBCEF59",IB59IEN,101))
K ^TMP($J,"IBCEF59")
Q IB4IEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF73A 10178 printed Oct 16, 2024@18:10:55 Page 2
IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ;30 Aug 2006 10:38 AM
+1 ;;2.0;INTEGRATED BILLING;**343,374,395,391,400,432,516,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
PROVNPI(IBIEN399,IBNONPI) ;
+1 ;Retrieves NPIs from #200 or 355.93
+2 ; Input:
+3 ; IBIEN399 - IEN of record in BILL/CLAIMS file 399
+4 ; IBNONPI - variable to pass info on missing NPI to calling routine. Pass by reference
+5 ; Output:
+6 ; NPI codes for all providers
+7 ; IBNONPI - U-delimited list of provider types with missing NPIs
+8 NEW IBRETVAL,IBPTR,IBFT
+9 SET IBRETVAL=""
SET IBNONPI=""
+10 FOR IBFT=1:1:9
Begin DoDot:1
+11 SET IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT)
+12 IF IBPTR
SET $PIECE(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR)
End DoDot:1
+13 QUIT IBRETVAL
GETNPI(IBPTR) ;look for NPI in #200 or #355.93
+1 ;Input: IBPTR from 399.0222, field .02
+2 ;Output: NPI
+3 ;if in file #200
+4 NEW NPI
+5 SET NPI=""
+6 ;if in 200 then get it from 200
+7 IF $PIECE(IBPTR,";",2)="VA(200,"
SET NPI=$PIECE($$NPI^XUSNPI("Individual_ID",$PIECE(IBPTR,";")),U)
if NPI<1
SET NPI=""
+8 ;if in 355.93 then use 355.93
+9 IF $PIECE(IBPTR,";",2)="IBA(355.93,"
SET NPI=$$NPIGET^IBCEP81($PIECE(IBPTR,";"))
+10 IF NPI=""
IF $DATA(IBNONPI)
SET IBNONPI=$SELECT(IBNONPI="":IBFT,1:IBNONPI_U_IBFT)
+11 QUIT NPI
+12 ;
SPECTAX(IBIEN399,IBNOSPEC) ;
+1 ;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399
+2 ; Input:
+3 ; IBIEN399 - IEN of record in BILL/CLAIMS file 399
+4 ; IBNOSPEC - variable to pass info on missing taxonomies to calling routine. Pass by reference
+5 ; Output:
+6 ; Taxonomy Specialty Codes for all providers
+7 ; IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes
+8 NEW IBRETVAL,IBN,IBFT,IBSPEC,SPEC
+9 SET IBRETVAL=""
SET IBNOSPEC=""
+10 IF $GET(IBIEN399)=""
QUIT ""
+11 FOR IBFT=1:1:9
Begin DoDot:1
+12 SET IBN=$ORDER(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
+13 IF +IBN=0
QUIT
+14 SET IBSPEC=$PIECE($GET(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
+15 SET SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE")
+16 SET $PIECE(IBRETVAL,"^",IBFT)=SPEC
+17 IF SPEC=""
IF $DATA(IBNOSPEC)
SET IBNOSPEC=$SELECT(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT)
End DoDot:1
+18 QUIT IBRETVAL
+19 ;
PROVTAX(IBIEN399,IBNOTAX) ;
+1 ;Retrieves Current Taxonomy entries for a claim from #399
+2 ; Input:
+3 ; IBIEN399 - IEN of record in BILL/CLAIMS file 399
+4 ; IBNOTAX - variable to pass info on missing taxonomies to calling routine. Pass by reference
+5 ; Output:
+6 ; Taxonomy X12 codes for all providers
+7 ; IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes
+8 NEW IBRETVAL,IBN,IBFT,IBTAX,TAX
+9 SET IBRETVAL=""
SET IBNOTAX=""
+10 IF $GET(IBIEN399)=""
QUIT ""
+11 FOR IBFT=1:1:9
Begin DoDot:1
+12 SET IBN=$ORDER(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
+13 IF +IBN=0
QUIT
+14 SET IBTAX=$PIECE($GET(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
+15 SET TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
+16 SET $PIECE(IBRETVAL,"^",IBFT)=TAX
+17 IF TAX=""
IF $DATA(IBNOTAX)
SET IBNOTAX=$SELECT(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT)
End DoDot:1
+18 QUIT IBRETVAL
GETTAX(IBPTR,IBDTEV) ;look for Taxonomy in #200 or #355.93
+1 ;Input: IBPTR from 399.0222, field .02, IBDTEV from 399, field .03
+2 ; IBPTR can be from 399.0404, field .02, as well (DEM;432)
+3 ;Output: Taxonomy X12 code_"^"_IEN
+4 NEW TAX,IBX12
+5 SET TAX="^"
SET IBX12=""
+6 if '$GET(IBDTEV)
SET IBDTEV=DT
+7 ;if in 200 then get it from 200
+8 IF $PIECE(IBPTR,";",2)="VA(200,"
SET IBX12=$PIECE($$GET^XUA4A72($PIECE(IBPTR,";"),IBDTEV),U,1)
SET TAX=$SELECT(IBX12'>0:TAX,1:$$GET1^DIQ(8932.1,IBX12,6)_U_IBX12)
+9 ;if in 355.93 then use 355.93
+10 IF $PIECE(IBPTR,";",2)="IBA(355.93,"
SET TAX=$$TAXGET^IBCEP81($PIECE(IBPTR,";"))
+11 QUIT TAX
+12 ;
ORGNPI(IBIEN399,IBNONPI) ; Extract NPIs for organizations on this claim
+1 ; Input
+2 ; IBIEN399 - Claim IEN in file 399
+3 ; IBNONPI - Variable to pass info on missing NPI back to calling routine. Pass by reference.
+4 ; Output - NPI codes for facilities
+5 ; Piece 1) Service Facility NPI code (with IB patch 400, a claim may not have a service facility)
+6 ; Piece 2) Non-VA Service Facility NPI code
+7 ; Piece 3) Billing Provider NPI code (IB patch 400 definition)
+8 ;
+9 NEW IBRETVAL,IBORG,IBEVDT,IBDIV,NPI,BSZ
+10 SET IBNONPI=""
+11 IF $GET(IBIEN399)=""
QUIT ""
+12 SET IBRETVAL=""
+13 ; get billing provider/service facility information
SET BSZ=$$B^IBCEF79(IBIEN399)
+14 ;
+15 ; MRD;IB*2.0*516 - The field used as the switchback flag is being
+16 ; marked for deletion, to be deleted after 3/15/2018. That flag
+17 ; will now always be null. The following section of code was
+18 ; commented out because of this. This section can be deleted in
+19 ; the future.
+20 ;
+21 ;S SWBCK=(+$$INSFLGS^IBCEF79(IBIEN399)>0) ; pre-patch 400 switchback flag & processing
+22 ;I SWBCK D G ORGNPIX
+23 ;. N PHARM,DPORG,PHARMNPI
+24 ;. S PHARM=+$$ISRX^IBCEF1(IBIEN399) ; pharmacy claim flag switchback
+25 ;. S PHARMNPI=""
+26 ;. I PHARM S DPORG=$$RXSITE(IBIEN399) I DPORG S PHARMNPI=$P($$NPI^XUSNPI("Organization_ID",DPORG),U,1)
+27 ;. ;
+28 ;. ; service facility NPI switchback
+29 ;. S NPI=""
+30 ;. S IBORG=+$P(BSZ,U,4) ; service facility ien (either ptr file 4 or 355.93)
+31 ;. I $P(BSZ,U,3)=0,IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1) ; file 4
+32 ;. I $P(BSZ,U,3)=1,IBORG S NPI=$$NPIGET^IBCEP81(IBORG) ; file 355.93
+33 ;. I PHARM S NPI=PHARMNPI ; in switchback mode for pharmacy claims, use the pharmacy NPI
+34 ;. I NPI>0 S $P(IBRETVAL,U,1)=NPI
+35 ;. I NPI<1 S IBNONPI=1
+36 ;. ;
+37 ;. ; non-VA facility NPI switchback
+38 ;. S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
+39 ;. I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2)
+40 ;. ;
+41 ;. ; billing provider NPI switchback
+42 ;. S IBORG=+$P(BSZ,U,1),NPI=""
+43 ;. I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
+44 ;. I PHARM S NPI=PHARMNPI ; in switchback mode for pharmacy claims, use the pharmacy NPI
+45 ;. I NPI>0 S $P(IBRETVAL,U,3)=NPI
+46 ;. I NPI<1 S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
+47 ;. ;
+48 ;. Q
+49 ;
+50 ; service facility NPI regular
+51 SET NPI=""
+52 ; service facility ien (either ptr file 4 or 355.93)
SET IBORG=+$PIECE(BSZ,U,4)
+53 ; file 4
IF $PIECE(BSZ,U,3)=0
IF IBORG
SET NPI=$PIECE($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
+54 ; file 355.93
IF $PIECE(BSZ,U,3)=1
IF IBORG
SET NPI=$$NPIGET^IBCEP81(IBORG)
+55 IF NPI>0
SET $PIECE(IBRETVAL,U,1)=NPI
+56 ; only report missing service facility NPI for non-VA facilities
IF NPI<1
IF $PIECE(BSZ,U,3)=1
SET IBNONPI=1
+57 ;
+58 ; non-VA facility NPI regular
+59 SET IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
+60 ; Let this one (#2) override #1 if both #1 and #2 are missing
+61 IF IBORG
SET NPI=$$NPIGET^IBCEP81(IBORG)
SET $PIECE(IBRETVAL,U,2)=NPI
IF 'NPI
SET IBNONPI=2
+62 ;
+63 ; billing provider NPI regular
+64 SET IBORG=+$PIECE(BSZ,U,1)
SET NPI=""
+65 IF IBORG
SET NPI=$PIECE($$NPI^XUSNPI("Organization_ID",IBORG),U,1)
if NPI>0
SET $PIECE(IBRETVAL,U,3)=NPI
+66 IF NPI<1
SET IBNONPI=$SELECT(IBNONPI="":3,1:IBNONPI_U_3)
+67 ;
+68 ;ORGNPIX ; MRD;IB*2.0*516 - Delete this label when deleting
+69 ; above code commented out.
+70 ;
+71 QUIT IBRETVAL
+72 ;
ORGTAX(IBIEN399,IBNOTAX) ; Extract Taxonomies for organizations on this claim
+1 ; Input
+2 ; IBIEN399 - Claim IEN in file 399
+3 ; IBNOTAX - Variable to pass info on missing taxonomies back to calling routine. Pass by reference.
+4 ; Output - Taxonomy X12 codes for facilities
+5 ; Piece 1) Service Facility Taxonomy X12 code (with IB patch 400, a claim may not have a service facility)
+6 ; Piece 2) Non-VA Service Facility Taxonomy X12 code
+7 ; Piece 3) Billing Provider Taxonomy X12 code (IB patch 400 definition)
+8 NEW IBRETVAL,IBTAX,TAX,BSZ
+9 ;
+10 ; get billing provider/service facility information
SET BSZ=$$B^IBCEF79(IBIEN399)
+11 ;
+12 ; claim field# 243 - service facility taxonomy code
+13 ; no service facility
IF $PIECE(BSZ,U,3)=""
SET (IBTAX,TAX)=""
+14 IF $PIECE(BSZ,U,3)'=""
SET IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I")
SET TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
+15 SET $PIECE(IBRETVAL,U,1)=TAX
+16 ; only record service facility taxonomy code missing if there is a service facility
+17 IF '$LENGTH(TAX)
IF $DATA(IBNOTAX)
IF $PIECE(BSZ,U,3)'=""
SET IBNOTAX=1
+18 ;
+19 ; claim field# 244 - non-VA facility taxonomy code
+20 SET IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I")
+21 SET TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
+22 SET $PIECE(IBRETVAL,U,2)=TAX
+23 IF '$LENGTH(TAX)
IF $$GET1^DIQ(399,IBIEN399_",",232,"I")
IF $DATA(IBNOTAX)
SET IBNOTAX=$SELECT(IBNOTAX="":2,1:IBNOTAX_U_2)
+24 ;
+25 ; claim field# 252 - billing provider taxonomy code
+26 SET IBTAX=$$GET1^DIQ(399,IBIEN399_",",252,"I")
+27 SET TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
+28 ;JWS;IB*2.0*592; if a Dental Claim, never send Billing Provider Taxonomy, since different from Rendering/Assistant Surgeon
+29 IF $$FT^IBCEF(IBIEN399)=7
SET TAX=""
+30 SET $PIECE(IBRETVAL,U,3)=TAX
+31 IF '$LENGTH(TAX)
IF $DATA(IBNOTAX)
SET IBNOTAX=$SELECT(IBNOTAX="":3,1:IBNOTAX_U_3)
+32 ;JWS;IB*2.0*592; if a Dental Claim, never send Billing Provider Taxonomy, since different from Rendering/Assistant Surgeon
+33 IF $$FT^IBCEF(IBIEN399)=7
SET IBNOTAX=""
+34 QUIT IBRETVAL
+35 ;
RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer
+1 ; for the given bill. If IBLIST passed by reference, then a list of
+2 ; the possible organizations are returned for a bill, since a bill may
+3 ; have more than one prescription. If more than one rx on the bill, the
+4 ; $$ return is the pointer of the last prescription found.
+5 ; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer)
+6 ;
+7 NEW IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN
+8 KILL ^TMP($JOB,"IBCEF73A")
+9 SET IBORG=0
SET DFN=$PIECE($GET(^DGCR(399,IBIEN399,0)),"^",2)
SET IBLIST="IBCEF73A"
+10 SET IBRXN=0
FOR
SET IBRXN=$ORDER(^IBA(362.4,"AIFN"_IBIEN399,IBRXN))
if 'IBRXN
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+11 SET IBDATA=$GET(^IBA(362.4,IBX,0))
+12 SET IBRX=$PIECE(IBDATA,"^",5)
SET IBDT=$PIECE(IBDATA,"^",3)
if 'IBRX!('IBDT)
QUIT
+13 DO RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
+14 IF IBDT=+$GET(^TMP($JOB,"IBCEF73A",DFN,IBRX,22))
SET (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$GET(^TMP($JOB,"IBCEF73A",DFN,IBRX,20)))
QUIT
+15 SET IBY=0
FOR
SET IBY=$ORDER(^TMP($JOB,"IBCEF73A",DFN,IBRX,"RF",IBY))
if 'IBY
QUIT
IF IBDT=+$GET(^TMP($JOB,"IBCEF73A",DFN,IBRX,"RF",IBY,.01))
SET (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$GET(^TMP($JOB,"IBCEF73A",DFN,IBRX,"RF",IBY,8)))
QUIT
End DoDot:1
+16 KILL ^TMP($JOB,"IBCEF73A")
+17 QUIT IBORG
+18 ;
PSONPI(IB59IEN) ; returns institution ien for a file 59 ien
+1 NEW IB4IEN
+2 KILL ^TMP($JOB,"IBCEF59")
+3 DO PSS^PSO59(IB59IEN,,"IBCEF59")
+4 SET IB4IEN=+$GET(^TMP($JOB,"IBCEF59",IB59IEN,101))
+5 KILL ^TMP($JOB,"IBCEF59")
+6 QUIT IB4IEN
