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 Oct 16, 2024@18:13:38 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)
