- XUSNPIXU ;OAK_BP/DLS - NPI Extract Utilities ; 6/17/09
- ;;8.0;KERNEL;**438,453,528,548**; Jul 10, 1995;Build 24
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- ;
- ; NPI Extract Functions and Utilities
- ;
- BCBSID ; This sub-routine is designed to create a string for each Blue Cross/Blue Shield Insurance Company,
- ; including the Ins Co name and an array of BCBS ID's (the ID's separated by a semi-colon sub-delimiter).
- ;
- ; Input Parameter - N/A
- ;
- ; System Parameters
- ; S ==> ";" (Semi-Colon Sub-Delimiter)
- ; U ==> "^"
- ;
- ; Variables
- ; INSCO - Insurance Company IEN
- ; INSTYP - Insurance Company Type
- ; INSNAM - Insurance Company Name
- ; INSHPR - Hospital Provider Number
- ; INSPPR - Professional Provider Number
- ; IBILP - IB Insurance Co Level Billing Provider IEN
- ; IBILF - IB Insurance Co Level Billing Facility IEN
- ; IBDFPID - Default BCBS Provider #
- ; IBILPID - IB Insurance Co Level Billing Provider ID
- ; IBILFID - IB Insurance Co Level Billing Facility ID
- ; IDSTR - Local BCBS ID String, placed into ^TMP when complete.
- ;
- K ^TMP("XUSNPIXU",$J)
- N INSCO,INSTYP,INSNAM,INSHPR,INSPPR,IBILP,IBILF,IBILPID,IBILFID,IDSTR,P,S
- ;
- S S=";"
- ;
- ; Loop through the Insurance Co file.
- S INSCO=0
- F S INSCO=$O(^DIC(36,INSCO)) Q:'INSCO D
- . S IDSTR=""
- . S INSTYP=$$GET1^DIQ(36,INSCO_",",.13)
- . ;
- . ; If the Insurance Co type is not Blue Cross or Blue Shield, QUIT and move on to the next one.
- . I '((INSTYP="BLUE CROSS")!(INSTYP="BLUE SHIELD")) Q
- . ;
- . ; Get Insurance Company Name.
- . S INSNAM=$$GET1^DIQ(36,INSCO_",",.01)
- . ;
- . ; Get the IB Insurance Co Level Billing Prov ID's.
- . S IBILP=0
- . F S IBILP=$O(^IBA(355.92,"B",INSCO,IBILP)) Q:'IBILP D
- . . S IBILPID=$$GET1^DIQ(355.92,IBILP_",",.07)
- . . D ADDID(.IDSTR,IBILPID)
- . ;
- . ; Get the IB Insurance Co Level Billing Facility ID's.
- . S IBILF=0
- . F S IBILF=$O(^IBA(355.91,"B",INSCO,IBILF)) Q:'IBILF D
- . . S IBILFID=$$GET1^DIQ(355.91,IBILF_",",.07)
- . . D ADDID(.IDSTR,IBILFID)
- . ;
- . ; Remove trailing semi-colon and place local ID string into ^TMP.
- . I $E(IDSTR,$L(IDSTR))=";" S IDSTR=$E(IDSTR,1,$L(IDSTR)-1)
- . I IDSTR'="" S ^TMP("XUSNPIXU",$J,INSCO)=INSNAM_U_IDSTR
- Q
- ;
- ;
- ADDID(IDSTRING,ID) ; Append BCBS ID to local ID string, using ";" as the sub-delimiter. Called from BCBSID
- ;
- ; Input Parameters
- ; IDSTRING - Local variable ID string, passed from BCBSID
- ; ID - ID to be appended to IDSTRING, passed from BCBSID
- ;
- I '$D(ID)!('$D(IDSTRING)) Q
- I ID'="",IDSTRING'[ID S IDSTRING=IDSTRING_ID_S
- Q
- ;
- PRACID(NPIEN,INS) ; Get Practitioner IDs
- ;
- ; Output Parameter
- ; INS - Array-Passed by Reference
- N BIEN,PRAC,A,A1,A2
- K INS
- S BIEN=NPIEN_";VA(200,"
- S PRAC=""
- F S PRAC=$O(^IBA(355.9,"B",BIEN,PRAC)) Q:'PRAC D
- . S A=$$BCBSTR(PRAC) I A="" Q ;P 528
- . S A1=$P(A,"^"),A2=$P(A,"^",2) I A1="" Q ;add p 528
- . I $D(INS(A1)) S INS(A1_" ")=A2 Q ;add p 528
- . S INS(A1)=A2 ;add p 528
- Q
- ;
- NNVAID(NPIEN,INS) ; Get Non-VA Provider IDS
- ;
- ; Output Parameter
- ; INS - Array-Passed by Reference
- N BIEN,PRAC,A,A1,A2
- K INS
- S BIEN=NPIEN_";IBA(355.93,"
- S PRAC=""
- F S PRAC=$O(^IBA(355.9,"B",BIEN,PRAC)) Q:'PRAC D
- . S A=$$BCBSTR(PRAC) I A="" Q ;p 528
- . S A1=$P(A,"^"),A2=$P(A,"^",2) I A1="" Q ;add p 528
- . I $D(INS(A1)) S INS(A1_" ")=A2 Q ;add p 528
- . S INS(A1)=A2 ;add p 528
- Q
- ;
- INSTID(INSARRAY) ; Get Institution IDs
- ;
- ; Output Parameter
- ; INSARRAY - Array-Passed by Reference
- N INS,A
- K INSARRAY
- S INS=0
- ; 12/13/2007 DLS - Change array structure from INSARRAY(A)="" to INSARRAY($P(A,U,1))=$P(A,U,2)
- F S INS=$O(^TMP("XUSNPIXU",$J,INS)) Q:INS="" D
- . S A=$G(^TMP("XUSNPIXU",$J,INS))
- . I A'="" S INSARRAY($P(A,U,1))=$P(A,U,2)
- Q
- ;
- ;
- BCBSTR(PRACIEN) ; Receive an IB Billing Practitioner Provider IEN and return the string of ID's already created.
- ;
- ; Input Parameters
- ; PRACIEN - Practitioner Ins. Co. file IEN - Linked to Provider and passed from NPI Extract.
- ;
- ; System Parameters
- ; S ==> ";" (Semi-Colon Sub-Delimiter)
- ; Variables
- ; INSCO - Insurance Company IEN
- ; PRVID - Provider ID for the specific Insurance Company. This is added on to the ID string stored in TMP.
- ;
- ; Get the Ins Co IEN
- N INSCO,PRVID,P,S
- S S=";"
- S INSCO=$$GET1^DIQ(355.9,PRACIEN_",",.02,"I")
- ;
- ; Quit if this is NOT a Blue Cross/Blue Shield Insurance Company.
- I $G(^TMP("XUSNPIXU",$J,+INSCO))="" Q ""
- ;
- ; Get the Practitioner ID for this specific Insurance Company. (commented out for now)
- S PRVID=$$GET1^DIQ(355.9,PRACIEN_",",.07)
- ;
- ; If PRVID is NOT null AND the ID is NOT already in the string AND
- ; (If the string DOES NOT end with a "^", return the ID string with the sub-delimiter and PRVID appended) OR
- ; (If the string DOES end with a "^", return the ID string with only PRVID appended.)
- I PRVID'="",((^TMP("XUSNPIXU",$J,INSCO)'["^PRVID;")!(^TMP("XUSNPIXU",$J,INSCO)'[";PRVID;")) D Q ^TMP("XUSNPIXU",$J,INSCO)_PRVID
- . I $E($L(^TMP("XUSNPIXU",$J,INSCO)))'=U S PRVID=S_PRVID
- . Q
- ;
- ; If nothing needs changing, return the string unchanged.
- Q ^TMP("XUSNPIXU",$J,INSCO)
- ;
- INIT ;Initialize ^XTMP
- K ^XTMP("XUSNPIX1")
- K ^XTMP("XUSNPIX2")
- K ^XTMP("XUSNPIX1NV")
- K ^XTMP("XUSNPIX2NV")
- K ^XTMP("XUSNPIXT")
- Q
- ;
- P2PBASE(XUSTMP) ;
- N XUSNP2P,IBSIEN,ZN19,P2PVAL,XUSDEF
- S XUSNP2P=0
- F S XUSNP2P=$O(^IBE(350.9,1,19,"B",XUSNP2P)) Q:XUSNP2P="" D
- . S IBSIEN=$O(^IBE(350.9,1,19,"B",XUSNP2P,""))
- . S ZN19=^IBE(350.9,1,19,IBSIEN,0),P2PVAL=$P(ZN19,U,5)
- . I P2PVAL S XUSTMP("P2P",XUSNP2P)=P2PVAL
- . E S XUSTMP("P2P",XUSNP2P)=IBSIEN
- S XUSDEF=$P($G(^IBE(350.9,1,11)),U,3)
- I XUSDEF="" G P2PBASEX
- I '$D(^IBE(350.9,1,19,XUSDEF)) S XUSDEF=""
- P2PBASEX ;
- I XUSDEF'="" S XUSTMP("P2P","DEFAULT")=XUSDEF
- Q
- ;
- P2PEXP(IEN,XUSPT) ;
- N IBE35090,IBE35091,P2PVAL,I
- S IBE35090=$G(^IBE(350.9,1,19,IEN,0))
- F I=1:1:6 S XUSPT(I)=""
- I IBE35090]"" S XUSPT(1)=$P(IBE35090,U,2)
- S IBE35091=$G(^IBE(350.9,1,19,IEN,1))
- I IBE35091]"" D
- . S XUSPT(2)=$P(IBE35091,U,1)
- . S XUSPT(3)=$P(IBE35091,U,2)
- . S XUSPT(4)=$P(IBE35091,U,3)
- . S XUSPT(5)=$P(IBE35091,U,4)
- . I XUSPT(5)?1N.N S XUSPT(5)=$P($G(^DIC(5,XUSPT(5),0)),U,2)
- . S XUSPT(6)=$P(IBE35091,U,5)
- Q XUSPT(1)_U_XUSPT(2)_U_XUSPT(3)_U_XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIXU 6585 printed Feb 18, 2025@23:39:17 Page 2
- XUSNPIXU ;OAK_BP/DLS - NPI Extract Utilities ; 6/17/09
- +1 ;;8.0;KERNEL;**438,453,528,548**; Jul 10, 1995;Build 24
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- +6 ; NPI Extract Functions and Utilities
- +7 ;
- BCBSID ; This sub-routine is designed to create a string for each Blue Cross/Blue Shield Insurance Company,
- +1 ; including the Ins Co name and an array of BCBS ID's (the ID's separated by a semi-colon sub-delimiter).
- +2 ;
- +3 ; Input Parameter - N/A
- +4 ;
- +5 ; System Parameters
- +6 ; S ==> ";" (Semi-Colon Sub-Delimiter)
- +7 ; U ==> "^"
- +8 ;
- +9 ; Variables
- +10 ; INSCO - Insurance Company IEN
- +11 ; INSTYP - Insurance Company Type
- +12 ; INSNAM - Insurance Company Name
- +13 ; INSHPR - Hospital Provider Number
- +14 ; INSPPR - Professional Provider Number
- +15 ; IBILP - IB Insurance Co Level Billing Provider IEN
- +16 ; IBILF - IB Insurance Co Level Billing Facility IEN
- +17 ; IBDFPID - Default BCBS Provider #
- +18 ; IBILPID - IB Insurance Co Level Billing Provider ID
- +19 ; IBILFID - IB Insurance Co Level Billing Facility ID
- +20 ; IDSTR - Local BCBS ID String, placed into ^TMP when complete.
- +21 ;
- +22 KILL ^TMP("XUSNPIXU",$JOB)
- +23 NEW INSCO,INSTYP,INSNAM,INSHPR,INSPPR,IBILP,IBILF,IBILPID,IBILFID,IDSTR,P,S
- +24 ;
- +25 SET S=";"
- +26 ;
- +27 ; Loop through the Insurance Co file.
- +28 SET INSCO=0
- +29 FOR
- SET INSCO=$ORDER(^DIC(36,INSCO))
- if 'INSCO
- QUIT
- Begin DoDot:1
- +30 SET IDSTR=""
- +31 SET INSTYP=$$GET1^DIQ(36,INSCO_",",.13)
- +32 ;
- +33 ; If the Insurance Co type is not Blue Cross or Blue Shield, QUIT and move on to the next one.
- +34 IF '((INSTYP="BLUE CROSS")!(INSTYP="BLUE SHIELD"))
- QUIT
- +35 ;
- +36 ; Get Insurance Company Name.
- +37 SET INSNAM=$$GET1^DIQ(36,INSCO_",",.01)
- +38 ;
- +39 ; Get the IB Insurance Co Level Billing Prov ID's.
- +40 SET IBILP=0
- +41 FOR
- SET IBILP=$ORDER(^IBA(355.92,"B",INSCO,IBILP))
- if 'IBILP
- QUIT
- Begin DoDot:2
- +42 SET IBILPID=$$GET1^DIQ(355.92,IBILP_",",.07)
- +43 DO ADDID(.IDSTR,IBILPID)
- End DoDot:2
- +44 ;
- +45 ; Get the IB Insurance Co Level Billing Facility ID's.
- +46 SET IBILF=0
- +47 FOR
- SET IBILF=$ORDER(^IBA(355.91,"B",INSCO,IBILF))
- if 'IBILF
- QUIT
- Begin DoDot:2
- +48 SET IBILFID=$$GET1^DIQ(355.91,IBILF_",",.07)
- +49 DO ADDID(.IDSTR,IBILFID)
- End DoDot:2
- +50 ;
- +51 ; Remove trailing semi-colon and place local ID string into ^TMP.
- +52 IF $EXTRACT(IDSTR,$LENGTH(IDSTR))=";"
- SET IDSTR=$EXTRACT(IDSTR,1,$LENGTH(IDSTR)-1)
- +53 IF IDSTR'=""
- SET ^TMP("XUSNPIXU",$JOB,INSCO)=INSNAM_U_IDSTR
- End DoDot:1
- +54 QUIT
- +55 ;
- +56 ;
- ADDID(IDSTRING,ID) ; Append BCBS ID to local ID string, using ";" as the sub-delimiter. Called from BCBSID
- +1 ;
- +2 ; Input Parameters
- +3 ; IDSTRING - Local variable ID string, passed from BCBSID
- +4 ; ID - ID to be appended to IDSTRING, passed from BCBSID
- +5 ;
- +6 IF '$DATA(ID)!('$DATA(IDSTRING))
- QUIT
- +7 IF ID'=""
- IF IDSTRING'[ID
- SET IDSTRING=IDSTRING_ID_S
- +8 QUIT
- +9 ;
- PRACID(NPIEN,INS) ; Get Practitioner IDs
- +1 ;
- +2 ; Output Parameter
- +3 ; INS - Array-Passed by Reference
- +4 NEW BIEN,PRAC,A,A1,A2
- +5 KILL INS
- +6 SET BIEN=NPIEN_";VA(200,"
- +7 SET PRAC=""
- +8 FOR
- SET PRAC=$ORDER(^IBA(355.9,"B",BIEN,PRAC))
- if 'PRAC
- QUIT
- Begin DoDot:1
- +9 ;P 528
- SET A=$$BCBSTR(PRAC)
- IF A=""
- QUIT
- +10 ;add p 528
- SET A1=$PIECE(A,"^")
- SET A2=$PIECE(A,"^",2)
- IF A1=""
- QUIT
- +11 ;add p 528
- IF $DATA(INS(A1))
- SET INS(A1_" ")=A2
- QUIT
- +12 ;add p 528
- SET INS(A1)=A2
- End DoDot:1
- +13 QUIT
- +14 ;
- NNVAID(NPIEN,INS) ; Get Non-VA Provider IDS
- +1 ;
- +2 ; Output Parameter
- +3 ; INS - Array-Passed by Reference
- +4 NEW BIEN,PRAC,A,A1,A2
- +5 KILL INS
- +6 SET BIEN=NPIEN_";IBA(355.93,"
- +7 SET PRAC=""
- +8 FOR
- SET PRAC=$ORDER(^IBA(355.9,"B",BIEN,PRAC))
- if 'PRAC
- QUIT
- Begin DoDot:1
- +9 ;p 528
- SET A=$$BCBSTR(PRAC)
- IF A=""
- QUIT
- +10 ;add p 528
- SET A1=$PIECE(A,"^")
- SET A2=$PIECE(A,"^",2)
- IF A1=""
- QUIT
- +11 ;add p 528
- IF $DATA(INS(A1))
- SET INS(A1_" ")=A2
- QUIT
- +12 ;add p 528
- SET INS(A1)=A2
- End DoDot:1
- +13 QUIT
- +14 ;
- INSTID(INSARRAY) ; Get Institution IDs
- +1 ;
- +2 ; Output Parameter
- +3 ; INSARRAY - Array-Passed by Reference
- +4 NEW INS,A
- +5 KILL INSARRAY
- +6 SET INS=0
- +7 ; 12/13/2007 DLS - Change array structure from INSARRAY(A)="" to INSARRAY($P(A,U,1))=$P(A,U,2)
- +8 FOR
- SET INS=$ORDER(^TMP("XUSNPIXU",$JOB,INS))
- if INS=""
- QUIT
- Begin DoDot:1
- +9 SET A=$GET(^TMP("XUSNPIXU",$JOB,INS))
- +10 IF A'=""
- SET INSARRAY($PIECE(A,U,1))=$PIECE(A,U,2)
- End DoDot:1
- +11 QUIT
- +12 ;
- +13 ;
- BCBSTR(PRACIEN) ; Receive an IB Billing Practitioner Provider IEN and return the string of ID's already created.
- +1 ;
- +2 ; Input Parameters
- +3 ; PRACIEN - Practitioner Ins. Co. file IEN - Linked to Provider and passed from NPI Extract.
- +4 ;
- +5 ; System Parameters
- +6 ; S ==> ";" (Semi-Colon Sub-Delimiter)
- +7 ; Variables
- +8 ; INSCO - Insurance Company IEN
- +9 ; PRVID - Provider ID for the specific Insurance Company. This is added on to the ID string stored in TMP.
- +10 ;
- +11 ; Get the Ins Co IEN
- +12 NEW INSCO,PRVID,P,S
- +13 SET S=";"
- +14 SET INSCO=$$GET1^DIQ(355.9,PRACIEN_",",.02,"I")
- +15 ;
- +16 ; Quit if this is NOT a Blue Cross/Blue Shield Insurance Company.
- +17 IF $GET(^TMP("XUSNPIXU",$JOB,+INSCO))=""
- QUIT ""
- +18 ;
- +19 ; Get the Practitioner ID for this specific Insurance Company. (commented out for now)
- +20 SET PRVID=$$GET1^DIQ(355.9,PRACIEN_",",.07)
- +21 ;
- +22 ; If PRVID is NOT null AND the ID is NOT already in the string AND
- +23 ; (If the string DOES NOT end with a "^", return the ID string with the sub-delimiter and PRVID appended) OR
- +24 ; (If the string DOES end with a "^", return the ID string with only PRVID appended.)
- +25 IF PRVID'=""
- IF ((^TMP("XUSNPIXU",$JOB,INSCO)'["^PRVID;")!(^TMP("XUSNPIXU",$JOB,INSCO)'[";PRVID;"))
- Begin DoDot:1
- +26 IF $EXTRACT($LENGTH(^TMP("XUSNPIXU",$JOB,INSCO)))'=U
- SET PRVID=S_PRVID
- +27 QUIT
- End DoDot:1
- QUIT ^TMP("XUSNPIXU",$JOB,INSCO)_PRVID
- +28 ;
- +29 ; If nothing needs changing, return the string unchanged.
- +30 QUIT ^TMP("XUSNPIXU",$JOB,INSCO)
- +31 ;
- INIT ;Initialize ^XTMP
- +1 KILL ^XTMP("XUSNPIX1")
- +2 KILL ^XTMP("XUSNPIX2")
- +3 KILL ^XTMP("XUSNPIX1NV")
- +4 KILL ^XTMP("XUSNPIX2NV")
- +5 KILL ^XTMP("XUSNPIXT")
- +6 QUIT
- +7 ;
- P2PBASE(XUSTMP) ;
- +1 NEW XUSNP2P,IBSIEN,ZN19,P2PVAL,XUSDEF
- +2 SET XUSNP2P=0
- +3 FOR
- SET XUSNP2P=$ORDER(^IBE(350.9,1,19,"B",XUSNP2P))
- if XUSNP2P=""
- QUIT
- Begin DoDot:1
- +4 SET IBSIEN=$ORDER(^IBE(350.9,1,19,"B",XUSNP2P,""))
- +5 SET ZN19=^IBE(350.9,1,19,IBSIEN,0)
- SET P2PVAL=$PIECE(ZN19,U,5)
- +6 IF P2PVAL
- SET XUSTMP("P2P",XUSNP2P)=P2PVAL
- +7 IF '$TEST
- SET XUSTMP("P2P",XUSNP2P)=IBSIEN
- End DoDot:1
- +8 SET XUSDEF=$PIECE($GET(^IBE(350.9,1,11)),U,3)
- +9 IF XUSDEF=""
- GOTO P2PBASEX
- +10 IF '$DATA(^IBE(350.9,1,19,XUSDEF))
- SET XUSDEF=""
- P2PBASEX ;
- +1 IF XUSDEF'=""
- SET XUSTMP("P2P","DEFAULT")=XUSDEF
- +2 QUIT
- +3 ;
- P2PEXP(IEN,XUSPT) ;
- +1 NEW IBE35090,IBE35091,P2PVAL,I
- +2 SET IBE35090=$GET(^IBE(350.9,1,19,IEN,0))
- +3 FOR I=1:1:6
- SET XUSPT(I)=""
- +4 IF IBE35090]""
- SET XUSPT(1)=$PIECE(IBE35090,U,2)
- +5 SET IBE35091=$GET(^IBE(350.9,1,19,IEN,1))
- +6 IF IBE35091]""
- Begin DoDot:1
- +7 SET XUSPT(2)=$PIECE(IBE35091,U,1)
- +8 SET XUSPT(3)=$PIECE(IBE35091,U,2)
- +9 SET XUSPT(4)=$PIECE(IBE35091,U,3)
- +10 SET XUSPT(5)=$PIECE(IBE35091,U,4)
- +11 IF XUSPT(5)?1N.N
- SET XUSPT(5)=$PIECE($GET(^DIC(5,XUSPT(5),0)),U,2)
- +12 SET XUSPT(6)=$PIECE(IBE35091,U,5)
- End DoDot:1
- +13 QUIT XUSPT(1)_U_XUSPT(2)_U_XUSPT(3)_U_XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)