- 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 Jan 18, 2025@03:11:27 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