source: FOIAVistA/tag/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@ 1154

Last change on this file since 1154 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER; 8/10/06
2 ;;8.0;KERNEL;**410,416**; July 10, 1997;Build 5
3 ;;
4ADDNPI(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 ;
52NPI(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 ;
88QI(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 ;
114GLCK(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 ;
121SRCHNPI(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 ;
138CHKDGT(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 ;
153CKDIGIT(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 ;
165CHKDT(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 TracBrowser for help on using the repository browser.