source: ePrescribing/trunk/p/C0PSUB.m

Last change on this file was 1595, checked in by George Lilly, 12 years ago

initial release of ePrescribing

File size: 14.6 KB
Line 
1C0PSUB ; ERX/GPL - ERX SUBSCRIBER utilities; 5/8/12 9:51pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 103
3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU
4 ;General Public License See attached copy of the License.
5 ;
6 ;This program is free software; you can redistribute it and/or modify
7 ;it under the terms of the GNU General Public License as published by
8 ;the Free Software Foundation; either version 2 of the License, or
9 ;(at your option) any later version.
10 ;
11 ;This program is distributed in the hope that it will be useful,
12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;GNU General Public License for more details.
15 ;
16 ;You should have received a copy of the GNU General Public License along
17 ;with this program; if not, write to the Free Software Foundation, Inc.,
18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19 ;
20 QUIT
21EN(INARY,C0PDUZ) ; creates the array inary passed by name for subscriber
22 ; variables, mostly from the new person file
23 ; SUBSCRIBER-FAMILY-NAME
24 ; SUBSCRIBER-GIVEN-NAME
25 ; SUBSCRIBER-MIDDLE-NAME
26 ; LOCATION-PHONE
27 ; LOCATION-FAX
28 ; ACCOUNT-PHONE
29 ; ACCOUNT-FAX
30 ; LOCATION-ADDRESS1
31 ; LOCATION-ADDRESS2
32 ; LOCATION-CITY
33 ; LOCATION-ZIP
34 ; LOCATION-ZIP4
35 ; LOCATION-STATE
36 ; SUBSCRIBER-LICENSE
37 ; SUBSCRIBER-LICENSE-STATE
38 ; SUBSCRIBER-USERROLE
39 ; SUBSCRIBER-USER
40 ; ACCOUNT-COUNTRY
41 ; ACCOUNT-ADDRESS-ZIP4
42 ; LOCATION-COUNTRY
43 ; REQUESTED-PAGE
44 D FAMILY(INARY,"SUBCRIBER-FAMILY-NAME",C0PDUZ)
45 D GIVEN(INARY,"SUBCRIBER-GIVEN-NAME",C0PDUZ)
46 D MIDDLE(INARY,"SUBCRIBER-MIDDLE-NAME",C0PDUZ)
47 D PHONEFAX(INARY,C0PLOC) ; SETS "LOCATION-PHONE" AND "LOCATION-FAX"
48 D ACTPHFAX(INARY,C0PACCT) ;SETS "ACCOUNT-PHONE" AND "ACCOUNT-FAX"
49 D GETLOC(INARY,C0PLOC) ;SETS "LOCATION-" VARIABLES (SEE ROUTINE FOR LIST)
50 D STLIC(INARY,C0PDUZ,C0PACCT) ;LICENSE AND LICENSE STATE
51 S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
52 S @INARY@("ACCOUNT-PARTNERNAME")=$$GET1^DIQ(C0PAF,C0PACCT_",",3.1) ;
53 I @INARY@("ACCOUNT-PARTNERNAME")="" S @INARY@("ACCOUNT-PARTNERNAME")="demo"
54 ; todo: NPs, PAs, assistants need different roles
55 D SETACCT(INARY,C0PDUZ) ; SET SUBSCRIBER VARIABLES
56 ;S @INARY@("SUBSCRIBER-USERROLE")="doctor" ; BASE CASE ACCESS
57 ;S @INARY@("SUBSCRIBER-USER")="LicensedPrescriber" ; BASE CASE ACCESS
58 S @INARY@("ACCOUNT-COUNTRY")="US" ;BASE CASE ACCESS
59 S @INARY@("ACCOUNT-ADDRESS-ZIP4")="" ;DON'T HAVE THIS
60 S @INARY@("LOCATION-COUNTRY")="US" ; NOT IN FILE
61 S @INARY@("REQUESTED-PAGE")="compose" ; DEFAULT PAG
62 S @INARY@("ACCOUNT-ACCOUNTID")=$$GET1^DIQ(C0PAF,C0PACCT_",",2.4)
63 I @INARY@("ACCOUNT-ACCOUNTID")="" S @INARY@("ACCOUNT-ACCOUNTID")="demo"
64 S @INARY@("ACCOUNT-NAME")=$$GET1^DIQ(C0PAF,C0PACCT_",",3)
65 I @INARY@("ACCOUNT-NAME")="" S @INARY@("ACCOUNT-NAME")="demo"
66 S @INARY@("ACCOUNT-PASSWORD")=$$GET1^DIQ(C0PAF,C0PACCT_",",3.2)
67 I @INARY@("ACCOUNT-PASSWORD")="" S @INARY@("ACCOUNT-PASSWORD")="demo"
68 ;S @INARY@("SUBSCRIBER-USERTYPE")="Doctor" ; IS RESET LATER
69 ;S @INARY@("SUBSCRIBER-USERID")="demo" ; IS RESET LATER
70 ;N NPI S NPI=$$NPI^XUSNPI("Individual_ID",C0PDUZ)
71 ;S @INARY@("SUBSCRIBER-SID")=+NPI ; FOR NOW
72 ;
73 Q
74 ;
75ACTPHFAX(RARY,ZACCT) ;SET ACCOUNT PHONE AND FAX FROM ACCOUNT FILE
76 ; ZACCT IS A POINTER TO THE ACCOUNT FILE
77 S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
78 S @RARY@("ACCOUNT-PHONE")=$$GET1^DIQ(C0PAF,ZACCT_",",2.2) ;PHONE NUMBER
79 S @RARY@("ACCOUNT-FAX")=$$GET1^DIQ(C0PAF,ZACCT_",",2.1) ; FAX NUMBER
80 Q
81 ;
82PHONEFAX(RARY,C0PLOC) ; SET LOCATION PHONE AND FAX INTO THE RETURN ARRAY
83 N PRIORITY,LOCIEN
84 S PRIORITY=$O(^SC(C0PLOC,"C0P","PRIORITY",""))
85 I PRIORITY="" W "NO LOCATION PHONE SET",! Q
86 S LOCIEN=$O(^SC(C0PLOC,"C0P","PRIORITY",PRIORITY,""))
87 S C0PLOCF=44.113059
88 S @RARY@("LOCATION-PHONE")=$$GET1^DIQ(C0PLOCF,LOCIEN_","_C0PLOC_",",1)
89 S @RARY@("LOCATION-FAX")=$$GET1^DIQ(C0PLOCF,LOCIEN_","_C0PLOC_",",2)
90 Q
91 ;
92GETLOC(RARY,ZLOC) ; GETS LOCATIONS VARIABLE FROM POINTER ZLOC
93 ; TO THE HOSPITAL LOCATION FILE
94 ; THE LOCATION ADDRESS IS FOUND IN NEW FIELDS IN THE HOSPITAL LOCATION FILE 44
95 ; IF THESE ARE NULL, THE ADDRESS WILL BE TAKEN FROM THE INSTITUTION FILE,
96 ; WHICH IS POINTED TO BY THE FILE 44
97 ;
98 S @RARY@("LOCATION-SITEID")="LOCATION_"_ZLOC ; SITE ID
99 S @RARY@("LOCATION-ADDRESS1")=$$GET1^DIQ(44,ZLOC_",",113059111) ;ADDR1
100 I @RARY@("LOCATION-ADDRESS1")'="" D ; ADDRESS PRESENT IN 44
101 . S @RARY@("LOCATION-ADDRESS2")=$$GET1^DIQ(44,ZLOC_",",113059112) ;ADDR2
102 . S @RARY@("LOCATION-CITY")=$$GET1^DIQ(44,ZLOC_",",113059114) ;CITY
103 . S @RARY@("LOCATION-ZIP")=$$GET1^DIQ(44,ZLOC_",",113059116) ;ZIP
104 . S @RARY@("LOCATION-ZIP4")="" ;NO ZIP4
105 . N ZJ
106 . S ZJ=$$GET1^DIQ(44,ZLOC_",",113059115,"I") ;STATE
107 . S @RARY@("LOCATION-STATE")=$$GET1^DIQ(5,ZJ_",",1) ;STATE ABBREVIATION
108 E D ; TAKE THE ADDRESS FROM THE INSTITUTION FILE
109 . N ZI
110 . S ZI=$$GET1^DIQ(44,ZLOC_",",3,"I") ; POINTER TO INSTITUTION FILE
111 . S @RARY@("LOCATION-ADDRESS1")=$$GET1^DIQ(4,ZI_",",1.01) ;ADDR1
112 . S @RARY@("LOCATION-ADDRESS2")=$$GET1^DIQ(4,ZI_",",1.02) ;ADDR2
113 . S @RARY@("LOCATION-CITY")=$$GET1^DIQ(4,ZI_",",1.03) ;CITY
114 . S @RARY@("LOCATION-ZIP")=$$GET1^DIQ(4,ZI_",",1.04) ;ZIP
115 . S @RARY@("LOCATION-ZIP4")="" ;NO ZIP4
116 . N ZJ
117 . S ZJ=$$GET1^DIQ(4,ZI_",",.02,"I") ;STATE
118 . S @RARY@("LOCATION-STATE")=$$GET1^DIQ(5,ZJ_",",1) ;STATE ABBREVIATION
119 Q
120 ;
121SUBINIT(C0PDUZ) ;
122 ; SUBSCRIPTIONS MULTIPLE IN NEW PERSON
123 S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
124 S C0PSUBF=200.113059 ; SUBFILE NUMBER OF C0P SUBSCRIPTION MULTIPLE
125 S C0PSIEN=$O(^VA(200,C0PDUZ,"C0P","B","ERX","")) ; ERX SUBFILE IEN
126 Q C0PSIEN
127 ;
128HASLIC(ZDUZ) ;EXTRINSIC TO CHECK IF PERSON HAS ANY STATE LICENSES
129 ;
130 Q ''$O(^VA(200,ZDUZ,"PS1","B",""))
131 ;
132GLICST(ZACCT) ;EXTRINSIC WHICH RETURNS THE POINTER TO THE STATE
133 ;WHICH IS THE PREFERED LICENSE STATE IN THE ACCOUNT PASSED IN ZACCT
134 S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
135 Q $$GET1^DIQ(C0PAF,ZACCT_",",5,"I")
136 ;
137STLIC(ZARY,ZDUZ,ZACCT) ;ADDS SUBSCRIBER-LICENSE AND SUBSCRIBER-LICENSE-STATE
138 ; TO ZARY, PASSED BY NAME BY LOOKING IN THE STATE LICENSE MULTIPLE
139 ; OF THE NEW PERSON FILE FOR THE PREFERED STATE AS FOUND BY GLICST ABOVE
140 ; FROM THE ACCOUNT NUMBER ZACCT
141 ; IF THE PREFERED STATE IS NOT FOUND, THE FIRST STATE LISTED IS USED
142 I '$$HASLIC(ZDUZ) D ; NEW PERSON ZDUZ HAS NO STATE LICENSES DEFINED
143 . S @ZARY@("SUBSCRIBER-LICENSE")="" ; NULL LICENSE
144 . S @ZARY@("SUBSCRIBER-LICENSE-STATE")="" ;NULL LICENSE STATE
145 E D ; THERE IS A LICENSE
146 . N ZST,ZIEN
147 . S ZST=$$GLICST(ZACCT) ; GET PREFERED LICENSE STATE FROM ACCOUNT FILE
148 . S ZIEN=$O(^VA(200,ZDUZ,"PS1","B",ZST,"")) ;IEN OF PREFERED STATE
149 . I ZIEN="" D ; PREFERED STATE NOT FOUND
150 . . ; todo: use get1^diq here instead of looping through global
151 . . S ZST=$O(^VA(200,ZDUZ,"PS1","B","")) ; FIRST STATE IN MULTIPLE
152 . . S ZIEN=$O(^VA(200,ZDUZ,"PS1","B",ZST,"")) ; IEN OF FIRST STATE
153 . S @ZARY@("SUBSCRIBER-LICENSE")=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",",1) ;LIC
154 . ; Try this...
155 . ; N ZG S ZG=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",","LICENSING STATE:ABBREVIATION")
156 . N ZG S ZG=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",",.01,"I") ;STATE POINTER
157 . S ZG=$$GET1^DIQ(5,ZG_",",1) ; STATE ABBREVIATION
158 . S @ZARY@("SUBSCRIBER-LICENSE-STATE")=ZG
159 Q
160FAMILY(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO FAMILY NAME OF DUZ
161 ;USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME.
162 S @RARY@(TAG)=$$FAMILY^C0CVA200(C0PDUZ)
163 Q
164 ;
165GIVEN(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO GIVEN NAME OF SUBSCRIBER
166 ; USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME
167 S @RARY@(TAG)=$$GIVEN^C0CVA200(C0PDUZ)
168 Q
169 ;
170MIDDLE(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO MIDDLE NAME OF SUBSCRIBER
171 ; USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME
172 S @RARY@(TAG)=$$MIDDLE^C0CVA200(C0PDUZ)
173 Q
174 ;
175STATUS(C0PDUZ,SERVICE) ; $$ Private EP - Check Prescriber's ability to use Service
176 ; FILEMAN USES THIS CALL. Field Status in C0P Subscription Multiple is
177 ; + a computed field.
178 ; gpl - changed the order of this Algorithm to do NPI and DEA last
179 ; because they are not required for all user type and roles
180 ; Algorithm as follows:
181 ; 1. Check existence of DEA# or Institutional DEA + VA#
182 ; 2. Check existence of NPI
183 ; 3. Check for at least one license in the licensure subfile in 200
184 ; 4. Check if a C0P Subscription for SERVICE in subfile C0P in 200 exists
185 ; 5. Check if a C0P Subscription for points to a valid account
186 ; 6. Check if a C0P Location is defined
187 ; 7. Make sure that the service is not disabled for the user.
188 ; 8. Check if the pointed to location has a phone and fax number filled in.
189 ; -- Output --
190 ; 1^ACTIVE --> Everything is fine
191 ; 0^NO DEA^NO NPI^NO LICENSE^NO SUBSCRIPTION^NO SUBSCRIPTION ACCOUNT^
192 ; + NO SUBSCSRIPTION LOCATION^SUBSCSRIBER IS DISABLED^LOCATION NOT SETUP
193 N RETURN
194 S RETURN="0" ; default case
195 ; --> step 4, see if there's an entry for the service IEN
196 N C0PVARS
197 N SERVIEN S SERVIEN=$O(^VA(200,C0PDUZ,"C0P","B",SERVICE,""))
198 I $L(SERVIEN)=0 S RETURN=RETURN_"^NO SUBSCRIPTION"
199 D:SERVIEN
200 . ; --> step 5, see if the service points to a valid account
201 . N ACCOUNT S ACCOUNT=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",1)
202 . I $L(ACCOUNT)=0 S RETURN=RETURN_"^NO SUBSCSRIPTION ACCOUNT"
203 . ; --> step 6, see if the service points to a valid location
204 . ; internal will return the IEN for use in a call below.
205 . N LOCATION S LOCATION=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",2,"I")
206 . I $L(LOCATION)=0 S RETURN=RETURN_"^NO SUBSCSRIPTION LOCATION"
207 . ; --> step 7, see if the user is disabled from service
208 . ; Internal will return 1 or 0, 1 for yes
209 . N DISABLED S DISABLED=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",3,"I")
210 . I +DISABLED S RETURN=RETURN_"^SUBSCSRIBER IS DISABLED"
211 . ; --> step 8, see if at least one set of location
212 . ; + phone and fax numbers have been set-up
213 . D:LOCATION
214 . . N PHONE,FAX,ARY
215 . . D PHONEFAX("ARY",LOCATION) ; GET THE LOCATION PHONE AND FAX
216 . . ;S PHONE=$$GET1^DIQ(44.113059,"1,"_LOCATION_",",1) ;this doesn't work
217 . . ;S FAX=$$GET1^DIQ(44.113059,"1,"_LOCATION_",",2) ; because of the 1
218 . . S PHONE=$G(ARY("LOCATION-PHONE")) ; PHONE IF ANY
219 . . S FAX=$G(ARY("LOCATION-FAX")) ; FAX IF ANY
220 . . I ($L(PHONE)=0)!($L(FAX)=0) S RETURN=RETURN_"^LOCATION NOT SETUP"
221 . D SETACCT("C0PVARS",C0PDUZ) ; INITIALIZE ARRAY
222 . ; --> step 1: DEA
223 . ;N DEA S DEA=$$DEA^XUSER("",C0PDUZ)
224 . ;I $L(DEA)=0 S RETURN=RETURN_"^NO DEA"
225 . I C0PVARS("SUBSCRIBER-DEA")="NONE" D ;
226 . . I C0PTYPE="P" S RETURN=RETURN_"^NO DEA" ; ONLY PRESCRIBERS NEED DEA
227 . ; --> step 2: NPI
228 . ;N NPI S NPI=$$NPI^XUSNPI("Individual_ID",C0PDUZ)
229 . ;I +NPI<0 S RETURN=RETURN_"^NO NPI"
230 . I C0PVARS("SUBSCRIBER-NPI")="NONE" D ;
231 . . I C0PTYPE="P" S RETURN=RETURN_"^NO NPI" ; ONLY PRESCRIBERS NEED DEA
232 . ; --> step 3, get first license # in license multiple
233 . N LIC S LIC=$$HASLIC(C0PDUZ)
234 . I 'LIC D ;
235 . . I (C0PTYPE="P")!(C0PROLE="N") S RETURN=RETURN_"^NO LICENSE" ;
236 . . ; PRESCRIBERS AND NURSES NEED LICENSE
237 ; If Retrun is still 0 and nothing else, then we are good.
238 I RETURN="0" S RETURN="1^ACTIVE"
239 QUIT RETURN ; <-- END $$STATUS
240 ;
241STATUS2 ; Private Procedure for interactive check of status
242 N DIC,X,Y,DLAYGO,DTOUT,DUOUT
243 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select New Person: "
244 D ^DIC
245 I Y<0 QUIT
246 N C0PDUZ S C0PDUZ=+Y
247 ; Then which service are we checking for
248 ; Grab this from the DD
249 N DIR,X,Y,DA,DTOUT,DUOUT,DIRUT,DIROUT
250 S DIR(0)="200.113059,.01"
251 S DIR("A")="Select Subcription Service"
252 D ^DIR
253 I $G(DIRUT) QUIT
254 N C0PSERV S C0PSERV=Y
255 N STATUS S STATUS=$$STATUS^C0PSUB(C0PDUZ,C0PSERV)
256 D EN^DDIOL("Status: "_$TR($P(STATUS,U,2,99),U,", "))
257 QUIT
258 ;
259SETACCT(C0PRTN,C0PDUZ) ; RETURN ALL SUBSCRIBER SETTINGS FOR
260 ; GENERATING XML AND VERIFYING A COMPLETE SETUP
261 ; ALSO, INITIALIZE NULL FIELDS WITH DEFAULTS
262 ; C0PRTN IS PASSED BY NAME
263 ; C0PSERV IS USUALLY "ERX" FOR EPRESCRIBING
264 ;
265 ;USER TYPE
266 ;
267 ;P LicensedPrescriber
268 ;S Staff
269 ;M MidlevelPrescriber
270 ;V SupervisingDoctor
271 ;
272 ;USER ROLE
273 ;
274 ;D doctor
275 ;N nurse
276 ;A admin
277 ;M manager
278 ;SD supervisingDoctor
279 ;MP midlevelPrescriber
280 ;
281 ;Requested Page
282 ;
283 ;C compose
284 ;A admin
285 ;M manager
286 ;S status
287 ;ME medentry
288 ;P patientDetail
289 ;H maintainHealthplans
290 ;R reports-rx-daily
291 ;
292 N ZI,ZJ
293 D SETUP^C0PMAIN() ; INITIALIZE VARIABLES
294 I ERXSERVIEN="" Q ; PERSON NOT SUBSCRIBED
295 S C0PTYPE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4,"I")
296 S C0PROLE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4.1,"I")
297 S C0PPAGE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4.2,"I")
298 N C0PSV ; SUPERVISING DOCTOR DUZ
299 S C0PSV=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",6,"I")
300 ; FIELD 6 IS SUPERVISING DOCTOR. USED FOR MIDLEVEL RENEWAL PROCESSING
301 I $G(C0PSV)'="" D ; IF THERE IS A SUPERVISING DOCTOR
302 . S @C0PRTN@("SUPERVISING-DOCTOR-DUZ")=C0PSV ; RECORD FOR LATER USE
303 I C0PTYPE="" D ; SUBSCRIBER TYPE NOT SET
304 . I C0PROLE="N" S C0PTYPE="S" ; DEFAULT FOR NURSE IS STAFF
305 . E S C0PTYPE="P" ; ELSE DEFAULT TYPE IS LICENSEDPRESCRIBER
306 . K C0PFDA
307 . S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4)=C0PTYPE ;SET TYPE
308 . D UPDIE ; SET THE SUBSCRIBER TYPE
309 I C0PROLE="" D ; SUBSCRIBER ROLE NOT SET
310 . I C0PTYPE="P" S C0PROLE="D" ; DOCTOR IS DEFAULT FOR LICENSED PRESCRIBER
311 . E S C0PROLE="N" ; ALL OTHERS SET TO NURSE
312 . K C0PFDA
313 . S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4.1)=C0PROLE ;SET ROLE
314 . D UPDIE ; SET THE SUBSCRIBER ROLE
315 I C0PPAGE="" D ;
316 . I C0PTYPE="P" S C0PPAGE="C" ; PRESCRIBERS TO COMPOSE PAGE
317 . E S C0PPAGE="P" ; ALL OTHERS DEFAULT TO PATIENT DETAIL PAGE
318 . K C0PFDA
319 . S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4.2)=C0PPAGE ;SET PAGE
320 . D UPDIE ; SET THE REQUESTED PAGE
321 N ZF S ZF=$$F200C0P^C0PMAIN()
322 S @C0PRTN@("REQUESTED-PAGE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4.2)
323 S @C0PRTN@("SUBSCRIBER-USERROLE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4.1)
324 S @C0PRTN@("SUBSCRIBER-USERTYPE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4)
325 S C0PSID=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",5)
326 I C0PSID="" D ; SUBSCRIBER ID NOT SET
327 . S C0PSID=$$UUID^C0CUTIL ; SET TO RANDOM UUID
328 . K C0PFDA
329 . S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",5)=C0PSID ;SET SID
330 . D UPDIE ; SET SUBSCRIBER ID
331 N NPI S NPI=+$$NPI^XUSNPI("Individual_ID",C0PDUZ)
332 I NPI=-1 S NPI="NONE"
333 S @C0PRTN@("SUBSCRIBER-NPI")=NPI
334 N DEA S DEA=$$DEA^XUSER("",C0PDUZ)
335 I $L(DEA)=0 S DEA="NONE"
336 S @C0PRTN@("SUBSCRIBER-DEA")=DEA
337 ;N C0PNPIF ; NPI FOR SID LEGACY FLAG - DON'T NEW THIS, IT'S NEEDED LATER
338 S C0PNPIF=$$GET1^DIQ(C0PAF,C0PACCT_",",8,"I") ; LEGACY FLAG TO USE NPI FOR SID
339 I C0PNPIF'=1 S @C0PRTN@("SUBSCRIBER-SID")=C0PSID ; IF NO FLAG, USE GUID
340 E D ; IF LEGACY FLAG IS ON, USE NPI FOR SID
341 . S @C0PRTN@("SUBSCRIBER-SID")=NPI
342 . I NPI="NONE" S @C0PRTN@("SUBSCRIBER-SID")="USER"_C0PDUZ ; IF NO NPI
343 Q
344 ;
345UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
346 K ZERR
347 D CLEAN^DILF
348 D UPDATE^DIE("","C0PFDA","","ZERR")
349 I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
350 K C0PFDA
351 Q
Note: See TracBrowser for help on using the repository browser.