Changeset 623 for WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m
r613 r623 1 XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER ;6/3/08 13:51 2 ;;8.0;KERNEL;**410,416,480**; July 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; 5 ;;============================================================== 6 ;; Update the Effective Date, Status & NPI trio. 7 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 8 ;; XUSIEN : Internal Entry Number. Required. 9 ;; XUSNPI : National Provider Identifier. Required. 10 ;; XUSDATE : Active Date. Required. 11 ;; 12 ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. 13 ;; Else return XUSRTN = "-1^ErrorMessage". 14 ;; ============================================================= 15 ; 16 ; Check valid inputs. 17 N XUSROOT,XUSFNB 18 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 19 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 20 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 21 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 22 S XUSFNB=+$P(XUSROOT,"(",2) 23 I 'XUSFNB Q "-1^No File #" 24 S XUSFNB=XUSFNB_".42" 25 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 26 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 27 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 28 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 29 I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" 30 I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" 31 I $G(XUSTATUS)="" S XUSTATUS=1 32 I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" 33 N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. 34 I CHNPI'=1 Q "-1^The NPI is being used." 35 ; 36 ;------------------------------------------------------------------ 37 N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" 38 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" 39 ; Update Effective Date #42 multiple fields 40 S XUSFNB=$P(XUSROOT,"(",2) 41 S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" 42 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE 43 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS 44 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI 45 D UPDATE^DIE("","ZZ(1)",,ERRMSG) 46 I $L(ERRMSG) Q "-1^"_$G(ERRMSG) 47 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" 48 S XUSRTN=$O(@XUSX,-1) 49 I '+XUSRTN Q "-1^No entry add" 50 Q XUSRTN 51 ; 52 NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. 53 ;;============================================================== 54 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 55 ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. 56 ;; XUSDATE : Active Date. Not Required. Default: 'Today'. 57 ;; 58 ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' 59 ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' 60 ;; Else return 0 61 ;; ============================================================= 62 ; check valid inputs 63 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 64 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 65 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 66 I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT 67 N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" 68 ;----------------------------------- 69 N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" 70 ; get global from Parameter file base on Qualified Identifier. 71 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 72 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 73 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 74 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 75 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 76 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" 77 S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" 78 S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI 79 I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) 80 I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) 81 I XUSDA="" Q 0 82 S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) 83 S XUSRTN=XUSROOT_","_XUSDA_","_0_")" 84 I '$D(@XUSRTN) Q "-1^Invalid IEN" 85 I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" 86 Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT 87 ; 88 QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. 89 ;;================================================ 90 ;; XUSNPI : National Provider Identifier. Required 91 ;; 92 ;; If qualified identified entity exists, return 93 ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' 94 ;; If more than one records found, they are separated by ";" 95 ;; Else return 0 96 ;;================================================ 97 ; check valid NPI 98 I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" 99 N ZZ 100 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") 101 I ZZ'>0 Q 0 102 N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" 103 S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D 104 . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT 105 . I $$GLCK(XUSROOT)'>0 Q ;check valid global root 106 . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 107 . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) 108 . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D 109 . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) 110 . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 111 I XUSRTN1="" S XUSRTN1=0 112 Q XUSRTN1 113 ; 114 GLCK(XUSROOT) ; check valid global root 115 N XUFNB,ZZ 116 I $G(XUSROOT)="" Q 0 117 S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") 118 D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") 119 Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) 120 ; 121 SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; 122 I $G(XUSIEN)'>0 Q 0 123 I (XUSIEN?.N)=0 Q 0 124 N XUSX,XUSRTN S XUSRTN=0 125 I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 126 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" 127 I '$D(@XUSX) Q 0 128 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" 129 S XUSRTN=$O(@XUSX,-1) 130 I '+XUSRTN Q 0 131 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" 132 I '$D(@XUSX) Q 0 133 S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) 134 I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" 135 I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" 136 Q XUSRTN 137 ; 138 CHKDGT(XUSNPI) ; 139 ; Function to validate the format of an NPI number. It checks the 140 ; length of the number, whether the NPI is numeric, and whether 141 ; the check digit is valid. 142 ; 143 ; Input parameter: 144 ; NPI - 10-digit NPI number to validate. 145 ; 146 ; Output parameter: 147 ; Boolean value indicating whether the NPI has a valid format 148 ; 149 ; NPI must be 10 digits long. 150 I XUSNPI'?10N Q 0 151 Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) 152 ; 153 CKDIGIT(XUSNPI) ; 154 ; Function to calculate and return the check digit of an NPI. 155 ; The check digit is calculated using the Luhn Formula for 156 ; Modulus 10 "double-add-double" Check Digit. A value of 24 is 157 ; added to the total to account for the implied USA (80840) prefix. 158 ; 159 N XUSCTOT,XUSCN,XUSCDIG,XUSI 160 S XUSCTOT=24 161 F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) 162 S XUSCDIG=150-XUSCTOT 163 Q $E(XUSCDIG,$L(XUSCDIG)) 164 ; 165 CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date 166 ;;============================================================================ 167 ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" 168 ;; XUSIEN : Internal Entry Number. Required. 169 ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. 170 ;; 171 ;; If input passes date comparison, return 1. 172 ;; Else return 0. 173 ;;============================================================================ 174 ; 175 I $G(XUSIEN)'>0 Q "0^Invalid IEN." 176 ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." 177 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 178 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." 179 ;----------------------------------- 180 N XUSROOT,XUSDA 181 N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 182 ; get global from Parameter file base on Qualified Identifier. 183 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 184 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 185 I XUSROOT="^" Q "0^Invalid Qualified Identifier." 186 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 187 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." 188 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) 189 Q (XUSDATE'<XUSDA) 190 ; 191 GETRLNPI(XUSIEN) ; Return field indicating blanket release of NPI 192 ;; XUSIEN : Internal Entry Number of person in file 200. Required 193 ;; Output: -1^error message or contents of AUTHORIZE RELEASE OF NPI field. 194 S XUSIEN=+$G(XUSIEN) I $G(^VA(200,XUSIEN,0))="" Q "-1^Invalid IEN" 195 N X 196 S X=$$NPI^XUSNPI("Individual_ID",XUSIEN) 197 I (X'>0)!($P(X,U,3)'="Active") Q "-1^User has no active NPI" 198 S X=$P($G(^VA(200,XUSIEN,"NPI")),U,3) 199 S:X="" X=0 200 Q X 201 ; 1 XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER; 8/10/06 2 ;;8.0;KERNEL;**410,416**; July 10, 1997;Build 5 3 ;; 4 ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; 5 ;;============================================================== 6 ;; Update the Effective Date, Status & NPI trio. 7 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 8 ;; XUSIEN : Internal Entry Number. Required. 9 ;; XUSNPI : National Provider Identifier. Required. 10 ;; XUSDATE : Active Date. Required. 11 ;; 12 ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. 13 ;; Else return XUSRTN = "-1^ErrorMessage". 14 ;; ============================================================= 15 ; 16 ; Check valid inputs. 17 N XUSROOT,XUSFNB 18 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 19 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 20 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 21 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 22 S XUSFNB=+$P(XUSROOT,"(",2) 23 I 'XUSFNB Q "-1^No File #" 24 S XUSFNB=XUSFNB_".42" 25 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 26 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 27 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 28 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 29 I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" 30 I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" 31 I $G(XUSTATUS)="" S XUSTATUS=1 32 I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" 33 N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. 34 I CHNPI'=1 Q "-1^The NPI is being used." 35 ; 36 ;------------------------------------------------------------------ 37 N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" 38 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" 39 ; Update Effective Date #42 multiple fields 40 S XUSFNB=$P(XUSROOT,"(",2) 41 S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" 42 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE 43 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS 44 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI 45 D UPDATE^DIE("","ZZ(1)",,ERRMSG) 46 I $L(ERRMSG) Q "-1^"_$G(ERRMSG) 47 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" 48 S XUSRTN=$O(@XUSX,-1) 49 I '+XUSRTN Q "-1^No entry add" 50 Q XUSRTN 51 ; 52 NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. 53 ;;============================================================== 54 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 55 ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. 56 ;; XUSDATE : Active Date. Not Required. Default: 'Today'. 57 ;; 58 ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' 59 ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' 60 ;; Else return 0 61 ;; ============================================================= 62 ; check valid inputs 63 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 64 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 65 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 66 I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT 67 N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" 68 ;----------------------------------- 69 N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" 70 ; get global from Parameter file base on Qualified Identifier. 71 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 72 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 73 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 74 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 75 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 76 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" 77 S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" 78 S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI 79 I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) 80 I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) 81 I XUSDA="" Q 0 82 S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) 83 S XUSRTN=XUSROOT_","_XUSDA_","_0_")" 84 I '$D(@XUSRTN) Q "-1^Invalid IEN" 85 I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" 86 Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT 87 ; 88 QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. 89 ;;================================================ 90 ;; XUSNPI : National Provider Identifier. Required 91 ;; 92 ;; If qualified identified entity exists, return 93 ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' 94 ;; If more than one records found, they are separated by ";" 95 ;; Else return 0 96 ;;================================================ 97 ; check valid NPI 98 I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" 99 N ZZ 100 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") 101 I ZZ'>0 Q 0 102 N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" 103 S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D 104 . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT 105 . I $$GLCK(XUSROOT)'>0 Q ;check valid global root 106 . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 107 . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) 108 . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D 109 . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) 110 . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 111 I XUSRTN1="" S XUSRTN1=0 112 Q XUSRTN1 113 ; 114 GLCK(XUSROOT) ; check valid global root 115 N XUFNB,ZZ 116 I $G(XUSROOT)="" Q 0 117 S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") 118 D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") 119 Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) 120 ; 121 SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; 122 I $G(XUSIEN)'>0 Q 0 123 I (XUSIEN?.N)=0 Q 0 124 N XUSX,XUSRTN S XUSRTN=0 125 I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 126 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" 127 I '$D(@XUSX) Q 0 128 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" 129 S XUSRTN=$O(@XUSX,-1) 130 I '+XUSRTN Q 0 131 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" 132 I '$D(@XUSX) Q 0 133 S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) 134 I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" 135 I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" 136 Q XUSRTN 137 ; 138 CHKDGT(XUSNPI) ; 139 ; Function to validate the format of an NPI number. It checks the 140 ; length of the number, whether the NPI is numeric, and whether 141 ; the check digit is valid. 142 ; 143 ; Input parameter: 144 ; NPI - 10-digit NPI number to validate. 145 ; 146 ; Output parameter: 147 ; Boolean value indicating whether the NPI has a valid format 148 ; 149 ; NPI must be 10 digits long. 150 I XUSNPI'?10N Q 0 151 Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) 152 ; 153 CKDIGIT(XUSNPI) ; 154 ; Function to calculate and return the check digit of an NPI. 155 ; The check digit is calculated using the Luhn Formula for 156 ; Modulus 10 "double-add-double" Check Digit. A value of 24 is 157 ; added to the total to account for the implied USA (80840) prefix. 158 ; 159 N XUSCTOT,XUSCN,XUSCDIG,XUSI 160 S XUSCTOT=24 161 F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) 162 S XUSCDIG=150-XUSCTOT 163 Q $E(XUSCDIG,$L(XUSCDIG)) 164 ; 165 CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date 166 ;;============================================================================ 167 ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" 168 ;; XUSIEN : Internal Entry Number. Required. 169 ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. 170 ;; 171 ;; If input passes date comparison, return 1. 172 ;; Else return 0. 173 ;;============================================================================ 174 ; 175 I $G(XUSIEN)'>0 Q "0^Invalid IEN." 176 ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." 177 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 178 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." 179 ;----------------------------------- 180 N XUSROOT,XUSDA 181 N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 182 ; get global from Parameter file base on Qualified Identifier. 183 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 184 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 185 I XUSROOT="^" Q "0^Invalid Qualified Identifier." 186 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 187 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." 188 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) 189 Q (XUSDATE'<XUSDA)
Note:
See TracChangeset
for help on using the changeset viewer.
