source: cprs/branches/tmg-cprs/m_files/TMGXMLUI.m@ 1381

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

Initial upload
File size: 57.5 KB
RevLine 
[796]1TMGXMLUI ;TMG/kst/XML Exporter -- User Interface ;03/25/06
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4 ;"TMG XML EXPORT -- USER INTERFACE FUNCTIONS
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"7-12-2005
8
9 ;"=======================================================================
10 ;" API -- Public Functions.
11 ;"=======================================================================
12 ;"UI
13
14 ;"=======================================================================
15 ;"PRIVATE API FUNCTIONS
16 ;"=======================================================================
17 ;"Welcome()
18 ;"ProcessFile(pArray,indent)
19 ;"GetRecs(File,pRecs,indent)
20 ;"GetTemplateRecs(File,pRecs,s)
21 ;"GetManualRecs(File,pRecs,s)
22 ;"GetFields(File,pArray,indent)
23 ;"GetManFields(File,pArray,s)
24 ;"AskCustomTag(File,field,pArray,indent)
25 ;"AskCustTransform(File,field,pArray,indent)
26 ;"$$FMGetField(FileNumber)
27 ;"$$AskGetField(FileNumber,indent)
28 ;"$$PickUnselField(FileNumber,pArray,indent)
29 ;"CfgOrderFields(File,pArray)
30 ;"ShowArray(indent)
31 ;"Pause
32 ;"WriteHeader(pHeader)
33 ;"HdrAddLine(pHeader,Line)
34 ;"HdrDelLine(pHeader,index)
35 ;"Spaces(Num)
36
37 ;"=======================================================================
38 ;"Dependencies
39 ;"XLFSTR
40 ;"TMGDBAPI, TMGDEBUG, TMGMISC
41 ;"=======================================================================
42 ;"=======================================================================
43
44
45UI(pArray)
46 ;"Purpose: To create a User Interface (UI) for creating array needed to
47 ;" export XML data from Fileman.
48 ;"Input: pArray -- pointer to (i.e. name of) array to put data into
49 ;"Output: values will be put into pArray. See TMGXMLEX for format
50 ;"Result: 1 if OK to continue, 0 if error or abort
51
52 new result set result=1
53
54 if $data(IOF)=0 do goto UIDone
55 . write "This function requires the VistA environment to be setup first.",!
56 . write "Terminating. This may be achieved via DO ^XUP, then dropping",!
57 . write "back to the command line and trying to run this again.",!
58 . set result=0
59
60 new done set done=0
61 new HeaderArray
62 new pHeader set pHeader="HeaderArray"
63 set pArray=$get(pArray,"TMGArray")
64 new TMGxmlArray set TMGxmlArray=pArray
65 new indent set indent=0
66 new TabInc set TabInc=5
67
68 do HdrAddLine(pHeader," XML Export Assistant.")
69 do HdrAddLine(pHeader,"=========================")
70
71 set result=$$Welcome
72 if result=0 goto UIDone
73 set result=$$ProcessFile(pArray,indent+TabInc)
74 if result=0 goto UIDone
75
76UIDone
77 quit result
78
79
80Welcome()
81 ;"Purpose: Decribe the wizard
82 ;"Input: none
83 ;"Result: 1 if OK to continue. 0 if user abort requested.
84 ;"Note: uses global pHeader
85
86 new result set result=1
87 do WriteHeader(pHeader)
88 write "Welcome. I'll walk you through the process",!
89 write "of choosing the data you wish to export to an ",!
90 write "XML file.",!!
91 write "Overview of planned steps:",!
92 write "Step 1. Pick 1st Fileman file to export.",!
93 write "Step 2. Pick records in file to export.",!
94 write "Step 3. Pick fields in records to export.",!
95 write "Step 4. Pick 2nd Fileman file to export.",!
96 write " ... repeat cycle until done.",!!
97 write "To back out, enter '^' at any prompt.",!!
98WcLoop
99 write "Are you ready to begin? (Y/N/^) YES//"
100 new input
101 read input:$get(DTIME,3600),!
102 if $TEST=0 set input="N"
103 if input="" set input="Y"
104 set input=$$UP^XLFSTR(input)
105 if (input'["Y")!(input["^") do goto WcmDone
106 . ;"write "Goodbye.",!
107 . set result=0
108 if (input["?") do goto WcLoop
109 . write " Enter Y or YES to continue.",!
110 . write " Enter N or No or ^ to exit.",!!
111 . do Pause()
112
113WcmDone
114 quit result
115
116
117ProcessFile(pArray,indent)
118 ;"Purpose: To add export options for one file, or edit previous choices
119 ;"Input: pArray -- pointer to (i.e. name of) array to fill with info.
120 ;" indent -- amount to indent from left margin
121 ;"Output: Array will be filled with data in appropriate format (See docs in TMGXMLEX.m)
122 ;"Result: 1 if OK to continue, 0 if aborted
123 ;"note: uses global variable pHeader,TabInc
124
125 new DIC,File
126 new Y set Y=0
127 new ref
128 new result set result=1
129 new Records
130 if $get(pArray)="" set result=0 goto SUFDone
131
132 do HdrAddLine(pHeader,$$Spaces(indent)_"Step 1. Pick a FILE for export to XML.")
133
134 new Another set Another=0
135 for do quit:(+Y'>0)!(result=0)
136 . do WriteHeader(pHeader,1)
137 . if Another do quit:(result=0)!(Y'>0)
138 . . write !,?indent,"Add another file for export? (Y/N/^) NO//"
139 . . new input read input:$get(DTIME,3600),!
140 . . if input="^" set Y=0,result=0 quit
141 . . if input="" set input="N"
142 . . set input=$$UP^XLFSTR(input)
143 . . if input'["Y" set Y=0 quit ;"signal to quit
144 . . set Y=1
145 . set DIC=1
146 . set DIC(0)="AEQ"
147 . set DIC("A")=$$Spaces(indent)_"Enter Fileman file for XML export (^ to quit): ^// "
148 . do ^DIC
149 . write !
150 . set File=+Y
151 . if File'>0 set result=0 quit
152 . set ref=$name(@pArray@(File))
153 . if $$GetRecs(File,ref,indent)=0 set Y=0,result=0 quit
154 . set Another=1
155
156 do HdrDelLine(pHeader)
157
158 if result=0 goto SUFDone
159
160 write !,?indent,"Also export pointed-to records (Y/N/^) YES// "
161 new input read input:$get(DTIME,3600),!
162 if input="^" set result=0 goto SUFDone
163 if input="" set input="Y"
164 set input=$$UP^XLFSTR(input)
165 if input["Y" do
166 . do ExpandPtrs(pArray)
167
168 set result=$$AskFlags(pArray,indent)
169SUFDone
170 quit result
171
172
173AskFlags(pArray,indent)
174 ;"Purpose: To ask user if various flags are desired
175 ;"Input: pArray -- pointer to (i.e. name of) array to put data into
176 ;" indent -- amount to indent from left margin
177 ;"Note: uses global variable pHeader
178 ;"Result: 1 if OK to continue, 0 if aborted
179
180 new input
181 set indent=$get(indent,0)
182 new result set result=1
183 if $get(pArray)="" set result=0 goto AFlgDone
184 new defLabel set defLabel="TMG_VISTA_XML_EXPORT"
185
186 new SysName,Y
187 set SysName=$get(^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME"))
188 if SysName="" do
189 . do GETENV^%ZOSV
190 . set SysName=$piece(Y,"^",4)
191 set @pArray@("EXPORT_SYSTEM_NAME")=SysName
192
193 do WriteHeader(pHeader)
194
195 write ?indent,"Formatting Options:",!
196 write ?indent,"----------------------",!!
197
198 write ?indent,"Use Default export settings? (Y/N,^) YES// "
199 read input:$get(DTIME,3600),!!
200 if input="^" set result=0 goto AFlgDone
201 if input="" set input="Y"
202 if "YesyesYES"[input do goto AFlgDone
203 . set @pArray@("FLAGS","i")="" ;"<-- default value of indenting
204 . set @pArray@("!DOCTYPE")=defLabel
205 . new SysName,Y
206 . set SysName=$get(^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME"))
207
208 write ?indent,"During export to XML file, do you want empty fields to be",!
209 write ?indent,"reported (vs. no data --> tag not written)? (Y/N,^) NO// "
210 read input:$get(DTIME,3600),!!
211 if input="^" set result=0 goto AFlgDone
212 if input="" set input="N"
213 if "YesyesYES"[input do
214 . set @pArray@("FLAGS","b")=""
215
216 write ?indent,"Do you want the XML file to have entries indented for visual",!
217 write ?indent,"organization? This will have no meaning to another program",!
218 write ?indent,"importing the XML file, but is easier for humans to read it ",!
219 write ?indent,"this way. Indent entries? (Y/N,^) YES// "
220 read input:$get(DTIME,3600),!!
221 if input="^" set result=0 goto AFlgDone
222 if input="" set input="Y"
223 if "YesyesYES"[input do
224 . set @pArray@("FLAGS","i")=""
225
226 write ?indent,"Do you want the exported entries to be INTERNAL Fileman values?",!
227 write ?indent,"Export INTERNAL entries? (Y/N,^) NO// "
228 read input:$get(DTIME,3600),!!
229 if input="^" set result=0 goto AFlgDone
230 if input="" set input="N"
231 if "YesyesYES"[input do
232 . set @pArray@("FLAGS","I")=""
233
234 write ?indent,"Do you want the export the Fileman data dictionary? (Y/N,^) NO// "
235 read input:$get(DTIME,3600),!!
236 if input="^" set result=0 goto AFlgDone
237 if input="" set input="N"
238 if "YesyesYES"[input do
239 . set @pArray@("FLAGS","D")=""
240
241 write ?indent,"Output export settings? (Y/N,^) YES// "
242 read input:$get(DTIME,3600),!!
243 if input="^" set result=0 goto AFlgDone
244 if input="" set input="Y"
245 if "YesyesYES"[input do
246 . set @pArray@("FLAGS","S")=""
247
248 new defLabel set defLabel="TMG_VISTA_XML_EXPORT"
249 write ?indent,"Use default XML !DOCTYPE '"_defLabel_"' label? (Y/N,^) YES// "
250 read input:$get(DTIME,3600),!!
251 if input="^" set result=0 goto AFlgDone
252 if input="" set input="Y"
253 if "YesyesYES"[input do
254 . set @pArray@("!DOCTYPE")=defLabel
255 else do goto:(result=0) AFlgDone
256 . write ?indent,"Specify a *custom* XML !DOCTYPE label? (Y/N,^) NO// "
257 . read input:$get(DTIME,3600),!!
258 . if input="^" set result=0 quit
259 . if input="" set input="Y"
260 . if "YesyesYES"[input do
261 . . write "Enter label for <!DOCTYPE YourInputGoesHere>",!
262 . . write "Enter Label: //"
263 . . read input:$get(DTIME,3600),!!
264 . . if input="^" set result=0 quit
265 . . if input'="" set @pArray@("!DOCTYPE")=input
266
267 write ?indent,"Enter a name for this VistA installation. ",SysName,"// "
268 read input:$get(DTIME,3600),!!
269 if input="^" set result=0 goto AFlgDone
270 if input="" set input=SysName
271 set SysName=input
272 set ^TMG("XML EXPORTER","EXPORT_SYSTEM_NAME")=SysName
273 set @pArray@("EXPORT_SYSTEM_NAME")=SysName
274
275AFlgDone
276 quit result
277
278
279 ;"NOTE: I need to notice if File has already been set (i.e. user choosing file a second time
280 ;" If so give option to erase old choices and choose again
281GetRecs(File,pRecs,indent)
282 ;"Purpose: For a given file, allow selection of records to export.
283 ;"Input: File -- the File (name or number) to select from.
284 ;" pRec -- Pointer to (i.e. name of) array to fill with records nums
285 ;" indent -- a value to indent from left margin
286 ;"Result: 1 if OK to continue, 0 if user aborted.
287 ;"Note: uses global variable pHeader,TabInc
288
289 new result set result=1
290 new input set input=""
291 new FileNumber,FileName
292 if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone
293 new defValue set defValue="X"
294
295 if +File=File do
296 . set FileNumber=File
297 . set FileName=$$GetFName^TMGDBAPI(File)
298 else do
299 . set FileName=File
300 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
301
302 do HdrAddLine(pHeader,$$Spaces(indent)_"Step 2. Which RECORDS to export from file "_FileName_"?")
303
304 for do quit:(input="^")!(result=0)
305 . do WriteHeader(pHeader)
306 . write ?indent,"1. Export ALL records (exclusions allowed).",!
307 . write ?indent,"2. Select a Search/Sort TEMPLATE to specify records.",!
308 . write ?indent,"3. Select SPECIFIC records",!
309 . write ?indent,"4. Select records to EXCLUDE",!
310 . write ?indent,"5. View selections so far.",!
311 . write ?indent,"X. Done here.",!!
312 . write ?indent,"Select option (1-5 or X or ? or ^): "_defValue_"// "
313 . read input:$get(DTIME,3600),!!
314 . if $TEST=0 set input="^"
315 . if input="" set input=defValue
316 . if ("Xx"[input) do quit
317 . . if $data(@pRecs)'>1 do quit:(input="")
318 . . . write ?indent,"NOTE: No records were chosen for export in file: ",FileName,!
319 . . . write ?indent,"This means that nothing will be exported to the XML file.",!!
320 . . . write ?indent,"Do you still want to stop selecting records? (Y,N,^) NO// "
321 . . . new Done read Done:$get(DTIME,3600),!
322 . . . if $TEST=0 set Done="^"
323 . . . if (Done="")!("NOnoNo"[Done) set input=""
324 . . set input="^"
325 . if input="^" set result=0 quit
326 . if (input>0)&(input<6) set defValue=input
327 . if input="?" do quit
328 . . write !
329 . . write ?indent," Enter '1' if you wish to export ALL records in this file.",!
330 . . write ?indent," You can still specify records to exclude after this option.",!
331 . . write ?indent," Enter '2' if you wish to use a pre-existing Search/Sort TEMPLATE",!
332 . . write ?indent," to select files. A Search/Sort TEMPLATE can be generated",!
333 . . write ?indent," through the Fileman Search function.",!
334 . . write ?indent," Enter '3' if you know the record nubmers (IEN values) for the",!
335 . . write ?indent," records you wish to export, and want to enter them",!
336 . . write ?indent," manually.",!
337 . . write ?indent," Enter '4' if you have records to EXCLUDE. If a record is excluded,",!
338 . . write ?indent," then it will NOT be output, even if it was specified ",!
339 . . write ?indent," manually or was included from a Search/Sort TEMPLATE.",!
340 . . write ?indent," Enter '5' to view array containing settings so far.",!
341 . . write ?indent," Enter 'X' to exit..",!
342 . . write ?indent," Enter '^' to abort entire process.",!
343 . . do Pause(indent)
344 . if input=1 do
345 . . set @pRecs@("*")=""
346 . . write ?indent,"OK. Will export all records in file: ",FileName,".",!
347 . . set defValue="X"
348 . . do Pause(indent)
349 . if input=2 set result=$$GetTemplateRecs(File,pRecs,"for INCLUSION ",indent+TabInc) set defValue="X"
350 . if input=3 set result=$$GetManualRecs(File,pRecs,"for INCLUSION ",indent+TabInc) set defValue="X"
351 . if input=4 set result=$$GetExclRecs(File,pRecs,indent+TabInc) set defValue="X"
352 . if input=5 do ShowArray(indent)
353
354GRDone
355 if $data(@pRecs)'>1 do
356 . write ?indent,"NOTE: No records were chosen. Aborting.",!
357 . set result=0
358 else do
359 . write ?indent,"Done chosing records...",!
360
361 write ?indent,"Now on to picking FIELDS to export.",!
362 do Pause(indent)
363 if $$GetFields(File,ref,indent)=0 set Y=0,result=0
364 write !
365
366 do HdrDelLine(pHeader)
367
368 quit result
369
370
371GetExclRecs(File,pRecs,indent)
372 ;"Purpose: to allow user to enter records to exclude
373 ;"Input: File -- the File (name or number) to select from.
374 ;" pRec -- Pointer to (i.e. name of) array to fill with records nums
375 ;" indent -- a value to indent from left margin
376 ;"Result: 1 if OK to continue, 0 if user aborted.
377 ;"Note: uses global variable pHeader,TabInc
378
379 new result set result=1
380 new FileNumber,FileName
381 new input set input=""
382 if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone
383 new defValue set defValue="X"
384
385 if +File=File do
386 . set FileNumber=File
387 . set FileName=$$GetFName^TMGDBAPI(File)
388 else do
389 . set FileName=File
390 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
391 set indent=+$get(indent,0)
392
393 do HdrAddLine(pHeader,$$Spaces(indent)_"To EXCLUDE records in file "_FileName_", choose:")
394
395 for do quit:(input="")!(result=0)
396 . new ExRecs,i
397 . do WriteHeader(pHeader)
398 . write ?indent,"1. Select a Search/Sort TEMPLATE to specify records to EXCLUDE.",!
399 . write ?indent,"2. Select SPECIFIC record numbers to EXCLUDE.",!
400 . write ?indent,"3. View all the records excluded so far.",!
401 . write ?indent,"X. Done here.",!!
402 . write ?indent,"Select option (1-3 or X or ? or ^) "_defValue_"// "
403 . read input:$get(DTIME,3600),!
404 . if $TEST=0 set input="^"
405 . if input="" set input=defValue
406 . if ("Xx"[input) set input=""
407 . if input="^" set result=0 quit
408 . if (input>0)&(input<4) set defValue=input
409 . if input="?" do
410 . . write !,?indent," By excluding just certain records, you can export every record",!
411 . . write ?indent," EXCEPT those you specify.",!
412 . . do Pause(indent)
413 . if input=1 do
414 . . new pArray set pArray=$name(@pRecs@("Rec Exclude"))
415 . . set result=$$GetTemplateRecs(File,pArray,"for EXCLUSION ",indent+TabInc)
416 . if input=2 do
417 . . new pArray set pArray=$name(@pRecs@("Rec Exclude"))
418 . . set result=$$GetManualRecs(File,pArray,"for EXCLUSION ",indent+TabInc)
419 . if input=3 do ShowArray(indent)
420
421 do HdrDelLine(pHeader)
422
423GERDone
424 quit result
425
426
427GetTemplateRecs(File,pRecs,s,indent)
428 ;"Purpose: to ask user for a search/sort template to inport records from
429 ;"Input -- File -- the file name or number to work with
430 ;" pRecs -- pointer to (i.e. name of) array to fill
431 ;" will probably be passed with "Array(12345)"
432 ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title.
433 ;" indent -- OPTIONAL -- a value to indent from left margin
434 ;"Output: Data is put into pRecs like this:
435 ;" @pRecs@(IEN1)=""
436 ;" @pRecs@(IEN2)=""
437 ;" @pRecs@(IEN3)=""
438 ;"Result: 1 if OK to continue, 0 if user aborted.
439 ;"Note: uses global variable pHeader (if available)
440
441 new FileNumber,FileName,Y
442 if ($get(File)="")!($get(pRecs)="") goto GTRDone
443 new tempH set pHeader=$get(pHeader,"tempH")
444 new result set result=1
445
446 if +File=File do
447 . set FileNumber=File
448 . set FileName=$$GetFName^TMGDBAPI(File)
449 else do
450 . set FileName=File
451 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
452 if FileNumber'>0 do goto GTRDone
453 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
454 . set result=0
455
456 set indent=+$get(indent,0)
457
458 do HdrAddLine(pHeader,$$Spaces(indent)_"Select records for export from a Template")
459
460 for do quit:((+Y>0)!(+Y=-1))
461 . do WriteHeader(pHeader)
462 . new DIC
463 . set DIC=.401
464 . set DIC(0)="AEQ"
465 . write $$Spaces(indent)_"Select a Template containing records for import. ",!
466 . write $$Spaces(indent)_"(? for list, ^ to quit) "
467 . set DIC("A")=$$Spaces(indent)_"Enter Template: "
468 . set DIC("S")="IF $P($G(^DIBT(+Y,0)),""^"",4)="_FileNumber ;"screen for Templates by file
469 . do ^DIC
470 . write !
471 . if +Y'>0 quit ;"set result=0
472 . new node set node=$get(^DIBT(+Y,0))
473 . if $piece(node,"^",4)'=FileNumber do quit
474 . . set Y=0 ;"signal to try again
475 . . new PriorErrorFound
476 . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: That template doesn't contain records from "_File_". Please select another.")
477 . . do Pause(indent)
478
479 if result=0 goto GTRL1
480
481 new count set count=0
482 if (+Y>0)&($data(^DIBT(+Y,1))>1) do
483 . new index set index=$order(^DIBT(+Y,1,0))
484 . if index'="" for do quit:(index="")
485 . . set @pRecs@(index)=""
486 . . set count=count+1
487 . . set index=$order(^DIBT(+Y,1,index))
488
489 write ?indent,count," Records imported.",!
490 do Pause(indent)
491
492GTRL1
493 do HdrDelLine(pHeader)
494
495GTRDone
496 quit result
497
498
499GetManualRecs(File,pRecs,s,indent)
500 ;"Purpose: to ask user for a series of IEN values
501 ;"Input: File -- name or number, file to get IENS's for
502 ;" pRecs -- a pointer to (i.e. Name of) array to put IEN's into
503 ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title.
504 ;"Output: Data is put into pRecs like this:
505 ;" @pRecs@(IEN1)=""
506 ;" @pRecs@(IEN2)=""
507 ;" @pRecs@(IEN3)=""
508 ;"Result: 1 if OK to continue, 0 if user aborted.
509 ;"Note: uses global variable pHeader
510
511 new PriorErrorFound
512 new FileNumber,FileName
513 new result set result=1
514 if ($get(File)="")!($get(pRecs)="") set result=0 goto GRDone
515
516 if +File=File do
517 . set FileNumber=File
518 . set FileName=$$GetFName^TMGDBAPI(File)
519 else do
520 . set FileName=File
521 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
522 if FileNumber'>0 do goto GMRDone
523 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
524 . do Pause(indent)
525 . set result=0
526
527 new ORef
528 set ORef=$get(^DIC(FileNumber,0,"GL"))
529 if ORef="" do goto GRDone
530 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Can't find global reference for file: "_FileNumber_".")
531 . do Pause(indent)
532 . set result=0
533
534 new defValue set defValue="X"
535
536 do HdrAddLine(pHeader,$$Spaces(indent)_"Select specific record "_$get(s)_"in file "_FileName)
537
538 new input
539 for do quit:(input="")!(result=0)
540 . do WriteHeader(pHeader)
541 . write ?indent,"1. Use Fileman to find record.",!
542 . write ?indent,"2. Enter record number by hand.",!
543 . write ?indent,"3. View all the records selected so far.",!
544 . write ?indent,"X. Done here.",!
545 . write !,?indent,"Select Option (1-3 or X or ^) "_defValue_"//"
546 . read input:$get(DTIME,3600),!!
547 . if $TEST=0 set input="^"
548 . if input="" set input=defValue
549 . if "Xx"[input set input="" quit
550 . if input="^" set result=0 quit
551 . if (input>0)&(input<4) set defValue=input
552 . if input=1 do
553 . . new DIC
554 . . set DIC=File
555 . . set DIC(0)="AEQ"
556 . . set DIC("A")=$$Spaces(indent)_"Select record in "_FileName_" (? for list, ^ to quit): "
557 . . do ^DIC
558 . . write !
559 . . if +Y>0 do
560 . . . write !,?indent,"O.K. You selected record number (IEN): ",+Y,!
561 . . . set @pRecs@(+Y)=""
562 . . . do Pause(indent)
563 . . ;" else set result=0 quit
564 . if input=2 do
565 . . new IEN
566 . . read ?indent,"Enter record number (a.k.a. IEN) (^ to abort): ",IEN:$get(DTIME,3600),!
567 . . if $TEST=0 set EIN="^"
568 . . if IEN="^" set result=0 quit
569 . . if +IEN>0 do
570 . . . new ref set ref=ORef_IEN_")"
571 . . . if $data(@ref)'>0 do quit
572 . . . . write ?indent,"Sorry. That record number (IEN) doesn't exist.",!
573 . . . . do Pause(indent)
574 . . . set @pRecs@(IEN)=""
575 . . . write ?indent,"O.K. You selected record number (IEN): ",IEN,!
576 . . . do Pause(indent)
577 . if input=3 do ShowArray(indent)
578
579 do HdrDelLine(pHeader)
580
581GMRDone
582 quit result
583
584
585GetFields(File,pArray,indent)
586 ;"Purpose: To query the user as to which fields to export for records
587 ;"Input: File -- the File number or name to work with.
588 ;" pArray -- point to (i.e. name of) Array to work with. Format discussed in TMGXMLEX.m
589 ;" will likely be equal to "Array(FileNumber)"
590 ;" indent -- a value to indent from left margin
591 ;"Result: 1 if OK to continue. 0 if user aborted.
592 ;"Note: uses global variable pHeader,TabInc
593
594 new result set result=1
595 new FileNumber,FileName
596 if ($get(File)="")!($get(pArray)="") set result=0 goto GRDone
597
598 if +File=File do
599 . set FileNumber=File
600 . set FileName=$$GetFName^TMGDBAPI(File)
601 else do
602 . set FileName=File
603 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
604 if FileNumber'>0 do
605 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
606
607 do HdrAddLine(pHeader,$$Spaces(indent)_"Step 3. Which FIELDS to export from file "_FileName_"?")
608
609 new defValue set defValue=1
610 new input
611 for do quit:(input="")!(result=0)
612 . do WriteHeader(pHeader)
613 . write ?indent,"1. Export ALL fields (exclusions allowed).",!
614 . write ?indent,"2. Select SPECIFIC field numbers.",!
615 . write ?indent,"3. Select fields to EXCLUDE",!
616 . write ?indent,"4. View selections so far.",!
617 . write ?indent,"X. Done here.",!!
618 . write ?indent,"Select option (1-4 or X or ? or ^): "_defValue_"// "
619 . read input:$get(DTIME,3600),!!
620 . if $TEST=0 set input="^"
621 . if input="" set input=defValue
622 . if ("Xx"[input) set input=""
623 . if input="^" set result=0 quit
624 . if (input>0)&(input<5) set defValue=input
625 . if input="?" do quit
626 . . write !
627 . . write ?indent," Enter '1' if you wish to export ALL fields for this file.",!
628 . . write ?indent," You can still specify fields to exclude after this option.",!
629 . . write ?indent," Enter '2' if you know the field numbers you wish to export,",!
630 . . write ?indent," and want to enter them manually.",!
631 . . write ?indent," Enter '3' if you have fields to EXCLUDE. If a field is excluded,",!
632 . . write ?indent," then it will NOT be output, even if it was specified manually.",!
633 . . write ?indent," Enter '4' to view array containing settings so far.",!
634 . . write ?indent," Enter 'X' to exit..",!
635 . . write ?indent," Enter '^' to abort entire process.",!
636 . . do Pause(indent)
637 . if input=1 do quit
638 . . set @pArray@("TEMPLATE","*")=""
639 . . write ?indent,"OK. Will export all fields (and any sub-fields) in file ",FileName,".",!
640 . . do Pause(indent)
641 . . set defValue="X"
642 . if input=2 do quit
643 . . new temp set temp=$name(@pArray@("TEMPLATE"))
644 . . set result=$$GetManFields(File,temp,"for INCLUSION ",indent+TabInc)
645 . if input=3 do quit
646 . . new temp set temp=$name(@pArray@("TEMPLATE","Field Exclude"))
647 . . set result=$$GetManFields(File,temp,"for EXCLUSION ",indent+TabInc)
648 . if input=4 do ShowArray(indent)
649
650 write ?indent,"Done choosing FIELDS.",!
651
652 new ref
653 ;"set ref=$name(@pArray@(File,"TEMPLATE"))
654 set ref=$name(@pArray@("TEMPLATE"))
655 set result=$$CfgOrderFields(File,ref,indent)
656 if result=0 set Y=0 quit
657
658 do HdrDelLine(pHeader)
659 quit result
660
661
662GetManFields(File,pArray,s,indent)
663 ;"Purpose: to ask user for a series of field values
664 ;"Input: File -- name or number, file to get field numbers for
665 ;" pArray -- a pointer to (i.e. Name of) array to put field numbers into
666 ;" will probably be something one of the following:
667 ;" "Array(FileNumber,"TEMPLATE")"
668 ;" "Array(FileNumber,"TEMPLATE","Field Exclude")"
669 ;" "Array(FileNumber,RecNumber)"
670 ;" s -- OPTIONAL -- e.g. "for INCLUSION " or "for EXCLUSION " -- part of title.
671 ;" indend -- optional -- a value to indent from left margin
672 ;"Output: Data is put into pArray
673 ;"Result: 1 if OK to continue. 0 if user aborted.
674 ;"Note: uses global variable pHeader,TabInc
675
676 new PriorErrorFound
677 new FileNumber,FileName
678 new result set result=1
679 if ($get(File)="")!($get(pArray)="") set result=0 goto GRDone
680 set indent=$get(indent,0)
681 new defValue set defValue="X"
682
683 if +File=File do
684 . set FileNumber=File
685 . set FileName=$$GetFName^TMGDBAPI(File)
686 else do
687 . set FileName=File
688 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
689 if FileNumber'>0 do goto GRDone
690 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
691 . set result=0
692
693 do HdrAddLine(pHeader,$$Spaces(indent)_"Which SPECIFIC FIELDS "_$get(s)_"to export?")
694
695 new input
696 for do quit:(input="")!(result=0)
697 . new field set field=0
698 . do WriteHeader(pHeader)
699 . write ?indent,"1. Select ALL fields.",!
700 . write ?indent,"2. Use Fileman to find FIELD number.",!
701 . write ?indent,"3. Enter FIELD by hand.",!
702 . write ?indent,"4. Pick an UNSELECTED field.",!
703 . write ?indent,"5. View all the FIELDS selected so far.",!
704 . write ?indent,"X. Done here.",!
705 . write !,?indent,"Select Option (1-5 or X or ^) ",defValue,"//"
706 . read input:$get(DTIME,3600),!!
707 . if $TEST=0 set input="^"
708 . if input="" set input=defValue
709 . if "Xx"[input set input="" quit
710 . if input="^" set result=0 quit
711 . if (input>0)&(input<6) set defValue=input
712 . if input="5" do quit
713 . . do ShowArray(indent)
714 . if input="1" do
715 . . write "OK All fields selected.",!
716 . . set @pArray@("*")=""
717 . if input="2" set field=$$FMGetField(FileNumber,indent)
718 . if input="3" set field=$$AskGetField(FileNumber,indent)
719 . if input="4" set field=$$PickUnselField(FileNumber,pArray,indent)
720 . if field=-1 set result=0 quit
721 . if field>0 do
722 . . set @pArray@(field)=""
723 . . if $get(s)'="for EXCLUSION " do quit:(result=0)
724 . . . set result=$$AskCustomTag(FileNumber,field,pArray,indent)
725 . . . if result=0 quit
726 . . . set result=$$AskCustTransform(FileNumber,field,pArray,indent)
727 . . . if result=0 quit
728 . . ;"Now, determine if we need to do sub-fields
729 . . new fieldInfo
730 . . do GetFieldInfo^TMGDBAPI(FileNumber,field,"fieldInfo","LABEL")
731 . . if $get(fieldInfo("MULTIPLE-VALUED"))>0 do
732 . . . if $get(fieldInfo("TYPE"))="WORD PROCESSING" quit
733 . . . new subFile set subFile=+$get(fieldInfo("SPECIFIER"))
734 . . . if subFile=0 quit
735 . . . new fieldLst if $$GetFldList^TMGDBAPI(subFile,"fieldLst")=0 quit
736 . . . new subArray set subArray=$name(@pArray@(field,"TEMPLATE"))
737 . . . if $$ListCt^TMGMISC("fieldLst")=1 do quit
738 . . . . new subField set subField=$order(fieldLst(""))
739 . . . . new subFName set subFName=$$GetFldName^TMGDBAPI(subFile,subField)
740 . . . . write ?indent,"Field ",$get(fieldInfo("LABEL"))," (#",field,") has exactly 1 sub-field (",subFName,")",!
741 . . . . write ?indent,"It has been automatically selected for you.",!
742 . . . . set @subArray@(subField)=""
743 . . . . if $get(s)'="for EXCLUSION " do quit:(result=0)
744 . . . . . set result=$$AskCustomTag(subFile,subField,subArray,indent)
745 . . . . . if result=0 quit
746 . . . . . set result=$$AskCustTransform(subFile,subField,subArray,indent)
747 . . . . . if result=0 quit
748 . . . write ?indent,"Field ",$get(fieldInfo("LABEL"))," (#",field,") has sub-fields. We'll select those next.",!
749 . . . do Pause(indent)
750 . . . set result=$$GetManFields(subFile,subArray,s,indent+TabInc)
751 . do Pause(indent)
752
753 do HdrDelLine(pHeader)
754
755GMFDone
756 quit result
757
758
759AskCustomTag(File,field,pArray,indent)
760 ;"Purpose: Ask user if they want a custom output tag for a field
761 ;"Input: FileNumber -- the name or number of the file to work with
762 ;" field -- the number of the field to work with
763 ;" pArray -- the array to put answer in.
764 ;" value passed will probably be like this:
765 ;" e.g. array(22704,"TEMPLATE") or
766 ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE")
767 ;" indent -- the indent value from left margin
768 ;"Output: value is put in, if user wants, like this
769 ;" e.g. array(22704,"TEMPLATE","TAG NAME",.01)="Custom name"
770 ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE","TRANSFORM",.01)="Custom name"
771 ;"Result: 1 if OK to continue. 0 if user aborted.
772
773 new result set result=1
774 if (+$get(File)=0)!($get(field)="")!($get(pArray)="") set result=0 goto ACTDone
775 set indent=$get(indent,0)
776
777 new defTag set defTag=$get(@pArray@("TAG NAME",field))
778 if defTag="" set defTag=$$GetFldName^TMGDBAPI(File,field)
779 write ?indent,"Tag name to use in XML file? ",defTag,"// "
780 new tagName read tagName:$get(DTIME,3600),!
781 if tagName="^" set result=0
782 if (tagName'="")&(tagName'="^") set @pArray@("TAG NAME",field)=tagName
783
784ACTDone
785 quit result
786
787
788AskCustTransform(File,field,pArray,indent)
789 ;"Purpose: Ask user if they want a custom output transform
790 ;"Input: FileNumber -- the name or number of the file to work with
791 ;" field -- the number of the field to work with
792 ;" pArray -- the array to put answer in.
793 ;" value passed will probably be like this:
794 ;" e.g. array(22704,"TEMPLATE") or
795 ;" e.g. array(22704,"TEMPLATE",2,"TEMPLATE")
796 ;" indent -- the indent value from left margin
797 ;"Output: value is put in, if user wants, like this
798 ;" e.g. array(22704,"TEMPLATE","TRANSFORM",.01)="Custom name"
799 ;" e.g. array(22704,"TEMPLATE",2,"TRANSFORM","TAG NAME",.01)="Custom name"
800 ;"Result: 1 if OK to continue. 0 if user aborted.
801
802 new result set result=1
803 if (+$get(File)=0)!($get(field)="")!($get(pArray)="") set result=0 goto ACXDone
804 set indent=$get(indent,0)
805
806 new defXForm
807 new XForm set XForm=""
808
809 set defXForm=$get(@pArray@("TRANSFORM",field))
810 for do quit:(XForm'="")!(result=0)
811 . if defXForm'="" write ?indent,defXForm,!
812 . write ?indent,"Custom output transform for field? (?,^) ^//"
813 . read XForm:$get(DTIME,3600),!
814 . if XForm="" set XForm="^"
815 . if XForm="^" set result=0 quit
816 . if XForm="?" do quit
817 . . write !
818 . . write ?indent,"OPTION FOR ADVANCED USERS ONLY",!
819 . . write ?indent,"An output transform is custom Mumps code that converts",!
820 . . write ?indent,"internally stored database values into information readable",!
821 . . write ?indent,"by end users. If you don't understand this, just leave this",!
822 . . write ?indent,"option blank (i.e., just hit [ENTER])",!
823 . . write ?indent,"The following variables will be set up:",!
824 . . write ?indent," X -- the value stored in the database",!
825 . . write ?indent," IENS -- a standard Fileman IENS",!
826 . . write ?indent," FILENUM -- the number of the current file or subfile",!
827 . . write ?indent," FIELD -- the number of the current file",!
828 . . write ?indent,"The resulting value (that should be written to the XML",!
829 . . write ?indent,"file) should be put into Y",!!
830 . . do Pause(indent)
831 . . set XForm=""
832 . ;"Note I should run some check here for valid code.
833 . set @pArray@("TRANSFORM",field)=XForm
834
835ACXDone
836 quit result
837
838
839FMGetField(FileNumber,indent)
840 ;"Purpose: To use Fileman to pick a field
841 ;"Input: File -- Number of file to get field numbers for
842 ;"Result -- The file number selected, or 0 if none or abort
843
844 new result set result=0
845 if +$get(FileNumber)'>0 goto FMGFDone
846 new DIC
847 set DIC="^DD("_FileNumber_","
848 set DIC(0)="AEQ"
849 set DIC("A")=$$Spaces(.indent)_"Select field (? for list, ^ to abort): "
850 do ^DIC
851 write !
852 if +Y>0 set result=+Y
853
854FMGFDone
855 quit result
856
857
858AskGetField(FileNumber,indent)
859 ;"Purpose: To ask user for a field number, then verify it exists.
860 ;"Input: File -- Number of file to get field numbers for
861 ;" indent -- OPTIONAL -- a number of spaces to indent.
862 ;"Result -- The file number selected, or 0 if none, or -1 if abort
863
864 new result set result=0
865 new fieldName,field
866 set indent=$get(indent,0)
867 if +$get(FileNumber)'>0 goto AGFDone
868
869 write ?indent
870 read "Enter field number or name: ",field:$get(DTIME,3600)
871 if field="^" set result=-1 goto AGFDone
872 if +field=0 do quit:(+field=0)
873 . set fieldName=field
874 . set field=$$GetNumField^TMGDBAPI(FileNumber,field) ;"Convert Field Name to Field Number
875 . write " (# ",field,")",!
876 else do
877 . set fieldName=$$GetFldName^TMGDBAPI(FileNumber,field) ;"Convert Field Number to Field Name
878 . write " (",fieldName,")",!
879 if +field>0 do
880 . new ref set ref="^DD("_FileNumber_","_field_",0)"
881 . if $data(@ref)'>0 do
882 . . write ?indent,"Sorry. That field number doesn't exist.",!
883 . . set field=0
884 . else do
885 . . set result=field
886
887AGFDone
888 quit result
889
890
891PickUnselField(FileNumber,pArray,indent)
892 ;"Purpose: To allow the user to pick those fields not already selected.
893 ;"Input: FileNumber -- the file number to work from
894 ;" pArray -- a pointer to (i.e. name of) array to work from. Format same as other functions in this module
895 ;" indent -- OPTIONAL -- a number of spaces to indent.
896 ;"Result -- The file number selected, or 0 if none, or -1 if abort
897
898 new result set result=0
899 new fieldName,field,index
900 set indent=$get(indent,0)
901 if (+$get(FileNumber)'>0)!($get(pArray)="") goto AGFDone
902
903 ;"Get list of available fields.
904 new allFields
905 new pickArray
906 new pickCt set pickCt=0
907 if $$GetFldList^TMGDBAPI(FileNumber,"allFields")=0 goto PUFDone
908 set field=0
909 for do quit:(+field'>0)
910 . new fieldName
911 . set field=$order(allFields(field))
912 . if (+field>0)&($data(@pArray@(field))=0) do
913 . . set pickCt=pickCt+1
914 . . set pickArray(pickCt)=field
915 . . set fieldName=$$GetFldName^TMGDBAPI(FileNumber,field) ;"Convert Field Number to Field Name
916 . . write ?indent,pickCt,". ",fieldName," (",field,")",!
917 . if (pickCt>0)&(((pickCt\10)=(pickCt/10))!(+field'>0)) do
918 . . new input
919 . . write !,?indent,"Select entry (NOT field number) (1-",pickCt,",^), ",!
920 . . write ?indent,"or ENTER to continue: // "
921 . . read input:$get(DTIME,3600),!
922 . . if $TEST=0 set input="^"
923 . . if input="^" set field=-1 quit
924 . . if (+input>0)&(+input<(pickCt+1)) do
925 . . . set result=pickArray(+input)
926 . . . set field=0 ;"signal Done
927
928 if pickCt=0 write ?indent,"(All fields have already been selected.)",!
929PUFDone
930 quit result
931
932
933CfgOrderFields(File,pArray,indent)
934 ;"Purpose: To allow customization of fields ORDER
935 ;"Input: File -- name or number, file to get field numbers for
936 ;" pArray -- a pointer to (i.e. Name of) array to put field numbers into
937 ;" will probably be something one of the following:
938 ;" "Array(FileNumber,"TEMPLATE")"
939 ;" "Array(FileNumber,RecNumber)"
940 ;" indent -- a value to indent from the left margin
941 ;"Output: Data is put into pArray
942 ;"Result: 1 if OK to continue. 0 if user aborted.
943
944 new PriorErrorFound
945 new FileNumber,FileName
946 new field,count,index
947 new input
948 new DoneArray set DoneArray=""
949 new result set result=1
950 if ($get(File)="")!($get(pArray)="") set result=0 goto COFDone
951
952
953 if +File=File do
954 . set FileNumber=File
955 . set FileName=$$GetFName^TMGDBAPI(File)
956 else do
957 . set FileName=File
958 . set FileNumber=$$GetFileNum^TMGDBAPI(File)
959 if FileNumber'>0 do goto COFDone
960 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.")
961 set indent=+$get(indent,0)
962
963 if $data(@pArray)'>1 set @pArray@("*")=""
964 ;"if $data(@pArray@("*"))>0 do goto COFDone ;"ORDER not allowed if all records requested.
965 ;". write ?indent,"Note: skipping option for field ordering because ALL fields",!
966 ;". write ?indent,"were selected for export.",!
967 ;". write ?indent,"(This is a technical limitation of this routine.)",!!
968
969COFLoop
970 write ?indent,"Do you wish to customize the ORDER that ",!
971 write ?indent,"fields will appear in the XML file? (Y/N,^) NO// "
972 new input read input:$get(DTIME,3600),!
973 if $TEST=0 set input="^"
974 if input="^" set result=0 goto COFDone
975 if input="" set input="N"
976 set input=$$UP^XLFSTR(input)
977 if input'["Y" goto COFDone
978 if input="?" do goto COFLoop
979 . write ?indent,"If you want to specify the order that the fields will be exported, enter YES.",!
980
981COFL1
982 new maxNum set maxNum=0
983 set index=$order(@pArray@("ORDER",""))
984 if index'="" for do quit:(index="")
985 . new n set n=@pArray@("ORDER",index)
986 . if index>maxNum set maxNum=index
987 . set index=$order(@pArray@("ORDER",index))
988
989 set field=$order(@pArray@(""))
990 set count=0
991 new CountArray
992 if field'="" do
993 . write ?indent,"Choose one of the following fields:",!
994 if field'="" for do quit:(+field'>0)
995 . if $data(DoneArray(field))=0 do
996 . . set count=count+1
997 . . set CountArray(count)=field
998 . . write ?indent,count,". Field: ",field
999 . . if +field=field do
1000 . . . write " (",$$GetFldName^TMGDBAPI(File,field),")",!
1001 . . else write !
1002 . set field=$order(@pArray@(field))
1003 if count=0 do goto COFDone
1004 . write ?indent,"All done specifying field order.",!!
1005 . do Pause()
1006
1007COFL2
1008 if count>1 do
1009 . write ?indent,"Note: Don't enter actual field number.",!
1010 . write ?indent,"Which field should come "
1011 . if maxNum=0 write "first."
1012 . else write "next."
1013 . write "? (1-"_count_",^ to abort) "
1014 . read input,!!
1015 . if $TEST=0 set input="^"
1016 else do
1017 . write ?indent,"Only one option left, so I'll enter it for you...",!
1018 . set input=1
1019 if ((input<1)!(input>count))&(input'="^") goto COFL2
1020 if input="^" do set result=0 goto COFDone
1021 . kill @pArray@("ORDER")
1022 . write ?indent,"Because the process of specifying an order",!
1023 . write ?indent,"for the fields wasn't completed, the partial ",!
1024 . write ?indent,"order information was deleted.",!
1025 . do Pause(indent)
1026 set maxNum=maxNum+1
1027 new tempField set tempField=$get(CountArray(input))
1028 set @pArray@("ORDER",maxNum)=tempField
1029 set DoneArray(tempField)=""
1030 goto COFL1
1031
1032COFDone
1033 quit result
1034
1035
1036ShowArray(indent)
1037 ;"Purpose: To show the array that composes the XML export request
1038 if ($data(TMGxmlArray)>0)&($data(@TMGxmlArray)) do
1039 . write !
1040 . new i for i=1:1:indent set indent(i)=0
1041 . do ArrayDump^TMGDEBUG(TMGxmlArray,,.indent)
1042 . ;"zwr @TMGxmlArray
1043 . write !
1044 do Pause(.indent)
1045 quit
1046
1047
1048Pause(indent)
1049 ;"Purpose: To prompt user to hit enter to continue
1050 ;"Input: indent -- OPTIONAL -- number of spaces to indent from left margin.
1051 ;" Note: to call with no value for indent, use "do Pause()"
1052
1053 new temp
1054 set indent=$get(indent,0)
1055 write ?indent
1056 read "Press [Enter] to continue...",temp:$get(DTIME,3600),!
1057 quit
1058
1059WriteHeader(pHeader,SuppressLF)
1060 ;"Purpose: to put a header at the top of the screen
1061 ;" The screen will be cleared
1062 ;"Note: because global variable IOF is used, the VistA environement must be setup first.
1063 ;"Input: pHeader -- expected format:
1064 ;" pHeader(1)="First Line"
1065 ;" pHeader(2)="Second Line"
1066 ;" pHeader("MAX LINE")=2
1067 ;" SuppressLF -- OPTIONAL if =1, then extra LF suppressed
1068 ;"Result: none
1069
1070 write @IOF
1071 if $get(pHeader)="" goto WHDone
1072 new max set max=+$get(@pHeader@("MAX LINE"))
1073 if max=0 goto WHDone
1074 for index=1:1:max do
1075 . if $data(@pHeader@(index))=0 quit
1076 . new line set line=$get(@pHeader@(index))
1077 . if (line[" Step") do
1078 . . if (index<max) do
1079 . . . set line=$$Substitute^TMGSTUTL(line," Step","(X) Step")
1080 . . else do
1081 . . . set line=$$Substitute^TMGSTUTL(line," Step","(_) Step")
1082 . write line,!
1083
1084 if $get(SuppressLF)'=0 write !
1085
1086WHDone
1087 quit
1088
1089HdrAddLine(pHeader,Line)
1090 ;"Purpose: To add Line to end of header array
1091 ;"Input: pHeader -- expected format: (it is OK to pass an empty array to be filled)
1092 ;" pHeader(1)="First Line"
1093 ;" pHeader(2)="Second Line"
1094 ;" pHeader("MAX LINE")=2
1095 ;" Line -- a string to be added.
1096 ;"result: none
1097
1098 if $get(pHeader)="" goto HALDone
1099 if $get(Line)="" goto HALDone
1100 new max set max=+$get(@pHeader@("MAX LINE"))
1101
1102 set max=max+1
1103 set @pHeader@(max)=Line
1104 set @pHeader@("MAX LINE")=max
1105
1106HALDone
1107 quit
1108
1109
1110HdrDelLine(pHeader,index)
1111 ;"Purpose: To delete a line from the header
1112 ;"Input: pHeader -- expected format: (it is OK to pass an empty array to be filled)
1113 ;" pHeader(1)="First Line"
1114 ;" pHeader(2)="Second Line"
1115 ;" pHeader("MAX LINE")=2
1116 ;" index -- OPTIONAL -- default is to be the last line
1117
1118 if $get(pHeader)="" goto HDLDone
1119 new max set max=+$get(@pHeader@("MAX LINE"))
1120 if max=0 goto HDLDone
1121 set index=$get(index,0)
1122 if index=0 set index=max
1123 kill @pHeader@(index)
1124 if index<max for index=index:1:(max-1) do
1125 . set @pHeader@(index)=$get(@pHeader@(index+1))
1126 . kill @pHeader@(index+1)
1127
1128 set @pHeader@("MAX LINE")=max-1
1129
1130HDLDone
1131 quit
1132
1133Spaces(Num)
1134 ;"purpose to return Num number of spaces
1135 new result set result=""
1136 set Num=+$get(Num,0)
1137 if Num=0 goto SPCDone
1138 new i
1139 for i=1:1:Num set result=result_" "
1140
1141SPCDone
1142 quit result
1143
1144
1145
1146 ;"===================================================
1147
1148GetPtrsOut(File,Array)
1149 ;"Purpose: to return a list of all possible pointers out, for a given file
1150 ;"Input: File -- name or number of file to investigate
1151 ;" Array -- PASS BY REFERENCE. Output format:
1152 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1153 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1154 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1155 ;"Results: 1 if some found, 0 if no pointers out.
1156
1157 new FileNumber
1158 kill Array
1159 new found set found=0
1160
1161 if +File=File set FileNumber=File
1162 else set FileNumber=$$GetFileNum^TMGDBAPI(File)
1163
1164 new field set field=0
1165 for set field=$order(^DD(FileNumber,field)) quit:(field'>0) do
1166 . new fldInfo set fldInfo=$piece($get(^DD(FileNumber,field,0)),"^",2)
1167 . if fldInfo'["P" quit
1168 . new otherFile set otherFile=+$piece(fldInfo,"P",2)
1169 . if $$GetFName^TMGDBAPI(otherFile)="" do quit
1170 . set Array(FileNumber,"POINTERS OUT",field,otherFile)=""
1171 . set found=1
1172
1173 quit found
1174
1175
1176CustPtrOuts(Array,RecsArray)
1177 ;"Purpose: Given an array of pointers out (as created by GetPtrsOut), look at the
1178 ;" specific group of records (provided in RecsArray) and trim out theoretical
1179 ;" pointers, and only leave actual pointers in the list.
1180 ;"Input: Array PASS BY REFERENCE. Format:
1181 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1182 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1183 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1184 ;" RecsArray
1185 ;" RecsArray(FileNumber,IENinFile)=""
1186 ;" RecsArray(FileNumber,IENinFile)=""
1187 ;" RecsArray(FileNumber,IENinFile)=""
1188 ;" Note: Array may well have other information in it.
1189 ;"Output: Array pointer will be trimmed such that every pointer listed exists
1190 ;" in at least of the records in RecsArray
1191
1192 new fileNum,fieldNum,IEN
1193 set fileNum=""
1194 for set fileNum=$order(Array(fileNum)) quit:(+fileNum'>0) do
1195 . set fieldNum=""
1196 . for set fieldNum=$order(Array(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do
1197 . . ;"Now, for given file:field, do any records in RecsArray contain a value?
1198 . . new ref set ref=$get(^DIC(fileNum,0,"GL")) ;"record global ref string (open ended)
1199 . . new node set node=$get(^DD(fileNum,fieldNum,0)) ;"node=entire 0 node
1200 . . new np set np=$piece(node,"^",4) ;"get node;piece
1201 . . new n set n=$piece(np,";",1) ;"n=node
1202 . . new p set p=$piece(np,";",2) ;"p=piece
1203 . . set IEN=""
1204 . . new found set found=0
1205 . . for set IEN=$order(RecsArray(fileNum,IEN)) quit:(+IEN'>0)!(found=1) do
1206 . . . new tempRef set tempRef=ref_IEN_","""_n_""")"
1207 . . . new line set line=$get(@tempRef)
1208 . . . new ptr set ptr=+$piece(line,"^",p) ;"get data from database
1209 . . . if ptr>0 set found=1 quit ;"found at least one record in group has an actual pointer
1210 . . if found=1 quit ;"don't cut out the theoritical pointers (but no actual data)
1211 . . kill Array(fileNum,"POINTERS OUT",fieldNum)
1212
1213 quit
1214
1215
1216TrimPtrOut(Array)
1217 ;"Purpose: Given array of pointers out (as created by GetPtrsOut, or CustPtrsOut), ask which
1218 ;" other files should be ignored.
1219 ;"Input: Array. PASS BY REFERENCE. Format:
1220 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1221 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1222 ;"Output: for those pointers out that can be ignored, entries will be changed:
1223 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="-" <-- Ignore flag
1224 ;" Array(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="+" <-- Confirmed flag
1225
1226 ;"first, make a temp array that groups pointers out.
1227
1228 new Array2
1229 new fileNum set fileNum=0
1230 for set fileNum=$order(Array(fileNum)) quit:(+fileNum'>0) do
1231 . new fieldNum set fieldNum=0
1232 . new ref
1233 . for set fieldNum=$order(Array(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do
1234 . . new otherFileNum set otherFileNum=$order(Array(fileNum,"POINTERS OUT",fieldNum,""))
1235 . . if +otherFileNum'>0 quit
1236 . . new ref set ref=$name(Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum))
1237 . . new IEN set IEN=$order(^TMG(22708,"B",otherFileNum,""))
1238 . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=0 do quit
1239 . . . set Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum)="-"
1240 . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=1 do quit
1241 . . . set Array(fileNum,"POINTERS OUT",fieldNum,otherFileNum)="+"
1242 . . set Array2(otherFileNum,ref)=""
1243
1244 new menu,count
1245 new UsrInput,IEN
1246 new TMGFDA,TMGMSG,TMGIEN
1247 new ref,%,otherFileNum
1248 new otherFileNum
1249
1250 if $data(Array2)=0 goto TPODone
1251
1252 set menu(0)="Pick Which Pointers are NOT to User Data"
1253 set count=1
1254 set otherFileNum=0
1255 for set otherFileNum=$order(Array2(otherFileNum)) quit:(otherFileNum="") do
1256 . set menu(count)=$$GetFName^TMGDBAPI(otherFileNum)_$char(9)_otherFileNum_"^"_count
1257 . set count=count+1
1258
1259TPO set UsrInput=$$Menu^TMGUSRIF(.menu)
1260 if "x^"[UsrInput goto TPODone
1261 if UsrInput["?" do goto TPO
1262 . write "Explore which entry above? //"
1263 . new temp read temp:$get(DTIME,3600),!
1264 . set temp=$piece($get(menu(temp)),$char(9),2)
1265 . set temp=$piece(temp,"^",1)
1266 . if temp="" quit
1267 . new DIC,X,Y
1268 . set DIC(0)="MAEQ"
1269 . set DIC=+temp
1270 . write "Here you can use Fileman to look at entries in file #",temp
1271 . do ^DIC write !
1272 set ref=""
1273 set count=$piece(UsrInput,"^",2)
1274 set UsrInput=$piece(UsrInput,"^",1)
1275 for set ref=$order(Array2(UsrInput,ref)) quit:(ref="") do
1276 . set @ref="-"
1277 . kill menu(count)
1278 . set otherFileNum=+$piece(ref,",",4)
1279 set %=1
1280 set IEN=$order(^TMG(22708,"B",otherFileNum,""))
1281 if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=0 goto TPO
1282 write "Remember that ",$$GetFName^TMGDBAPI(otherFileNum)," DOESN'T contain ",!
1283 WRITE " site-specific data (stored in File #22708)"
1284 do YN^DICN write !
1285 if %'=1 goto TPO
1286 kill TMGMSG,TMGFDA,TMGIEN
1287 if +IEN>0 do
1288 . set TMGFDA(22708,IEN_",",1)=0
1289 . do FILE^DIE("","TMGFDA","TMGMSG")
1290 else do
1291 . set TMGFDA(22708,"+1,",.01)=otherFileNum
1292 . set TMGFDA(22708,"+1,",1)=0
1293 . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG")
1294 do ShowIfDIERR^TMGDEBUG(.TMGMSG)
1295 goto TPO
1296
1297TPODone
1298 if $data(menu)=0 goto TPOQ
1299 if $order(menu(0))="" goto TPOQ
1300 new Entry set Entry=0
1301 for set Entry=$order(menu(Entry)) quit:(Entry="") do
1302 . write " -- ",$piece(menu(Entry),$char(9),1),!
1303 write "Perminantly mark these files as CONTAINING site specific data"
1304 set %=1
1305 do YN^DICN write !
1306 if %=1 do
1307 . set Entry=0
1308 . for set Entry=$order(menu(Entry)) quit:(Entry="") do
1309 . . set UsrInput=$piece(menu(Entry),$char(9),2)
1310 . . set otherFileNum=$piece(UsrInput,"^",1)
1311 . . set ref=""
1312 . . for set ref=$order(Array2(otherFileNum,ref)) quit:(ref="") do
1313 . . . set @ref="+"
1314 . . set IEN=$order(^TMG(22708,"B",otherFileNum,""))
1315 . . if (IEN'=""),$piece($get(^TMG(22708,IEN,0)),"^",2)=1 quit
1316 . . if +IEN>0 do
1317 . . . set TMGFDA(22708,IEN_",",1)=1
1318 . . . do FILE^DIE("","TMGFDA","TMGMSG")
1319 . . else do
1320 . . . kill TMGIEN
1321 . . . set TMGFDA(22708,"+1,",.01)=otherFileNum
1322 . . . set TMGFDA(22708,"+1,",1)=1
1323 . . . do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG")
1324 . . do ShowIfDIERR^TMGDEBUG(.TMGMSG)
1325
1326TPOQ
1327 quit
1328
1329
1330GetRecsOut(RecsArray,PtrsArray,Array)
1331 ;"Purpose: For a given set of records in a file, determine the linked-to record #'s
1332 ;" in other files through pointers out. This will return the actual IEN's
1333 ;" in other files that are being pointed to.
1334 ;"Input -- PtrsArray. PASS BY REFERENCE. Format:
1335 ;" RecsArray(FileNumber,IENinFile)=""
1336 ;" RecsArray(FileNumber,IENinFile)=""
1337 ;" RecsArray(FileNumber,IENinFile)=""
1338 ;" Note: Array may well have other information in it.
1339 ;" RecsArray. PASS BY REFERENCE. Format:
1340 ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1341 ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)="-" <-- flag to ignore
1342 ;" PtrsArray(FileNumber,"POINTERS OUT",FieldNum,OtherFileNum)=""
1343 ;" Array. PASS BY REFERENCE. An OUT PARAMETER. Format:
1344 ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)=""
1345 ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)=""
1346 ;" Array(FileNumber,IEN,FieldNum,"LINKED TO",OtherFileNum,OtherIEN)=""
1347 ;" Array("X1",OtherFileNum,OtherIEN)=""
1348 ;" Array("X1",OtherFileNum,OtherIEN)=""
1349 ;"Output: Array is filled as above.
1350 ;"Results: None
1351
1352 new fileNum set fileNum=0
1353 for set fileNum=$order(PtrsArray(fileNum)) quit:(+fileNum'>0) do
1354 . new IEN set IEN=0
1355 . for set IEN=$order(RecsArray(fileNum,IEN)) quit:(+IEN'>0) do
1356 . . new fieldNum set fieldNum=0
1357 . . for set fieldNum=$order(PtrsArray(fileNum,"POINTERS OUT",fieldNum)) quit:(+fieldNum'>0) do
1358 . . . new otherFileNum set otherFileNum=$order(PtrsArray(fileNum,"POINTERS OUT",fieldNum,""))
1359 . . . if +otherFileNum'>0 quit
1360 . . . new flag set flag=$get(PtrsArray(fileNum,"POINTERS OUT",fieldNum,otherFileNum))
1361 . . . if flag="-" quit
1362 . . . new otherIEN set otherIEN=$$GET1^DIQ(fileNum,IEN_",",fieldNum,"I")
1363 . . . if +otherIEN'>0 quit
1364 . . . set Array(fileNum,IEN,fieldNum,"LINKED TO",otherFileNum,otherIEN)=""
1365 . . . if $data(RecsArray(otherFileNum,otherIEN))=0 do
1366 . . . . set Array("X1",otherFileNum,otherIEN)="tag=POINTED_TO_RECORD"
1367
1368 quit
1369
1370
1371
1372ExpandPtrs(pRecsArray)
1373 ;"Purpose: To take selected record set and include records from other files that
1374 ;" the selected records point to. Only records in files that marked as holding
1375 ;" site-specific data will be added
1376 ;"
1377 new changed
1378 new RecsArray
1379 new PtrsArray,Array
1380 merge RecsArray=@pRecsArray
1381T1
1382 set changed=0
1383 set fileNum=0
1384 for set fileNum=$order(RecsArray(fileNum)) quit:(fileNum="") do
1385 . if $$GetPtrsOut(fileNum,.PtrsArray)=0 goto TQuit
1386 . do CustPtrOuts(.PtrsArray,.RecsArray)
1387 . do TrimPtrOut(.PtrsArray)
1388 . do GetRecsOut(.RecsArray,.PtrsArray,.Array)
1389 . if $data(Array("X1")) do
1390 . . merge RecsArray=Array("X1")
1391 . . set changed=1
1392 . . kill Array("X1")
1393 if changed=1 goto T1
1394
1395TQuit
1396 merge @pRecsArray=RecsArray
1397 quit
1398
1399
1400Test
1401 new Recs,fileNum
1402
1403 if $data(^TMG("TMP","KILLTHIS"))=0 do
1404 . if $$UI^TMGXMLUI("RecsArray")=0 quit
1405 . merge ^TMG("TMP","KILLTHIS")=Recs
1406 else do
1407 . merge Recs=^TMG("TMP","KILLTHIS")
1408
1409 do ExpandPtrs("Recs")
1410
1411 quit
1412
1413
Note: See TracBrowser for help on using the repository browser.