TMGTEST ;TMG/kst/Scratch fns for programming tests ;03/25/06 ;;1.0;TMG-LIB;**1**;09/01/05 new array set array="Fruits:" set array(1)="apple" set array(2)="pear" set array(3)="peach" zwr array new i,j,k for i=1:1:10 do .for j=1:1:10 do ..for k=1:1:10 do ...write "*" quit ;"Scratch function for various programming tests A new Name write "this is a test",! read "Enter name:",Name,! write "Here is that name: ",Name,! quit B new name set name="kevin" read "input name",name,! set ^TMG("KILL LATER")=name quit N new n for n=1:1:10 do . write n,! quit Add1(X) quit X+1 Fn(Name) write "That input value was: ",Name,! quit PG new i new startTime set startTime=$H write !,"Lets begin...",! for i=0:1:100 do . do ProgressBar^TMGUSRIF(i,"Progress",1,100,60,startTime) . hang (1) write !,"All done!...",! quit PB new pct for do quit:(pct'>-1) . read "enter percent: ",pct,! . if pct'>-1 quit . do ProgressBar^TMGUSRIF(pct,"Progress",0,100,60) . write ! quit Esc new key for do quit:(key="x")!(key=27) . read *key . if key=27 write "You escaped!" T2 D INIT^XPDID S XPDIDTOT=100 D TITLE^XPDID("hello world") D UPDATE^XPDID(50) F I=1:1:100 D . do UPDATE^XPDID(I) . hang (0.2) D EXIT^XPDID() quit MakeFile new handle set handle="TMGHandle" new path read "enter path: ",path,! new fname read "enter filename: ",fname,! write "Will create a binary test file: ",path,fname,! new input read "Continue? (Y/N) Y// ",input,! if "Yy"'[input quit set path=$$DEFDIR^%ZISH($get(path)) do OPEN^%ZISH(handle,path,fname,"W") if POP quit use IO new i,j for i=0:1:255 do . for j=0:1:255 do . . write $char(j) . . set $X=0 do CLOSE^%ZISH(handle) quit TEST new fname,path,gref set fname="triplegears.jpg" set fname2="triplegears2.jpg" set path="/var/local/OpenVistA_UserData/server-files/" set gref="^TMP(""TMG"",""x"",1)" kill ^TMP("TMG","x") write "Reading in file: ",path,fname,! w $$BFTG^TMGBINF(path,fname,gref,3),! ;"read in write "Now let's browse the original data...",! do BROWSE^TMGBVIEW(gref,3) write "Will now encode the data...",! do ENCODE^TMGRPC1(gref,3) write "Now let's browse the encoded data...",! do BROWSE^TMGBUTIL(gref,3) write "Now let's decode the data again...",! do DECODE^TMGRPC1(gref,3) write "Now let's browse the decoded data...",! do BROWSE^TMGBUTIL(gref,3) write "will now write out file to: ",path,fname2,! w $$GTBF^TMGBINF(gref,3,path,fname2),! ;"write out quit TESTRPC new fname,path set fname="triplegears.jpg" set path="/" new gref do GETFILE^TMGRPC1(.gref,path,fname) if $get(@gref@(0))=0 goto TRPCDone set gref=$name(@gref@(1)) write "Now let's browse the original (encoded) data...",! do BROWSE^TMGBVIEW(gref,3) write "Now let's decode the data again...",! do DECODE^TMGRPC1(gref,3) write "Now let's browse the decoded data...",! do BROWSE^TMGBUTIL(gref,3) TRPCDone write "goodbye.",! quit OR(a,b) new result set result=0 new mult set mult=1 for do quit:(a'>0)&(b'>0) . set result=result+(((a#2)!(b#2))*mult) . set a=a\2,b=b\2,mult=mult*2 quit result TERMLIST(GRef) new i kill ^TMP($J,"TMG-DATA") do LIST^DIC(3.2) if '$data(DIERR) do . set i=0 . for set i=$order(^TMP("DILIST",$J,2,i)) quit:(i="") do . . set ^TMP($J,"TMG-DATA",i)=$get(^TMP("DILIST",$J,2,i))_"^"_$get(^TMP("DILIST",$J,1,i)) kill ^TMP("DILIST",$J) set GRef=$name(^TMP($J,"TMG-DATA")) quit SIMPLE(input) quit "You said:"_input ImageUpload new params set params("NETLOCABS")="ABS^STUFFONLY" set params("magDFN")="5^70685" ;"DFN 70685 = TEST,KILLME DON'T set params("OBJType")="3^1" ;"type 1 is still image set params("FileExt")="EXT^JPG" set params("DateTime")="7^NOW" set params("DUZ")="8^73" ;"73 = my DUZ set params("Desc")="10^A sample upload image." do ADD^MAGGTIA(.results,.params) zwr results(*) quit FIXRX new i,OI set i="" F2 for set i=$o(^PSDRUG(i)) do quit:(i="") . s i2=i . s i=$o(^PSDRUG(i)) . q:i="" . w i2,": " . s name=$p($g(^PSDRUG(i2,0)),"^",1) . set OI=$p($get(^PSDRUG(i2,2)),"^",1) . write name,"-->",OI . if +OI>0 do . . if $d(^PS(50.7,OI))=0 do . . . w " BAD LINK",! . . . ;"set $P(^PSDRUG(i2,2),"^",1)="" . . else do . . . write " GOOD LINK",! . else write " (no link)",! ELHTEST write "Hello World",! New address1,address2 read "Enter street name:",address1,! read "Enter city/state:",address2,! write "The address is:",!,address1,!,address2,! set ^Eddie("line1")=address1 set ^Eddie("line2")=address2 quit ELHTEST2 for loop=1:1:10 do . write "Hello World",! quit ELHTEST3 new i set i=1 for do if i=3 quit . write i,! . set i=i+1 ADDPT() new TMGFDA,TMGIEN,TMGMsg read "Enter first name of test patient: ",FNAME,! if FNAME="^" quit 0 ;"Note: the "2" means file 2 (PATIENT file), and "+1" means "add entry" set TMGFDA(2,"+1,",.096)="`"_DUZ ;"field .096 = WHO ENTERED PATIENT (`DUZ=current user) set TMGFDA(2,"+1,",.01)="TEST,"_FNAME ;"field .01 = NAME set TMGFDA(2,"+1,",.02)="FEMALE" ;"field .02 = SEX set TMGFDA(2,"+1,",.03)="1/1/1980" ;"field .03 = DOB ;"set TMGFDA(2,"+1,",.09)="P" ;"field .09 = SSNUM ;"These fields below *USED TO BE* required. I changed the filemans status for these fields to NOT required set TMGFDA(2,"+1,",1901)="NO" ;"field 1901 = VETERAN Y/N --For my purposes, use NO set TMGFDA(2,"+1,",.301)="NO" ;"field .301 = "SERVICE CONNECTED?" -- required field set TMGFDA(2,"+1,",391)="NON-VETERAN (OTHER)" ;"field 391 = "TYPE" - required field do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMsg") if $data(TMGMsg("DIERR")) do . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . set result=0 . merge ErrArray("DIERR")=TMGMsg("DIERR") set result=+$get(TMGIEN(1)) ;"result is the added patient's IEN if result'>0 goto ANPDone ;"Now, manually add a record in the file 9000001 (^AUPNPAT) with IEN (stored in result) ;"This is done because some PATIENT fields don't point to the PATIENT file, but instead ;" point to the PATIENT/IHS file (9000001), which in turn points to the PATIENT file. set ^AUPNPAT(result,0)=result set ^AUPNPAT("B",result,result)="" if $data(Entry(.09)) do . set ^AUPNPAT(result,41,0)="^9000001.41P^1^1" . set ^AUPNPAT(result,41,1,0)="1^"_Entry(.09) ANPDone quit result X write "Hello " do write "And Then..." do write "Goodbye",! . write "There " quit TestKB new KEY,VK new i for do quit:(VK="") . S KEY=$$READ^%ZVEMKRN("",1,1) . S VK=VEE("K") . write "KEY=",KEY," VK=",VK,! quit P set PrintArray(59610)="" goto PR3 Print ;"Test printing new PrintArray set DIC=8925 set DIC(0)="MAEQ" PR2 do ^DIC write ! if +Y>0 do goto PR2 . set PrintArray(+Y)="" . write "Now pick another, or ^ when done picking",! PR3 if $data(PrintArray) do . do PRINT^TMGTRAN1(.PrintArray) quit iodemo ;; "demonstrate use of $x and wrapping Set file="/tmp/gtm"_$J_".tmp" Open file ;"Open file:(variable:nowrap) Use file Do io write !!,"--------------------",!! Use file:(wrap:width=120:length=70) Use file Do io Close file ZSYstem "cat "_file ZSystem "rm "_file Quit ; io ;; actual IO For i=1:1:70 Do . For j=1:1:6 do . . Write $Justify(i,2),",",$Justify(j,2),":" . . write " [",$Justify($x,3),",",$Justify($y,3),"] " . Write " EOL",! Quit io2demo do ^%ZIS use IO new i for i=1:1:125 do . write i,?5,$Y,! do ^%ZISC quit i3 do ^%ZIS use IO new i write $char(27),"E" write "Here is some text characters...",!!! write "========================",! for i=32:1:128 w $char(i) write !,"========================",! do ^%ZISC JSELF1 ;test 1 - build a temporary xref of Drug file. set start=$H s drugRef=$$glo^view1(50)_"DrugNo)" s getDrug=$$getvars^view1(50,"NtDrFlEn;PsVaPrNE(""DsgForm"");PsVaPrNE(""Strength"")") s DrugNo=0 f item=1:1 s DrugNo=$o(@drugRef) q:'DrugNo do . s @getDrug . s pArray(+NtDrFlEn,+PsVaPrNE("DsgForm"),+PsVaPrNE("Strength"),DrugNo)="" . s pArray("BY 50",DrugNo,+NtDrFlEn,+PsVaPrNE("DsgForm"))="" set end=$H write start,!,end,! zwr item quit JSELF2 ;test 2 - build a temporary xref of Drug file. set start=$H s drugRef="^PSDRUG(DrugNo)" s DrugNo=0 f item=1:1 s DrugNo=$o(@drugRef) q:'DrugNo do . s NtDrFlEn=$$GET1^DIQ(50,DrugNo_",","20","I") . s PsVaPrNE("DsgForm")=$$GET1^DIQ(50,DrugNo_",","22:1","I") . s PsVaPrNE("Strength")=$$GET1^DIQ(50,DrugNo_",","22:2") . s pArray(+NtDrFlEn,+PsVaPrNE("DsgForm"),+PsVaPrNE("Strength"),DrugNo)="" . s pArray("BY 50",DrugNo,+NtDrFlEn,+PsVaPrNE("DsgForm"))="" set end=$H write start,!,end,! zwr item quit Look4(IEN50) ;"Purpose: Look in "B" cross ref for IEN new IEN,name set name="" for set name=$order(^PSDRUG("B",name)) quit:(name="") do . set IEN="" . for set IEN=$order(^PSDRUG("B",name,IEN)) quit:(IEN="") do . . if IEN=IEN50 do . . . write IEN," ",name,! . . . write "--",$piece($get(^PSDRUG(IEN,0)),"^",1),! quit Ensure ;"research new IEN set IEN=159 ;"TEST,PERSON new TMGFDA,TMGIEN,TMGMSG set TMGFDA(200.04,"?+1,"_IEN_",",.01)="BILLY" do UPDATE^DIE("ES","TMGFDA","TMGIDE","TMGMSG") if $$ShowIfError^TMGDBAPI(.TMGMSG) quit do UPDATE^DIE("ES","TMGFDA","TMGIDE","TMGMSG") if $$ShowIfError^TMGDBAPI(.TMGMSG) quit quit READ(timeout) D INITKB^XGF("*") ;"turn on escape processing set timeout=$get(timeout,1) write "Testing keyboard with timeout=",timeout," sec",! R2 set s=$$READ^TMGWSCR(1,3) if s="^" goto RDone if s'="" goto R2 if XGRT'="" do goto R2 . if XGRT'="CR" write "[",XGRT,"]" quit . new temp set temp=$$READ^TMGWSCR(1,timeout) ;"double clicks must occur within ~1 sec . if (temp="")&(XGRT="CR") do . . write "[","DOUBLECLICK","]" . else do . . write "[CLICK]" . . do UNREAD^TMGWSCR(temp,XGRT) RDone do RESETKB^XGF ;"reset keyboard(escape processing off, terminators off) quit MathGame new n,i,st,et,tt new a,b new NCor,NWrong new NumQs set NumQs=20 new abort set abort=0 LOOP set st=$piece($H,",",2) set NCor=0,NWrong=0 for i=1:1:NumQs do quit:(abort=1) . set a=$random(10),b=$random(10) . write #,!! . write "#",i," What is ",a," x ",b,"? " . read n,! . if n="^" set abort=1 quit . if +n=(a*b) do . . write "CORRECT!",! . . set NCor=NCor+1 . else do . . write "WRONG. It is ",a*b,! . . set NWrong=NWrong+1 . . read "Press ENTER to continue...",n,! set et=$piece($H,",",2) set tt=et-st write "It took you ",tt," seconds to complete the game (",tt/NumQs," sec each)",! write "You had ",NCor," correct answers and ",NWrong," wrong answers.",! read "Do you want to play again? (y/n)? ",n,! if n="y" goto LOOP quit TGT new DIC set DIC=200,DIC(0)="MAEQ" do ^DIC write !,Y,! quit DNTest new tempArray new FILE set FILE=0 for set FILE=$O(^DD(FILE)) quit:'FILE do . new X . new field set field=0 . for set field=$order(^DD(FILE,field)) quit:(+field'>0) do . . if '($D(^DD(FILE,field,0))#2) quit . . set X=^DD(FILE,field,0) . . if $P(X,U,5,99)["DINUM" do . . . new P2 set P2=$piece(X,"^",2) . . . if P2'["P" write "!!-->",X,! quit . . . new targetFile . . . set targetFile=+$piece(P2,"P",2) . . . if targetFile=0 write "?? --->",X,! . . . set tempArray(targetFile,FILE)="" . . . set tempArray("B",FILE,targetFile)="" ;"zwr tempArray quit X12 new ref new output set ref="ExtraB" for set ref=$query(@ref) quit:(ref="") do . new s1,i . set s1=$qsubscript(ref,1) . new newRef set newRef="output("""_$qs(s1,0)_""")" . if $qlength(s1)>1 do . . for i=1:1:$qlength(s1) do . . . set newRef=$name(@newRef@($qsubscript(s1,i))) . for i=2:1:$qlength(ref) do . . set newRef=$name(@newRef@($qsubscript(ref,i))) . merge @newRef=@ref . ;"write ref," ---- :",newRef,! zwr output quit X13 new TMGdbgLine do INITKB^XGF() ;"set up keyboard input escape code processing set TMGdbgLine=$$READ^XGKB(,604800) ;"read TMGdbgLine,! write "[TMGXGRT=",TMGXGRT,"]",! write TMGdbgLine,! quit XFR set DIC=200 set DIC(0)="MAEQ" set DIC("A")="Enter FROM person: " do ^DIC write ! if +Y'>0 quit new FromIEN set FromIEN=+Y set DIC("A")="Enter TO person: " do ^DIC write ! if +Y'>0 quit new ToIEN set ToIEN=+Y new flags read "Enter mode flags (MOARX): ",flags do TRNMRG^DIT(flags,200,200,FromIEN_",",ToIEN_",") quit nums set IO=$P do IOCapON^TMGKERNL new i for i=1:1:1000 do . write "Num #",i,! new saved do IOCapOFF^TMGKERNL("saved") if $data(saved) zwr saved do PressToCont^TMGUSRIF quit MATH(num1,num2) quit (num1+num2)**2 G(Fn,v) ;"Purpose: To evaluate Fn pointer ;"Input: Fn -- Must be NAMe of function with format as follow: ;" 'SomeFunctionName("abc",-4,"99",.01,var)' ;" Note: the last variable may be of any name ;" v -- the value to be used in place of last variable in Fn ;"Output: Returns curried form of Fn NEW S SET S=$P($P(Fn,")",1),"(",2) NEW L SET L=$L(S,",") ;"Now substitue in value for variable IF L>1 SET $P(S,",",L)=v ELSE SET S=v NEW LFn set LFn=$P(Fn,"(",1)_"("_S_")" NEW R SET @("R=$$"_LFn) QUIT R CURRY(Fn,v) ;"Purpose: To create a curried form of Fn ;" e.g. 'MyFunct(A,B,C,D,...)' --> 'MyFunct(99,B,C,D,...)' ;"Input: Fn -- Must be NAMe of function with format as follow: ;" 'SomeFunctionName(A,B,C,D,...)' ;" Note: the first variable name may be any name ;" x -- the value to be used in function ;"Output: Returns curried form of Fn NEW S SET S=$P($P(Fn,")",1),"(",2) ;adadfsdasdf ;"Now substitue in value for variable IF $L(S,",")>1 SET $P(S,",",1)=v ELSE SET S=x quit $P(Fn,"(",1)_"("_S_")" ;"return curried form of function GETFN() quit "MATH(X,Y)" FNTEST new Fn set Fn=$$GETFN() new Fn2 set Fn2=$$CURRY(Fn,7) ;"Fn2 set to 'MATH(7,Y)' write $$G(Fn2,123) ;"Will effect MATCH(7,123) quit CLSCHED write !,"--- CLEAR SCHEDULE UTILITY --- CAUTION!!!",! new X,Y,DIC set DIC=44 set DIC(0)="MAEQ" do ^DIC write ! set Y=+Y if Y'>0 quit new % set %=2 write "Clear out ALL AVAILABILITY slots in this location" do YN^DICN write ! if %'=1 quit new D set D=0 for set D=$order(^SC(Y,"ST",D)) quit:(D'>0) do . kill ^SC(Y,"ST",D) set D=0 for set D=$order(^SC(Y,"OST",D)) quit:(D'>0) do . kill ^SC(Y,"OST",D) set D=0 for set D=$order(^SC(Y,"T",D)) quit:(D'>0) do . kill ^SC(Y,"T",D) new i for i=0:1:6 do . set D=0 . for set D=$order(^SC(Y,"T"_i,D)) quit:(D'>0) do . . kill ^SC(Y,"T"_i,D) write "done" quit SHOWSCH new i set i=0 new L1,L2,L3 set (L1,L2,L3)="" for set i=$order(^SC(10,"T1",i)) quit:(i'>0) do . new label set label=$get(^SC(10,"T1",i,1)) . set label=$e(label,1,7) . set L1=L1_" "_$$LJ^XLFSTR(label,8)_" " . set L2=L2_"+------->|" . set L3=L3_$$RJ^XLFSTR(i,10) write L1,!,L2,!,L3,! quit TESTADD new %,TMGIEN,DOW set TMGIEN=10 set DOW=1 for do quit:%'=1 . do SHOWSCH . set %=1 . write "Add range" do YN^DICN write ! . if %'=1 quit . new start,end,str . new %DT set %DT="EAF" . write "Enter starting " do ^%DT . set start=Y . write " Enter ending " do ^%DT . set end=Y . read " Enter string for range: ",str,! . do FILTEMPL^TMGSDAVS(start,end,1,str) . set %=1 do CLSCHED quit ADDSCH1 do SHOWSCH new % new TMGIEN set TMGIEN=10 new PATRN,MODE,MSG,Date1,Date2,Y set %=2 write "Clear clinic before starting" do YN^DICN write ! if %=-1 quit if %=1 do CLSCHED new %DT set %DT="EAF" L0 kill PATRN write "Enter Starting Date for template:" do ^%DT write ! if Y=-1 goto ASDone set Date1=Y write "Enter Range Ending Date ([ENTER] for 1 day only / indefinite pattern):" do ^%DT write ! set Date2=Y new % set %=1 if Date2<1 do . write "Use pattern indefinitely after starting date" do YN^DICN write ! . if %=1 set Date2="I" quit . set Date2="" if %=-1 goto ASDone new TimeRange,ApptsPerSlot new Result L1 read "Enter a time range (e.g. 0830-1145), ^ or [ENTER] if done: ",TimeRange,! if (TimeRange="^")!(TimeRange="") goto L2 read "Enter Appts Per Slot: ",ApptsPerSlot,! if ApptsPerSlot="^" goto L2 set PATRN(Date1_"^"_Date2,TimeRange)=ApptsPerSlot goto L1 L2 set flags="" set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG) if Result=1 write "Success!",! else do . write "Here is message array:",! . zwr MSG set %=2 write "View clinic array now" do YN^DICN write ! if %=-1 goto ASDone if %=1 do . write "Here is Clinic array now:",! . zwr ^SC(TMGIEN,*) set %=1 write "Add more patterns" do YN^DICN write ! if %=1 goto L0 ASDone do CLSCHED quit ADDSCH2 do SHOWSCH new TMGIEN set TMGIEN=10 new Result new PATRN,MODE,MSG,Date1,Date2,Y new %DT set %DT="" new X set X="12/15/2008" do ^%DT set Date1=Y set PATRN(Date1,"0830-1000")=2 set X="12/22/2008" do ^%DT set Date2=Y set PATRN(Date2,"0830-1000")=2 set flags="" set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG) if Result=1 write "Success!" else do . write "Here is message array:",! . zwr MSG write "Here is Clinic array now:",! zwr ^SC(TMGIEN,*) do CLSCHED quit ADDSCH3 do SHOWSCH new TMGIEN set TMGIEN=10 new Result new PATRN,MODE,MSG,Date1,Date2,Y new %DT set %DT="" new X set X="12/15/2008" do ^%DT set Date1=Y set PATRN(Date1_"^I","0830-1000")=2 set flags="" set Result=$$SETAVAIL^TMGSDAVS(TMGIEN,.PATRN,flags,.MSG) if Result=1 write "Success!" else do . write "Here is message array:",! . zwr MSG write "Here is Clinic array now:",! zwr ^SC(TMGIEN,*) do CLSCHED quit xx1(var) write var,! quit xx2 set s="hello" do xx1(s) set s=$char(9)_"hello" do xx1(s) new fn set fn="do xx1("""_s_""")" write fn,! xecute fn quit INT write "Starting an endless cycle. ESC to abort",! new abort set abort=0 INT2 if $$UserAborted^TMGUSRIF("from INT^TMGTEST") goto INT3 hang 0.1 if $get(TMGBRK)="??" do . zshow "*" . set TMGBRK="" if $get(TMGBRK)'="" quit goto INT2 INT3 write "Goodbye!",! quit SEND(DocID) new lst,info ; set TMGDEBUG=1 new pwd set pwd=" U(?Ec%U{," ;"set pwd="" 3U set info(1)=DocID_";1^1^1^E" do SEND^ORWDX(.list,70685,73,6,pwd,.info) quit fields S FILE=2,FIELD=0 F S FIELD=$O(^DD(FILE,FIELD)) Q:'FIELD do . S NODE=$G(^(FIELD,0)) . I NODE="" quit . S NAME=$P(NODE,U) . set REQUIRED=$P(NODE,U,2)["R" . set ID=''$D(^DD(FILE,0,"ID",FIELD)) . if REQUIRED set FIELD("1 REQUIRED",FIELD)=NAME . if ID set FIELD("2 IDENTIFIER",FIELD)=NAME . if REQUIRED&ID set FIELD("3 REQUIRED & IDENTIFIER",FIELD)=NAME . ;I REQUIRED!ID S FIELD(FIELD)=NAME_U_REQUIRED_U_ID zwr FIELD quit