| [796] | 1 | TMGTEST ;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
|
|---|
| 18 | A new Name write "this is a test",!
|
|---|
| 19 | read "Enter name:",Name,!
|
|---|
| 20 | write "Here is that name: ",Name,!
|
|---|
| 21 | quit
|
|---|
| 22 |
|
|---|
| 23 | B
|
|---|
| 24 | new name
|
|---|
| 25 | set name="kevin"
|
|---|
| 26 | read "input name",name,!
|
|---|
| 27 | set ^TMG("KILL LATER")=name
|
|---|
| 28 | quit
|
|---|
| 29 |
|
|---|
| 30 | N
|
|---|
| 31 | new n
|
|---|
| 32 | for n=1:1:10 do
|
|---|
| 33 | . write n,!
|
|---|
| 34 | quit
|
|---|
| 35 |
|
|---|
| 36 | Add1(X)
|
|---|
| 37 | quit X+1
|
|---|
| 38 |
|
|---|
| 39 | Fn(Name)
|
|---|
| 40 | write "That input value was: ",Name,!
|
|---|
| 41 | quit
|
|---|
| 42 |
|
|---|
| 43 | PG
|
|---|
| 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 |
|
|---|
| 54 | PB
|
|---|
| 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 |
|
|---|
| 65 | Esc
|
|---|
| 66 | new key
|
|---|
| 67 | for do quit:(key="x")!(key=27)
|
|---|
| 68 | . read *key
|
|---|
| 69 | . if key=27 write "You escaped!"
|
|---|
| 70 |
|
|---|
| 71 |
|
|---|
| 72 | T2
|
|---|
| 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 |
|
|---|
| 85 | MakeFile
|
|---|
| 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 |
|
|---|
| 110 | TEST
|
|---|
| 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 |
|
|---|
| 141 | TESTRPC
|
|---|
| 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 |
|
|---|
| 160 | TRPCDone
|
|---|
| 161 | write "goodbye.",!
|
|---|
| 162 |
|
|---|
| 163 | quit
|
|---|
| 164 |
|
|---|
| 165 | OR(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 |
|
|---|
| 176 | TERMLIST(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 |
|
|---|
| 189 | SIMPLE(input)
|
|---|
| 190 | quit "You said:"_input
|
|---|
| 191 |
|
|---|
| 192 |
|
|---|
| 193 | ImageUpload
|
|---|
| 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 |
|
|---|
| 212 | FIXRX
|
|---|
| 213 | new i,OI
|
|---|
| 214 | set i=""
|
|---|
| 215 | F2
|
|---|
| 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 |
|
|---|
| 232 | ELHTEST
|
|---|
| 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 |
|
|---|
| 242 | ELHTEST2
|
|---|
| 243 | for loop=1:1:10 do
|
|---|
| 244 | . write "Hello World",!
|
|---|
| 245 |
|
|---|
| 246 | quit
|
|---|
| 247 |
|
|---|
| 248 | ELHTEST3
|
|---|
| 249 | new i
|
|---|
| 250 | set i=1
|
|---|
| 251 | for do if i=3 quit
|
|---|
| 252 | . write i,!
|
|---|
| 253 | . set i=i+1
|
|---|
| 254 |
|
|---|
| 255 |
|
|---|
| 256 | ADDPT()
|
|---|
| 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 |
|
|---|
| 292 | ANPDone
|
|---|
| 293 | quit result
|
|---|
| 294 |
|
|---|
| 295 |
|
|---|
| 296 | X
|
|---|
| 297 | write "Hello " do write "And Then..." do write "Goodbye",!
|
|---|
| 298 | . write "There "
|
|---|
| 299 | quit
|
|---|
| 300 |
|
|---|
| 301 |
|
|---|
| 302 |
|
|---|
| 303 | TestKB
|
|---|
| 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 |
|
|---|
| 315 | P
|
|---|
| 316 | set PrintArray(59610)=""
|
|---|
| 317 | goto PR3
|
|---|
| 318 | Print
|
|---|
| 319 | ;"Test printing
|
|---|
| 320 | new PrintArray
|
|---|
| 321 | set DIC=8925
|
|---|
| 322 | set DIC(0)="MAEQ"
|
|---|
| 323 | PR2 do ^DIC write !
|
|---|
| 324 | if +Y>0 do goto PR2
|
|---|
| 325 | . set PrintArray(+Y)=""
|
|---|
| 326 | . write "Now pick another, or ^ when done picking",!
|
|---|
| 327 | PR3
|
|---|
| 328 | if $data(PrintArray) do
|
|---|
| 329 | . do PRINT^TMGTRAN1(.PrintArray)
|
|---|
| 330 |
|
|---|
| 331 | quit
|
|---|
| 332 |
|
|---|
| 333 |
|
|---|
| 334 | iodemo ;; "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 | ;
|
|---|
| 349 | io ;; 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 |
|
|---|
| 357 | io2demo
|
|---|
| 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 |
|
|---|
| 367 | i3
|
|---|
| 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 |
|
|---|
| 383 | JSELF1
|
|---|
| 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 |
|
|---|
| 397 | JSELF2
|
|---|
| 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 |
|
|---|
| 413 | Look4(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 |
|
|---|
| 429 | Ensure
|
|---|
| 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 |
|
|---|
| 445 | READ(timeout)
|
|---|
| 446 | D INITKB^XGF("*") ;"turn on escape processing
|
|---|
| 447 | set timeout=$get(timeout,1)
|
|---|
| 448 | write "Testing keyboard with timeout=",timeout," sec",!
|
|---|
| 449 |
|
|---|
| 450 | R2 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 |
|
|---|
| 463 | RDone
|
|---|
| 464 | do RESETKB^XGF ;"reset keyboard(escape processing off, terminators off)
|
|---|
| 465 |
|
|---|
| 466 | quit
|
|---|
| 467 |
|
|---|
| 468 | MathGame
|
|---|
| 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
|
|---|
| 474 | LOOP
|
|---|
| 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 |
|
|---|
| 500 | TGT
|
|---|
| 501 | new DIC
|
|---|
| 502 | set DIC=200,DIC(0)="MAEQ"
|
|---|
| 503 | do ^DIC
|
|---|
| 504 | write !,Y,!
|
|---|
| 505 | quit
|
|---|
| 506 |
|
|---|
| 507 |
|
|---|
| 508 | DNTest
|
|---|
| 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 |
|
|---|
| 530 | X12
|
|---|
| 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 |
|
|---|
| 551 | X13
|
|---|
| 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 |
|
|---|
| 562 | XFR
|
|---|
| 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 |
|
|---|
| 584 | nums
|
|---|
| 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 |
|
|---|
| 601 | MATH(num1,num2)
|
|---|
| 602 | quit (num1+num2)**2
|
|---|
| 603 |
|
|---|
| 604 | G(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 |
|
|---|
| 621 | CURRY(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 |
|
|---|
| 635 | GETFN()
|
|---|
| 636 | quit "MATH(X,Y)"
|
|---|
| 637 |
|
|---|
| 638 | FNTEST
|
|---|
| 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 |
|
|---|
| 646 | CLSCHED
|
|---|
| 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 |
|
|---|
| 678 | SHOWSCH
|
|---|
| 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 |
|
|---|
| 691 | TESTADD
|
|---|
| 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 |
|
|---|
| 715 | ADDSCH1
|
|---|
| 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"
|
|---|
| 727 | L0 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
|
|---|
| 741 | L1 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
|
|---|
| 747 | L2 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 |
|
|---|
| 766 | ASDone
|
|---|
| 767 | do CLSCHED
|
|---|
| 768 | quit
|
|---|
| 769 |
|
|---|
| 770 | ADDSCH2
|
|---|
| 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 |
|
|---|
| 794 | ADDSCH3
|
|---|
| 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 |
|
|---|
| 818 | xx1(var)
|
|---|
| 819 | write var,!
|
|---|
| 820 | quit
|
|---|
| 821 |
|
|---|
| 822 | xx2
|
|---|
| 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 |
|
|---|
| 832 | INT
|
|---|
| 833 | write "Starting an endless cycle. ESC to abort",!
|
|---|
| 834 | new abort set abort=0
|
|---|
| 835 | INT2 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
|
|---|
| 842 | INT3 write "Goodbye!",!
|
|---|
| 843 | quit
|
|---|
| 844 |
|
|---|
| 845 |
|
|---|
| 846 | SEND(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 |
|
|---|
| 858 | fields
|
|---|
| 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 |
|---|
