Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUSNPIXU

XUSNPIXU.m

Go to the documentation of this file.
  1. XUSNPIXU ;OAK_BP/DLS - NPI Extract Utilities ; 6/17/09
  1. ;;8.0;KERNEL;**438,453,528,548**; Jul 10, 1995;Build 24
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. ; NPI Extract Functions and Utilities
  1. ;
  1. 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).
  1. ;
  1. ; Input Parameter - N/A
  1. ;
  1. ; System Parameters
  1. ; S ==> ";" (Semi-Colon Sub-Delimiter)
  1. ; U ==> "^"
  1. ;
  1. ; Variables
  1. ; INSCO - Insurance Company IEN
  1. ; INSTYP - Insurance Company Type
  1. ; INSNAM - Insurance Company Name
  1. ; INSHPR - Hospital Provider Number
  1. ; INSPPR - Professional Provider Number
  1. ; IBILP - IB Insurance Co Level Billing Provider IEN
  1. ; IBILF - IB Insurance Co Level Billing Facility IEN
  1. ; IBDFPID - Default BCBS Provider #
  1. ; IBILPID - IB Insurance Co Level Billing Provider ID
  1. ; IBILFID - IB Insurance Co Level Billing Facility ID
  1. ; IDSTR - Local BCBS ID String, placed into ^TMP when complete.
  1. ;
  1. K ^TMP("XUSNPIXU",$J)
  1. N INSCO,INSTYP,INSNAM,INSHPR,INSPPR,IBILP,IBILF,IBILPID,IBILFID,IDSTR,P,S
  1. ;
  1. S S=";"
  1. ;
  1. ; Loop through the Insurance Co file.
  1. S INSCO=0
  1. F S INSCO=$O(^DIC(36,INSCO)) Q:'INSCO D
  1. . S IDSTR=""
  1. . S INSTYP=$$GET1^DIQ(36,INSCO_",",.13)
  1. . ;
  1. . ; If the Insurance Co type is not Blue Cross or Blue Shield, QUIT and move on to the next one.
  1. . I '((INSTYP="BLUE CROSS")!(INSTYP="BLUE SHIELD")) Q
  1. . ;
  1. . ; Get Insurance Company Name.
  1. . S INSNAM=$$GET1^DIQ(36,INSCO_",",.01)
  1. . ;
  1. . ; Get the IB Insurance Co Level Billing Prov ID's.
  1. . S IBILP=0
  1. . F S IBILP=$O(^IBA(355.92,"B",INSCO,IBILP)) Q:'IBILP D
  1. . . S IBILPID=$$GET1^DIQ(355.92,IBILP_",",.07)
  1. . . D ADDID(.IDSTR,IBILPID)
  1. . ;
  1. . ; Get the IB Insurance Co Level Billing Facility ID's.
  1. . S IBILF=0
  1. . F S IBILF=$O(^IBA(355.91,"B",INSCO,IBILF)) Q:'IBILF D
  1. . . S IBILFID=$$GET1^DIQ(355.91,IBILF_",",.07)
  1. . . D ADDID(.IDSTR,IBILFID)
  1. . ;
  1. . ; Remove trailing semi-colon and place local ID string into ^TMP.
  1. . I $E(IDSTR,$L(IDSTR))=";" S IDSTR=$E(IDSTR,1,$L(IDSTR)-1)
  1. . I IDSTR'="" S ^TMP("XUSNPIXU",$J,INSCO)=INSNAM_U_IDSTR
  1. Q
  1. ;
  1. ;
  1. ADDID(IDSTRING,ID) ; Append BCBS ID to local ID string, using ";" as the sub-delimiter. Called from BCBSID
  1. ;
  1. ; Input Parameters
  1. ; IDSTRING - Local variable ID string, passed from BCBSID
  1. ; ID - ID to be appended to IDSTRING, passed from BCBSID
  1. ;
  1. I '$D(ID)!('$D(IDSTRING)) Q
  1. I ID'="",IDSTRING'[ID S IDSTRING=IDSTRING_ID_S
  1. Q
  1. ;
  1. PRACID(NPIEN,INS) ; Get Practitioner IDs
  1. ;
  1. ; Output Parameter
  1. ; INS - Array-Passed by Reference
  1. N BIEN,PRAC,A,A1,A2
  1. K INS
  1. S BIEN=NPIEN_";VA(200,"
  1. S PRAC=""
  1. F S PRAC=$O(^IBA(355.9,"B",BIEN,PRAC)) Q:'PRAC D
  1. . S A=$$BCBSTR(PRAC) I A="" Q ;P 528
  1. . S A1=$P(A,"^"),A2=$P(A,"^",2) I A1="" Q ;add p 528
  1. . I $D(INS(A1)) S INS(A1_" ")=A2 Q ;add p 528
  1. . S INS(A1)=A2 ;add p 528
  1. Q
  1. ;
  1. NNVAID(NPIEN,INS) ; Get Non-VA Provider IDS
  1. ;
  1. ; Output Parameter
  1. ; INS - Array-Passed by Reference
  1. N BIEN,PRAC,A,A1,A2
  1. K INS
  1. S BIEN=NPIEN_";IBA(355.93,"
  1. S PRAC=""
  1. F S PRAC=$O(^IBA(355.9,"B",BIEN,PRAC)) Q:'PRAC D
  1. . S A=$$BCBSTR(PRAC) I A="" Q ;p 528
  1. . S A1=$P(A,"^"),A2=$P(A,"^",2) I A1="" Q ;add p 528
  1. . I $D(INS(A1)) S INS(A1_" ")=A2 Q ;add p 528
  1. . S INS(A1)=A2 ;add p 528
  1. Q
  1. ;
  1. INSTID(INSARRAY) ; Get Institution IDs
  1. ;
  1. ; Output Parameter
  1. ; INSARRAY - Array-Passed by Reference
  1. N INS,A
  1. K INSARRAY
  1. S INS=0
  1. ; 12/13/2007 DLS - Change array structure from INSARRAY(A)="" to INSARRAY($P(A,U,1))=$P(A,U,2)
  1. F S INS=$O(^TMP("XUSNPIXU",$J,INS)) Q:INS="" D
  1. . S A=$G(^TMP("XUSNPIXU",$J,INS))
  1. . I A'="" S INSARRAY($P(A,U,1))=$P(A,U,2)
  1. Q
  1. ;
  1. ;
  1. BCBSTR(PRACIEN) ; Receive an IB Billing Practitioner Provider IEN and return the string of ID's already created.
  1. ;
  1. ; Input Parameters
  1. ; PRACIEN - Practitioner Ins. Co. file IEN - Linked to Provider and passed from NPI Extract.
  1. ;
  1. ; System Parameters
  1. ; S ==> ";" (Semi-Colon Sub-Delimiter)
  1. ; Variables
  1. ; INSCO - Insurance Company IEN
  1. ; PRVID - Provider ID for the specific Insurance Company. This is added on to the ID string stored in TMP.
  1. ;
  1. ; Get the Ins Co IEN
  1. N INSCO,PRVID,P,S
  1. S S=";"
  1. S INSCO=$$GET1^DIQ(355.9,PRACIEN_",",.02,"I")
  1. ;
  1. ; Quit if this is NOT a Blue Cross/Blue Shield Insurance Company.
  1. I $G(^TMP("XUSNPIXU",$J,+INSCO))="" Q ""
  1. ;
  1. ; Get the Practitioner ID for this specific Insurance Company. (commented out for now)
  1. S PRVID=$$GET1^DIQ(355.9,PRACIEN_",",.07)
  1. ;
  1. ; If PRVID is NOT null AND the ID is NOT already in the string AND
  1. ; (If the string DOES NOT end with a "^", return the ID string with the sub-delimiter and PRVID appended) OR
  1. ; (If the string DOES end with a "^", return the ID string with only PRVID appended.)
  1. I PRVID'="",((^TMP("XUSNPIXU",$J,INSCO)'["^PRVID;")!(^TMP("XUSNPIXU",$J,INSCO)'[";PRVID;")) D Q ^TMP("XUSNPIXU",$J,INSCO)_PRVID
  1. . I $E($L(^TMP("XUSNPIXU",$J,INSCO)))'=U S PRVID=S_PRVID
  1. . Q
  1. ;
  1. ; If nothing needs changing, return the string unchanged.
  1. Q ^TMP("XUSNPIXU",$J,INSCO)
  1. ;
  1. INIT ;Initialize ^XTMP
  1. K ^XTMP("XUSNPIX1")
  1. K ^XTMP("XUSNPIX2")
  1. K ^XTMP("XUSNPIX1NV")
  1. K ^XTMP("XUSNPIX2NV")
  1. K ^XTMP("XUSNPIXT")
  1. Q
  1. ;
  1. P2PBASE(XUSTMP) ;
  1. N XUSNP2P,IBSIEN,ZN19,P2PVAL,XUSDEF
  1. S XUSNP2P=0
  1. F S XUSNP2P=$O(^IBE(350.9,1,19,"B",XUSNP2P)) Q:XUSNP2P="" D
  1. . S IBSIEN=$O(^IBE(350.9,1,19,"B",XUSNP2P,""))
  1. . S ZN19=^IBE(350.9,1,19,IBSIEN,0),P2PVAL=$P(ZN19,U,5)
  1. . I P2PVAL S XUSTMP("P2P",XUSNP2P)=P2PVAL
  1. . E S XUSTMP("P2P",XUSNP2P)=IBSIEN
  1. S XUSDEF=$P($G(^IBE(350.9,1,11)),U,3)
  1. I XUSDEF="" G P2PBASEX
  1. I '$D(^IBE(350.9,1,19,XUSDEF)) S XUSDEF=""
  1. P2PBASEX ;
  1. I XUSDEF'="" S XUSTMP("P2P","DEFAULT")=XUSDEF
  1. Q
  1. ;
  1. P2PEXP(IEN,XUSPT) ;
  1. N IBE35090,IBE35091,P2PVAL,I
  1. S IBE35090=$G(^IBE(350.9,1,19,IEN,0))
  1. F I=1:1:6 S XUSPT(I)=""
  1. I IBE35090]"" S XUSPT(1)=$P(IBE35090,U,2)
  1. S IBE35091=$G(^IBE(350.9,1,19,IEN,1))
  1. I IBE35091]"" D
  1. . S XUSPT(2)=$P(IBE35091,U,1)
  1. . S XUSPT(3)=$P(IBE35091,U,2)
  1. . S XUSPT(4)=$P(IBE35091,U,3)
  1. . S XUSPT(5)=$P(IBE35091,U,4)
  1. . I XUSPT(5)?1N.N S XUSPT(5)=$P($G(^DIC(5,XUSPT(5),0)),U,2)
  1. . S XUSPT(6)=$P(IBE35091,U,5)
  1. Q XUSPT(1)_U_XUSPT(2)_U_XUSPT(3)_U_XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)