source: cprs/branches/tmg-cprs/m_files/TMGTEST.m@ 1742

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

Initial upload

File size: 21.6 KB
RevLine 
[796]1TMGTEST ;TMG/kst/Scratch fns for programming tests ;03/25/06
2 ;;1.0;TMG-LIB;**1**;09/01/05
3
4 new array
5 set array="Fruits:"
6 set array(1)="apple"
7 set array(2)="pear"
8 set array(3)="peach"
9 zwr array
10 new i,j,k
11 for i=1:1:10 do
12 .for j=1:1:10 do
13 ..for k=1:1:10 do
14 ...write "*"
15 quit
16
17 ;"Scratch function for various programming tests
18A new Name write "this is a test",!
19 read "Enter name:",Name,!
20 write "Here is that name: ",Name,!
21 quit
22
23B
24 new name
25 set name="kevin"
26 read "input name",name,!
27 set ^TMG("KILL LATER")=name
28 quit
29
30N
31 new n
32 for n=1:1:10 do
33 . write n,!
34 quit
35
36Add1(X)
37 quit X+1
38
39Fn(Name)
40 write "That input value was: ",Name,!
41 quit
42
43PG
44 new i
45 new startTime set startTime=$H
46 write !,"Lets begin...",!
47 for i=0:1:100 do
48 . do ProgressBar^TMGUSRIF(i,"Progress",1,100,60,startTime)
49 . hang (1)
50
51 write !,"All done!...",!
52 quit
53
54PB
55 new pct
56 for do quit:(pct'>-1)
57 . read "enter percent: ",pct,!
58 . if pct'>-1 quit
59 . do ProgressBar^TMGUSRIF(pct,"Progress",0,100,60)
60 . write !
61
62 quit
63
64
65Esc
66 new key
67 for do quit:(key="x")!(key=27)
68 . read *key
69 . if key=27 write "You escaped!"
70
71
72T2
73 D INIT^XPDID
74 S XPDIDTOT=100
75 D TITLE^XPDID("hello world")
76 D UPDATE^XPDID(50)
77 F I=1:1:100 D
78 . do UPDATE^XPDID(I)
79 . hang (0.2)
80 D EXIT^XPDID()
81
82 quit
83
84
85MakeFile
86 new handle set handle="TMGHandle"
87 new path read "enter path: ",path,!
88 new fname read "enter filename: ",fname,!
89 write "Will create a binary test file: ",path,fname,!
90 new input
91 read "Continue? (Y/N) Y// ",input,!
92 if "Yy"'[input quit
93
94 set path=$$DEFDIR^%ZISH($get(path))
95 do OPEN^%ZISH(handle,path,fname,"W")
96 if POP quit
97 use IO
98
99 new i,j
100 for i=0:1:255 do
101 . for j=0:1:255 do
102 . . write $char(j)
103 . . set $X=0
104
105 do CLOSE^%ZISH(handle)
106
107
108 quit
109
110TEST
111 new fname,path,gref
112 set fname="triplegears.jpg"
113 set fname2="triplegears2.jpg"
114 set path="/var/local/OpenVistA_UserData/server-files/"
115 set gref="^TMP(""TMG"",""x"",1)"
116 kill ^TMP("TMG","x")
117
118 write "Reading in file: ",path,fname,!
119 w $$BFTG^TMGBINF(path,fname,gref,3),! ;"read in
120
121 write "Now let's browse the original data...",!
122 do BROWSE^TMGBVIEW(gref,3)
123
124 write "Will now encode the data...",!
125 do ENCODE^TMGRPC1(gref,3)
126
127 write "Now let's browse the encoded data...",!
128 do BROWSE^TMGBUTIL(gref,3)
129
130 write "Now let's decode the data again...",!
131 do DECODE^TMGRPC1(gref,3)
132
133 write "Now let's browse the decoded data...",!
134 do BROWSE^TMGBUTIL(gref,3)
135
136 write "will now write out file to: ",path,fname2,!
137 w $$GTBF^TMGBINF(gref,3,path,fname2),! ;"write out
138
139 quit
140
141TESTRPC
142 new fname,path
143 set fname="triplegears.jpg"
144 set path="/"
145 new gref
146
147 do GETFILE^TMGRPC1(.gref,path,fname)
148 if $get(@gref@(0))=0 goto TRPCDone
149 set gref=$name(@gref@(1))
150
151 write "Now let's browse the original (encoded) data...",!
152 do BROWSE^TMGBVIEW(gref,3)
153
154 write "Now let's decode the data again...",!
155 do DECODE^TMGRPC1(gref,3)
156
157 write "Now let's browse the decoded data...",!
158 do BROWSE^TMGBUTIL(gref,3)
159
160TRPCDone
161 write "goodbye.",!
162
163 quit
164
165OR(a,b)
166 new result set result=0
167 new mult set mult=1
168 for do quit:(a'>0)&(b'>0)
169 . set result=result+(((a#2)!(b#2))*mult)
170 . set a=a\2,b=b\2,mult=mult*2
171
172 quit result
173
174
175
176TERMLIST(GRef)
177
178 new i
179 kill ^TMP($J,"TMG-DATA")
180 do LIST^DIC(3.2)
181 if '$data(DIERR) do
182 . set i=0
183 . for set i=$order(^TMP("DILIST",$J,2,i)) quit:(i="") do
184 . . set ^TMP($J,"TMG-DATA",i)=$get(^TMP("DILIST",$J,2,i))_"^"_$get(^TMP("DILIST",$J,1,i))
185 kill ^TMP("DILIST",$J)
186 set GRef=$name(^TMP($J,"TMG-DATA"))
187 quit
188
189SIMPLE(input)
190 quit "You said:"_input
191
192
193ImageUpload
194
195 new params
196
197 set params("NETLOCABS")="ABS^STUFFONLY"
198 set params("magDFN")="5^70685" ;"DFN 70685 = TEST,KILLME DON'T
199 set params("OBJType")="3^1" ;"type 1 is still image
200 set params("FileExt")="EXT^JPG"
201 set params("DateTime")="7^NOW"
202 set params("DUZ")="8^73" ;"73 = my DUZ
203 set params("Desc")="10^A sample upload image."
204
205 do ADD^MAGGTIA(.results,.params)
206
207 zwr results(*)
208
209 quit
210
211
212FIXRX
213 new i,OI
214 set i=""
215F2
216 for set i=$o(^PSDRUG(i)) do quit:(i="")
217 . s i2=i
218 . s i=$o(^PSDRUG(i))
219 . q:i=""
220 . w i2,": "
221 . s name=$p($g(^PSDRUG(i2,0)),"^",1)
222 . set OI=$p($get(^PSDRUG(i2,2)),"^",1)
223 . write name,"-->",OI
224 . if +OI>0 do
225 . . if $d(^PS(50.7,OI))=0 do
226 . . . w " BAD LINK",!
227 . . . ;"set $P(^PSDRUG(i2,2),"^",1)=""
228 . . else do
229 . . . write " GOOD LINK",!
230 . else write " (no link)",!
231
232ELHTEST
233 write "Hello World",!
234 New address1,address2
235 read "Enter street name:",address1,!
236 read "Enter city/state:",address2,!
237 write "The address is:",!,address1,!,address2,!
238 set ^Eddie("line1")=address1
239 set ^Eddie("line2")=address2
240 quit
241
242ELHTEST2
243 for loop=1:1:10 do
244 . write "Hello World",!
245
246 quit
247
248ELHTEST3
249 new i
250 set i=1
251 for do if i=3 quit
252 . write i,!
253 . set i=i+1
254
255
256ADDPT()
257 new TMGFDA,TMGIEN,TMGMsg
258
259 read "Enter first name of test patient: ",FNAME,!
260 if FNAME="^" quit 0
261
262 ;"Note: the "2" means file 2 (PATIENT file), and "+1" means "add entry"
263 set TMGFDA(2,"+1,",.096)="`"_DUZ ;"field .096 = WHO ENTERED PATIENT (`DUZ=current user)
264 set TMGFDA(2,"+1,",.01)="TEST,"_FNAME ;"field .01 = NAME
265 set TMGFDA(2,"+1,",.02)="FEMALE" ;"field .02 = SEX
266 set TMGFDA(2,"+1,",.03)="1/1/1980" ;"field .03 = DOB
267 ;"set TMGFDA(2,"+1,",.09)="P" ;"field .09 = SSNUM
268 ;"These fields below *USED TO BE* required. I changed the filemans status for these fields to NOT required
269 set TMGFDA(2,"+1,",1901)="NO" ;"field 1901 = VETERAN Y/N --For my purposes, use NO
270 set TMGFDA(2,"+1,",.301)="NO" ;"field .301 = "SERVICE CONNECTED?" -- required field
271 set TMGFDA(2,"+1,",391)="NON-VETERAN (OTHER)" ;"field 391 = "TYPE" - required field
272
273 do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMsg")
274
275 if $data(TMGMsg("DIERR")) do
276 . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
277 . set result=0
278 . merge ErrArray("DIERR")=TMGMsg("DIERR")
279
280 set result=+$get(TMGIEN(1)) ;"result is the added patient's IEN
281 if result'>0 goto ANPDone
282
283 ;"Now, manually add a record in the file 9000001 (^AUPNPAT) with IEN (stored in result)
284 ;"This is done because some PATIENT fields don't point to the PATIENT file, but instead
285 ;" point to the PATIENT/IHS file (9000001), which in turn points to the PATIENT file.
286 set ^AUPNPAT(result,0)=result
287 set ^AUPNPAT("B",result,result)=""
288 if $data(Entry(.09)) do
289 . set ^AUPNPAT(result,41,0)="^9000001.41P^1^1"
290 . set ^AUPNPAT(result,41,1,0)="1^"_Entry(.09)
291
292ANPDone
293 quit result
294
295
296X
297 write "Hello " do write "And Then..." do write "Goodbye",!
298 . write "There "
299 quit
300
301
302
303TestKB
304 new KEY,VK
305 new i
306
307 for do quit:(VK="<ESC>")
308 . S KEY=$$READ^%ZVEMKRN("",1,1)
309 . S VK=VEE("K")
310 . write "KEY=",KEY," VK=",VK,!
311
312 quit
313
314
315P
316 set PrintArray(59610)=""
317 goto PR3
318Print
319 ;"Test printing
320 new PrintArray
321 set DIC=8925
322 set DIC(0)="MAEQ"
323PR2 do ^DIC write !
324 if +Y>0 do goto PR2
325 . set PrintArray(+Y)=""
326 . write "Now pick another, or ^ when done picking",!
327PR3
328 if $data(PrintArray) do
329 . do PRINT^TMGTRAN1(.PrintArray)
330
331 quit
332
333
334iodemo ;; "demonstrate use of $x and wrapping
335 Set file="/tmp/gtm"_$J_".tmp"
336 Open file
337 ;"Open file:(variable:nowrap)
338 Use file
339 Do io
340 write !!,"--------------------",!!
341 Use file:(wrap:width=120:length=70)
342 Use file
343 Do io
344 Close file
345 ZSYstem "cat "_file
346 ZSystem "rm "_file
347 Quit
348 ;
349io ;; actual IO
350 For i=1:1:70 Do
351 . For j=1:1:6 do
352 . . Write $Justify(i,2),",",$Justify(j,2),":"
353 . . write " [",$Justify($x,3),",",$Justify($y,3),"] "
354 . Write " EOL",!
355 Quit
356
357io2demo
358 do ^%ZIS
359 use IO
360 new i
361 for i=1:1:125 do
362 . write i,?5,$Y,!
363 do ^%ZISC
364 quit
365
366
367i3
368 do ^%ZIS
369 use IO
370 new i
371 write $char(27),"E"
372 write "Here is some text characters...",!!!
373 write "========================",!
374
375 for i=32:1:128 w $char(i)
376 write !,"========================",!
377 do ^%ZISC
378
379
380
381
382
383JSELF1
384 ;test 1 - build a temporary xref of Drug file.
385 set start=$H
386 s drugRef=$$glo^view1(50)_"DrugNo)"
387 s getDrug=$$getvars^view1(50,"NtDrFlEn;PsVaPrNE(""DsgForm"");PsVaPrNE(""Strength"")")
388 s DrugNo=0 f item=1:1 s DrugNo=$o(@drugRef) q:'DrugNo do
389 . s @getDrug
390 . s pArray(+NtDrFlEn,+PsVaPrNE("DsgForm"),+PsVaPrNE("Strength"),DrugNo)=""
391 . s pArray("BY 50",DrugNo,+NtDrFlEn,+PsVaPrNE("DsgForm"))=""
392 set end=$H
393 write start,!,end,!
394 zwr item
395 quit
396
397JSELF2
398 ;test 2 - build a temporary xref of Drug file.
399 set start=$H
400 s drugRef="^PSDRUG(DrugNo)"
401 s DrugNo=0 f item=1:1 s DrugNo=$o(@drugRef) q:'DrugNo do
402 . s NtDrFlEn=$$GET1^DIQ(50,DrugNo_",","20","I")
403 . s PsVaPrNE("DsgForm")=$$GET1^DIQ(50,DrugNo_",","22:1","I")
404 . s PsVaPrNE("Strength")=$$GET1^DIQ(50,DrugNo_",","22:2")
405 . s pArray(+NtDrFlEn,+PsVaPrNE("DsgForm"),+PsVaPrNE("Strength"),DrugNo)=""
406 . s pArray("BY 50",DrugNo,+NtDrFlEn,+PsVaPrNE("DsgForm"))=""
407 set end=$H
408 write start,!,end,!
409 zwr item
410 quit
411
412
413Look4(IEN50)
414 ;"Purpose: Look in "B" cross ref for IEN
415
416 new IEN,name
417
418 set name=""
419 for set name=$order(^PSDRUG("B",name)) quit:(name="") do
420 . set IEN=""
421 . for set IEN=$order(^PSDRUG("B",name,IEN)) quit:(IEN="") do
422 . . if IEN=IEN50 do
423 . . . write IEN," ",name,!
424 . . . write "--",$piece($get(^PSDRUG(IEN,0)),"^",1),!
425
426 quit
427
428
429Ensure
430 ;"research
431
432 new IEN set IEN=159 ;"TEST,PERSON
433 new TMGFDA,TMGIEN,TMGMSG
434 set TMGFDA(200.04,"?+1,"_IEN_",",.01)="BILLY"
435
436 do UPDATE^DIE("ES","TMGFDA","TMGIDE","TMGMSG")
437 if $$ShowIfError^TMGDBAPI(.TMGMSG) quit
438 do UPDATE^DIE("ES","TMGFDA","TMGIDE","TMGMSG")
439 if $$ShowIfError^TMGDBAPI(.TMGMSG) quit
440
441 quit
442
443
444
445READ(timeout)
446 D INITKB^XGF("*") ;"turn on escape processing
447 set timeout=$get(timeout,1)
448 write "Testing keyboard with timeout=",timeout," sec",!
449
450R2 set s=$$READ^TMGWSCR(1,3)
451
452 if s="^" goto RDone
453 if s'="" goto R2
454 if XGRT'="" do goto R2
455 . if XGRT'="CR" write "[",XGRT,"]" quit
456 . new temp set temp=$$READ^TMGWSCR(1,timeout) ;"double clicks must occur within ~1 sec
457 . if (temp="")&(XGRT="CR") do
458 . . write "[","DOUBLECLICK","]"
459 . else do
460 . . write "[CLICK]"
461 . . do UNREAD^TMGWSCR(temp,XGRT)
462
463RDone
464 do RESETKB^XGF ;"reset keyboard(escape processing off, terminators off)
465
466 quit
467
468MathGame
469 new n,i,st,et,tt
470 new a,b
471 new NCor,NWrong
472 new NumQs set NumQs=20
473 new abort set abort=0
474LOOP
475 set st=$piece($H,",",2)
476 set NCor=0,NWrong=0
477 for i=1:1:NumQs do quit:(abort=1)
478 . set a=$random(10),b=$random(10)
479 . write #,!!
480 . write "#",i," What is ",a," x ",b,"? "
481 . read n,!
482 . if n="^" set abort=1 quit
483 . if +n=(a*b) do
484 . . write "CORRECT!",!
485 . . set NCor=NCor+1
486 . else do
487 . . write "WRONG. It is ",a*b,!
488 . . set NWrong=NWrong+1
489 . . read "Press ENTER to continue...",n,!
490 set et=$piece($H,",",2)
491 set tt=et-st
492 write "It took you ",tt," seconds to complete the game (",tt/NumQs," sec each)",!
493 write "You had ",NCor," correct answers and ",NWrong," wrong answers.",!
494 read "Do you want to play again? (y/n)? ",n,!
495 if n="y" goto LOOP
496 quit
497
498
499
500TGT
501 new DIC
502 set DIC=200,DIC(0)="MAEQ"
503 do ^DIC
504 write !,Y,!
505 quit
506
507
508DNTest
509 new tempArray
510 new FILE set FILE=0
511 for set FILE=$O(^DD(FILE)) quit:'FILE do
512 . new X
513 . new field set field=0
514 . for set field=$order(^DD(FILE,field)) quit:(+field'>0) do
515 . . if '($D(^DD(FILE,field,0))#2) quit
516 . . set X=^DD(FILE,field,0)
517 . . if $P(X,U,5,99)["DINUM" do
518 . . . new P2 set P2=$piece(X,"^",2)
519 . . . if P2'["P" write "!!-->",X,! quit
520 . . . new targetFile
521 . . . set targetFile=+$piece(P2,"P",2)
522 . . . if targetFile=0 write "?? --->",X,!
523 . . . set tempArray(targetFile,FILE)=""
524 . . . set tempArray("B",FILE,targetFile)=""
525
526 ;"zwr tempArray
527
528 quit
529
530X12
531 new ref
532 new output
533 set ref="ExtraB"
534 for set ref=$query(@ref) quit:(ref="") do
535 . new s1,i
536 . set s1=$qsubscript(ref,1)
537 . new newRef set newRef="output("""_$qs(s1,0)_""")"
538 . if $qlength(s1)>1 do
539 . . for i=1:1:$qlength(s1) do
540 . . . set newRef=$name(@newRef@($qsubscript(s1,i)))
541 . for i=2:1:$qlength(ref) do
542 . . set newRef=$name(@newRef@($qsubscript(ref,i)))
543 . merge @newRef=@ref
544 . ;"write ref," ---- :",newRef,!
545
546 zwr output
547
548 quit
549
550
551X13
552 new TMGdbgLine
553 do INITKB^XGF() ;"set up keyboard input escape code processing
554
555 set TMGdbgLine=$$READ^XGKB(,604800)
556 ;"read TMGdbgLine,!
557 write "[TMGXGRT=",TMGXGRT,"]",!
558 write TMGdbgLine,!
559 quit
560
561
562XFR
563 set DIC=200
564 set DIC(0)="MAEQ"
565 set DIC("A")="Enter FROM person: "
566 do ^DIC write !
567 if +Y'>0 quit
568 new FromIEN set FromIEN=+Y
569
570 set DIC("A")="Enter TO person: "
571 do ^DIC write !
572 if +Y'>0 quit
573 new ToIEN set ToIEN=+Y
574
575 new flags
576 read "Enter mode flags (MOARX): ",flags
577
578 do TRNMRG^DIT(flags,200,200,FromIEN_",",ToIEN_",")
579
580 quit
581
582
583
584nums
585 set IO=$P
586 do IOCapON^TMGKERNL
587
588 new i
589 for i=1:1:1000 do
590 . write "Num #",i,!
591
592 new saved
593 do IOCapOFF^TMGKERNL("saved")
594 if $data(saved) zwr saved
595 do PressToCont^TMGUSRIF
596
597 quit
598
599
600
601MATH(num1,num2)
602 quit (num1+num2)**2
603
604G(Fn,v)
605 ;"Purpose: To evaluate Fn pointer
606 ;"Input: Fn -- Must be NAMe of function with format as follow:
607 ;" 'SomeFunctionName("abc",-4,"99",.01,var)'
608 ;" Note: the last variable may be of any name
609 ;" v -- the value to be used in place of last variable in Fn
610 ;"Output: Returns curried form of Fn
611 NEW S SET S=$P($P(Fn,")",1),"(",2)
612 NEW L SET L=$L(S,",")
613 ;"Now substitue in value for variable
614 IF L>1 SET $P(S,",",L)=v
615 ELSE SET S=v
616 NEW LFn set LFn=$P(Fn,"(",1)_"("_S_")"
617 NEW R SET @("R=$$"_LFn)
618 QUIT R
619
620
621CURRY(Fn,v)
622 ;"Purpose: To create a curried form of Fn
623 ;" e.g. 'MyFunct(A,B,C,D,...)' --> 'MyFunct(99,B,C,D,...)'
624 ;"Input: Fn -- Must be NAMe of function with format as follow:
625 ;" 'SomeFunctionName(A,B,C,D,...)'
626 ;" Note: the first variable name may be any name
627 ;" x -- the value to be used in function
628 ;"Output: Returns curried form of Fn
629 NEW S SET S=$P($P(Fn,")",1),"(",2) ;adadfsdasdf
630 ;"Now substitue in value for variable
631 IF $L(S,",")>1 SET $P(S,",",1)=v
632 ELSE SET S=x
633 quit $P(Fn,"(",1)_"("_S_")" ;"return curried form of function
634
635GETFN()
636 quit "MATH(X,Y)"
637
638FNTEST
639 new Fn set Fn=$$GETFN()
640 new Fn2 set Fn2=$$CURRY(Fn,7) ;"Fn2 set to 'MATH(7,Y)'
641 write $$G(Fn2,123) ;"Will effect MATCH(7,123)
642 quit
643
644
645
646CLSCHED
647 write !,"--- CLEAR SCHEDULE UTILITY --- CAUTION!!!",!
648 new X,Y,DIC
649 set DIC=44
650 set DIC(0)="MAEQ"
651 do ^DIC write !
652 set Y=+Y
653 if Y'>0 quit
654 new % set %=2
655 write "Clear out ALL AVAILABILITY slots in this location"
656 do YN^DICN write !
657 if %'=1 quit
658 new D set D=0
659 for set D=$order(^SC(Y,"ST",D)) quit:(D'>0) do
660 . kill ^SC(Y,"ST",D)
661 set D=0
662 for set D=$order(^SC(Y,"OST",D)) quit:(D'>0) do
663 . kill ^SC(Y,"OST",D)
664 set D=0
665 for set D=$order(^SC(Y,"T",D)) quit:(D'>0) do
666 . kill ^SC(Y,"T",D)
667 new i
668 for i=0:1:6 do
669 . set D=0
670 . for set D=$order(^SC(Y,"T"_i,D)) quit:(D'>0) do
671 . . kill ^SC(Y,"T"_i,D)
672
673 write "done"
674 quit
675
676
677
678SHOWSCH
679 new i set i=0
680 new L1,L2,L3 set (L1,L2,L3)=""
681 for set i=$order(^SC(10,"T1",i)) quit:(i'>0) do
682 . new label set label=$get(^SC(10,"T1",i,1))
683 . set label=$e(label,1,7)
684 . set L1=L1_" "_$$LJ^XLFSTR(label,8)_" "
685 . set L2=L2_"+------->|"
686 . set L3=L3_$$RJ^XLFSTR(i,10)
687 write L1,!,L2,!,L3,!
688 quit
689
690
691TESTADD
692 new %,TMGIEN,DOW
693 set TMGIEN=10
694 set DOW=1
695 for do quit:%'=1
696 . do SHOWSCH
697 . set %=1
698 . write "Add range" do YN^DICN write !
699 . if %'=1 quit
700 . new start,end,str
701 . new %DT set %DT="EAF"
702 . write "Enter starting " do ^%DT
703 . set start=Y
704 . write " Enter ending " do ^%DT
705 . set end=Y
706 . read " Enter string for range: ",str,!
707 . do FILTEMPL^TMGSDAVS(start,end,1,str)
708 . set %=1
709
710 do CLSCHED
711
712 quit
713
714
715ADDSCH1
716 do SHOWSCH
717 new %
718 new TMGIEN set TMGIEN=10
719 new PATRN,MODE,MSG,Date1,Date2,Y
720
721 set %=2
722 write "Clear clinic before starting" do YN^DICN write !
723 if %=-1 quit
724 if %=1 do CLSCHED
725
726 new %DT set %DT="EAF"
727L0 kill PATRN
728 write "Enter Starting Date for template:" do ^%DT write !
729 if Y=-1 goto ASDone
730 set Date1=Y
731 write "Enter Range Ending Date ([ENTER] for 1 day only / indefinite pattern):" do ^%DT write !
732 set Date2=Y
733 new % set %=1
734 if Date2<1 do
735 . write "Use pattern indefinitely after starting date" do YN^DICN write !
736 . if %=1 set Date2="I" quit
737 . set Date2=""
738 if %=-1 goto ASDone
739 new TimeRange,ApptsPerSlot
740 new Result
741L1 read "Enter a time range (e.g. 0830-1145), ^ or [ENTER] if done: ",TimeRange,!
742 if (TimeRange="^")!(TimeRange="") goto L2
743 read "Enter Appts Per Slot: ",ApptsPerSlot,!
744 if ApptsPerSlot="^" goto L2
745 set PATRN(Date1_"^"_Date2,TimeRange)=ApptsPerSlot
746 goto L1
747L2 set flags=""
748 set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG)
749 if Result=1 write "Success!",!
750 else do
751 . write "Here is message array:",!
752 . zwr MSG
753
754 set %=2
755 write "View clinic array now" do YN^DICN write !
756 if %=-1 goto ASDone
757 if %=1 do
758 . write "Here is Clinic array now:",!
759 . zwr ^SC(TMGIEN,*)
760
761 set %=1
762 write "Add more patterns" do YN^DICN write !
763 if %=1 goto L0
764
765
766ASDone
767 do CLSCHED
768 quit
769
770ADDSCH2
771 do SHOWSCH
772 new TMGIEN set TMGIEN=10
773 new Result
774 new PATRN,MODE,MSG,Date1,Date2,Y
775 new %DT set %DT=""
776 new X
777 set X="12/15/2008" do ^%DT set Date1=Y
778 set PATRN(Date1,"0830-1000")=2
779 set X="12/22/2008" do ^%DT set Date2=Y
780 set PATRN(Date2,"0830-1000")=2
781 set flags=""
782 set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG)
783 if Result=1 write "Success!"
784 else do
785 . write "Here is message array:",!
786 . zwr MSG
787
788 write "Here is Clinic array now:",!
789 zwr ^SC(TMGIEN,*)
790
791 do CLSCHED
792 quit
793
794ADDSCH3
795 do SHOWSCH
796 new TMGIEN set TMGIEN=10
797 new Result
798 new PATRN,MODE,MSG,Date1,Date2,Y
799 new %DT set %DT=""
800 new X
801 set X="12/15/2008" do ^%DT set Date1=Y
802 set PATRN(Date1_"^I","0830-1000")=2
803 set flags=""
804 set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG)
805 if Result=1 write "Success!"
806 else do
807 . write "Here is message array:",!
808 . zwr MSG
809
810 write "Here is Clinic array now:",!
811 zwr ^SC(TMGIEN,*)
812
813 do CLSCHED
814 quit
815
816
817
818xx1(var)
819 write var,!
820 quit
821
822xx2
823 set s="hello"
824 do xx1(s)
825 set s=$char(9)_"hello"
826 do xx1(s)
827 new fn set fn="do xx1("""_s_""")"
828 write fn,!
829 xecute fn
830 quit
831
832INT
833 write "Starting an endless cycle. ESC to abort",!
834 new abort set abort=0
835INT2 if $$UserAborted^TMGUSRIF("from INT^TMGTEST") goto INT3
836 hang 0.1
837 if $get(TMGBRK)="??" do
838 . zshow "*"
839 . set TMGBRK=""
840 if $get(TMGBRK)'="" quit
841 goto INT2
842INT3 write "Goodbye!",!
843 quit
844
845
846SEND(DocID)
847 new lst,info
848 ;
849 set TMGDEBUG=1
850 new pwd
851 set pwd=" U(?Ec%U{,"
852 ;"set pwd="" 3U
853 set info(1)=DocID_";1^1^1^E"
854 do SEND^ORWDX(.list,70685,73,6,pwd,.info)
855 quit
856
857
858fields
859 S FILE=2,FIELD=0
860 F S FIELD=$O(^DD(FILE,FIELD)) Q:'FIELD do
861 . S NODE=$G(^(FIELD,0))
862 . I NODE="" quit
863 . S NAME=$P(NODE,U)
864 . set REQUIRED=$P(NODE,U,2)["R"
865 . set ID=''$D(^DD(FILE,0,"ID",FIELD))
866 . if REQUIRED set FIELD("1 REQUIRED",FIELD)=NAME
867 . if ID set FIELD("2 IDENTIFIER",FIELD)=NAME
868 . if REQUIRED&ID set FIELD("3 REQUIRED & IDENTIFIER",FIELD)=NAME
869 . ;I REQUIRED!ID S FIELD(FIELD)=NAME_U_REQUIRED_U_ID
870 zwr FIELD
871 quit
Note: See TracBrowser for help on using the repository browser.