source: cprs/branches/GUI-config/KIDS Server patch/TMG_GUI_CONFIG-1-1.kid@ 476

Last change on this file since 476 was 476, checked in by Kevin Toppenberg, 16 years ago

New WorldVistA Config Utility
File size: 82.3 KB
Line 
1KIDS Distribution saved on Aug 20, 2008@19:39:18
2This patch supports the WorldVistA Config Utility GUI
3**KIDS**:TMG-GUI-CONFIG*1.0*1^
4
5**INSTALL NAME**
6TMG-GUI-CONFIG*1.0*1
7"BLD",5421,0)
8TMG-GUI-CONFIG*1.0*1^^0^3080820^n
9"BLD",5421,1,0)
10^^12^12^3080820^^
11"BLD",5421,1,1,0)
12This will contain one source file (TMGRPC3.m) and RPC's
13"BLD",5421,1,2,0)
14to support the WorldVistA Config Utility (a Windows
15"BLD",5421,1,3,0)
16GUI client for performing Fileman tasks.
17"BLD",5421,1,4,0)
18
19"BLD",5421,1,5,0)
20Note, user will need to have the menu option:
21"BLD",5421,1,6,0)
22 TMG RPC CONTEXT GUI_CONFIG
23"BLD",5421,1,7,0)
24added to their secondary menu to be authorized for use.
25"BLD",5421,1,8,0)
26
27"BLD",5421,1,9,0)
28Note: This utility will allow an authorized user to perform
29"BLD",5421,1,10,0)
30arbitrary Fileman writes, and could potentially cause
31"BLD",5421,1,11,0)
32significant problems. So careful consideration should be
33"BLD",5421,1,12,0)
34given to determining who can use this GUI utility.
35"BLD",5421,4,0)
36^9.64PA^^0
37"BLD",5421,"KRN",0)
38^9.67PA^8989.52^19
39"BLD",5421,"KRN",.4,0)
40.4
41"BLD",5421,"KRN",.401,0)
42.401
43"BLD",5421,"KRN",.402,0)
44.402
45"BLD",5421,"KRN",.403,0)
46.403
47"BLD",5421,"KRN",.5,0)
48.5
49"BLD",5421,"KRN",.84,0)
50.84
51"BLD",5421,"KRN",3.6,0)
523.6
53"BLD",5421,"KRN",3.8,0)
543.8
55"BLD",5421,"KRN",9.2,0)
569.2
57"BLD",5421,"KRN",9.8,0)
589.8
59"BLD",5421,"KRN",9.8,"NM",0)
60^9.68A^1^1
61"BLD",5421,"KRN",9.8,"NM",1,0)
62TMGRPC3^^0^B43913
63"BLD",5421,"KRN",9.8,"NM","B","TMGRPC3",1)
64
65"BLD",5421,"KRN",19,0)
6619
67"BLD",5421,"KRN",19,"NM",0)
68^9.68A^1^1
69"BLD",5421,"KRN",19,"NM",1,0)
70TMG RPC CONTEXT GUI_CONFIG^^0
71"BLD",5421,"KRN",19,"NM","B","TMG RPC CONTEXT GUI_CONFIG",1)
72
73"BLD",5421,"KRN",19.1,0)
7419.1
75"BLD",5421,"KRN",101,0)
76101
77"BLD",5421,"KRN",409.61,0)
78409.61
79"BLD",5421,"KRN",771,0)
80771
81"BLD",5421,"KRN",870,0)
82870
83"BLD",5421,"KRN",8989.51,0)
848989.51
85"BLD",5421,"KRN",8989.52,0)
868989.52
87"BLD",5421,"KRN",8994,0)
888994
89"BLD",5421,"KRN",8994,"NM",0)
90^9.68A^1^1
91"BLD",5421,"KRN",8994,"NM",1,0)
92TMG CHANNEL^^0
93"BLD",5421,"KRN",8994,"NM","B","TMG CHANNEL",1)
94
95"BLD",5421,"KRN","B",.4,.4)
96
97"BLD",5421,"KRN","B",.401,.401)
98
99"BLD",5421,"KRN","B",.402,.402)
100
101"BLD",5421,"KRN","B",.403,.403)
102
103"BLD",5421,"KRN","B",.5,.5)
104
105"BLD",5421,"KRN","B",.84,.84)
106
107"BLD",5421,"KRN","B",3.6,3.6)
108
109"BLD",5421,"KRN","B",3.8,3.8)
110
111"BLD",5421,"KRN","B",9.2,9.2)
112
113"BLD",5421,"KRN","B",9.8,9.8)
114
115"BLD",5421,"KRN","B",19,19)
116
117"BLD",5421,"KRN","B",19.1,19.1)
118
119"BLD",5421,"KRN","B",101,101)
120
121"BLD",5421,"KRN","B",409.61,409.61)
122
123"BLD",5421,"KRN","B",771,771)
124
125"BLD",5421,"KRN","B",870,870)
126
127"BLD",5421,"KRN","B",8989.51,8989.51)
128
129"BLD",5421,"KRN","B",8989.52,8989.52)
130
131"BLD",5421,"KRN","B",8994,8994)
132
133"BLD",5421,"QUES",0)
134^9.62^^
135"KRN",19,10090,-1)
1360^1
137"KRN",19,10090,0)
138TMG RPC CONTEXT GUI_CONFIG^GUIConfig 1.0.0.0^^B^^^^^^^^FP OF GREENEVILLE (TMG)
139"KRN",19,10090,1,0)
140^^2^2^3080720^^
141"KRN",19,10090,1,1,0)
142This will be the context file for GUI_Config
143"KRN",19,10090,1,2,0)
144It will hold the list of all allowed RPC calls.
145"KRN",19,10090,"RPC",0)
146^19.05P^1^1
147"KRN",19,10090,"RPC",1,0)
148TMG CHANNEL
149"KRN",19,10090,"U")
150GUICONFIG 1.0.0.0
151"KRN",8994,1785,-1)
1520^1
153"KRN",8994,1785,0)
154TMG CHANNEL^CHANNEL^TMGRPC3^2^^^^1^1
155"KRN",8994,1785,1,0)
156^8994.01^2^2^3080805^^^
157"KRN",8994,1785,1,1,0)
158This RPC will be used to pass multiple requests back
159"KRN",8994,1785,1,2,0)
160and forth from client to server
161"KRN",8994,1785,2,0)
162^8994.02A^1^1
163"KRN",8994,1785,2,1,0)
164INPUT^3^^1^1
165"KRN",8994,1785,2,1,1,0)
166^8994.021^2^2^3080805^^^
167"KRN",8994,1785,2,1,1,1,0)
168This is the data array sent from client.
169"KRN",8994,1785,2,1,1,2,0)
170Format still to be decided.
171"KRN",8994,1785,2,"B","INPUT",1)
172
173"KRN",8994,1785,2,"PARAMSEQ",1,1)
174
175"KRN",8994,1785,3,0)
176^8994.03^3^3^3080805^^^
177"KRN",8994,1785,3,1,0)
178This is the result array passed from server back to client.
179"KRN",8994,1785,3,2,0)
180Format still to be decided.
181"KRN",8994,1785,3,3,0)
182See documentation in CHANNEL^TMGRPC3
183"MBREQ")
1840
185"ORD",16,8994)
1868994;16;1;;;;;;;RPCDEL^XPDIA1
187"ORD",16,8994,0)
188REMOTE PROCEDURE
189"ORD",18,19)
19019;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
191"ORD",18,19,0)
192OPTION
193"QUES","XPF1",0)
194Y
195"QUES","XPF1","??")
196^D REP^XPDH
197"QUES","XPF1","A")
198Shall I write over your |FLAG| File
199"QUES","XPF1","B")
200YES
201"QUES","XPF1","M")
202D XPF1^XPDIQ
203"QUES","XPF2",0)
204Y
205"QUES","XPF2","??")
206^D DTA^XPDH
207"QUES","XPF2","A")
208Want my data |FLAG| yours
209"QUES","XPF2","B")
210YES
211"QUES","XPF2","M")
212D XPF2^XPDIQ
213"QUES","XPI1",0)
214YO
215"QUES","XPI1","??")
216^D INHIBIT^XPDH
217"QUES","XPI1","A")
218Want KIDS to INHIBIT LOGONs during the install
219"QUES","XPI1","B")
220YES
221"QUES","XPI1","M")
222D XPI1^XPDIQ
223"QUES","XPM1",0)
224PO^VA(200,:EM
225"QUES","XPM1","??")
226^D MG^XPDH
227"QUES","XPM1","A")
228Enter the Coordinator for Mail Group '|FLAG|'
229"QUES","XPM1","B")
230
231"QUES","XPM1","M")
232D XPM1^XPDIQ
233"QUES","XPO1",0)
234Y
235"QUES","XPO1","??")
236^D MENU^XPDH
237"QUES","XPO1","A")
238Want KIDS to Rebuild Menu Trees Upon Completion of Install
239"QUES","XPO1","B")
240YES
241"QUES","XPO1","M")
242D XPO1^XPDIQ
243"QUES","XPZ1",0)
244Y
245"QUES","XPZ1","??")
246^D OPT^XPDH
247"QUES","XPZ1","A")
248Want to DISABLE Scheduled Options, Menu Options, and Protocols
249"QUES","XPZ1","B")
250YES
251"QUES","XPZ1","M")
252D XPZ1^XPDIQ
253"QUES","XPZ2",0)
254Y
255"QUES","XPZ2","??")
256^D RTN^XPDH
257"QUES","XPZ2","A")
258Want to MOVE routines to other CPUs
259"QUES","XPZ2","B")
260NO
261"QUES","XPZ2","M")
262D XPZ2^XPDIQ
263"RTN")
2641
265"RTN","TMGRPC3")
2660^1^B43913
267"RTN","TMGRPC3",1,0)
268TMGRPC3 ;TMG/kst/RPC Functions for GUI_Config ;07/20/08
269"RTN","TMGRPC3",2,0)
270 ;;1.0;TMG-LIB;**1**;07/20/08
271"RTN","TMGRPC3",3,0)
272
273"RTN","TMGRPC3",4,0)
274 ;"TMG RPC FUNCTIONS for a GUI config program
275"RTN","TMGRPC3",5,0)
276
277"RTN","TMGRPC3",6,0)
278 ;"Kevin Toppenberg MD
279"RTN","TMGRPC3",7,0)
280 ;"GNU Lesser General Public License (LGPL) applies
281"RTN","TMGRPC3",8,0)
282 ;"7/20/08
283"RTN","TMGRPC3",9,0)
284
285"RTN","TMGRPC3",10,0)
286 ;"=======================================================================
287"RTN","TMGRPC3",11,0)
288 ;" RPC -- Public Functions.
289"RTN","TMGRPC3",12,0)
290 ;"=======================================================================
291"RTN","TMGRPC3",13,0)
292 ;"CHANNEL(RESULT,INPUT) -- general purpose channel RPC from a GUI config program
293"RTN","TMGRPC3",14,0)
294
295"RTN","TMGRPC3",15,0)
296 ;"=======================================================================
297"RTN","TMGRPC3",16,0)
298 ;"PRIVATE API FUNCTIONS
299"RTN","TMGRPC3",17,0)
300 ;"=======================================================================
301"RTN","TMGRPC3",18,0)
302 ;"GetUserList(OutArray,param) -- fill list with users on the system.
303"RTN","TMGRPC3",19,0)
304 ;"GetRecordsList(OutArray,param) -- fill list with records in file on the system
305"RTN","TMGRPC3",20,0)
306 ;"GetOneUser(OutArray,IEN) -- Get one user's record
307"RTN","TMGRPC3",21,0)
308 ;"GetOneRecord(OutArray,params) -- get one record in file
309"RTN","TMGRPC3",22,0)
310 ;"ExtractFields(OutArray,TMGARRAY,Flag) -- convert output from GETS^DIQ into another format
311"RTN","TMGRPC3",23,0)
312 ;"GetFileSubset(OutArray,params) -- return a subset of entries a file's .01 names
313"RTN","TMGRPC3",24,0)
314 ;"GetSubRecsList(OutArray,params) -- Get all .01 sub record entries for a subfile
315"RTN","TMGRPC3",25,0)
316 ;"PostData(OutArray,Data) -- Post Changes to database via Fileman
317"RTN","TMGRPC3",26,0)
318 ;"QtTermUser(XUDA) -- quietly inactive a given user
319"RTN","TMGRPC3",27,0)
320 ;"QtReactUser(TMGDA) -- launch quiet reactivation code
321"RTN","TMGRPC3",28,0)
322 ;"GetEmptyEntry(OutArray,params) -- get stub entries for a file (typically a subfile)
323"RTN","TMGRPC3",29,0)
324 ;"CloneUser(OutArray,params) -- replicate a record into a new record, including all subrecs.
325"RTN","TMGRPC3",30,0)
326 ;"CloneRecord(OutArray,params) --- replicate a record into a new record, including all subrecs.
327"RTN","TMGRPC3",31,0)
328 ;"GetHelpMsg(OutArray,param) -- retrieve the help message for a given field.
329"RTN","TMGRPC3",32,0)
330 ;"StubNewRecord(File,NewValue,OutArray) -- create a stub entry in the file (200), to be filled in elsewhere
331"RTN","TMGRPC3",33,0)
332 ;"GetIfWPField(OutArray,params) -- return if filenumber is a WP subfile
333"RTN","TMGRPC3",34,0)
334 ;"GetWPField(OutArray,params) -- retrieve on word processing (WP) field entry
335"RTN","TMGRPC3",35,0)
336 ;"PostWPField(OutArray,params,INPUT) -- store a word processing (WP) field entry
337"RTN","TMGRPC3",36,0)
338 ;"RegPatient(OutArray,params) -- register a new patient into VistA, providing not already been registered.
339"RTN","TMGRPC3",37,0)
340 ;"SrchPtExact(Array) -- search for a preexisting patient, using an exact search
341"RTN","TMGRPC3",38,0)
342 ;"GetErrStr(ErrArray) -- convert a standard DIERR array into a string for output
343"RTN","TMGRPC3",39,0)
344
345"RTN","TMGRPC3",40,0)
346 ;"=======================================================================
347"RTN","TMGRPC3",41,0)
348 ;"=======================================================================
349"RTN","TMGRPC3",42,0)
350 ;"Dependencies:
351"RTN","TMGRPC3",43,0)
352 ;" No TMG* dependencies
353"RTN","TMGRPC3",44,0)
354
355"RTN","TMGRPC3",45,0)
356 ;"=======================================================================
357"RTN","TMGRPC3",46,0)
358 ;"=======================================================================
359"RTN","TMGRPC3",47,0)
360
361"RTN","TMGRPC3",48,0)
362CHANNEL(RESULT,INPUT)
363"RTN","TMGRPC3",49,0)
364 ;"Purpose: This will be a general purpose channel RPC from a GUI config program
365"RTN","TMGRPC3",50,0)
366 ;"Input: RESULT -- this is an OUT parameter, and it is always passed by reference
367"RTN","TMGRPC3",51,0)
368 ;" INPUT -- this will be array of data sent from the GUI client. Defined below:
369"RTN","TMGRPC3",52,0)
370 ;" <Stuff will go here>
371"RTN","TMGRPC3",53,0)
372 ;" INPUT("REQUEST")="cmd^params" Valid values for "cmd" are:
373"RTN","TMGRPC3",54,0)
374 ;" "GET USER LIST"
375"RTN","TMGRPC3",55,0)
376 ;" params: <empty> or NODISUSER
377"RTN","TMGRPC3",56,0)
378 ;" "GET RECORDS LIST" -- get list of all .01 fields for file.
379"RTN","TMGRPC3",57,0)
380 ;" params: FileNumber (e.g. 'GET RECORDS LIST^8989.3')
381"RTN","TMGRPC3",58,0)
382 ;" "GET ONE USER"
383"RTN","TMGRPC3",59,0)
384 ;" params: IEN (e.g. 'GET ONE USER^12345')
385"RTN","TMGRPC3",60,0)
386 ;" "GET ONE RECORD"
387"RTN","TMGRPC3",61,0)
388 ;" params: FileNum^IENS (e.g. 'GET ONE RECORD^200^73,')
389"RTN","TMGRPC3",62,0)
390 ;" "GET ONE WP FIELD"
391"RTN","TMGRPC3",63,0)
392 ;" params: FileNum^Field^IENS^ (e.g. 'GET ONE WP FIELD^200^2^73,')
393"RTN","TMGRPC3",64,0)
394 ;" "FILE ENTRY SUBSET"
395"RTN","TMGRPC3",65,0)
396 ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44)
397"RTN","TMGRPC3",66,0)
398 ;" "GET SUB RECS LIST" -- get all .01 sub record entries for a subfile
399"RTN","TMGRPC3",67,0)
400 ;" params: SubFileNum^ParentIENS
401"RTN","TMGRPC3",68,0)
402 ;" "POST DATA"
403"RTN","TMGRPC3",69,0)
404 ;" params: (not used)
405"RTN","TMGRPC3",70,0)
406 ;" INPUT(0)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue
407"RTN","TMGRPC3",71,0)
408 ;" INPUT(1)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue
409"RTN","TMGRPC3",72,0)
410 ;" ... (note: FieldName and oldValue are not used)
411"RTN","TMGRPC3",73,0)
412 ;" "POST WP FIELD"
413"RTN","TMGRPC3",74,0)
414 ;" params: FileNum^FieldNum^IENS (e.g. 'POST WP FIELD^200^2^73,')
415"RTN","TMGRPC3",75,0)
416 ;" WP field itself is stored as follows:
417"RTN","TMGRPC3",76,0)
418 ;" INPUT(0)=0TH line
419"RTN","TMGRPC3",77,0)
420 ;" INPUT(1)=1st line
421"RTN","TMGRPC3",78,0)
422 ;" INPUT(2)=2nd line
423"RTN","TMGRPC3",79,0)
424 ;" ...
425"RTN","TMGRPC3",80,0)
426 ;" Note: don't include INPUT("REQUEST") with text.
427"RTN","TMGRPC3",81,0)
428 ;" "GET EMPTY ENTRY" -- getting stub entries for subfiles typically
429"RTN","TMGRPC3",82,0)
430 ;" params: file entry (file or subfile number)
431"RTN","TMGRPC3",83,0)
432 ;" "GET CURRENT USER NAME" -- return name of DUZ (current) user
433"RTN","TMGRPC3",84,0)
434 ;" (params: not used)
435"RTN","TMGRPC3",85,0)
436 ;" "CLONE USER"
437"RTN","TMGRPC3",86,0)
438 ;" params: SourceIENS^New.01Value
439"RTN","TMGRPC3",87,0)
440 ;" "CLONE RECORD"
441"RTN","TMGRPC3",88,0)
442 ;" params: FileNum^SourceIENS^New.01Value
443"RTN","TMGRPC3",89,0)
444 ;" "GET HELP MSG"
445"RTN","TMGRPC3",90,0)
446 ;" params : FileNum^FieldNum^HelpType
447"RTN","TMGRPC3",91,0)
448 ;" "IS WP FIELD"
449"RTN","TMGRPC3",92,0)
450 ;" params: FileNum^FieldNum
451"RTN","TMGRPC3",93,0)
452 ;" "GET ONE WP FIELD" -- retrieve on word processing (WP) field entry
453"RTN","TMGRPC3",94,0)
454 ;" param -- FileNum^Field^IENS (e.g. 'GET ONE WP FIELD^200^2^73,')
455"RTN","TMGRPC3",95,0)
456 ;" "REGISTER PATIENT"
457"RTN","TMGRPC3",96,0)
458 ;" param -- FieldNum1^FieldValue1^FieldNum2^FieldValue2^FieldNum3^FieldValue3^...
459"RTN","TMGRPC3",97,0)
460 ;"Output: results of this function should be put into RESULTS array.
461"RTN","TMGRPC3",98,0)
462 ;" For cmd:
463"RTN","TMGRPC3",99,0)
464 ;" "GET USER LIST"
465"RTN","TMGRPC3",100,0)
466 ;" RESULT(0)="1^Success" or "-1^Message"
467"RTN","TMGRPC3",101,0)
468 ;" RESULT(1)=Name^IEN^200^DISUSER DISUSER will be 1 for "Y" or 0 for "N"
469"RTN","TMGRPC3",102,0)
470 ;" RESULT(2)=Name^IEN^200^DISUSER
471"RTN","TMGRPC3",103,0)
472 ;" etc ...
473"RTN","TMGRPC3",104,0)
474 ;" "GET RECORDS LIST"
475"RTN","TMGRPC3",105,0)
476 ;" RESULT(0)="1^Success" or "-1^Message"
477"RTN","TMGRPC3",106,0)
478 ;" RESULT(1)=.01Value^IEN^FileNum
479"RTN","TMGRPC3",107,0)
480 ;" RESULT(2)=.01Value^IEN^FileNum
481"RTN","TMGRPC3",108,0)
482 ;" etc ...
483"RTN","TMGRPC3",109,0)
484 ;" "GET ONE USER"
485"RTN","TMGRPC3",110,0)
486 ;" RESULT(0)="1^Success" or "-1^Message"
487"RTN","TMGRPC3",111,0)
488 ;" RESULT(1)=File^IENS^FieldNum^ExternalValue^DDInfo...
489"RTN","TMGRPC3",112,0)
490 ;" RESULT(2)=File^IENS^FieldNum^ExternalValue^DDInfo...
491"RTN","TMGRPC3",113,0)
492 ;" etc ...
493"RTN","TMGRPC3",114,0)
494 ;" "GET ONE RECORD"
495"RTN","TMGRPC3",115,0)
496 ;" RESULT(0)="1^Success" or "-1^Message"
497"RTN","TMGRPC3",116,0)
498 ;" RESULT(1)=File^IENS^FieldNum^ExternalValue^DDInfo...
499"RTN","TMGRPC3",117,0)
500 ;" RESULT(2)=File^IENS^FieldNum^ExternalValue^DDInfo...
501"RTN","TMGRPC3",118,0)
502 ;" ...
503"RTN","TMGRPC3",119,0)
504 ;" "GET ONE WP FIELD"
505"RTN","TMGRPC3",120,0)
506 ;" RESULT(0): "1^Success" or "-1^Message"
507"RTN","TMGRPC3",121,0)
508 ;" RESULT(1) will contain Fileman error, if any
509"RTN","TMGRPC3",122,0)
510 ;" - or to return WP array -
511"RTN","TMGRPC3",123,0)
512 ;" RESULT(1)=1st line of text
513"RTN","TMGRPC3",124,0)
514 ;" RESULT(2)=2nd line of text
515"RTN","TMGRPC3",125,0)
516 ;" etc..
517"RTN","TMGRPC3",126,0)
518 ;" "FILE ENTRY SUBSET"
519"RTN","TMGRPC3",127,0)
520 ;" RESULT(0)="1^Success" or "-1^Message"
521"RTN","TMGRPC3",128,0)
522 ;" RESULT(1)=Value
523"RTN","TMGRPC3",129,0)
524 ;" RESULT(2)=Value
525"RTN","TMGRPC3",130,0)
526 ;" etc ...
527"RTN","TMGRPC3",131,0)
528 ;" "GET SUB RECS LIST"
529"RTN","TMGRPC3",132,0)
530 ;" RESULT(0)="1^Success" or "-1^Message"
531"RTN","TMGRPC3",133,0)
532 ;" RESULT(1)=IEN^Value
533"RTN","TMGRPC3",134,0)
534 ;" RESULT(2)=IEN^Value
535"RTN","TMGRPC3",135,0)
536 ;" ...
537"RTN","TMGRPC3",136,0)
538 ;" "POST DATA"
539"RTN","TMGRPC3",137,0)
540 ;" RESULT(0)="1^Success" or "-1^Message"
541"RTN","TMGRPC3",138,0)
542 ;" RESULT(1)=Fileman message (long) (if generated)
543"RTN","TMGRPC3",139,0)
544 ;" -or (if +1 etc values used)-
545"RTN","TMGRPC3",140,0)
546 ;" RESULT(1)=+5^1234 <-- results of IEN array returned (+5 converted to record 1234)
547"RTN","TMGRPC3",141,0)
548 ;" RESULT(2)=+3^2341 <-- results of IEN array returned (+3 converted to record 2341)
549"RTN","TMGRPC3",142,0)
550 ;" ...
551"RTN","TMGRPC3",143,0)
552 ;" "GET EMPTY ENTRY"
553"RTN","TMGRPC3",144,0)
554 ;" RESULT(0)="1^Success" or "-1^Message"
555"RTN","TMGRPC3",145,0)
556 ;" RESULT(1)=File^^FieldNum^^DDInfo...
557"RTN","TMGRPC3",146,0)
558 ;" RESULT(2)=File^^FieldNum^^DDInfo...
559"RTN","TMGRPC3",147,0)
560 ;" etc ...
561"RTN","TMGRPC3",148,0)
562 ;" "GET CURRENT USER NAME" -- return name of DUZ (current) user
563"RTN","TMGRPC3",149,0)
564 ;" RESULT(0)="1^Success^UserName" or "-1^Message"
565"RTN","TMGRPC3",150,0)
566 ;" "CLONE USER"
567"RTN","TMGRPC3",151,0)
568 ;" RESULT(0)="1^Success^NewIENS" or "-1^Message"
569"RTN","TMGRPC3",152,0)
570 ;" RESULT(1)=Long Fileman message (if -1 error)
571"RTN","TMGRPC3",153,0)
572 ;" "CLONE RECORD"
573"RTN","TMGRPC3",154,0)
574 ;" RESULT(0)="1^Success^NewIENS" or "-1^Message"
575"RTN","TMGRPC3",155,0)
576 ;" RESULT(1)=Fileman message (long) (if generated)
577"RTN","TMGRPC3",156,0)
578 ;" "GET HELP MSG"
579"RTN","TMGRPC3",157,0)
580 ;" RESULT(0)="1^Success^NewIENS" or "-1^Message"
581"RTN","TMGRPC3",158,0)
582 ;" RESULT(1)=Fileman message (long) (if generated)
583"RTN","TMGRPC3",159,0)
584 ;" "IS WP FIELD"
585"RTN","TMGRPC3",160,0)
586 ;" RESULT(0)="1^Success^YES/NO" or "-1^Message"
587"RTN","TMGRPC3",161,0)
588 ;" "YES" if is a WP subfile, otherwise "NO"
589"RTN","TMGRPC3",162,0)
590 ;" RESULT(1)=Fileman message (long) (if generated)
591"RTN","TMGRPC3",163,0)
592 ;" "REGISTER PATIENT"
593"RTN","TMGRPC3",164,0)
594 ;" RESULT(0)="1^Success^NewIEN" or "-1^Message"
595"RTN","TMGRPC3",165,0)
596 ;" RESULT(1)=Fileman message (long) (if generated)
597"RTN","TMGRPC3",166,0)
598
599"RTN","TMGRPC3",167,0)
600 ;"Result: none
601"RTN","TMGRPC3",168,0)
602
603"RTN","TMGRPC3",169,0)
604 new command,params
605"RTN","TMGRPC3",170,0)
606 set command=$$TRIM^XLFSTR($$UP^XLFSTR($piece($get(INPUT("REQUEST")),"^",1)))
607"RTN","TMGRPC3",171,0)
608 set params=$$UP^XLFSTR($piece($get(INPUT("REQUEST")),"^",2,199))
609"RTN","TMGRPC3",172,0)
610 set RESULT(0)="-1^No command requested." ;"default to error state.
611"RTN","TMGRPC3",173,0)
612 if command="GET USER LIST" do
613"RTN","TMGRPC3",174,0)
614 . do GetUserList(.RESULT,params)
615"RTN","TMGRPC3",175,0)
616 if command="GET RECORDS LIST" do
617"RTN","TMGRPC3",176,0)
618 . do GetRecordsList(.RESULT,params)
619"RTN","TMGRPC3",177,0)
620 else if command="GET ONE USER" do
621"RTN","TMGRPC3",178,0)
622 . do GetOneUser(.RESULT,params)
623"RTN","TMGRPC3",179,0)
624 else if command="GET ONE RECORD" do
625"RTN","TMGRPC3",180,0)
626 . do GetOneRecord(.RESULT,params)
627"RTN","TMGRPC3",181,0)
628 else if command="FILE ENTRY SUBSET" do
629"RTN","TMGRPC3",182,0)
630 . do GetFileSubset(.RESULT,params)
631"RTN","TMGRPC3",183,0)
632 else if command="GET SUB RECS LIST" do
633"RTN","TMGRPC3",184,0)
634 . do GetSubRecsList(.RESULT,params)
635"RTN","TMGRPC3",185,0)
636 else if command="POST DATA" do
637"RTN","TMGRPC3",186,0)
638 . kill INPUT("REQUEST")
639"RTN","TMGRPC3",187,0)
640 . do PostData(.RESULT,.INPUT)
641"RTN","TMGRPC3",188,0)
642 else if command="GET EMPTY ENTRY" do
643"RTN","TMGRPC3",189,0)
644 . do GetEmptyEntry(.RESULT,params)
645"RTN","TMGRPC3",190,0)
646 else if command="GET CURRENT USER NAME" do
647"RTN","TMGRPC3",191,0)
648 . set RESULT(0)="1^Success^"_$piece($get(^VA(200,DUZ,0)),"^",1)
649"RTN","TMGRPC3",192,0)
650 else if command="CLONE RECORD" do
651"RTN","TMGRPC3",193,0)
652 . do CloneRecord(.RESULT,params)
653"RTN","TMGRPC3",194,0)
654 else if command="CLONE USER" do
655"RTN","TMGRPC3",195,0)
656 . do CloneUser(.RESULT,params)
657"RTN","TMGRPC3",196,0)
658 else if command="GET HELP MSG" do
659"RTN","TMGRPC3",197,0)
660 . do GetHelpMsg(.RESULT,params)
661"RTN","TMGRPC3",198,0)
662 else if command="IS WP FIELD" do
663"RTN","TMGRPC3",199,0)
664 . do GetIfWPField(.RESULT,params)
665"RTN","TMGRPC3",200,0)
666 else if command="GET ONE WP FIELD" do
667"RTN","TMGRPC3",201,0)
668 . do GetWPField(.RESULT,params)
669"RTN","TMGRPC3",202,0)
670 else if command="POST WP FIELD" do
671"RTN","TMGRPC3",203,0)
672 . kill INPUT("REQUEST")
673"RTN","TMGRPC3",204,0)
674 . do PostWPField(.RESULT,params,.INPUT)
675"RTN","TMGRPC3",205,0)
676 else if command="REGISTER PATIENT" do
677"RTN","TMGRPC3",206,0)
678 . do RegPatient(.RESULT,params)
679"RTN","TMGRPC3",207,0)
680
681"RTN","TMGRPC3",208,0)
682
683"RTN","TMGRPC3",209,0)
684 quit
685"RTN","TMGRPC3",210,0)
686
687"RTN","TMGRPC3",211,0)
688 ;"=======================================================================
689"RTN","TMGRPC3",212,0)
690
691"RTN","TMGRPC3",213,0)
692GetUserList(OutArray,param)
693"RTN","TMGRPC3",214,0)
694 ;"Purpose: to fill list with users on the system.
695"RTN","TMGRPC3",215,0)
696 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
697"RTN","TMGRPC3",216,0)
698 ;" param -- either "" or "NODISUSER" if not to return DISUSER=YES users
699"RTN","TMGRPC3",217,0)
700 ;"Output: OutArray is filled as follows:
701"RTN","TMGRPC3",218,0)
702 ;" OutArray(0)="1^Success" or "-1^Message"
703"RTN","TMGRPC3",219,0)
704 ;" OutArray(1)=Name^IEN^200^DISUSER DISUSER will be 1 for "Y" or 0 for "N"
705"RTN","TMGRPC3",220,0)
706 ;" OutArray(2)=Name^IEN^200^DISUSER
707"RTN","TMGRPC3",221,0)
708 ;"Results: none
709"RTN","TMGRPC3",222,0)
710
711"RTN","TMGRPC3",223,0)
712 new onlyActive set onlyActive=($get(param)="NODISUSER")
713"RTN","TMGRPC3",224,0)
714 new index set index=1
715"RTN","TMGRPC3",225,0)
716 new name set name=""
717"RTN","TMGRPC3",226,0)
718 for set name=$order(^VA(200,"B",name)) quit:(name="") do
719"RTN","TMGRPC3",227,0)
720 . new IEN set IEN=""
721"RTN","TMGRPC3",228,0)
722 . for set IEN=$order(^VA(200,"B",name,IEN)) quit:(+IEN'>0) do
723"RTN","TMGRPC3",229,0)
724 . . new disUser set disUser=$piece($get(^VA(200,IEN,0)),"^",7)
725"RTN","TMGRPC3",230,0)
726 . . if onlyActive&disUser quit
727"RTN","TMGRPC3",231,0)
728 . . new name set name=$piece($get(^VA(200,IEN,0)),"^",1)
729"RTN","TMGRPC3",232,0)
730 . . set OutArray(index)=name_"^"_IEN_"^200^"_disUser
731"RTN","TMGRPC3",233,0)
732 . . set index=index+1
733"RTN","TMGRPC3",234,0)
734
735"RTN","TMGRPC3",235,0)
736 set OutArray(0)="1^Success"
737"RTN","TMGRPC3",236,0)
738
739"RTN","TMGRPC3",237,0)
740 quit
741"RTN","TMGRPC3",238,0)
742
743"RTN","TMGRPC3",239,0)
744GetRecordsList(OutArray,param)
745"RTN","TMGRPC3",240,0)
746 ;"Purpose: to fill list with records in file on the system.
747"RTN","TMGRPC3",241,0)
748 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
749"RTN","TMGRPC3",242,0)
750 ;" param -- Filenumber
751"RTN","TMGRPC3",243,0)
752 ;"Output: OutArray is filled as follows:
753"RTN","TMGRPC3",244,0)
754 ;" OutArray(0)="1^Success" or "-1^Message"
755"RTN","TMGRPC3",245,0)
756 ;" OutArray(1)=.01Value^IEN^FileNum
757"RTN","TMGRPC3",246,0)
758 ;" OutArray(2)=.01Value^IEN^FileNum
759"RTN","TMGRPC3",247,0)
760 ;"Results: none
761"RTN","TMGRPC3",248,0)
762
763"RTN","TMGRPC3",249,0)
764 new index set index=1
765"RTN","TMGRPC3",250,0)
766 new name set name=""
767"RTN","TMGRPC3",251,0)
768 new FileNum set FileNum=+$get(param)
769"RTN","TMGRPC3",252,0)
770 if FileNum'>0 do goto GRLDone
771"RTN","TMGRPC3",253,0)
772 . set OutArray(0)="-1^Valid file number not found"
773"RTN","TMGRPC3",254,0)
774 new ref set ref=$get(^DIC(FileNum,0,"GL"))
775"RTN","TMGRPC3",255,0)
776 set ref=$$CREF^DILF(ref)
777"RTN","TMGRPC3",256,0)
778 if ref="" do goto GRLDone
779"RTN","TMGRPC3",257,0)
780 . set OutArray(0)="-1^Unable to find global reference for file: "_FileNum
781"RTN","TMGRPC3",258,0)
782 new loc,pce
783"RTN","TMGRPC3",259,0)
784 set loc=$piece(^DD(FileNum,.01,0),"^",4)
785"RTN","TMGRPC3",260,0)
786 set pce=$piece(loc,";",2)
787"RTN","TMGRPC3",261,0)
788 set loc=$piece(loc,";",1)
789"RTN","TMGRPC3",262,0)
790 for set name=$order(@ref@("B",name)) quit:(name="") do
791"RTN","TMGRPC3",263,0)
792 . new IEN set IEN=""
793"RTN","TMGRPC3",264,0)
794 . for set IEN=$order(@ref@("B",name,IEN)) quit:(+IEN'>0) do
795"RTN","TMGRPC3",265,0)
796 . . new name set name=$piece($get(@ref@(IEN,loc)),"^",pce)
797"RTN","TMGRPC3",266,0)
798 . . set OutArray(index)=name_"^"_IEN_"^"_FileNum
799"RTN","TMGRPC3",267,0)
800 . . set index=index+1
801"RTN","TMGRPC3",268,0)
802
803"RTN","TMGRPC3",269,0)
804 set OutArray(0)="1^Success"
805"RTN","TMGRPC3",270,0)
806GRLDone
807"RTN","TMGRPC3",271,0)
808 quit
809"RTN","TMGRPC3",272,0)
810
811"RTN","TMGRPC3",273,0)
812GetOneUser(OutArray,IEN)
813"RTN","TMGRPC3",274,0)
814 ;"Purpose: to get record of one user
815"RTN","TMGRPC3",275,0)
816 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
817"RTN","TMGRPC3",276,0)
818 ;" IEN -- the IEN in file 200 to get
819"RTN","TMGRPC3",277,0)
820 ;"Output: OutArray is filled as follows:
821"RTN","TMGRPC3",278,0)
822 ;" OutArray(0)="1^Success" or "-1^Message"
823"RTN","TMGRPC3",279,0)
824 ;" OutArray(1)=File^IENS^FieldNum^ExternalValue^DDInfo...
825"RTN","TMGRPC3",280,0)
826 ;" OutArray(2)=File^IENS^FieldNum^ExternalValue^DDInfo...
827"RTN","TMGRPC3",281,0)
828 ;"Note: the fields to return are decided HERE
829"RTN","TMGRPC3",282,0)
830 ;"Results: none
831"RTN","TMGRPC3",283,0)
832
833"RTN","TMGRPC3",284,0)
834 new IENS set IENS=+$get(IEN)_","
835"RTN","TMGRPC3",285,0)
836 do GetOneRecord(.OutArray,"200^"_IENS)
837"RTN","TMGRPC3",286,0)
838 quit
839"RTN","TMGRPC3",287,0)
840
841"RTN","TMGRPC3",288,0)
842
843"RTN","TMGRPC3",289,0)
844GetOneRecord(OutArray,params)
845"RTN","TMGRPC3",290,0)
846 ;"Purpose: to get one record in file
847"RTN","TMGRPC3",291,0)
848 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
849"RTN","TMGRPC3",292,0)
850 ;" params: File^IENS
851"RTN","TMGRPC3",293,0)
852 ;" File -- the file or subfile to retrieve from
853"RTN","TMGRPC3",294,0)
854 ;" IENS -- if File is a subfile, then IENS should be full IENS to get (e.g. '2,103,')
855"RTN","TMGRPC3",295,0)
856 ;" if File is not a subfile, then IENS can be just IEN or IEN_","
857"RTN","TMGRPC3",296,0)
858 ;"Output: OutArray is filled as follows:
859"RTN","TMGRPC3",297,0)
860 ;" OutArray(0)="1^Success" or "-1^Message"
861"RTN","TMGRPC3",298,0)
862 ;" OutArray(1)=File^IENS^FieldNum^ExternalValue^DDInfo...
863"RTN","TMGRPC3",299,0)
864 ;" OutArray(2)=File^IENS^FieldNum^ExternalValue^DDInfo...
865"RTN","TMGRPC3",300,0)
866 ;"Note: the fields to return are decided HERE
867"RTN","TMGRPC3",301,0)
868 ;"Results: none
869"RTN","TMGRPC3",302,0)
870
871"RTN","TMGRPC3",303,0)
872 set OutArray(0)="1^Success" ;"default to success
873"RTN","TMGRPC3",304,0)
874 new TMGARRAY,TMGMSG
875"RTN","TMGRPC3",305,0)
876 new ref set ref="TMGARRAY"
877"RTN","TMGRPC3",306,0)
878 set params=$get(params)
879"RTN","TMGRPC3",307,0)
880 new file set file=$piece(params,"^",1)
881"RTN","TMGRPC3",308,0)
882 if +file'>0 do goto GORDone
883"RTN","TMGRPC3",309,0)
884 . set OutArray(0)="-1^No file number supplied"
885"RTN","TMGRPC3",310,0)
886 new IENS set IENS=$piece(params,"^",2)
887"RTN","TMGRPC3",311,0)
888 if IENS="" do goto GORDone
889"RTN","TMGRPC3",312,0)
890 . set OutArray(0)="-1^No IENS supplied"
891"RTN","TMGRPC3",313,0)
892
893"RTN","TMGRPC3",314,0)
894 do GETS^DIQ(file,IENS,"**","IE",ref,"TMGMSG")
895"RTN","TMGRPC3",315,0)
896
897"RTN","TMGRPC3",316,0)
898 if $data(TMGMSG("DIERR")) do goto GORDone
899"RTN","TMGRPC3",317,0)
900 . set OutArray(0)="-1^See Fileman message"
901"RTN","TMGRPC3",318,0)
902 . set OutArray(1)=$$GetErrStr(.TMGMSG)
903"RTN","TMGRPC3",319,0)
904
905"RTN","TMGRPC3",320,0)
906 do ExtractFields(.OutArray,.TMGARRAY,"E")
907"RTN","TMGRPC3",321,0)
908
909"RTN","TMGRPC3",322,0)
910GORDone
911"RTN","TMGRPC3",323,0)
912 quit
913"RTN","TMGRPC3",324,0)
914
915"RTN","TMGRPC3",325,0)
916
917"RTN","TMGRPC3",326,0)
918ExtractFields(OutArray,TMGARRAY,Flag)
919"RTN","TMGRPC3",327,0)
920 ;"Purpose: convert output from GETS^DIQ into another format
921"RTN","TMGRPC3",328,0)
922
923"RTN","TMGRPC3",329,0)
924 new index set index=1
925"RTN","TMGRPC3",330,0)
926 new file,field,IENS
927"RTN","TMGRPC3",331,0)
928 set file=""
929"RTN","TMGRPC3",332,0)
930 for set file=$order(TMGARRAY(file)) quit:(file="") do
931"RTN","TMGRPC3",333,0)
932 . set IENS=""
933"RTN","TMGRPC3",334,0)
934 . for set IENS=$order(TMGARRAY(file,IENS)) quit:(IENS="") do
935"RTN","TMGRPC3",335,0)
936 . . set field=0
937"RTN","TMGRPC3",336,0)
938 . . for set field=$order(^DD(file,field)) quit:(+field'>0) do
939"RTN","TMGRPC3",337,0)
940 . . . if $get(TMGARRAY(file,IENS,field,Flag))="" do
941"RTN","TMGRPC3",338,0)
942 . . . . set TMGARRAY(file,IENS,field,Flag)=""
943"RTN","TMGRPC3",339,0)
944 . . set field=""
945"RTN","TMGRPC3",340,0)
946 . . for set field=$order(TMGARRAY(file,IENS,field)) quit:(field="") do
947"RTN","TMGRPC3",341,0)
948 . . . new Value set Value=$get(TMGARRAY(file,IENS,field,Flag))
949"RTN","TMGRPC3",342,0)
950 . . . new DDInfo set DDInfo=$piece($get(^DD(file,field,0)),"^",1,4)
951"RTN","TMGRPC3",343,0)
952 . . . if $piece(DDInfo,"^",2)["D" do ;"convert data format to one Delphi can use
953"RTN","TMGRPC3",344,0)
954 . . . . if Flag="I" quit
955"RTN","TMGRPC3",345,0)
956 . . . . new X set X=$get(TMGARRAY(file,IENS,field,"I"))
957"RTN","TMGRPC3",346,0)
958 . . . . set Value=$$FMTE^XLFDT(X,5)
959"RTN","TMGRPC3",347,0)
960 . . . set OutArray(index)=file_"^"_IENS_"^"_field_"^"_Value
961"RTN","TMGRPC3",348,0)
962 . . . set OutArray(index)=OutArray(index)_"^"_DDInfo
963"RTN","TMGRPC3",349,0)
964 . . . set index=index+1
965"RTN","TMGRPC3",350,0)
966
967"RTN","TMGRPC3",351,0)
968 quit
969"RTN","TMGRPC3",352,0)
970
971"RTN","TMGRPC3",353,0)
972GetFileSubset(OutArray,params)
973"RTN","TMGRPC3",354,0)
974 ;"Purpose: to return a subset of entries a file's .01 names
975"RTN","TMGRPC3",355,0)
976 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
977"RTN","TMGRPC3",356,0)
978 ;" params -- FileNum^StartFrom^Direction^maxCount
979"RTN","TMGRPC3",357,0)
980 ;" FileNum - filename file to traverse
981"RTN","TMGRPC3",358,0)
982 ;" StartFrom -- text to $order() from -- OPTIONAL
983"RTN","TMGRPC3",359,0)
984 ;" Direction -- $order(xx,Direction) direction (should be 1 or -1) -- OPTIONAL
985"RTN","TMGRPC3",360,0)
986 ;" maxCt -- OPTIONAL -- the max number of entries to return.
987"RTN","TMGRPC3",361,0)
988 ;"Output: OutArray is filled as follows:
989"RTN","TMGRPC3",362,0)
990 ;" OutArray(0)="1^Success" or "-1^Message"
991"RTN","TMGRPC3",363,0)
992 ;" OutArray(1)=IEN^Value
993"RTN","TMGRPC3",364,0)
994 ;" OutArray(2)=IEN^Value
995"RTN","TMGRPC3",365,0)
996 ;" ...
997"RTN","TMGRPC3",366,0)
998 ;"Results: none
999"RTN","TMGRPC3",367,0)
1000 ;"NOTE: does NOT work with sub files.
1001"RTN","TMGRPC3",368,0)
1002
1003"RTN","TMGRPC3",369,0)
1004 new File set File=+$piece(params,"^",1)
1005"RTN","TMGRPC3",370,0)
1006 if File'>0 do goto GFSDone
1007"RTN","TMGRPC3",371,0)
1008 . set OutArray(0)="-1^No file number supplied"
1009"RTN","TMGRPC3",372,0)
1010 new From set From=$piece(params,"^",2)
1011"RTN","TMGRPC3",373,0)
1012 new dir set dir=$piece(params,"^",3)
1013"RTN","TMGRPC3",374,0)
1014 if dir'=-1 set dir=1
1015"RTN","TMGRPC3",375,0)
1016 new maxCt set maxCt=+$piece(params,"^",4)
1017"RTN","TMGRPC3",376,0)
1018 if maxCt=0 set maxCt=44
1019"RTN","TMGRPC3",377,0)
1020
1021"RTN","TMGRPC3",378,0)
1022 new i set i=0
1023"RTN","TMGRPC3",379,0)
1024 new last set last=""
1025"RTN","TMGRPC3",380,0)
1026 new prev set prev=""
1027"RTN","TMGRPC3",381,0)
1028 new ref set ref=$get(^DIC(File,0,"GL"))
1029"RTN","TMGRPC3",382,0)
1030 set ref=$$CREF^DILF(ref) ;"convert open --> closed reference
1031"RTN","TMGRPC3",383,0)
1032 if ref="" do goto GFSDone
1033"RTN","TMGRPC3",384,0)
1034 . set OutArray(0)="-1^Unable to obtain global ref for file #"_File
1035"RTN","TMGRPC3",385,0)
1036
1037"RTN","TMGRPC3",386,0)
1038 for set From=$order(@ref@("B",From),dir) quit:(From="")!(i=maxCt) do
1039"RTN","TMGRPC3",387,0)
1040 . new IEN set IEN=""
1041"RTN","TMGRPC3",388,0)
1042 . for set IEN=$order(@ref@("B",From,IEN),dir) quit:(+IEN'>0) do
1043"RTN","TMGRPC3",389,0)
1044 . . set i=i+1
1045"RTN","TMGRPC3",390,0)
1046 . . set OutArray(i)=IEN_"^"_$$GET1^DIQ(File,IEN_",",.01)
1047"RTN","TMGRPC3",391,0)
1048 . . ;"set OutArray(i)=$$GET1^DIQ(File,IEN_",",.01)
1049"RTN","TMGRPC3",392,0)
1050
1051"RTN","TMGRPC3",393,0)
1052 set OutArray(0)="1^Success"
1053"RTN","TMGRPC3",394,0)
1054GFSDone
1055"RTN","TMGRPC3",395,0)
1056 quit
1057"RTN","TMGRPC3",396,0)
1058
1059"RTN","TMGRPC3",397,0)
1060
1061"RTN","TMGRPC3",398,0)
1062GetSubRecsList(OutArray,params)
1063"RTN","TMGRPC3",399,0)
1064 ;"Purpose: Get all .01 sub record entries for a subfile
1065"RTN","TMGRPC3",400,0)
1066 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1067"RTN","TMGRPC3",401,0)
1068 ;" params -- SubFileNum^ParentIENS
1069"RTN","TMGRPC3",402,0)
1070 ;" SubFileNum - Subfile Number to get list from.
1071"RTN","TMGRPC3",403,0)
1072 ;" ParentIENS -- IENS for parent to get list from (e.g. "73,"
1073"RTN","TMGRPC3",404,0)
1074 ;"Output: OutArray is filled as follows:
1075"RTN","TMGRPC3",405,0)
1076 ;" OutArray(0)="1^Success" or "-1^Message"
1077"RTN","TMGRPC3",406,0)
1078 ;" OutArray(1)=IEN^Value
1079"RTN","TMGRPC3",407,0)
1080 ;" OutArray(2)=IEN^Value
1081"RTN","TMGRPC3",408,0)
1082 ;" ...
1083"RTN","TMGRPC3",409,0)
1084 ;"Results: none
1085"RTN","TMGRPC3",410,0)
1086
1087"RTN","TMGRPC3",411,0)
1088 set OutArray(0)="1^Success"
1089"RTN","TMGRPC3",412,0)
1090 new subFile set subFile=+$piece(params,"^",1)
1091"RTN","TMGRPC3",413,0)
1092 if subFile'>0 do goto GSRLDone
1093"RTN","TMGRPC3",414,0)
1094 . set OutArray(0)="-1^No Subfile number supplied"
1095"RTN","TMGRPC3",415,0)
1096 new ParentIENS set ParentIENS=$piece(params,"^",2)
1097"RTN","TMGRPC3",416,0)
1098 if ParentIENS="" do goto GSRLDone
1099"RTN","TMGRPC3",417,0)
1100 . set OutArray(0)="-1^No Parent IENS supplied"
1101"RTN","TMGRPC3",418,0)
1102 new IENS set IENS=","_ParentIENS
1103"RTN","TMGRPC3",419,0)
1104
1105"RTN","TMGRPC3",420,0)
1106 do LIST^DIC(subFile,IENS,,"PU","*",,,,,,"TMGMSG","TMGERR")
1107"RTN","TMGRPC3",421,0)
1108
1109"RTN","TMGRPC3",422,0)
1110 if $data(TMGMSG("DIERR")) do goto GSRLDone
1111"RTN","TMGRPC3",423,0)
1112 . set OutArray(0)="-1^See Fileman message"
1113"RTN","TMGRPC3",424,0)
1114 . set OutArray(1)=$$GetErrStr(.TMGMSG)
1115"RTN","TMGRPC3",425,0)
1116
1117"RTN","TMGRPC3",426,0)
1118 new count set count=1
1119"RTN","TMGRPC3",427,0)
1120 new i set i=0
1121"RTN","TMGRPC3",428,0)
1122 for set i=$order(TMGMSG("DILIST",i)) quit:(+i'>0) do
1123"RTN","TMGRPC3",429,0)
1124 . new oneEntry set oneEntry=$get(TMGMSG("DILIST",i,0))
1125"RTN","TMGRPC3",430,0)
1126 . if oneEntry="" quit
1127"RTN","TMGRPC3",431,0)
1128 . new IEN set IEN=$piece(oneEntry,"^",1)
1129"RTN","TMGRPC3",432,0)
1130 . set $piece(oneEntry,"^",1)=IEN_","_ParentIENS
1131"RTN","TMGRPC3",433,0)
1132 . set OutArray(count)=oneEntry
1133"RTN","TMGRPC3",434,0)
1134 . set count=count+1
1135"RTN","TMGRPC3",435,0)
1136
1137"RTN","TMGRPC3",436,0)
1138GSRLDone
1139"RTN","TMGRPC3",437,0)
1140 quit
1141"RTN","TMGRPC3",438,0)
1142
1143"RTN","TMGRPC3",439,0)
1144
1145"RTN","TMGRPC3",440,0)
1146PostData(OutArray,Data,Flag)
1147"RTN","TMGRPC3",441,0)
1148 ;"Post Changes to database via Fileman
1149"RTN","TMGRPC3",442,0)
1150 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1151"RTN","TMGRPC3",443,0)
1152 ;" Data -- Entries to be filed. Format:
1153"RTN","TMGRPC3",444,0)
1154 ;" Data(0)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue
1155"RTN","TMGRPC3",445,0)
1156 ;" Data(1)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue
1157"RTN","TMGRPC3",446,0)
1158 ;" Data(2)=FileNum^IENS^FieldNum^FieldName^newValue^oldValue
1159"RTN","TMGRPC3",447,0)
1160 ;" ...
1161"RTN","TMGRPC3",448,0)
1162 ;" Note: FieldName, oldValue pieces are not used (optional)
1163"RTN","TMGRPC3",449,0)
1164 ;" Flag -- OPTIONAL, "E" is default. Flag passed to FILE^DIE or UPDATE^DIE
1165"RTN","TMGRPC3",450,0)
1166 ;" should be "E" or "I"
1167"RTN","TMGRPC3",451,0)
1168 ;"Output: OutArray is filled as follows:
1169"RTN","TMGRPC3",452,0)
1170 ;" OutArray(0)="1^Success" or "-1^Short Message"
1171"RTN","TMGRPC3",453,0)
1172 ;" OutArray(1)=Fileman message (long)
1173"RTN","TMGRPC3",454,0)
1174 ;" -or if new records added:
1175"RTN","TMGRPC3",455,0)
1176 ;" OutArray(1)=5^1234 <-- results of IEN array returned (+5 converted to record 1234)
1177"RTN","TMGRPC3",456,0)
1178 ;" OutArray(2)=3^2341 <-- results of IEN array returned (+3 converted to record 2341)
1179"RTN","TMGRPC3",457,0)
1180 ;" ...
1181"RTN","TMGRPC3",458,0)
1182 ;"Results: none
1183"RTN","TMGRPC3",459,0)
1184
1185"RTN","TMGRPC3",460,0)
1186 new AVC set AVC=0 ;"AVC=AccessVerifyCode. Default to no change.
1187"RTN","TMGRPC3",461,0)
1188 new InactUser,ReactUser
1189"RTN","TMGRPC3",462,0)
1190 set Flag=$get(Flag,"E")
1191"RTN","TMGRPC3",463,0)
1192 new i set i=""
1193"RTN","TMGRPC3",464,0)
1194 new TMGFDA,TMGNEWFDA,TMGMSG,TMGIEN,DIC
1195"RTN","TMGRPC3",465,0)
1196 new TMGintFDA
1197"RTN","TMGRPC3",466,0)
1198 for set i=$order(Data(i)) quit:(i="") do
1199"RTN","TMGRPC3",467,0)
1200 . new file,IENS,field,value,oneEntry
1201"RTN","TMGRPC3",468,0)
1202 . new internalValue set internalValue=0
1203"RTN","TMGRPC3",469,0)
1204 . new continue set continue=0
1205"RTN","TMGRPC3",470,0)
1206 . set oneEntry=$get(Data(i))
1207"RTN","TMGRPC3",471,0)
1208 . set file=$piece(oneEntry,"^",1)
1209"RTN","TMGRPC3",472,0)
1210 . set IENS=$piece(oneEntry,"^",2)
1211"RTN","TMGRPC3",473,0)
1212 . set field=$piece(oneEntry,"^",3)
1213"RTN","TMGRPC3",474,0)
1214 . set value=$piece(oneEntry,"^",5)
1215"RTN","TMGRPC3",475,0)
1216 . if file=200 do
1217"RTN","TMGRPC3",476,0)
1218 . . if field=2 do ;"2 = Access Code
1219"RTN","TMGRPC3",477,0)
1220 . . . if IENS["+" do quit
1221"RTN","TMGRPC3",478,0)
1222 . . . . set continue=1
1223"RTN","TMGRPC3",479,0)
1224 . . . . set OutArray(1)="Can't set Access code when first adding new user. Try again."
1225"RTN","TMGRPC3",480,0)
1226 . . . ;"NOTICE: currently this code does NOT force code of certain length etc.
1227"RTN","TMGRPC3",481,0)
1228 . . . ;"S Y=$$VCHK(XV2,XUH) Q:Y Y ;check for valid verify code, returns 0 (for OK), or 1^msg
1229"RTN","TMGRPC3",482,0)
1230 . . . ;"set value=$$UP^XLFSTR(value) ;"access code must be upper case elh
1231"RTN","TMGRPC3",483,0)
1232 . . . set value=$$EN^XUSHSH(value) ;"access code is supposed to be hashed first
1233"RTN","TMGRPC3",484,0)
1234 . . . set AVC=1 ;"signal change
1235"RTN","TMGRPC3",485,0)
1236 . . . set AVC("DA")=+IENS
1237"RTN","TMGRPC3",486,0)
1238 . . . set internalValue=1
1239"RTN","TMGRPC3",487,0)
1240 . . else if field=11 do ;"11 = Verify Code
1241"RTN","TMGRPC3",488,0)
1242 . . . if IENS["+" do quit
1243"RTN","TMGRPC3",489,0)
1244 . . . . set continue=1
1245"RTN","TMGRPC3",490,0)
1246 . . . . set OutArray(1)="Can't set Verify code when first adding new user. Try again."
1247"RTN","TMGRPC3",491,0)
1248 . . . ;"NOTICE: currently this code does NOT force code of certain length etc.
1249"RTN","TMGRPC3",492,0)
1250 . . . ;"S Y=$$VCHK(XV2,XUH) Q:Y Y ;check for valid verify code, returns 0 (for OK), or 1^msg
1251"RTN","TMGRPC3",493,0)
1252 . . . ;"set value=$$UP^XLFSTR(value) ;"verify code must be upper case elh
1253"RTN","TMGRPC3",494,0)
1254 . . . set value=$$EN^XUSHSH(value) ;"verify code is supposed to be hashed first
1255"RTN","TMGRPC3",495,0)
1256 . . . set AVC=1 ;"signal change
1257"RTN","TMGRPC3",496,0)
1258 . . . set AVC("DA")=+IENS
1259"RTN","TMGRPC3",497,0)
1260 . . . set internalValue=1
1261"RTN","TMGRPC3",498,0)
1262 . . else if field=7 do ;"7 = DISUSER Value should be 'YES' or 'NO'
1263"RTN","TMGRPC3",499,0)
1264 . . . if IENS["+" do quit
1265"RTN","TMGRPC3",500,0)
1266 . . . . set continue=1
1267"RTN","TMGRPC3",501,0)
1268 . . . . set OutArray(1)="Can't set DISUSER code when first adding new user. Try again."
1269"RTN","TMGRPC3",502,0)
1270 . . . if value="YES" do
1271"RTN","TMGRPC3",503,0)
1272 . . . . set TMGFDA(200,IENS,9.2)="NOW" ;"add 9.2 = termination date
1273"RTN","TMGRPC3",504,0)
1274 . . . . set InactUser("DA")=+IENS
1275"RTN","TMGRPC3",505,0)
1276 . . . if (value="NO")!(value="@") do
1277"RTN","TMGRPC3",506,0)
1278 . . . . set TMGFDA(200,IENS,9.2)="@" ;"delete 9.2 = termination date
1279"RTN","TMGRPC3",507,0)
1280 . . . . set TMGFDA(200,IENS,9.4)="@" ;"delete 9.4 = termination reason
1281"RTN","TMGRPC3",508,0)
1282 . . . . set ReactUser("DA")=+IENS
1283"RTN","TMGRPC3",509,0)
1284 . . else if field=3 do ;"3 = FILE MANAGER ACCESS CODE (i.e. @ etc)
1285"RTN","TMGRPC3",510,0)
1286 . . . if value'["^" do
1287"RTN","TMGRPC3",511,0)
1288 . . . . set $piece(^VA(200,+IENS,0),"^",4)=value ;"force value in with low-level write
1289"RTN","TMGRPC3",512,0)
1290 . . . . set continue=1
1291"RTN","TMGRPC3",513,0)
1292 . if continue quit
1293"RTN","TMGRPC3",514,0)
1294 . if IENS["+" do
1295"RTN","TMGRPC3",515,0)
1296 . . set TMGNEWFDA(file,IENS,field)=value
1297"RTN","TMGRPC3",516,0)
1298 . else do
1299"RTN","TMGRPC3",517,0)
1300 . . if internalValue=1 set TMGintFDA(file,IENS,field)=value
1301"RTN","TMGRPC3",518,0)
1302 . . else set TMGFDA(file,IENS,field)=value
1303"RTN","TMGRPC3",519,0)
1304
1305"RTN","TMGRPC3",520,0)
1306 set OutArray(0)="1^Success" ;"default to success
1307"RTN","TMGRPC3",521,0)
1308 if $data(TMGFDA) do
1309"RTN","TMGRPC3",522,0)
1310 . do FILE^DIE(Flag_"K","TMGFDA","TMGMSG")
1311"RTN","TMGRPC3",523,0)
1312 if $data(TMGMSG("DIERR")) do
1313"RTN","TMGRPC3",524,0)
1314 . set OutArray(0)="-1^See Fileman message re posting"
1315"RTN","TMGRPC3",525,0)
1316 . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1))
1317"RTN","TMGRPC3",526,0)
1318
1319"RTN","TMGRPC3",527,0)
1320 if $data(TMGintFDA) do ;"process FDA with INTERNAL values
1321"RTN","TMGRPC3",528,0)
1322 . do FILE^DIE("K","TMGintFDA","TMGMSG")
1323"RTN","TMGRPC3",529,0)
1324 if $data(TMGMSG("DIERR")) do
1325"RTN","TMGRPC3",530,0)
1326 . set OutArray(0)="-1^See Fileman message re posting"
1327"RTN","TMGRPC3",531,0)
1328 . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1))
1329"RTN","TMGRPC3",532,0)
1330
1331"RTN","TMGRPC3",533,0)
1332 if $data(TMGNEWFDA) do
1333"RTN","TMGRPC3",534,0)
1334 . do UPDATE^DIE(Flag_"K","TMGNEWFDA","TMGIEN","TMGMSG")
1335"RTN","TMGRPC3",535,0)
1336 if $data(TMGMSG("DIERR")) do
1337"RTN","TMGRPC3",536,0)
1338 . set OutArray(0)="-1^See Fileman message re posting"
1339"RTN","TMGRPC3",537,0)
1340 . set OutArray(1)=$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1))
1341"RTN","TMGRPC3",538,0)
1342
1343"RTN","TMGRPC3",539,0)
1344 if ($piece(OutArray(0),"^",1)=1)&($data(TMGIEN)) do
1345"RTN","TMGRPC3",540,0)
1346 . new count set count=1
1347"RTN","TMGRPC3",541,0)
1348 . new i set i=""
1349"RTN","TMGRPC3",542,0)
1350 . for set i=$order(TMGIEN(i)) quit:(i="") do
1351"RTN","TMGRPC3",543,0)
1352 . . set OutArray(count)=i_"^"_$get(TMGIEN(i))
1353"RTN","TMGRPC3",544,0)
1354 . . set count=count+1
1355"RTN","TMGRPC3",545,0)
1356
1357"RTN","TMGRPC3",546,0)
1358 ;"If Access code / Verify code changed, then finish some follow up business
1359"RTN","TMGRPC3",547,0)
1360 ;" as per BRCVC^XUS2<--CVC^XUSRB<--called by RPC 'XUS CVC'
1361"RTN","TMGRPC3",548,0)
1362 if AVC do
1363"RTN","TMGRPC3",549,0)
1364 . new DA set DA=AVC("DA")
1365"RTN","TMGRPC3",550,0)
1366 . do CALL^XUSERP(DA,2) ;"Call for Kernel Create, **Update**, Disuser or Terminate events
1367"RTN","TMGRPC3",551,0)
1368 . ;"The above sets Taskman job -->DEQUE^XUSERP--> --> D HL7^ALPBGEN
1369"RTN","TMGRPC3",552,0)
1370
1371"RTN","TMGRPC3",553,0)
1372 if $data(InactUser) do ;"Finish up inactivating user with VistA code
1373"RTN","TMGRPC3",554,0)
1374 . new result
1375"RTN","TMGRPC3",555,0)
1376 . set result=$$QtTermUser(InactUser("DA")) ;"finish termination of user code
1377"RTN","TMGRPC3",556,0)
1378 . if +result'=0 do
1379"RTN","TMGRPC3",557,0)
1380 . . set OutArray(0)="-1^See Fileman message re terminating user"
1381"RTN","TMGRPC3",558,0)
1382 . . set OutArray(1)=OutArray(1)_";"_result
1383"RTN","TMGRPC3",559,0)
1384
1385"RTN","TMGRPC3",560,0)
1386 if $data(ReactUser) do ;"finish up reactivating user with VistA code
1387"RTN","TMGRPC3",561,0)
1388 . new result
1389"RTN","TMGRPC3",562,0)
1390 . set result=$$QtReactUser(ReactUser("DA")) ;"launch quiet reactivation code
1391"RTN","TMGRPC3",563,0)
1392 . if +result'=0 do
1393"RTN","TMGRPC3",564,0)
1394 . . set OutArray(0)="-1^See Fileman message re reactivating user"
1395"RTN","TMGRPC3",565,0)
1396 . . set OutArray(1)=OutArray(1)_";"_result
1397"RTN","TMGRPC3",566,0)
1398
1399"RTN","TMGRPC3",567,0)
1400 quit
1401"RTN","TMGRPC3",568,0)
1402
1403"RTN","TMGRPC3",569,0)
1404
1405"RTN","TMGRPC3",570,0)
1406QtTermUser(XUDA)
1407"RTN","TMGRPC3",571,0)
1408 ;"Purpose: to quietly inactive a given user
1409"RTN","TMGRPC3",572,0)
1410 ;" I traced through menu option XUSERDEACT --> XUSTERM to create below
1411"RTN","TMGRPC3",573,0)
1412 ;"Input: XUDA -- the IEN in 200 of user to inactivate
1413"RTN","TMGRPC3",574,0)
1414 ;"Note: based on code from XUSTERM
1415"RTN","TMGRPC3",575,0)
1416 ;"Results: 0 = OK, or 1^message if error
1417"RTN","TMGRPC3",576,0)
1418
1419"RTN","TMGRPC3",577,0)
1420 new result set result=0
1421"RTN","TMGRPC3",578,0)
1422 new TMGFDA,TMGMSG,XUDT,DIC
1423"RTN","TMGRPC3",579,0)
1424 set TMGFDA(200,+XUDA_",",9.2)="NOW"
1425"RTN","TMGRPC3",580,0)
1426 do FILE^DIE("EK","TMGFDA","TMGMSG")
1427"RTN","TMGRPC3",581,0)
1428 if $data(TMGMSG("DIERR")) do goto QTUDone
1429"RTN","TMGRPC3",582,0)
1430 . set result="1^"_$$GetErrStr(.TMGMSG)_";"_$get(OutArray(1))
1431"RTN","TMGRPC3",583,0)
1432 set XUDT=$P(^VA(200,+XUDA,0),"^",11) ;" field 9.2 termination date
1433"RTN","TMGRPC3",584,0)
1434 do GET^XUSTERM ;"load up info about mail, mailboxes, keys ? needed ?
1435"RTN","TMGRPC3",585,0)
1436 set ZTDTH=XUDT ;"Task Start time. VA FileMan or $HOROLOG format
1437"RTN","TMGRPC3",586,0)
1438 set ZTRTN="DQ1^XUSTERM1" ;"routine to be fired
1439"RTN","TMGRPC3",587,0)
1440 set ZTDESC="DEACTIVATE USER" ;"description
1441"RTN","TMGRPC3",588,0)
1442 set ZTSAVE("XUDA")="" ;"save variable XUDA for use in task
1443"RTN","TMGRPC3",589,0)
1444 set ZTIO="" ;"no IO device needed
1445"RTN","TMGRPC3",590,0)
1446 do ^%ZTLOAD ;"que a taskman task
1447"RTN","TMGRPC3",591,0)
1448QTUDone
1449"RTN","TMGRPC3",592,0)
1450 quit result
1451"RTN","TMGRPC3",593,0)
1452
1453"RTN","TMGRPC3",594,0)
1454
1455"RTN","TMGRPC3",595,0)
1456QtReactUser(TMGDA)
1457"RTN","TMGRPC3",596,0)
1458 ;"Purpose: launch quiet reactivation code
1459"RTN","TMGRPC3",597,0)
1460 ;" I traced through menu option XUSERREACT --> REACT^XUSERNEW to create below
1461"RTN","TMGRPC3",598,0)
1462 ;"Input: TMGDA -- the IEN in 200 to be reactivated
1463"RTN","TMGRPC3",599,0)
1464 ;"Results: 0 if OK, or 1^ErrMsg
1465"RTN","TMGRPC3",600,0)
1466 ;"NOTE: when user is deleated through VistA code, the access and verify codes
1467"RTN","TMGRPC3",601,0)
1468 ;" are deleted. This function does NOT replace these.
1469"RTN","TMGRPC3",602,0)
1470
1471"RTN","TMGRPC3",603,0)
1472 new result set result=0
1473"RTN","TMGRPC3",604,0)
1474 new TMGFDA,TMGMSG,DIC
1475"RTN","TMGRPC3",605,0)
1476 set TMGFDA(200,TMGDA_",",9.2)="@" ;"Clear the Termination date
1477"RTN","TMGRPC3",606,0)
1478 do FILE^DIE("EK","TMGFDA","TMGMSG") ;"Post data
1479"RTN","TMGRPC3",607,0)
1480 if $data(TMGMSG("DIERR")) do goto QRUDone
1481"RTN","TMGRPC3",608,0)
1482 . set result="1^"_$$GetErrStr(.TMGMSG)
1483"RTN","TMGRPC3",609,0)
1484
1485"RTN","TMGRPC3",610,0)
1486 K XMZ ;" if null, then user can access old mail.
1487"RTN","TMGRPC3",611,0)
1488 S Y=TMGDA ;"set user to work on.
1489"RTN","TMGRPC3",612,0)
1490 D NEW^XM ;"mailman driver -- create a mailbox for user Y
1491"RTN","TMGRPC3",613,0)
1492
1493"RTN","TMGRPC3",614,0)
1494 if +$piece($get(^VA(200,TMGDA,201)),"^",1)'>0 do ;"201;1 = PRIMARY MENU OPTION (#201)
1495"RTN","TMGRPC3",615,0)
1496 . set TMGFDA(200,TMGDA_",",201)="EVE" ;"set default primary menu to EVE (high level!)
1497"RTN","TMGRPC3",616,0)
1498 . do FILE^DIE("EK","TMGFDA","TMGMSG")
1499"RTN","TMGRPC3",617,0)
1500 . if $data(TMGMSG("DIERR")) do
1501"RTN","TMGRPC3",618,0)
1502 . . set result="1^"_$$GetErrStr(.TMGMSG)
1503"RTN","TMGRPC3",619,0)
1504 if +result>0 goto QRUDone
1505"RTN","TMGRPC3",620,0)
1506
1507"RTN","TMGRPC3",621,0)
1508 K XMDT,XMM,XMZ
1509"RTN","TMGRPC3",622,0)
1510 D REACT^XQ84(TMGDA) ;"See if this user's menu trees need to be rebuilt
1511"RTN","TMGRPC3",623,0)
1512QRUDone
1513"RTN","TMGRPC3",624,0)
1514 Q result
1515"RTN","TMGRPC3",625,0)
1516
1517"RTN","TMGRPC3",626,0)
1518
1519"RTN","TMGRPC3",627,0)
1520GetEmptyEntry(OutArray,params)
1521"RTN","TMGRPC3",628,0)
1522 ;"Purpose: to get stub entries for a file (typically a subfile)
1523"RTN","TMGRPC3",629,0)
1524 ;" "GET EMPTY ENTRY" -- getting stub entries for subfiles typically
1525"RTN","TMGRPC3",630,0)
1526 ;" params: file entry (file or subfile number)
1527"RTN","TMGRPC3",631,0)
1528 ;"Input: OutArray --an OUT ARRAY, filled as follows:
1529"RTN","TMGRPC3",632,0)
1530 ;" OutArray(0)="1^Success" or "-1^Message"
1531"RTN","TMGRPC3",633,0)
1532 ;" OutArray(1)=File^^FieldNum^^DDInfo...
1533"RTN","TMGRPC3",634,0)
1534 ;" OutArray(2)=File^^FieldNum^^DDInfo...
1535"RTN","TMGRPC3",635,0)
1536 ;" Etc ...
1537"RTN","TMGRPC3",636,0)
1538 ;" Params: filenumber (typically a subfilenumber)
1539"RTN","TMGRPC3",637,0)
1540 ;"Result: None
1541"RTN","TMGRPC3",638,0)
1542
1543"RTN","TMGRPC3",639,0)
1544 set OutArray(0)="1^Success"
1545"RTN","TMGRPC3",640,0)
1546 new count set count=1
1547"RTN","TMGRPC3",641,0)
1548 new fileNum set fileNum=+$get(params)
1549"RTN","TMGRPC3",642,0)
1550 new fieldNum set fieldNum=0
1551"RTN","TMGRPC3",643,0)
1552 for set fieldNum=$order(^DD(fileNum,fieldNum)) quit:(+fieldNum'>0) do
1553"RTN","TMGRPC3",644,0)
1554 . new DDInfo set DDInfo=$piece($get(^DD(fileNum,fieldNum,0)),"^",1,4)
1555"RTN","TMGRPC3",645,0)
1556 . set OutArray(count)=fileNum_"^^"_fieldNum_"^^"_DDInfo
1557"RTN","TMGRPC3",646,0)
1558 . set count=count+1
1559"RTN","TMGRPC3",647,0)
1560
1561"RTN","TMGRPC3",648,0)
1562 quit
1563"RTN","TMGRPC3",649,0)
1564
1565"RTN","TMGRPC3",650,0)
1566
1567"RTN","TMGRPC3",651,0)
1568CloneUser(OutArray,params)
1569"RTN","TMGRPC3",652,0)
1570 ;"Purpose: to replicate a record into a new record, including all subrecs.
1571"RTN","TMGRPC3",653,0)
1572 ;" Implementation of "CLONE RECORD" request
1573"RTN","TMGRPC3",654,0)
1574 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1575"RTN","TMGRPC3",655,0)
1576 ;" params -- SourceIENS^New.01Value
1577"RTN","TMGRPC3",656,0)
1578 ;" FileNum - filename file that is to be worked in
1579"RTN","TMGRPC3",657,0)
1580 ;" SourceIENS -- source IENS for new record, (i.e. '123,' not '123')
1581"RTN","TMGRPC3",658,0)
1582 ;" New.01Value -- new value to be put into the .01 field (to distinguish it from the old record)
1583"RTN","TMGRPC3",659,0)
1584 ;"Output: OutArray is filled as follows:
1585"RTN","TMGRPC3",660,0)
1586 ;" OutArray(0)="1^Success^NewIENS" or "-1^Message"
1587"RTN","TMGRPC3",661,0)
1588 ;" OutArray(1)=Long Fileman message (if -1 error)
1589"RTN","TMGRPC3",662,0)
1590
1591"RTN","TMGRPC3",663,0)
1592 set params="200^"_params
1593"RTN","TMGRPC3",664,0)
1594 do CloneRecord(.OutArray,params)
1595"RTN","TMGRPC3",665,0)
1596 new TMGFDA,TMGMSG
1597"RTN","TMGRPC3",666,0)
1598 if +OutArray(0)'=1 goto CUDone
1599"RTN","TMGRPC3",667,0)
1600 new newIEN,newIENS
1601"RTN","TMGRPC3",668,0)
1602 set newIEN=+$piece(OutArray(0),"^",3)
1603"RTN","TMGRPC3",669,0)
1604 if newIEN="" do goto CUDone
1605"RTN","TMGRPC3",670,0)
1606 . set OutArray(0)="-1^Can't find IEN of added record"
1607"RTN","TMGRPC3",671,0)
1608
1609"RTN","TMGRPC3",672,0)
1610 ;"Set new user to inactive (needs editing before it is active)
1611"RTN","TMGRPC3",673,0)
1612 new data
1613"RTN","TMGRPC3",674,0)
1614 set data(0)="200^"_newIEN_",^7^^YES"
1615"RTN","TMGRPC3",675,0)
1616 do PostData(.OutArray,.data,"E")
1617"RTN","TMGRPC3",676,0)
1618 if +OutArray(0)=1 set $piece(OutArray(0),"^",3)=newIEN
1619"RTN","TMGRPC3",677,0)
1620
1621"RTN","TMGRPC3",678,0)
1622CUDone
1623"RTN","TMGRPC3",679,0)
1624 quit
1625"RTN","TMGRPC3",680,0)
1626
1627"RTN","TMGRPC3",681,0)
1628CloneRecord(OutArray,params)
1629"RTN","TMGRPC3",682,0)
1630 ;"Purpose: to replicate a record into a new record, including all subrecs.
1631"RTN","TMGRPC3",683,0)
1632 ;" Implementation of "CLONE RECORD" request
1633"RTN","TMGRPC3",684,0)
1634 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1635"RTN","TMGRPC3",685,0)
1636 ;" params -- FileNum^SourceIENS^New.01Value
1637"RTN","TMGRPC3",686,0)
1638 ;" FileNum - filename file that is to be worked in
1639"RTN","TMGRPC3",687,0)
1640 ;" SourceIENS -- the source IENS for the new record, (i.e. 123, not 123)
1641"RTN","TMGRPC3",688,0)
1642 ;" New.01Value -- the new value to be put into the .01 field (to distinguish it from the old record)
1643"RTN","TMGRPC3",689,0)
1644 ;"Output: OutArray is filled as follows:
1645"RTN","TMGRPC3",690,0)
1646 ;" OutArray(0)="1^Success^NewIENS" or "-1^Message"
1647"RTN","TMGRPC3",691,0)
1648 ;" OutArray(1)=Long Fileman message (if -1 error)
1649"RTN","TMGRPC3",692,0)
1650 ;"NOTE: This hasn't been tested on subfiles yet...
1651"RTN","TMGRPC3",693,0)
1652
1653"RTN","TMGRPC3",694,0)
1654 new File,IENS,new01Value
1655"RTN","TMGRPC3",695,0)
1656 set OutArray(0)="-1^Error" ;"default to error
1657"RTN","TMGRPC3",696,0)
1658
1659"RTN","TMGRPC3",697,0)
1660 set File=+$piece(params,"^",1)
1661"RTN","TMGRPC3",698,0)
1662 if File'>0 do goto CRDone
1663"RTN","TMGRPC3",699,0)
1664 . set OutArray(0)="-1^No file number supplied"
1665"RTN","TMGRPC3",700,0)
1666 set IENS=$piece(params,"^",2)
1667"RTN","TMGRPC3",701,0)
1668 if IENS="" do goto CRDone
1669"RTN","TMGRPC3",702,0)
1670 . set OutArray(0)="-1^IENS supplied"
1671"RTN","TMGRPC3",703,0)
1672 if +IENS=IENS do
1673"RTN","TMGRPC3",704,0)
1674 . if IENS'["," set IENS=IENS_","
1675"RTN","TMGRPC3",705,0)
1676 set new01Value=$piece(params,"^",3)
1677"RTN","TMGRPC3",706,0)
1678 if new01Value="" do goto CRDone
1679"RTN","TMGRPC3",707,0)
1680 . set OutArray(0)="-1^No new value supplied for .01 value"
1681"RTN","TMGRPC3",708,0)
1682
1683"RTN","TMGRPC3",709,0)
1684 new oldRec,TMGARRAY,TMGMSG,TMGTEMP
1685"RTN","TMGRPC3",710,0)
1686 new ref set ref="TMGARRAY"
1687"RTN","TMGRPC3",711,0)
1688
1689"RTN","TMGRPC3",712,0)
1690 do StubNewRecord(File,new01Value,.OutArray)
1691"RTN","TMGRPC3",713,0)
1692 if +OutArray(0)'=1 do goto CRDone
1693"RTN","TMGRPC3",714,0)
1694 . set $piece(OutArray(0),"^",2)="Unable to stub in new record. "_$piece(OutArray(0),"^",2)
1695"RTN","TMGRPC3",715,0)
1696 new newIEN set newIEN=$piece(OutArray(0),"^",3)
1697"RTN","TMGRPC3",716,0)
1698 ;"Write "The IENS of the new record is: ",newIEN,! ;"TEMP!!!
1699"RTN","TMGRPC3",717,0)
1700
1701"RTN","TMGRPC3",718,0)
1702 ;"Note: Using a "X" flag is VERY slow, because it reindexes
1703"RTN","TMGRPC3",719,0)
1704 ;" ALL XREFS for ALL entries in file (e.g. 60 seconds)
1705"RTN","TMGRPC3",720,0)
1706 ;"do TRNMRG^TMGDIT("M",File,File,IENS,newIEN_",") ;"do actual record copy.
1707"RTN","TMGRPC3",721,0)
1708 do TRNMRG^DIT("M",File,File,IENS,newIEN_",") ;"do actual record copy.
1709"RTN","TMGRPC3",722,0)
1710 new DA,DIK
1711"RTN","TMGRPC3",723,0)
1712 set DIK=$get(^DIC(File,0,"GL"))
1713"RTN","TMGRPC3",724,0)
1714 set DA=newIEN
1715"RTN","TMGRPC3",725,0)
1716 if (+DA>0)&(DIK'="") do IX1^DIK ;"index just the new record
1717"RTN","TMGRPC3",726,0)
1718
1719"RTN","TMGRPC3",727,0)
1720 ;"OK if we got this far (can't check error from TRNMRG)
1721"RTN","TMGRPC3",728,0)
1722 set OutArray(0)="1^Success^"_newIEN
1723"RTN","TMGRPC3",729,0)
1724
1725"RTN","TMGRPC3",730,0)
1726CRDone quit
1727"RTN","TMGRPC3",731,0)
1728
1729"RTN","TMGRPC3",732,0)
1730
1731"RTN","TMGRPC3",733,0)
1732GetHelpMsg(OutArray,param)
1733"RTN","TMGRPC3",734,0)
1734 ;"Purpose: to retrieve the help message for a given field.
1735"RTN","TMGRPC3",735,0)
1736 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1737"RTN","TMGRPC3",736,0)
1738 ;" param -- file^field^HelpType
1739"RTN","TMGRPC3",737,0)
1740 ;"Output: OutArray is filled as follows:
1741"RTN","TMGRPC3",738,0)
1742 ;" OutArray(0)="1^Success" or "-1^Message"
1743"RTN","TMGRPC3",739,0)
1744 ;" OutArray(1...?)=Help Message
1745"RTN","TMGRPC3",740,0)
1746
1747"RTN","TMGRPC3",741,0)
1748 new TMGMSG
1749"RTN","TMGRPC3",742,0)
1750 new index set index=1
1751"RTN","TMGRPC3",743,0)
1752 new File set File=+$piece(params,"^",1)
1753"RTN","TMGRPC3",744,0)
1754 new Field set Field=+$piece(params,"^",2)
1755"RTN","TMGRPC3",745,0)
1756 new HelpType set HelpType=$piece(params,"^",3)
1757"RTN","TMGRPC3",746,0)
1758 if File'>0 do goto GHMDone
1759"RTN","TMGRPC3",747,0)
1760 . set OutArray(0)="-1^No file number supplied"
1761"RTN","TMGRPC3",748,0)
1762 if Field'>0 do goto GHMDone
1763"RTN","TMGRPC3",749,0)
1764 . set OutArray(0)="-1^No Field Number supplied"
1765"RTN","TMGRPC3",750,0)
1766 do HELP^DIE(File,,Field,HelpType,"TMGMSG")
1767"RTN","TMGRPC3",751,0)
1768 set i=""
1769"RTN","TMGRPC3",752,0)
1770 for set i=$order(TMGMSG("DIHELP",i)) quit:(i="") do
1771"RTN","TMGRPC3",753,0)
1772 . set OutArray(index)=TMGMSG("DIHELP",i)
1773"RTN","TMGRPC3",754,0)
1774 . set index=index+1
1775"RTN","TMGRPC3",755,0)
1776
1777"RTN","TMGRPC3",756,0)
1778 set OutArray(0)="1^Success"
1779"RTN","TMGRPC3",757,0)
1780
1781"RTN","TMGRPC3",758,0)
1782GHMDone
1783"RTN","TMGRPC3",759,0)
1784 quit
1785"RTN","TMGRPC3",760,0)
1786
1787"RTN","TMGRPC3",761,0)
1788
1789"RTN","TMGRPC3",762,0)
1790StubNewRecord(File,NewValue,OutArray)
1791"RTN","TMGRPC3",763,0)
1792 ;"Purpose: to create a stub entry in the file (200), to be filled in elsewhere
1793"RTN","TMGRPC3",764,0)
1794 ;"Input: NewValue -- a value for the .01 field
1795"RTN","TMGRPC3",765,0)
1796 ;" OutArray -- PASS BY REFERENCE, an OUT PARAMETER.
1797"RTN","TMGRPC3",766,0)
1798 ;"Output: A new record will be added to file, if no errors
1799"RTN","TMGRPC3",767,0)
1800 ;" OutArray(0): 1^Success^NewIEN or -1^See Fileman message
1801"RTN","TMGRPC3",768,0)
1802 ;" OutArray(1) will contain Fileman error, if any
1803"RTN","TMGRPC3",769,0)
1804 ;"Results: none
1805"RTN","TMGRPC3",770,0)
1806 ;"NOTICE: This function makes no promise that the creation of the
1807"RTN","TMGRPC3",771,0)
1808 ;" new record will succeed. For example, if there are required
1809"RTN","TMGRPC3",772,0)
1810 ;" fields, the creation will fail. So users should check for success
1811"RTN","TMGRPC3",773,0)
1812 ;" result and error feedback.
1813"RTN","TMGRPC3",774,0)
1814 ;"Results: none
1815"RTN","TMGRPC3",775,0)
1816
1817"RTN","TMGRPC3",776,0)
1818 new TMGFDA,TMGIEN,TMGMSG,DIC
1819"RTN","TMGRPC3",777,0)
1820 set DIC(0)="" ;"I get a crash without this, for some reason...
1821"RTN","TMGRPC3",778,0)
1822 set TMGFDA(File,"+1,",.01)=NewValue
1823"RTN","TMGRPC3",779,0)
1824 do UPDATE^DIE("S","TMGFDA","TMGIEN","TMGMSG")
1825"RTN","TMGRPC3",780,0)
1826
1827"RTN","TMGRPC3",781,0)
1828 if $data(TMGMSG("DIERR")) do goto SNPDone
1829"RTN","TMGRPC3",782,0)
1830 . set OutArray(0)="-1^See Fileman message"
1831"RTN","TMGRPC3",783,0)
1832 . set OutArray(1)=$$GetErrStr(.TMGMSG)
1833"RTN","TMGRPC3",784,0)
1834
1835"RTN","TMGRPC3",785,0)
1836 set OutArray(0)="1^Success^"_$get(TMGIEN(1))
1837"RTN","TMGRPC3",786,0)
1838
1839"RTN","TMGRPC3",787,0)
1840SNPDone
1841"RTN","TMGRPC3",788,0)
1842 quit
1843"RTN","TMGRPC3",789,0)
1844
1845"RTN","TMGRPC3",790,0)
1846
1847"RTN","TMGRPC3",791,0)
1848GetIfWPField(OutArray,params)
1849"RTN","TMGRPC3",792,0)
1850 ;"Purpose: to return if filenumber is a WP subfile
1851"RTN","TMGRPC3",793,0)
1852 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1853"RTN","TMGRPC3",794,0)
1854 ;" param -- file^field
1855"RTN","TMGRPC3",795,0)
1856 ;"Output:
1857"RTN","TMGRPC3",796,0)
1858 ;" OutArray(0): "1^Success^YES/NO" or "-1^Message"
1859"RTN","TMGRPC3",797,0)
1860 ;" "YES" if is a WP subfile, otherwise "NO"
1861"RTN","TMGRPC3",798,0)
1862 ;" OutArray(1) will contain Fileman error, if any
1863"RTN","TMGRPC3",799,0)
1864 ;"Results: none
1865"RTN","TMGRPC3",800,0)
1866
1867"RTN","TMGRPC3",801,0)
1868 new result
1869"RTN","TMGRPC3",802,0)
1870 new File set File=+$piece(params,"^",1)
1871"RTN","TMGRPC3",803,0)
1872 new Field set Field=+$piece(params,"^",2)
1873"RTN","TMGRPC3",804,0)
1874 if File'>0 do goto GWPSDone
1875"RTN","TMGRPC3",805,0)
1876 . set OutArray(0)="-1^No file number supplied"
1877"RTN","TMGRPC3",806,0)
1878 if Field'>0 do goto GWPSDone
1879"RTN","TMGRPC3",807,0)
1880 . set OutArray(0)="-1^No Field Number supplied"
1881"RTN","TMGRPC3",808,0)
1882
1883"RTN","TMGRPC3",809,0)
1884 do FIELD^DID(File,Field,"","TYPE","TMGARRAY","TMGMSG")
1885"RTN","TMGRPC3",810,0)
1886
1887"RTN","TMGRPC3",811,0)
1888 if $data(TMGMSG("DIERR")) do goto GWPSDone
1889"RTN","TMGRPC3",812,0)
1890 . set OutArray(0)="-1^See Fileman message"
1891"RTN","TMGRPC3",813,0)
1892 . set OutArray(1)=$$GetErrStr(.TMGMSG)
1893"RTN","TMGRPC3",814,0)
1894
1895"RTN","TMGRPC3",815,0)
1896 if $get(TMGARRAY("TYPE"))="WORD-PROCESSING" do
1897"RTN","TMGRPC3",816,0)
1898 . set result="YES"
1899"RTN","TMGRPC3",817,0)
1900 else do
1901"RTN","TMGRPC3",818,0)
1902 . set result="NO"
1903"RTN","TMGRPC3",819,0)
1904
1905"RTN","TMGRPC3",820,0)
1906 set OutArray(0)="1^Success^"_result
1907"RTN","TMGRPC3",821,0)
1908
1909"RTN","TMGRPC3",822,0)
1910GWPSDone
1911"RTN","TMGRPC3",823,0)
1912 quit
1913"RTN","TMGRPC3",824,0)
1914
1915"RTN","TMGRPC3",825,0)
1916
1917"RTN","TMGRPC3",826,0)
1918GetWPField(OutArray,params)
1919"RTN","TMGRPC3",827,0)
1920 ;"Purpose: To retrieve on word processing (WP) field entry
1921"RTN","TMGRPC3",828,0)
1922 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
1923"RTN","TMGRPC3",829,0)
1924 ;" param -- FileNum^Field^IENS (e.g. 'GET ONE WP FIELD^200^73,')
1925"RTN","TMGRPC3",830,0)
1926 ;"Output:
1927"RTN","TMGRPC3",831,0)
1928 ;" OutArray(0): "1^Success" or "-1^Message"
1929"RTN","TMGRPC3",832,0)
1930 ;" OutArray(1) will contain Fileman error, if any
1931"RTN","TMGRPC3",833,0)
1932 ;" - or to return WP array -
1933"RTN","TMGRPC3",834,0)
1934 ;" OutArray(1)=1st line of text
1935"RTN","TMGRPC3",835,0)
1936 ;" OutArray(2)=2nd line of text
1937"RTN","TMGRPC3",836,0)
1938 ;" etc..
1939"RTN","TMGRPC3",837,0)
1940 ;"Results: None
1941"RTN","TMGRPC3",838,0)
1942
1943"RTN","TMGRPC3",839,0)
1944 new File set File=+$piece(params,"^",1)
1945"RTN","TMGRPC3",840,0)
1946 new Field set Field=+$piece(params,"^",2)
1947"RTN","TMGRPC3",841,0)
1948 new IENS set IENS=+$piece(params,"^",3)
1949"RTN","TMGRPC3",842,0)
1950 if File'>0 do goto GWPDone
1951"RTN","TMGRPC3",843,0)
1952 . set OutArray(0)="-1^No file number supplied"
1953"RTN","TMGRPC3",844,0)
1954 if Field'>0 do goto GWPDone
1955"RTN","TMGRPC3",845,0)
1956 . set OutArray(0)="-1^No Field Number supplied"
1957"RTN","TMGRPC3",846,0)
1958 if IENS="" do goto GWPDone
1959"RTN","TMGRPC3",847,0)
1960 . set OutArray(0)="-1^No IENS supplied"
1961"RTN","TMGRPC3",848,0)
1962
1963"RTN","TMGRPC3",849,0)
1964 new temp
1965"RTN","TMGRPC3",850,0)
1966 set temp=$$GET1^DIQ(File,IENS,Field,"","TMGARRAY","TMGMSG")
1967"RTN","TMGRPC3",851,0)
1968 if $data(TMGMSG("DIERR")) do goto GWPDone
1969"RTN","TMGRPC3",852,0)
1970 . set OutArray(0)="-1^See Fileman message"
1971"RTN","TMGRPC3",853,0)
1972 . set OutArray(1)=$$GetErrStr(.TMGMSG)
1973"RTN","TMGRPC3",854,0)
1974
1975"RTN","TMGRPC3",855,0)
1976 set OutArray(0)="1^Success"
1977"RTN","TMGRPC3",856,0)
1978 new index,i
1979"RTN","TMGRPC3",857,0)
1980 set i=0
1981"RTN","TMGRPC3",858,0)
1982 set index=1
1983"RTN","TMGRPC3",859,0)
1984 for set i=$order(TMGARRAY(i)) quit:(i="") do
1985"RTN","TMGRPC3",860,0)
1986 . set OutArray(index)=TMGARRAY(i)
1987"RTN","TMGRPC3",861,0)
1988 . set index=index+1
1989"RTN","TMGRPC3",862,0)
1990
1991"RTN","TMGRPC3",863,0)
1992GWPDone
1993"RTN","TMGRPC3",864,0)
1994 quit
1995"RTN","TMGRPC3",865,0)
1996
1997"RTN","TMGRPC3",866,0)
1998
1999"RTN","TMGRPC3",867,0)
2000PostWPField(OutArray,params,INPUT)
2001"RTN","TMGRPC3",868,0)
2002 ;"Purpose: To store a word processing (WP) field entry
2003"RTN","TMGRPC3",869,0)
2004 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
2005"RTN","TMGRPC3",870,0)
2006 ;" param -- FileNum^FieldNum^IENS (e.g. 'GET ONE WP FIELD^200^73,')
2007"RTN","TMGRPC3",871,0)
2008 ;" INPUT -- holds the WP itself to be stored:
2009"RTN","TMGRPC3",872,0)
2010 ;" INPUT(0)=0TH line
2011"RTN","TMGRPC3",873,0)
2012 ;" INPUT(1)=1st line
2013"RTN","TMGRPC3",874,0)
2014 ;" INPUT(2)=2nd line
2015"RTN","TMGRPC3",875,0)
2016 ;" ...
2017"RTN","TMGRPC3",876,0)
2018 ;"Output:
2019"RTN","TMGRPC3",877,0)
2020 ;" OutArray(0): "1^Success" or "-1^Message"
2021"RTN","TMGRPC3",878,0)
2022 ;" OutArray(1) will contain Fileman error, if any
2023"RTN","TMGRPC3",879,0)
2024 ;"Results: None
2025"RTN","TMGRPC3",880,0)
2026
2027"RTN","TMGRPC3",881,0)
2028 new File set File=+$piece(params,"^",1)
2029"RTN","TMGRPC3",882,0)
2030 new Field set Field=+$piece(params,"^",2)
2031"RTN","TMGRPC3",883,0)
2032 new IENS set IENS=+$piece(params,"^",3)
2033"RTN","TMGRPC3",884,0)
2034 if File'>0 do goto PWPDone
2035"RTN","TMGRPC3",885,0)
2036 . set OutArray(0)="-1^No file number supplied"
2037"RTN","TMGRPC3",886,0)
2038 if Field'>0 do goto PWPDone
2039"RTN","TMGRPC3",887,0)
2040 . set OutArray(0)="-1^No Field Number supplied"
2041"RTN","TMGRPC3",888,0)
2042 if IENS="" do goto PWPDone
2043"RTN","TMGRPC3",889,0)
2044 . set OutArray(0)="-1^No IENS supplied"
2045"RTN","TMGRPC3",890,0)
2046 if $length(IENS,",")=1 set IENS=IENS_","
2047"RTN","TMGRPC3",891,0)
2048
2049"RTN","TMGRPC3",892,0)
2050 do WP^DIE(File,IENS,Field,"K","INPUT","TMGMSG")
2051"RTN","TMGRPC3",893,0)
2052
2053"RTN","TMGRPC3",894,0)
2054 if $data(TMGMSG("DIERR")) do goto GWPDone
2055"RTN","TMGRPC3",895,0)
2056 . set OutArray(0)="-1^See Fileman message"
2057"RTN","TMGRPC3",896,0)
2058 . set OutArray(1)=$$GetErrStr(.TMGMSG)
2059"RTN","TMGRPC3",897,0)
2060
2061"RTN","TMGRPC3",898,0)
2062 set OutArray(0)="1^Success"
2063"RTN","TMGRPC3",899,0)
2064
2065"RTN","TMGRPC3",900,0)
2066PWPDone
2067"RTN","TMGRPC3",901,0)
2068 quit
2069"RTN","TMGRPC3",902,0)
2070
2071"RTN","TMGRPC3",903,0)
2072
2073"RTN","TMGRPC3",904,0)
2074RegPatient(OutArray,params)
2075"RTN","TMGRPC3",905,0)
2076 ;"Purpose: to register a new patient into VistA, providing that they have not
2077"RTN","TMGRPC3",906,0)
2078 ;" already been registered.
2079"RTN","TMGRPC3",907,0)
2080 ;"Note: The search for preexisting records is exact, meaning that DOE,JOHN
2081"RTN","TMGRPC3",908,0)
2082 ;" would be considered different from DOE,JOHN H
2083"RTN","TMGRPC3",909,0)
2084 ;"Input: OutArray -- an OUT PARAMETER, PASS BY REFERENCE.
2085"RTN","TMGRPC3",910,0)
2086 ;" param -- FieldNum1^FieldValue1^FieldNum2^FieldValue2^FieldNum3^FieldValue3^...
2087"RTN","TMGRPC3",911,0)
2088 ;" NOTE: Because I want to be able to specify here the HealthRecordNumber (HRN),
2089"RTN","TMGRPC3",912,0)
2090 ;" even though it is not truly a field in the PATIENT file, I am going
2091"RTN","TMGRPC3",913,0)
2092 ;" to manually allow a field of '0' (HRN) to be specified as a FieldNumber
2093"RTN","TMGRPC3",914,0)
2094 ;"Output: OutArray is filled as follows:
2095"RTN","TMGRPC3",915,0)
2096 ;" OutArray(0)="1^Success^NewIEN" or "-1^Message"
2097"RTN","TMGRPC3",916,0)
2098 ;" OutArray(1)=Long Fileman message (if -1 error)
2099"RTN","TMGRPC3",917,0)
2100
2101"RTN","TMGRPC3",918,0)
2102 new array
2103"RTN","TMGRPC3",919,0)
2104 for do quit:($length(params,"^"))<2
2105"RTN","TMGRPC3",920,0)
2106 . new pair,field,value
2107"RTN","TMGRPC3",921,0)
2108 . set pair=$piece(params,"^",1,2)
2109"RTN","TMGRPC3",922,0)
2110 . set field=$piece(pair,"^",1)
2111"RTN","TMGRPC3",923,0)
2112 . set value=$piece(pair,"^",2)
2113"RTN","TMGRPC3",924,0)
2114 . set params=$extract(params,$length(pair)+2,999)
2115"RTN","TMGRPC3",925,0)
2116 . if (field="")!(value="") quit
2117"RTN","TMGRPC3",926,0)
2118 . set array(field)=value
2119"RTN","TMGRPC3",927,0)
2120
2121"RTN","TMGRPC3",928,0)
2122 new IEN set IEN=$$SrchPtExact(.array)
2123"RTN","TMGRPC3",929,0)
2124 if +IEN>0 do goto RPtDone
2125"RTN","TMGRPC3",930,0)
2126 . set OutArray(0)="-1^Patient already registered^"_IEN
2127"RTN","TMGRPC3",931,0)
2128
2129"RTN","TMGRPC3",932,0)
2130 new TMGFDA,TMGMSG,TMGIEN
2131"RTN","TMGRPC3",933,0)
2132 if $get(array(.01))="" do goto RPtDone
2133"RTN","TMGRPC3",934,0)
2134 . set OutArray(0)="-1^Patient name (.01 field) missing"
2135"RTN","TMGRPC3",935,0)
2136 set TMGFDA(2,"+1,",.01)=array(.01)
2137"RTN","TMGRPC3",936,0)
2138 if $get(array(.02))="" do goto RPtDone
2139"RTN","TMGRPC3",937,0)
2140 . set OutArray(0)="-1^Patient sex (.02 field) missing"
2141"RTN","TMGRPC3",938,0)
2142 set TMGFDA(2,"+1,",.02)=array(.02)
2143"RTN","TMGRPC3",939,0)
2144 if $get(array(.03))="" do goto RPtDone
2145"RTN","TMGRPC3",940,0)
2146 . set OutArray(0)="-1^Patient DOB (.03 field) missing"
2147"RTN","TMGRPC3",941,0)
2148 set TMGFDA(2,"+1,",.03)=array(.03)
2149"RTN","TMGRPC3",942,0)
2150 if $get(array(.09))'="" do ;"let fileman decide if field is required
2151"RTN","TMGRPC3",943,0)
2152 . set TMGFDA(2,"+1,",.09)=array(.09)
2153"RTN","TMGRPC3",944,0)
2154
2155"RTN","TMGRPC3",945,0)
2156 ;"Create basic record first, then add other fields on subsequent post
2157"RTN","TMGRPC3",946,0)
2158 ;"(I think I have had problems trying to load some fields when the
2159"RTN","TMGRPC3",947,0)
2160 ;" record has not already been created.)
2161"RTN","TMGRPC3",948,0)
2162 do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG")
2163"RTN","TMGRPC3",949,0)
2164 if $data(TMGMSG("DIERR")) do goto RPtDone
2165"RTN","TMGRPC3",950,0)
2166 . set OutArray(0)="-1^See Fileman message"
2167"RTN","TMGRPC3",951,0)
2168 . set OutArray(1)=$$GetErrStr(.TMGMSG)
2169"RTN","TMGRPC3",952,0)
2170
2171"RTN","TMGRPC3",953,0)
2172 set IEN=$get(TMGIEN(1))
2173"RTN","TMGRPC3",954,0)
2174 if IEN'>0 do goto RPtDone
2175"RTN","TMGRPC3",955,0)
2176 . set OutArray(0)="-1^Unable to find IEN of added record"
2177"RTN","TMGRPC3",956,0)
2178
2179"RTN","TMGRPC3",957,0)
2180 new field set field=""
2181"RTN","TMGRPC3",958,0)
2182 kill TMGFDA,TMGIEN,TMGMSG
2183"RTN","TMGRPC3",959,0)
2184 for set field=$order(array(field)) quit:(field="") do
2185"RTN","TMGRPC3",960,0)
2186 . if (field=".01")!(field=".02")!(field=".03")!(field=".09")!(field="0") quit
2187"RTN","TMGRPC3",961,0)
2188 . new value set value=$get(array(field))
2189"RTN","TMGRPC3",962,0)
2190 . if value="" quit
2191"RTN","TMGRPC3",963,0)
2192 . set TMGFDA(2,IEN_",",field)=value
2193"RTN","TMGRPC3",964,0)
2194
2195"RTN","TMGRPC3",965,0)
2196 if $data(TMGFDA) do
2197"RTN","TMGRPC3",966,0)
2198 . do FILE^DIE("E","TMGFDA","TMGMSG")
2199"RTN","TMGRPC3",967,0)
2200 if $data(TMGMSG("DIERR")) do goto RPtDone
2201"RTN","TMGRPC3",968,0)
2202 . set OutArray(0)="-1^See Fileman message"
2203"RTN","TMGRPC3",969,0)
2204 . set OutArray(1)=$$GetErrStr(.TMGMSG)
2205"RTN","TMGRPC3",970,0)
2206
2207"RTN","TMGRPC3",971,0)
2208 set OutArray(0)="1^Success^"_IEN
2209"RTN","TMGRPC3",972,0)
2210
2211"RTN","TMGRPC3",973,0)
2212 new HRN set HRN=$get(array("0"))="" ;" pseudoField '0' from client will hold HRN
2213"RTN","TMGRPC3",974,0)
2214 if HRN="" goto RPtDone
2215"RTN","TMGRPC3",975,0)
2216 ;"Set HRN field in file 9000001 (^AUPNPAT), linked to Patient entry
2217"RTN","TMGRPC3",976,0)
2218
2219"RTN","TMGRPC3",977,0)
2220 new LocIEN,InstIEN
2221"RTN","TMGRPC3",978,0)
2222 ;"Get DEFAULT INSTITUTION from KERNEL SYSTEM PARAMETERS.
2223"RTN","TMGRPC3",979,0)
2224 set InstIEN=$piece($get(^XTV(8989.3,1,"XUS")),17) ;" XUS;17 = DEFAULT INSTITUTION
2225"RTN","TMGRPC3",980,0)
2226 if +InstIEN'>0 do goto RPtDone
2227"RTN","TMGRPC3",981,0)
2228 . set OutArray(0)="1^Success (but see message)^"_IEN
2229"RTN","TMGRPC3",982,0)
2230 . set OutArray(1)="Unable to add HRN because couldn't find value for DEFAULT INSTITUTION in KERNEL SYSTEM PARAMETERS file."
2231"RTN","TMGRPC3",983,0)
2232
2233"RTN","TMGRPC3",984,0)
2234 ;"Get LOCATION file entry pointing to this INSTITUTION
2235"RTN","TMGRPC3",985,0)
2236 set LocIEN=$order(^AUTTLOC("B",InstIEN,""))
2237"RTN","TMGRPC3",986,0)
2238 if +LocIEN'>0 do goto RPtDone
2239"RTN","TMGRPC3",987,0)
2240 . set OutArray(0)="1^Success (but see message)^"_IEN
2241"RTN","TMGRPC3",988,0)
2242 . set OutArray(1)="Unable to add HRN because couldn't find `"_InstIEN_" in LOCATION file"
2243"RTN","TMGRPC3",989,0)
2244
2245"RTN","TMGRPC3",990,0)
2246 new HRNIEN set HRNIEN=+$order(^AUNPNPAT("B",IEN,""))
2247"RTN","TMGRPC3",991,0)
2248 if HRNIEN'>0 do goto RPtDone
2249"RTN","TMGRPC3",992,0)
2250 . set OutArray(0)="1^Success (but see message)^"_IEN
2251"RTN","TMGRPC3",993,0)
2252 . set OutArray(1)="Unable to add HRN because couldn't find record in PATIENT/IHS file"
2253"RTN","TMGRPC3",994,0)
2254
2255"RTN","TMGRPC3",995,0)
2256 kill TMGFDA,TMGMSG,TMGIEN
2257"RTN","TMGRPC3",996,0)
2258 ;"Now see if there already is an entry for LocIEN (DINUM in play, so subFile record#=LocIEN)
2259"RTN","TMGRPC3",997,0)
2260 if $get(^AUPNPAT(HRNIEN,41,LocIEN,0))="" do
2261"RTN","TMGRPC3",998,0)
2262 . ;"Put HRN into value for current subfile entry
2263"RTN","TMGRPC3",999,0)
2264 . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.02)=HRN
2265"RTN","TMGRPC3",1000,0)
2266 . do FILE^DIE("","TMGFDA","TMGMSG")
2267"RTN","TMGRPC3",1001,0)
2268 . if $data(TMGMSG("DIERR")) do
2269"RTN","TMGRPC3",1002,0)
2270 . . set OutArray(0)="1^Success (but see message)^"_IEN
2271"RTN","TMGRPC3",1003,0)
2272 . . set OutArray(1)=$$GetErrStr(.TMGMSG)
2273"RTN","TMGRPC3",1004,0)
2274 else do
2275"RTN","TMGRPC3",1005,0)
2276 . ;"Add new subfile entry for HRN
2277"RTN","TMGRPC3",1006,0)
2278 . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.01)=LocIEN
2279"RTN","TMGRPC3",1007,0)
2280 . set TMGFDA(9000001.41,LocIEN_","_HRNIEN_",",.02)=HRN
2281"RTN","TMGRPC3",1008,0)
2282 . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG")
2283"RTN","TMGRPC3",1009,0)
2284 . if $data(TMGMSG("DIERR")) do
2285"RTN","TMGRPC3",1010,0)
2286 . . set OutArray(0)="1^Success (but see message)^"_IEN
2287"RTN","TMGRPC3",1011,0)
2288 . . set OutArray(1)=$$GetErrStr(.TMGMSG)
2289"RTN","TMGRPC3",1012,0)
2290
2291"RTN","TMGRPC3",1013,0)
2292RPtDone
2293"RTN","TMGRPC3",1014,0)
2294 quit
2295"RTN","TMGRPC3",1015,0)
2296
2297"RTN","TMGRPC3",1016,0)
2298SrchPtExact(Array)
2299"RTN","TMGRPC3",1017,0)
2300 ;"Purpose: to search for a preexisting patient, using an exact search
2301"RTN","TMGRPC3",1018,0)
2302 ;" By exact search, I mean that DOE,JOHN would be considered different
2303"RTN","TMGRPC3",1019,0)
2304 ;" from DOE,JOHN H because it is a different ascii string. Etc.
2305"RTN","TMGRPC3",1020,0)
2306 ;" However, see search description below.
2307"RTN","TMGRPC3",1021,0)
2308 ;"Input: Array -- PASS BY REFERENCE. Search info. Format:
2309"RTN","TMGRPC3",1022,0)
2310 ;" Array(.01)=PatientName, e.g. DOE,JOHN
2311"RTN","TMGRPC3",1023,0)
2312 ;" Array(.02)=Sex e.g. M
2313"RTN","TMGRPC3",1024,0)
2314 ;" Array(.03)=DOB e.g. 01-04-69 (an external date format)
2315"RTN","TMGRPC3",1025,0)
2316 ;" Array(.09)=SSNum e.g. 123-45-6789
2317"RTN","TMGRPC3",1026,0)
2318 ;"Result: returns DFN (patient IEN), or 0^Message if not found.
2319"RTN","TMGRPC3",1027,0)
2320 ;"Notes:
2321"RTN","TMGRPC3",1028,0)
2322 ;" The following are sufficient for search:
2323"RTN","TMGRPC3",1029,0)
2324 ;" -- SSNum only
2325"RTN","TMGRPC3",1030,0)
2326 ;" -- or Name-Sex-DOB
2327"RTN","TMGRPC3",1031,0)
2328
2329"RTN","TMGRPC3",1032,0)
2330 ;" Search technique:
2331"RTN","TMGRPC3",1033,0)
2332 ;" 1. Search for SSN, if found then no further comparison made.
2333"RTN","TMGRPC3",1034,0)
2334 ;" 2. Search for exact name match, no none found, then exit with 0
2335"RTN","TMGRPC3",1035,0)
2336 ;" 3. ...
2337"RTN","TMGRPC3",1036,0)
2338
2339"RTN","TMGRPC3",1037,0)
2340 new result set result=0
2341"RTN","TMGRPC3",1038,0)
2342
2343"RTN","TMGRPC3",1039,0)
2344 ;"Search by SSN. Quit if match found
2345"RTN","TMGRPC3",1040,0)
2346 new SSN set SSN=$translate($get(Array(.09)),"-","")
2347"RTN","TMGRPC3",1041,0)
2348 if SSN'="" set result=+$order(^DPT("SSN",SSN,""))
2349"RTN","TMGRPC3",1042,0)
2350 if result>0 goto PSEDone
2351"RTN","TMGRPC3",1043,0)
2352
2353"RTN","TMGRPC3",1044,0)
2354 new name,sex,DOB
2355"RTN","TMGRPC3",1045,0)
2356 set name=$get(Array(.01))
2357"RTN","TMGRPC3",1046,0)
2358 if name="" do goto PSEDone
2359"RTN","TMGRPC3",1047,0)
2360 . set result="0^No Name (.01 field) provided"
2361"RTN","TMGRPC3",1048,0)
2362
2363"RTN","TMGRPC3",1049,0)
2364 set sex=$get(Array(.02))
2365"RTN","TMGRPC3",1050,0)
2366 if sex="" do goto PSEDone
2367"RTN","TMGRPC3",1051,0)
2368 . set result="0^Sex (.02 field) not specified"
2369"RTN","TMGRPC3",1052,0)
2370 if (sex'="M")&(sex'="F") do goto PSEDone
2371"RTN","TMGRPC3",1053,0)
2372 . set result="0^Sex should be 'Y' or 'N'. Value provided="_sex
2373"RTN","TMGRPC3",1054,0)
2374
2375"RTN","TMGRPC3",1055,0)
2376 set DOB=$get(Array(.03))
2377"RTN","TMGRPC3",1056,0)
2378 if DOB="" do goto PSEDone
2379"RTN","TMGRPC3",1057,0)
2380 . set result="0^No DOB (.03 field) provided"
2381"RTN","TMGRPC3",1058,0)
2382 new %DT,X,Y set %DT="P" ;"P-Post dates assumed
2383"RTN","TMGRPC3",1059,0)
2384 set X=DOB do ^%DT set DOB=Y ;"convert external date into internal format
2385"RTN","TMGRPC3",1060,0)
2386 if +DOB'>0 do goto PSEDone
2387"RTN","TMGRPC3",1061,0)
2388 . set result="0^Invalid date: "_$get(Array(.03))
2389"RTN","TMGRPC3",1062,0)
2390
2391"RTN","TMGRPC3",1063,0)
2392 new matches merge matches=^DPT("B",name)
2393"RTN","TMGRPC3",1064,0)
2394 if $data(matches)=0 do goto PSEDone
2395"RTN","TMGRPC3",1065,0)
2396 . set result="0^No match for name"
2397"RTN","TMGRPC3",1066,0)
2398
2399"RTN","TMGRPC3",1067,0)
2400 ;"Now compare each name match for also matching sex and DOB
2401"RTN","TMGRPC3",1068,0)
2402 new IEN set IEN=""
2403"RTN","TMGRPC3",1069,0)
2404 for set IEN=$order(matches(IEN)) quit:(+IEN'>0) do
2405"RTN","TMGRPC3",1070,0)
2406 . new node0 set node0=$get(^DPT(IEN,0))
2407"RTN","TMGRPC3",1071,0)
2408 . if $piece(node0,"^",2)'=sex do quit
2409"RTN","TMGRPC3",1072,0)
2410 . . kill matches(IEN)
2411"RTN","TMGRPC3",1073,0)
2412 . if $piece(node0,"^",3)'=DOB do quit
2413"RTN","TMGRPC3",1074,0)
2414 . . kill matches(IEN)
2415"RTN","TMGRPC3",1075,0)
2416
2417"RTN","TMGRPC3",1076,0)
2418 ;"matches should contain all entries matching name+sex+DOB
2419"RTN","TMGRPC3",1077,0)
2420 set result=+$order(matches(""))
2421"RTN","TMGRPC3",1078,0)
2422 ;"Now check for more than one match
2423"RTN","TMGRPC3",1079,0)
2424 if $order(matches(result))'="" do goto PSEDone
2425"RTN","TMGRPC3",1080,0)
2426 . set result="0^More than one match found for Name+Sex+DOB"
2427"RTN","TMGRPC3",1081,0)
2428
2429"RTN","TMGRPC3",1082,0)
2430PSEDone
2431"RTN","TMGRPC3",1083,0)
2432 quit result
2433"RTN","TMGRPC3",1084,0)
2434
2435"RTN","TMGRPC3",1085,0)
2436
2437"RTN","TMGRPC3",1086,0)
2438GetErrStr(ErrArray)
2439"RTN","TMGRPC3",1087,0)
2440 ;"Purpose: convert a standard DIERR array into a string for output
2441"RTN","TMGRPC3",1088,0)
2442 ;"Input: ErrArray -- PASS BY REFERENCE. example:
2443"RTN","TMGRPC3",1089,0)
2444 ;" array("DIERR")="1^1"
2445"RTN","TMGRPC3",1090,0)
2446 ;" array("DIERR",1)=311
2447"RTN","TMGRPC3",1091,0)
2448 ;" array("DIERR",1,"PARAM",0)=3
2449"RTN","TMGRPC3",1092,0)
2450 ;" array("DIERR",1,"PARAM","FIELD")=.02
2451"RTN","TMGRPC3",1093,0)
2452 ;" array("DIERR",1,"PARAM","FILE")=2
2453"RTN","TMGRPC3",1094,0)
2454 ;" array("DIERR",1,"PARAM","IENS")="+1,"
2455"RTN","TMGRPC3",1095,0)
2456 ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers."
2457"RTN","TMGRPC3",1096,0)
2458 ;" array("DIERR","E",311,1)=""
2459"RTN","TMGRPC3",1097,0)
2460 ;"Results: returns one long equivalent string from above array.
2461"RTN","TMGRPC3",1098,0)
2462 ;"Note: This is a copy of the function GetErrStr^TMGDEBUG
2463"RTN","TMGRPC3",1099,0)
2464 ;" I copied it here so that this file has no TMG* dependencies.
2465"RTN","TMGRPC3",1100,0)
2466
2467"RTN","TMGRPC3",1101,0)
2468 new ErrStr
2469"RTN","TMGRPC3",1102,0)
2470 new TMGIDX
2471"RTN","TMGRPC3",1103,0)
2472 new ErrNum
2473"RTN","TMGRPC3",1104,0)
2474
2475"RTN","TMGRPC3",1105,0)
2476 set ErrStr=""
2477"RTN","TMGRPC3",1106,0)
2478 for ErrNum=1:1:+$get(ErrArray("DIERR")) do
2479"RTN","TMGRPC3",1107,0)
2480 . set ErrStr=ErrStr_"Fileman says: '"
2481"RTN","TMGRPC3",1108,0)
2482 . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") "
2483"RTN","TMGRPC3",1109,0)
2484 . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",""))
2485"RTN","TMGRPC3",1110,0)
2486 . if TMGIDX'="" for do quit:(TMGIDX="")
2487"RTN","TMGRPC3",1111,0)
2488 . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" "
2489"RTN","TMGRPC3",1112,0)
2490 . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))
2491"RTN","TMGRPC3",1113,0)
2492 . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do
2493"RTN","TMGRPC3",1114,0)
2494 . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0))
2495"RTN","TMGRPC3",1115,0)
2496 . . set ErrStr=ErrStr_"Details: "
2497"RTN","TMGRPC3",1116,0)
2498 . . for do quit:(TMGIDX="")
2499"RTN","TMGRPC3",1117,0)
2500 . . . if TMGIDX="" quit
2501"RTN","TMGRPC3",1118,0)
2502 . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" "
2503"RTN","TMGRPC3",1119,0)
2504 . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX))
2505"RTN","TMGRPC3",1120,0)
2506
2507"RTN","TMGRPC3",1121,0)
2508 quit ErrStr
2509"RTN","TMGRPC3",1122,0)
2510
2511"RTN","TMGRPC3",1123,0)
2512
2513"VER")
25148.0^22.0
2515**END**
2516**END**
Note: See TracBrowser for help on using the repository browser.