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