source: cprs/branches/tmg-cprs/m_files/TMGGDFN.m@ 861

Last change on this file since 861 was 796, checked in by Kevin Toppenberg, 15 years ago

Initial upload
File size: 40.9 KB
Line 
1TMGGDFN ;TMG/kst-Get A Patient's IEN (DFN) ;01/01/04
2 ;;1.0;TMG-LIB;**1**;06/04/08
3
4 ;"TMG GET DFN (TMGGDFN)
5 ;"
6 ;"Purpose: This module will provide functionality for getting a DFN
7 ;" (which is the database record number) for a given patient.
8 ;" If the patient has not been encountered before, then the patient
9 ;" will be added to the database.
10
11 ;"=======================================================================
12 ;" API -- Public Functions.
13 ;"=======================================================================
14 ;"$$GetDFN(Info) -- Ensure that a patient is registered, return IEN
15 ;"$$GetDFN2(Entry,AutoRegister) -- Get patient DFN (i.e. IEN), possibly registering if needed.
16 ;" This function is very similar to GetDFN, but slightly streamlined.
17
18 ;"=======================================================================
19 ;"PRIVATE API FUNCTIONS
20 ;"=======================================================================
21 ;"Pat2Entry(Patient,Entry) convert a named-node entry, into numeric 'Entry' array:
22 ;"LookupPatient(Entry)
23 ;"SSNumLookup(SSNum)
24 ;"PMSNumLookup(PMSNum)
25 ;"ParadigmNumLookup(PMSNum)
26 ;"Compare(TestData,dbData,EntryNum)
27 ;"CompEntry(TestData,dbDataEntry)
28 ;"$$AddToPat(DFN,Entry)
29 ;"$$AddNewPt(Entry)
30
31
32 ;"=======================================================================
33 ;"PRIVATE FUNCTIONS
34 ;"=======================================================================
35 ;"SSNum2Lookup(SSNum) <--- depreciated
36
37
38GetDFN(Patient)
39 ;"Purpose: This code is to ensure that a patient is registered
40 ;" It is intended for use during upload of old records
41 ;" from another EMR. As each dictation is processed,
42 ;" this function will be called with the header info.
43 ;" If the patient is already registered, then this function
44 ;" will have no effect other than to return the DFN.
45 ;" Otherwise, the patient will be registered.
46 ;" ??? *I'll have this function used another way as well: If
47 ;" only the TMGPTNUM is passed, it will load valid values
48 ;" into TMGNAME etc., which can be passed back to the calling
49 ;" function (providing that values were passed by reference)
50 ;"Input: Patient: Array is loaded with Patient, like this:
51 ;" Patient("SSNUM")="123-45-6789"
52 ;" Patient("NAME")="DOE,JOHN"
53 ;" Patient("DOB")="01-04-69"
54 ;" Patient("PATIENTNUM")="12345677" <-- Medic account number
55 ;" Patient("SEQUELNUM")="234567890" <-- SequelMedSystems Account number
56 ;" Patient("PARADIGMNUM")="234567890" <-- Pardigm Account number
57 ;" Patient("SEX")="M"
58 ;" Patient("ALIAS")="DOE,JOHNNY"
59 ;" -Note: The following are optional, only used if adding a patient
60 ;" If adding a patient, and these are not supplied, then defaults of
61 ;" Not a veteran, NON-VETERAN type, Not service connected are used
62 ;" Patient("VETERAN")= VETERAN Y/N --For my purposes, use NO -- optional
63 ;" Patient("PT_TYPE")= "SERVICE CONNECTED?" -- required field -- optional
64 ;" Patient("SERVICE_CONNECTED")= "TYPE" - required field -- optional
65
66 ;" (TMGFREG) Also, variable with global scope, TMGFREG, is used
67 ;" if TMGFREG=1, and patient is not found, then
68 ;" patient will be automatically registered as a new patient.
69 ;"
70 ;"Output: The patient's info is used to register the patient, if they are
71 ;" are not already registered
72 ;"Result: RETURNS DFN (patient internal entry number), or -1 if not found or added.
73 ;"------------------------------------------------------------------------------
74
75 new result,Entry
76 do Pat2Entry(.Patient,.Entry)
77 set result=$$LookupPatient(.Entry)
78 if result>0 goto ERDone
79 ;"1-18-2005 I am going to stop adding patients automatically--I think it
80 ;" will make duplicate entries. I should have all patients in now...
81 ;"10-15-2005 I will allow the patient to be added automatically if the variable
82 ;" with global scope TMGFREG=1 (stands for: TMG FORCE REGISTRATION)
83 ;" At this time, this will only be set from ERRORS^TMGUPLD
84 set result=-1 ;"signal failure as default
85 if $get(TMGFREG)=1 do ;"Allowed gobal-scope variable to force add.
86 . set result=$$AddNewPt(.Entry)
87 . if result'>0 set result=-1
88
89ERDone
90 quit result ;"result=DFN
91
92
93GetDFN2(Entry,AutoRegister)
94 ;"Purpose: Get patient DFN (i.e. IEN), possibly registering if needed.
95 ;" This function is very similar to GetDFN, but slightly streamlined.
96 ;"Input: Entry: Array is loaded with Patient, like this:
97 ;" Entry(.01)=PatientName, e.g. DOE,JOHN
98 ;" Entry(.02)=Sex e.g. M
99 ;" Entry(.03)=DOB e.g. 01-04-69
100 ;" --Below are optional (depending if fields have Fileman 'required' status)
101 ;" Entry(.09)=SSNum e.g. 123-45-6789
102 ;" Entry(10,.01)=ALIAS e.g. DOE,JOHNNY
103 ;" Entry(1901)=VETERAN
104 ;" Entry(.301)=PT_TYPE
105 ;" Entry(391)=SERVICE_CONNECTED
106 ;" Entry(22700)=PatientNum
107 ;" Entry(22701)=PMS ACCOUNT NUM
108 ;" Entry(22701)=SEQUELNUM
109 ;" Entry(22702)=PARADIGM
110 ;" AutoRegister: if 1, then patient will be registered if not found.
111 ;"Output: The patient's info is used to register the patient, if they are
112 ;" are not already registered
113 ;"Result: DFN (patient IEN), or 0 if not found/added.
114 ;"------------------------------------------------------------------------------
115
116 new result
117 set result=$$LookupPatient(.Entry)
118 if result>0 goto DFN2Done
119 if $get(AutoRegister)=1 set result=$$AddNewPt(.Entry)
120
121DFN2Done
122 quit result ;"result=DFN
123
124
125
126 ;"======================================================================
127
128Pat2Entry(Patient,Entry)
129 ;"Purpose: to convert a named-node entry, into numeric 'Entry' array:
130 ;"Input: Patient: PASS BY REFERENCE. Array loaded with patient info:
131 ;" Patient("SSNUM")="123-45-6789"
132 ;" Patient("NAME")="DOE,JOHN"
133 ;" Patient("DOB")="01-04-69"
134 ;" Patient("PATIENTNUM")="12345677" <-- Medic account number
135 ;" Patient("SEQUELNUM")="234567890" <-- SequelMedSystems Account number
136 ;" Patient("PARADIGMNUM")="234567890" <-- Pardigm Account number
137 ;" Patient("SEX")="M"
138 ;" Patient("ALIAS")="DOE,JOHNNY"
139 ;" -Note: The following are optional, only used if adding a patient
140 ;" If adding a patient, and these are not supplied, then defaults of
141 ;" Not a veteran, NON-VETERAN type, Not service connected are used
142 ;" Patient("VETERAN")= VETERAN Y/N --For my purposes, use NO -- optional
143 ;" Patient("PT_TYPE")= "SERVICE CONNECTED?" -- required field -- optional
144 ;" Patient("SERVICE_CONNECTED")= "TYPE" - required field -- optional
145 ;" Entry; PASS BY REFERENCE, an OUT PARAMETER.
146 ;" Entry(.01)=PatientName
147 ;" Entry(.02)=Sex
148 ;" Entry(.03)=DOB
149 ;" Entry(.09)=SSNum
150 ;" Entry(22700)=PatientNum
151 ;" Entry(22701)=PMS ACCOUNT NUM
152 ;" Entry(22701)=SEQUELNUM
153 ;" Entry(22702)=PARADIGM
154 ;" Entry(10,.01)=ALIAS
155 ;" Entry(1901)=VETERAN
156 ;" Entry(.301)=PT_TYPE
157 ;" Entry(391)=SERVICE_CONNECTED
158 ;"Results: None
159
160 if $data(Patient("NAME")) set Entry(.01)=$get(Patient("NAME"))
161 if $data(Patient("SEX")) set Entry(.02)=$get(Patient("SEX"))
162 if $data(Patient("DOB")) set Entry(.03)=$get(Patient("DOB"))
163 if $data(Patient("SSNUM")) set Entry(.09)=$get(Patient("SSNUM"))
164 if $data(Patient("PATIENTNUM")) set Entry(22700)=$get(Patient("PATIENTNUM"))
165 if $data(Patient("PMS ACCOUNT NUM")) set Entry(22701)=$get(Patient("PMS ACCOUNT NUM"))
166 if $data(Patient("SEQUELNUM")) set Entry(22701)=$get(Patient("SEQUELNUM"))
167 if $data(Patient("PARADIGMNUM")) set Entry(22702)=$get(Patient("PARADIGM"))
168 if $data(Patient("ALIAS")) set Entry(10,.01)=$get(Patient("ALIAS"))
169
170 if $data(Patient("VETERAN")) set Entry(1901)=Patient("VETERAN")
171 if $data(Patient("PT_TYPE")) set Entry(.301)=Patient("PT_TYPE")
172 if $data(Patient("SERVICE_CONNECTED")) set Entry(391)=Patient("SERVICE_CONNECTED")
173
174 quit
175
176
177LookupPatient(Entry)
178 ;"Purpose: Search for Patient (an existing entry in the database)
179 ;"Input: Entry -- Array is loaded with info, like this:
180 ;" set Entry(.01)=Name
181 ;" set Entry(.02)=Sex
182 ;" set Entry(.03)=DOB
183 ;" set Entry(.09)=SSNum
184 ;" set Entry(22700)=PtNum
185 ;" set Entry(22701)=SequelSystems PMS AccountNumber
186 ;" set Entry(22702)=Paradigm PMS AccountNumber
187 ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found
188 ;"NOTE: For now, I am ignoring any passed Alias info.
189 ;"------------------------------------------------------------------------------
190
191 if $data(cConflict)#10=0 new cConflict set cConflict=0
192 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
193 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2
194 if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3
195
196 new Missing set Missing=0
197 new BailOut set BailOut=0
198 new result set result=0 ;"set default to no match, or conflict found
199 new TMGErrMsg,TMGOutput
200 new RecComp
201
202 ;"If can find patient by SSNum, then don't look any further (if successful)
203 if +$get(Entry(.09))>0 set result=$$SSNumLookup(Entry(.09))
204 if result>0 goto LUDone
205
206 ;"If can find patient by SequelMedSystem account number, then don't look any further (if successful)
207 if (+$get(Entry(22701))>0),$$FieldExists(22701) set result=$$PMSNumLookup(Entry(22701))
208 if result>0 goto LUDone
209
210 ;"If can find patient by Paradigm account number, then don't look any further (if successful)
211 if (+$get(Entry(22702))>0),$$FieldExists(22702) set result=$$ParadigmNumLookup(Entry(22702))
212 if result>0 goto LUDone
213
214 ;"Below specifies fields to get back.
215 new Value set Value=$get(Entry(.01))
216
217 ;"=========================================================
218 ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP)
219 do
220 . new File set File=2 ;"PATIENT file.
221 . new IENS set IENS=""
222 . new Fields set Fields="@;.01;.02;.03;.09"
223 . if $$FieldExists(22700) set Fields=Fields_";22700"
224 . ;"new Fields set Fields=".01"
225 . new Flags set Flags="M"
226 . new MatchValue set MatchValue=Value
227 . new Number set Number="*" ;"i.e. max number to return *=all entries.
228 . new Indexes set Indexes=""
229 . new ScreenCode set ScreenCode="" ;"option screening M code
230 . new Ident set Ident="" ;"optional text to accompany each found entry
231 . new OutVarP set OutVarP="TMGOutput"
232 . new ErrVarP set ErrVarP="TMGErrMsg"
233 . do FIND^DIC(File,IENS,Fields,Flags,MatchValue,Number,Indexes,ScreenCode,Ident,OutVarP,ErrVarP)
234 ;"-----------------------------------------------------------
235 ;"Here is an example of the output of FIND^DIC():
236 ;"TMGOutput("DILIST",0)="2^*^0^" <-2 matches
237 ;"TMGOutput("DILIST",0,"MAP")=".01^.02^.03^.09^22700"
238 ;"TMGOutput("DILIST",2,1)=16
239 ;"TMGOutput("DILIST",2,2)=2914
240 ;"TMGOutput("DILIST","ID",1,.01)="VIRIATO,ENEAS"
241 ;"TMGOutput("DILIST","ID",1,.02)="MALE"
242 ;"TMGOutput("DILIST","ID",1,.03)="01/20/1957"
243 ;"TMGOutput("DILIST","ID",1,.09)=123237654
244 ;"TMGOutput("DILIST","ID",1,22700)=3542340
245 ;"TMGOutput("DILIST","ID",2,.01)="VOID,BURT"
246 ;"TMGOutput("DILIST","ID",2,.02)="FEMALE"
247 ;"TMGOutput("DILIST","ID",2,.03)=""
248 ;"TMGOutput("DILIST","ID",2,.09)=""
249 ;"TMGOutput("DILIST","ID",1,22700)=000455454
250 ;"-----------------------------------------------
251
252 if $data(TMGErrMsg("DIERR")) do ShowDIERR^TMGDEBUG(.TMGErrMsg,.PriorErrorFound)
253
254 if $data(TMGOutput)'=0 do
255 . new NumMatch,Num
256 . set NumMatch=+$PIECE(TMGOutput("DILIST",0),"^",1) ;"Get first part of entry like this: '8^*^0^' <-8 matches
257 . for Num=1:1:NumMatch do ;"Compare all entries found. If NumMatch=0-->no 1st loop
258 . . set RecComp=$$Compare(.Entry,.TMGOutput,Num)
259 . . if (RecComp=cInsufficient)&(NumMatch=1) do
260 . . . ;"Fileman has said there is 1 (and only 1) match.
261 . . . ;"Even if the supplied info is lacking, it is still a match.
262 . . . ;"We still needed to call $$Compare to check for cExtraInfo
263 . . . set RecComp=cFullMatch
264 . . if (RecComp=cFullMatch)!(RecComp=cExtraInfo) do
265 . . . set result=TMGOutput("DILIST",2,Num) ;"This is DFN (record) number
266 . . . if RecComp=cExtraInfo do
267 . . . . new temp set temp=$$AddToPat(result,.Entry)
268 . . . set Num=NumMatch+1 ;"some value to abort loop
269
270LUDone;
271 quit result ;" return patient internal entry number (DFN)
272
273
274FieldExists(FieldNum)
275 ;"Purpose: to ensure a given field exists in File 2
276 ;"Input: FieldNum: NUMBER of field in file 2
277 ;"Output: 1=field exists, 0=doesn't exist
278
279 quit ($data(^DD(2,FieldNum,0))'=0)
280
281
282ExtraLookup(Entry,Intensity)
283 ;"Purpose: Search for Patient (an existing entry in the database)
284 ;"Input: Entry -- Array is loaded with info, like this:
285 ;" Entry(.01)=Name
286 ;" Entry(.02)=Sex
287 ;" Entry(.03)=DOB
288 ;" Entry(.09)=SSNum
289 ;" Entry(22701)=SequelMedSystem Account Number
290 ;" Intensity -- How intense to search.
291 ;" NOTE: Because this returns the FIRST match, is it advised that this function
292 ;" be run with intensity 1 first, then 2-->3-->4
293 ;"Result: returns FIRST matching DFN (patient internal entry number), or 0 if none found
294 ;"NOTE: For now, I am ignoring any passed Alias info.
295
296 ;"Note: I am assuming that LookupPatient(Entry) has been called, and failed.
297 ;" Thus I am not going to compare SSNums, Medic or SequelMed's account numbers.
298 ;"------------------------------------------------------------------------------
299
300 if $data(cConflict)#10=0 new cConflict set cConflict=0
301 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
302 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2
303 if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3
304 set Intensity=$get(Intensity,1)
305 if Intensity=1 set Threshold=1 ;"(exact match)
306 if Intensity=2 set Threshold=.75 ;"(probable match)
307 if Intensity=3 set Threshold=.5 ;"(possible match)
308 if Intensity=4 set Threshold=.25 ;"(doubtful match)
309
310 new Missing set Missing=0
311 new BailOut set BailOut=0
312 new result set result=0 ;"set default to no match, or conflict found
313 new TMGErrMsg,TMGOutput
314 new RecComp
315
316 ;"If can find patient by SSNum, then don't look any further (if successful)
317 if +$get(Entry(.09))>0 set result=$$SSNumLookup(Entry(.09))
318 if result>0 goto LUDone
319
320 ;"If can find patient by SequelMedSystem account number, then don't look any further (if successful)
321 if (+$get(Entry(22701))>0),$$FieldExists(22701) set result=$$PMSNumLookup(Entry(22701)) if result>0 goto LUDone
322
323 ;"If can find patient by Paradigm account number, then don't look any further (if successful)
324 if (+$get(Entry(22702))>0),$$FieldExists(22702) set result=$$ParadigmNumLookup(Entry(22702))
325 if result>0 goto LUDone
326
327 new SearchName set SearchName=$get(Entry(.01))
328 if SearchName="" goto XLUDone
329 set SearchName=$$FormatName^TMGMISC(SearchName,1)
330 do STDNAME^XLFNAME(.SearchName,"C",.TMGErrMsg) ;"parse into component array
331 if Intensity>0 kill SearchName("SUFFIX")
332 if Intensity>1 kill SearchName("MIDDLE")
333 if Intensity>2 set SearchName("GIVEN")=$EXTRACT(SearchName("GIVEN"),1,3)
334 if Intensity>3 do
335 . set SearchName("GIVEN")=$EXTRACT(SearchName("GIVEN"),1,1)
336 . set SearchName("FAMILY")=$EXTRACT(SearchName("FAMILY"),1,3)
337
338 set SearchName=$$BLDNAME^XLFNAME(.SearchName)
339
340 ;"=========================================================
341 ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP)
342 do
343 . new Fields set Fields="@;.01;.02;.03"
344 . do FIND^DIC(2,"",Fields,"M",SearchName,"*","","","","TMGOutput","TMGErrMsg")
345 ;"=========================================================
346
347 if $data(TMGErrMsg("DIERR")) goto XLUDone
348
349 if $data(TMGOutput)'=0 do
350 . new NumMatch,Num
351 . set NumMatch=+$get(TMGOutput("DILIST",0),0) ;"Get first part of entry like this: '8^*^0^' <-8 matches
352 . for Num=1:1:NumMatch do ;"Compare all entries found. If NumMatch=0-->no 1st loop
353 . . new dbDataEntry
354 . . merge dbDataEntry=TMGOutput("DILIST","ID",Num)
355 . . set RecComp=$$XCompEntry(.Entry,.dbDataEntry,.Threshold)
356 . . if (RecComp=cInsufficient)&(NumMatch=1) do
357 . . . ;"Fileman has said there is 1 (and only 1) match.
358 . . . ;"Even if the supplied info is lacking, it is still a match.
359 . . . set RecComp=cFullMatch
360 . . if (RecComp=cFullMatch)!(RecComp=cExtraInfo) do
361 . . . set result=$get(TMGOutput("DILIST",2,Num),0) ;"This is DFN (record) number
362 . . . set Num=NumMatch+1 ;"some value to abort loop
363
364XLUDone;
365 quit result ;" return patient internal entry number (DFN)
366
367
368XCompEntry(TestData,dbDataEntry,Threshold) ;
369 ;"PURPOSE: To compare two entries for certain fields, and return a comparison code.
370 ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data
371 ;" See CompEntry for Format
372 ;" dbDataEntry -- array derived from output from FIND^DIC. See CompEntry for Format
373 ;" Threshold -- OPTIONAL --How strict to be during the comparison
374 ;" default is 1.
375 ;" e.g. 0.5 --> comparison value must >= 0.5
376 ;" Valid values are: .25, .5, .75, 1
377 ;"Results:
378 ;" return value = cConflict (0) if entries conflict
379 ;" return value = cFullMatch (1) if entries match (to the degreee specified by Threshold)
380 ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info.
381 ;" return value = cInsufficient (3) Insufficient data to make match, but no conflict.
382 ;"Note: This function IS DIFFERENT then CompEntry (which this was originally copied from)
383 ;" --It's purpose is to look for matches after a partial fileman search,
384 ;" Smi,Jo for Smith,John
385
386 if $data(cConflict)#10=0 new cConflict set cConflict=0
387 if $data(cConsistent)#10=0 new cConsistent set cConsistent=0.5
388 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
389 set Threshold=$get(Threshold,1)
390 if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3
391
392 new tD,dbD
393 new CResult set CResult=cFullMatch ;"set default to match
394 new result set result=cFullMatch ;"default is Success.
395 new WorstScore set WorstScore=1
396 new Extra set Extra=0 ;"0=false
397
398 if $data(TestData(.01))#10'=0 do
399 . set tD=$get(TestData(.01)) ;"field .01 = NAME
400 . set dbD=$get(dbDataEntry(.01))
401 . set result=$$CompName^TMGMISC(tD,dbD)
402 if result=cConflict goto CmpEDone
403 if result<WorstScore set WorstScore=result
404
405 if $data(TestData(.02))#10'=0 do
406 . set tD=$get(TestData(.02)) ;"field .02 = SEX
407 . set dbD=$get(dbDataEntry(.02))
408 . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"SEX")
409 if result=cConflict goto XCmpEDone
410 if result=cExtraInfo set Extra=1
411
412 if $data(TestData(.03))#10'=0 do
413 . set tD=$get(TestData(.03)) ;"field .03 = DOB
414 . set dbD=$get(dbDataEntry(.03))
415 . set result=$$CompDOB^TMGMISC(tD,dbD)
416 if result=cConflict goto XCmpEDone
417 if result<WorstScore set WorstScore=result
418
419 ;"If we are here, then there is no conflict.
420 if result>WorstScore set result=WorstScore
421 set result=(result'<Threshold)
422 if result=cConflict goto XCmpEDone
423
424 ;"If extra info present, reflect this in result
425 if Extra=1 set result=cExtraInfo
426
427 ;"OK, no conflict. But is there sufficient data for a match?
428 ;"ensure we check at least Name & DOB-->success
429 if ($data(TestData(.01))#10=0)&($data(TestData(.03))=0) set result=cInsufficient
430
431XCmpEDone
432
433 quit result
434
435
436
437SSNumLookup(SSNum)
438 ;"PURPOSE: To lookup patient by social security number
439 ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found
440 ;"
441 new result set result=0
442
443 new DIC
444 set DIC=2
445 set DIC(0)="M"
446 set X=SSNum
447 do ^DIC
448 if +Y>0 set result=+Y
449 quit result
450
451
452SSNum2Lookup(SSNum)
453 ;"NOTICE: I have learned to be more effecient, so will not use this function anymore
454 ;" Will use SSNumLookup instead
455
456 ;"PURPOSE: To lookup patient by social security number
457 ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found
458 ;"
459
460 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SSNLookup^TMGGDFN")
461
462 new result set result=0 ;"set default to no match, or conflict found
463 new TMGErrMsg,TMGOutput
464
465 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Entry' passed for processing:")
466 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry")
467
468 ;"Below specifies fields to get back. Note: file 2 is PATIENT file.
469 new Value set Value=$get(SSNum)
470
471 ;"=========================================================
472 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FIND^DIC")
473 ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP)
474 do
475 . new File set File=2
476 . new IENS set IENS=""
477 . new Fields set Fields="@;.01;.02;.03;.09"
478 . if $$FieldExists(22700) set Fields=Fields_";22700"
479 . new Flags set Flags="M"
480 . new MatchValue set MatchValue=Value
481 . new Number set Number="*" ;"i.e. max number to return *=all entries.
482 . new Indexes set Indexes=""
483 . new ScreenCode set ScreenCode="" ;"option screening M code
484 . new Ident set Ident="" ;"optional text to accompany each found entry
485 . new OutVarP set OutVarP="TMGOutput"
486 . new ErrVarP set ErrVarP="TMGErrMsg"
487 . do FIND^DIC(File,IENS,Fields,Flags,MatchValue,Number,Indexes,ScreenCode,Ident,OutVarP,ErrVarP)
488 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FIND^DIC")
489 ;"=========================================================
490
491 ;"if ($get(TMGDEBUG)>0) do
492 ;". if $data(TMGOutput)>0 do ArrayDump^TMGDEBUG("TMGOutput")
493 ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGOutput found.")
494 ;". if $data(TMGErrMsg)>0 do ArrayDump^TMGDEBUG("TMGErrMsg")
495 ;". else do DebugMsg^TMGDEBUG(.DBIndent,"No TMGErrMsg found")
496
497 if $data(TMGErrMsg("DIERR")) do ShowDIERR^TMGDEBUG(.TMGErrMsg,.PriorErrorFound)
498
499 if $data(TMGOutput)'=0 do
500 . new NumMatch,Num
501 . set NumMatch=+$PIECE(TMGOutput("DILIST",0),"^",1) ;"Get first part of entry like this: '8^*^0^' <-8 matches
502 . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,NumMatch," matches found in database")
503 . if NumMatch>0 set result=$get(TMGOutput("DILIST",2,1))
504
505SSLUDone
506 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result (patient DFN#)=",result)
507 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SSNLookup^TMGGDFN")
508
509 quit result ;" return patient internal entry number (DFN)
510
511
512PMSNumLookup(PMSNum)
513 ;"PURPOSE: To lookup patient by SequelSystem account number
514 ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found
515 ;"
516
517 new result set result=0 ;"set default to no match, or conflict found
518 new TMGErrMsg,TMGOutput
519
520 ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP)
521 ;"Uses custom TMGS index.
522 do FIND^DIC(2,"",".01","",PMSNum,"*","TMGS","","","TMGOutput","TMGErrMsg")
523
524 if '$data(TMGErrMsg("DIERR")) set result=$get(TMGOutput("DILIST",2,1),0)
525 quit result ;" return patient internal entry number (DFN)
526
527
528ParadigmNumLookup(PMSNum)
529 ;"PURPOSE: To lookup patient by Paradigm account number
530 ;"Result: RETURNS DFN (patient internal entry number), or 0 if not found
531
532 new result set result=0 ;"set default to no match, or conflict found
533 new TMGErrMsg,TMGOutput
534
535 ;"FIND^DIC(File,IENStr,Fields,Flags,Value,Number,Indexes,Screen,Ident,OutVarP,ErrVarP)
536 ;"Uses custom TMGS index.
537 do FIND^DIC(2,"",".01","",PMSNum,"*","TMGP","","","TMGOutput","TMGErrMsg")
538
539 if '$data(TMGErrMsg("DIERR")) set result=$get(TMGOutput("DILIST",2,1),0)
540 quit result ;" return patient internal entry number (DFN)
541
542
543Compare(TestData,dbData,EntryNum) ;
544 ;"PURPOSE: To compare two entries for certain fields, and return a comparison code.
545 ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data
546 ;" Format is:
547 ;" TestData(FieldNumber)=Value
548 ;" TestData(FieldNumber)=Value
549 ;" TestData(FieldNumber)=Value
550 ;" dbData -- array returned from FIND^DIC.
551 ;" EntryNum -- Entry number in dbData
552 ;"Results:
553 ;" return value = cConflict (0) if entries conflict
554 ;" return value = cFullMatch (1) if entries completely match
555 ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info.
556 ;" return value = cInsufficient (3) Insufficient data to make match, but no conflict.
557 ;"Note: The following data sets will be sufficient for a match:
558 ;" 1. SSNumber (not a P/pseudo value)
559 ;" 2. Patient Identifier (field 22700)
560 ;" 3. Name, DOB
561
562 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"Compare^TMGGDFN")
563
564 if $data(cConflict)#10=0 new cConflict set cConflict=0
565 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
566 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2
567 if $data(cInsufficient)#10=0 new cInsufficient set cInsufficient=3
568
569 new dbDataEntry,result
570
571 ;"First, ensure no conflict between TestData and dbData
572 merge dbDataEntry=dbData("DILIST","ID",EntryNum)
573 set result=$$CompEntry(.TestData,.dbDataEntry)
574 if result=cConflict goto CompDone
575
576 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No conflict found so far")
577
578 if $get(TestData(.01))="" kill TestData(.01)
579 if $get(TestData(.03))="" kill TestData(.03)
580 if $get(TestData(.09))="" kill TestData(.09)
581 if $get(TestData(22700))="" kill TestData(22700)
582 if $get(TestData(22701))="" kill TestData(22701)
583
584 ;"OK, no conflict. But is there sufficient data for a match?
585 if (+$get(TestData(.09))>0)&($get(TestData(.09))'["P") goto CompDone ;".09=SSNum --> success
586 if ($data(TestData(22700))#10'=0) goto CompDone ;"22700=Pt. Identifier --> success
587 if ($data(TestData(.01))#10'=0)&($data(TestData(.03))) goto CompDone ;"Name & DOB-->success
588
589 ;"If here, then we don't have enough data for a match
590 set result=cInsufficient
591
592CompDone
593 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result)
594 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"Compare^TMGGDFN")
595 quit result
596
597
598CompEntry(TestData,dbDataEntry) ;
599 ;"PURPOSE: To compare two entries for certain fields, and return a comparison code.
600 ;"INPUT: TestData -- array holding uploaded data, that is being tested against preexisting data
601 ;" Format is:
602 ;" TestData(FieldNumber)=Value
603 ;" TestData(FieldNumber)=Value
604 ;" TestData(FieldNumber)=Value
605 ;" dbDataEntry -- array derived from output from FIND^DIC.
606 ;" Format is:
607 ;" dbDataEntry(FieldNumber)=Value
608 ;" dbDataEntry(FieldNumber)=Value
609 ;" dbDataEntry(FieldNumber)=Value
610 ;" EntryNum -- Entry number in dbDataEntry
611 ;"Results:
612 ;" return value = cConflict (0) if entries conflict
613 ;" return value = cFullMatch (1) if entries completely match
614 ;" return value = cExtraInfo (2) if entries have no conflict, but tEntry has extra info.
615
616 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompEntry^TMGGDFN")
617
618 if $data(cConflict)#10=0 new cConflict set cConflict=0
619 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1
620 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2
621
622 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'TestData' passed for processing:")
623 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TestData")
624 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'dbDataEntry' passed for processing:")
625 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("dbDataEntry")
626
627 new tD,dbD
628 new CResult set CResult=cFullMatch ;"set default to match (so data won't be entered into database)
629 new result set result=cFullMatch ;"default is Success.
630 new Extra set Extra=0 ;"0=false
631
632 ;"I am not going to test field .01 (NAME) because Fileman has already done this, and
633 ;" feels that the names it has returned are compatible.
634 ;" I was having a problem with input like this:
635 ;" TestData(.01)="DOE,JOHN"
636 ;" dbDataEntry(.01)="DOE,JOHN J"
637 ;" And this was failing the match. It shouldn't have.
638 ;"if $data(TestData(.01))#10'=0 do
639 ;". set tD=$get(TestData(.01)) ;"field .01 = NAME
640 ;". set dbD=$get(dbDataEntry(.01))
641 ;". set result=$$FieldCompare^TMGDBAPI(tD,dbD)
642 ;"if result=cConflict goto CmpEDone
643 ;"if result=cExtraInfo set Extra=1
644
645 if $data(TestData(.09))#10'=0 do
646 . set tD=$get(TestData(.09)) ;"field .09 = SSNUM
647 . set dbD=$get(dbDataEntry(.09))
648 . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"SSNUM")
649 if result=cConflict goto CmpEDone
650 if result=cExtraInfo set Extra=1
651
652 if $data(TestData(.02))#10'=0 do
653 . set tD=$get(TestData(.02)) ;"field .02 = SEX
654 . set dbD=$get(dbDataEntry(.02))
655 . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"SEX")
656 if result=cConflict goto CmpEDone
657 if result=cExtraInfo set Extra=1
658
659 if $data(TestData(.03))#10'=0 do
660 . set tD=$get(TestData(.03)) ;"field .03 = DOB
661 . set dbD=$get(dbDataEntry(.03))
662 . set result=$$FieldCompare^TMGDBAPI(tD,dbD,"DATE")
663 if result=cConflict goto CmpEDone
664 if result=cExtraInfo set Extra=1
665
666 ;"if $data(TestData(22700))#10'=0 do
667 ;". set tD=$get(TestData(22700)) ;"field 22700 = Patient ID number
668 ;". set dbD=$get(dbDataEntry(22700))
669 ;". set result=$$FieldCompare^TMGDBAPI(tD,dbD,"NUMBER")
670 ;"if result=cConflict goto CmpEDone
671 ;"if result=cExtraInfo set Extra=1
672
673 ;"If we are here, then there is no conflict.
674 set result=cFullMatch
675 ;"If extra info present, reflect this in result
676 if Extra=1 set result=cExtraInfo
677
678CmpEDone
679 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result)
680 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompEntry^TMGGDFN")
681
682 quit result
683
684AddToPat(PatIEN,Entry)
685 ;"PURPOSE: Stuffs Entry into record number PatIEN (RecNum must already exist)
686 ;"INPUT: PatIEN -- the record number, in file 2, that is to be updated
687 ;" Entry -- the record to put in
688 ;" Format is:
689 ;" Entry(FieldNumber)=Value
690 ;" Entry(FieldNumber)=Value
691 ;" Entry(FieldNumber)=Value
692 ;" The following FieldNumbers will be used if avail.
693 ;" .01,.02,.03,.09,22700
694 ;"Results: cOKToCont (1) or cAbort(0)
695
696 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
697 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1
698 if $data(cAbort)#10=0 new cAbort set cAbort=0
699
700 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddToPat^TMGGDFN")
701
702 new TMGFDA,TMGMsg
703 new result set result=cOKToCont
704
705 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Entry passed for processing")
706 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry")
707
708 if $get(Entry(.01))'="" set TMGFDA(2,PatIEN_",",.01)=Entry(.01) ;"field .01 = NAME
709 if $get(Entry(.02))'="" set TMGFDA(2,PatIEN_",",.02)=Entry(.02) ;"field .02 = SEX
710 if $get(Entry(.03))'="" set TMGFDA(2,PatIEN_",",.03)=Entry(.03) ;"field .03 = DOB
711 if $get(Entry(.09))'=""&($get(Entry(.09))'["P") do
712 . set TMGFDA(2,PatIEN_",",.09)=Entry(.09) ;"field .09 = SSNUM
713 if $get(Entry(22700))'="" set TMGFDA(2,PatIEN_",",22700)=Entry(22700) ;"field 22700 = Patient Medic ID Num (custom field)
714
715 set result=$$dbWrite^TMGDBAPI(.TMGFDA,1)
716 if result=cAbort goto ATRDone
717
718ATRDone
719 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddToPat")
720 quit result
721
722
723
724AddNewPt(Entry,ErrArray)
725 ;"Purpose: Create a new entry in file 2 (Patient File)
726 ;"Input: 'Entry' array should be set up prior to calling. See those items expected below
727 ;" Entry(.01)=Patient Name
728 ;" Entry(.03)=DOB
729 ;" Entry(.09)=SS Num
730 ;" Entry(22700)=Medic Pt Identifier -- optional
731 ;" Entry(1901)=field 1901 = VETERAN Y/N --For my purposes, use NO -- optional
732 ;" Entry(.301)=field .301 = "SERVICE CONNECTED?" -- required field -- optional
733 ;" Entry(391)=field 391 = "TYPE" - required field -- optional
734
735 ;" ErrArray (OPTIONAL) -- PASS BY REFERENCE. An OUT parameter to receive
736 ;" Fileman "DIERR" message, if any
737 ;" Note: To use this, and have the function not display the Fileman
738 ;" Error to the screen, ** must SET ErrArray=-1 (-1 = extra quiet mode)
739 ;" If TMGDEBUG is defined, then this quit mode described above will NOT be used,
740 ;" and existing values for TMGDEBUG will be used.
741 ;"Output: Returns internal entry number (DFN) if successful, otherwise 0
742 ;"Note: The following data sets must be available for a patient to be entered:
743 ;" Patient name (.01) -- always required
744 ;" Patient sex (.02) -- always required
745 ;" And ONE of the following...
746 ;" 1. SSNumber (.09) (not a P/pseudo value)
747 ;" 2. Patient Identifier (field 22700)
748 ;" 3. DOB (.03)
749 ;"Results: returns the DFN of the added record, or 0 if not added/error
750
751
752 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddNewPt^TMGGDFN")
753
754 if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0
755 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1
756 if $data(cAbort)#10=0 new cAbort set cAbort=0
757
758 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the 'Entry' passed for processing:")
759 ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Entry")
760
761 new TMGFDA,TMGIEN,TMGMSG
762 new result set result=cOKToCont ;"default it success.
763
764 if ($Data(Entry(.09))#10'=0) do ;"Kill SSNum if it isn't in right format
765 . set Entry(.09)=$translate(Entry(.09),"- ","")
766 . if Entry(.09)'?9N0.1"P" kill Entry(.09)
767
768 if ($Data(Entry(.01))#10=0) goto ANPDone ;"Abort
769 if ($Data(Entry(.03))#10'=0) goto ANPOK ;"OK to make record
770 if ($Data(Entry(.09))#10'=0) goto ANPOK ;"OK to make record
771 if ($Data(Entry(22700))#10'=0) goto ANPOK ;"OK to make record
772
773 ;"If we get to this point, then insufficient data to add record... so abort
774 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Not enough info to create unique patient record.")
775 set result=cAbort
776 goto ANPDone ;"Abort
777
778ANPOK
779 ;"Note: the "2" means file 2 (PATIENT file), and "+1" means "add entry"
780 set TMGFDA(2,"+1,",.096)="`"_DUZ ;"field .096 = WHO ENTERED PATIENT (`DUZ=current user)
781 set TMGFDA(2,"+1,",.01)=Entry(.01) ;"field .01 = NAME
782 if $data(Entry(.02)) set TMGFDA(2,"+1,",.02)=Entry(.02) ;"field .02 = SEX
783 if $data(Entry(.03)) set TMGFDA(2,"+1,",.03)=Entry(.03) ;"field .03 = DOB
784 if +$get(Entry(.09))>0 set TMGFDA(2,"+1,",.09)=Entry(.09) ;"field .09 = SSNUM
785 if $data(Entry(22700)),$$FieldExists(22700) set TMGFDA(2,"+1,",22700)=Entry(22700) ;"field 22700 = Patient ID Num (custom field)
786 ;"These fields below *USED TO BE* required. I changed the filemans status for these fields to NOT required
787 if $data(Entry(1901)) set TMGFDA(2,"+1,",1901)=Entry(1901)
788 else set TMGFDA(2,"+1,",1901)="NO" ;"field 1901 = VETERAN Y/N --For my purposes, use NO
789 if $data(Entry(.301)) set TMGFDA(2,"+1,",.301)=Entry(.301)
790 else set TMGFDA(2,"+1,",.301)="NO" ;"field .301 = SERVICE CONNECTED? -- required field
791 if $data(Entry(391)) set TMGFDA(2,"+1,",391)=Entry(391)
792 else set TMGFDA(2,"+1,",391)="NON-VETERAN (OTHER)" ;"field 391 = "TYPE" - required field
793
794 if $data(TMGDEBUG)=0 new TMGDEBUG
795 set TMGDEBUG=$get(ErrArray,0)
796
797 ;"set result=$$dbWrite^TMGDBAPI(.TMGFDA,0,.TMGIEN,,.ErrArray)
798 do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG")
799 if $data(TMGMSG("DIERR")) do
800 . ;"TMGDEBUG=-1 --> extra quiet mode
801 . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
802 . merge ErrArray("DIERR")=TMGMSG("DIERR")
803 . set result=cAbort
804
805 if result=cAbort goto ANPDone
806
807 set result=+$get(TMGIEN(1)) ;"result is the added patient's IEN
808 if result'>0 goto ANPDone
809
810 ;"Add subfile entry for Alias if an alias was specified.
811 if $data(Entry(10,.01)) do ;"field 10 in file 2 = ALIAS, .01 subfield=ALIAS
812 . kill TMGFDA,TMGMsg,TMGIEN,tempresult
813 . set TMGFDA(2.01,"+1,"_result_",",.01)=Entry(10,.01)
814 . ;"set tempresult=$$dbWrite^TMGDBAPI(.TMGFDA,0,.TMGIEN,,.ErrArray)
815 . do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG")
816 . if $data(TMGMSG("DIERR")) do
817 . . ;"TMGDEBUG=-1 --> extra quiet mode
818 . . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
819 . . merge ErrArray("DIERR")=TMGMSG("DIERR")
820
821 ;"Now, manually add a record in the file 9000001 (^AUPNPAT) with IEN (stored in result)
822 ;"This is done because some PATIENT fields don't point to the PATIENT file, but instead
823 ;" point to the PATIENT/IHS file (9000001), which in turn points to the PATIENT file.
824 set ^AUPNPAT(result,0)=result
825 set ^AUPNPAT("B",result,result)=""
826 if $data(Entry(.09)) do
827 . set ^AUPNPAT(result,41,0)="^9000001.41P^1^1"
828 . set ^AUPNPAT(result,41,1,0)="1^"_Entry(.09)
829
830ANPDone
831 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result / IEN of added record=",result)
832 ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddNewPt^TMGGDFN")
833 quit result
834
835
836
837
838
Note: See TracBrowser for help on using the repository browser.