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

XUSNPI.m

Go to the documentation of this file. 
  1. XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER ;6/3/08  13:51
  1.  ;;8.0;KERNEL;**410,416,480**; July 10, 1995;Build 38
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified
  1. ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ;
  1.  ;;==============================================================
  1.  ;; Update the Effective Date, Status & NPI trio.
  1.  ;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
  1.  ;; XUSIEN  : Internal Entry Number. Required.
  1.  ;; XUSNPI  : National Provider Identifier. Required.
  1.  ;; XUSDATE : Active Date. Required.
  1.  ;;
  1.  ;; If successful, return XUSRTN = IEN of new 42 sub-file entry.
  1.  ;; Else return XUSRTN = "-1^ErrorMessage".
  1.  ;; =============================================================
  1.  ;
  1.  ; Check valid inputs.
  1.  N XUSROOT,XUSFNB
  1.  S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
  1.  I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
  1.  I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
  1.  I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
  1.  S XUSFNB=+$P(XUSROOT,"(",2)
  1.  I 'XUSFNB Q "-1^No File #"
  1.  S XUSFNB=XUSFNB_".42"
  1.  I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
  1.  ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
  1.  I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
  1.  N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
  1.  I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI"
  1.  I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date"
  1.  I $G(XUSTATUS)="" S XUSTATUS=1
  1.  I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status"
  1.  N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used.
  1.  I CHNPI'=1 Q "-1^The NPI is being used."
  1.  ;
  1.  ;------------------------------------------------------------------
  1.  N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG=""
  1.  S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")"
  1.  ; Update Effective Date #42 multiple fields
  1.  S XUSFNB=$P(XUSROOT,"(",2)
  1.  S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042"
  1.  S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE
  1.  S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS
  1.  S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI
  1.  D UPDATE^DIE("","ZZ(1)",,ERRMSG)
  1.  I $L(ERRMSG) Q "-1^"_$G(ERRMSG)
  1.  S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")"
  1.  S XUSRTN=$O(@XUSX,-1)
  1.  I '+XUSRTN Q "-1^No entry add"
  1.  Q XUSRTN
  1.  ;
  1. NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity.
  1.  ;;==============================================================
  1.  ;; XUSQI   : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID
  1.  ;; XUSIEN  : Internal Entry Number of file #4 or #200. Required.
  1.  ;; XUSDATE : Active Date. Not Required. Default: 'Today'.
  1.  ;;
  1.  ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status'
  1.  ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage'
  1.  ;; Else return 0
  1.  ;; =============================================================
  1.  ; check valid inputs
  1.  I $G(XUSIEN)'>0 Q "-1^Invalid IEN"
  1.  ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN"
  1.  I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
  1.  I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT
  1.  N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date"
  1.  ;-----------------------------------
  1.  N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive"
  1.  ; get global from Parameter file base on Qualified Identifier.
  1.  S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
  1.  I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
  1.  I XUSROOT="^" Q "-1^Invalid Qualified Identifier"
  1.  N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN"
  1.  I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
  1.  S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""
  1.  S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found"
  1.  S XUSI=0 F  S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI
  1.  I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1)
  1.  I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1)
  1.  I XUSDA="" Q 0
  1.  S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1)
  1.  S XUSRTN=XUSROOT_","_XUSDA_","_0_")"
  1.  I '$D(@XUSRTN) Q "-1^Invalid IEN"
  1.  I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active"
  1.  Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT
  1.  ;
  1. QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value.
  1.  ;;================================================
  1.  ;; XUSNPI  : National Provider Identifier. Required
  1.  ;;
  1.  ;; If qualified identified entity exists, return
  1.  ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;'
  1.  ;; If more than one records found, they are separated by ";"
  1.  ;; Else return 0
  1.  ;;================================================
  1.  ; check valid NPI
  1.  I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI"
  1.  N ZZ
  1.  D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER")
  1.  I ZZ'>0 Q 0
  1.  N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1=""
  1.  S XUSI=0 F  S XUSI=$O(ZZ(XUSI)) Q:'XUSI  D
  1.  . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT
  1.  . I $$GLCK(XUSROOT)'>0 Q  ;check valid global root
  1.  . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
  1.  . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX)
  1.  . S XUSIEN=0 F  S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0  D
  1.  . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI)
  1.  . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1
  1.  I XUSRTN1="" S XUSRTN1=0
  1.  Q XUSRTN1
  1.  ;
  1. GLCK(XUSROOT) ; check valid global root
  1.  N XUFNB,ZZ
  1.  I $G(XUSROOT)="" Q 0
  1.  S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",")
  1.  D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ")
  1.  Q (XUSROOT=$G(ZZ("GLOBAL NAME")))
  1.  ;
  1. SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ;
  1.  I $G(XUSIEN)'>0 Q 0
  1.  I (XUSIEN?.N)=0 Q 0
  1.  N XUSX,XUSRTN S XUSRTN=0
  1.  I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_""""
  1.  S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")"
  1.  I '$D(@XUSX) Q 0
  1.  S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")"
  1.  S XUSRTN=$O(@XUSX,-1)
  1.  I '+XUSRTN Q 0
  1.  S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")"
  1.  I '$D(@XUSX) Q 0
  1.  S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2)
  1.  I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active"
  1.  I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive"
  1.  Q XUSRTN
  1.  ;
  1. CHKDGT(XUSNPI) ;
  1.  ;  Function to validate the format of an NPI number.  It checks the
  1.  ;  length of the number, whether the NPI is numeric, and whether
  1.  ;  the check digit is valid.
  1.  ;
  1.  ;  Input parameter:
  1.  ;    NPI - 10-digit NPI number to validate.
  1.  ;
  1.  ;  Output parameter:
  1.  ;    Boolean value indicating whether the NPI has a valid format
  1.  ;
  1.  ;  NPI must be 10 digits long.
  1.  I XUSNPI'?10N Q 0
  1.  Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9))
  1.  ;
  1. CKDIGIT(XUSNPI) ;
  1.  ;  Function to calculate and return the check digit of an NPI.
  1.  ;  The check digit is calculated using the Luhn Formula for
  1.  ;  Modulus 10 "double-add-double" Check Digit.  A value of 24 is
  1.  ;  added to the total to account for the implied USA (80840) prefix.
  1.  ;
  1.  N XUSCTOT,XUSCN,XUSCDIG,XUSI
  1.  S XUSCTOT=24
  1.  F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1)
  1.  S XUSCDIG=150-XUSCTOT
  1.  Q $E(XUSCDIG,$L(XUSCDIG))
  1.  ;
  1. CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date
  1.  ;;  XUSQI   : Qualified Identifier. Required. For examble: "Individual_ID"
  1.  ;;  XUSIEN  : Internal Entry Number. Required.
  1.  ;;  XUSDATE : The Effective Date value to test. Must be FM date. Required.
  1.  ;;
  1.  ;;  If input passes date comparison, return 1.
  1.  ;;  Else return 0.
  1.  ;
  1.  I $G(XUSIEN)'>0 Q "0^Invalid IEN."
  1.  ;I (XUSIEN?.N)=0 Q "0^Invalid IEN."
  1.  I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN"
  1.  N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time."
  1.  ;-----------------------------------
  1.  N XUSROOT,XUSDA
  1.  N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0
  1.  ; get global from Parameter file base on Qualified Identifier.
  1.  S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
  1.  I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
  1.  I XUSROOT="^" Q "0^Invalid Qualified Identifier."
  1.  I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier"
  1.  N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN."
  1.  S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1)
  1.  Q (XUSDATE'<XUSDA)
  1.  ;
  1. GETRLNPI(XUSIEN) ; Return field indicating blanket release of NPI
  1.  ;; XUSIEN  : Internal Entry Number of person in file 200. Required
  1.  ;; Output: -1^error message or contents of AUTHORIZE RELEASE OF NPI field.
  1.  S XUSIEN=+$G(XUSIEN) I $G(^VA(200,XUSIEN,0))="" Q "-1^Invalid IEN"
  1.  N X
  1.  S X=$$NPI^XUSNPI("Individual_ID",XUSIEN)
  1.  I (X'>0)!($P(X,U,3)'="Active") Q "-1^User has no active NPI"
  1.  S X=$P($G(^VA(200,XUSIEN,"NPI")),U,3)
  1.  S:X="" X=0
  1.  Q X
  1.  ;