Index: cprs/branches/tmg-cprs/m_files/TMGDBAP2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGDBAP2.m~ (revision 796) +++ (revision ) @@ -1,1448 +1,0 @@ -TMGDBAP2 ;TMG/kst/Database API library 2 ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - - ;"This module holds moved functions from TMGDBAPI (moved due to size constraints) - -ConvertFDA(FDA,MarkerArray) - ;"Purpose: To convert all the IENS's in a FDA via ConvertIENS - ;"Input: FDA -- An FDA that need conversion. MUST PASS BY REFERENCE - ;" Expected FDA is as follows. I.e., expecting that - ;" there will only be ONE filenumber (the 19.01) part: - ;" FDA(*) - ;" }~19.01 - ;" }~?+4,?+2, - ;" | }~.01 = DIUSER - ;" | }~2 = FM2 - ;" | }~3 = 1 - ;" | - ;" }~?+5,?+2, - ;" | }~.01 = XMMGR - ;" | }~2 = X2 - ;" | }~3 = 1 - ;" | - ;" }~?+6,?+2, - ;" }~.01 = DIEDIT - ;" }~2 = Edit - ;" }~3 = 2 - ;" MarkerArray -- see documentation in ConvertIENS - ;"Output: FDA is changed - ;"Result: 1=OKToContinue, 0=Abort - - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cParentIENS set cParentIENS="ParentIENS" - new cRef set cRef="Ref" - - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") - - new result set result=1 - if $data(FDA)=0 set result=0 goto CvFDAQ - new FileNum - new Index - new IENS,OldIENS - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the FDA to convert") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the MarkerArray") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MarkerArray") - - set FileNum=$order(FDA("")) - if +FileNum=0 set result=0 goto CvFDAQ - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Looking at filenumber ",FileNum) - set IENS=$order(FDA(FileNum,"")) - for do quit:(IENS="") - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) - . if IENS="" do quit - . . set result=0 - . set OldIENS=IENS - . if $$ConvertIENS(.IENS,.MarkerArray)=0 do quit - . . set IENS="" - . . set result=0 - . if IENS'=OldIENS do - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Converted to IENS=",IENS) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Convert FDA(FileNumber,"""_OldIENS_""") to FDA(Filenumber,"""_IENS_""")") - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(FDA(FileNum,OLDIENS))=",$data(FDA(FileNum,OldIENS))) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is FDA so far") - . . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") - . . merge FDA(FileNum,IENS)=FDA(FileNum,OldIENS) - . . set IENS=$order(FDA(FileNum,OldIENS)) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"killing FDA(FileNumber,"_OldIENS_")") - . . kill FDA(FileNum,OldIENS) - . else do - . . set IENS=$order(FDA(FileNum,OldIENS)) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Resulting FDA so far") - . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of cycle. IENS=",IENS) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After conversion, here is the FDA.") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") - -CvFDAQ - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") - quit result - - -ConvertIENS(IENS,MarkerArray) - ;"Purpose: to convert an IENS such as "?+4,?+2," into "?+4,12345,", given - ;" the MarkerArray that corelates "2" to #"12345" - ;"Input: IENS -- the IENS string to convert. MUST PASS BY REFERENCE - ;" MarkerArray -- a composite array composed of results returned - ;" by database server, like below. SHOULD PASS BY REFERENCE - ;" MarkerArray(*) - ;" }~2 = 10033 - ;" }~0 = + - ;" }~4 = 12345 - ;" }~0 = + - ;"Output: IENS will be changed - ;"Result: 1=OkToContinue, 0=Abort - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cParentIENS set cParentIENS="ParentIENS" - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") - - new result set result=1 - new S set S="" - - if $data(IENS)#10=0 set result=0 goto CvIENSQ - if $data(MarkerArray)=0 set result=0 goto CvIENSQ - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Initial IENS=",IENS) - - new I set I=1 - for do quit:(I=-1) - . new Part,RecMarker - . set Part=$piece(IENS,",",I) - . ;";"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"Part="_Part_" --> ",0) - . if Part="" set I=-1 quit - . set RecMarker=+$translate(Part,"?+","") - . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"RecMarker="_RecMarker_" --> ",0) - . new tS set tS=$get(MarkerArray(RecMarker),Part) - . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"tS="_tS,1) - . set S=S_tS_"," - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"S so far=",S) - . set I=I+1 - - set IENS=S - -CvIENSQ - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") - quit result - - -SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) - ;"Purpose: to transfer from Data format to FDA format - ;"Input: Data - Data array should be in format output from GetRInfo - ;" FDA -- SHOULD BE PASSED BY REFERENCE (to receive results) - ;" parentIENS -- initial IENS.. the IENS of any PARENT record, or "" if no parent record - ;" SrchType -- should be "?", "+", or "?+" - ;" MarkNum -- -- SHOULD BE PASSED BY REFERENCE. A variable to ensure - ;" "?X" search term always has unique number. On first call, should=0 - ;" MsgArray -- SHOULD BE PASSED BY REFERENCE. An array that can accept - ;" messages back from function. - ;" -- One such type of message is a list of needed hackwrites. - ;" Format as follows: - ;" MsgArray(cHack,0,Entries)=2 - ;" MsgArray(cHack,1)="^VA(;200;?+1;.01;SomeData" - ;" MsgArray(cHack,1,cFlags)="H" - ;" MsgArray(cHack,2)="^VA(;200;?+1;.02;SomeMoreData" - ;" MsgArray(cHack,2,cFlags)="H" - ;" i.e. MsgArray(cHack,0,Entries)=Number of Entries - ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data - ;" MsgArray(n,cFlags)=User specified Flags for field. - ;" -- MsgArray(cRef,SubFileNumber)=Reference to Part of Data that created this. - ;" MsgArray(*) - ;" }~cRef - ;" }~1234.21 = "Data(6,".07") - ;" }~1234.2101 = "Data(6,".07",2,".04") - ;" Minimal -- OPTIONAL. 1=fill only .01 fields and subfile .01 fields - ;" RecNum -- OPTIONAL. If FDA is to be setup such that data is put into - ;" a specified record number, put that number here. - ;" !!! Note: I believe this is used erroneously here. A record number - ;" is not specified in the FDA. For calls to UPDATE^DIE to a specific - ;" record number, the FDA should have an IENS that is like "+1,", and then - ;" put the desired record number into the IEN_ROOT, like TMGIEN(1)=1234 - ;" with the "1" matching the "1" in TMGIEN(1) - ;"Output: FDA is changed if passed by reference. - ;"Returns: If should continue execution: 1=OK to continue. 0=abort. - - ;"Note: input Data array will be formated like this: - ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion - ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," - ;" Data(0,cRecNum)=2 <-- only if user-specified. - ;" Data(0,cEntries)=1 - ;" Data(1,".01")="MyData1" - ;" Data(1,".01",cMatchValue)="MyData1" - ;" Data(1,".02")="Bill" - ;" Data(1,".02",cMatchValue)="John" - ;" Data(1,".03")="MyData3" - ;" Data(1,".04")="MyData4" - ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" - ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" - ;" Data(1,".07",1,".01")="SubEntry1" - ;" Data(1,".07",1,".02")="SE1" - ;" Data(1,".07",1,".03")="'Some Info'" - ;" Data(1,".07",2,".01")="SubEntry2" - ;" Data(1,".07",2,".02")="SE2" - ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 - ;" Data(1,".07",2,".04",1,".01")="JD" - ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" - ;" ADDENDUM - ;" Data(1,".01",cFlags)=any flags specified for given field. - ;" only present if user specified. - - ;"Resulting FDA will look like this. - ;" i.e. FDA(1234,"?+1,10024,",.01)="MyData1" - ;" i.e. FDA(1234,"?+1,10024,",.02)="Bill" - ;" i.e. FDA(1234,"?+1,10024,",.03)="MyData3" - ;" i.e. FDA(1234,"?+1,10024,",.04)="MyData4" - ;" i.e. FDA(1234,"?+1,10024,",.06)="MyData5" - ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.01)="SubEntry1" - ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.02)="SE1" - ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.03)="'Some Info'" - ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.01)="SubEntry2" - ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.02)="SE2" - ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.03)="'Some Info'" - ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.01)="JD" - ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.02)="DOE,JOHN" - ;"(OR... reformat of above) - ;" FDA(*) - ;" }~1234 - ;" }~?+1,10024 - ;" }~.01 = MyData1 - ;" }~.02 = Bill - ;" }~.03 = MyData3 - ;" }~.04 = MyData4 - ;" }~.06 = MyData5 - ;" }~1234.21 - ;" }~?+2,?+1,10024 - ;" }~.01 = SubEntry1 - ;" }~.02 = SE1 - ;" }~.03 = 'Some Info' - ;" }~?+3,?+1,10024 - ;" }~.01 = SubEntry2 - ;" }~.02 = SE2 - ;" }~.03 = 'Some Info' - ;" }~1234.2101 - ;" }~?+4,?+3,?+1,10024 - ;" }~.01 = JD - ;" }~.02 = DOE,JOHN - - ;"MsgArray will hold the following - ;" MsgArray(*) - ;" }~"H" - ;" }~"Ref" - ;" }~1234.21 = "Data(6,".07") - ;" }~1234.2101 = "Data(6,".07",2,".04") - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cFile set cFile="FILE" ;"File" - new cHack set cHack="H" - new cFlags set cFlags="FLAGS" ;"Flags" - new cEntries set cEntries="Entries" - new cNoOverwrite set cNoOverwrite="N" - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") - - new result set result=cOKToCont - new index - new FieldNum - new FileNumber - new SubMarkNum set SubMarkNum=0 - new IENS set IENS="" - if $get(RecNum)="" kill RecNum - - set FileNumber=$get(Data(0,cFile)) - if +FileNumber=0 goto SFDAQ - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"parentIENS=",parentIENS) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SrchType=",SrchType) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",$get(RecNum)) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the Data array to work with:") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") - - set index=$order(Data(0)) - ;"Cycle through all entries (i.e. 1, 2, 3) - for do quit:(index="")!(result=cAbort) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index=",index) - . set FieldNum=$order(Data(index,"")) - . ;"Cycle through all fields (i.e. .01, .02, ,1223) - . for do quit:(FieldNum="")!(result=cAbort) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) - . . new NextFieldNum set NextFieldNum=$order(Data(index,FieldNum)) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NextFieldNum=",NextFieldNum) - . . if ($get(Data(index,FieldNum,cFlags))[cNoOverwrite)&(SrchType["?") do quit - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m0") - . . . set FieldNum=NextFieldNum - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NoOverwrite flag found, ignoring current field.") - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m1") - . . if (FieldNum=.01)!(IENS="") do - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m2") - . . . if $data(RecNum)#10=0 do - . . . . set MarkNum=+$get(MarkNum)+1 - . . . . set IENS=SrchType_MarkNum_","_$get(parentIENS) - . . . else do - . . . . set IENS=$get(RecNum)_","_$get(parentIENS) - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) - . . if $get(Data(index,FieldNum,cFlags))[cHack do ;"HACK PROCESSING - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Hack Processing") - . . . ;"Load hacks into a message array for later processing - . . . new NumHacks set NumHacks=$get(MsgArray(cHack,0,cEntries))+1 - . . . new Entry set Entry=Data(index,FieldNum) - . . . if $get(Data(index,FieldNum,cFlags))[cEncrypt do - . . . . set Entry=$$EN^XUSHSH(Entry) ;"encrypt data - . . . new Global set Global=$get(Data(0,cFile,cGlobal)) - . . . if Global="" do quit - . . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to local global name for file") - . . . . set result=cAbort - . . . set MsgArray(cHack,NumHacks)=Global_";"_FileNumber_";"_IENS_";"_FieldNum_";"_Entry - . . . set MsgArray(cHack,NumHacks,cFlags)=Data(index,FieldNum,cFlags) - . . else if $data(Data(index,FieldNum,0,cEntries)) do ;"SUB-FILE PROCESSING - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub-file processing") - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Addition of subfile entries encountered.") - . . . new tempData merge tempData=Data(index,FieldNum) - . . . new SubFileNum set SubFileNum=$get(Data(index,FieldNum,0,cFile),0) - . . . set MsgArray(cRef,SubFileNum)=$name(Data(index,FieldNum)) - . . . ;"call self recursively to handle subfile. - . . . new SubMarkNum set SubMarkNum=MarkNum - . . . set result=$$SetupFDA(.tempData,.FDA,IENS,SrchType,.SubMarkNum,.MsgArray,.Minimal) - . . . if SubMarkNum>MarkNum set MarkNum=SubMarkNum - . . else do ;"THE-USUAL-CASE PROCESSING - . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing usual case") - . . . if (FieldNum=.01)!($get(Minimal)'=1) do - . . . . new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")="_$get(Data(index,FieldNum)) - . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ts=",ts) - . . . . set FDA(FileNumber,IENS,FieldNum)=$get(Data(index,FieldNum)) - . . . if $data(Data(index,FieldNum,"WP")) do - . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Detected word-processor field") - . . . . merge FDA(FileNumber,IENS,FieldNum,"WP")=Data(index,FieldNum,"WP") - . . . . ;"if $get(TMGDEBUG)>0 do - . . . . ;". new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")=" - . . . . ;". ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE - . . . . ;". set ts=ts_$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) - . . . . ;". do DebugMsg^TMGDEBUG(.DBIndent,ts) - . . . . ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE - . . . . set FDA(FileNumber,IENS,FieldNum)=$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) - . . set FieldNum=NextFieldNum - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of field loop") - . set index=$order(Data(index)) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of index loop") - -SFDAQ - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is resulting FDA") - ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("FDA") ;"zwr FDA(*) - - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") - quit result - - - -OverwriteRec(RecNum,Data) - ;"Purpose: To stuff data from data array into record specified by RecNum. - ;" This function will not directly put any data into subfiles, but will - ;" call UploadData to handle this. - ;"Input: RecNum -- the record number (as returned by GetRecMatch) to put data into - ;" Data - Should be in format output from GetRInfo - ;"Output: database will be modified by changing record - ;"Returns: If should continue execution: 1=OK to continue. 0=abort. - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 - if $data(cAbort)#10=0 new cAbort set cAbort=0 - new cParentIENS set cParentIENS="ParentIENS" - - new result set result=cOKToCont - new Flags - new FileNumber,FieldNum,SubFileNum - new FieldFlags - new tmgFDA,TMGFDA,TMGMsg - new index - new IENS set IENS=$get(Data(0,cParentIENS)) - new FDAIndex - new MarkerArray - new MsgArray - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") - if $get(RecNum)=0 set result=cAbort goto OWQuit - - set FileNumber=Data(0,cFile) - set Flags="KE" ;"E=External format values; K=Func locks file during use. - - set IENS=$get(Data(0,cParentIENS)) - - new MarkNum set MarkNum=0 - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) - - ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data") - - set result=$$SetupFDA(.Data,.tmgFDA,IENS,"?",.MarkNum,.MsgArray,0,RecNum) - if result=cAbort goto OWQuit - set FileNum=$get(Data(0,cFile),0) if FileNum=0 set result=cAbort goto OWQuit - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MsgArray") - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") - ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) - - if $data(tmgFDA)=0 do goto OWPast ;"This can happen with single records with NoOverwrite flag - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No data to file with fileman, so skipping.") - - set FDAIndex=FileNum - kill TMGFDA - merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing "_FDAIndex_" part of tmgFDA") - ; - set Flags="E" ;"E=External format values - ; - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the TMGFDA to pass to FILE^DIE") - ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) - ; - ;"====================================================== - ;"Call FILE^DIE - ;"====================================================== - if $data(TMGFDA)=0 set result=cAbort quit - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") - do - . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, FILE^DIE is for working with records that already exist.") - . set ^TMP("TMG",$J,"ErrorTrap")=result - . set ^TMP("TMG",$J,"Caller")="FILE^DIE" - . do FILE^DIE(Flags,"TMGFDA","TMGMsg") - . set result=^TMP("TMG",$J,"ErrorTrap") - . kill ^TMP("TMG",$J,"ErrorTrap") - . kill ^TMP("TMG",$J,"Caller") - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") - ;"====================================================== - ;"====================================================== - ;" - if $data(TMGMsg("DIERR")) do goto OWQuit - . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . set result=cAbort - - if result=cAbort goto OWQuit - - kill tmgFDA(FDAIndex) - set FDAIndex="" ;"I don't want to loop through rest of tmgFDA, will handle below. - -OWPast - set result=$$HandleHacksArray^TMGDBAPI(.MsgArray) - if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Error in writing record") goto OWQuit - - ;"Now we handle possible subfile entries. Info regarding these is in MsgArray - if $data(MsgArray(cRef))'=0 do - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Handling subfile entries.") - . set SubFileNum=$order(MsgArray(cRef,"")) - . for do quit:(+SubFileNum=0)!(result=cAbort) - . . if +SubFileNum=0 quit - . . new SubData,DataP - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFileNum="_SubFileNum) - . . set DataP=MsgArray(cRef,SubFileNum) - . . merge SubData=@DataP - . . set SubData(0,cParentIENS)=RecNum_","_IENS - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub IENS="_RecNum_","_IENS) - . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DataP="_DataP) - . . set result=$$UploadData^TMGDBAPI(.SubData) - . . set SubFileNum=$order(MsgArray(cRef,SubFileNum)) - -OWQuit - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") - quit result - - -GetFileNum(FileName) - ;"Purpose: Convert a file name into a file number - ;"Input: The name of a file - ;"Result: The filenumber, or 0 if not found. - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") - new result set result=0 - - if $get(FileName)="" goto GtFlNumDone - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") - - if FileName=" " do goto GtFlNumDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") - . set result=0 - - set DIC=1 ;"File 1=Global file reference (the file listing info for all files) - set DIC(0)="M" - set X=FileName ;"i.e. "AGENCY" - do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) - set result=$piece(Y,"^",1) - if result=-1 set result=0 - -GtFlNumDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") - quit result - - -GetFName(FileNumber) - ;"Purpose: Convert a file number into a file name - ;"Input: The number of a file - ;"Result: The file name, or "" if not found. - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") - new result set result="" - - if $get(FileNumber)=0 goto GtFlNumDone - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Number='"_FileNumber_"'") - - set result=$get(^DIC(FileNumber,0)) - if (result="")&(FileNumber[".") do - . set result=$get(^DD(FileNumber,0)) - set result=$piece(result,"^",1) - -GtFNmDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") - quit result - - -GetFldName(File,FieldNumber) - ;"Purpose: Convert a field number into a field name - ;"Input: File -- name or number of file - ;" FieldNumber -- the number of the field to convert - ;"Result: The field name, or "" if not found. - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") - new result set result="" - new array - do GetFieldInfo^TMGDBAPI(.File,.FieldNumber,"array","LABEL") - set result=$get(array("LABEL")) - -GFldNmDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") - quit result - - -GetFldList(File,pArray) - ;"Purpose: Get list of all fields for a file. - ;"Input: File -- File name or number to look query. May be a sub file number - ;" pArray -- pointer to (i.e. name of) array to put data into - ;" Any preexisting data in pArray will be killed. - ;"Output: Array will be fille with info like this: - ;" example: Array(.01)=""<--- shows that field .01 exists - ;" Array(1)="" <--- shows that field 1 exists - ;" Array(2)="" <--- shows that field 2 exists - ;"Results: 1=OK to continue. 0=error - - new result set result=1 - new FileNumber,FileName - if ($get(File)="")!($get(pArray)="") set result=0 goto GFdLDone - kill @pArray - - if +File=File do - . set FileNumber=File - . set FileName=$$GetFName(File) - else do - . set FileName=File - . set FileNumber=$$GetFileNum(File) - if FileNumber'>0 do goto GFdLDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") - . set result=0 - - new index set index=$order(^DD(FileNumber,0)) - if +index>0 for do quit:(+index'>0) - . set @pArray@(index)="" - . set index=$order(^DD(FileNumber,index)) - -GFdLDone - quit result - - -SetupFileNum(Data) - ;"Purpose: To Ensure that Data(0,cFile) contains valid file number - ;"Input: Data-- should be passed by reference, Array setup by GetRInfo - ;" Specifically, Data(0,cFile) should have file name OR number - ;"Output: Data is changed: - ;" Data(0,cFile)=FileNumber - ;" Data(0,cFile,cGlobal)=Global reference name ;i.e. "^VA(200)" - ;" Data(0,cFile,cGlobal,cOpen)=Open Global reference name ;i.e. "^VA(200," - ;"Returns: If should continue execution: 1=OK to continue. 0=abort. - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cFile set cFile="FILE" ;"File" - new cGlobal set cGlobal="GLOBAL" - new cOpen set cOpen="OPEN" - - new result set result=cOKToCont - new FileNumber,FileName,File - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Data passed to SetupFileNum") - ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") ;"zwr Data(*) - - set File=$get(Data(0,cFile)," ") - if +File'=0 do goto CKFileNum - . set FileNumber=File - set FileName=File - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") - - if FileName=" " do goto SFNDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") - . set result=cAbort ;"0=Abort - - ;"Note: I could replace this code with GetFileNum(FileName) - ;"---------------- - set DIC=1 ;"File 1=Global file reference (the file listing info for all files) - set DIC(0)="M" - set X=FileName ;"i.e. "AGENCY" - do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) - set FileNumber=$piece(Y,"^",1) - ;"---------------- - -CKFileNum - set Data(0,cFile)=FileNumber - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Uploading to File number: "_FileNumber) - ;"if $data(FileName) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"('",FileName,"' file)") - if FileNumber=-1 do goto SFNDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to locate file specified as #"_FileNumber_" or '"_FileName_"'.") - . set result=cAbort ;"0=Abort - if $$VFILE^DILFD(FileNumber)=0 do goto SFNDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") - . set result=cAbort ;"0=Abort - - set Global=$get(^DIC(FileNumber,0,"GL"),"INVALID") ;"^DIC is file 1/FILE - set Data(0,cFile,cGlobal,cOpen)=Global - ;"Convert global form of ^VA(200, into ^VA(200) - new Len - set Len=$length(Global) - if $extract(Global,Len)="," do - . set $extract(Global,Len)=")" - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"The global file to access is: "_Global) - set Data(0,cFile,cGlobal)=Global - -SFNDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") - - quit result - - - -RecFind(Params) - ;"Purpose: To look through a file and find matching record - ;"Input -- Params(cFile)=File name or number - ;" Params(FieldNumber)=LookupValue - ;" Params(FieldNumber)=LookupValue - ;" - ;" e.g. Params(0,cFile)="PERSON CLASS" - ;" Params(.01)="Physicians (M.D. and D.O.)" - ;" Params(1)="Physician/Osteopath" - ;" Params(2)="Family Practice" - ;" - ;"Note: Does not support searching based on subfile data. - ;"Output -- (via results) - ;"Result -- Returns record number file, OR 0 if not found - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") - - if $data(cFile)=0 new cFile set cFile="FILE" - if $data(cEntries)=0 new cEntries set cEntries="Entries" - if $data(cMatchValue)=0 new cMatchValue set cMatchValue="MATCHVALUE" - new result set result=0 - new Data - new RecNum - new FieldNum - - set Data(0,cFile)=$get(Params(0,cFile)) - if Data(0,cFile)="" goto RFDone - if $$SetupFileNum(.Data)=0 goto RFDone - set Data(0,cEntries)=1 - - set FieldNum=$order(Params(0)) - for do quit:(+FieldNum=0) - . if +FieldNum=0 quit - . set Data(1,FieldNum,cMatchValue)=$get(Params(FieldNum)) - . set FieldNum=$order(Params(FieldNum)) - - if $$GetRecMatch^TMGDBAPI(.Data,.RecNum)=0 goto RFDone - set result=RecNum - -RFDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") - quit result - - - -FieldCompare(TestField,dbField,Type) - ;"PURPOSE: To compare two fields and return a comparison code - ;"INPUT: TestField -- User input to be tested (in "external format"). **Don't pass by Ref** - ;" dbField -- data from database to be tested. **Don't pass by Ref - ;" Type -- (Optional) The type of data being compared: - ;" "NORMAL" or "" -- Simple comparison carried out (i.e. 'if A=B') - ;" "DATE" -- the two values are date/time values - ;" "SSNUM"-- the two values are social security numbers - ;" "SEX" -- the two values are Sex descriptors. - ;" "NUMBER" -- the two values are numbers - ;"Results: - ;" return value = cConflict (0) if entries conflict - ;" i.e. TestField="John" vs dbField="Bill" - ;" return value = cFullMatch (1) if entries completely match - ;" ie. TestField="John" vs dbField="John" - ;" or TestField="" vs. dbField="" - ;" return value = cExtraInfo (2) if entries have no conflict, but TestField has extra info. - ;" i.e. TestField="John" vs. dbField="" - ;" return value = cdbExtraInfo (3) if entries have no conflict, but dbField has extra info. - ;" i.e. TestField="" vs. dbField="12345" - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") - - if $data(cConflict)#10=0 new cConflict set cConflict=0 - if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 - if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 - if $data(cdbExtraInfo)#10=0 new cdbExtraInfo set cdbExtraInfo=3 - - set TestField=$get(TestField) - set dbField=$get(dbField) - set Type=$get(Type) - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField=",TestField) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField=",dbField) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Type=",Type) - - new result set result=cConflict - - if Type="DATE" do - . set TestField=$$IDATE^TIULC(TestField) - . set dbField=$$IDATE^TIULC(dbField) - else if Type="SSNUM" do - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing SSNUM's") - . set TestField=$translate(TestField," /-","") ;"Clean delimiters - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) - . if TestField["P" set TestField="P" - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) - . if dbField["P" set dbField="P" - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField now=",dbField) - else if Type="SEX" do - . if (TestField="m")!(TestField="M") set TestField="MALE" - . if (TestField="f")!(TestField="F") set TestField="FEMALE" - - if TestField'="" do - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(dbField)=",$data(dbField)) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$get(dbField)='' =",($get(dbField)="")) - . if ($data(dbField)#10=0)!($get(dbField)="") set result=cExtraInfo - . else do - . . if Type="NUMBER" do - . . . if +TestField=+dbField set result=cFullMatch - . . else do - . . . if TestField=dbField set result=cFullMatch - else do ;"i.e. test case when TestField="" - . if $get(dbfield)="" set result=cFullMatch - . else set result=cdbExtraInfo - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") - - quit result - - -EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) - ;"Purpose: To provide code to that will ensure that data is written to - ;" the database, but it will not add duplicate records if the value - ;" is already there. So a FIND is done first, and added if not found. - ;" Note: This is primarly targeted at adding entries in a subfile. - ;"Input: File -- File name or number - ;" Field -- Field name or number - ;" IENS -- standard IENS string describing IEN in File, or IEN path to subfile - ;" Value -- The value to be filed - ;" Flags -- Flags to be passed - ;" MsgArray -- PASS BY REFERENCE. Messages to pass back out. - ;"Results : 1=Writen OK, 0=Already present so not written, -1=error - - new result set result=-1 - - - quit result - - - -dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) - ;"Purpose: To provide a unified interface for writing a FDA to the database - ;"Input: FDA -- PASS BY REFERENCE. A standard FDA structure. (won't be changed) - ;" Overwrite -- specifies if records already exist in database - ;" if = 1, then FILE^DIE used to write into pre-existing records - ;" if = 0, then UPDATE^DIE used to write new records - ;" TMGIEN (OPTIONAL)-- an array to receive back records added (only applies if - ;" Overwrite=0) - ;" It can also be used to pass info to UPDATE^DIE recarding requested record numbers - ;" Flags (OPTIONAL) -- Flags to pass to UPDATE^DIE or FILE^DIE. - ;" default is "E". If "E" is not wanted, then pass a " " - ;" ErrArray (OPTIONAL) -- an OUT parameter to receive fileman "DIERR" results, if any - ;"Results --1 if OK, or 0 if error - - merge ^TMG("TMP","EDDIE","FDA")=FDA ;"TEMP!! - - set Overwrite=$get(Overwrite,0) - new TMGFDA merge TMGFDA=FDA - new TMGMsg - new TMGFlags set TMGFlags=$get(Flags,"E") ;"E=External values - if TMGFlags=" " set TMGFlags="" - if (Overwrite=1)&($get(Flags)'="") set TMGFlags=TMGFlags_"K" ;"K means filer does file locking. - - new result set result=1 ;"Default to success - if $data(TMGFDA)=0 set result=-1 goto DBWDone - - set ^TMP("TMG",$J,"ErrorTrap")=result - ;"====================================================== - ;"====================================================== - if Overwrite=1 do ;"i.e. FILE^DIE used to write into pre-existing records - . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . set ^TMP("TMG",$J,"Caller")="FILE^DIE" - . do FILE^DIE(TMGFlags,"TMGFDA","TMGMsg") - else if Overwrite=0 do ;"i.e. UPDATE^DIE used to write new records - . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" - . do UPDATE^DIE(TMGFlags,"TMGFDA","TMGIEN","TMGMsg") - ;"====================================================== - ;"====================================================== - set result=^TMP("TMG",$J,"ErrorTrap") - kill ^TMP("TMG",$J,"ErrorTrap") - kill ^TMP("TMG",$J,"Caller") - - if $data(TMGMsg("DIERR")) do - . ;"TMGDEBUG=-1 --> extra quiet mode - . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . set result=0 - . merge ErrArray("DIERR")=TMGMsg("DIERR") - -DBWDone - quit result - - -DelIEN(File,RecNumIEN,ErrArray) - ;"Purpose: To delete record# RecNumIEN from file FILE - ;"Input: File -- File name or number to delete from - ;" RecNumIEN -- the IEN to delete - ;" ErrArray --OPTIONAL, PASS BY REFERENCE. - ;" an OUT parameter to receive fileman "DIERR" results, if any - ;"Output: will cause deletion from database - ;"Results -- if error occured - ;" cOKToCont (i.e. 1) if no error - ;" cAbort (i.e. 0) if error - - new TMGFDA,result - set result=0 - - if $get(File)="" goto DIENDone - if +$get(RecNumIEN)'>0 goto DIENDone - if +File'>0 set File=$$GetFileNum(File) - - set TMGFDA(File,+RecNumIEN_",",.01)="@" - set result=$$dbWrite(.TMGFDA,1,,,.ErrArray) - -DIENDone - quit result - - -WriteWP(File,RecNumIEN,Field,TMGArray) - ;"Purpose: To provide a shell around WP^DIE with error trap, error reporting - ;"Note: This does not support subfiles or multiples. Does not support appending - ;"Input: File: a number or name - ;" RecNumIEN: The record number, in File, to use - ;" Field: a name or number - ;" TMGArray: The array that contains WP data. Must be in Fileman acceptible format. - ;"Results -- if error occured - ;" cOKToCont (i.e. 1) if no error - ;" cAbort (i.e. 0) if error - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 - if $data(cAbort)#10=0 new cAbort set cAbort=0 - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") - - new IENS - new TMGMsg - new FileNumber,FieldNumber - new result set result=cAbort - new TMGFlags set TMGFlags="K" - - set FileNumber=+$get(File) - if FileNumber=0 set FileNumber=$$GetFileNum(.File) - if FileNumber=0 do goto WWPDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") - - set FieldNumber=$get(Field) - if FieldNumber=0 set FieldNumber=$$GetNumField^TMGDBAPI(.Field) - if FieldNumber=0 do goto WWPDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") - - if +$get(RecNumIEN)=0 do goto WWPDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"No numeric record number supplied.") - - set IENS=RecNumIEN_"," - - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS='",IENS,"'") - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNumber=",FieldNumber) - ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",TMGFlags) - ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGArray") - - do - . ;"====================================================== - . ;"Call WP^DIE - . ;"====================================================== - . ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") - . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, WP^DIE files WP data.") - . set ^TMP("TMG",$J,"ErrorTrap")=result - . set ^TMP("TMG",$J,"Caller")="WP^DIE" - . do WP^DIE(FileNumber,IENS,FieldNumber,TMGFlags,"TMGArray","TMGMsg") - . set result=^TMP("TMG",$J,"ErrorTrap") - . kill ^TMP("TMG",$J,"ErrorTrap") - . kill ^TMP("TMG",$J,"Caller") - . ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") - . ;"====================================================== - . ;"====================================================== - - if $data(TMGMsg("DIERR"))'=0 do goto WWPDone - . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . set result=cAbort - - set result=cOKToCont - - ;"zbreak WWPDone - -WWPDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") - quit result - - -ReadWP(File,IENS,Field,Array) - ;"Purpose: To provide a shell for reading a WP with error trap, error reporting - ;"Input: File: a number or name - ;" IENS: a standard IENS (i.e. "IEN,parent-IEN,grandparent-IEN,ggparent-IEN," etc. - ;" Note: can just pass a single IEN (without a terminal ",") - ;" Field: a name or number - ;" Array: The array to receive WP data. PASS BY REFERENCE - ;" returned In Fileman acceptible format. - ;" Array will be deleted before refilling - ;"Results -- if error occured - ;" cOKToCont (i.e. 1) if no error - ;" cAbort (i.e. 0) if error - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 - if $data(cAbort)#10=0 new cAbort set cAbort=0 - - ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") - - new FileNumber,FieldNumber - new TMGWP,temp - new result set result=cOKToCont - - if $get(IENS)="" do goto RWPDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Valid IENS not supplied.") - if $extract(IENS,$length(IENS))'="," set IENS=IENS_"," - - if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=cAbort goto RWPDone - - set temp=$$GET1^DIQ(FileNumber,IENS,FieldNumber,"","TMGWP","TMGMsg") - - if $data(TMGMsg) do - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are TMGMsg entries") - . ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") - . if $data(TMGMsg("DIERR"))'=0 do quit - . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . . set result=cAbort - if result=cAbort goto RWPDone - - kill Array - merge Array=TMGWP - -RWPDone - ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") - quit result - -ShowIfError(TMGMsg,PriorErrorFound) - ;"Purpose: to show DIERR if preesnt in pTMGMsg - ;"Input: pTMGMsg -- PASS BY REFERENCE, holds message route, as set up by Fileman - ;" PriorErrroFound -- OPTIONAL, a variable holding if a prior error has been found - ;"Output: 1 if ERROR found, 0 otherwise - - new result set result=0 - if $data(TMGMsg("DIERR"))'=0 do - . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . set result=1 - quit result - - -DataImport(Info,ProgressFN) - ;"Purpose: to provide a generic loading utility. - ;" Note: this is more specific than code found in DDMP.m - ;"Assumptions: that all data for one record is found on one line, with a given - ;" number of columns for each field. - ;"Input: Info, an array with relevent info. PASS BY REFERENCE - ;" Format as follows: - ;" Info("HFS DIR")= - ;" Info("HFS FILE")= - ;" Info("DEST FILE")= - ;" Info(x)=field# (or "IEN" if data should be used to determine record number - ;" Info(x,"START")=starting column - ;" Info(x,"END")=ending column - ;" ProgressFN: optional. If not "", then this will be XECUTED after each line - ;"Result: 1 if OK to continue, 0 if error - - ;"Note: input Data array will be formated like this: - ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion - ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," - ;" Data(0,cRecNum)=2 <-- only if user-specified. - ;" Data(0,cEntries)=1 - ;" Data(1,".01")="MyData1" - ;" Data(1,".01",cMatchValue)="MyData1" - ;" Data(1,".02")="Bill" - ;" Data(1,".02",cMatchValue)="John" - ;" Data(1,".03")="MyData3" - ;" Data(1,".04")="MyData4" - ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" - ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" - ;" Data(1,".07",1,".01")="SubEntry1" - ;" Data(1,".07",1,".02")="SE1" - ;" Data(1,".07",1,".03")="'Some Info'" - ;" Data(1,".07",2,".01")="SubEntry2" - ;" Data(1,".07",2,".02")="SE2" - ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 - ;" Data(1,".07",2,".04",1,".01")="JD" - ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" - ;" ADDENDUM - ;" Data(1,".01",cFlags)=any flags specified for given field. - ;" only present if user specified. - - new cFile set cFile="FILE" - new cRecNum set cRecNum="RECNUM" - new result set result=1 - - new GRef set GRef=$name(^TMP("TMG","DATAIMPORT",$J)) - new GRef1 set GRef1=$name(@GRef@(1)) ;"I have to use this to load file - kill @GRef - - new result - new dir set dir=$get(Info("HFS DIR")) - new HFSfile set HFSfile=$get(Info("HFS FILE")) - set result=$$FTG^%ZISH(dir,HFSfile,GRef1,4) - if result=0 goto DIDone - new file set file=$get(Info("DEST FILE")) - if +file=0 set file=$$GetFileNum(file) - - new index - set index=$order(@GRef@("")) - for do quit:(+index=0)!(result=0) - . new RecData,FDA - . set RecData(0,cFile)=file - . new line set line=$get(@GRef@(index)) - . new fields set fields=$order(Info("")) - . new IEN set IEN="" - . for do quit:(+fields=0)!(result=0) - . . new fieldNum set fieldNum=$get(Info(fields)) ;"could be number or 'IEN' - . . new oneField - . . set oneField=$extract(line,$get(Info(fields,"START")),$get(Info(fields,"END"))) - . . set oneField=$$Trim^TMGSTUTL(oneField) - . . if fieldNum="IEN" do - . . . set RecData(0,cRecNum)=fieldNum - . . . set IEN=fieldNum - . . else do - . . . set RecData(1,fieldNum)=oneField - . . set fields=$order(Info(fields)) - . new MarkNum set MarkNum=0 - . new MsgArray - . set result=$$SetupFDA(.RecData,.FDA,,"+",.MarkNum,.MsgArray,IEN) - . if result=0 quit - . set result=$$dbWrite(.FDA,0,," ") - . if result=0 quit - . if $get(ProgressFN)'="" do - . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" - . . xecute ProgressFN - . set index=$order(@GRef@(index)) - -DIDone - kill @GRef - quit result - - -Set1(File,IEN,Field,Value,Flag) - ;"Purpose: to be the reverse of GET1^DIQ (i.e. a setter instead of a getter) - ;" It will set the value for 1 field in 1 record in 1 file. - ;" Note: only to be used in existing files. - ;"Input: File -- the Filename or number - ;" IEN -- the record number to set into - ;" Field -- the field name or number - ;" Value -- the value to set it to (WP not currently supported) - ;" Flag -- OPTIONAL. Combinations of below: - ;" 'I' -- values are in internal format - ;" 'E' -- values are in external format (this is the DEFAULT) - ;"Results: 1 if OKtoCont, 0 if error - - new FileNumber,FieldNumber - new result set result=0 ;"default to error - - ;"new tempDebug set tempDebug=$get(TMGDEBUG) - ;"set TMGDEBUG=-1 ;"Extra quiet mode - - if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=0 goto S1Done - if (+FileNumber=0)!(+FieldNumber=0) goto S1Done - if ($get(Value)="")!(+IEN=0) goto S1Done - - new result set result=1 ;"default to success. - - new TMGFDA,FMFlag,TMGMSG - set FMFlag="E" - if $get(Flag)["I" set FMFlag="" - set FMFlag=FMFlag_"K" - set TMGFDA(FileNumber,IEN_",",FieldNumber)=Value - do FILE^DIE(FMFlag,"TMGFDA","TMGMSG") - if $data(TMGMSG("DIERR"))'=0 do goto S1Done - . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) - -S1Done - ;"set TMGDEBUG=tempDebug - quit result - - -GetValidInput(File,Field) - ;"Purpose: Gets a valid input for field in file, asking user from console - ;"Input: File: File number or name of file to use - ;" Field: Field number or name in file. - ;"Results: returns valid input, or "" - - new FileNum,FldNum - new DIR,X,Y - set Y="" - - set FileNum=+$get(File) - if FileNum=0 set FileNum=$$GetFileNum^TMGDBAPI(.File) - if FileNum=0 goto GVIDone - - set FldNum=$get(Field) - if FldNum=0 set FldNum=$$GetNumField^TMGDBAPI(FileNum,.Field) - if FldNum=0 goto GVIDone - - set DIR(0)=FileNum_","_FldNum - do ^DIR write ! -GVIDone - quit Y - - -AskFIENS() - ;"Purpose: Ask user to pick a file number, then pick a record - ;" from that file. This supports selection of subfiles. - ;"Input: none - ;"Results: format-- File^IENS, or ^ if abort - new result set result="^" - - new DIR,X,Y - set DIR(0)="F" - set DIR("A")="Select FILE (or SUBFILE)" - set DIR("?")="Answer with FILE NUMBER or NAME, or SUBFILE NUMBER" - set DIR("PRE")="D ASKSCRN^TMGDBAPI" - do ^DIR - set Y=+Y - if Y>0 set result=Y_"^"_$$AskIENS(Y) - - quit result - -ASKSCRN - ;"Purpose: an Input transform for AskFIENS - ;"Input: (global) X -- the user's response in ^DIR - ;" (global) DTOUT -- this will be defined if the read timed out. - ;"Output: If X is changed, it will be as if user entered in new X - ;" If X is killed, it will be as if user entered an illegal value. - - if $data(DTOUT) quit - if +X=X do - . if $data(^DD(X,0))=0 kill X quit - . if $data(^DIC(X,0)) write " ",$piece(^DIC(X,0),"^",1)," " quit - . ;"Here we deal with subfiles - . new temp,i,filenum - . set filenum=X - . set X="" - . for i=100:-1:0 do quit:(filenum=0) - . . set temp(i)=filenum - . . set X=X_filenum_"," - . . set filenum=+$get(^DD(filenum,0,"UP")) - . new indent set indent=5 - . new indentS set $piece(indentS," ",75)=" " - . write ! - . set i="" - . for set i=$order(temp(i)) quit:(i="") do - . . set filenum=+$get(temp(i)) quit:(filenum=0) - . . write $extract(indentS,1,indent) - . . if $data(^DIC(filenum,0)) do - . . . write $piece(^DIC(filenum,0),"^",1)," (FILE #",filenum,")",! - . . else write "+--SUBFILE# ",filenum,! - . . set indent=indent+3 - else do ;"check validity of FILE NAME - . if X="" quit - . new filenum - . set filenum=$order(^DIC("B",X,"")) - . if +filenum>0 set X=+filenum_"," quit - . set filenum=$$GetFileNum(X) - . if +filenum>0 set X=+filenum_"," quit - . new DIC,Y - . set DIC=1 set DIC(0)="EQM" - . do ^DIC w ! - . if +Y>0 set X=+Y quit - . set X=0 - - if $get(X)="" set X=0 - quit - - -AskIENS(FileNum,IENS) - ;"Purpose: To ask user to select a record in File indicated by FileNum. - ;" If FileNum is a subfile number, then the user will be asked - ;" for records to drill down to desired record, and return values - ;" as an IENS. - ;"Input: FileNum: A file number or subfile number - ;" IENS: OPTIONAL. Allows for supplying a partial IENS supplying a - ;" partial path. E.g. if a full IENS to FileNum - ;" would be '2,3,4455,' and if the IENS supplied is - ;" '3,4455,' then only the missing IEN (in this case 2) - ;" would be asked. - ;"Results: Returns IENS. format: IEN in file,IEN in parentfile,IEN in grandparentfile, ... , - ;" Note: IENS will contain '?' if there is a problem, - ;" or "" if FileNum is invalid - new array - do GetRefArray(FileNum,.array) - new resultIENS set resultIENS="" - set IENS=$get(IENS) - - new DANum set DANum=1 - new TMGDA,numIENS - set numIENS=$length(IENS,",") - new i,abort set i="",abort=0 - for set i=$order(array(i),-1) quit:(i="")!abort do - . new DIC,X,Y,DA - . new tempIEN set tempIEN=+$piece(IENS,",",numIENS-DANum) - . if tempIEN'>0 do - . . set DIC=$get(array(i,"GL")),DIC(0)="AEQM" - . . if DIC'="" write !,"Select entry in file# ",array(i,"FILE NUM") - . . do ^DIC write ! - . else set Y=tempIEN - . if +Y'>0 set resultIENS="?,"_resultIENS,abort=1 quit - . set TMGDA(DANum)=+Y,DANum=DANum+1 - . set resultIENS=+Y_","_resultIENS - - write "#: ",resultIENS,! - quit resultIENS - - -GetRefArray(FileNum,array) - ;"Purpose: To return an array containing global references that can - ;" be passed to ^DIC, for given file or subfile number - ;"Input: FileNum: A file number or subfile number - ;" array: PASS BY REFERENCE. See format below - ;"Results: none, but array is filled with result. Format (example): - ;" array(1,"FILE NUM")=2.011 <--- sub sub file - ;" array(1,"GL")="^DPT(TMGDA(1),""DE"",TMGDA(2),""1""," - ;" array(2,"FILE NUM")=2.001 <---- sub file - ;" array(2,"GL")="^DPT(TMGDA(1),""DE""," - ;" array(3,"FILE NUM")=2 <---- parent file - ;" array(3,"GL")="^DPT(" - ;"Note: To use the references stored in "GL", then the IEN for - ;" each step should be stored in TMGDA(x) - - new i - for i=1:1 quit:(+$get(FileNum)=0) do - . set array(i,"FILE NUM")=FileNum - . if $data(^DD(FileNum,0,"UP")) do - . . new parentFlNum,field - . . set parentFlNum=+$get(^DD(FileNum,0,"UP")) - . . if parentFlNum=0 quit ;"really should be an abort - . . set field=$order(^DD(parentFlNum,"SB",FileNum,"")) - . . if field="" quit ;"really should be an abort - . . new node set node=$piece($piece($get(^DD(parentFlNum,field,0)),"^",4),";",1) - . . set array(i,"NODE IN PARENT")=node - . else do - . . set array(i,"GL")=$get(^DIC(FileNum,0,"GL")) - . set FileNum=+$get(^DD(FileNum,0,"UP")) - - set i="" set i=$order(array(i),-1) - set array(i,"ref")=$get(array(i,"GL"))_"TMGDA(1)," - new DANum set DANum=2 - for set i=$order(array(i),-1) quit:(i="") do - . new ref - . set ref=$get(array(i+1,"ref"))_""""_$get(array(i,"NODE IN PARENT"))_"""," - . kill array(i+1,"ref"),array(i,"NODE IN PARENT") - . set array(i,"GL")=ref - . set array(i,"ref")=ref_"TMGDA("_DANum_")," - . set DANum=DANum+1 - kill array(1,"ref") - quit - -FIENS2Root(FIENS) - ;"Purpose: to convert a Files^IENS string into a root reference - ;"Input: FIENS: format: FileNumber^StandardIENS - ;"Output: A global root in open format - quit - - -GetRef(file,IENS,field) - ;"Purpose: to return the global reference for a given record - ;"Input: file -- File or subfile number - ;" IENS -- an IEN, or an IENS for record - ;" field -- OPTIONAL. - ;"Results: if field is NOT supplied, or - ;" OPEN global ref - ;" if field IS supplied - ;" CLOSED global ref@piece - ;" e.g. ^TMG(22706.9,3,2,IEN,0)@1 <-- note 'IEN' placeholder - - ;"Note: This function really needs to be fleshed out some more... - ;"Note: this only will work for normal files, or subfiles ONE (1) level deep... - - new ref set ref="" - new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) - if parentFile=0 goto GRF1 ;"handle non-subfiles separately. - - set fieldInParent=$piece(parentFile,"^",2) - set ref=$get(^DIC(+parentFile,0,"GL")) - new IENinParent set IENinParent=$piece(IENS,",",2) - set ref=ref_IENinParent_"," - new storeLoc set storeLoc=$piece($get(^DD(+parentFile,fieldInParent,0)),"^",4) - ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... - set ref=ref_+storeLoc_"," - new IENinSubRec set IENinSubRec=$piece(IENS,",",1) - if IENinSubRec="" set IENinSubRec="IEN" - set ref=ref_IENinSubRec_"," - - if $get(field)="" goto GRF2 ;"done - set storeLoc=$piece($get(^DD(file,field,0)),"^",4) - set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) - goto GRF2 - -GRF1 - set ref=$get(^DIC(file,0,"GL")) - set ref=ref_+IENS_"," - if $get(field)="" goto GRF2 ;"done - new storeLoc set storeLoc=$piece($get(^DD(file,field,0)),"^",4) - set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) - ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... -GRF2 - quit ref - -TrimFDA(FDA,Quiet) - ;"Purpose: To take an FDA, and compare it to data already present in the - ;" record specified by the FDA. If any values already in the record - ;" match those in the FDA, then those entries will be removed from the - ;" FDA array. - ;"Input: FDA -- PASS BY REFERENCE. A standard Fileman FDA. - ;" Quiet -- OPTIONAL. If 1, then error messages will be supressed - ;" (These would be messages generated on READING existing - ;" data, not writing new data.) - ;" default value=1 - ;"Output: Values from FDA may be removed. - ;"Results: final IENS (i.e. '+1,3,' --> '5,3,' if prev value found) - ;"Note: match will be made base on INTERNAL, or EXTERNAL forms - ;"Note: Fields should be specified by numbers, NOT NAMES. - - new tempIENS set tempIENS="" - if $data(FDA)'>0 goto TFDDone - new TMGDATA,TMGMSG - new file,IENS - set file=$order(FDA("")) - set IENS=$order(FDA(file,"")) - set tempIENS=IENS - set Quiet=$get(Quiet,1) - - new fieldsS set fieldsS="" - new field set field="" - for set field=$order(FDA(file,IENS,field)) quit:(field="") do - . set fieldsS=fieldsS_field_";" - - new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) - if parentFile=0 goto TFD0 ;"handle non-subfiles separately. - - ;"e.g. FDA(22706.9001,"+1,3",.01)=1 - ;" FDA(22706.9001,"+1,3",.02)=2 - ;"Note: The .01 field is used to find a matching subrecord, which is then - ;" check for preexisting data. If multiple matches for .01 are found, - ;" then the process is aborted, and the FDA will NOT BE TRIMMED. - - set $piece(tempIENS,",",1)="" ;"leave first piece blank in IENS - new value set value=$get(FDA(file,IENS,.01)) - - ;"new i for i=1:1:$length(fieldsS,",") do ;"append 'E' to each field number - ;". new field set field=$piece(fieldsS,";",i) - ;". set field=field_"E" - ;". set $piece(fieldsS,";",i)=field - ;" - ;"new TMGFIND - ;" - ;"I can't get this part to work... so will work around - ;"do FIND^DIC(file,tempIENS,fieldsS,"BMU",value,"*",,,,"TMGFIND","TMGMSG") - ;"do ShowIfDIERR^TMGDEBUG(.TMGMSG) - ;"if +$get(TMGFIND(0))'=1 goto TFDDone ;"abort - ;"merge TMGDATA(file,IENS)=TMGDATA("ID",1) - ;"goto TFD1 - - new ref set ref=$$GetRef(file,tempIENS,.01) ;"returns ref with 'IEN' built in... - new ref2 set ref2=$$CREF^DILF($piece(ref,"IEN",1)) - new ref3 set ref3=$piece(ref,"@",1) - new p set p=$piece(ref,"@",2) - new found set found=0 - new IEN set IEN=0 - for set IEN=$order(@ref2@(IEN)) quit:(+IEN'>0)!(found>0) do - . new valueFound set valueFound=$piece($get(@ref3),"^",p) - . if valueFound=value set found=IEN - if found=0 set tempIENS=IENS goto TFDDone - set tempIENS=found_tempIENS -TFD0 - do GETS^DIQ(file,tempIENS,fieldsS,"EI","TMGDATA","TMGMSG") - if 'Quiet do ShowIfDIERR^TMGDEBUG(.TMGMSG) - -TFD1 - for set field=$order(FDA(file,IENS,field)) quit:(field="") do - . new found set found=0 - . new FDAvalue set FDAvalue=$get(FDA(file,IENS,field)) - . if $get(TMGDATA(file,tempIENS,field,"I"))=FDAvalue set found=1 - . if $get(TMGDATA(file,tempIENS,field,"E"))=FDAvalue set found=1 - . if (FDAvalue="@")&($data(TMGDATA(file,tempIENS,field))=0) set found=1 - . if found=1 kill FDA(file,IENS,field) - goto TFDDone -TFDDone - quit tempIENS - - - -GetPtrsOUT(File,Info) - ;"Purpose: to get a list of pointers out from the file. - ;"Input: File -- File Name or Number of file to investigate - ;" Info -- PASS BY REFERENCE. An OUT PARAMETER. Format: - ;" Info(Field#)=PointedToFileNum - ;" Info(Field#,"GL")=an open global ref to pointed-to file - ;"results: none - - if $get(File)="" goto GPODone - if +File'=File set File=$$GetFileNum(File) - new field set field=0 - new done set done=0 - for set field=$order(^DD(File,field)) quit:(+field'>0)!(done=1) do - . new array - . do FIELD^DID(File,field,"N","POINTER","array") - . if $get(array("POINTER"))="" quit - . if array("POINTER")[";" quit - . set Info(field,"GL")=array("POINTER") - . new temp set temp=$piece($get(^DD(File,field,0)),"^",2) - . set temp=+$piece(temp,"P",2) - . set Info(field)=temp - . if $data(array) write field," " zwr array -GPODone - quit - Index: cprs/branches/tmg-cprs/m_files/TMGDBAPI.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGDBAPI.m~ (revision 796) +++ (revision ) @@ -1,1260 +1,0 @@ -TMGDBAPI ;TMG/kst/Database API library ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - ;"TMG DATABASE API FUNCTIONS - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"$$GetNumField^TMGDBAPI(FileNumber,FieldName) ;Convert Field Name to Field Number - ;"$$GetFileNum^TMGDBAPI(FileName) ;Convert File Name to File Number - ;"$$SetFileFldNums^TMGDBAPI(File,Field,FileNumber,FieldNumber) ;do both functions above at once. - ;"$$GetFName^TMGDBAPI(FileNumber) ;Convert File Number to File Name - ;"$$GetFldName^TMGDBAPI(File,FieldNumber) ;Convert Field Number to Field Name - ;"$$GetFldList^TMGDBAPI(File,pArray) ;Get list of all fields for a file. - ;"FieldExists^TMGDBAPI(FileNumber,Field) - ;"SetFieldInfo^TMGDBAPI(File,Field,Array) - ;"GetFieldInfo^TMGDBAPI(FileNumber,Field,VarOutP) - ;"GetSubFileNumber^TMGDBAPI(FileNumber,Field) - ;"$$IsSubFile^TMGDBAPI(File) - ;"GetSubFInfo^TMGDBAPI(SubFileNum,Array) - ;"GetRecMatch^TMGDBAPI(Data,RecNumIEN) - ;"CompRec^TMGDBAPI(FileNumber,dbRec,TestRec) - ;"UploadData^TMGDBAPI(DaDIta,RecNumIEN) - ;"ValueLookup^TMGDBAPI(Params) - ;"FileUtility^TMGDBAPI(Params) - ;"AddRec^TMGDBAPI(Data) - ;"OverwriteRec^TMGDBAPI(RecNum,Data) - ;"SetupFileNum^TMGDBAPI(Data) - ;"RecFind^TMGDBAPI(Params) - ;"FieldCompare^TMGDBAPI(TestField,dbField,Type) - ;"$$dbWrite^TMGDBAPI(FDA,Overwrite,TMGIDE,Flags,ErrArray) - ;"$$DelIEN^TMGDBAPI(File,RecNumIEN,ErrArray) - ;"$$WriteWP^TMGDBAPI(File,RecNumIEN,Field,Array) - ;"$$ReadWP^TMGDBAPI(File,IENS,Field,Array) - ;"$$ShowIfError^TMGDBAPI(TMGMsg,PriorErrorFund) - ;"$$GetValidInput^TMGDBAPI(File,Field) -- Get a valid input for field in file, asking user - ;"$$AskFIENS^TMGDBAPI() -- pick a (sub)file number, then pick a record from that file. - ;"$$AskIENS^TMGDBAPI(FileNum) -- return IENS for File (or subfile) number - ;"GetRef^TMGDBAPI(file,IENS,field) -- to return the global reference for a given record - ;"GetPtrsOUT^TMGDBAPI(FileNum,Info) -- get a list of pointers out from the file. - ;"$$TrimFDA^TMGDBAPI(FDA,Quiet) -- Trim FDA of any data already present in the database - - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"ConvertFDA(FDA,MarkerArray) - ;"ConvertIENS(IENS,MarkerArray) - ;"SetupFDA(Data,FDA,IENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) - ;"HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) - ;"HandleHacksArray(MsgArray) - ;"GetRefArray(FileNum,array) - - ;"======================================================================= - ;"DEPENDENCIES - ;"TMGDEBUG - ;"TMGUSRIF - ;"TMGSTUTL - ;"======================================================================= - - ;"======================================================================= - - ;"FORMAT OF DATA ARRAY - - ;" cNull="(none)" - ;" cRecNum="RECNUM" - ;" cOutput="OUTVAR" - ;" cGlobal="GLOBAL" - ;" cEntries="Entries" - ;" cFlags="FLAGS" - ;" cParentIENS="ParentIENS" - - ;"The Data array will be filed with data. (An example) - ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion - ;" Data(0,"FILE",cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," - ;" Data(0,cRecNum)=2 <-- only if user-specified. - ;" Data(0,cEntries)=1 - ;" Data(1,".01")="MyData1" - ;" Data(1,".01","MATCHVALUE")="MyData1" - ;" Data(1,".01",cFlags)=any flags given (only present if user specified) - ;" Data(1,".02")="Bill" - ;" Data(1,".02","MATCHVALUE")="John" - ;" Data(1,".03")="MyData3" - ;" Data(1,".03",cFlags)=any flags given (only present if user specified) - ;" Data(1,".04")="MyData4" - ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" - ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" - ;" Data(1,".07",0,cParentIENS)=",10033," - ;" Data(1,".07",1,".01")="SubEntry1" - ;" Data(1,".07",1,".02")="SE1" - ;" Data(1,".07",1,".03")="'Some Info'" - ;" Data(1,".07",2,".01")="SubEntry2" - ;" Data(1,".07",2,".02")="SE2" - ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 - ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033," - ;" Data(1,".07",2,".04",1,".01")="JD" - ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" - - ;"======================================================================= - ;"======================================================================= - -GetNumField(FileNumber,FieldName) - ;"PUBLIC FUNCTION - ;"Purpose: Given file and the name of a field, this will return the field NUMBER - ;"Input: FileNumber. Number of file, i.e. "4.11" - ;" FieldName: the name of a field, i.e. "NAME" spelling must exactly match - ;"Output: Returns field number, i.e. ".01" or 0 if not found - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - - new result - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") - - set result=$$FLDNUM^DILFD(FileNumber,FieldName) - - if result'=0 goto GNMFDone - - ;"-------------------------- - ;"The below is a manual method - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Having difficulty finding field name (? due to security ?). Doing Manual Check.") - - new FoundField - new Index - new result set result=cAbort - set U=$get(U,"^") ;"Setup up U if doesn't yet exist - - if $$VFILE^DILFD(FileNumber)=0 do goto GNMFDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") - - set Index="" -GNmLoop set Index=$order(^DD(FileNumber,Index)) - if Index="" goto GNMFDone - if $data(^DD(FileNumber,Index,0))=0 goto GNMFDone - set FoundField=$piece(^DD(FileNumber,Index,0),"^",1) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing fields: '",FoundField,"' vs. '",FieldName,"'") - if FieldName=FoundField do goto GNMFDone - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Match!") - . set result=Index - goto GNmLoop - -GNMFDone - if result=cAbort do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to convert '",FieldName,"' in file '",FileNumber,"' to a field number. Check for Field name typo") - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetNumField^TMGDBAPI") - - quit result - -SetFileFldNums(File,Field,FileNumber,FieldNumber) - ;"Purpose: To provide a generic shell to ensure that File and Field numbers are in place - ;"Input: File -- File number or name - ;" Field -- field number or name - ;" FileNumber -- PASS BY REFERENCE -- an out parameter - ;" FieldNum -- PASS BY REFERENCE -- an out parameter - ;"Results: cOKToCont(1) if ok, otherwise cAbort(0) if error - ;"Output -- FileNumber and FieldNumber are filled in. - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - - new result set result=cOKToCont - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") - - set FileNumber=+$get(File) - if FileNumber=0 set FileNumber=$$GetFileNum(.File) - if FileNumber=0 do goto SFFNDone - . set result=cAbort - . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") - - set FieldNumber=$get(Field) - if FieldNumber=0 set FieldNumber=$$GetNumField(FileNumber,.Field) - if FieldNumber=0 do goto SFFNDone - . set result=cAbort - . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") - -SFFNDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetFileFldNums^TMGDBAPI") - quit result - - -FieldExists(FileNumber,Field) - ;"PUBLIC FUNCTION - ;"Purpose: To ensure that a field exists -- even if hidden by security measures - ;"Input: FileNumber: File to check - ;" Field: the field number (or name) to check - ;"Result: 1 if field exists, 0 if doesn't, 2 if exists but is hidden to user - - new result,FieldNumber - if +Field=0 set FieldNumber=$$GetNumField(FileNumber,Field) - else set FieldNumber=Field - - set result=$$VFIELD^DILFD(FileNumber,FieldNumber) - if result=1 goto FExsDone - - ;"Try a low-level data dictionary eval to see if really does exist, but is hidden - if $data(^DD(FileNumber,FieldNumber,0))'=0 set result=2 - -FExsDone - quit result - - - -GetSubFileNumber(FileNumber,Field) - ;"PUBLIC FUNCTION - ;"Purpose: If FieldNumber is a 'multiple' field, then this function should return 'subfile' - ;" number of the sub file. - ;"Input:FileNumber-- the file number (or sub file number) that field exists in - ;" Field-- the field number (or name) in file to lookup - ;"Result: Returns sub file number, or 0 if not found or invalid - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - - new Info - new result set result=cAbort - new Output - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Field=",Field) - - ;"First, verify file (or subfile) exists - if $$VFILE^DILFD(FileNumber)=0 do goto GSFDone ;"abort - . do ShowError^TMGDEBUG(.PriorErrorFound,"File number '"_FileNumber_"' is not valid.") - - ;"Next, ensure Field exists in file - if $$FieldExists(FileNumber,Field)=0 do goto GSFDone ;"abort - . do ShowError^TMGDEBUG(.PriorErrorFound,"Field number '"_Field_"' is not valid.") - - ;"Next, ensure field is a multiple and get field info. - do GetFieldInfo(FileNumber,Field,"Output") - if $data(Output("MULTIPLE-VALUED"))=0 do goto GSFDone ;"abort - . do ShowError^TMGDEBUG(.PriorErrorFound,"Field '"_Field_"' in File '"_FileNumber_"' is not a subfile.") - - ;"Now actually get subfile number - if $data(Output("SPECIFIER"))=0 do goto GSFDone ;"abort - . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to find 'Specifier' (subfile number)") - set result=+Output("SPECIFIER") - - ;"Now actually get subfile number - ;"set Info=$get(^DD(FileNumber,Field,0),0) - ;"if Info=0 do goto GSFDone - ;". do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to get information from data dictionary.") - ;"set result=+$piece(Info,"^",2) - -GSFDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFile number is: ",result) - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetSubFileNumber^TMGDBAPI") - quit result - - -IsSubFile(File) - ;"Purpose: to return if file is actually a subfile - ;"Input: File -- File name or number - ;"Results: Parent file number^Field in Parent File - ;" or 0 if not a subfile. - - new result - if +File'=File set File=$$GetFileNum(File) - set result=+$get(^DD(File,0,"UP")) - if result'>0 goto ISFDone - - ;"Now find which field this sub file is in its parent - new fldInParent set fldInParent=0 - new field set field=0 - new done set done=0 - for set field=$order(^DD(result,field)) quit:(+field'>0)!(done=1) do - . new fldInfo set fldInfo=$piece($get(^DD(result,field,0)),"^",2) - . if +fldInfo=File set fldInParent=field set done=1 - if fldInParent>0 set result=result_"^"_fldInParent -ISFDone - quit result - - -GetSubFInfo(SubFileNum,Array) - ;"PUBLIC FUNCTION - ;"Purpose: To take a subfile NUMBER, and return information about it. - ;"Input: SubFileNum-- the sub file number - ;" Array -- PASS BY REFERENCE. An array to receive results. - ;" any preexisting data is deleted. - ;"Output Array is formated as follows: - ;" Array("SUBFILE","NUMBER")=file number of this sub file. - ;" Array("SUBFILE","NAME")=file name of this sub file. - ;" Array("PARENT","NUMBER")=parent file number - ;" Array("PARENT","NAME")=parent file name - ;" Array("PARENT","GL")=global reference of parent, in open format<-- only valid if parent isn't also a subfile - ;" Array("FIELD IN PARENT","NUMBER")=field number of subfile in parent - ;" Array("FIELD IN PARENT","NAME")=filed name of subfile in parent - ;" Array("FIELD IN PARENT","LOC")=node and piece where subfile is stored - ;" Array("FIELD IN PARENT","CODE")=code giving subfile's attributes. - ;"Result: 1 if found info, or 0 if not found or invalid - - new result set result=0 - if '$get(SubFileNum) goto GSPDone - kill Array - set Array("SUBFILE","NUMBER")=SubFileNum - set Array("SUBFILE","NAME")=$piece($get(^DD(SubFileNum,0)),"^",1) - new parent - set parent=+$get(^DD(SubFileNum,0,"UP")) - if parent=0 goto GSPDone - set Array("PARENT","NUMBER")=parent - set Array("PARENT","NAME")=$order(^DD(parent,0,"NM","")) - set Array("PARENT","GL")=$get(^DIC(parent,0,"GL")) - new i set i=$order(^DD(parent,"")) - for do quit:(i="")!(result=1) ;"scan all fields for a match - . quit:(i="") - . new node,num - . set node=$get(^DD(parent,i,0)) - . if +$piece(node,"^",2)=SubFileNum do quit - . . set Array("FIELD IN PARENT","NUMBER")=i - . . set Array("FIELD IN PARENT","NAME")=$piece(node,"^",1) - . . set Array("FIELD IN PARENT","LOC")=$piece(node,"^",4) - . . set Array("FIELD IN PARENT","CODE")=$piece(node,"^",2) - . . set result=1 - . set i=$order(^DD(parent,i)) - -GSPDone - quit result - - - -GetFieldInfo(FileNumber,Field,VarOutP,InfoS) - ;"PUBLIC FUNCTION - ;"Purpose: To get Field info, - ;"Input: FileNumber: File or subfile number - ;" Field: Field name or number - ;" VarOutP -- the NAME of the variable to put result into. - ;" InfoS -- [OPTIONAL] -- additional attributes of field info to be looked up - ;" (as allowed by FIELD^DID). Multiple items should be - ;" separated by a semicolon (';') - ;" e.g. "TITLE;LABEL;POINTER" - ;"Output: Data is put into VarOutP (any thing in VarOutP is erased first - ;" i.e. @VarOutP@("MULTIPLE-VALUED")=X - ;" i.e. @VarOutP@("SPECIFIER")=Y - ;" i.e. @VarOutP@("TYPE")=Z - ;" i.e. @VarOutP@("StoreLoc")="0;1" <-- not from fileman output (i.e. extra info) - ;" (if additional attributes were specified, they will also be in array) - ;"Result: none - - kill @VarOutP ;"erase any old information - - if +Field=0 set Field=$$GetNumField(FileNumber,Field) - set @VarOutP@("StoreLoc")=$piece($get(^DD(FileNumber,Field,0)),"^",4) - - new Attribs set Attribs="MULTIPLE-VALUED;SPECIFIER;TYPE" - if $data(InfoS) set Attribs=Attribs_";"_InfoS - ;"Next, check if field is a multiple and get field info. - do FIELD^DID(FileNumber,Field,,Attribs,VarOutP,"TMGMsg") - if $data(TMGMsg) do - . if $data(TMGMsg("DIERR"))'=0 do quit - . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - -GFIDone - quit - - - -HackWrite(GlobalP,FileNumber,IENS,FieldNum,Data) - ;"PUBLIC FUNCTION - ;"Purpse: To force data into a field -- using low level 'hack' method - ;"Input: GlobalP -- the NAME of the global to put this into, i.e. "^VA(200," - ;" FileNumber- the file number - ;" IENS -- the standard API IENS - ;" FieldNum the field to put this into - ;" Data -- the value to put in - ;"Note: This can be used to put a value of "@" into a field - ;"Result: 1 if ok to continue, 0=abort - ;"!!!NOTICE: This is a very low level means of accessing the database. - ;" The built in data verifiers, indexers etc etc will not be made aware of - ;" changes made to the database through this method. USE ONLY WITH CAUTION. - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - - new result set result=cAbort - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") - - if '$data(GlobalP) goto HWDone - if '$data(FileNumber) goto HWDone - if '$data(IENS) goto HWDone - if '$data(FieldNum) goto HWDone - if '$data(Data) goto HWDone - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File:",FileNumber) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS:",IENS) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum:",FieldNum) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Data:",Data) - - new DDInfo - new FieldInfo - new Index,Part - new OldData - new RecNum - - ;"Get info from data dictionary r.e. where actual fields are stored in files. - set DDInfo=$get(^DD(FileNumber,FieldNum,0)) - if '$data(DDInfo) goto HWDone - set FieldInfo=$piece(DDInfo,"^",4) - if '$data(FieldInfo),(FieldInfo="") goto HWDone - set Index=$piece(FieldInfo,";",1) - set Part=$piece(FieldInfo,";",2) - - ;"Convert global form of ^VA(200, into ^VA(200) - new Len - set Len=$length(GlobalP) - if $extract(GlobalP,Len)="," do - . set $extract(GlobalP,Len)=")" - - set RecNum=$piece(IENS,",",1) - if $piece(IENS,",",2)'="" do goto HWDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Hack writing to subfiles not supported") - if $data(@GlobalP@(RecNum,Index))=0 goto HWDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) - set OldData=$piece(@GlobalP@(RecNum,Index),"^",Part) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And that data item is now: '",OldData,"'") - if Data'=OldData do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing hack write") - . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Data - . ;"Give Message - . new Text - . set Text(0)=" Caution" - . set Text(1)="Yikes!" - . set Text(2)=" " - . set Text(3)="We just bypassed all safety measures, " - . set Text(4)="and wrote directly to the database." - . set Text(5)="Make sure you know what you are doing!!" - . set Text(6)=" " - . set Text(7)="File: "_FileNumber - . set Text(8)="Field: "_FieldNum - . set Text(9)="Prior value: '"_OldData_"'" - . set Text(10)="New value: '"_Data_"'" - . set Text(11)=" " - . set Text(12)="(This was caused by using Flags='H' in" - . set Text(13)="the XML script.)" - . do PopupArray^TMGUSRIF(5,45,.Text) - else do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No need for hackwrite... the data is already what we want.") - -HWDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HackWrite^TMGDBAPI") - quit - - -HandleHacksArray(MsgArray) - ;"PUBLIC FUNCTION - ;"Purpose: To cycle through an array of hackwrites and process each one. - ;"Input: HacksArray. Best if passed by reference - ;" Expected format of array: - ;" MsgArray(cHack,0,cEntries)=Number of Entries - ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data - ;" MsgArray(cHack,n,cFlags)=User specified Flags for field. - ;"Output: database is changed - ;"Result: 1 if ok to continue, 0=abort - ;"!!!NOTICE: This is a very low level means of accessing the database. - ;" The built in data verifiers, indexers etc etc will not be made aware of - ;" changes made to the database through this method. USE ONLY WITH CAUTION. - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cHack set cHack="H" - new cEntries set cEntries="Entries" - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") - - new result set result=cOKToCont - new index set index=1 - new GlobalP,FileNum,IENS,FieldNum,Data - new s - - for index=1:1:$get(MsgArray(cHack,0,cEntries)) do quit:(s="")!(result=cAbort) - . set s=$get(MsgArray(cHack,index)) if s="" quit - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing: ",s) - . set GlobalP=$piece(s,";",1) - . set FileNum=$piece(s,";",2) - . set IENS=$piece(s,";",3) - . set FieldNum=$piece(s,";",4) - . set Data=$piece(s,";",5) - . set result=$$HackWrite(GlobalP,FileNum,IENS,FieldNum,Data) - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"HandleHacksArray^TMGDBAPI") - quit result - - -GetRecMatch(Data,RecNumIEN) - ;"PUBLIC FUNCTION - ;"Purpose: Take Data array from DoUpload, and search in database - ;" for a prior matching record - ;"Input: Data - Data array will contain all the information that is to be uploaded - ;" Fields that should be specifically matched will have "MATCHTHIS" fields. - ;" A field may have a "MATCHTHIS" node meaning that the value - ;" specified should be searched for. - ;" Or, rarely, one may want to specifically search for a different - ;" search value. This is stored in a "MATCHVALUE" node. This - ;" node is ignored if "MATCHTHIS" node is present. - ;" The .01 field always is used for searching. If not present, then - ;" a "MATCHTHIS" node is assumed. - ;" Example array: - ;" Data(0,"FILE")="1234.1" <-- "NEW PERSON" Note conversion - ;" Data(1,".01")="BILL" - ;" Data(1,".01","MATCHVALUE")="JOHN" <-- optional search value - ;" Data(1,".01","MATCHTHIS")=1 - ;" Data(1,".02")="Sue" - ;" Data(1,".03")="MyData3" - ;" Data(1,".03",cFlags)=any flags given (only present if user specified) - ;" RecNumIEN -- MUST PASS BY REFERENCE. An OUT parameter to receive results - ;"Output: Returns answer in RecNumIEN (record number in file) if found, or 0 otherwise - ;"Result: 1=OKToContinue, 0=Abort - ;"Note: - ;" * Data in Multiple fields are NOT used for matching. - ;" * I am not going to support matching for subrecords (i.e. SubEntry stuff above) - ;" * If data passed is a subset of a larger data group (i.e. when this function - ;" is called recursively to handle a subfile), then an entry will be placed - ;" in the Data(0,cParentIENS) that will specify the RecNumIEN of the parent record - ;" holding this subfile. - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cParentIENS set cParentIENS="ParentIENS" - - new FileNumber,FieldNum - set RecNumIEN=0 - new IENS,Fields,Flags - new MatchValue set MatchValue="" - new FieldMatch set FieldMatch="" - new ScreenCode - new Matches,NumMatches - new TMGMsg - new result set result=cOKToCont - new index - new SlimData ;"Will hold just those fields that should be matched against - new OneMatch - - set IENS=$get(Data(0,cParentIENS)) - if IENS'="" if $extract(IENS,1)'="," do - . set IENS=","_IENS - - set Fields="@" - ;"Setup specifier to tell which fields to return info on - new done set done=0 - set index=0 - for set index=$order(Data(index)) quit:(index="")!done do - . set FieldNum="" - . for set FieldNum=$order(Data(index,FieldNum)) quit:(+FieldNum=0) do - . . if $get(Data(index,FieldNum,"MATCHTHIS"))=1 do - . . . set FieldMatch=$get(Data(index,FieldNum)) - . . else set FieldMatch=$get(Data(index,FieldNum,"MATCHVALUE")) - . . if FieldNum=".01" do - . . . if FieldMatch="" set FieldMatch=$get(Data(index,.01)) - . . . set MatchValue=FieldMatch - . . if FieldMatch'="" do - . . . set Fields=Fields_";"_FieldNum - . . . set SlimData(FieldNum)=FieldMatch - . . . set FieldMatch="" - . set done=1 ;"Force handling only 1 entry (i.e. #1), then quit after first cycle. - - set FileNumber=$get(Data(0,"FILE")) - set ScreenCode="" - set Flags="" - - ;"====================================================== - ;"Call FIND^DIC - ;"====================================================== - ;"Params: - ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS - do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FIND^DIC") - ;"====================================================== - ;"====================================================== - - if $data(TMGMsg) do - . if $data(TMGMsg("DIERR"))'=0 do quit - . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . . set result=cAbort - if result=cAbort goto GRMQuit - - if $data(Matches("DILIST"))=0 goto GRMQuit ;"keep RecNumIEN default of 0 - set NumMatches=$piece(Matches("DILIST",0),"^",1) - if NumMatches=0 goto GRMQuit ;"keep RecNumIEN default of 0 - - for index=1:1:NumMatches do quit:RecNumIEN'=0 ;"Note: FIRST match returned. - . kill OneMatch - . merge OneMatch=Matches("DILIST","ID",index) - . if $$CompRec(FileNumber,.OneMatch,.SlimData) set RecNumIEN=Matches("DILIST",2,index) - -GRMQuit - quit result - - -CompRec(FileNumber,dbRec,TestRec) - ;"PUBLIC FUNCTION - ;"Purpose: To compare data from the database against a test match - ;"Input: FileNumber: the file data is from - ;" dbRec, an array of data from the database in the following format - ;" dbRec(.01)="JOHNS,BILL" - ;" dbRec(.02)="MALE" - ;" dbRec(.03)="01/20/1957" - ;" dbRec(.07)="(123) 555-1212" - ;" TestRec, an array of data to test for match with, in same format - ;" as above. Note: there may well be less entries in this array - ;" than in the dbRec - ;" TestRec(.01)="JOHNS,BILL" - ;" TestRec(.03)="01/20/1957" - ;"Output: 1 if all values in TestRec=dbRec. 0=conflict - ;" Note: values in dbRec that don't have a corresponding entry in TestRec - ;" are ignored. - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - - new result set result=cOKToCont - new index set index="" - new FieldType,TMGFDA,TMGMsg - new dbIDT,testIDT ;" IDT = internal form of date/time - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") - - if TMGDEBUG do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is records to be compared") - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbRec:") - . do ArrayDump^TMGDEBUG("dbRec") ;"zwr dbRec(*) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestRec:") - . do ArrayDump^TMGDEBUG("TestRec") ;"zwr TestRec(*) - -CRLoop - set index=$order(TestRec(index)) - if index="" goto CRDone - if $data(dbRec(index))=0 goto CRLoop - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Comparing field ",index) - kill TMGFDA,TMGMsg - do FIELD^DID(FileNumber,index,,"TYPE","TMGFDA","TMGMsg") - if $get(TMGFDA("TYPE"))="DATE/TIME" do goto CRDone:'result - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Doing special date comparison") - . set X=TestRec(index) - . do ^%DT ;"convert date/time into internal format - . set testIDT=Y - . set X=dbRec(index) - . do ^%DT ;"convert date/time into internal format - . set dbIDT=Y - . if testIDT'=dbIDT do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Dates not equal: ",TestRec(index)," vs, ",dbRec(index)) - . . set result=cAbort - else if TestRec(index)'=dbRec(index) do goto CRDone ;"Note: simple '=' compare - . set result=cAbort - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fields are equal") - goto CRLoop -CRDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Leaving CompRec. Result=",result," (0 if conflict)") - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"CompRec^TMGDBAPI") - quit result - - -UploadData(Data,RecNumIEN) - ;"PUBLIC FUNCTION - ;"Purpose: Do actual upload of Data, given in specific format - ;"Note: This function may be called recursively by subfiles - ;"Input: Data -- data in format show at TOP OF THIS FILE - ;" Note: If this function is being passed recursively, then the data - ;" passed is probably just a subpart that corresponds to the subfile - ;" RecNumIEN -- OPTIONAL pameter. May be used to specify the - ;" record to force data into. If passed by reference, then - ;" record number (IEN) where data was placed is passed back. - ;" Use of this parameter only makes sense when filing the highest - ;" level file. (When filing subfiles recursively, then the parent - ;" record number is stored in (0,cParentIENS)=",10033," e.g.) - ;"Output: Information will be put into global database, based on - ;" entries in Data. - ;" Record number (IEN) of record will be put into RecNumIEN (or 0 if error) - ;"Result: Returns success 1=OK to continue. 0=Abort - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cEntries set cEntries="Entries" - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") - - new result set result=cOKToCont - new NumEntries - new index - - set RecNumIEN=$get(RecNumIEN,0) ;"See if user-specified IEN was given. - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) - - if RecNumIEN'=0 do goto UDDone:(result=cAbort) - . new Params,MyOutVar - . set Params("FILE")=$get(Data(0,"FILE")) - . set Params(cRecNum)=RecNumIEN - . set Params(cField)=".01" - . set Params(cOutput)="MyOutVar" - . set result=$$ValueLookup(.Params) ;"result=0 (cAbort) if unsuccessful lookup - . if result=cAbort do - . . if $data(PriorErrorFound)=0 new PriorErrorFound - . . new s set s="Unable to overwrite data into record#"_RecNumIEN_" because that record does not already exist.\n" - . . set s=s_"Will try to put data into a new record, which may not be record#"_RecNumIEN - . . do ShowError^TMGDEBUG(.PriorErrorFound,s) - . . set result=cOKToCont - . . set PriorErrorFound=0 ;"clear errors and continue program. - . . set RecNumIEN=0 - - set NumEntries=$get(Data(0,cEntries)) - for index=1:1:NumEntries do quit:(result=cAbort) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop to process all uploadData entries. Entry=",index) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNumIEN=",RecNumIEN) - . new tData ;"Create a tData array that has only 1 entry in it. - . merge tData(0)=Data(0) - . set tData(0,cEntries)=1 - . merge tData(1)=Data(index) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"This is entry to process") - . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tData") - . if RecNumIEN=0 set result=$$GetRecMatch(.tData,.RecNumIEN) ;"if no prior record, returns 0 - . if result=cAbort quit ;//kt added 1/6/05 - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Using RecNumIEN=",RecNumIEN) - . ; - . if RecNumIEN=0 do quit:(result=cAbort) - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling AddRec") - . . new AddRecNum - . . set AddRecNum=$$AddRec(.tData) - . . if AddRecNum=0 do quit - . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error adding a record.") - . . . set result=cAbort - . else do quit:(result=cAbort) - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"calling Overwriterec") - . . set result=$$OverwriteRec(RecNumIEN,.tData) - . . set RecNumIEN=0 ;"We won't to file any more into that record num, force search next cycle. - . . if result=cAbort do quit - . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error modifying an existing record.") - -UDDone - ;"if (result'=cAbort) set result=(RecNumIEN>0) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Result = ",result) - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"UploadData^TMGDBAPI") - quit result - - - -ValueLookup(Params) - ;"PUBLIC FUNCTION - ;"Purpose: To look for a value of a given value in a given record in given file. - ;"Input: Params -- an array loaded with expected parameters. I.e.: - ;" Params("FILE")="NEW PERSON" in our example - ;" Params(cRecNum)="1" in example - ;" Params(cField)=".01" in our example (could be Name of field) - ;" Params(cOutput)="MyVar" - ;"Output: MyVar is loaded with data, i.e.: - ;" MyVar("FILE")=200 - ;" MyVar(cGlobal)="^VA(200)" - ;" MyVar(cGlobal,cOpen)="^VA(200," - ;" MyVar(cRecNum)=1 - ;" MyVar(cField)=.01 - ;" MyVar(cValue)=xxx <-- the looked-up value - ;"Returns: If should continue execution: 1=OK to continue. 0=unsuccessful lookup - ;"Note: I am getting values by directly looking into database, rather than use - ;" the usual lookup commands. I am doing this so that there will be no - ;" 'hidden' data, based on security etc. - ;" **I need to check, but this probably means that the data returned will be - ;" in INTERNAL FILEMAN FORMAT (i.e. time values are encoded etc.) - - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cField set cField="FIELD" ;"Field" - new cNull set cNull="(none)" - new cRecNum set cRecNum="RECNUM" ;"RecNum - new cOutput set cOutput="OUTVAR" ;"OutVar" - new cGlobal set cGlobal="GLOBAL" - new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" - new cOpen set cOpen="OPEN" - - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") - new result set result=cAbort - - new Data - new DDInfo - new FieldInfo - new Index,Part - - new Field set Field=$get(Params(cField),cNull) - new RecNum set RecNum=$get(Params(cRecNum),cNull) - new OutVarP set OutVarP=$get(Params(cOutput),cNull) - if (RecNum=cNull),(OutVarP=cNull) goto DVLUDone - kill @OutVarP ;"--ensure old variables in output variable are removed. - - set Data(0,"FILE")=$get(Params("FILE")) - set result=$$SetupFileNum(.Data) - if result=cAbort goto DVLUDone - new FileNum set FileNum=$get(Data(0,"FILE"),cNull) - new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) - if (FileNum=cNull),(GlobalP=cNull) goto DVLUDone - new FieldNum set FieldNum=$$GetNumField(FileNum,Field) - if FieldNum=0 goto DVLUDone - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"GlobalP: ",GlobalP) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"File: ",FileNum) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Rec#: ",RecNum) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum: ",FieldNum) - - ;"Get info from data dictionary r.e. where actual fields are stored in files. - set DDInfo=$get(^DD(FileNum,FieldNum,0)) - if $data(DDInfo)=0 goto HWDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo='",DDInfo,"', $data(DDInfo)=",$data(DDinfo)) - set FieldInfo=$piece(DDInfo,"^",4) - if '$data(FieldInfo),(FieldInfo="") goto DVLUDone - set Index=$piece(FieldInfo,";",1) - set Part=$piece(FieldInfo,";",2) - - if $data(@GlobalP@(RecNum,Index))=0 goto DVLUDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"That line is now: ",@GlobalP@(RecNum,Index)) - set Data=$piece(@GlobalP@(RecNum,Index),"^",Part) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"And our value is: ",Data) - - kill @OutVarP - set @OutVarP@("FILE")=FileNum - set @OutVarP@(cRecNum)=RecNum - set @OutVarP@(cField)=FieldNum - set @OutVarP@(cValue)=Data - set @OutVarP@(cGlobal)=GlobalP - set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) - - set result=cOKToCont - -DVLUDone - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ValueLookup^TMGDBAPI") - quit result - - -FileUtility(Params) - ;"PUBLIC FUNCTION - ;"Purpose: To provide file access/manipulation utilities to script user - ;"syntax: - ;" - ;"Input: Params -- an array loaded with expected parameters. I.e.: - ;" Params("FILE")="NEW PERSON" for example - ;" File: The name of the file to act upon. - ;" File may have subnodes (i.e. "NEW PERSON|ALIAS|TITLE") - ;" **BUT**, any deletion or set values will only work on top level (i.e. "NEW PERSON") - ;" Params(cFn)="info" or "delete", or "set" [OPTIONAL] - ;" Fn="delete" If Field is not specified: - ;" Will cause record RecNum to be deleted. - ;" MyOutVar("DELETED")=RecNum of deleted record, or - ;" 0 if not found. - ;" If Field IS specified: - ;" Will delete the value in field, in record RecNum - ;" Note: delete is intended only for the highest-level records - ;" (i.e. not subfiels, or multiple fields) - ;" Note: delete method uses ^DIK to delete the record - ;" Fn="info" Will just fill in info below. - ;" If Fn not specified, this is default - ;" Fn="set" Will put Value into Field, in RecNum, in File (all required) - ;" Params(cRecNum)="1" for example - ;" RecNum: [OPTIONAL] Specifies which record to act on. If not - ;" specified, then just file info is returned. - ;" Params(cField)=".01" for example (could be Name of field) - ;" Field: [OPTIONAL] Specifies which field to act on. - ;" Params(cOutput)="MyVar" - ;" OutVar: Needed to get information back from function (but still Optional) - ;" Gives name of variable to put info into. - ;"Output: MyVar is loaded with data, i.e. - ;" i.e. MyOutVar("FILE")=Filenumber - ;" MyOutVar("FILE","FILE")=SubFilenumber <-- only if subnodes input in File name (e.g."ALIAS") - ;" MyOutVar("FILE","FILE","FILE")=SubSubFilenumber <-- only if subnodes input in File name (e.g."TITLE") - ;" MyOutVar("GLOBAL")="^VA(200)" - ;" MyOutVar("GLOBAL, OPEN")="^VA(200," - ;" MyOutVar("RECNUM")=record number - ;" MyOutVar("FIELD")=Filenumber - ;" MyOutVar("VALUE")=xxxx <=== value of field (PRIOR TO deletion, if deleted) - ;" MyOutVar("NEXTREC")=record number after RecNum, or "" if none - ;" MyOutVar("PREVREC")=record number before RecNum, or "" if none - ;" MyOutVar("FN")=the function executed - ;" MyOutVar("NUMRECS")=Number of records in file PRIOR to any deletions - ;" MyOutVar("FIRSTREC")=Rec number of first record in file - ;" MyOutVar("LASTREC")=Rec number of last record in file - ;"Returns: If should continue execution: 1=OK to continue. 0=abort - ;"Note: I am getting values by directly looking into database, rather than use - ;" the usual lookup commands. I am doing this so that there will be no - ;" 'hidden' data, based on security etc. - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cField set cField="FIELD" ;"Field" - new cNull set cNull="(none)" - new cRecNum set cRecNum="RECNUM" ;"RecNum - new cRecord set cRecord="RECORD" ;"Record" - new cOutput set cOutput="OUTVAR" ;"OutVar" - new cGlobal set cGlobal="GLOBAL" - new cValueLookup set cValueLookup="LOOKUPFIELDVALUE" ;"LookupFieldValue" - new cOpen set cOpen="OPEN" - new cInfo set cInfo="INFO" ;"Info - if $data(cNodeDiv)#10=0 new cNodeDiv set cNodeDiv="|" - new cDelete set cDelete="DELETE" ;"Delete - new cNextRec set cNextRec="NEXTREC" - new cPrev set cPrev="PREV" - new cNumRecs set cNumRecs="NUMRECS" - new cFirstRec set cFirstRec="FIRSTREC" - new cLastRec set cLastRec="LASTREC" - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") - new result set result=cAbort - - new Data - new DDInfo - new FieldInfo - new Index,Part - new DummyOut - - new OutVarP set OutVarP=$get(Params(cOutput),cNull) - ;"if (OutVarP=cNull) goto DFUTDone - if (OutVarP=cNull) do - . set OutVarP="DummyOut" - - kill @OutVarP ;"--ensure old variables in output variable are removed. - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output variable=",OutVarP) - - new RecNum set RecNum=$get(Params(cRecNum)) - set @OutVarP@(cRecNum)=RecNum - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) - - new Fn set Fn=$get(Params(cFn),cInfo) - set Fn=$$UP^XLFSTR(Fn) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Action Fn=",Fn) - - new Value set Value=$get(Params(cValue)) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Value=",Value) - - new FileN set FileN=$get(Params("FILE")) - - new SpliceArray - if FileN[cNodeDiv do ;"Parse 'NEW PERSON|ALIAS|TITLE' into 'NEW PERSON', 'ALIAS', 'TITLE' - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Multiple nodes found for file name. Processing...") - . do CleaveToArray^TMGSTUTL(FileN,cNodeDiv,.SpliceArray) - . set FileN=$get(SpliceArray(1)) - set Data(0,"FILE")=FileN - set result=$$SetupFileNum(.Data) if result=cAbort goto DFUTDone - new FileNum set FileNum=$get(Data(0,"FILE"),cNull) - set @OutVarP@("FILE")=FileNum - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) - - new index set index=2 - new GlobalP set GlobalP=$name(@OutVarP@("FILE")) - if $data(SpliceArray(index)) do - . for index=index:1 do quit:index="" - . . set FileN=SpliceArray(index) - . . set FileNum=$$GetSubFileNumber(FileNum,FileN) - . . if +FileNum'=0 set @GlobalP@("FILE")=FileNum - . . set GlobalP=$name(@GlobalP@("FILE")) - . . set index=$order(SpliceArray(index)) - - new GlobalP set GlobalP=$get(Data(0,"FILE",cGlobal),cNull) - if (FileNum=cNull),(GlobalP=cNull) goto DFUTDone - set @OutVarP@(cGlobal)=GlobalP - set @OutVarP@(cGlobal,cOpen)=$get(Data(0,"FILE",cGlobal,cOpen)) - - ;"If we've gotten this far, will consider the function a success - set result=cOKToCont - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Setting fn result to success") - - new FieldN set FieldN=$get(Params(cField)) - new FieldNum - if (+FieldN=0)&(FieldN'="") do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldN=",FieldN) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNum=",FileNum) - . set FieldNum=$$GetNumField(FileNum,FieldN) - else do - . if FieldN - . set FieldNum=FieldN - set @OutVarP@(cField)=FieldNum - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) - - if $data(@GlobalP@(0))=0 goto DFUTDone - new NumRecs set NumRecs=$piece(@GlobalP@(0),"^",4) - new LastRec set LastRec=$piece(@GlobalP@(0),"^",3) - set @OutVarP@(cNumRecs)=NumRecs - set @OutVarP@(cLastRec)=LastRec - new RecI set RecI=LastRec - new PrevRec - for do quit:(RecI="")!(RecI=0) ;"Scan backwards to find first record - . set PrevRec=$order(@GlobalP@(RecI),-1) - . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"PrevRec=",PrevRec," RecI=",RecI) - . if (PrevRec="")!(PrevRec=0) do - . . set @OutVarP@(cFirstRec)=RecI - . set RecI=PrevRec - - if FieldNum="" do goto DFUTDone - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No field name specified") - . if (Fn=cDelete)&(RecNum'="") do - . . set DIK=$get(Data(0,"FILE",cGlobal,cOpen)) - . . set DA=RecNum - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Deleting one record (number: ",RecNum,") from File number",FileNum) - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Notice: deleting record does not clear any pointers to deleted records") - . . do ^DIK - - ;"Get info from data dictionary r.e. where actual fields are stored in files. - set DDInfo=$get(^DD(FileNum,FieldNum,0)) - if '$data(DDInfo) goto HWDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DDInfo=",DDInfo) - set FieldInfo=$piece(DDInfo,"^",4) - if '$data(FieldInfo),(FieldInfo="") goto DFUTDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldInfo=",FieldInfo) - set Index=$piece(FieldInfo,";",1) - set Part=$piece(FieldInfo,";",2) - - if RecNum="" goto DFUTDone - if $data(@GlobalP@(RecNum,Index))=0 goto DFUTDone - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"I think the correct data place is: ",GlobalP,"(",RecNum,",",Index,") at piece: ",Part) - new Temp set Temp=@GlobalP@(RecNum,Index) - set @OutVarP@(cValue)=$piece(Temp,"^",Part) - kill Temp - set @OutVarP@(cNextRec)=$order(@GlobalP@(RecNum)) - set @OutVarP@(cPrev)=$order(@GlobalP@(RecNum),-1) - - if Fn=cDelete do - . set $piece(@GlobalP@(RecNum,Index),"^",Part)="" - - if Fn=cSet do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Performing a hack write. CAUTION!") - . set $piece(@GlobalP@(RecNum,Index),"^",Part)=Value - - set result=cOKToCont - -DFUTDone - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Fn result=",result) - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DoFileUtility^TMGDBAPI") - quit result - - - -AddRec(Data) - ;"Purpose: Use info from data array to create a MINIMAL new record in database - ;" This record will have only it's .01 field, and any multiple - ;" subfiles will have only their .01 fields also. - ;"Input: Data - Data array should be in format output from GetRInfo - ;"Output: data base will be modified by adding record - ;"Assumption: That a matching record does not already exist in database - ;"Returns: RecNum of added record, or 0 if error (0=abort) - - ;"NOTE!!! -- As I review this code, does it really return record number added??? - - if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 - new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new cParentIENS set cParentIENS="ParentIENS" - - - new tmgFDA,TMGFDA ;"Fileman Data Array - new IENS ;"Internal Entry Number String - new RecNum ;"Internal number entry array - new Flags - new TMGMsg - new FileNum - new result set result=cAbort - new FDAIndex - new MarkerArray - new MsgArray - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") - - set IENS=$get(Data(0,cParentIENS)) - - new MarkNum set MarkNum=0 - set result=$$SetupFDA(.Data,.tmgFDA,IENS,"+",.MarkNum,.MsgArray) - if result=cAbort goto SkRDone - set FileNum=$get(Data(0,"FILE"),0) - if FileNum=0 set result=cAbort goto SkRDone - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") - if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("MsgArray") - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") - if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) - - set FDAIndex=FileNum - for do quit:(FDAIndex="")!(result=cAbort) - . kill TMGFDA - . merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting cycle with "_FDAIndex_" part.") - . ; - . set Flags="E" ;"E=External format values - . ; - . set result=$$ConvertFDA(.TMGFDA,.MarkerArray) - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"AFTER CONVERSION, Here is the FDA to pass to UPDATE^DIE") - . if TMGDEBUG do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) - . ; - . ;"====================================================== - . ;"Call UPDATE^DIE - . ;"====================================================== - . if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") - . if $data(TMGFDA)'=0 do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",Flags) - . . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, UPDATE^DIE adds new entries in files or subfiles.") - . . set ^TMP("TMG",$J,"ErrorTrap")=result - . . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" - . . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMsg") - . . set result=^TMP("TMG",$J,"ErrorTrap") - . . kill ^TMP("TMG",$J,"ErrorTrap") - . . kill ^TMP("TMG",$J,"Caller") - . if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::UPDATE^DIE") - . ;"====================================================== - . ;"====================================================== - . ; - . if $data(RecNum) do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is RecNum array after update/filing") - . . if TMGDEBUG do ArrayDump^TMGDEBUG("RecNum") ;"zwr RecNum(*) - . . merge MarkerArray=RecNum - . . if result=cAbort do - . . . new index - . . . set index=$order(RecNum("")) - . . . set result=$get(RecNum(index)) - . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Output Record#=",result) - . else do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After update/filing, RecNum array is empty!") - . ; - . if $data(TMGMsg("DIERR")) do quit - . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . . if $data(RecNum(1)) do - . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Trying to ignore error") - . . . set PriorErrorFound=0 - . . else do - . . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Unable to ignore error") - . . . set result=cAbort - . do - . . new tI set tI=FDAIndex - . . set FDAIndex=$order(tmgFDA(FDAIndex)) - . . kill tmgFDA(tI) - - if result=cAbort do goto SkRDone - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Error encountered, dropping out.") - - set result=$$HandleHacksArray(.MsgArray) - - if result=cAbort goto SkRDone - -SkRDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"AddRec^TMGDBAPI") - quit result - - - - ;"========================================================= - ;" Error trap routine - ;"========================================================= -ErrTrp - new cAbort set cAbort=0 - set $etrap="",$ecode="" - new Caller - set Caller=$get(^TMP("TMG",$J,"Caller"),"?") - do ShowError^TMGDEBUG(.PriorErrorFound,"Error trapped. Caller was: ",Caller) - if $data(TMGMsg) do ShowDIERR^TMGDEBUG(TMGMsg) - set ^TMP("TMG",$J,"ErrorTrap")=cAbort - quit - ;"========================================================= - ;" End of Error trap routine - ;"========================================================= - - ;"======================================================== - ;"The following routines were moved to shorten module length - -ConvertFDA(FDA,MarkerArray) - goto ConvertFDA+1^TMGDBAP2 - -ConvertIENS(IENS,MarkerArray) - goto ConvertIENS+1^TMGDBAP2 - -SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) - goto SetupFDA+1^TMGDBAP2 - -OverwriteRec(RecNum,Data) - goto OverwriteRec+1^TMGDBAP2 - -GetFileNum(FileName) - goto GetFileNum+1^TMGDBAP2 - -GetFName(FileNumber) - goto GetFName+1^TMGDBAP2 - -GetFldName(File,FieldNumber) - goto GetFldName+1^TMGDBAP2 - -GetFldList(File,pArray) - goto GetFldList+1^TMGDBAP2 - -SetupFileNum(Data) - goto SetupFileNum+1^TMGDBAP2 - -RecFind(Params) - goto RecFind+1^TMGDBAP2 - -FieldCompare(TestField,dbField,Type) - goto FieldCompare+1^TMGDBAP2 - -EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) - goto EnsureWrite+1^TMGDBAP2 - -dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) - goto dbWrite+1^TMGDBAP2 - -DelIEN(File,RecNumIEN,ErrArray) - goto DelIEN+1^TMGDBAP2 - -WriteWP(File,RecNumIEN,Field,TMGArray) - goto WriteWP+1^TMGDBAP2 - -ReadWP(File,IENS,Field,Array) - goto ReadWP+1^TMGDBAP2 - -ShowIfError(TMGMsg,PriorErrorFound) - goto ShowIfError+1^TMGDBAP2 - -DataImport(Info,ProgressFN) - goto DataImport+1^TMGDBAP2 - -Set1(File,IEN,Field,Value,Flag) - goto Set1+1^TMGDBAP2 - -GetValidInput(File,Field) - goto GetValidInput+1^TMGDBAP2 - -AskFIENS() - goto AskFIENS+1^TMGDBAP2 - -ASKSCRN - goto ASKSCRN+1^TMGDBAP2 - -AskIENS(FileNum,IENS) - goto AskIENS+1^TMGDBAP2 - -GetRefArray(FileNum,array) - goto GetRefArray+1^TMGDBAP2 - -FIENS2Root(FIENS) - goto FIENS2Root+1^TMGDBAP2 - -GetRef(file,IENS,field) - goto GetRef+1^TMGDBAP2 - -TrimFDA(FDA,Quiet) - goto TrimFDA+1^TMGDBAP2 - -GetPtrsOUT(File,Info) - goto GetPtrsOUT+1^TMGDBAP2 - Index: cprs/branches/tmg-cprs/m_files/TMGDEBUG.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGDEBUG.m~ (revision 796) +++ (revision ) @@ -1,764 +1,0 @@ -TMGDEBUG ;TMG/kst/Debug utilities: logging, record dump ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - ;"TMG DEBUG UTILITIES - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"$$GetDebugMode^TMGDEBUG(DefVal) - ;"OpenDefLogFile^TMGDEBUG - ;"OpenLogFile^TMGDEBUG(DefPath,DefName) - ;"DebugMsg^TMGDEBUG(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) - ;"DebugWrite^TMGDEBUG(DBIndent,s,AddNewline) - ;"DebugIndent^TMGDEBUG(Num) - ;"ArrayDump^TMGDEBUG(ArrayP,index,indent) - ;"ASKANODES - ;"ArrayNodes(pArray) - ;"DebugEntry^TMGDEBUG((DBIndent,ProcName) - ;"DebugExit^TMGDEBUG(DBIndent,ProcName) - ;"ShowError^TMGDEBUG(PriorErrorFound,Error) - ;"$$GetErrStr^TMGDEBUG(ErrArray) - ;"ShowIfDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) ;really same as below - ;"ShowDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) - ;"ExpandLine(Pos) - ;"ASKDUMP -- A record dumper -- a little different from Fileman Inquire - ;"DumpRec(FileNum,IEN) -- dump (display) a record, using Fileman functionality. - ;"DumpRec2(FileNum,IEN,ShowEmpty) -- dump (display) a record, NOT Fileman's Inquire code - - ;"======================================================================= - ;"Private API functions - - ;"DumpRec2(FileNum,IEN,ShowEmpty) - ;"WriteRLabel(IEN,Ender) - ;"WriteFLabel(Label,Field,Type,Ender) - ;"WriteLine(Line) - - ;"======================================================================= - ;"DEPENDENCIES - ;" TMGUSRIF - - ;"Note: This module accesses custom file 22711, TMG UPLOAD SETTINGS - ;" It is OK if this file does not exist (i.e. on other computer systems.) However, the function - ;" OpenDefLogFile will fail to find a default specified file, and would not open a log file. - ;" Nothing is PUT INTO this file in this module. So new global would NOT be created. - ;"======================================================================= - ;"======================================================================= - -GetDebugMode(DefVal) - ;"Purpose: to ask if debug output desired - ;"Input: DefVal [optional] -- Default choice - ;"result: returns values as below - ;" 0, cdbNone - no debug - ;" 1, cdbToScrn - Debug output to screen - ;" 2, cdbToFile - Debug output to file - ;" 3, cdbToTail - Debug output to X tail dialog box. - ;" Note: 2-2-06 I am adding a mode (-1) which is EXTRA QUIET (used initially in ShowError) - ;"Note: This does not set up output streams etc, just gets preference. - - new cdbNone set cdbNone=0 - new cdbAbort set cdbAbort=0 - new cdbToScrn set cdbToScrn=1 ;"was 2 - new cdbToFile set cdbToFile=2 ;"was 3 - new cdbToTail set cdbToTail=3 ;"was 4 - - new Input - new result set result=cdbNone ;"the default - new Default set Default=$get(DefVal,3) - - write !,"Select debug output option:",! - write " '^'. Abort",! - write " 0. NO debug output",! - write " 1. Show debug output on screen",! - write " 2. Send debug output to file",! - if $get(DispMode(cDialog)) do - . write " 3. Show debug output in X tail dialog box.",! - - write "Enter option number ("_Default_"): " - read Input,! - - if Input="" do - . write "Defaulting to: ",Default,! - . set Input=Default - - if Input="^" set result=cdbAbort - if Input=0 set result=cdbNone - if Input=1 set result=cdbToScrn - if Input=2 set result=cdbToFile - if Input=3 set result=cdbToTail - -GDMDone - quit result - -OpenDefLogFile - ;"Purpose: To open a default log file for debug output - ;"Results: none - - new DefPath,DefName - - set DefPath=$piece($get(^TMG(22711,1,2)),"^",1) - set DefName=$piece($get(^TMG(22711,1,1)),"^",1) - - do OpenLogFile(.DefPath,.DefName) - - quit - - -OpenLogFile(DefPath,DefName) - ;"Purpose: To open a log file for debug output - ;"Input: DefPath -- the default path, like this: "/tmp/" <-- note trailing '/' - ;" DefName -- default file name (without path). e.g. "LogFile.tmp" - ;"Results: None - - new DebugFPath set DebugFPath=$get(DefPath,"/tmp/") - new DebugFName set DebugFName=$get(DefName,"M_DebugLog.tmp") - if $get(TMGDEBUG)>1 do - . write "Note: Sending debug output to file: ",DebugFPath,DebugFName,! - - ;"new DebugFile -- don't NEW here, needs to be global-scope - set DebugFile=DebugFPath_DebugFName - new FileSpec set FileSpec(DebugFile)="" - - if +$piece($get(^TMG(22711,1,1)),"^",2)'=1 do - . ;"kill any pre-existing log - . new result - . set result=$$DEL^%ZISH(DebugFPath,$name(FileSpec)) ;"delete any preexisting one. - - open DebugFile - use $PRINCIPAL - - quit - - -DebugMsg(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L) - ;"PUBLIC FUNCTION - ;"Purpose: a debugging message output procedure - ;"Input:DBIndent -- the value of indentation expected - ;" Msg -- a string or value to show as message - ;" A..L -- extra values to show. - ;" - if $get(TMGDEBUG,0)=0 quit - set cTrue=$get(cTrue,1) - set DBIndent=$get(DBIndent,0) - - set Msg=$get(Msg) - set Msg=Msg_$get(A) - set Msg=Msg_$get(B) - set Msg=Msg_$get(C) - set Msg=Msg_$get(D) - set Msg=Msg_$get(E) - set Msg=Msg_$get(F) - set Msg=Msg_$get(G) - set Msg=Msg_$get(H) - set Msg=Msg_$get(I) - set Msg=Msg_$get(J) - set Msg=Msg_$get(K) - set Msg=Msg_$get(L) - do DebugIndent(DBIndent) - do DebugWrite(DBIndent,.Msg,cTrue) - - quit - - -DebugWrite(DBIndent,s,AddNewline) - ;"PUBLIC FUNCTION - ;"Purpose: to write debug output. Having the proc separate will allow - ;" easier dump to file etc. - ;"Input:DBIndent, the amount of indentation expected for output. - ;" s -- the text to write - ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s - - ;"Relevant DEBUG values - ;" cdbNone - no debug (0) - ;" cdbToScrn - Debug output to screen (1) - ;" cdbToFile - Debug output to file (2) - ;" cdbToTail - Debug output to X tail dialog box. (3) - ;"Note: If above values are not defined, then functionality will be ignored. - - - set cdbNone=$get(cdbNone,0) - set cdbToScrn=$get(cdbToScrn,1) - set cdbToFile=$get(cdbToFile,2) - set cdbToTail=$get(cdbToTail,3) - set TMGDEBUG=$get(TMGDEBUG,cdbNone) - if $get(TMGDEBUG)=cdbNone quit - - if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do - . if $data(DebugFile) use DebugFile - - new ch,chN,l,i - set l=$length(s) - for i=1:1:l do - . set ch=$extract(s,i) - . set chN=$ascii(ch) - . if (chN<32)&(chN'=13) write "<",chN,">" - . else write ch - ;"write s - - set cTrue=$get(cTrue,1) - if $get(AddNewline)=cTrue write ! - - if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do - . use $PRINCIPAL - - quit - - -DebugIndent(DBIndentForced) - ;"PUBLIC FUNCTION - ;"Purpose: to provide a unified indentation for debug messages - ;"Input: DBIndent = number of indentations - ;" Forced = 1 if to indent regardless of DEBUG mode - - set Forced=$get(Forced,0) - - if ($get(TMGDEBUG,0)=0)&(Forced=0) quit - new i - for i=1:1:DBIndent do - . if Forced do DebugWrite(DBIndent," ") - . else do DebugWrite(DBIndent,". ") - quit - - - -ArrayDump(ArrayP,TMGIDX,indent,flags) - ;"PUBLIC FUNCTION - ;"Purpose: to get a custom version of GTM's "zwr" command - ;"Input: Uses global scope var DBIndent (if defined) - ;" ArrayP: NAME of global or variable to display, i.e. "^VA(200)", "MyVar" - ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) -- Optional - ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces) - ;" OPTIONAL: indent may be an array, with information about columns - ;" to skip. For example: - ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2 - ;" flags: OPTIONAL. "F"-> flat (don't use tre structure) - ;"Result: none - - ;"--Leave out, this calls itself recursively! do DebugEntry("ArrayDump") - ;"--Leave out, this calls itself recursively! do DebugMsg^TMGDEBUG("ArrayP=",ArrayP,", TMGIDX=",index) - - if $data(ArrayP)=0 quit - - if $get(flags)["F" do goto ADDone - . new ref set ref=ArrayP - . new nNums set nNums=$qlength(ref) - . new lValue set lValue=$qsubscript(ref,nNums) - . write ref,"=""",$get(@ref),"""",! - . for set ref=$query(@ref) quit:(ref="")!($qsubscript(ref,nNums)'=lValue) do - . . write ref,"=""",$get(@ref),"""",! - - ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. - new X set X="SET TEMP=$GET("_ArrayP_")" - set X=$$UP^XLFSTR(X) - do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. - if $get(X)="" quit - - set DBIndent=$get(DBIndent,0) - set cTrue=$get(cTrue,1) - set cFalse=$get(cFalse,0) - - ;"Force this function to output, even if TMGDEBUG is not defined. - ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working - new TMGDEBUG ;"//kt added 1-16-06 - set TMGDEBUG=1 - - new ChildP,TMGi - - set TMGIDX=$get(TMGIDX,"") - set indent=$get(indent,0) - new SavIndex set SavIndex=TMGIDX - - do DebugIndent(DBIndent) - - if indent>0 do - . for TMGi=1:1:indent-1 do - . . new s set s="" - . . if $get(indent(TMGi),-1)=0 set s=" " - . . else set s="| " - . . do DebugWrite(DBIndent,s) - . do DebugWrite(DBIndent,"}~") - - if TMGIDX'="" do - . if $data(@ArrayP@(TMGIDX))#10=1 do - . . new s set s=@ArrayP@(TMGIDX) - . . if s="" set s="""""" - . . new qt set qt="" - . . if +TMGIDX'=TMGIDX set qt="""" - . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue) - . else do - . . do DebugWrite(DBIndent,TMGIDX,1) - . set ArrayP=$name(@ArrayP@(TMGIDX)) - else do - . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse) - . do DebugWrite(DBIndent,ArrayP,cFalse) - . if $data(@ArrayP)#10=1 do - . . do DebugWrite(0,"="_$get(@ArrayP),cFalse) - . do DebugWrite(0,"",cTrue) - - set TMGIDX=$order(@ArrayP@("")) - if TMGIDX="" goto ADDone - set indent=indent+1 - - for do quit:TMGIDX="" - . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) - . if tTMGIDX="" set indent(indent)=0 - . new tIndent merge tIndent=indent - . do ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively - . set TMGIDX=$order(@ArrayP@(TMGIDX)) - - ;"Put in a blank space at end of subbranch - do DebugIndent(DBIndent) - - if indent>0 do - . for TMGi=1:1:indent-1 do - . . new s set s="" - . . if $get(indent(TMGi),-1)=0 set s=" " - . . else set s="| " - . . do DebugWrite(DBIndent,s) - . do DebugWrite(DBIndent," ",1) - -ADDone - ;"--Leave out, this calls itself recursively! do DebugExit("ArrayDump") - quit - - -ASKANODES - ;"Purpose: to ask user for the name of an array, then display nodes - - new name - write ! - read "Enter name of array to display nodes in: ",name,! - if name="^" set name="" - if name'="" do ArrayNodes(name) - quit - - -ArrayNodes(pArray) - ;"Purpose: To display all the nodes of the given array - ;"Input: pArray -- NAME OF array to display - - new TMGi - - write pArray,! - set TMGi=$order(@pArray@("")) - if TMGi'="" for do quit:(TMGi="") - . write " +--(",TMGi,")",! - . set TMGi=$order(@pArray@(TMGi)) - - quit - -DebugEntry(DBIndent,ProcName) - ;"PUBLIC FUNCTION - ;"Purpose: A way to show when entering a procedure, in debug mode - ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE - ;" ProcName: any arbitrary name to show when decreasing indent amount. - - set ProcName=$get(ProcName,"?") - set DBIndent=$get(DBIndent,0) - do DebugMsg(DBIndent,ProcName_" {") - set DBIndent=DBIndent+1 - quit - - -DebugExit(DBIndent,ProcName) - ;"PUBLIC FUNCTION - ;"Purpose: A way to show when leaving a procedure, in debug mode - ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE - ;" ProcName: any arbitrary name to show when decreasing indent amount. - - ;"write "DBIndent=",DBIndent,! - ;"write "ProcName=",ProcName,! - set ProcName=$get(ProcName,"?") - set DBIndent=$get(DBIndent)-1 - if DBIndent<0 set DBIndent=0 - do DebugMsg(DBIndent,"} //"_ProcName) - - quit - - - - -ShowError(PriorErrorFound,Error) - ;"Purpose: to output an error message - ;"Input: [OPTIONAL] PriorErrorFound -- var to see if an error already shown. - ;" if not passed, then default value used ('no prior error') - ;" Error -- a string to display - ;"results: none - - if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely - - if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowError") - if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error msg=",Error) - - if $get(PriorErrorFound,0) do goto ShErrQuit ;"Remove to show cascading errors - . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Prior error found, so won't show this error.") - - if $data(DBIndent)=0 new DBIndent ;"If it wasn't global before, keep it that way. - new SaveIndent set SaveIndent=$get(DBIndent) - set DBIndent=1 - do PopupBox^TMGUSRIF(" ERROR . . .",Error) - set PriorErrorFound=1 - set DBIndent=SaveIndent - -ShErrQuit - if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowError") - - quit - - -GetErrStr(ErrArray) - ;"Purpose: convert a standard DIERR array into a string for output - ;"Input: ErrArray -- PASS BY REFERENCE. example: - ;" array("DIERR")="1^1" - ;" array("DIERR",1)=311 - ;" array("DIERR",1,"PARAM",0)=3 - ;" array("DIERR",1,"PARAM","FIELD")=.02 - ;" array("DIERR",1,"PARAM","FILE")=2 - ;" array("DIERR",1,"PARAM","IENS")="+1," - ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers." - ;" array("DIERR","E",311,1)="" - ;"Results: returns one long equivalent string from above array. - - new ErrStr - new TMGIDX - new ErrNum - - set ErrStr="" - for ErrNum=1:1:+$get(ErrArray("DIERR")) do - . set ErrStr=ErrStr_"Fileman says: '" - . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") " - . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT","")) - . if TMGIDX'="" for do quit:(TMGIDX="") - . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" " - . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX)) - . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do - . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0)) - . . set ErrStr=ErrStr_"Details: " - . . for do quit:(TMGIDX="") - . . . if TMGIDX="" quit - . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" " - . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX)) - - quit ErrStr - - - -ShowIfDIERR(ErrMsg,PriorErrorFound) ;"really same as below - goto SEL1 - -ShowDIERR(ErrMsg,PriorErrorFound) - ;"Purpose: To provide a standard output mechanism for the fileman DIERR message - ;"Input: ErrMsg -- PASS BY REFERENCE. a standard error message array, as - ;" put out by fileman calls - ;" PriorErrorFound -- OPTIONAL variable to keep track if prior error found. - ;" Note -- can also be used as ErrorFound (i.e. set to 1 if error found) - ;"Output -- none - ;"Result -- none - -SEL1 - if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely - - if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowDIERR") - - if $data(ErrMsg("DIERR")) do - . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error message found. Here is array:") - . if $get(TMGDEBUG) do ArrayDump("ErrMsg") - . new ErrStr - . set ErrStr=$$GetErrStr(.ErrMsg) - . do ShowError(.PriorErrorFound,.ErrStr) - - if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowDIERR") - quit - -ExpandLine(Pos) - ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality - ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS) - ;"Output: Writes to the currently selecte IO device and expansion of one line of code - ;"Note: This is used for taking the very long lines of code, as found in Fileman, and - ;" convert them to a format with one command on each line. - ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA - ;" conventions--such as commands must be UPPERCASE etc. - - ;"--- copied and modified from XINDX8.m --- - - kill ^UTILITY($J) - - new label,offset,RTN,dmod - do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) - if label'="" do ;"change position from one relative to label into one relative to top of file - . new CodeArray - . set Pos=$$ConvertPos^TMGMISC(Pos,"CodeArray") - . do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod) - - if RTN="" goto ELDone - - do BUILD^XINDX7 - set ^UTILITY($J,RTN)="" - do LOAD^XINDEX - set CCN=0 - for I=1:1:+^UTILITY($J,1,RTN,0,0) S CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2 - set ^UTILITY($J,1,RTN,0)=CCN - ;"do ^XINDX8 -- included below - - new Q,DDOT,LO,PG,LIN,ML,IDT - new tIOSL set tIOSL=IOSL - set IOSL=999999 ;"really long 'page length' prevents header printout (and error) - - set Q="""" - set DDOT=0 - set LO=0 - set PG=+$G(PG) - - set LC=offset - if $D(^UTILITY($J,1,RTN,0,LC)) do - . S LIN=^(LC,0),ML=0,IDT=10 - . set LO=LC-1 - . D CD^XINDX8 - - K AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY - - set IOSL=tIOSL ;"restore saved IOSL -ELDone - quit - - -DumpRec(FileNum,IEN) - ;"Purpose: to dump (display) a record, using Fileman functionality. - ;"Input: FileNum -- the number of the file to dump from - ;" IEN -- the record number to display - ;"Note: this code is modified from INQ^DII - - new DIC,X,Y,DI,DPP,DK,DICSS - - set X=FileNum,Y=X - - set DI=$get(^DIC(FileNum,0,"GL")) if DI="" quit - set DPP(1)=FileNum_"^^^@" - set DK=FileNum - - K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS - - set DIK=1 - set ^UTILITY(U,$J,DIK,IEN)="" ;"<-- note, to have multiple IEN's shown, iterate via DIK - - do S^DII ;"Jump into Fileman code. - - quit - - -xASKDUMP - ;"Purpose: A record dumper -- a little different from Fileman Inquire - - new DIC,X,Y - new FileNum,IEN - new UseDefault set UseDefault=1 - - ;"Pick file to dump from -xASK1 set DIC=1 - set DIC(0)="AEQM" - if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called - . do ^DICRW ;" has default value of user's last response - else do ^DIC ;doesn't have default value... - if +Y'>0 write ! goto xASKDone - set FileNum=+Y - - ;"Pick record to dump -xASKLOOP kill DIC,X - set DIC=+FileNum - set DIC(0)="AEQM" - do ^DIC write ! - if +Y'>0 set UseDefault=0 goto xASK1 - set IEN=+Y - - new % set %=2 - write "Display empty fields" - do YN^DICN - if %=-1 write ! goto xASKDone - - new %ZIS - set %ZIS("A")="Enter Output Device: " - set %ZIS("B")="HOME" - do ^%ZIS ;"standard device call - if POP do goto xASKDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") - use IO - - ;"Do the output - write ! - do DumpRec2(FileNum,IEN,(%=1)) - - ;" Close the output device - do ^%ZISC - - new temp - read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! - - goto xASKLOOP - -xASKDone - quit - -ASKDUMP - ;"Purpose: A record dumper -- a little different from Fileman Inquire - - write !!," -= RECORD DUMPER =-",! - new FIENS,IENS -AL1 - set FIENS=$$AskFIENS^TMGDBAPI() - if (FIENS["?")!(FIENS="^") goto ASKDone - - set FileNum=$piece(FIENS,"^",1) - set IENS=$piece(FIENS,"^",2) - -AL2 - set IENS=$$AskIENS^TMGDBAPI(FileNum,IENS) - if (IENS["?")!(IENS="") goto AL1 - - new % set %=2 - write "Display empty fields" - do YN^DICN - if %=-1 write ! goto ASKDone - - new %ZIS - set %ZIS("A")="Enter Output Device: " - set %ZIS("B")="HOME" - do ^%ZIS ;"standard device call - if POP do goto ASKDone - . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") - use IO - - ;"Do the output - write ! do DumpRec2(FileNum,IENS,(%=1)) - - ;" Close the output device - do ^%ZISC - - do PressToCont^TMGUSRIF - ;"new temp - ;"read "Press [ENTER] to continue...",temp:$get(DTIME,3600),! - - set IENS=$piece(IENS,",",2,99) ;"force Pick of new record to dump - if +IENS>0 goto AL2 - goto AL1 - -ASKDone - quit - - -DumpRec2(FileNum,IENS,ShowEmpty,FieldsArray) - ;"Purpose: to dump (display) a record, NOT using ^DII (Fileman's Inquire code) - ;"Input: FileNum -- the number of the file to dump from - ;" IENS -- the record number to display (or IENS: #,#,#,) - ;" ShowEmpty -- OPTIONAL; if 1 then empty fields will be displayed - ;" FieldsArray -- OPTIONAL. PASS BY REFERENCE. - ;" Allows user to specify which fields to show. Format: - ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number - ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number - ;" Default is an empty array, in which all fields are considered - - new Fields - set Fields("*")="" - new flags set flags="i" - if $get(ShowEmpty)=1 set flags=flags_"b" - - write "Record# ",IENS,! - - new field,fieldName - if $data(FieldsArray)=0 do - . set field=$order(^DD(FileNum,0)) - . if +field>0 for do quit:(+field'>0) - . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) - . . set Fields("TAG NAME",field)=fieldName_"("_field_")" - . . set field=$order(^DD(FileNum,field)) - else do ;"Handle case of showing ONLY requested fields - . new temp set temp="" - . for set temp=$order(FieldsArray(temp)) quit:(temp="") do - . . if +temp=temp do - . . . set field=+temp - . . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) - . . else do - . . . set fieldName=temp - . . . if $$SetFileFldNums^TMGDBAPI(FileNum,fieldName,,.field)=0 quit - . . set Fields("TAG NAME",field)=fieldName_"("_field_")" - . ;"Now exclude those fields not specifically included - . set field=0 - . for set field=$order(^DD(FileNum,field)) quit:(+field'>0) do - . . if $data(Fields("TAG NAME",field))'=0 quit - . . set fieldName=$piece(^DD(FileNum,field,0),"^",1) - . . set Fields("Field Exclude",field)="" - - new RFn,FFn,LFn,WPLFn - set RFn="WriteRLabel^TMGDEBUG" - set FFn="WriteFLabel^TMGDEBUG" - set LFn="WriteLine^TMGDEBUG" - set WPLFn="WriteWPLine^TMGDEBUG" - - ;"write "Using flags (options): ",flags,! - - if +IENS=IENS do - . do Write1Rec^TMGXMLE2(FileNum,IENS,.Fields,flags,,,"",RFn,FFn,LFn,WPLFn) - else do ;"dump a subfile record - . do Write1Rec^TMGXMLE2(FileNum,+IENS,.Fields,flags,,IENS,"",RFn,FFn,LFn,WPLFn) - - quit - - -WriteRLabel(IEN,Ender) - ;"Purpose: To actually write out labels for record starting and ending. - ;" IEN -- the IEN (record number) of the record - ;" Ender -- OPTIONAL if 1, then ends field. - ;"Results: none. - ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 - - if +$get(Ender)>0 write ! - else write " Multiple Entry #",IEN,"",! - - quit - - -WriteFLabel(Label,Field,Type,Ender) - ;"Purpose: This is the code that actually does writing of labels etc for output - ;" This is a CUSTOM CALL BACK function called by Write1Fld^TMGXMLE2 - ;"Input: Label -- OPTIONAL -- Name of label, to write after 'label=' - ;" Field -- OPTIONAL -- Name of field, to write after 'id=' - ;" Type -- OPTIONAL -- Typeof field, to write after 'type=' - ;" Ender -- OPTIONAL if 1, then ends field. - ;"Results: none. - ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 - - ;"To write out or - - if +$get(Ender)>0 do - . write ! - else do - . new s set s=Field - . if $get(Field)'="" write $$RJ^XLFSTR(.s,6," "),"-" - . if $get(Label)'="" write Label," " - . ;"if $get(Type)'="" write "type=""",Type,""" " - . write ": " - - quit - - -WriteLine(Line) - ;"Purpose: To actually write out labels for record starting and ending. - ;"Input: Line -- The line of text to be written out. - ;"Results: none. - ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 - - write line - quit - - -WriteWPLine(Line) - ;"Purpose: To actually write out line from WP field - ;"Input: Line -- The line of text to be written out. - ;"Results: none. - ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 - - write line,! - quit - Index: cprs/branches/tmg-cprs/m_files/TMGDIS.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGDIS.m~ (revision 796) +++ (revision ) @@ -1,491 +1,0 @@ -TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 ; 5/12/10 3:06pm - ;;1.0;TMG-LIB;**1**;01/01/06 - ;"-------Prior header below --------------- - ;"SFISC/GFT-GATHER SEARCH CRITERIA ;05:52 PM 27 Mar 2002 - ;";22.0;VA FileMan;**6,97**;Mar 30, 1999 - ;" - ;"Purpose: to GATHER SEARCH CRITERIA - ;"------Also includes code from DIS2, with header as below. - ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;5:49 AM 2 Jun 1999 - ;;22.0;VA FileMan;**6**;Mar 30, 1999 - ; - ;"Purpose: SEARCH, TEMPLATES & COMPUTED FIELDS - ;"Note: Program execution can loop all the way back to ^DIS - ;" -SRCH(TMGINFO,TMGOUT,TMGBYROOT) ; - ;"Purpose: Provide an API interface for the classic Fileman console search - ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format: - ;" TMGINFO("FILE") -- File name or number to be used for search - ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console) - ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console) - ;" ... - ;" --DETAILS ON SEARCH CONDITION---- - ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in - ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate - ;" TMGINFO(n,"VALUE") -- the value to search for - ;" TMGOUT --An OUT PARAMETER. Prior values killed. Format: - ;" TMGOUT(FILENUM,IEN)="" - ;" TMGOUT(FILENUM,IEN)="" - ;" TMGOUT(FILENUM,IEN)="" - ;" TMGBYROOT -- (Optional) If 1, then TMGOUT is treated as a variable NAME (root) - ;" i.e. @TMGOUT@(FILENUM,IEN)="" - ;"Results: 1 if OK, or -1^Error Message - ; - NEW DC ;"Variable DC stores coded search values - ;"Example: - ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) - ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file) - ;" - ;"Example - ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA - ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % - ;" - ;"Example - ;"DC=6 - ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) - ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % - ;" note field 2 is a pointer, so perhaps '-' means non-exact match - ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA - ;" note field 1 is free text, so perhaps '-' not needed - ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211 - ;"DC(5) = .01^["A" <-- field .01 '[' A - ;"Values of O with above example - ;"O=0 - ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN - ;"O(2) = VA PRODUCT UNITS CONTAINS "%" - ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1" - ;"O(4) = DOSAGE FORM EQUALS 211^BAG - ;"O(5) = NAME CONTAINS "A" - NEW DIS,%ZIS - NEW O ;"('Oh', not 'zero') Stores file & field names and values to search FOR - ;"Example: - ;"O=0 - ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN" - ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF" - ;"O(3) = VA GENERIC NAME CONTAINS "A" - ;"Note: - ;" Each node (i.e. (1),(2) etc) contains a separate search item. - ;" - ;"Another example - ;"O="EQUALS" - ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN" - ;"O(2)="VA PRODUCT UNITS EQUALS 44^%" - ;" - ;"Note: - ;" In above examples, - ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field - ;" of ACTIVE INGREDIENTS multiple - ;" 105 is IEN of ACETAMINOPHEN - ;" EQUALS is chosen comparator - ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple - ;" 44 is IEN of unit '%' - ;" EQUALS is chosen comparator - ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search. - - NEW N,P,C,Z,I,J,Q - NEW R ;"stores root of file being searched - NEW E ;"stores field type codes (piece 2 of 0 node) - NEW DIC,X,Y - NEW DL ;"DL=indent amount from left margin. - NEW DC ;"DC=search element i.e. 1=A,2=B,3=C etc. - NEW DU ;"DU = field number - NEW DA,DI,DV,DX,DY,DTOUT,DK - NEW DICMX,DICOMP - NEW TMGRESULT SET TMGRESULT=1 ;"Default to success - SET DIC=1 - SET X=$GET(TMGINFO("FILE")) - DO ^DIC - IF Y=-1 DO GOTO SRCHDN - . SET TMGRESULT="-1^File '"_X_"' is not valid." - SET DIC=+Y - NEW TMGFILE SET TMGFILE=$P(Y,U,2) -EN ; - IF DIC SET DIC=$G(^DIC(DIC,0,"GL")) - IF DIC="" DO GOTO SRCHDN - . SET TMGRESULT="-1^File '"_TMGFILE_"' is not valid." - KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J) - IF '$DATA(@(DIC_"0)")) DO GOTO SRCHDN - . SET TMGRESULT="-1^File '"_TMGFILE_"' is missing its global." - SET (R,DI,I(0))=DIC - SET DL=1 ;"DL=indent amount from left margin. - SET DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc. - SET DY=999 - SET N=0 - SET Q="""" - SET DV="" -R ; - ;"SET J(N) and DK<--file NUMBER, R<--file NAME - IF +R=R DO - . SET (J(N),DK)=R - . SET R="" - ELSE DO - . SET @("(J(N),DK)=+$PIECE("_R_"0),U,2)") - . SET R=$PIECE(^(0),U) - ; -F ;=== Get next field=== - IF DC>58 GOTO UP - ;"WRITE ! - KILL X,DIC,P - ;"DO W ;"Write label to screen line -A-, or -B- etc. - SET DIC(0)="Z" ;"WAS EZ - SET C="," - SET DIC="^DD("_DK_C - ;"SET DIC("W")="SET %=$PIECE(^(0),U,2) WRITE:% $SELECT($PIECE(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" - SET DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$select($DATA(DICS):" "_DICS,1:""),DU="" - ;"WRITE "SEARCH FOR "_R_" "_$PIECE(^DD(DK,0),U)_": " - ;"READ X:DTIME ;"ask user FOR filed to search in, from specified file - ;"SET:'$T DTOUT=1 - ;"IF X=U!'$T GOTO Q - SET X=$GET(TMGINFO(DC,"FLD")) - ;"IF X?1"[".E GOTO TEM ;"I think this is for putting all on one line. REMOVED. - DO - . NEW DISVX SET DISVX=X - . DO ^DIC ;"search FOR field, based on user input. - . IF Y=-1 SET X=DISVX - IF '(Y>0) GOTO HARD ;"Time to do the hard part... - KILL P - SET DE=Y(0) - SET O(DC)=$PIECE(DE,U) ;"Store first part of search term - SET DU=+Y ;"DU = field number - SET Z=$PIECE(DE,U,3) ;"pointers or SET data - SET E=$PIECE(DE,U,2) ;"field info codes, poss with subfile # -G ;==== Get Condition ========= - KILL X,DIC - SET DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc. - SET DIC(0)="Z" ;"Was QEZ - IF E["B" SET X="" GOTO OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip - IF +E=0 GOTO G2KT ;"E=file info code starts with # IF subfile. So skip IF not subfile - SET N(DL)=N - SET N=N+1 - SET DV(DL)=DV - SET DL(DL)=DK - SET DK=+E - SET J(N)=DK - SET X=$PIECE($PIECE(DE,U,4),";") ;"4th piece of 0 node holds storage location - SET I(N)=$select(+X=X:X,1:""""_X_"""") - SET Y(0)=^DD(DK,.01,0) - SET DL=DL+1 ;"indent further - IF $PIECE(Y(0),U,2)["W" GOTO WP ;"Process WP fields - SET DV=DV_+Y_"," - GOTO F ;"loop back to get more field info for subfile FIX!!! How is this pre-determined?? -G2KT IF E["P" DO GOTO HARD ;"IF field points to another file, setup and GOTO HARD - . SET P=+Y_U_Y(0) ;"e.g. P=.02^PATIENT^P9000001' - . SET X="(#"_+Y_")" -C ;"DO W ;"Write label to screen line -A-, or -B- etc. - ;"READ "CONDITION: ",X:DTIME - ;"SET:'$T DTOUT=1 - ;"IF X[U!'$T GOTO Q - SET X=$GET(TMGINFO(DC,"COND")) ;"Get pre-defined user search condition - IF X="" DO GOTO SRCHDN - . SET TMGRESULT="-1^Search condition not specified for term #"_DC - SET DN=$select("'-"[$E(X):"'",1:"") ;"IF NOT is specified then DN="'" - SET X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, IF present - DO ^DIC - ;"IF Y>0 GOTO C2 - ;"IF X[U GOTO Q - ;"IF X="" GOTO B - ;"IF X["?" GOTO DISCDIQQQ - ;"GOTO C - IF Y=-1 DO GOTO SRCHDN - . SET TMGRESULT="-1^Search condition '"_X_"' is not valid." -C2 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2) ;"Store search condition in O - IF +Y=1 DO GOTO OK ;"Handle NULL selected - . SET X=DN_"?."" """ - . SET O(DC)=O(DC)_" "_O - SET DQ=Y - ;"At this point DQ (and Y) should be one of following values: - ;"1 for NULL, 2 for CONTAINS 3 for matches - ;"4 for LESS THAN 5 for EQUALS 6 for GREATER THAN - ; - ;"====Get Search Term================= - ;"DO W ;"Write label to screen line -A-, or -B- etc. - ;"WRITE O - IF (E'["D")!(Y<4) GOTO PT - ;"Handle searches for DATES - ;"READ " DATE: ",X:DTIME - SET X=$GET(INFO(DC,"VALUE")) - ;"SET:'$T DTOUT=1 - ;"IF X=U!'$T GOTO Q - IF X="" DO GOTO SRCHDN - . SET TMGRESULT="-1^No search value specified for term #"_DC - SET %DT="T" ;"was TE - DO ^%DT - IF Y<0 DO GOTO SRCHDN - . SET TMGRESULT="-1^Invalid date value '"_X - SET X=Y_U_X - XECUTE ^DD("DD") - SET Y=X_U_Y - GOTO GOT -PT ;"POINTERS - IF $DATA(P),+DQ=5 DO GOTO Q:U[X!'$T DO ^DIC GOTO GOT:Y>0,PT - . KILL DIC,DIS($char(DC+64)_DL) - . SET DIC=U_$PIECE(P,U,4) - . SET DIC(0)="EMQ" - . SET DU=+P - . WRITE " "_$PIECE(@(DIC_"0)"),U)_": " - . READ X:DTIME - . SET:'$T DTOUT=1 - READ ": ",Y:DTIME - IF '$T SET DTOUT=1 GOTO Q - GOTO X:Y="" - IF Y[U,$PIECE(DE,U,4)'[";E" GOTO Q - IF +DQ=3 SET X="I X?"_Y DO ^DIM GOTO GOT:$DATA(X) SET Y="?" - GOTO DISDIQQQ:Y?."?" -SET IF E["S" DO IF '$DATA(X) KILL DIS(U,DC) GOTO DISDIQQQ - . IF +DQ=5!(Y["""") DO kill:D="" X QUIT - . . SET Y=":"_Y - . . NEW TMGQUIT SET TMGQUIT=0 - . . ;"FOR X=1:1 DO IF D[Y WRITE $PIECE(D,Y,2,9) SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) Q - . . FOR X=1:1 DO QUIT:TMGQUIT=1 - . . . SET D=$PIECE(Z,";",X) - . . . IF D="" SET TMGQUIT=1 QUIT - . . . IF D[Y DO - . . . . WRITE $PIECE(D,Y,2,9) - . . . . SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) - . . . . SET TMGQUIT=1 -N . NEW N,%,C - . WRITE !?7 - . SET N="DE"_DN_$E(" [?<=>",DQ)_""""_Y_"""" - . NEW TMGQUIT SET TMGQUIT=0 - . FOR X=1:1 DO QUIT:TMGQUIT=1 - . . SET D=$PIECE(Z,";",X) - . . SET DE=$PIECE(D,":",2) - . . IF D="" SET TMGQUIT=1 - . . SET DIS(U,DC,$PIECE(D,":"))=DE - . . IF @N DO - . . . SET:'$DATA(%) %="[ Will match" - . . . WRITE % - . . . SET C=$G(C)+1 - . . . SET %="'"_DE_"'" - . . . write:C>1 "," - . . . WRITE " " - . . . write:$X+$L(%)>73 !?7 - . IF '$DATA(%) KILL X Q - . write:C>1 "and " - . WRITE %_" ]" -T IF DQ["THAN",+$PIECE(Y,U)'=$PIECE(Y,U) GOTO X -QUOTE IF DQ#3=2 DO ;"Equals or Contains - . write:$PIECE(Y,U)[""""&($L($PIECE(Y,U))>1) " (Your answer includes quotes)" - . SET $PIECE(Y,U)=""""_$$CONVQQ^DILIBF($PIECE(Y,U))_"""" - . IF $PIECE(Y,U)?.E2A.E DO - . . SET DIS("XFORM",DC)="$$UP^DILIBF(;)" - . . SET O=O_" (case-insensitive)" - . . SET $PIECE(Y,U)=$$UP^DILIBF($PIECE(Y,U)) -GOT ;"At this point, Y should be search value - SET X=DN_$E(" [?<=>",DQ)_$PIECE(Y,U) - IF E["D" DO - . SET Y=$PIECE(Y,U,3)_U_$PIECE(Y,U,2) - . IF $PIECE(Y,U)'["." DO - . . SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ) - . . IF %]"" DO - . . . SET DIS("XFORM",DC)="$PIECE(;,""."")" - . . . SET O=O_% - SET O(DC)=O(DC)_" "_O_" "_Y -OK SET DC(DC)=DV_DU_U_X - SET %=DL-1_U_(N#100) - IF DL>1,O(DC)'[R SET O(DC)=R_" "_O(DC) - IF DU["W" SET %=DL-2_U_(N#100-1) - SET DX(DC)=% - SET DC=DC+1 ;"Inc logical part (i.e. 'A'->'B'->'C'->D) - IF DC=27 SET DC=33 -B GOTO F:(DU'["W"&(DC<59)) - - ;"============== -UP IF '(DC>1) GOTO Q - IF DL<$select('$DATA(DIARF0):2,1:2) GOTO ^TMGDIS0 ;"Done with entering conditions - SET DL=DL-1 - SET DV=DV(DL) - SET DK=DL(DL) - SET N=N(DL) - SET R=$select($DATA(R(DL)):R(DL),1:R) - KILL R(DL) - SET %=N - FOR SET %=$O(I(%)) SET:%="" %=-1 GOTO F:%<0 KILL I(%),J(%) - FOR DO IF %<0 GOTO F - . SET %=$O(I(%)) - . IF %="" SET %=-1 - . IF %<0 QUIT - . KILL I(%),J(%) - ;"========================================== - ;"Q IF '$DATA(DIARU) GOTO Q^TMGDIS2 - ;" GOTO ^TMGDIS2 - - ;"========================================== -HARD IF X="" GOTO UP - ;"IF X?."?" GOTO F - ;"IF X=U!($DATA(DTOUT)) GOTO Q - GOTO COMP - - ;"========================================== -WP SET DIC("S")="IF Y<3" - SET DU=+Y_"W" - GOTO C - - ;"========================================== -X ; - WRITE $char(7),"??",!! - GOTO B - - ;"========================================== -W WRITE !?DL*2,"-"_$char(DC+64)_"- " - QUIT - - ;"========================================== -ENS ;" ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE - GOTO EN^DIS3 - - - - ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS. -DISDIQQQ ; - WRITE !?8,"ENTER A VALUE WHICH '"_O(DC)_"'" - WRITE !?8,"MUST "_$P("NOT ",U,DN]"") - WRITE $PIECE("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ) - WRITE ", IN ORDER FOR TRUTH CONDITION -"_$char(DC+64)_"- TO BE TRUE",! - write:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",! - IF E["S" WRITE !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?") - WRITE ! - GOTO F - - ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS - ;"DISCDIQQ ; - ;"WRITE !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-""" - ;"WRITE !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",! - ;"GOTO C - ; - -SRCHDN ; - ;"Purpose: New common exit point for function - QUIT TMGRESULT - - - ;=========================================================================== - ;=========================================================================== - ;" Below was code from DIS2 - ;=========================================================================== - ;=========================================================================== - -DIS2 KILL DISV - GOTO G3:'DUZ -0 DO - . NEW DIS,DIS0,DA,DC,DE,DJ,DL - . DO S3^DIBT1 - . Q - KILL DIRUT,DIROUT - IF $D(DTOUT)!($D(DUOUT)) GOTO Q - IF X="" GOTO G3:'$D(DIAR) - IF Y<0 GOTO Q:X=U,0 - IF $D(DIARU),DIARU-Y=0 DO GOTO 0 - . write $C(7),!,"Archivers must not store results in the default template" - SET (DIARI,DISV)=+Y - SET A=$D(^DIBT(DISV,"DL")) - SET:$D(DIS0)#2 ^("DL")=DIS0 - SET:$D(DA)#2 ^("DA")=DA - SET:$D(DJ)#2 ^("DJ")=DJ - IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV - SET Z=-1,DIS0="^DIBT(+Y," - FOR P="DIS","DA","DC","DE","DJ","DL" DO - . SET %Y=DIS0_""""_P_"""," - . SET %X=P_"(" - . DO %XY^%RCR - SET %X="^UTILITY($J," - SET %Y="^DIBT(DISV,""O""," - SET @(%X_"0)=U") - DO %XY^%RCR -G3 NEW DISTXT - SET %X="^UTILITY($J," - SET %Y="DISTXT(" - DO %XY^%RCR - write ! - SET Y=DI - DO Q - SET DIC=Y - GOTO EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP - - ;"========================================== -TEM ; - KILL DIC - SET X=$P($extract(X,2,99),"]",1) - SET DIC="^DIBT(" - SET DIC(0)="EQ" - SET DIC("S")="IF "_$select($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))" - SET DIC("W")="X ""FOR %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) write !?9 SET I=^(0) W:$L(I)+$X>79 !?9 write I""" - DO ^DIC - KILL DIC - GOTO F:Y<0 - SET P="DIS" - SET Z=-1 - SET %X="^DIBT(+Y,P," - SET %Y="DIS(" - DO %XY^%RCR - SET %Y="^UTILITY($J," - SET P="O" - DO %XY^%RCR - GOTO DIS2 - - ;"========================================== -COMP ; - SET E=X ;"e.g. X="(#.02)" - SET DICMX="X DIS(DIXX)" - SET DICOMP=N_"?" - SET DQI="Y(" - SET DA="DIS("""_$C(DC+64)_DL_"""," - IF '$D(O(DC))#2 SET O(DC)=X - GOTO COLON:X?.E1":" - IF X?.E1":.01",'$D(O(DC))#2 SET O(DC)=$extract(X,1,$L(X)-4) - DO EN^DICOMP ;"Eval computed expression - DO XA - GOTO X:'$D(X) - GOTO X:Y["m" ;"IF Y["m" SET X=E_":" GOTO COMP - SET DA(DC)=X - SET DU=-DC - SET E=$extract("B",Y["B")_$extract("D",Y["D") - GOTO G3 - - ;"========================================== -XA SET %=0 - FOR DO Q:%="" - . SET %=$O(X(%)) - . Q:%="" - . SET @(DA_%_")")=X(%) - SET %=-1 - QUIT - - ;"========================================== -COLON DO ^DICOMPW - GOTO X:'$D(X) - DO XA - SET R(DL)=R - SET N(DL)=N - SET N=+Y - SET DY=DY+1 - SET DV(DL)=DV - SET DL(DL)=DK - SET DL=DL+1 - SET DV=DV_-DY_C - SET DY(DY)=DP_U_$select(Y["m":DC_"."_DL,1:"")_U_X - SET R=U_$P(DP,U,2) - KILL X - GOTO R - - ;"========================================== -Q ; - KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE - KILL DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT - KILL ^UTILITY($J) - QUIT - - ;"========================================== -DIS ;"PUT SET LOGIC INTO DIS FOR SUBFILE - SET %X="" - FOR %Y=1:1 DO QUIT:'%X - . SET %X=$O(DIS(%X)) - . QUIT:'%X - . SET %=$select($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) - . SET:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) - . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X - . SET ^(1)=% - IF %Y>1 DO - . SET %Y=%Y-1 - . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y - GOTO DIS2 Index: cprs/branches/tmg-cprs/m_files/TMGDIS2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGDIS2.m~ (revision 796) +++ (revision ) @@ -1,113 +1,0 @@ -TMGDIS2 ;TMG/kst/Custom version of DIS2 ;03/25/06 ; 5/15/10 11:15pm - ;;1.0;TMG-LIB;**1**;01/01/06 - ;"---- Prior header below ---------- - ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005 - ;;22.0;VA FileMan;**6,144**;Mar 30, 1999;Build 5 - ; -DIS2 ; - ;"Purpose: - ;"Input: ... - ;"Output: TMGRESULT is set - ;"Results: none - KILL DISV - ;"GOTO G:'DUZ -0 ;"D - ;". N DIS,DIS0,DA,DC,DE,DJ,DL - ;". D S3^DIBT1 Q - ;"KILL DIRUT,DIROUT - ;"I $D(DTOUT)!($D(DUOUT)) GOTO Q - ;"Get SORT TEMPLATE to store search into. - SET Y=$$PREPTMPL() - IF +TMGRESULT=-1 GOTO TMGDONE ;"Quit from there - SET TMGSORTT=Y - IF X="",'$D(DIAR) GOTO G - IF Y<0 GOTO Q:X=U,0 - IF $D(DIARU),DIARU-Y=0 DO GOTO 0 - . WRITE $C(7),!,"Archivers must not store results in the default template" - SET (DIARI,DISV)=+Y - SET A=$D(^DIBT(DISV,"DL")) - IF $D(DIS0)#2 SET ^("DL")=DIS0 - IF $D(DA)#2 SET ^("DA")=DA - IF $D(DJ)#2 SET ^("DJ")=DJ - IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV - SET Z=-1 - SET DIS0="^DIBT(+Y," - FOR P="DIS","DA","DC","DE","DJ","DL" DO - . SET %Y=DIS0_""""_P_"""," - . SET %X=P_"(" - . DO %XY^%RCR - SET %X="^UTILITY($J,",%Y="^DIBT(DISV,""O""," - SET @(%X_"0)=U") - DO %XY^%RCR -G NEW DISTXT - SET %X="^UTILITY($J," - SET %Y="DISTXT(" - DO %XY^%RCR - ;"WRITE ! - SET Y=DI - DO Q - SET DIC=Y - IF $D(SF)!$D(L)&'$D(DIAR) GOTO EN1^DIP - GOTO EN^DIP - ; - ;"========================================== -TEM GOTO TEMP^TMGDIS ;"-- MOVED TO TMGDIS -COMP GOTO COMP^TMGDIS ;"-- MOVED TO TMGDIS -XA GOTO XA^TMGDIS ;"-- MOVED TO TMGDIS -COLON GOTO COLON^TMGDIS ;"-- MOVED TO TMGDIS -Q GOTO Q^TMGIDS ;"-- MOVED TO TMGDIS - ;"========================================== - ; - ;"X KILL O(DC) - ;" GOTO X^TMGDIS - ; -DIS ;PUT SET LOGIC INTO DIS FOR SUBFILE - SET %X="" - FOR %Y=1:1 SET %X=$O(DIS(%X)) Q:'%X DO - . SET %=$S($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) - . IF %["X DIS(" SET %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) - . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X - . SET ^(1)=% - IF %Y>1 DO - . SET %Y=%Y-1 - . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y - GOTO DIS2 ;"quit will occur there. - ; -PREPTMPL() ; - ;"//kt added - ;"Purpose: Return IEN of a SORT TEMPLATE ready for use. - ;"Get SORT TEMPLATE to store search into. - NEW TMGTMPL SET TMGTMPL=-1 - NEW Y SET Y=+$GET(INFO("SORT IEN")) - IF (Y'>0)!($DATA(^DIBT(Y))=0) DO ;"Get a new record - . NEW DIC,X - . SET DIC=.401,DIC(0)="L" - . SET X="TMG SRCH "_$J - . DO ^DIC ;"Create now, or get pre-existing - . IF +Y'>0 DO QUIT - . . SET TMGRESULT="-1^Error getting SORT TEMPLATE for use." - IF +Y>0,$DATA(^DIBT(+Y)) DO ;"Edit existing record - . NEW TMGFDA,TMGMSG,TMGIEN,TMGIENS,DA,DIE - . SET TMGTMPL=+Y - . NEW I SET I=0 - . ;"Kill all but zero node of record - . FOR SET I=$ORDER(^DIBT(Y,I)) QUIT:I="" KILL ^DIBT(Y,I) - . NEW % DO NOW^%DTC - . SET DIE=.401 - . SET DA=+Y - . SET DR="2///"_%_";3///"_DUZ(0)_";4///"_TMGFILE_";5///"_DUZ_";6///"_DUZ(0) - . DO ^DIE - . ;"SET IENS=+Y_"," - . ;"SET TMGFDA(.401,IENS,2)=% - . ;"SET TMGFDA(.401,IENS,3)=DUZ(0) - . ;"SET TMGFDA(.401,IENS,4)=TMGFILE - . ;"SET TMGFDA(.401,IENS,5)=DUZ - . ;"SET TMGFDA(.401,IENS,6)=DUZ(0) - . ;"Set back new field data - . ;"DO FILE^DIE("K","TMGFDA","TMGMSG") - . ;"IF $DATA(TMGMSG("DIERROR")) DO QUIT - . ;". SET TMGRESULT="-1^Error editing SORT TEMPLATE: '"_$GET(TMGMSG("DIERR",1,"TEXT",1))_"'" - . ;". SET Y=-1 - QUIT TMGTMPL - ; -TMGDONE QUIT Index: cprs/branches/tmg-cprs/m_files/TMGFIX.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGFIX.m~ (revision 796) +++ (revision ) @@ -1,368 +1,0 @@ - - - -;"===================================================================== -;"================================================================ - -ENV ;Establish Routine Environment - N DDH,DIR,X,Y,ZTENV,ZTKEY,ZTNAME,ZTSK,XUTMUCI - D ENV^XUTMUTL Q:'$D(ZTENV) - ; - new DIC,X,Y - set DIC=.401 - set DIC(0)="MAEQ" - do ^DIC write ! - if +Y'>0 quit - new templIEN set tempLIEN=+Y - new IEN set IEN="" - for set IEN=$order(^DIBT(tempLIEN,1,IEN)) quit:IEN="" do - . do KILLTSK(IEN) - - quit - - -KILLTSK(ZTSK) - ;"W ! - ;"S XUTMT(0)="AL" - ;"D ^XUTMT - I 'ZTSK K ^TMP($J,"XUTMT") Q - ;"I ZTSK["-"!(ZTSK[",") D ^XUTMD1 Q:$D(DTOUT) G SELECT - S XUTMT=ZTSK,XUTMT(0)="R3" - D ^XUTMT - ; -STATUS ;Report On Status Of Task And Whether User May Delete It - I $D(ZTSK(.11))#2,ZTSK(.11)="UNDEFINED",$O(ZTSK(.3))="" W !!?5,"That task is not defined.",$C(7) G SELECT - I $D(ZTSK(.11))#2,ZTSK(.11)="UNDEFINED",$O(ZTSK(.3))="TASK",$O(ZTSK("TASK"))="" W !!?5,"That task is running and has no record." G SELECT - I $D(ZTSK(.11))#2,ZTSK(.11)="UNDEFINED" W !!?5,"That task is scheduled but has no record." G CONFIRM:ZTKEY G SELECT - ; -S5 I $D(ZTSK(.11))#2,$O(ZTSK(.3))="" W !!?5,"That task's record is incomplete." G CONFIRM:ZTKEY G SELECT - I $D(ZTSK(.11))#2,$O(ZTSK(.3))="TASK",$O(ZTSK("TASK"))="" W !!?5,"That task is running and has an incomplete record." G SELECT - I $D(ZTSK(.11))#2 W !!?5,"That task is scheduled, but has an incomplete record." G CONFIRM:ZTKEY G SELECT - ; -S9 I $O(ZTSK(.3))="TASK",$O(ZTSK("TASK"))="" W !!?5,"That task is running." G SELECT - I 'ZTKEY,$S($P(ZTSK(0),U,11)_","_$P(ZTSK(0),U,12)=XUTMUCI:DUZ'=$P(ZTSK(0),U,3),1:ZTNAME'=$P(ZTSK(0),U,10)) W !!?5,"You may only delete your own tasks." G SELECT - ; -CONFIRM ;Prompt User To Confirm Unscheduling - I $S($D(ZTSK(.11))[0:1,1:ZTSK(.11)'="UNDEFINED") W ! D EN^XUTMTP(ZTSK) - ;"W ! - ;"K DIR - ;"S DIR(0)="Y" - ;"S DIR("A")="Are you sure you want to delete this task" - ;"S DIR("B")="NO" - ;"S DIR("?")=" Answer YES to delete the task." - ;"D ^DIR - ;"I 'Y W !!?5,"Tasks NOT deleted!" - ;"I $D(DTOUT) W $C(7) Q - ;"K DIR,DIRUT,DTOUT,DUOUT - ;"I 'Y G SELECT - ; -DELETE ;Delete Task - I $D(ZTSK(0))#2,ZTSK(0)["ZTSK^XQ1",$P(ZTSK(0),U,11)_","_$P(ZTSK(0),U,12)=XUTMUCI,$P(ZTSK(0),U,8)]"" D - . F DA=0:0 S DA=$O(^DIC(19.2,DA)) Q:DA'>0 I $G(^DIC(19.2,DA,1))=ZTSK D - . . N DIE S DIE="^DIC(19.2,",DR="2///@;12///@" D ^DIE Q - . Q - S XUTMT=ZTSK,XUTMT(0)="D" - D ^XUTMT - W !!?5,"Deleted!" - G SELECT - ; - -SELECT - quit - - - -FS1 - NEW X,Y,DIC - SET DIC=1,DIC(0)="MAEQ" - DO ^DIC WRITE ! - IF +Y'>0 QUIT - NEW I SET I="" - FOR SET I=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS",+Y,I)) QUIT:(I'>0) DO - . NEW NODE SET NODE="" - . FOR SET NODE=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS",+Y,I,NODE)) QUIT:(NODE="") DO - . . KILL ^TMG("TMGSIPH","NEEDED RECORDS",+Y,I,NODE) - . . SET ^TMG("TMGSIPH","NEEDED RECORDS",+Y,I,NODE,0)="" - QUIT - -KILLTMPL - new X,Y,DIC - set DIC=.401 - set DIC(0)="MAEQ" - do ^DIC write ! - if +Y'>0 write "goodbye.",! quit - NEW TMPL SET TMPL=+Y - new file set file=$piece($get(^DIBT(TMPL,0)),"^",4) - if file'=8925 do quit - . write "That file doesn't refer to file 8925. That is all this function can work with!",! - new % set %=2 - write "Delete all the records referred to in this sort template?" do YN^DICN write ! - if %'=1 write "goodbye.",! quit - new MIN,MAX - set MIN=$ORDER(^DIBT(TMPL,1,0)) - set MAX=$ORDER(^DIBT(TMPL,1,""),-1) - new TMGCT set TMGCT=0 - new STIME set STIME=$H - new TMGIEN set TMGIEN=0 - for set TMGIEN=$ORDER(^DIBT(TMPL,1,TMGIEN)) quit:(+TMGIEN'>0) do - . ;"write TMGIEN,! quit - . new TMGFDA set TMGFDA(8925,TMGIEN_",",.01)="@" - . ;"new TMGFDA set TMGFDA(8925,TMGIEN_",",.05)="COMPLETED" - . new TMGMSG - . do FILE^DIE("E","TMGFDA","TMGMSG") - . NEW RPTR SET RPTR=+$GET(^TMG("TMGSIPH","DOWNLOADED",8925,TMGIEN)) - . KILL ^TMG("TMGSIPH","DOWNLOADED",8925,TMGIEN) - . KILL ^TMG("TMGSIPH","PT XLAT",8925,RPTR) - . do ShowIfDIERR^TMGDEBUG(.TMGMSG) - . set TMGCT=TMGCT+1 - . if TMGCT>50 do - . . do ProgressBar^TMGUSRIF(TMGIEN,"Deleting records",MIN,MAX,70,STIME) - . . set TMGCT=0 - write "goodbye.",! - quit - - -FIXXREF ; - NEW FILENUM SET FILENUM=0 - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","PT XLAT",FILENUM)) QUIT:(+FILENUM'>0) DO - . NEW RPTR SET RPTR=0 - . FOR SET RPTR=$ORDER(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)) QUIT:(+RPTR'>0) DO - . . NEW LPTR SET LPTR=+$GET(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)) - . . IF LPTR'>0 WRITE "FILE ",FILENUM,", REMOTE IEN=",RPTR," --> ?? LOCAL PTR",! QUIT - . . IF $DATA(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR))=0 DO QUIT - . . . WRITE "FILE ",FILENUM,", LOCAL IEN=",LPTR," --> Not downloaded??",! - . . SET ^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)=RPTR - . . WRITE "Set ",$NAME(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)),"=",RPTR,! - quit - - - ;" ; Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] - ;" ; ONEREF will have multiple IEN entries if IENDepth>1, e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C")' - ;" ; with order of IEN, IEN(2), IEN(3), ... etc. -FIXSUBFILES ; - NEW FILENUM SET FILENUM=0 - NEW ABORT SET ABORT=0 - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM)) QUIT:(+FILENUM'>0)!ABORT DO - . NEW TMP SET TMP=$$HASPTRSF^TMGFMUT2(FILENUM) - . IF TMP DO - . . WRITE "FILE ",FILENUM," has pointer subfiles.... probably needs fix.",! - . . ;"IF $$DDOK^TMGSIPH1(JNUM,FILENUM) - . . IF $$SETPTOUT^TMGSIPH1(FILENUM) - . . NEW ONEREF SET ONEREF="" - . . FOR SET ONEREF=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF)) QUIT:(ONEREF="")!ABORT DO - . . . ;"WRITE "ONEREF=",ONEREF,! - . . . NEW ENTRY SET ENTRY="" - . . . FOR SET ENTRY=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF,ENTRY)) QUIT:(ENTRY="")!ABORT DO - . . . . NEW IENDEPTH SET IENDEPTH=$PIECE(ENTRY,"^",4) - . . . . IF IENDEPTH=1 QUIT - . . . . NEW PCE SET PCE=+ENTRY - . . . . ;"WRITE " ENTRY=",ENTRY,! - . . . . NEW IEN SET IEN=0 - . . . . NEW GREF SET GREF=^DIC(FILENUM,0,"GL") QUIT:(GREF="") - . . . . NEW CGREF SET CGREF=$$CREF^DILF(GREF) - . . . . FOR SET IEN=$ORDER(@CGREF@(IEN)) QUIT:(+IEN'>0)!ABORT DO - . . . . . FOR QUIT:($$IENCOMBO^TMGFMUT2(ONEREF,IENDEPTH,.IEN)'=1)!ABORT DO - . . . . . . SET ABORT=$$UserAborted^TMGUSRIF QUIT:ABORT - . . . . . . NEW TMPREF SET TMPREF=$NAME(@ONEREF) ;"Puts IEN's from IEN array into name. - . . . . . . NEW IENS SET IENS=$$GETIENS^TMGFMUT2(.IEN) - . . . . . . IF $GET(^TMG("TMGSIPH","FIX",FILENUM,TMPREF))'="" QUIT ;"Already fixed. - . . . . . . NEW FROMFILE SET FROMFILE=$PIECE(ENTRY,"^",6) - . . . . . . NEW PT SET PT=$PIECE($GET(@TMPREF),"^",PCE) ;"$$IENCOMBO sets up IEN(n).. needed for @REF - . . . . . . NEW ISVIRT SET ISVIRT=($PIECE(ENTRY,"^",5)="V") - . . . . . . NEW P2REF SET P2REF=$PIECE(ENTRY,"^",3) - . . . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different ENTRY (V-Ptrs stored as IEN;OREF) - . . . . . . SET PT=+PT QUIT:(PT'>0) - . . . . . . NEW P2FILE SET P2FILE=$PIECE(ENTRY,"^",2) - . . . . . . NEW FROMFLD SET FROMFLD=$PIECE(ENTRY,"^",7) - . . . . . . NEW LPTR SET LPTR=$GET(^TMG("TMGSIPH","PT XLAT",P2FILE,PT),"??") - . . . . . . WRITE "FILENUM: ",FILENUM," IENS=",IENS," ",TMPREF," --> PTR=",PT," in file: ",P2FILE," LPTR=",LPTR,! - . . . . . . IF LPTR'="??" DO - . . . . . . . IF (PT'=LPTR) SET $PIECE(@TMPREF,"^",PCE)=LPTR - . . . . . . . SET ^TMG("TMGSIPH","FIX",FILENUM,TMPREF)=PT ;"Store old value just in case... - . . . . . . ELSE DO - . . . . . . . SET ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",P2FILE,PT,TMPREF,ENTRY)="" - . . . . . . . ;"IF $$NEEDPTIN^TMGSIPH3(FILENUM) DO - . . . . . . . ;". SET ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,)="" - . . . . . NEW TMPIEN SET TMPIEN=IEN KILL IEN SET IEN=TMPIEN ;"delete subnodes in array. - do PRESSTOCONT^TMGUSRIF - quit - - - ;" ; Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] - ;" ; ONEREF will have multiple IEN entries if IENDepth>1, e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C")' - ;" ; with order of IEN, IEN(2), IEN(3), ... etc. -FIXDDSUBFILES ; - NEW FILENUM SET FILENUM=0 - NEW ABORT SET ABORT=0 - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM)) QUIT:(+FILENUM'>0)!ABORT DO - . ;"NEW TMP SET TMP=$$HASPTRSF^TMGFMUT2(FILENUM) - . ;"IF TMP DO - . WRITE "FILE ",FILENUM," has had DD reset.",! - . IF $$SETPTOUT^TMGSIPH1(FILENUM) - do PRESSTOCONT^TMGUSRIF - quit - - -FTIU - new IEN set IEN=0 - for set IEN=$O(^TIU(8925,IEN)) q:(+IEN'>0) if $D(^TIU(8925,IEN,"TEMP")) do - . write IEN - . if $D(^TIU(8925,IEN,"TEXT"))=0 do quit - . . write "NO TEXT" - . . merge ^TIU(8925,IEN,"TEXT")=^TIU(8925,IEN,"TEMP") - . . kill ^TIU(8925,IEN,"TEMP") - . . write " -- FIXED",! - . new SAME set SAME=1 - . new j set j=0 - . for set j=$o(^TIU(8925,IEN,"TEMP",j)) quit:(+j'>0)!(SAME=0) - . . if $G(^TIU(8925,IEN,"TEMP",j,0))'=$G(^TIU(8925,IEN,"TEXT",j,0)) set SAME=0 - . write " --> SAME=",SAME - . if SAME kill ^TIU(8925,IEN,"TEMP") write " FIXED." - . write ! - quit - -CKREC - ;"^TMG("TMGSIPH","PT XLAT",FILENUM,RemoteIEN)=LocalIEN - NEW DIC,X,Y - SET DIC(0)="MAEQ" - SET DIC=1 - DO ^DIC WRITE ! - IF +Y'>0 QUIT - NEW ARRAY - NEW OVERLAP - SET OVERLAP=$$CKREC1F(+Y,.ARRAY) - IF OVERLAP DO - . WRITE "FILE #",+Y," has ",OVERLAP," overlapping records.",! - QUIT - - -CKALLREC - NEW FILENUM SET FILENUM=0 - NEW ARRAY - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM)) QUIT:(+FILENUM'>0) DO - . NEW OVERLAP - . write "Checking file #",FILENUM,"..." - . SET OVERLAP=$$CKREC1F(FILENUM,.ARRAY) - . WRITE "FILE #",FILENUM," has ",OVERLAP," overlapping records.",! - MERGE ^TMG("TMGSIPH","OVERLAP")=ARRAY - QUIT - - -CKREC1F(FILENUM,ARRAY) - NEW CT SET CT=0 - NEW RPTR,LPTR - SET RPTR=0 - FOR SET RPTR=$ORDER(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)) QUIT:(+RPTR'>0) DO - . SET LPTR=$GET(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)) QUIT:LPTR="" - . SET ARRAY(FILENUM,LPTR,RPTR)="" - . SET CT=CT+1 - . IF CT#100=0 WRITE "." SET CT=0 - ;"Now delete all entries that are not doubled up. - SET LPTR=0 - FOR SET LPTR=$ORDER(ARRAY(FILENUM,LPTR)) QUIT:(LPTR="") DO - . NEW REF SET REF=$NAME(ARRAY(FILENUM,LPTR)) - . SET CT=$$ListCt^TMGMISC(REF) - . IF CT=1 KILL @REF - write ! - QUIT $$ListCt^TMGMISC($NAME(ARRAY(FILENUM))) - - -SUMM - NEW FILENUM SET FILENUM=0 - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","OVERLAP",FILENUM)) QUIT:FILENUM="" DO - . NEW FNAME SET FNAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) - . NEW REF SET REF=$NAME(^TMG("TMGSIPH","OVERLAP",FILENUM)) - . WRITE "FILE [",FNAME,"] has ",$$ListCt^TMGMISC(REF)," overlapping records",! - quit - - -COMPRPC - NEW DIC,X,Y - NEW OPTION1,OPTION2 - SET DIC=19,DIC(0)="MAEQ" - WRITE "First pick the OLDER entry to compaire",! - DO ^DIC WRITE ! - IF Y=-1 GOTO CPRDN - SET OPTION1=+Y - WRITE !,"Now, pick the NEWER entry to compare",! - DO ^DIC WRITE ! - IF Y=-1 GOTO CPRDN - SET OPTION2=+Y - NEW ARRAY1,ARRAY2 - NEW IEN - SET IEN=0 - FOR SET IEN=$ORDER(^DIC(19,OPTION1,"RPC",IEN)) QUIT:(+IEN'>0) DO - . NEW PRPC - . SET PRPC=+$GET(^DIC(19,OPTION1,"RPC",IEN,0)) - . NEW NAME SET NAME=$PIECE($GET(^XWB(8994,PRPC,0)),"^",1) - . IF NAME="" WRITE IEN," --> ??",! - . ELSE SET ARRAY1(NAME,IEN)="" - - SET IEN=0 - FOR SET IEN=$ORDER(^DIC(19,OPTION2,"RPC",IEN)) QUIT:(+IEN'>0) DO - . NEW PRPC - . SET PRPC=+$GET(^DIC(19,OPTION2,"RPC",IEN,0)) - . NEW NAME SET NAME=$PIECE($GET(^XWB(8994,PRPC,0)),"^",1) - . IF NAME="" WRITE IEN," --> ??",! - . ELSE SET ARRAY2(NAME,IEN)="" - - NEW NAME SET NAME="" - FOR SET NAME=$ORDER(ARRAY1(NAME)) QUIT:(NAME="") DO - . IF $DATA(ARRAY2(NAME)) DO - . . WRITE "Both have: ",NAME,! - . . KILL ARRAY1(NAME),ARRAY2(NAME) - - NEW TEMP - WRITE "OK. Here are the entries in the OLDER option, not present in the new one.",! - IF $DATA(ARRAY1) ZWR ARRAY1 - else write "(none)",! - - DO PRESSTOCONT^TMGUSRIF - - WRITE "OK. Here are the entries in the NEWER option, not present in the old one.",! - IF $DATA(ARRAY2) ZWR ARRAY2 - else write "(none)",! - - DO PRESSTOCONT^TMGUSRIF - -CPRDN WRITE "GOODBYE",! - QUIT - -IHS - new IEN set IEN=0 - for set IEN=$order(^DPT(IEN)) quit:(+IEN'>0) do - . if $data(^AUPNPAT(IEN))'=0 write "." quit - . write "Missing data for IEN=",IEN,! - . set ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",9000001,IEN)="" - . kill ^TMG("TMGSIPH","PT XLAT",9000001,IEN) - quit - -IHS2 - new IEN set IEN=0 - new Ct set Ct=0 - new DIK set DIK="^AUPNPAT(" - new DA - new matched set matched=0 - new ABORT set ABORT=0 - for set IEN=$order(^AUPNPAT(IEN)) quit:(+IEN'>0)!ABORT do - . set ABORT=$$UserAborted^TMGUSRIF - . new P2 set P2=$P($G(^AUPNPAT(IEN,0)),"^",1) - . if $data(^DPT(IEN))=0 do quit - . . write "!" - . . set Ct=Ct+1 - . . set DA=IEN - . . do ^DIK - . if IEN=P2 write "." set matched=matched+1 quit - . write !,IEN," ",P2,! - write !,Ct," extra records",! - write matched," matched records",! - quit - -IHS3 - new IEN set IEN=0 - for set IEN=$order(^TMG("TMGSIPH","PT XLAT",9000001,IEN)) QUIT:(IEN'>0) DO - . NEW PT SET PT=$GET(^TMG("TMGSIPH","PT XLAT",9000001,IEN)) - . if PT=0 kill ^TMG("TMGSIPH","PT XLAT",9000001,IEN) quit - . if PT'=IEN write "MISMATCH IEN ",IEN,"=",PT,! - write "goodbye",! - quit Index: cprs/branches/tmg-cprs/m_files/TMGFIX2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGFIX2.m~ (revision 796) +++ (revision ) @@ -1,1071 +1,0 @@ -TMGFIX2 ;TMG/kst/Misc system fixes;05/21/09 - ;;"1.0;TMG-LIB;**1**;05/21/09 - ; -FIXDD2 ;" i.e. Fix DD for file 2 - ;"Purpose: To alter the input tranform for the SSNUM field in file 2 - ; - NEW TMGXFRM SET TMGXFRM=$PIECE($GET(^DD(2,.09,0)),"^",5,999) - SET ^TMG("BAK",2,.09,"XFRM",$H)=TMGXFRM - NEW TMGXFRM2 SET TMGXFRM2=$PIECE($TEXT(TXT^TMGFIX2),";;",2,999) - SET $PIECE(^DD(2,.09,0),"^",5,999)=TMGXFRM2 - ;"Now change field in file 2 to be not required - DO URESTRCT(2,.09) ;"SSN field - DO URESTRCT(2,.301) ;"Service Connected? - DO URESTRCT(2,1901) ;"Veteran Y/N? - QUIT - ; - ;"DON'T remove the following line. It is used... -TXT ;;"K:X[""""!($A(X)=45) X I $D(X) S:'$D(DPTX) DFN=DA D:'(($G(DA)="+")&(X["P")) SSN^DGRPDD1 Q - ; -URESTRCT(TMGFILE,TMGFIELD) ;"i.e. UNRESTRICT - ;"Purpose: Remove R flag from DD entry - ; - NEW TMGDEF set TMGDEF=$PIECE($GET(^DD(TMGFILE,TMGFIELD,0)),"^",2) - IF TMGDEF["R" DO - . SET ^TMG("BAK",TMGFILE,TMGFIELD,0,"Field Def",$H)=TMGDEF - . SET TMGDEF=$TRANSLATE(TMGDEF,"R","") ;"REMOVE R (RESTRICTED) FLAG - . SET $PIECE(^DD(TMGFILE,TMGFIELD,0),"^",2)=TMGDEF - QUIT - ; -ENSURECPRS - ;"Purpose: Ensure the OR CPRS GUI CHART ... has all needed RPC's - ;" - NEW DIC,X,Y - SET DIC=19,DIC(0)="M" - SET X="OR CPRS GUI CHART" - DO ^DIC - IF +Y'>0 DO GOTO ENCDN - NEW L SET L=1 - NEW DONE SET DONE=0 - FOR DO QUIT:DONE - . NEW LINE,RPC - . SET LINE=$TEXT(RPCLIST+L^TMGFIX2) - . SET L=L+1 - . IF LINE["" SET DONE=1 QUIT - . SET RPC=$PIECE(LINE,";;""",2) - . ;"WRITE RPC,! - . IF $$ENSURE1(+Y,RPC)=1 SET DONE=1 QUIT -ENCDN QUIT - ; -ENSURE1(IEN,RPC) - ;"Purpose: to ensure that the RPC is present. - ;"Results: 0 if OK, 1 if error - NEW RPCIEN,TMGERR - NEW RESULT SET RESULT=0 - NEW IENS SET IENS=","_IEN_"," - SET RPCIEN=$$FIND1^DIC(19.05,IENS,"UX",RPC,,,"TMGERR") - IF $DATA(TMGERR) DO goto ENS1DN - . ZWR TMGERR - . ;"SET RESULT=1 - IF RPCIEN>0 DO GOTO ENS1DN - . WRITE "." - WRITE "MISSING: ",RPC,! - NEW TMGFDA,TMGIEN - SET TMGFDA(19.05,"+1,"_IEN_",",.01)=RPC - DO UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") - IF $DATA(TMGERR) DO goto ENS1DN - . ZWR TMGERR - . SET RESULT=1 - IF $DATA(TMGIEN) WRITE "ADDED: ",RPC,! -ENS1DN QUIT RESULT - ; -RPCLIST ; OR CPRS GUI CHART RPC's From Astronaut VistA - ;;"GMRC LIST CONSULT REQUESTS - ;;"XWB GET VARIABLE VALUE - ;;"TIU AUTHORIZATION - ;;"TIU CAN CHANGE COSIGNER? - ;;"TIU CREATE ADDENDUM RECORD - ;;"TIU CREATE RECORD - ;;"TIU DELETE RECORD - ;;"TIU DETAILED DISPLAY - ;;"TIU DOCUMENTS BY CONTEXT - ;;"TIU GET ADDITIONAL SIGNERS - ;;"TIU GET ALERT INFO - ;;"TIU GET DOCUMENT PARAMETERS - ;;"TIU GET DS TITLES - ;;"TIU GET DS URGENCIES - ;;"TIU GET PERSONAL PREFERENCES - ;;"TIU GET PN TITLES - ;;"TIU GET RECORD TEXT - ;;"TIU IDENTIFY CONSULTS CLASS - ;;"TIU IS THIS A CONSULT? - ;;"TIU JUSTIFY DELETE? - ;;"TIU LOAD BOILERPLATE TEXT - ;;"TIU LOAD RECORD FOR EDIT - ;;"TIU LOCK RECORD - ;;"TIU LONG LIST CONSULT TITLES - ;;"TIU LONG LIST OF TITLES - ;;"TIU NOTES - ;;"TIU NOTES 16 BIT - ;;"TIU NOTES BY VISIT - ;;"TIU PERSONAL TITLE LIST - ;;"TIU PRINT RECORD - ;;"TIU REQUIRES COSIGNATURE - ;;"TIU SIGN RECORD - ;;"TIU SUMMARIES - ;;"TIU SUMMARIES BY VISIT - ;;"TIU UNLOCK RECORD - ;;"TIU UPDATE ADDITIONAL SIGNERS - ;;"TIU UPDATE RECORD - ;;"TIU WHICH SIGNATURE ACTION - ;;"ORB DELETE ALERT - ;;"ORB FOLLOW-UP ARRAY - ;;"ORB FOLLOW-UP STRING - ;;"ORB FOLLOW-UP TYPE - ;;"ORB SORT METHOD - ;;"ORK TRIGGER - ;;"ORQ NULL LIST - ;;"ORQOR DETAIL - ;;"TIU TEMPLATE CHECK BOILERPLATE - ;;"TIU TEMPLATE CREATE/MODIFY - ;;"TIU TEMPLATE DELETE - ;;"TIU TEMPLATE GETPROOT - ;;"TIU TEMPLATE LISTOWNR - ;;"TIU TEMPLATE SET ITEMS - ;;"TIU GET LIST OF OBJECTS - ;;"ORQOR LIST - ;;"ORQORB SORT - ;;"ORQPT ATTENDING/PRIMARY - ;;"ORQPT CLINIC PATIENTS - ;;"ORQPT CLINICS - ;;"ORQPT DEFAULT LIST SOURCE - ;;"ORQPT DEFAULT PATIENT LIST - ;;"ORQPT PATIENT TEAM PROVIDERS - ;;"ORQPT PROVIDER PATIENTS - ;;"ORQPT PROVIDERS - ;;"ORQPT SPECIALTIES - ;;"ORQPT SPECIALTY PATIENTS - ;;"ORQPT TEAM PATIENTS - ;;"ORQPT TEAMS - ;;"ORQPT WARD PATIENTS - ;;"ORQPT WARDRMBED - ;;"ORQPT WARDS - ;;"ORQQAL DETAIL - ;;"ORQQAL LIST - ;;"ORQQAL LIST REPORT - ;;"ORQQCN ADDCMT - ;;"ORQQCN ADMIN COMPLETE - ;;"ORQQCN DETAIL - ;;"ORQQCN DISCONTINUE - ;;"ORQQCN FIND CONSULT - ;;"ORQQCN FORWARD - ;;"ORQQCN GET CONSULT - ;;"ORQQCN GET ORDER NUMBER - ;;"ORQQCN GET PROC SVCS - ;;"ORQQCN LIST - ;;"ORQQCN LOAD FOR EDIT - ;;"ORQQCN MED RESULTS - ;;"ORQQCN PRINT SF513 - ;;"ORQQCN RECEIVE - ;;"ORQQCN RESUBMIT - ;;"ORQQCN SET ACT MENUS - ;;"ORQQCN SHOW SF513 - ;;"ORQQCN SIGFIND - ;;"ORQQCN STATUS - ;;"ORQQCN SVCLIST - ;;"ORQQCN SVCTREE - ;;"ORQQCN URGENCIES - ;;"ORQQCN2 GET CONTEXT - ;;"ORQQCN2 SAVE CONTEXT - ;;"ORQQLR DETAIL - ;;"ORQQLR SEARCH RANGE INPT - ;;"ORQQLR SEARCH RANGE OUTPT - ;;"ORQQPL ADD SAVE - ;;"ORQQPL AUDIT HIST - ;;"ORQQPL CHECK DUP - ;;"ORQQPL CLIN FILTER LIST - ;;"ORQQPL CLIN SRCH - ;;"ORQQPL DELETE - ;;"ORQQPL DETAIL - ;;"ORQQPL EDIT LOAD - ;;"ORQQPL EDIT SAVE - ;;"ORQQPL INACTIVATE - ;;"ORQQPL INIT PT - ;;"ORQQPL INIT USER - ;;"ORQQPL LIST - ;;"ORQQPL PROB COMMENTS - ;;"ORQQPL PROBLEM LEX SEARCH - ;;"ORQQPL PROBLEM LIST - ;;"ORQQPL PROV FILTER LIST - ;;"ORQQPL PROVIDER LIST - ;;"ORQQPL REPLACE - ;;"ORQQPL SAVEVIEW - ;;"ORQQPL SERV FILTER LIST - ;;"ORQQPL SRVC SRCH - ;;"ORQQPL UPDATE - ;;"ORQQPL USER PROB CATS - ;;"ORQQPL USER PROB LIST - ;;"ORQQPL VERIFY - ;;"ORQQPP LIST - ;;"ORQQPS DETAIL - ;;"ORQQPS LIST - ;;"ORQQPX REMINDER DETAIL - ;;"ORQQPX REMINDERS LIST - ;;"ORQQVI NOTEVIT - ;;"ORQQVI VITALS - ;;"ORQQVI VITALS FOR DATE RANGE - ;;"ORQQVI1 DETAIL - ;;"ORQQVI1 GRID - ;;"ORQQVI2 VITALS HELP - ;;"ORQQVI2 VITALS RATE CHECK - ;;"ORQQVI2 VITALS VAL & STORE - ;;"ORQQVI2 VITALS VALIDATE - ;;"ORQQVI2 VITALS VALIDATE TYPE - ;;"ORQQVS DETAIL NOTES - ;;"ORQQVS DETAIL SUMMARY - ;;"ORQQVS VISITS/APPTS - ;;"ORQQXMB MAIL GROUPS - ;;"ORQQXQA PATIENT - ;;"ORQQXQA USER - ;;"ORWCH LOADALL - ;;"ORWCH LOADSIZ - ;;"ORWCH SAVEALL - ;;"ORWCH SAVESIZ - ;;"ORWCS LIST OF CONSULT REPORTS - ;;"ORWCS PRINT REPORT - ;;"ORWCS REPORT TEXT - ;;"ORWCV DTLVST - ;;"ORWCV LAB - ;;"ORWCV POLL - ;;"ORWCV START - ;;"ORWCV STOP - ;;"ORWCV VST - ;;"ORWD DEF - ;;"ORWD DT - ;;"ORWD FORMID - ;;"ORWD GET4EDIT - ;;"ORWD KEY - ;;"ORWD OI - ;;"ORWD PROVKEY - ;;"ORWD SAVE - ;;"ORWD SAVEACT - ;;"ORWD SIGN - ;;"ORWD VALIDACT - ;;"ORWD1 PARAM - ;;"ORWD1 PRINTGUI - ;;"ORWD1 RVPRINT - ;;"ORWD2 DEVINFO - ;;"ORWD2 MANUAL - ;;"ORWDAL32 ALLERGY MATCH - ;;"ORWDAL32 DEF - ;;"ORWDAL32 SYMPTOMS - ;;"ORWDCN32 DEF - ;;"ORWDCN32 ORDRMSG - ;;"ORWDCN32 PROCEDURES - ;;"ORWDCSLT DEF - ;;"ORWDCSLT LOOK200 - ;;"ORWDFH ADDLATE - ;;"ORWDFH ATTR - ;;"ORWDFH CURISO - ;;"ORWDFH DIETS - ;;"ORWDFH FINDTYP - ;;"ORWDFH ISOIEN - ;;"ORWDFH ISOLIST - ;;"ORWDFH PARAM - ;;"ORWDFH QTY2CC - ;;"ORWDFH TFPROD - ;;"ORWDFH TXT - ;;"ORWDGX LOAD - ;;"ORWDGX VMDEF - ;;"ORWDLR ABBSPEC - ;;"ORWDLR ALLSAMP - ;;"ORWDLR DEF - ;;"ORWDLR LOAD - ;;"ORWDLR OIPARAM - ;;"ORWDLR STOP - ;;"ORWDLR32 ABBSPEC - ;;"ORWDLR32 ALLSAMP - ;;"ORWDLR32 ALLSPEC - ;;"ORWDLR32 DEF - ;;"ORWDLR32 IC DEFAULT - ;;"ORWDLR32 IC VALID - ;;"ORWDLR32 IMMED COLLECT - ;;"ORWDLR32 LAB COLL TIME - ;;"ORWDLR32 LOAD - ;;"ORWDLR32 MAXDAYS - ;;"ORWDLR32 ONE SAMPLE - ;;"ORWDLR32 ONE SPECIMEN - ;;"ORWDLR32 STOP - ;;"ORWDOR VMSLCT - ;;"ORWDPS32 ALLROUTE - ;;"ORWDPS32 AUTH - ;;"ORWDPS32 DLGSLCT - ;;"ORWDPS32 DOSES - ;;"ORWDPS32 DRUGMSG - ;;"ORWDPS32 FORMALT - ;;"ORWDPS32 ISSPLY - ;;"ORWDPS32 IVAMT - ;;"ORWDPS32 MEDISIV - ;;"ORWDPS32 OISLCT - ;;"ORWDPS32 SCSTS - ;;"ORWDPS32 VALQTY - ;;"ORWDPS32 VALRATE - ;;"ORWDPS32 VALSCH - ;;"ORWDRA DEF - ;;"ORWDRA32 APPROVAL - ;;"ORWDRA32 DEF - ;;"ORWDRA32 IMTYPSEL - ;;"ORWDRA32 ISOLATN - ;;"ORWDRA32 LOCTYPE - ;;"ORWDRA32 PROCMSG - ;;"ORWDRA32 RADSRC - ;;"ORWDRA32 RAORDITM - ;;"ORWDX AGAIN - ;;"ORWDX DGRP - ;;"ORWDX DISMSG - ;;"ORWDX DLGDEF - ;;"ORWDX DLGID - ;;"ORWDX DLGQUIK - ;;"ORWDX FORMID - ;;"ORWDX LOADRSP - ;;"ORWDX LOCK - ;;"ORWDX MSG - ;;"ORWDX ORDITM - ;;"ORWDX SAVE - ;;"ORWDX SEND - ;;"ORWDX SENDP - ;;"ORWDX UNLOCK - ;;"ORWDX WRLST - ;;"ORWDXA ALERT - ;;"ORWDXA COMPLETE - ;;"ORWDXA DC - ;;"ORWDXA DCREASON - ;;"ORWDXA DCREQIEN - ;;"ORWDXA FLAG - ;;"ORWDXA FLAGTXT - ;;"ORWDXA HOLD - ;;"ORWDXA UNFLAG - ;;"ORWDXA UNHOLD - ;;"ORWDXA VALID - ;;"ORWDXA VERIFY - ;;"ORWDXA WCGET - ;;"ORWDXA WCPUT - ;;"ORWDXC ACCEPT - ;;"ORWDXC DELAY - ;;"ORWDXC DELORD - ;;"ORWDXC DISPLAY - ;;"ORWDXC FILLID - ;;"ORWDXC ON - ;;"ORWDXC SAVECHK - ;;"ORWDXC SESSION - ;;"ORWDXM AUTOACK - ;;"ORWDXM DLGNAME - ;;"ORWDXM FORMID - ;;"ORWDXM LOADSET - ;;"ORWDXM MENU - ;;"ORWDXM MSTYLE - ;;"ORWDXM PROMPTS - ;;"ORWDXM1 BLDQRSP - ;;"ORWDXM2 CLRRCL - ;;"ORWDXQ DLGNAME - ;;"ORWDXQ DLGSAVE - ;;"ORWDXQ GETQLST - ;;"ORWDXQ GETQNAM - ;;"ORWDXQ PUTQLST - ;;"ORWDXQ PUTQNAM - ;;"ORWDXR ISREL - ;;"ORWDXR RENEW - ;;"ORWDXR RNWFLDS - ;;"ORWGEPT CLINRNG - ;;"ORWLR CUMULATIVE REPORT - ;;"ORWLR CUMULATIVE SECTION - ;;"ORWLR REPORT LISTS - ;;"ORWLRR ALLTESTS - ;;"ORWLRR ATESTS - ;;"ORWLRR ATG - ;;"ORWLRR ATOMICS - ;;"ORWLRR CHART - ;;"ORWLRR CHEMTEST - ;;"ORWLRR GRID - ;;"ORWLRR INTERIM - ;;"ORWLRR INTERIMG - ;;"ORWLRR INTERIMS - ;;"ORWLRR MICRO - ;;"ORWLRR NEWOLD - ;;"ORWLRR PARAM - ;;"ORWLRR SPEC - ;;"ORWLRR TG - ;;"ORWLRR USERS - ;;"ORWLRR UTGA - ;;"ORWLRR UTGD - ;;"ORWLRR UTGR - ;;"ORWMC PATIENT PROCEDURES - ;;"ORWOR RESULT - ;;"ORWOR SHEETS - ;;"ORWOR TSALL - ;;"ORWORB AUTOUNFLAG ORDERS - ;;"ORWORB FASTUSER - ;;"ORWORB GET TIU ALERT INFO - ;;"ORWORB GETDATA - ;;"ORWORB KILL UNSIG ORDERS ALERT - ;;"ORWORDG ALLTREE - ;;"ORWORDG GRPSEQB - ;;"ORWORDG IEN - ;;"ORWORDG MAPSEQ - ;;"ORWORDG REVSTS - ;;"ORWORR AGET - ;;"ORWORR GET - ;;"ORWORR GET4LST - ;;"ORWORR GETBYIFN - ;;"ORWORR GETTXT - ;;"ORWPCE ACTIVE PROV - ;;"ORWPCE ACTPROB - ;;"ORWPCE CPTREQD - ;;"ORWPCE DELETE - ;;"ORWPCE DIAG - ;;"ORWPCE GET EDUCATION TOPICS - ;;"ORWPCE GET EXAM TYPE - ;;"ORWPCE GET HEALTH FACTORS TY - ;;"ORWPCE GET IMMUNIZATION TYPE - ;;"ORWPCE GET SET OF CODES - ;;"ORWPCE GET SKIN TEST TYPE - ;;"ORWPCE GET TREATMENT TYPE - ;;"ORWPCE HF - ;;"ORWPCE IMM - ;;"ORWPCE LEX - ;;"ORWPCE LEXCODE - ;;"ORWPCE NOTEVSTR - ;;"ORWPCE PCE4NOTE - ;;"ORWPCE PED - ;;"ORWPCE PROC - ;;"ORWPCE SAVE - ;;"ORWPCE SCDIS - ;;"ORWPCE SCSEL - ;;"ORWPCE SK - ;;"ORWPCE TRT - ;;"ORWPCE VISIT - ;;"ORWPCE XAM - ;;"ORWPS ACTIVE - ;;"ORWPS COVER - ;;"ORWPS DETAIL - ;;"ORWPS1 NEWDLG - ;;"ORWPS1 PICKUP - ;;"ORWPS1 REFILL - ;;"ORWPT ADMITLST - ;;"ORWPT APPTLST - ;;"ORWPT CLINRNG - ;;"ORWPT CWAD - ;;"ORWPT DFLTSRC - ;;"ORWPT DIEDON - ;;"ORWPT DISCHARGE - ;;"ORWPT ENCTITL - ;;"ORWPT FULLSSN - ;;"ORWPT ID INFO - ;;"ORWPT LAST5 - ;;"ORWPT LIST ALL - ;;"ORWPT PTINQ - ;;"ORWPT SAVDFLT - ;;"ORWPT SELCHK - ;;"ORWPT SELECT - ;;"ORWPT SHARE - ;;"ORWPT TOP - ;;"ORWPT1 PCDETAIL - ;;"ORWPT1 PRCARE - ;;"ORWPT16 ADMITLST - ;;"ORWPT16 APPTLST - ;;"ORWPT16 DEMOG - ;;"ORWPT16 GETVSIT - ;;"ORWPT16 ID INFO - ;;"ORWPT16 LIST ALL - ;;"ORWPT16 LOOKUP - ;;"ORWPT16 PSCNVT - ;;"ORWRA DEFAULT EXAM SETTINGS - ;;"ORWRA IMAGING EXAMS - ;;"ORWRA PRINT REPORT - ;;"ORWRA REPORT TEXT - ;;"ORWRP PRINT LAB REPORTS - ;;"ORWRP PRINT REPORT - ;;"ORWRP REPORT LISTS - ;;"ORWRP REPORT TEXT - ;;"ORWRP1 LISTNUTR - ;;"ORWRP16 REPORT LISTS - ;;"ORWRP16 REPORT TEXT - ;;"ORWTIU GET DCSUMM CONTEXT - ;;"ORWTIU GET TIU CONTEXT - ;;"ORWTIU SAVE DCSUMM CONTEXT - ;;"ORWTIU SAVE TIU CONTEXT - ;;"ORWU CLINLOC - ;;"ORWU DEVICE - ;;"ORWU DT - ;;"ORWU EXTNAME - ;;"ORWU GBLREF - ;;"ORWU GENERIC - ;;"ORWU HASKEY - ;;"ORWU HOSPLOC - ;;"ORWU INPLOC - ;;"ORWU NEWPERS - ;;"ORWU NPHASKEY - ;;"ORWU PATCH - ;;"ORWU TOOLMENU - ;;"ORWU USERINFO - ;;"ORWU VALDT - ;;"ORWU VALIDSIG - ;;"ORWU VERSRV - ;;"ORWU16 DEVICE - ;;"ORWU16 HOSPLOC - ;;"ORWU16 NEWPERS - ;;"ORWU16 USERINFO - ;;"ORWU16 VALDT - ;;"ORWU16 VALIDSIG - ;;"ORWUH POPUP - ;;"ORWUX SYMTAB - ;;"ORWUXT LST - ;;"ORWUXT REF - ;;"ORWUXT VAL - ;;"ORQQCN DEFAULT REQUEST REASON - ;;"ORWDX LOCK ORDER - ;;"ORWDX UNLOCK ORDER - ;;"ORWDCN32 NEWDLG - ;;"ORQQCN GET SERVICE IEN - ;;"ORQQCN PROVDX - ;;"TIU TEMPLATE ACCESS LEVEL - ;;"TIU GET DOCUMENT TITLE - ;;"ORWPT BYWARD - ;;"ORQQPX GET HIST LOCATIONS - ;;"ORQQPX NEW REMINDERS ACTIVE - ;;"ORWPCE GET VISIT - ;;"TIU GET REQUEST - ;;"ORWORB KILL EXPIR MED ALERT - ;;"DG CHK BS5 XREF ARRAY - ;;"DG CHK BS5 XREF Y/N - ;;"DG CHK PAT/DIV MEANS TEST - ;;"DG SENSITIVE RECORD ACCESS - ;;"DG SENSITIVE RECORD BULLETIN - ;;"ORQQCN CANEDIT - ;;"ORQQCN EDIT DEFAULT REASON - ;;"ORQQCN SF513 WINDOWS PRINT - ;;"ORWCIRN FACLIST - ;;"ORWDLR32 GET LAB TIMES - ;;"ORWPT LEGACY - ;;"ORWRP GET DEFAULT PRINTER - ;;"ORWRP PRINT WINDOWS REPORT - ;;"ORWRP SAVE DEFAULT PRINTER - ;;"ORWRP WINPRINT DEFAULT - ;;"ORWRP WINPRINT LAB REPORTS - ;;"ORWTIU WINPRINT NOTE - ;;"ORWPCE GAFOK - ;;"ORWPCE MHCLINIC - ;;"ORWPCE LOADGAF - ;;"ORWPCE SAVEGAF - ;;"ORWPCE FORCE - ;;"TIU GET DEFAULT PROVIDER - ;;"TIU GET SITE PARAMETERS - ;;"TIU IS USER A PROVIDER? - ;;"ORWOR VWGET - ;;"ORWOR VWSET - ;;"ORWU PARAM - ;;"ORWDOR LKSCRN - ;;"ORWDOR VALNUM - ;;"ORWDPS32 VALROUTE - ;;"ORWORB UNSIG ORDERS FOLLOWUP - ;;"ORWTIU GET LISTBOX ITEM - ;;"ORWRP2 HS COMP FILES - ;;"ORWRP2 HS COMPONENTS - ;;"ORWRP2 HS FILE LOOKUP - ;;"ORWRP2 HS REPORT TEXT - ;;"ORWRP2 HS SUBITEMS - ;;"ORWPCE HASCPT - ;;"ORWPCE ASKPCE - ;;"ORWPCE MHTESTOK - ;;"ORWPCE GAFURL - ;;"ORQQPXRM DIALOG PROMPTS - ;;"ORQQPXRM EDUCATION SUBTOPICS - ;;"ORQQPXRM EDUCATION SUMMARY - ;;"ORQQPXRM EDUCATION TOPIC - ;;"ORQQPXRM MENTAL HEALTH - ;;"ORQQPXRM MENTAL HEALTH RESULTS - ;;"ORQQPXRM MENTAL HEALTH SAVE - ;;"ORQQPXRM PROGRESS NOTE HEADER - ;;"ORQQPXRM REMINDER CATEGORIES - ;;"ORQQPXRM REMINDER DETAIL - ;;"ORQQPXRM REMINDER DIALOG - ;;"ORQQPXRM REMINDER EVALUATION - ;;"ORQQPXRM REMINDER INQUIRY - ;;"ORQQPXRM REMINDER WEB - ;;"ORQQPXRM REMINDERS APPLICABLE - ;;"ORQQPXRM REMINDERS UNEVALUATED - ;;"ORWLRR INFO - ;;"TIU GET PRINT NAME - ;;"TIU WAS THIS SAVED? - ;;"ORWD1 COMLOC - ;;"ORWD1 SIG4ANY - ;;"ORWD1 SIG4ONE - ;;"ORWOR UNSIGN - ;;"ORWPT INPLOC - ;;"ORQQCN2 GET PREREQUISITE - ;;"ORQQCN2 SCHEDULE CONSULT - ;;"YS GAF API - ;;"TIU LONG LIST BOILERPLATED - ;;"ORWDLR33 FUTURE LAB COLLECTS - ;;"ORWRP PRINT REMOTE REPORT - ;;"ORWRP PRINT WINDOWS REMOTE - ;;"ORWRP PRINT LAB REMOTE - ;;"ORWRP PRINT WINDOWS LAB REMOTE - ;;"ORQQPXRM DIALOG ACTIVE - ;;"ORWPCE MH TEST AUTHORIZED - ;;"TIU GET BOILERPLATE - ;;"ORWRP2 HS COMPONENT SUBS - ;;"ORWCH SAVFONT - ;;"ORWDLR33 LASTTIME - ;;"ORWD1 SVONLY - ;;"ORWPCE HASVISIT - ;;"ORWPCE GETMOD - ;;"ORWPCE CPTMODS - ;;"XWB REMOTE CLEAR - ;;"XWB REMOTE GETDATA - ;;"XWB REMOTE RPC - ;;"XWB REMOTE STATUS CHECK - ;;"ORQQCN ASSIGNABLE MED RESULTS - ;;"ORQQCN ATTACH MED RESULTS - ;;"ORQQCN GET MED RESULT DETAILS - ;;"ORQQCN REMOVABLE MED RESULTS - ;;"ORQQCN REMOVE MED RESULTS - ;;"ORQQCN SVC W/SYNONYMS - ;;"ORWCV1 COVERSHEET LIST - ;;"ORWORB KILL EXPIR OI ALERT - ;;"ORWPCE GETSVC - ;;"ORWRP LAB REPORT LISTS - ;;"ORWTPN GETCLASS - ;;"ORWTPN GETTC - ;;"ORWTPO CSARNGD - ;;"ORWTPO CSLABD - ;;"ORWTPO GETTABS - ;;"ORWTPP ADDLIST - ;;"ORWTPP CHKSURR - ;;"ORWTPP CLDAYS - ;;"ORWTPP CLEARNOT - ;;"ORWTPP CLRANGE - ;;"ORWTPP CSARNG - ;;"ORWTPP CSLAB - ;;"ORWTPP DELLIST - ;;"ORWTPP GETCOMBO - ;;"ORWTPP GETCOS - ;;"ORWTPP GETDCOS - ;;"ORWTPP GETNOT - ;;"ORWTPP GETNOTO - ;;"ORWTPP GETOC - ;;"ORWTPP GETOTHER - ;;"ORWTPP GETREM - ;;"ORWTPP GETSUB - ;;"ORWTPP GETSURR - ;;"ORWTPP GETTD - ;;"ORWTPP GETTU - ;;"ORWTPP LSDEF - ;;"ORWTPP NEWLIST - ;;"ORWTPP PLISTS - ;;"ORWTPP PLTEAMS - ;;"ORWTPP REMLIST - ;;"ORWTPP SAVECD - ;;"ORWTPP SAVECS - ;;"ORWTPP SAVELIST - ;;"ORWTPP SAVENOT - ;;"ORWTPP SAVENOTO - ;;"ORWTPP SAVEOC - ;;"ORWTPP SAVEPLD - ;;"ORWTPP SAVESURR - ;;"ORWTPP SAVET - ;;"ORWTPP SETCOMBO - ;;"ORWTPP SETDCOS - ;;"ORWTPP SETOTHER - ;;"ORWTPP SETREM - ;;"ORWTPP SETSUB - ;;"ORWTPP SORTDEF - ;;"ORWTPP TEAMS - ;;"ORWTPT ATEAMS - ;;"ORWTPT GETTEAM - ;;"TIU TEMPLATE GET DEFAULTS - ;;"TIU TEMPLATE GET DESCRIPTION - ;;"TIU TEMPLATE SET DEFAULTS - ;;"ORWTIU IDNOTES INSTALLED - ;;"ORQQPX GET FOLDERS - ;;"ORQQPX SET FOLDERS - ;;"TIU FIELD CAN EDIT - ;;"TIU FIELD DELETE - ;;"TIU FIELD EXPORT - ;;"TIU FIELD IMPORT - ;;"TIU FIELD LIST - ;;"TIU FIELD LOAD - ;;"TIU FIELD LOAD BY IEN - ;;"TIU FIELD LOCK - ;;"TIU FIELD NAME IS UNIQUE - ;;"TIU FIELD SAVE - ;;"TIU FIELD UNLOCK - ;;"ORWDPS1 CHK94 - ;;"ORWDPS1 ODSLCT - ;;"ORWDPS1 SCHALL - ;;"ORWDPS2 ADMIN - ;;"ORWDPS2 DAY2QTY - ;;"ORWDPS2 OISLCT - ;;"ORWDPS2 REQST - ;;"ORWDX DGNM - ;;"ORWUL FV4DG - ;;"ORWUL FVIDX - ;;"ORWUL FVSUB - ;;"ORWUL QV4DG - ;;"ORWUL QVIDX - ;;"ORWUL QVSUB - ;;"ORWDPS1 DFLTSPLY - ;;"PXRM REMINDER DIALOG (TIU) - ;;"ORWPCE ANYTIME - ;;"ORQQPX GET DEF LOCATIONS - ;;"ORWTPP GETIMG - ;;"ORWTPP SETIMG - ;;"ORWTPO GETIMGD - ;;"ORQQPX REM INSERT AT CURSOR - ;;"TIU REMINDER DIALOGS - ;;"TIU REM DLG OK AS TEMPLATE - ;;"ORWDPS2 MAXREF - ;;"ORWDPS2 SCHREQ - ;;"ORWRP COLUMN HEADERS - ;;"TIU FIELD DOLMTEXT - ;;"TIU TEMPLATE PERSONAL OBJECTS - ;;"ORWPCE AUTO VISIT TYPE SELECT - ;;"ORWDPS2 QTY2DAY - ;;"ORWU HAS OPTION ACCESS - ;;"TIU TEMPLATE LOCK - ;;"ORQQPX LVREMLST - ;;"ORQQPX NEW COVER SHEET ACTIVE - ;;"ORQQPX NEW COVER SHEET REMS - ;;"ORQQPX SAVELVL - ;;"PXRM REMINDER CATEGORY - ;;"PXRM REMINDERS AND CATEGORIES - ;;"TIU DIV AND CLASS INFO - ;;"TIU TEMPLATE GETBOIL - ;;"TIU TEMPLATE GETITEMS - ;;"TIU TEMPLATE GETROOTS - ;;"TIU TEMPLATE GETTEXT - ;;"TIU TEMPLATE ISEDITOR - ;;"TIU TEMPLATE UNLOCK - ;;"TIU USER CLASS LONG LIST - ;;"ORWPCE ALWAYS CHECKOUT - ;;"ORWPCE GET EXCLUDED - ;;"ORWDPS1 FORMALT - ;;"ORQPT DEFAULT LIST SORT - ;;"ORWDPS1 DOSEALT - ;;"ORWTPR OCDESC - ;;"ORWTPR NOTDESC - ;;"ORWDPS1 FAILDEA - ;;"ORQPT DEFAULT CLINIC DATE RANG - ;;"ORWTIU CANLINK - ;;"TIU ID ATTACH ENTRY - ;;"TIU ID CAN ATTACH - ;;"TIU ID CAN RECEIVE - ;;"TIU ID DETACH ENTRY - ;;"ORWCOM GETOBJS - ;;"ORWCOM DETAILS - ;;"ORWCOM PTOBJ - ;;"TIU TEMPLATE GETLINK - ;;"TIU TEMPLATE ALL TITLES - ;;"ORWSR LIST - ;;"ORWSR SHOW SURG TAB - ;;"ORWSR GET SURG CONTEXT - ;;"ORWSR SAVE SURG CONTEXT - ;;"ORWSR ONECASE - ;;"ORWSR SHOW OPTOP WHEN SIGNING - ;;"ORWSR IS NON-OR PROCEDURE - ;;"ORWSR CASELIST - ;;"ORQQCN GET PROC IEN - ;;"ORWRP PRINT V REPORT - ;;"ORWRP3 EXPAND COLUMNS - ;;"ORWTPD ACTDF - ;;"ORWTPD DELDFLT - ;;"ORWTPD GETDFLT - ;;"ORWTPD RSDFLT - ;;"ORWTPD SUDF - ;;"ORWTPD SUINDV - ;;"ORWTPD GETSETS - ;;"ORWCOM ORDEROBJ - ;;"ORWRP2 COMPABV - ;;"ORWRP2 GETLKUP - ;;"ORWRP2 SAVLKUP - ;;"ORWRP2 COMPDISP - ;;"ORWPCE ISCLINIC - ;;"ORWCH SAVECOL - ;;"ORWSR RPTLIST - ;;"ORQQPXRM MST UPDATE - ;;"ORWMC PATIENT PROCEDURES1 - ;;"ORWRA IMAGING EXAMS1 - ;;"ORWRA REPORT TEXT1 - ;;"ORWDPS4 CPINFO - ;;"ORWDPS4 CPLST - ;;"ORWORB KILL UNVER MEDS ALERT - ;;"ORWORB KILL UNVER ORDERS ALERT - ;;"ORWPCE HNCOK - ;;"ORWPS MEDHIST - ;;"TIU FIELD CHECK - ;;"TIU FIELD LIST ADD - ;;"TIU FIELD LIST IMPORT - ;;"TIU SET DOCUMENT TEXT - ;;"ORWDPS2 CHKPI - ;;"ORWDXR GTORITM - ;;"ORWDPS2 CHKGRP - ;;"ORWDPS2 QOGRP - ;;"ORWDXR GETPKG - ;;"ORQPT MAKE RPL - ;;"ORQPT READ RPL - ;;"ORQPT KILL RPL - ;;"ORWTIU GET SAVED CP FIELDS - ;;"ORWDPS1 LOCPICK - ;;"ORWPT LAST5 RPL - ;;"ORWPT FULLSSN RPL - ;;"ORWOR PKIUSE - ;;"ORWOR1 SIG - ;;"ORWOR1 CHKDIG - ;;"ORWOR1 GETDTEXT - ;;"ORWOR1 GETDSIG - ;;"ORWTPD GETIMG - ;;"OREVNTX1 PRMPTID - ;;"ORECS01 CHKESSO - ;;"ORECS01 VSITID - ;;"OREVNTX LIST - ;;"OREVNTX PAT - ;;"OREVNTX1 GTEVT - ;;"OREVNTX1 CPACT - ;;"OREVNTX1 CURSPE - ;;"OREVNTX1 CHGEVT - ;;"OREVNTX1 DELPTEVT - ;;"OREVNTX1 DFLTEVT - ;;"OREVNTX ACTIVE - ;;"OREVNTX1 PUTEVNT - ;;"OREVNTX1 WRLSTED - ;;"OREVNTX1 EVT - ;;"OREVNTX1 NAME - ;;"OREVNTX1 MATCH - ;;"OREVNTX1 EMPTY - ;;"OREVNTX1 EXISTS - ;;"OREVNTX1 GTEVT1 - ;;"OREVNTX1 DIV - ;;"OREVNTX1 DIV1 - ;;"OREVNTX1 LOC - ;;"OREVNTX1 LOC1 - ;;"ORWDX SENDED - ;;"OREVNTX1 GETDLG - ;;"ORECS01 ECPRINT - ;;"ORECS01 ECRPT - ;;"OREVNTX1 ISDCOD - ;;"OREVNTX1 SETDFLT - ;;"TIU IS THIS A CLINPROC? - ;;"TIU IDENTIFY CLINPROC CLASS - ;;"TIU LONG LIST CLINPROC TITLES - ;;"ORWDPS1 HASOIPI - ;;"OREVNTX1 DEFLTS - ;;"OREVNTX1 MULTS - ;;"OREVNTX1 DONE - ;;"OREVNTX1 PROMPT IDS - ;;"ORWCIRN CHECKLINK - ;;"XWB DIRECT RPC - ;;"ORWDPS1 HASROUTE - ;;"ORQQCN UNRESOLVED - ;;"OREVNTX1 DELDFLT - ;;"ORWCH LDFONT - ;;"ORWU1 NAMECVT - ;;"OREVNTX1 DFLTDLG - ;;"ORWDPS5 LESAPI - ;;"ORWDPS5 LESGRP - ;;"OREVNTX1 TYPEXT - ;;"ORWORR RGET - ;;"OREVNTX1 AUTHMREL - ;;"OREVNTX1 HAVEPRT - ;;"OREVNTX1 CMEVTS - ;;"OREVNTX1 ODPTEVID - ;;"ORWOR PKISITE - ;;"OREVNTX1 COMP - ;;"OREVNTX1 ISHDORD - ;;"ORWDXR ORCPLX - ;;"OREVNTX1 ISPASS - ;;"OREVNTX1 ISPASS1 - ;;"OREVNTX1 DLGIEN - ;;"ORWDXR CANRN - ;;"ORWDXR ISCPLX - ;;"ORWDXA OFCPLX - ;;"ORQQPX GET NOT PURPOSE - ;;"ORWDPS1 IVDEA - ;;"ORWDXR ISNOW - ;;"ORRHCQ QRYITR - ;;"OREVNTX1 GETSTS - ;;"ORWU DEFAULT DIVISION - ;;"ORWDXA ISACTOI - ;;"ORECS01 SAVPATH - ;;"ORWOR RESULT HISTORY - ;;"XUS GET TOKEN - ;;"ORQQPX IMMUN LIST - ;;"XWB DEFERRED CLEARALL - ;;"ORWOR1 SETDTEXT - ;;"ORWOR1 GETDEA - ;;"ORWOR1 GETDSCH - ;;"ORWORB TEXT FOLLOWUP - ;;"ORWU1 NEWLOC - ;;"ORWPCE ACTIVE CODE - ;;"ORQQPXRM GET WH LETTER TEXT - ;;"ORQQPXRM GET WH LETTER TYPE - ;;"ORQQPXRM GET WH PROC RESULT - ;;"ORQQPXRM WOMEN HEALTH SAVE - ;;"ORB FORWARD ALERT - ;;"ORB RENEW ALERT - ;;"ORPRF CLEAR - ;;"ORPRF GETFLG - ;;"ORPRF HASFLG - ;;"ORWTPD GETOCM - ;;"TIU ONE VISIT NOTE? - ;;"VAFCTFU CONVERT ICN TO DFN - ;;"ORIMO IMOLOC - ;;"ORIMO IMOOD - ;;"ORWDPS4 IPOD4OP - ;;"ORWDPS4 UPDTDG - ;;"TIU USER INACTIVE? - ;;"ORWTPD PUTOCM - ;;"ORWOR ACTION TEXT - ;;"ORQQPXRM GEC DIALOG - ;;"ORQQPXRM GET WH REPORT TEXT - ;;"ORWDXR01 CANCHG - ;;"ORWDXR01 SAVCHG - ;;"TIU HAS AUTHOR SIGNED? - ;;"ORQQPXRM CHECK REM VERSION - ;;"ORQQPXRM GEC STATUS PROMPT - ;;"ORWDAL32 SEND BULLETIN - ;;"ORWDBA1 ORPKGTYP - ;;"ORWDXR01 ISSPLY - ;;"ORWDBA1 RCVORCI - ;;"ORWPS REASON - ;;"ORQQPXRM GEC FINISHED? - ;;"ORWDXM3 ISUDQO - ;;"ORWDBA1 SCLST - ;;"ORWDXR01 OXDATA - ;;"ORWDBA1 BASTATUS - ;;"ORWORB SETSORT - ;;"ORWORB GETSORT - ;;"ORWOR EXPIRED - ;;"ORECS01 GETDIV - ;;"ORWTPD1 GETEFDAT - ;;"ORWTPD1 GETEDATS - ;;"ORWTPD1 PUTEDATS - ;;"ORWTPD1 GETCSDEF - ;;"ORWTPD1 GETCSRNG - ;;"ORWTPD1 PUTCSRNG - ;;"ORWTPD1 GETEAFL - ;;"ORWDBA1 GETORDX - ;;"ORWDBA3 HINTS - ;;"ORWDAL32 LOAD FOR EDIT - ;;"ORWDAL32 SAVE ALLERGY - ;;"ORWDAL32 SITE PARAMS - ;;"ORWPCE CXNOSHOW - ;;"ORWDBA2 ADDPDL - ;;"ORWDBA2 DELPDL - ;;"ORWDBA2 GETDUDC - ;;"ORWDBA2 GETPDL - ;;"ORWDBA4 GETBAUSR - ;;"ORWDBA4 GETTFCI - ;;"ORWNSS NSSMSG - ;;"ORWNSS QOSCH - ;;"ORWNSS VALSCH - ;;"ORWNSS CHKSCH - ;;"ORWDPS4 ISUDIV - ;;"ORWDPS32 AUTHNVA - ;;"ORWTIU CHKTXT - ;;"ORWDPS5 ISVTP - ;;"TIU IS THIS A SURGERY? - ;;"TIU IDENTIFY SURGERY CLASS - ;;"TIU LONG LIST SURGERY TITLES - ;;"TIU GET DOCUMENTS FOR REQUEST - ;;"TIU SET ADMINISTRATIVE CLOSURE - ;;"ORBCMA5 GETUDID - ;;"ORIMO ISCLOC - ;;"ORIMO ISIVQO - ;;"ORWDBA7 GETIEN9 - ;;"ORWGN GNLOC - ;;"ORWGN AUTHUSR - ;;"ORVAA VAA - ;;"ORWCIRN VISTAWEB - ;;"ORWCIRN WEBCH - ;;"ORWDAL32 CLINUSER - ;;"ORWDBA7 ISWITCH - ;;"ORWDFH CURRENT MEALS - ;;"ORWDFH NFSLOC READY - ;;"ORWDFH OPDIETS - ;;"ORWMHV MHV - ;;"ORWPCE1 NONCOUNT - ;;"ORWPFSS IS PFSS ACTIVE? - ;;"GMV EXTRACT REC - ;;"GMV MARK ERROR - ;;"ORWDXVB COMPORD - ;;"ORWDXVB GETALL - ;;"ORWDXVB RAW - ;;"ORWDXVB RESULTS - ;;"ORWDXVB STATALOW - ;;"ORWGRPC ALLITEMS - ;;"ORWGRPC CLASS - ;;"ORWGRPC DATEITEM - ;;"ORWGRPC DELVIEWS - ;;"ORWGRPC DETAILS - ;;"ORWGRPC GETDATES - ;;"ORWGRPC GETPREF - ;;"ORWGRPC GETVIEWS - ;;"ORWGRPC ITEMDATA - ;;"ORWGRPC ITEMS - ;;"ORWGRPC LOOKUP - ;;"ORWGRPC PUBLIC - ;;"ORWGRPC RPTPARAM - ;;"ORWGRPC SETPREF - ;;"ORWGRPC SETVIEWS - ;;"ORWGRPC TESTSPEC - ;;"ORWGRPC TYPES - ;;"TIU GET DOCUMENT STATUS - ;;"TIU GET PRF ACTIONS - ;;"TIU ISPRF - ;;"TIU LINK TO FLAG - ;;"ORWGRPC DETAIL - ;;"ORWU VERSION - ;;"GMV ALLERGY - ;;"ORWCIRN WEBADDR - ;;"ORWGRPC TAX - ;;"GMV DLL VERSION - ;;"ORWDX CHANGE - ;;"GMV ADD VM - ;;"GMV CONVERT DATE - ;;"GMV GET CATEGORY IEN - ;;"GMV GET CURRENT TIME - ;;"GMV GET VITAL TYPE IEN - ;;"GMV LATEST VM - ;;"GMV MANAGER - ;;"GMV PARAMETER - ;;"GMV USER - ;;"GMV VITALS/CAT/QUAL - ;;"GMV V/M ALLDATA - ;;"TIU GET LINKED PRF NOTES - ;;"TIU GET PRF TITLE - ;;"ORWDX1 PATWARD - ;;"ORWRP4 HDR MODIFY - ;;"ORWDX1 STCHANGE - ;;"ORWDX1 DCREN - ;;"ORQQPXRM MHV - ;;"ORWGRPC GETSIZE - ;;"ORWGRPC SETSIZE - ;;"GMV LOCATION SELECT - ;;"ORWCIRN AUTORDV - ;;"ORPRF TRIGGER POPUP - ;;"ORWCIRN HDRON - ;;"MAG4 REMOTE IMPORT - ;;"ORWPT ENHANCED PATLOOKUP - ;;"ORWPT OTHER-RADIOBUTTONS - ;;"TMG ADD PATIENT - ;;"TMG AUTOSIGN TIU DOCUMENT - ;;"TMG BARCODE DECODE - ;;"TMG BARCODE ENCODE - ;;"TMG DOWNLOAD FILE - ;;"TMG DOWNLOAD FILE DROPBOX - ;;"TMG GET BLANK TIU DOCUMENT - ;;"TMG GET DFN - ;;"TMG GET IMAGE LONG DESCRIPTION - ;;"TMG GET PATIENT DEMOGRAPHICS - ;;"TMG SET PATIENT DEMOGRAPHICS - ;;"TMG UPLOAD FILE - ;;"TMG UPLOAD FILE DROPBOX - ;;"TMG CPRS GET URL LIST - ;;"TMG INIFILE GET - ;;"TMG INIFILE SET - ;;" - - QUIT - - -ORQQPXRM GEC STATUS PROMPT Index: cprs/branches/tmg-cprs/m_files/TMGFMUT.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGFMUT.m~ (revision 796) +++ (revision ) @@ -1,1419 +1,0 @@ -TMGFMUT ;TMG/kst/Fileman utility functions ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - ;"TMG FILEMAN-UTILITY FUNCTIONS - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"$$PTRLINKS - ;"$$FilePtrs(File,OutVarP) - ;"DispArray(ArrayP,DispdList,indentDepth,MaxDepth) - ;"ASKPTRIN - ;"ASKMVPTR - ;"QTMVPTR(Info,PFn) --quietly redirect pointers. - ;"QTMMVPTR(Info,ShowProgress) --quietly redirect multiple pointers at once. - ;"$$PtrsIn(File,IEN,Array) - ;"$$PtrsMIn(IENArray,Array,ShowProgress) - ;"$$PossPtrs(File,Array) - ;"$$FMDate(DateStr) -- convert string to FM date, with extended syntax handing - - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"ScanFile(FInfo,IEN,Array) - ;"ScanMFile(FInfoArray,IENArray,Array,ShowProgress) - ;"HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) - ;"HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) - - ;"======================================================================= - ;"DEPENDENCIES - ;"======================================================================= - ;"TMGDBAPI - ;"======================================================================= - - -PTRLINKS - ;"Purpose: To examine the Fileman data dictionary for a specified file - ;" Then tell any pointers out to other files. If found, then display - ;" this 'dependency'. Then follow trail to that file, and show it's - ;" 'dependency'. Trail will be followed up to N levels deep (set=6 here) - ;"Results: 1=OKToContinue, 0=failure - - new File,Info,DispdList - new result - - write "Display pointer dependencies between files.",!! - read "Enter file name or number to explore (^ to abort): ",File,! - if File="^" goto PTDone - set result=$$FilePtrs(File,"Info") - if result=0 write "Error. Aborting. Sorry about that...",!! goto PTDone - - do DispArray("Info",.DispdList,0,6) ;"force max depth=6 - -PTDone - quit result - - -FilePtrs(File,OutVarP) - ;"For File, create array listing those fields with pointers to other files - ;"Input: File -- can be file name or number to explore - ;" OutVarP -- the name of array to put results into - ;"Output: Values are put into @OutVarP as follows: - ;" @OutVarP@(FileNum,"FILE NAME")=File Name - ;" @OutVarP@(FileNum,FieldNum)=Field Number - ;" @OutVarP@(FileNum,FieldNum,"FIELD NAME")=Field Name - ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference - ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to - ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to - ;" @OutVarP@(FileNum,FieldNum,"X GET")=Code to xecute to get value - ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,.11),"^",5))" - ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE - ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value - ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,.11),"^",5)=TMGVALUE" - ;" ** For subfiles ** ... - ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"FIELD NAME")=Field Name - ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference - ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to - ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to - ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"X GET")=Code to xecute to get value - ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5))" - ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE - ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value - ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5)=TMGVALUE" - ;" ... etc. - ;"Results: 1=OKToContinue, 0=failure - - new TMGptrArray - new result - new index - new FileNum,FileName - - set result=$$GetFldList^TMGDBAPI(.File,"TMGptrArray") - if result=0 goto FPtrDone - set result=($get(OutVarP)'="") - if result=0 goto FPtrDone - if +$get(File)=0 do - . set FileNum=$$GetFileNum^TMGDBAPI(.File) - . set FileName=$get(File) - else do - . set FileNum=+File - . set FileName=$$GetFName^TMGDBAPI(FileNum) - set result=(FileNum'=0) - if result=0 goto FPtrDone - - set index=$order(TMGptrArray("")) - for do quit:(result=0)!(index="") - . new fieldnum,TMGFldInfo - . set fieldnum=index - . if +fieldnum=0 set result=0 quit - . do FIELD^DID(FileNum,fieldnum,,"POINTER;MULTIPLE-VALUED","TMGFldInfo","TMGMsg") - . if $data(TMGMsg) do set result=0 quit - . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") - . . if $data(TMGMsg("DIERR"))'=0 do quit - . . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) - . if $get(TMGFldInfo("MULTIPLE-VALUED"))=1 do - . . ;" handle subfiles via a recursive call - . . new subfile,subArrayP - . . set subfile=$$GetSubFileNumber^TMGDBAPI(FileNum,fieldnum) - . . if subfile=0 quit - . . set subArrayP=$name(@OutVarP@(FileNum,fieldnum,"SUBFILE")) - . . ;"set subArrayP=OutVarP - . . set result=$$FilePtrs(subfile,subArrayP) - . if $get(TMGFldInfo("POINTER"))'="" do - . . if +TMGFldInfo("POINTER")>0 quit ;"screen out computed nodes. - . . if TMGFldInfo("POINTER")[":" quit ;"screen out set type fields - . . new gref,node0 - . . set gref=TMGFldInfo("POINTER") - . . set @OutVarP@(FileNum,"FILE NAME")=FileName - . . set @OutVarP@(FileNum,fieldnum,"FIELD NAME")=$$GetFldName^TMGDBAPI(FileNum,fieldnum) - . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","GREF")=gref - . . set gref="^"_gref_"0)" - . . ;"write "index=",index," gref=",gref,! - . . set node0=$get(@gref) - . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NAME")=$piece(node0,"^",1) - . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NUMBER")=+$piece(node0,"^",2) - . . new DD set DD=$get(^DD(FileNum,fieldnum,0)) quit:(DD="") - . . new nodepce set nodepce=$piece(DD,"^",4) quit:(nodepce="") - . . new node set node=+$piece(nodepce,";",1) quit:(node="") - . . new pce set pce=+$piece(nodepce,";",2) quit:(pce'>0) - . . new thisGL set thisGL=$get(^DIC(FileNum,0,"GL")) - . . new getCode,setCode - . . if thisGL="" do quit:(thisGL="") - . . . ;"Note: I am only going to support 1 sub level. More--> brain hurts! - . . . new upNum set upNum=$get(^DD(FileNum,0,"UP")) - . . . if upNum="" quit - . . . set thisGL=$get(^DIC(upNum,0,"GL")) - . . . if thisGL="" quit ;"happens with sub-sub.. nodes. - . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,TMGIEN(1),"_node_")),""^"","_pce_")" - . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,TMGIEN(1),"_node_"),""^"","_pce_")=TMGVALUE" - . . else do - . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,"_node_")),""^"","_pce_")" - . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,"_node_"),""^"","_pce_")=TMGVALUE" - . . set @OutVarP@(FileNum,fieldnum,"X GET")=getCode - . . set @OutVarP@(FileNum,fieldnum,"X SET")=setCode - . set index=$order(TMGptrArray(index)) - -FPtrDone - quit result - -DispArray(ArrayP,DispdList,indentDepth,MaxDepth) - ;"Purpose: Display array created by FilePtrs (see format there) - ;"Input: ArrayP : name of array containing information - ;" DispdList : array (pass by reference) contining list of files already displayed - ;" DispdList("TIU DOCUMENT")="" - ;" DispdList("PATIENT")="" etc. - ;" indentDepth : Number of indents deep this function is. Default=0 - ;" MaxDepth : maximum number of indents deep allowed. - - new i,fieldnum,file,FileName - set indentDepth=+$get(indentDepth,0) - new indentS set indentS="" - for i=1:1:(indentDepth) s indentS=indentS_". " - - set file=$order(@ArrayP@("")) - set FileName=$get(@ArrayP@(file,"FILE NAME")) - set DispdList(FileName)="" - if FileName'="" write indentS,"FILE: ",FileName,! - set fieldnum=$order(@ArrayP@(file,"")) - for do quit:(+fieldnum=0) - . if +fieldnum=0 quit - . new p2FName - . set p2FName=$get(@ArrayP@(file,fieldnum,"POINTS TO","FILE NAME")) - . write indentS,"field: ",$get(@ArrayP@(file,fieldnum,"FIELD NAME")),"--> file: ",p2FName - . if $data(DispdList(p2FName))=0 do - . . set DispdList(p2FName)="" - . . if indentDepth0 goto APTDone - set DIC=File - do ^DIC - set IEN=+Y - if IEN'>0 goto APTDone - new TMGTIME set TMGTIME=$H - ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" - set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" - write !!,"Starting File Scan for instances of pointers (references) to this record.",!! - set result=$$PtrsIn(File,IEN,.Array,PFn) - if result=0 write !,"There was some problem. Sorry.",!! goto APTDone - - if $data(Array) do - . write !,"Done. Here are results:",! - . write "Format is: ",! - . write " Array(File#,IEN,0)=LastCount",! - . write " Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",! - . write " Description of parts:",! - . write " ----------------------",! - . write " File# -- the file the found entry exists it (may be a subfile number)",! - . write " IEN -- the record number in file",! - . write " Note: IEN here is different from the IEN passed in as a parameter",! - . write " FullRef -- the is the full reference to the found value. e.g.",! - . write " set value=$piece(@FullRef,""^"",piece)",! - . write " piece -- piece where value is stored in the node that is specified by FullRef",! - . write " IENS -- this is provided only for matches in subfiles. ",! - . write " It is the IENS that may be used in database calls",! - . write " TopGlobalRef -- this is the global reference for file. If the match is in a",! - . write " subfile, then this is the global reference of the parent file ",! - . write " (or the highest grandparent file if the parent file itself is",! - . write " a subfile)",! - . zwr Array(*) - . write "---------------------------",! - . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),! - else write !,"No pointers to that record found.",! - -APTDone - quit - -SCRLPTRIN - ;"Purpose: An scrolling interface shell to PtrsIn. - ;" Will ask for name of a file, and then a record in that file. - ;" Will then show all pointers to that particular record. - ;" Will then allow one to trace along pointer path (in or out) - - new File,IEN,Array,PFn,result - new AFile,AIEN,ACount - new ShowArray,ShowResults,Header,Count - new PickStr,PickInfo,Abort,Menu,UsrSlct - new DIC,X,Y - - write !!,"Pointer Scanner/Browser.",! - write "Will look for all pointers (references) to specified record.",!! - set DIC="^DIC(" - set DIC(0)="MAQE" - DO ^DIC - set File=+Y - if File'>0 goto SCPTDone - set DIC=File - do ^DIC - set IEN=+Y - if IEN'>0 goto SCPTDone - new TMGTIME set TMGTIME=$H - set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" -SCPT1 ; - write !!,"Scanning files for instances of pointers (references) to this record.",!! - set result=$$PtrsIn(File,IEN,.Array,PFn) - if result=0 do goto APTDone - . write !,"There was some problem. Sorry.",!! - . do PressToCont^TMGUSRIF - ;"Returned format is: ",! - ;" Array(File#,IEN,0)=LastCount",! - ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",! - ;" Description of parts:",! - - set File=0,Abort=0 - for set File=$order(Array(File)) quit:(+File'>0) do - . new FName set FName=$piece($get(^DIC(File,0)),"^",1) - . new IEN set IEN=0; - . for set IEN=$order(Array(File,IEN)) quit:(+IEN'>0) do - . . new Value01 set Value01=$$GET1^DIQ(File,IEN,.01) - . . set Count=0 - . . for set Count=$order(Array(File,IEN,Count)) quit:(+Count'>0) do - . . . new Str set Str=FName_"; #"_IEN_"; "_Value01 - . . . if Count>1 set Str=Str_" ("_Count_")" - . . . set ShowArray(Str,File_"^"_IEN_"^"_Count)="" - . . . - set Header="Pick ONE (and only ONE) record to explore. Press ESC ESC when done." -SCPT2 kill ShowResults - if $get(TMGPTCABORT)=1 goto SCPTDone - do Slctor2^TMGUSRIF("ShowArray","ShowResults",Header) - - set Count=$$ListCt^TMGMISC("ShowResults") - if Count>1 do goto SCPT2 - . write "Please pick ONE (and only ONE) record to explore.",! - . write "You selected at least ",Count,! - . write "Enter ^ to quit",! - . do PressToCont^TMGUSRIF - - set PickStr="" - set PickStr=$order(ShowResults(PickStr)) - if PickStr="" do goto SCPTDone - . write "No selected record. Goodbye.",! - . do PressToCont^TMGUSRIF - - set Count=$$ListCt^TMGMISC("ShowArray("_PickStr_")") - if Count>0 do goto SCPTDone - . set Abort=1 - . write "Please pick ONE (and only ONE) record to explore.",! - . write "You selected at least ",Count,! - . do PressToCont^TMGUSRIF - - set PickInfo=$order(ShowResults(PickStr,"")) - set AFile=$piece(PickInfo,"^",1) - set AIEN=$piece(PickInfo,"^",2) - set ACount=$piece(PickInfo,"^",3) - - set Menu(0)="Pick Option." - set Menu(1)="Show info for this selected record"_$C(9)_"ShowInfo" - set Menu(2)="DUMP this record"_$C(9)_"DumpRec" - set Menu(3)="Show pointers INTO selected record"_$C(9)_"ShowPtrIN" - set Menu(4)="Browse to other records pointed OUT from this record."_$C(9)_"BrowseOUT" - -MC1 write # - set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") - if UsrSlct="^" do goto SCPTDone - . write "Goodbye.",! - if UsrSlct=0 set UsrSlct="" - - if UsrSlct="ShowInfo" do goto MC1 - . if $data(Array(AFile,AIEN,ACount))=0 quit - . zwr Array(AFile,AIEN,ACount,*) - . do PressToCont^TMGUSRIF - if UsrSlct="DumpRec" do goto MC1 - . do DumpRec2^TMGDEBUG(AFile,AIEN,0) - . do PressToCont^TMGUSRIF - if UsrSlct="ShowPtrIN" do goto SCPT1 - . set File=AFile - . set IEN=AIEN - . set Count=ACount - if UsrSlct="BrowseOUT" do goto MC1 - . do Browse^TMGBROWS(AFile,AIEN,0) - . do PressToCont^TMGUSRIF - goto MC1 -SCPTDone - quit - - -ASKMVPTR - ;"Purpose: An interface shell toRedirect any pointer. - ;" Will ask for name of a file, and then a record in that file. - ;" Will then pass information to fileman function to move pointers. - - ;"Note: Example of array passed to P^DITP - ;" 23510 is $J - ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) - ;" 1646 is IEN to be substituted for all 47's - ;" - ;" First part of array is list of all files & fields that point to file - ;" ---------------- - ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" - ;" ... - ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" - ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" - ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" - ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" - ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" - ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" - ;" - ;" Second part of array is list of changes that should be made. Only 1 change shown here. - ;" ---------------- - ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" - ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" - - new File,fromIEN,toIEN,Array,PFn,result - new PossPtrs - - write !,"Pointer Redirection Utility",! - write "Will change pointers to FROM to TO value",! - - kill DIC - set DIC("A")="Select File holding records being pointed to: " - set DIC="^DIC(" - set DIC(0)="MAQE" - d ^DIC ;"Get File to search - set File=+Y - if File'>0 goto AMPTDone - - ;"Get list of files/fields with pointers in - set result=$$PossPtrs(File,.PossPtrs) if result=0 goto AMPTDone - if $data(PossPtrs)'>0 goto AMPTDone - - set DIC=File - set DIC("A")="Select Original (i.e OLD) Record: " - do ^DIC ;"get FROM record in File - set fromIEN=+Y - if fromIEN'>0 goto AMPTDone - - set DIC("A")="Select New Record: " - do ^DIC ;"get FROM record in File - set toIEN=+Y - if toIEN'>0 goto AMPTDone - - ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!" - ;"new TMGTIME set TMGTIME=$H - set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""Scanning File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)" - write !!,"Starting File Scan for instances of pointers (references) to this record.",!! - set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 goto AMPTDone - - ;" write !,"Here are possible pointers in (file level)",! - ;" if $data(PossPtrs) zwr PossPtrs(*) - - ;" write !,"Here are actual pointers in",! - ;" if $data(Array) zwr Array(*) - - ;"Now convert to FileMan Format. - kill ^UTILITY("DIT",$J) - do Prep4FM(.Array) - - if $data(^UTILITY("DIT",$J)) do - . merge ^UTILITY("DIT",$J,0)=PossPtrs - . ;"write !,"here are results",! - . ;" zwr ^UTILITY("DIT",$J,*) - . set DIR(0)="Y",DIR("B")="YES" - . set DIR("A")="Ask Fileman to redirect pointers?" - . set DIR("?")="Enter YES if you want Fileman to change all instances of the FROM record into the TO record." - . do ^DIR ;"get user response - . if +Y'=1 quit - . write "YES",! - . do PTS^DITP - else do - . write "No matches found...",!! - -AMPTDone - quit - - -QTMVPTR(Info,PFn) ;"NOTE: this function hasn't been debugged/tested yet - ;"Purpose: An interface to quietly redirect any pointer. - ;"Input: Info, an array containing info for redirecting pointers. - ;" Format: Note: File can be file name or number. - ;" Info(File,OldIEN)=newIEN - ;" Info(File,OldIEN)=newIEN1 - ;" Info(File,OldIEN)=newIEN - ;" PFn: OPTIONAL, a progress function (must be a complete M expression) - ;"Output: all pointers in linked files to OldIEN will be changed to newIEN - ;"Results: none - - ;"Note: Example of array passed to P^DITP - ;" 23510 is $J - ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) - ;" 1646 is IEN to be substituted for all 47's - ;" - ;" First part of array is list of all files & fields that point to file - ;" ---------------- - ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" - ;" ... - ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" - ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" - ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" - ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" - ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" - ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" - ;" - ;" Second part of array is list of changes that should be made. Only 1 change shown here. - ;" ---------------- - ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" - ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" - - new File,Array,result - set PFn=$get(PFn) - new Itr,File - - ;"Cycle through all files to be changed. - set File=$$ItrAInit^TMGITR("Info",.Itr) - if File'="" for do quit:($$ItrANext^TMGITR(.Itr,.File)="") - . new PossPtrs - . if +File'=File set File=$$GetFileNum^TMGDBAPI(File) ;Convert File Name to File Number - . ;"Get list of files/fields with pointers in - . set result=$$PossPtrs(File,.PossPtrs) if result=0 quit - . if $data(PossPtrs)'>0 quit - . kill ^UTILITY("DIT",$J) - . new fromIEN,toIEN,fromItr - . set fromIEN=+$$ItrAInit^TMGITR($name(Info(File)),.fromItr) - . new done2 set done2=0 - . ;"Cycle through all records to be changed. - . if fromIEN'=0 for do quit:(+$$ItrANext^TMGITR(.fromItr,.fromIEN)=0)!(done2=1) - . . set toIEN=$get(Info(File,fromIEN)) - . . set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 set done2=1 - . . do Prep4FM(.Array) - . if $data(^UTILITY("DIT",$J))=0 quit - . merge ^UTILITY("DIT",$J,0)=PossPtrs - . do PTS^DITP ;"Note: call separately for each file specified. - -QMPTDone - quit - - -QTMMVPTR(Info,ShowProgress) ;"NOTE: this function hasn't been debugged/tested yet - ;"Purpose: An interface to quietly redirect multiple pointer. - ;"NOTE: This functions differes from QTMVPTR in that it can look for all IEN's - ;" for a given file at once, speeding database access. - ;"Input: Info, an array containing info for redirecting pointers. - ;" Format: Note: File can be file name or number. - ;" Info(File,OldIEN)=newIEN - ;" Info(File,OldIEN)=newIEN1 - ;" Info(File,OldIEN)=newIEN - ;" ShowProgress: if 1, progress bar shown - ;"Output: all pointers in linked files to OldIEN will be changed to newIEN - ;"Results: none - - ;"Note: Example of array passed to P^DITP - ;" 23510 is $J - ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*)) - ;" 1646 is IEN to be substituted for all 47's - ;" - ;" First part of array is list of all files & fields that point to file - ;" ---------------- - ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'" - ;" ... - ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV" - ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V" - ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V" - ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX" - ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX" - ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'" - ;" - ;" Second part of array is list of changes that should be made. Only 1 change shown here. - ;" ---------------- - ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG(" - ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG(" - - new ToFile,Array,result - set PFn=$get(PFn) - new Itr - - ;"Cycle through all files to be changed. - set ToFile=$$ItrAInit^TMGITR("Info",.Itr) - if ToFile'="" for do quit:($$ItrANext^TMGITR(.Itr,.ToFile)="") - . new PossPtrs - . if +ToFile'=ToFile set ToFile=$$GetFileNum^TMGDBAPI(ToFile) ;"Convert File Name to File Number - . ;"Get list of files/fields with pointers in - . set result=$$PossPtrs(ToFile,.PossPtrs) if result=0 quit - . if $data(PossPtrs)'>0 quit - . kill ^UTILITY("DIT",$J) - . ;"new fromIEN,toIEN,fromItr - . ;"set fromIEN=+$$ItrAInit^TMGITR($name(Info(ToFile)),.fromItr) - . new IENArray set IENArray=ToFile - . merge IENArray=Info(ToFile) - . set IENArray=ToFile - . set result=$$PtrsMIn(.IENArray,.Array,.ShowProgress) - . new toFile2,toIEN,fromFile,fromIEN,Array2 - . set toFile2="" - . for set toFile2=$order(Array(toFile2)) quit:(toFile2="") do - . . set toIEN="" - . . for set toIEN=$order(Array(toFile2,toIEN)) quit:(toIEN="") do - . . . set fromFile="" - . . . for set fromFile=$order(Array(toFile2,toIEN,fromFile)) quit:(fromFile="") do - . . . . set fromIEN="" - . . . . for set fromIEN=$order(Array(toFile2,toIEN,fromFile,fromIEN)) quit:(fromIEN="") do - . . . . . merge Array2(fromFile,fromIEN)=Array(toFile2,toIEN,fromFile,fromIEN) - . set toFile2="" - . for set toFile2=$order(Array2(toFile2)) quit:(toFile2="") do - . . do MPrep4FM(toFile2,.Array2) - . . if $data(^UTILITY("DIT",$J))=0 quit - . . merge ^UTILITY("DIT",$J,0)=PossPtrs - . . do PTS^DITP ;"Note: call separately for each file specified. - -QMMPTDone - quit - - -Prep4FM(Array) - ;"Purpose: to convert Array with redirection info into format for Fileman - ;"Input: Array -- PASS BY REFERENCE. An array as created by PtrsIn() - ;"Output: Data will be put into ^UTILITY('DIT',$J) - ;"Results: none - - ;"Now convert to FileMan Format. - new iFile,iIEN,count,index,toRef - set iFile=$order(Array("")) - if +iFile'=0 for do quit:(+iFile=0) - . set iIEN=$order(Array(iFile,"")) - . if +iIEN'=0 for do quit:(+iIEN=0) - . . set count=+$get(Array(iFile,iIEN,0)) - . . for index=1:1:count do - . . . set toRef=$piece($get(Array(iFile,iIEN,count)),";",4) - . . . set toRef=$extract(toRef,2,999) - . . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef - . . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" - . . set iIEN=$order(Array(iFile,iIEN)) - . set iFile=$order(Array(iFile)) - - quit - - -MPrep4FM(fromFile,Array) - ;"Purpose: to convert Array with redirection info into format for Fileman - ;"Input: fromFile -- the FromFileNum -- Note: should be called once for - ;" each File number - ;" Array -- PASS BY REFERENCE. An array as created by PtrsMIn() - ;" Array(FromFile#,fromIEN,0)=LastCount - ;" Array(FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef - ;"Output: Data will be put into ^UTILITY('DIT',$J) - ;"Results: none - - ;"Now convert to FileMan Format. - new fromIEN set fromIEN="" - for set fromIEN=$order(Array(fromFile,fromIEN)) quit:(+fromIEN'>0) do - . new count - . set count=+$get(Array(fromFile,fromIEN,0)) - . new index for index=1:1:count do - . . new toRef - . . set toRef=$piece($get(Array(fromFile,fromIEN,count)),";",4) - . . set toRef=$extract(toRef,2,999) - . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef - . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_"" - - quit - - -PtrsIn(File,IEN,Array,PrgsFn) - ;"SCOPE: PUBLIC - ;"Purpose: Create a list of incoming pointers to a given record in given file - ;"Input: File: The file to investigate (Number or Name) - ;" IEN: IEN of record to - ;" Array -- PASS BY REFERENCE. An array to receive results back. - ;" any prexisting data in Array is killed before filling - ;" PrgsFn: OPTIONAL -- - ;" because this search process can be quite lengthy, - ;" an optional line of M code may be given here that will be executed - ;" before each file is scanned. The following variables will be defined: - ;" TMGCODE -- will hold code of current file being scanned. - ;" TMGTOTAL -- will hold total number of records to scan - ;" TMGCUR -- will hold count of current record being scanned. - ;"Output: Array is filled with format as follows: - ;" Array(File#,IEN,0)=LastCount - ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" Description of parts: - ;" ---------------------- - ;" File# -- the file the found entry exists it (may be a subfile number) - ;" IEN -- the record number in file - ;" Note: IEN here is different from the IEN passed in as a parameter - ;" FullRef -- the is the full reference to the found value. e.g. - ;" set value=$piece(@FullRef,"^",piece) - ;" piece -- the piece where value is stored in the node that is specified by FullRef - ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls - ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then - ;" this is the global reference of the parent file (or the highest grandparent file if - ;" the parent file itself is a subfile, etc.) - ;" - ;"Result: 1 if results found, 0 if error occurred. - ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! - - kill Array - new result set result=0 - new FileNum - set IEN=+$get(IEN) - if IEN=0 goto FPIDone ;"NOTE: IEN doesn't have to point to a valid record. - if $data(File)#10=0 goto FPIDone - if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number - else set FileNum=File - if +FileNum=0 goto FPIDone - - new PossArray,TMGCODE - if $$PossPtrs(File,.PossArray)=0 goto FPIDone - - ;"Count number of records to scan - new TMGCUR set TMGCUR=0 - new TMGTOTAL set TMGTOTAL=0 - do - . new temp set temp=$order(PossArray("")) - . if temp'="" for do quit:(temp="") - . . new code set code=PossArray(temp) - . . new ref set ref=$get(^DIC(+code,0,"GL")) - . . set ref=$$CREF^DILF(ref) ;"convert open to closed format - . . new NumRecs - . . if ref'="" set NumRecs=+$piece(@ref@(0),"^",4) - . . else set NumRecs=10000 ;"some arbitrary guess of #recs in a subfile - . . set TMGTOTAL=TMGTOTAL+1 - . . set TMGTOTAL(TMGTOTAL)=NumRecs - . . set temp=$order(PossArray(temp)) - . set temp=$order(TMGTOTAL("")) - . set TMGTOTAL=1 - . if temp'="" for do quit:(temp="") - . . set TMGTOTAL=TMGTOTAL+TMGTOTAL(temp) - . . set temp=$order(TMGTOTAL(temp)) - . if TMGTOTAL=0 set TMGTOTAL=1 ;"avoid div by zero issues. - - new count set count=1 - new index set index=$order(PossArray("")) - if index'="" for do quit:(index="") - . set TMGCUR=TMGCUR+TMGTOTAL(count) - . set count=count+1 - . set TMGCODE=PossArray(index) - . if $get(PrgsFn)'="" do - . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" - . . xecute PrgsFn - . do ScanFile(TMGCODE,IEN,.Array) - . set index=$order(PossArray(index)) - - set result=1 -FPIDone - quit result - - -PtrsMIn(IENArray,Array,ShowProgress) - ;"SCOPE: PUBLIC - ;"Purpose: Create a list of incoming pointers to an array of records in given file - ;"NOTE: this function differes from PtrsIn because is allows multiple input IEN's - ;"Input: IENArray: PASS BY REFERENCE. Array of IENs of record in ToFile. Format: - ;" IENArray=SourceFile# - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;" Array -- PASS BY REFERENCE. An array to receive results back. Format below. - ;" any prexisting data in Array is killed before filling - ;" ShowProgress: if 1, progress bar shown - ;"Output: Array is filled with format as follows: - ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,0)=LastCount - ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" Description of parts: - ;" ---------------------- - ;" ToFile# -- the file containing the target IEN record - ;" ToIEN --the IEN in ToFile - ;" FromFile# -- the file the found entry exists it (may be a subfile number) - ;" fromIEN -- the record number in file - ;" Note: IEN here is different from the IEN passed in as a parameter - ;" FullRef -- the is the full reference to the found value. e.g. - ;" set value=$piece(@FullRef,"^",piece) - ;" piece -- the piece where value is stored in the node that is specified by FullRef - ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls - ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then - ;" this is the global reference of the parent file (or the highest grandparent file if - ;" the parent file itself is a subfile, etc.) - ;" - ;"Result: 1 if results found, 0 if error occurred. - ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT! - - kill Array - new result set result=0 - new FileNum - set ToFile=$get(IENArray) if ToFile="" goto FMPIDone - if +ToFile=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number - else set FileNum=ToFile - if +FileNum=0 goto FMPIDone - - new PossArray - if $$PossPtrs(FileNum,.PossArray)=0 goto FMPIDone - - new FInfoArray - new index set index="" - for set index=$order(PossArray(index)) quit:(index="") do - . new tempS set tempS=$get(PossArray(index)) - . new fromFile set fromFile=$piece(tempS,"^",1) - . new fromField set fromField=$piece(tempS,"^",2) - . new fldCode set fldCode=$piece(tempS,"^",3) - . set FInfoArray(fromFile,fromField)=fldCode - - do ScanMFile(.FInfoArray,.IENArray,.Array,.ShowProgress) - - set result=1 -FMPIDone - quit result - - -ScanFile(FInfo,IEN,Array) - ;"SCOPE: PUBLIC - ;"Purpose: To scan one file (from array setup by PossPtrs) for actual pointers to IEN - ;"Input: FInfo : OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) - ;"Examples of possible inputs follow: - ;"50^62.05^*P50'" - ;"695^.01^RP50'" - ;"801.43^.02^RV" - ;"810.31^.04^V" - ;"811.902^.01^MVX" - - ;"NOTE: Idea for future enhancement: Allow FInfo to hold a list rather than just one value. - ;" This would be for instances where multiple fields in given record need to be searched - ;" This might speed up database access times. - - ;" IEN : the IEN that pointers should point to, to be considered a match. - ;" Array : PASS BY REFERENCE. An array to receive results. - ;"Output: Format of Array output: - ;" Array(File#,IEN,0)=LastCount - ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" Description of parts: - ;" ---------------------- - ;" File# -- the file the found entry exists it (may be a subfile number) - ;" IEN -- the record number in file - ;" Note: IEN here is different from the IEN passed in as a parameter - ;" FullRef -- the is the full reference to the found value. e.g. - ;" set value=$piece(@FullRef,"^",piece) - ;" piece -- the piece where value is stored in the node that is specified by FullRef - ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls - ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then - ;" this is the global reference of the parent file (or the highest grandparent file if - ;" the parent file itself is a subfile, etc.) - ;" - ;"result : none - - new File set File=$piece(FInfo,"^",1) if File="" goto SFDone - new Field set Field=$piece(FInfo,"^",2) if Field="" goto SFDone - new Code set Code=$piece(FInfo,"^",3) if Code="" goto SFDone - new count - if '((Code["P")!(Code["V")) goto SFDone - new GRef - new znode set znode=$get(^DD(File,Field,0)) - new loc set loc=$piece(znode,"^",4) - new node set node=$piece(loc,";",1) - new pce set pce=$piece(loc,";",2) - if +$$IsSubFile^TMGDBAPI(File) do - . new FileArray,i,k,FNum,SubInfo - . set i=0 - . set FileArray(0)=0 - . set FileArray(i,"PARENT","LOC")=loc - . set FNum=File - . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence - . . set i=i+1 - . . set FileArray(i)=FNum - . . if i=1 set FileArray(0,"FILE")=FNum - . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do - . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") - . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor - . . else do - . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) - . . set FNum=$$IsSubFile^TMGDBAPI(FNum) - . do HandleSubFile(IEN,.FileArray,.Array) - else do - . set GRef=$get(^DIC(File,0,"GL")) - . new ORef set ORef=GRef - . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format - . new index set index=$order(@GRef@(0)) - . if index'="" for do quit:(index="") - . . new value set value=$get(@GRef@(index,node)) - . . if $piece(value,"^",pce)=IEN do - . . . set Array(File,index,0)=1 - . . . set Array(File,index,1)=$name(@GRef@(index,node))_";"_pce_";"_""_";"_ORef - . . set index=$order(@GRef@(index)) - -SFDone - quit - - -ScanMFile(FInfoArray,IENArray,Array,ShowProgress) - ;"SCOPE: PUBLIC - ;"Purpose: To scan multiple file (from array setup by PossPtrs) for actual pointers to IENs - ;"Input: FInfoArray : PASS BY REFERENCE. Format: - ;" FInfoArray(OtherFile,Field)=FieldCode(piece#2 of 0 node of ^DD entry for field) - ;" Examples of possible inputs follow: - ;" FInfoArray(50,62.05)="*P50'" - ;" FInfoArray(695,.01)="RP50'" - ;" FInfoArray(801.43,.02)="RV" - ;" FInfoArray(810.31,.04)="V" - ;" FInfoArray(811.902,.01)="MVX" - ;" IENArray : PASS BY REFERENCE. IEN's that pointers should point TO, to be considered a match. - ;" Format: IENArray=SourceFile - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: - ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount - ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" Description of parts: - ;" ---------------------- - ;" ToFile# -- the file containing the target IEN record - ;" ToIEN --the IEN in ToFile - ;" fromFile# -- the file the found entry exists it (may be a subfile number) - ;" fromIEN -- the record number in file - ;" Note: IEN here is different from the IEN passed in as a parameter - ;" FullRef -- the is the full reference to the found value. e.g. - ;" set value=$piece(@FullRef,"^",piece) - ;" piece -- the piece where value is stored in the node that is specified by FullRef - ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls - ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then - ;" this is the global reference of the parent file (or the highest grandparent file if - ;" the parent file itself is a subfile, etc.) - ;" ShowProgress: if 1, progress bar shown - ;" - ;"result : none - - new ToFile set ToFile=+$get(IENArray) - set ShowProgress=$get(ShowProgress,0) - new abort set abort=0 - set fromFile="" - for set fromFile=$order(FInfoArray(fromFile)) quit:(fromFile="")!abort do - . if $$UserAborted^TMGUSRIF set abort=1 quit - . write !,"Processing File#: ",fromFile,! - . new Field set Field="" - . for set Field=$order(FInfoArray(fromFile,Field)) quit:(Field="") do - . . write " Field#: ",Field,! - . . new Code set Code=$get(FInfoArray(fromFile,Field)) if Code="" quit - . . new count - . . if '((Code["P")!(Code["V")) goto SFDone - . . new GRef - . . new znode set znode=$get(^DD(fromFile,Field,0)) - . . new loc set loc=$piece(znode,"^",4) - . . new node set node=$piece(loc,";",1) - . . new pce set pce=$piece(loc,";",2) - . . if +$$IsSubFile^TMGDBAPI(fromFile) do - . . . new FileArray,i,k,FNum,SubInfo - . . . set i=0 - . . . set FileArray(0)=0 - . . . set FileArray(i,"PARENT","LOC")=loc - . . . set FNum=fromFile - . . . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence - . . . . set i=i+1 - . . . . set FileArray(i)=FNum - . . . . if i=1 set FileArray(0,"FILE")=FNum - . . . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do - . . . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC") - . . . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor - . . . . else do - . . . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL")) - . . . . set FNum=$$IsSubFile^TMGDBAPI(FNum) - . . . do HandleMSubFile(.IENArray,.FileArray,.Array) - . . else do - . . . set GRef=$get(^DIC(fromFile,0,"GL")) - . . . new ORef set ORef=GRef - . . . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format - . . . new Itr,fromIEN - . . . set fromIEN=$$ItrAInit^TMGITR(GRef,.Itr) - . . . if ShowProgress=1 do PrepProgress^TMGITR(.Itr,20,1,"fromIEN") - . . . if fromIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.fromIEN)="")!abort - . . . . if $$UserAborted^TMGUSRIF set abort=1 quit - . . . . ;"for set fromIEN=$order(@GRef@(fromIEN)) quit:(fromIEN="") do - . . . . new valueS set valueS=$get(@GRef@(fromIEN,node)) - . . . . new ToIEN set ToIEN=$piece(valueS,"^",pce) - . . . . if $data(IENArray(ToIEN))>0 do - . . . . . new lastCount set lastCount=+$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 - . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=lastCount - . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,lastCount)=$name(@GRef@(fromIEN,node))_";"_pce_";"_""_";"_ORef - -SMFDone - quit - - -HandleSubFile(SearchValue,FileArray,Array,IENS,Ref) - ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. - ;"Input: SearchValue -- the value to be searched for, in INTERNAL format. - ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers - ;" and storage locations. Example: - ;" FileArra(0,"TOP GL")="^XTV(8989.3," - ;" FileArra(0,"FILE")=8989.33211 - ;" FileArra(0)=0 - ;" FileArra(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece - ;" FileArra(1)=8989.33211 - ;" FileArra(1,"PARENT","LOC")="1;0" <--- 1 is storage node - ;" FileArra(2)=8989.3321 - ;" FileArra(2,"PARENT","LOC")="1;0" <--- 1 is storage node - ;" FileArra(3)=8989.332 - ;" FileArra(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node - ;" FileArra(4)=8989.3 - ;" FileArra(4,"PARENT","GL")="^XTV(8989.3," - ;" Array -- PASS BY REFERENCE. An array the receives any search matches. - ;" Format is as follows - ;" Array(File#,IEN,0)=LastCount - ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" - ;" IENS -- OPTIONAL -- used by this function internally during recursive calls - ;" Ref -- OPTIONAL -- used by this function internally during recursive calls - - new index,s,IEN,CRef,pce,node - set index=$order(FileArray(""),-1) - set s=$get(FileArray(index,"PARENT","LOC")) - set node=$piece(s,";",1) - set pce=+$piece(s,";",2) - if s'="" do - . if +node'=node set node=""""_node_"""" - . set s=node_"," - else do - . set s=$get(FileArray(index,"PARENT","GL")) - . set node="" - set Ref=$get(Ref)_s - if Ref="" goto HSFDone - set CRef=$$CREF^DILF(Ref) - new subFArray - merge subFArray=FileArray - kill subFArray(index) ;"trim top entry from list/array - if index>0 do - . set IEN=$order(@CRef@(0)) - . if +IEN>0 for do quit:(+IEN=0) - . . new subRef,subIENS - . . set subRef=Ref_IEN_"," - . . set subIENS=IEN_","_$get(IENS) - . . do HandleSubFile(SearchValue,.subFArray,.Array,.subIENS,subRef) - . . set IEN=$order(@CRef@(IEN)) - else do - . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs - . . set subRef=$$CREF^DILF(subRef) - . . new p,t set (p,t)=0 - . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter - . . ;"new ORef set ORef=$extract(subRef,1,p-1) - . . set IEN=$piece($extract(subRef,p,99),")",1) - . . new value set value=$get(@subRef@(node)) - . . set value=$piece(value,"^",pce) - . . set value=$piece(value,";",1) ;"I think VARIABLE pointers format is: IEN;file# - . . if value=SearchValue do - . . . new tFile set tFile=$get(FileArray(0,"FILE"),"?") - . . . new count set count=$get(Array(tFile,IEN,0))+1 - . . . set Array(tFile,IEN,0)=count - . . . set Array(tFile,IEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) - -HSFDone - quit - - -HandleMSubFile(IENArray,FileArray,Array,IENS,Ref) - ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue. - ;"Input: IENArray : PASS BY REFERENCE. IEN's to search for in INTERNAL format. - ;" Format: IENArray=SourceFile - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers - ;" and storage locations. Example: - ;" FileArray(0,"TOP GL")="^XTV(8989.3," - ;" FileArray(0,"FILE")=8989.33211 - ;" FileArray(0)=0 - ;" FileArray(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece - ;" FileArray(1)=8989.33211 - ;" FileArray(1,"PARENT","LOC")="1;0" <--- 1 is storage node - ;" FileArray(2)=8989.3321 - ;" FileArray(2,"PARENT","LOC")="1;0" <--- 1 is storage node - ;" FileArray(3)=8989.332 - ;" FileArray(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node - ;" FileArray(4)=8989.3 - ;" FileArray(4,"PARENT","GL")="^XTV(8989.3," - ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format: - ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount - ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef - ;" Description of parts: - ;" ---------------------- - ;" ToFile# -- the file containing the target IEN record - ;" ToIEN --the IEN in ToFile - ;" fromFile# -- the file the found entry exists it (may be a subfile number) - ;" fromIEN -- the record number in file - ;" Note: IEN here is different from the IEN passed in as a parameter - ;" FullRef -- the is the full reference to the found value. e.g. - ;" set value=$piece(@FullRef,"^",piece) - ;" piece -- the piece where value is stored in the node that is specified by FullRef - ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls - ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then - ;" this is the global reference of the parent file (or the highest grandparent file if - ;" the parent file itself is a subfile, etc.) - ;" - ;" IENS -- OPTIONAL -- used by this function internally during recursive calls - ;" Ref -- OPTIONAL -- used by this function internally during recursive calls - - new ToFile set ToFile=$get(IENArray) - new index,s,IEN,CRef,pce,node - set index=$order(FileArray(""),-1) - set s=$get(FileArray(index,"PARENT","LOC")) - set node=$piece(s,";",1) - set pce=+$piece(s,";",2) - if s'="" do - . if +node'=node set node=""""_node_"""" - . set s=node_"," - else do - . set s=$get(FileArray(index,"PARENT","GL")) - . set node="" - set Ref=$get(Ref)_s - if Ref="" goto HSFDone - set CRef=$$CREF^DILF(Ref) - new subFArray - merge subFArray=FileArray - kill subFArray(index) ;"trim top entry from list/array - if index>0 do - . set fromIEN=0 - . for set fromIEN=$order(@CRef@(fromIEN)) quit:(+fromIEN=0) do - . . new subRef,subIENS - . . set subRef=Ref_fromIEN_"," - . . set subIENS=fromIEN_","_$get(IENS) - . . do HandleMSubFile(.IENArray,.subFArray,.Array,.subIENS,subRef) - else do - . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs - . . set subRef=$$CREF^DILF(subRef) - . . new p,t set (p,t)=0 - . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter - . . ;"new ORef set ORef=$extract(subRef,1,p-1) - . . set fromIEN=$piece($extract(subRef,p,99),")",1) - . . new valueS set valueS=$get(@subRef@(node)) - . . set valueS=$piece(valueS,"^",pce) - . . new ToIEN set ToIEN=$piece(valueS,";",1) ;"I think VARIABLE pointers format is: IEN;file# - . . if $data(IENArray(ToIEN))>0 do - . . . new fromFile set fromFile=$get(FileArray(0,"FILE"),"?") - . . . new count set count=$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1 - . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=count - . . . set Array(ToFile,ToIEN,fromFile,fromIEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL")) - -HMSFDone - quit - - -PossPtrs(File,Array) - ;"SCOPE: PUBLIC - ;"Purpose: to create a list of all possible pointers to a specified file, i.e. all other fields/fields - ;" that point to the specified file. - ;"Input: File: The file to investigate (Number or Name) - ;" Array -- PASS BY REFERENCE. An array to receive results back. - ;" any prexisting data in Array is killed before filling - ;"Output: Array is filled with format as follows: - ;" Array(1)=OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field) - ;" Array(2)=OtherFile#^Field#^FieldCode - ;"Result: 1 if results found, 0 if error occurred. - - kill Array - new result set result=0 - new FileNum - if $data(File)#10=0 goto PPtrsDone - if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number - else set FileNum=File - if +FileNum=0 goto PPtrsDone - - new count set count=1 - new PtrFile set PtrFile=$order(^DD(FileNum,0,"PT","")) - if PtrFile'="" for do quit:(PtrFile="") - . new PtrField set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,"")) - . if PtrField'="" for do quit:(PtrField="") - . . new s set s=PtrFile_"^"_PtrField - . . set s=s_"^"_$piece($get(^DD(PtrFile,PtrField,0)),"^",2) - . . set Array(count)=s - . . set count=count+1 - . . set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,PtrField)) - . set PtrFile=$order(^DD(FileNum,0,"PT",PtrFile)) - - set result=1 -PPtrsDone - quit result - - - ;"Note: Not fully debugged yet..." -SAFEKILL(Array,ShowProgress) - ;"Purpose: to safely kill records, including removing any pointers TO them - ;"input: pArray -- PASS BY REFERENCE. Expected input Format: - ;" Array(File,IEN)=0 - ;" Array(File,IEN)=0 - ;" ShowProgress: if 1, progress bar shown - ;"Output: all pointers in linked files to OldIEN will be changed to newIEN - ;"Results: none - - do QTMMVPTR(.Array,.ShowProgress) - quit - - -ASKKILL - ;"Purpose: to interact with user and safely kill records - ;"Input: none. - ;"Output: Records and pointers may be deleted - ;"Results: none - - new DIC,File,X,Y - new fromIEN,toIEN - new delArray - - kill DIC - set DIC("A")="Select file to delete from: " - set DIC="^DIC(" - set DIC(0)="MAQE" - d ^DIC ;"Get File to search - set File=+Y - if File'>0 goto ASKKDone - - new Menu,UsrSlct - set Menu(0)="Pick Option for Selecting Record(s) to Safely Delete" - set Menu(1)="Manually pick Record(s)"_$char(9)_"ManualPick" - set Menu(2)="Select a SET (aka SORT TEMPLATE) Contianing Many Records"_$char(9)_"PickSet" - -M1 write # - set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") - - if UsrSlct="ManualPick" goto ManualPick - if UsrSlct="PickSet" goto PickSet - if UsrSlct="^" goto ASKKDone - if UsrSlct=0 set UsrSlct="" - goto M1 - -ManualPick - set DIC=File - set DIC("A")="Select record to delete: " - do ^DIC ;"get FROM record in File - write ! - set fromIEN=+Y - if fromIEN'>0 goto ASKGo - set delArray(File,fromIEN)=0 - new % set %=2 - write "Pick another record" do YN^DICN write ! - if %=1 goto ManualPick - if %=-1 goto ASKKDone - goto ASKGo - -PickSet new IENArray - if $$GetTemplateRecs^TMGXMLUI(File,"IENArray","",1)=0 goto ASKKDone - ;"Output: Data is put into pRecs like this: @pRecs@(IEN)="" - - new IEN set IEN="" - for set IEN=$order(IENArray(IEN)) quit:(IEN="") do - . set delArray(File,IEN)=0 - -ASKGo - if $data(delArray)=0 goto ASKKDone - - ;"Get list of files/fields with pointers in - set result=$$PossPtrs(File,.PossPtrs) if result=0 goto ASKKDone - if $data(PossPtrs)'>0 goto DelRecs - - do SAFEKILL(.delArray,1) - -DelRecs ;"Now that pointers to records are deleted, it is safe to remove records themselves - - set IEN="" - new abort set abort=0 - for set IEN=$order(IENArray(IEN)) quit:(IEN="")!(abort=1) do - . if $$UserAborted^TMGUSRIF set abort=1 quit - . new TMGFDA,TMGMSG - . set TMGFDA(File,IEN_",",.01)="@" - . do FILE^DIE("EK","TMGFDA","TMGMSG") - . do ShowIfDIERR^TMGDEBUG(.TMGMSG) - -ASKKDone - quit - - - -VerifyPtrs(File,pArray,Verbose,AutoFix) - ;"Purpose: to scan a file for pointers OUT that are bad/invalid - ;"Input: File : file Name or Number to scan - ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: - ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr - ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr - ;" Verbose: OPTIONAL. If 1, then errors immediately written out. - ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. - ;"Results: None - - new PtrsOUT - new pPtrsOUT set pPtrsOUT="PtrsOUT" - new fileNum - if +File=File set fileNum=+File - else set fileNum=$$GetFileNum^TMGDBAPI(File) - set Verbose=+$get(Verbose) - set AutoFix=+$get(AutoFix) - - if $$FilePtrs(fileNum,pPtrsOUT)=0 goto VPtrDone - - new Itr,Itr2,TMGIEN,fieldNum - new TMGVALUE,code - new abort set abort=0 - new $etrap set $etrap="set Y=""(Invalid M code!. Error Trapped.)"" set $etrap="""",$ecode=""""" - - do DoVerify(File,pArray,Verbose,AutoFix) ;" Split out code to call it to call itself reentrantly - -VPtrDone - quit - - -DoVerify(fileNum,pArray,Verbose,AutoFix,IENS,pTMGIEN) - ;"Purpose: Function allow VerifyPtrs to call reentrantly - ;"Input: File : file Name or Number to scan - ;" pArray : PASS BY NAME, an OUT PARAMETER. Format: - ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr - ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr - ;" Verbose: OPTIONAL. If 1, then errors immediately written out. - ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted. - ;" IENS: OPTIONAL. If fileNum is a sub-file, then must supply - ;" to give location of subfile in parent file. - ;" pTMGIEN: "TMGIEN", or "TMGIEN(1)" etc. - ;"Results: None - ;"NOTICE: right now this MUST first be called from VerifyPtrs because - ;" I have not moved some NEW commandes etc from there to here. - ;" So this function depends on it's variables with global scope. - - set IENS=$get(IENS) - set pTMGIEN=$get(pTMGIEN,"TMGIEN") - set @pTMGIEN=$$ItrInit^TMGITR(fileNum,.Itr,.IENS) - if IENS="" do PrepProgress^TMGITR(.Itr,20,0,pTMGIEN) ;" no bar for subfiles - if @pTMGIEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.@pTMGIEN)'>0)!abort - . set fieldNum=$$ItrAInit^TMGITR($name(@pPtrsOUT@(fileNum)),.Itr2) - . if fieldNum'="" for do quit:(+$$ItrANext^TMGITR(.Itr2,.fieldNum)'>0)!abort - . . if (@pTMGIEN#10=0),$$UserAborted^TMGUSRIF set abort=1 quit - . . ;"Line below handles subfiles - . . if $data(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE")) do quit - . . . new subFile set subFile=$order(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE","")) - . . . set IENS=IENS_@pTMGIEN_"," - . . . do DoVerify(subFile,$name(@pArray@("SUBFILE")),.Verbose,.AutoFix,IENS,$name(@pTMGIEN@(1))) - . . ;"Otherwise, the usual case.... - . . set code=$get(PtrsOUT(fileNum,fieldNum,"X GET")) - . . if code="" quit - . . xecute code - . . if TMGVALUE="" quit - . . set TMGVALUE=+TMGVALUE - . . if TMGVALUE'>0 do quit - . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE - . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") - . . . new priorValue set priorValue=TMGVALUE - . . . set TMGVALUE="" - . . . if 'AutoFix quit - . . . xecute setCode - . . . if 'Verbose quit - . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! - . . . write " fixed...",! - . . ;"if (fileNum=2)&(TMGVALUE=777) do quit ;"TEMP!!!! - . . ;". set code=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(code="") - . . ;". set TMGVALUE=69 - . . ;". xecute code - . . new PtToGref set PtToGref="^"_$get(PtrsOUT(fileNum,fieldNum,"POINTS TO","GREF")) - . . if PtToGref="" do quit - . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)="??No reference for pointed to file??" - . . . if 'Verbose quit - . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Pointer value=[",TMGVALUE,"] but 'No reference for pointed to file (??)'",! - . . set PtToGref=PtToGref_TMGVALUE_")" - . . if $data(@PtToGref)'>0 do quit - . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE - . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="") - . . . new priorValue set priorValue=TMGVALUE - . . . set TMGVALUE="" - . . . if 'AutoFix quit - . . . xecute setCode - . . . if 'Verbose quit - . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",! - . . . write " fixed...",! - if IENS="" do ProgressDone^TMGITR(.Itr) - quit - - -ASKVFYPT ;"ASK VERIFY POINTERS - ;"Ask user to pick file, then verify pointers for that file. - - write "NOTICE: this function caused corruption of the database from",! - write " deletion of pointers incorrectly. Until this function",! - write " (ASKVFYPT^TMGFMUT) is fixed, it may not be used.",!,! - do PressToCont^TMGUSRIF - goto ASKDone - - - new DIC,X,Y - new FileNum,IEN - new UseDefault set UseDefault=1 - - ;"Pick file to dump from -ASK1 set DIC=1 - set DIC(0)="AEQM" - set DIC("A")="SELECT FILE TO VERIFY POINTERS IN: " - if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called - . do ^DICRW ;" has default value of user's last response - else do ^DIC ;doesn't have default value... - write ! - if +Y'>0 write ! goto ASKDone - set FileNum=+Y - - new BadPtrs - new AutoFix,Verbose,% - set %=2 - write "View details of scan" do YN^DICN write ! - if %=-1 goto ASKDone - set Verbose=(%=1) - - set %=2 - write "Auto-delete bad pointers (i.e. 0 value, or pointers to empty records)" - do YN^DICN write ! - if %=-1 goto ASKDone - set AutoFix=(%=1) - - do VerifyPtrs(FileNum,"BadPtrs",Verbose,AutoFix) - - if $data(BadPtrs) do - . new % set %=2 - . write "View array of bad pointers" do YN^DICN write ! - . if %'=1 quit - . do ArrayDump^TMGDEBUG("BadPtrs") - else write "No bad pointers. Great!",! - - do PressToCont^TMGUSRIF - -ASKDone - quit - -GREP(FIELD,S) - ;"The is a stub function, called by a Fileman Function (entry in file .5) - new result - set result="X1="_$get(FIELD)_" X2="_$get(S)_" D0="_$get(D0)_" DCC="_$get(DCC) - merge ^TMG("TMP","KILL","DIQGEY")=DIQGEY - set ^TMG("TMP","KILL","DA")=$get(DA) - set ^TMG("TMP","KILL","DR")=$get(DR) - set ^TMG("TMP","KILL","D0")=$get(D0) - set ^TMG("TMP","KILL","DCC")=$get(DCC) - QUIT result - -GETAPPT(TMGIEN) - QUIT 0 - -FMDate(DateStr) - ;"Purpose: convert string to FM date, with extended syntax handling - ;"Results: returns FM date, or -1 if error - new result set result=-1 - ;"First try direct conversion - new X,Y - set DateStr=$$TRIM^XLFSTR($get(DateStr)) - if DateStr="" goto FMDDone - for quit:(DateStr'[" ") set DateStr=$$Substitute^TMGSTUTL(DateStr," "," ") - if (DateStr'["@")&($length(DateStr," ")>3) do - . set DateStr=$piece(DateStr," ",1,3)_"@"_$piece(DateStr," ",4,99) - for quit:(DateStr'["@ ") set DateStr=$$Substitute^TMGSTUTL(DateStr,"@ ","@") - for quit:(DateStr'[" @") set DateStr=$$Substitute^TMGSTUTL(DateStr," @","@") - set %DT="T",X=DateStr - do ^%DT - set result=Y -FMDDone quit result Index: cprs/branches/tmg-cprs/m_files/TMGKERN2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGKERN2.m~ (revision 796) +++ (revision ) @@ -1,237 +1,0 @@ -TMGKERN2 ;TMG/kst/OS Specific functions ;11/21/09 - ;;1.0;TMG-LIB;**1**;11/21/09 - ; - ;"TMG KERNEL FUNCTIONS -- 2 - ;"This module is primarly for functions to support a SOCKET - ;" connection between two different VistA instances. One running - ;" as a server, and the other as a client. - ;"I.e. functions that are OS specific. - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"11/21/09 - ; -RUNSERVER(PORT,TMGMSGFN,TMGVERBOSE) - ;"Purpose: To open up a socket that will listen to requests from a client. - ;"Input: Port -- the port to listen on - ;" TMGMSGFN -- the NAME of a function that will handle incoming - ;" messages. E.g. 'HANDLMSG^MOD1' - ;" This function will be called as follows: - ;" xecute "DO "_TMGMSGFN_"(TMGCLIENT)" - ;" So the function must accept at least 1 parameter. - ;" TMGVERBOSE -- If 1 then some output will be show to console. - ;"Results: 1 if successful, -1^Error Message if failed. - ;"NOTE: This will be messaging protocol. - ;" #HELLO# will be sent on startup (possibly preceeded by 2 blank lines) - ;" #BYE# will be sent when server is quitting - ;" Server will respond to query of #BYE# by quitting. - ;" Server will turn control over to the message-handler-fn, allowing it to write - ;" out as many lines as it wants. - ;" After message-handler-fn returns, the server will send #OK# to signal done. - ;" - NEW RESULT,TMGDELIM,TMGTCPDEV,TMGTIMEOUT - NEW TMGCLIENT,TMGANSWR,TMGCODE - ; - SET RESULT=1 ;"Default of success - IF +$GET(PORT)'>0 DO GOTO RSVRDN - . SET RESULT="-1^Invalid port number passed. Received: "_$GET(PORT) - IF $GET(TMGMSGFN)="" DO GOTO RSVRDN - . SET RESULT="-1^No Message handling function passed." - IF $TEXT(@TMGMSGFN)="" DO GOTO RSVRDN - . SET RESULT="-1^Message handler ["_TMGMSGFN_"] appears invalid" - SET PORT=+$GET(PORT) - SET TMGDELIM=$CHAR(13) - SET TMGTCPDEV="server$"_$JOB - SET TMGTIMEOUT=30 - SET TMGCODE="DO "_TMGMSGFN_"(TMGCLIENT)" - SET TMGVERBOSE=+$GET(TMGVERBOSE) - ; - OPEN TMGTCPDEV:(ZLISTEN=PORT_":TCP":attach="server":DELIMITER=TMGDELIM):TMGTIMEOUT:"SOCKET" - IF $TEST=0 DO goto RSVRDN - . SET RESULT="-1^Attempts to open server failed (timedout)" - USE TMGTCPDEV - WRITE /listen(1) - WRITE /wait(TMGTIMEOUT) - WRITE "#HELLO#",! - ; -L1 ;"Main Listen-Reply loop - NEW TMGCLIENT,TMGI,TMGDONE - SET TMGDONE=-1,TMGI=1 - FOR DO QUIT:(TMGDONE>0)!(TMGI>100)!(TMGCLIENT="#BYE#") - . USE TMGTCPDEV - . READ TMGCLIENT:TMGTIMEOUT - . IF ($TEST=0)!(TMGCLIENT="") DO QUIT - . . SET TMGDONE=TMGDONE+1 - . . WRITE "#BYE#",! - . IF TMGCLIENT="#ENQ#" WRITE "#ACK#",! QUIT - . IF TMGCLIENT="#BYE#" WRITE "#BYE#",! QUIT - . SET TMGI=TMGI+1 - . DO - . . NEW $etrap - . . SET $etrap="write """",!,$ZSTATUS,! set $etrap="""",$ecode=""""" - . . XECUTE TMGCODE - . USE TMGTCPDEV ;"Ensure handler didn't redirect $IO - . WRITE "#OK#",! ;"Send message to indicate done sending reply (will allow multi line responses) - . use $P - . read *TMGDONE:0 - . IF TMGVERBOSE DO - . . if TMGI#10=1 write "+" - . . else write "." - ; - CLOSE TMGTCPDEV - ; -RSVRDN USE $P - QUIT RESULT - ; - ; -RUNCLIENT(HOST,PORT) ;"NOTE: meant to be run as a background process - ;"Purpose: Establish a connection with specified server. Then maintain connection, - ;" sending queries to server, and returning results. Will take as input - ;" a messaging global ^TMG("TMP","TCP",$J,"TS",)= TS=ToServer - ;" And replies will be stored in ^TMG("TMP","TCP",$J,"FS",)= FS=FromServer - ;"Input: HOST -- the IP address, (or name for DNS lookup) of the server. - ;" PORT -- the port that the server is listening on. - ;"Result: none - ;"Output: Results will be stored in ^TMG("TMP","TCP",$J,"RESULT")= - ;" 1 -- if successful, -1^Error Message if failed. - ;" - NEW RESULT,TMGDELIM,TMGTCPDEV,TMGTIMEOUT - ;"Setup vars - SET TMGTCPDEV="client$"_$JOB - SET TMGTIMEOUT=30 - KILL ^TMG("TMP","TCP",$J,"RESULT") - SET RESULT=1 - ;"Validate input - IF +$GET(PORT)'>0 DO GOTO RCLDN - . SET RESULT="-1^Valid port number passed. Received: "_$GET(PORT) - IF $GET(HOST)="" DO GOTO RCLDN - . SET RESULT="-1^No Host passed." - SET PORT=+$GET(PORT) - IF PORT'>0 DO GOTO RCLDN - . SET RESULT="-1^Invalid port: ["_PORT_"]" - ;"Open up the TCP/IP connection - OPEN TMGTCPDEV:(CONNECT=HOST_":"_PORT_":TCP":ATTACH="client":DELIMITER=$CHAR(13)):TMGTIMEOUT:"SOCKET" - IF $TEST=0 DO GOTO RCLDN - . SET RESULT="-1^Error on OPEN of SOCKET" - USE TMGTCPDEV - ;"Make sure server is ready to send information. - NEW TMGI,SRVREPLY - FOR TMGI=1:1:3 DO QUIT:(SRVREPLY="#HELLO#") - . READ SRVREPLY:TMGTIMEOUT - IF SRVREPLY'="#HELLO#" DO GOTO RCLDN - . SET RESULT="-1^Failed to get a '#HELLO#' from server" - SET ^TMG("TMP","TCP",$J,"RESULT")=$GET(RESULT) - ; - ;"Now process messaging. -RC1 NEW TSREF SET TSREF=$NAME(^TMG("TMP","TCP",$J,"TS")) - NEW FSREF SET FSREF=$NAME(^TMG("TMP","TCP",$J,"FS")) - NEW QUERY SET QUERY="" - NEW TMGIDLE SET TMGIDLE=0 - FOR DO quit:(QUERY="#BYE#")!(SRVREPLY="#BYE#") - . SET TMGI=$ORDER(@TSREF@("")) - . IF TMGI="" DO ;"Start idle handling - . . SET QUERY="" - . . SET TMGIDLE=TMGIDLE+1 - . . HANG 0.1 - . . IF TMGIDLE<50 QUIT - . . SET QUERY="#ENQ#" ;"send an ENQ every 5 seconds of idleness. - . . SET TMGIDLE=0 - . ELSE DO - . . SET QUERY=$get(@TSREF@(TMGI)) - . . KILL @TSREF@(TMGI) - . . SET TMGIDLE=0 ;"Reset idle counter - . IF QUERY="" QUIT - . USE TMGTCPDEV - . WRITE QUERY,! ;"send query to server. - . FOR DO QUIT:(SRVREPLY="#BYE#")!(SRVREPLY="#OK#")!(SRVREPLY="#ACK#") - . . READ SRVREPLY:TMGTIMEOUT ;"read reply. - . . IF ($TEST=0)!(SRVREPLY="") SET SRVREPLY="#BYE#" - . . IF SRVREPLY="#ACK#" QUIT ;"Don't record ENQ-ACK's - . . IF SRVREPLY="#BYE#" QUIT ;"Don't record Termination signal. - . . SET TMGI=+$ORDER(@FSREF@(""),-1) - . . SET @FSREF@(TMGI+1)=SRVREPLY - WRITE "#BYE#",! - CLOSE TMGTCPDEV - ; -RCLDN USE $P - SET ^TMG("TMP","TCP",$J,"RESULT")=$GET(RESULT) - HALT - ; - ; -MSGCLIENT(JNUM,QUERY,REPLY,ERROR,TIMEOUT) - ;"Purpose: To send messages to background client. So this will be one function - ;" that the programmer may interact with. The reason for having the client - ;" run as a separate job is so that the server and the client can talk back - ;" and forth with ENQ<-->ACK upon either timing out, to keep the connection - ;" alive. - ;"Input: JNUM -- The job number of the background client process - ;" QUERY -- The message to send to the server. - ;" REPLY -- PASS BY REFERENCE, AN OUT PARAMETER. Prior data killed. - ;" REPLY(1)= - ;" REPLY(2)= - ;" REPLY(3)= - ;" ERROR -- PASS BY REFERENCE, AN OUT PARAMETER. Prior data killed. - ;" If error, filled with -1^Message. - ;" TIMEOUT -- OPTIONAL. Default=1 (in seconds) - ;"Result: none - ; - KILL ERROR,REPLY - NEW RESULT SET RESULT="" - SET JNUM=+$GET(JNUM) - IF JNUM'>0 SET ERROR="-1^BAD JOB NUMBER" GOTO MSGDN - SET QUERY=$GET(QUERY) - IF QUERY="" SET ERROR="-1^NO QUERY PROVIDED" GOTO MSGDN - SET TIMEOUT=+$GET(TIMEOUT,1) - NEW NTIME,STIME SET STIME=$PIECE($H,",",2) - NEW TMGI SET TMGI=+$ORDER(^TMG("TMP","TCP",JNUM,"TS",""),-1) - SET ^TMG("TMP","TCP",JNUM,"TS",TMGI+1)=QUERY - IF QUERY="#BYE#" GOTO MSGDN - NEW REPLYI SET REPLYI=1 - NEW ONELINE SET ONELINE="" - FOR DO QUIT:(ONELINE="#OK#") - . SET TMGI=$ORDER(^TMG("TMP","TCP",JNUM,"FS","")) - . IF TMGI="" DO QUIT - . . SET NTIME=$PIECE($H,",",2) - . . IF (NTIME-STIME)'0 SET ERROR="-1^BAD JOB NUMBER" GOTO CLBFDN - NEW TMGI - FOR DO QUIT:(TMGI="") - . SET TMGI=$ORDER(^TMG("TMP","TCP",JNUM,"TS","")) - . IF TMGI="" QUIT - . KILL ^TMG("TMP","TCP",JNUM,"TS",TMGI) - FOR DO QUIT:(TMGI="") - . SET TMGI=$ORDER(^TMG("TMP","TCP",JNUM,"FS","")) - . IF TMGI="" QUIT - . KILL ^TMG("TMP","TCP",JNUM,"FS",TMGI) - ; -CLBFDN QUIT - ; - ; - ;"=================================================================== - ;"=================================================================== - ;" Delete later... - ;"=================================================================== - ;"=================================================================== - ; -HANDLMSG(MESSAGE) - write "Got: ["_MESSAGE_"]. Server is $JOB="_$J,! - quit - ; - ; Index: cprs/branches/tmg-cprs/m_files/TMGKERNL.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGKERNL.m.bak (revision 796) +++ (revision ) @@ -1,557 +1,0 @@ -TMGKERNL ;TMG/kst/OS Specific functions ;11/01/04 - ;;1.0;TMG-LIB;**1**;04/24/09 - - ;"TMG KERNEL FUNCTIONS - ;"I.e. functions that are OS specific. - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"$$Dos2Unix^TMGKERNL(FullNamePath) - ;"$$IsDir^TMGKERNL(Path) - ;"$$Move^TMGKERNL(Source,Dest) - ;"$$Copy^TMGKERNL(Source,Dest) - ;"$$Convert^TMGKERNL(FPathName,NewType) -- convert a graphic image to new type - ;"$$GetPckList(PckInit,Array,NeedsRefresh,PckDirFName) -- launch special linux script to get patch file list from ftp.va.gov - ;"$$DownloadFile^TMGKERNL(URL,DestDir) -- Interact with Linux to download a file with wget - ;"$$EditHFSFile^TMGKERNL(FilePathName) -- interact with Linux to edit a file on the host file system - ;"ZSAVE -- to save routine out to HFS - ;"MAKEBAKF^TMGKERNL(FilePathName,NodeDiv) ;Make Backup File if original exists - ;"$$GetScrnSize(ROWS,COLS) --query the OS and get the dimensions of the terminal window. - - ;"======================================================================= - ;"Dependancies - ;"======================================================================= - - ;"======================================================================= - -Dos2Unix(FullNamePath) - ;"Purpose: To execute the unix command Dos2Unix on filename path - ;"FullNamePath: The filename to act on. - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new result set result=0 - if $get(FullNamePath)="" goto DUDone - new spec set spec(" ")="\ " - set FullNamePath=$$REPLACE^XLFSTR(FullNamePath,.spec) - - new HookCmd set HookCmd="dos2unix -q "_FullNamePath - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - -DUDone - quit result - - - -IsDir(Path,NodeDiv) - ;"Purpose: To determine if Path is a path to a directory (i.e. are there sub files) - ;"Input: Path to test, e.g. "/home/user" or "/home/user/" - ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") - ;" if not supplied, then default value is "/" - ;"Result: 1 filepath is actually a directory - ;"Note: NEW! Will now return 1 if Path is a valid path to a directory, but there are no files in directory - - set Path=$get(Path) - set NodeDiv=$get(NodeDiv,"/") - if $extract(Path,$length(Path))'=NodeDiv set Path=Path_NodeDiv - - new p set p="myTerm" - open p:(COMMAND="stat --format=%F "_Path:readonly)::"pipe" - use p - new x read x - close p use $p - quit (x="directory") - - ;" ==== old code/method below (slower) === - ;"Old results - ;"Result: 1 if there are files in path, 0 otherwise - ;"Note: if Path is a valid path to a directory, but there are no files in directory, 0 returned. - - new TMGMask set TMGMask("*")="" - new TMGFiles - new result set result=0 - - new spec set spec(" ")="\ " - set Path=$$REPLACE^XLFSTR(Path,.spec) - - ;"Note: I can't seem to get this to work with names containing spaces. - if $$LIST^%ZISH(Path,"TMGMask","TMGFiles")=1 do - . new index set index=$order(TMGFiles("")) - . if index'="" set result=1 - - quit result - - -Move(Source,Dest) - ;"Purpose to provide a shell for the Linux command 'mv' - ;" This can serve to move or rename a file - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch - set Srch(" ")="\ " - set Source=$$REPLACE^XLFSTR(Source,.Srch) - set Dest=$$REPLACE^XLFSTR(Dest,.Srch) - set HookCmd="mv "_Source_" "_Dest - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - - -Copy(Source,Dest) - ;"Purpose to provide a shell for the Linux command 'cp' - ;" This can serve to move or rename a file - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch - set Srch(" ")="\ " - set Source=$$REPLACE^XLFSTR(Source,.Srch) - set Dest=$$REPLACE^XLFSTR(Dest,.Srch) - set HookCmd="cp "_Source_" "_Dest - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - -mkdir(Dir) - ;"Purpose to provide a shell for the Linux command 'mkdir' - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch set Srch(" ")="\ " - set Dir=$$REPLACE^XLFSTR(Dir,.Srch) - set HookCmd="mkdir "_Dir - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - -rmdir(Dir) - ;"Purpose to provide a shell for the Linux command 'rmdir' - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch set Srch(" ")="\ " - set Dir=$$REPLACE^XLFSTR(Dir,.Srch) - set HookCmd="rmdir "_Dir - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - - -Convert(FPathName,NewType) - ;"Purpose: to convert a graphic image on the linux host to new type - ;" i.e. image.jpg --> image.png. This is more than a simple renaming. - ;"Input: FPathName -- full path, filename and extention. E.g. "\tmp\image.jpg" - ;" NewType -- the new image type (without '.'), - ;" E.g. "jpg", or "JPG", or "TIFF", or "pcd" (NOT ".jpg" etc) - ;"Output: New FPathName (with new extension) to new image file, or "" if problem - ;" - ;"Note: If the conversion is successful, then the original image will be deleted - ;"Note: This function depends on the ImageMagick graphic utility "convert" to be - ;" installed on the host linux system, and in the path so that it can be - ;" launched from any directory. - - new newFPathName set newFPathName="" - set NewType=$get(NewType) - if NewType="" goto ConvDone - - new FName,FPath,FileSpec - do SplitFNamePath^TMGIOUTL(FPathName,.FPath,.FName,"/") - set FileSpec(FName)="" - - set newFPathName=$piece(FPathName,".",1)_"."_NewType - - ;"Setup and launch linux command to execute convert - new CmdStr - set CmdStr="convert "_FPathName_" "_newFPathName - do - . ;"new $ETRAP,$ZTRAP - . ;"set $ETRAP="S $ECODE=""""" - . zsystem CmdStr ;"Launch command - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 do goto ConvDone - . set newFPathName="" - - ;"Delete old image file - ;"**** temp!!!!! REMOVE COMMENTS LATER - ;"new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - -ConvDone - quit newFPathName - - -XLTLANG(Phrase,langPair) - ;"Purpose: To execute a linux OS call to convert a phrase into another - ;" spoken language - ;"Input: Phrase -- The text to be translated. - ;" LangPair -- a language pair (as allowed by Google translater) - ;" for now, tested pairs are: - ;" "en-es" -- english -> spanish - ;" "en-fr" -- english --> french - ;" "en-da" -- english --> ? - ;"Result: The translated text, or "" if error. - ;"Note: This depends on the "tw" package be installed in the host OS - ;" I got this on 7/11/08 from: http://savannah.nongnu.org/projects/twandgtw/ - ;"Note: This is not working for some reason..... - - new result set result="" - set langPair=$get(langPair,"en-es") - set Phrase=$get(Phrase,"?? Nothing Provided ??") - - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/TransLang.txt") - - ;"Setup and launch linux command to execute tw command - new CmdStr - set CmdStr="tw translate.google.com."_langPair_" """_Phrase_""" > """_msgFName_"""" - - ;"write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - ;"write "Back from zsystem",! - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 goto TLDone - - new FName,FPath - do SplitFNamePath^TMGIOUTL(msgFName,.FPath,.FName,"/") - new resultArray - if $$FTG^%ZISH(FPath,FName,"resultArray(0)",1)=0 goto TLDone - set result=$get(resultArray(0)) - -TLDone - quit result - - -TestTrans - set langPair=$get(langPair,"en-es") - set Phrase=$get(Phrase,"Hello friend") - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/TransLang.txt") - - new CmdStr - new qtChar set qtChar="'" - - set CmdStr="sh /var/local/OpenVistA_UserData/twlang.sh "_qtChar_langPair_qtChar_" "_qtChar_Phrase_qtChar_" "_msgFName - write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - write "Back from zsystem",! - - set qtChar="""" - set CmdStr="sh /var/local/OpenVistA_UserData/twlang.sh "_qtChar_langPair_qtChar_" "_qtChar_Phrase_qtChar_" "_msgFName - write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - write "Back from zsystem",! - - quit - - -GetPckList(PckInit,Array,NeedsRefresh,PckDirFName) - ;"Purpose: Call Linux, launching special script to get patch file list from ftp.va.gov - ;" This is a support function for automating the KIDS installation of patches. - ;"Input: PckInit -- this is the namespace of the package to get patches for, e.g. 'DI' for fileman - ;" Array -- PASS BY REFERENCE. An OUT parameter. Format: - ;" Array(0)=1st line - ;" Array(1)=2nd line etc. - ;" NeedsRefresh -- if 0 then no refresh needed, just set PckDirFName (but ensure file exists) - ;" PckDirFName -- Optional. PASS BY REFERNCE, an OUT PARAMETER. Filled with HFS filename of file - ;"Result : 1=success, 0=failure - - new result set result=1 ;"success - kill Array - if $get(PckInit)="" set result=0 goto GPLDone - - ;"Results will be stored in //ftp.va.gov-dirFor-'PckInit' - new FName,FPath - ;"Fix this.... check if path exists..... - set FPath=$get(^TMG("KIDS","PATCH DIR")) - if (FPath="")!($$IsDir^TMGKERNL(FPath)=0) do - . new Msg set Msg="Please choose a file path for storing VA patches in." - . set FPath=$$GetDirName^TMGIOUTL2(Msg,DefPath,"/","Pick directory") - if FPath="" set result=0 goto GPLDone - set FName="ftp.va.gov-dirFor-"_PckInit - set PckDirFName=FPath_FName - if ($get(NeedsRefresh)'>0)&($$FileExists^TMGIOUTL(PckDirFName)) goto GPLDone - - new FPScript set FPScript=$get(^TMG("KIDS","VA FTP Script")) - if (FPScript'=""),($$FileExists^TMGIOUTL(FPScript)=0) do - . kill ^TMG("KIDS","VA FTP Script") - . set FPScript="" - if FPScript="" do - . new msg set msg="Linux script needed: vaftp_launcher.sh\n" - . set msg=msg_"Please browse to this script and select it after the pause." - . set FPScript=$$GetFName^TMGIOUTL(msg,"/","vaftp_launcher.sh") - . if $$FileExists^TMGIOUTL(FPScript) do - . . set ^TMG("KIDS","VA FTP Script")=FPScript - . else do - . . write "ERROR: Choice of "_FPScript_" is invalid. Aborting." - . . set FPScript="" - if FPScript="" set result=0 goto GPLDone - - new CmdStr set CmdStr=FPScript_" "_PckInit_" "_FPath - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 do - . ;"Failed, so get log file instead of results - . set FName="ftp.va.gov_log" - . set result=1 ;"success - -GPL2 ;"Get results file (or log file if problem) - if $$FTG^%ZISH(FPath,FName,"Array(0)",1)=0 set result=0 goto GPLDone - -GPLDone - quit result - - -DownloadFile(URL,DestDir,Verbose) - ;"Purpose: Interact with Linux to download a file with wget - ;"Input: URL -- this is the URL of the file to be downloaded, as to be passed to wget - ;" if the server is an FTP server, then URL should start with 'ftp://' - ;" NOTE: the URL will be enclosed in " ", so it may contain spaces etc, - ;" but should NOT have escaped characters, i.e. "Not\ this" - ;" Exception "April Fool'\''s Day" is proper - ;" DestDir -- this is the destination directory, on the HFS, where file should be stored - ;" Verbose -- OPTIONAL. If 1, then output from wget is shown. Default is 0 - ;"result: 1 if success, 0 if failure - - ;"NOTE: This needs to be rewritten to use the vawget_launcher because wget it - ;" hanging when the file doesn't exist, and the process has to be aborted... - - new CmdStr,qFlag - ;"Setup and launch linux command to execute command - if +$get(Verbose) set qFlag="" - else set qFlag="-q " - set CmdStr="wget "_qFlag_"-P """_DestDir_""" """_URL_"""" - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) - new CmdResult set CmdResult=$ZSYSTEM&255 - new result set result=(CmdResult=0) - - quit result - - -EditHFSFile(FilePathName) - ;"Purpose: interact with Linux to edit a file on the host file system - ;"Input: FilePathName -- the full path of the file to edit. - ;"result: 1 if success, 0 if failure - - ;"Setup and launch linux command to execute command - new CmdStr set CmdStr="nano "_FilePathName - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) - new CmdResult set CmdResult=$ZSYSTEM&255 - new result set result=(CmdResult=0) - quit result - - -ZSAVE - ;"Purpose: to save routine out to HFS - ;"Input: globally scoped variable X should hold routine name - - ;"NOTE: this was moved out of ^DD("OS",19,"ZS") - ;"Original line there was (all three lines were one long line) - ;"N %I,%F,%S S %I=$I,%F=$P($P($ZRO,")"),"(",2)_"/"_X_".m" O %F:(NEWVERSION) - ;"U %F X "S %S=0 F S %S=$O(^UTILITY($J,0,%S)) Q:%S="""" Q:'$D(^(%S)) S %= - ;"^UTILITY($J,0,%S) I $E(%)'="";"" W %,!" C %F U %I - - ;"NOTE: The KIDS system seems to be using X ^%ZOSF("SAVE") instead of this. - - new %I,%F,%S - new % ;"//kt added -- not newing this caused problems in SAVE^DIKZ - set %I=$I - new %DIR set %DIR=$P($P($ZRO,")"),"(",2) - set %DIR=$piece(%DIR," ",$length(%DIR," ")) - set %F=%DIR_"/"_X_".m" - open %F:(NEWVERSION) - use %F - set %S=0 - for set %S=$O(^UTILITY($J,0,%S)) Q:%S="" Q:'$D(^(%S)) do - . set %=^UTILITY($J,0,%S) - . if $E(%)'=";" W %,! - close %F - use %I - - quit - - -MAKEBAKF(FilePathName,NodeDiv) ;"Make Backup File if original exists - ;"Purpose: to COPY existing File to File-ext_#.bak, creating a backup - ;" e.g. /tmp/dir1/FName.txt --> /tmp/dir1/FName-txt_1.bak - ;"Input: FilePathName -- the name, e.g. /tmp/dir1/filename.txt - ;" NodeDiv -- OPTIONAL. Default is "/" - ;" The node divider. "/" for unix, "\" for Microsoft - ;"results: none - ;"Note: This assumes that the HFS supports filenames like FName-txt_1.bak, - ;" and length file name is not limited (e.g. not old 8.3 DOS style) - ;" Also, if backup file, then number is incremented until a filename is found that doesn't exists - ;" e.g. /tmp/dir1/FName-txt_1.bak - ;" /tmp/dir1/FName-txt_2.bak - ;" /tmp/dir1/FName-txt_3.bak - - set NodeDiv=$get(NodeDiv,"/") - if $$FileExists^TMGIOUTL(FilePathName) do ;"backup file if it exists - . new count set count=0 - . new FName,FPath,done - . do SplitFNamePath^TMGIOUTL(FilePathName,.FPath,.FName,NodeDiv) - . for do quit:done - . . set count=count+1 - . . new bakName set bakName=FName_"_"_count - . . set bakName=FPath_$translate(bakName,".","-")_".bak" - . . if $$FileExists^TMGIOUTL(bakName) set done=0 quit - . . else do - . . . set done=1 - . . . if $$Copy(FilePathName,bakName) - - quit - -IOCapON - ;"Purpose: to redirect IO to a HFS file, so that it can be captured. - ;"NOTE: CAUTION: If this is called, and then a routine asks for user input, - ;" then the program will appear to hang, because the message asking - ;" for input has gone to the output channel. - - set TMGIOCAP=IO - set TMGIOCPT="/tmp/" - set TMGIOCFN="io-capture-"_$J_".txt" - set IO=TMGIOCPT_TMGIOCFN - open IO:(REWIND) - use IO - - quit - - -IOCapOFF(pOutArray) - ;"Purpose: To restore IO channel to that prior IOCapON was called, and return - ;" captured output in OutArray - ;"NOTE: MUST call IOCapON prior to calling this function - ;"Input: Globally-scoped TMGIOCAP is used. - ;" pOutArray -- PASS BY NAME, an OUT PARAMETER. Prior contents are killed. - ;"results: none - - close IO - if $get(TMGIOCAP)="" use $P goto IOCDone - set IO=TMGIOCAP - use IO - if $get(pOutArray)="" goto IOCDone - kill @pOutArray - - if ($get(TMGIOCPT)="")!($get(TMGIOCFN)="") goto IOCDone - if $$FTG^%ZISH(TMGIOCPT,TMGIOCFN,$name(@pOutArray@(0)),1) - new TMGA set TMGA(TMGIOCFN)="" - if $$DEL^%ZISH(TMGIOCPT,"TMGA") - -IOCDone quit - -KillPID(JobNum) - ;"Purpose: send message to MUPIP to kill Job - new CmdStr set CmdStr="mupip stop "_JobNum - zsystem CmdStr ;"Launch command in linux OS - ;"do PressToCont^TMGUSRIF - quit - -TEST - new array - new p set p="temp" - open p:(COMMAND="ps -C mumps":readonly)::"pipe" - use p - new lineIn - for do quit:($zeof) - . read lineIn - . new ch for do quit:(ch'=" ") - . . set ch=$extract(lineIn,1,1) - . . if ch=" " set lineIn=$extract(lineIn,2,40) - . if +lineIn=0 quit - . set array(+lineIn)=lineIn - close p - use $p - zwr array - quit - -MJOBS(array) - ;"Purpose: To execute a linux OS call to get list of all 'mumps' jobs - ;" using: 'ps -C mumps' - ;"Input: array -- PASS BY REFERNCE, an OUT PARAMETER. - ;"Output: array is filled as follows: (Prior data is killed) - ;" array(job#)=InfoLineFromOS - ;" array(job#)=InfoLineFromOS - ;" e.g. array(4483)=' 4883 pts/8 00:00:00 mumps' - ;" e.g. array(19308)='19308 ? 00:00:00 mumps' - ;" e.g. array(27454)='27454 pts/5 00:00:53 mumps' - ;"Result: none - - new p set p="temp" - open p:(COMMAND="ps -C mumps":readonly)::"pipe" - use p - new lineIn,ch - for do quit:($zeof) - . read lineIn - . for do quit:(ch'=" ") - . . set ch=$extract(lineIn,1,1) quit:(ch'=" ") - . . set lineIn=$extract(lineIn,2,40) - . if +lineIn=0 quit - . set array(+lineIn)=lineIn - close p - use $p - quit - - ;"====== old method below ============== - kill array - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/mjobslist.txt") - new CmdStr set CmdStr="ps -C mumps > """_msgFName_"""" - zsystem CmdStr ;"Launch command in linux OS - ; - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 goto MJDone - ; - new FName,FPath - do SplitFNamePath^TMGIOUTL(msgFName,.FPath,.FName,"/") - new resultArray - if $$FTG^%ZISH(FPath,FName,"resultArray(0)",1)=0 goto TLDone - ; - ;"Delete temp info file - new FileSpec set FileSpec(FName)="" - new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - ; - ;"Format resulting array - new i set i=0 - for set i=$order(resultArray(i)) quit:(i'>0) do - . new j set j=$extract(resultArray(i),1,5) - . new ch for do quit:(ch'=" ") - . . set ch=$extract(j,1,1) - . . if ch=" " set j=$extract(j,2,40) - . set array(+j)=resultArray(i) - ; -MJDone quit - - -GetScrnSize(ROWS,COLS) - ;"Purpose: To query the OS and get the dimensions of the terminal window - ;"Input: ROWS,COLS -- Optional. PASS BY REFERENCE. Filled with results - ;"Results: Row^Col e.g. '24^80', or '0^0' if problem. - ;"Note: thanks Bhaskar for figuring this out! - new p set p="myTerm" - open p:(COMMAND="stty -a -F "_$p_"|grep columns":readonly)::"pipe" - new x - for use p read x quit:($zeof)!(x["columns") - close p use $p - set COLS=+$piece(x,"columns ",2) - set ROWS=+$piece(x,"rows ",2) - quit ROWS_"^"_COLS Index: cprs/branches/tmg-cprs/m_files/TMGKERNL.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGKERNL.m~ (revision 796) +++ (revision ) @@ -1,557 +1,0 @@ -TMGKERNL ;TMG/kst/OS Specific functions ;11/01/04 - ;;1.0;TMG-LIB;**1**;04/24/09 - - ;"TMG KERNEL FUNCTIONS - ;"I.e. functions that are OS specific. - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"$$Dos2Unix^TMGKERNL(FullNamePath) - ;"$$IsDir^TMGKERNL(Path) - ;"$$Move^TMGKERNL(Source,Dest) - ;"$$Copy^TMGKERNL(Source,Dest) - ;"$$Convert^TMGKERNL(FPathName,NewType) -- convert a graphic image to new type - ;"$$GetPckList(PckInit,Array,NeedsRefresh,PckDirFName) -- launch special linux script to get patch file list from ftp.va.gov - ;"$$DownloadFile^TMGKERNL(URL,DestDir) -- Interact with Linux to download a file with wget - ;"$$EditHFSFile^TMGKERNL(FilePathName) -- interact with Linux to edit a file on the host file system - ;"ZSAVE -- to save routine out to HFS - ;"MAKEBAKF^TMGKERNL(FilePathName,NodeDiv) ;Make Backup File if original exists - ;"$$GetScrnSize(ROWS,COLS) --query the OS and get the dimensions of the terminal window. - - ;"======================================================================= - ;"Dependancies - ;"======================================================================= - - ;"======================================================================= - -Dos2Unix(FullNamePath) - ;"Purpose: To execute the unix command Dos2Unix on filename path - ;"FullNamePath: The filename to act on. - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new result set result=0 - if $get(FullNamePath)="" goto DUDone - new spec set spec(" ")="\ " - set FullNamePath=$$REPLACE^XLFSTR(FullNamePath,.spec) - - new HookCmd set HookCmd="dos2unix -q "_FullNamePath - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - -DUDone - quit result - - - -IsDir(Path,NodeDiv) - ;"Purpose: To determine if Path is a path to a directory (i.e. are there sub files) - ;"Input: Path to test, e.g. "/home/user" or "/home/user/" - ;" NodeDiv: [OPTIONAL] -- the character that separates folders (e.g. "/") - ;" if not supplied, then default value is "/" - ;"Result: 1 filepath is actually a directory - ;"Note: NEW! Will now return 1 if Path is a valid path to a directory, but there are no files in directory - - set Path=$get(Path) - set NodeDiv=$get(NodeDiv,"/") - if $extract(Path,$length(Path))'=NodeDiv set Path=Path_NodeDiv - - new p set p="myTerm" - open p:(COMMAND="stat --format=%F "_Path:readonly)::"pipe" - use p - new x read x - close p use $p - quit (x="directory") - - ;" ==== old code/method below (slower) === - ;"Old results - ;"Result: 1 if there are files in path, 0 otherwise - ;"Note: if Path is a valid path to a directory, but there are no files in directory, 0 returned. - - new TMGMask set TMGMask("*")="" - new TMGFiles - new result set result=0 - - new spec set spec(" ")="\ " - set Path=$$REPLACE^XLFSTR(Path,.spec) - - ;"Note: I can't seem to get this to work with names containing spaces. - if $$LIST^%ZISH(Path,"TMGMask","TMGFiles")=1 do - . new index set index=$order(TMGFiles("")) - . if index'="" set result=1 - - quit result - - -Move(Source,Dest) - ;"Purpose to provide a shell for the Linux command 'mv' - ;" This can serve to move or rename a file - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch - set Srch(" ")="\ " - set Source=$$REPLACE^XLFSTR(Source,.Srch) - set Dest=$$REPLACE^XLFSTR(Dest,.Srch) - set HookCmd="mv "_Source_" "_Dest - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - - -Copy(Source,Dest) - ;"Purpose to provide a shell for the Linux command 'cp' - ;" This can serve to move or rename a file - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch - set Srch(" ")="\ " - set Source=$$REPLACE^XLFSTR(Source,.Srch) - set Dest=$$REPLACE^XLFSTR(Dest,.Srch) - set HookCmd="cp "_Source_" "_Dest - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - -mkdir(Dir) - ;"Purpose to provide a shell for the Linux command 'mkdir' - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch set Srch(" ")="\ " - set Dir=$$REPLACE^XLFSTR(Dir,.Srch) - set HookCmd="mkdir "_Dir - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - -rmdir(Dir) - ;"Purpose to provide a shell for the Linux command 'rmdir' - ;"Note: a platform independant version of the this could be constructed later... - ;"Result: 0 if no error; >0 if error - ;"Notice!!!! The return code here is DIFFERENT from usual - - new HookCmd,result - new Srch set Srch(" ")="\ " - set Dir=$$REPLACE^XLFSTR(Dir,.Srch) - set HookCmd="rmdir "_Dir - zsystem HookCmd - set result=$ZSYSTEM&255 ;"get result of execution. (low byte only) - quit result - - -Convert(FPathName,NewType) - ;"Purpose: to convert a graphic image on the linux host to new type - ;" i.e. image.jpg --> image.png. This is more than a simple renaming. - ;"Input: FPathName -- full path, filename and extention. E.g. "\tmp\image.jpg" - ;" NewType -- the new image type (without '.'), - ;" E.g. "jpg", or "JPG", or "TIFF", or "pcd" (NOT ".jpg" etc) - ;"Output: New FPathName (with new extension) to new image file, or "" if problem - ;" - ;"Note: If the conversion is successful, then the original image will be deleted - ;"Note: This function depends on the ImageMagick graphic utility "convert" to be - ;" installed on the host linux system, and in the path so that it can be - ;" launched from any directory. - - new newFPathName set newFPathName="" - set NewType=$get(NewType) - if NewType="" goto ConvDone - - new FName,FPath,FileSpec - do SplitFNamePath^TMGIOUTL(FPathName,.FPath,.FName,"/") - set FileSpec(FName)="" - - set newFPathName=$piece(FPathName,".",1)_"."_NewType - - ;"Setup and launch linux command to execute convert - new CmdStr - set CmdStr="convert "_FPathName_" "_newFPathName - do - . ;"new $ETRAP,$ZTRAP - . ;"set $ETRAP="S $ECODE=""""" - . zsystem CmdStr ;"Launch command - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 do goto ConvDone - . set newFPathName="" - - ;"Delete old image file - ;"**** temp!!!!! REMOVE COMMENTS LATER - ;"new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - -ConvDone - quit newFPathName - - -XLTLANG(Phrase,langPair) - ;"Purpose: To execute a linux OS call to convert a phrase into another - ;" spoken language - ;"Input: Phrase -- The text to be translated. - ;" LangPair -- a language pair (as allowed by Google translater) - ;" for now, tested pairs are: - ;" "en-es" -- english -> spanish - ;" "en-fr" -- english --> french - ;" "en-da" -- english --> ? - ;"Result: The translated text, or "" if error. - ;"Note: This depends on the "tw" package be installed in the host OS - ;" I got this on 7/11/08 from: http://savannah.nongnu.org/projects/twandgtw/ - ;"Note: This is not working for some reason..... - - new result set result="" - set langPair=$get(langPair,"en-es") - set Phrase=$get(Phrase,"?? Nothing Provided ??") - - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/TransLang.txt") - - ;"Setup and launch linux command to execute tw command - new CmdStr - set CmdStr="tw translate.google.com."_langPair_" """_Phrase_""" > """_msgFName_"""" - - ;"write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - ;"write "Back from zsystem",! - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 goto TLDone - - new FName,FPath - do SplitFNamePath^TMGIOUTL(msgFName,.FPath,.FName,"/") - new resultArray - if $$FTG^%ZISH(FPath,FName,"resultArray(0)",1)=0 goto TLDone - set result=$get(resultArray(0)) - -TLDone - quit result - - -TestTrans - set langPair=$get(langPair,"en-es") - set Phrase=$get(Phrase,"Hello friend") - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/TransLang.txt") - - new CmdStr - new qtChar set qtChar="'" - - set CmdStr="sh /var/local/OpenVistA_UserData/twlang.sh "_qtChar_langPair_qtChar_" "_qtChar_Phrase_qtChar_" "_msgFName - write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - write "Back from zsystem",! - - set qtChar="""" - set CmdStr="sh /var/local/OpenVistA_UserData/twlang.sh "_qtChar_langPair_qtChar_" "_qtChar_Phrase_qtChar_" "_msgFName - write "About to execute zsystem command:",!,CmdStr,! - zsystem CmdStr ;"Launch command in linux OS - write "Back from zsystem",! - - quit - - -GetPckList(PckInit,Array,NeedsRefresh,PckDirFName) - ;"Purpose: Call Linux, launching special script to get patch file list from ftp.va.gov - ;" This is a support function for automating the KIDS installation of patches. - ;"Input: PckInit -- this is the namespace of the package to get patches for, e.g. 'DI' for fileman - ;" Array -- PASS BY REFERENCE. An OUT parameter. Format: - ;" Array(0)=1st line - ;" Array(1)=2nd line etc. - ;" NeedsRefresh -- if 0 then no refresh needed, just set PckDirFName (but ensure file exists) - ;" PckDirFName -- Optional. PASS BY REFERNCE, an OUT PARAMETER. Filled with HFS filename of file - ;"Result : 1=success, 0=failure - - new result set result=1 ;"success - kill Array - if $get(PckInit)="" set result=0 goto GPLDone - - ;"Results will be stored in //ftp.va.gov-dirFor-'PckInit' - new FName,FPath - ;"Fix this.... check if path exists..... - set FPath=$get(^TMG("KIDS","PATCH DIR")) - if (FPath="")!($$IsDir^TMGKERNL(FPath)=0) do - . new Msg set Msg="Please choose a file path for storing VA patches in." - . set FPath=$$GetDirName^TMGIOUTL2(Msg,DefPath,"/","Pick directory") - if FPath="" set result=0 goto GPLDone - set FName="ftp.va.gov-dirFor-"_PckInit - set PckDirFName=FPath_FName - if ($get(NeedsRefresh)'>0)&($$FileExists^TMGIOUTL(PckDirFName)) goto GPLDone - - new FPScript set FPScript=$get(^TMG("KIDS","VA FTP Script")) - if (FPScript'=""),($$FileExists^TMGIOUTL(FPScript)=0) do - . kill ^TMG("KIDS","VA FTP Script") - . set FPScript="" - if FPScript="" do - . new msg set msg="Linux script needed: vaftp_launcher.sh\n" - . set msg=msg_"Please browse to this script and select it after the pause." - . set FPScript=$$GetFName^TMGIOUTL(msg,"/","vaftp_launcher.sh") - . if $$FileExists^TMGIOUTL(FPScript) do - . . set ^TMG("KIDS","VA FTP Script")=FPScript - . else do - . . write "ERROR: Choice of "_FPScript_" is invalid. Aborting." - . . set FPScript="" - if FPScript="" set result=0 goto GPLDone - - new CmdStr set CmdStr=FPScript_" "_PckInit_" "_FPath - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 do - . ;"Failed, so get log file instead of results - . set FName="ftp.va.gov_log" - . set result=1 ;"success - -GPL2 ;"Get results file (or log file if problem) - if $$FTG^%ZISH(FPath,FName,"Array(0)",1)=0 set result=0 goto GPLDone - -GPLDone - quit result - - -DownloadFile(URL,DestDir,Verbose) - ;"Purpose: Interact with Linux to download a file with wget - ;"Input: URL -- this is the URL of the file to be downloaded, as to be passed to wget - ;" if the server is an FTP server, then URL should start with 'ftp://' - ;" NOTE: the URL will be enclosed in " ", so it may contain spaces etc, - ;" but should NOT have escaped characters, i.e. "Not\ this" - ;" Exception "April Fool'\''s Day" is proper - ;" DestDir -- this is the destination directory, on the HFS, where file should be stored - ;" Verbose -- OPTIONAL. If 1, then output from wget is shown. Default is 0 - ;"result: 1 if success, 0 if failure - - ;"NOTE: This needs to be rewritten to use the vawget_launcher because wget it - ;" hanging when the file doesn't exist, and the process has to be aborted... - - new CmdStr,qFlag - ;"Setup and launch linux command to execute command - if +$get(Verbose) set qFlag="" - else set qFlag="-q " - set CmdStr="wget "_qFlag_"-P """_DestDir_""" """_URL_"""" - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) - new CmdResult set CmdResult=$ZSYSTEM&255 - new result set result=(CmdResult=0) - - quit result - - -EditHFSFile(FilePathName) - ;"Purpose: interact with Linux to edit a file on the host file system - ;"Input: FilePathName -- the full path of the file to edit. - ;"result: 1 if success, 0 if failure - - ;"Setup and launch linux command to execute command - new CmdStr set CmdStr="nano "_FilePathName - zsystem CmdStr ;"Launch command in linux OS - - ;"get result of execution. (low byte only) - new CmdResult set CmdResult=$ZSYSTEM&255 - new result set result=(CmdResult=0) - quit result - - -ZSAVE - ;"Purpose: to save routine out to HFS - ;"Input: globally scoped variable X should hold routine name - - ;"NOTE: this was moved out of ^DD("OS",19,"ZS") - ;"Original line there was (all three lines were one long line) - ;"N %I,%F,%S S %I=$I,%F=$P($P($ZRO,")"),"(",2)_"/"_X_".m" O %F:(NEWVERSION) - ;"U %F X "S %S=0 F S %S=$O(^UTILITY($J,0,%S)) Q:%S="""" Q:'$D(^(%S)) S %= - ;"^UTILITY($J,0,%S) I $E(%)'="";"" W %,!" C %F U %I - - ;"NOTE: The KIDS system seems to be using X ^%ZOSF("SAVE") instead of this. - - new %I,%F,%S - new % ;"//kt added -- not newing this caused problems in SAVE^DIKZ - set %I=$I - new %DIR set %DIR=$P($P($ZRO,")"),"(",2) - set %DIR=$piece(%DIR," ",$length(%DIR," ")) - set %F=%DIR_"/"_X_".m" - open %F:(NEWVERSION) - use %F - set %S=0 - for set %S=$O(^UTILITY($J,0,%S)) Q:%S="" Q:'$D(^(%S)) do - . set %=^UTILITY($J,0,%S) - . if $E(%)'=";" W %,! - close %F - use %I - - quit - - -MAKEBAKF(FilePathName,NodeDiv) ;"Make Backup File if original exists - ;"Purpose: to COPY existing File to File-ext_#.bak, creating a backup - ;" e.g. /tmp/dir1/FName.txt --> /tmp/dir1/FName-txt_1.bak - ;"Input: FilePathName -- the name, e.g. /tmp/dir1/filename.txt - ;" NodeDiv -- OPTIONAL. Default is "/" - ;" The node divider. "/" for unix, "\" for Microsoft - ;"results: none - ;"Note: This assumes that the HFS supports filenames like FName-txt_1.bak, - ;" and length file name is not limited (e.g. not old 8.3 DOS style) - ;" Also, if backup file, then number is incremented until a filename is found that doesn't exists - ;" e.g. /tmp/dir1/FName-txt_1.bak - ;" /tmp/dir1/FName-txt_2.bak - ;" /tmp/dir1/FName-txt_3.bak - - set NodeDiv=$get(NodeDiv,"/") - if $$FileExists^TMGIOUTL(FilePathName) do ;"backup file if it exists - . new count set count=0 - . new FName,FPath,done - . do SplitFNamePath^TMGIOUTL(FilePathName,.FPath,.FName,NodeDiv) - . for do quit:done - . . set count=count+1 - . . new bakName set bakName=FName_"_"_count - . . set bakName=FPath_$translate(bakName,".","-")_".bak" - . . if $$FileExists^TMGIOUTL(bakName) set done=0 quit - . . else do - . . . set done=1 - . . . if $$Copy(FilePathName,bakName) - - quit - -IOCapON - ;"Purpose: to redirect IO to a HFS file, so that it can be captured. - ;"NOTE: CAUTION: If this is called, and then a routine asks for user input, - ;" then the program will appear to hang, because the message asking - ;" for input has gone to the output channel. - - set TMGIOCAP=IO - set TMGIOCPT="/tmp/" - set TMGIOCFN="io-capture-"_$J_".txt" - set IO=TMGIOCPT_TMGIOCFN - open IO:(REWIND) - use IO - - quit - - -IOCapOFF(pOutArray) - ;"Purpose: To restore IO channel to that prior IOCapON was called, and return - ;" captured output in OutArray - ;"NOTE: MUST call IOCapON prior to calling this function - ;"Input: Globally-scoped TMGIOCAP is used. - ;" pOutArray -- PASS BY NAME, an OUT PARAMETER. Prior contents are killed. - ;"results: none - - close IO - if $get(TMGIOCAP)="" use $P goto IOCDone - set IO=TMGIOCAP - use IO - if $get(pOutArray)="" goto IOCDone - kill @pOutArray - - if ($get(TMGIOCPT)="")!($get(TMGIOCFN)="") goto IOCDone - if $$FTG^%ZISH(TMGIOCPT,TMGIOCFN,$name(@pOutArray@(0)),1) - new TMGA set TMGA(TMGIOCFN)="" - if $$DEL^%ZISH(TMGIOCPT,"TMGA") - -IOCDone quit - -KillPID(JobNum) - ;"Purpose: send message to MUPIP to kill Job - new CmdStr set CmdStr="mupip stop "_JobNum - zsystem CmdStr ;"Launch command in linux OS - ;"do PressToCont^TMGUSRIF - quit - -TEST - new array - new p set p="temp" - open p:(COMMAND="ps -C mumps":readonly)::"pipe" - use p - new lineIn - for do quit:($zeof) - . read lineIn - . new ch for do quit:(ch'=" ") - . . set ch=$extract(lineIn,1,1) - . . if ch=" " set lineIn=$extract(lineIn,2,40) - . if +lineIn=0 quit - . set array(+lineIn)=lineIn - close p - use $p - zwr array - quit - -MJOBS(array) - ;"Purpose: To execute a linux OS call to get list of all 'mumps' jobs - ;" using: 'ps -C mumps' - ;"Input: array -- PASS BY REFERNCE, an OUT PARAMETER. - ;"Output: array is filled as follows: (Prior data is killed) - ;" array(job#)=InfoLineFromOS - ;" array(job#)=InfoLineFromOS - ;" e.g. array(4483)=' 4883 pts/8 00:00:00 mumps' - ;" e.g. array(19308)='19308 ? 00:00:00 mumps' - ;" e.g. array(27454)='27454 pts/5 00:00:53 mumps' - ;"Result: none - - new p set p="temp" - open p:(COMMAND="ps -C mumps":readonly)::"pipe" - use p - new lineIn,ch - for do quit:($zeof) - . read lineIn - . for do quit:(ch'=" ") - . . set ch=$extract(lineIn,1,1) quit:(ch'=" ") - . . set lineIn=$extract(lineIn,2,40) - . if +lineIn=0 quit - . set array(+lineIn)=lineIn - close p - use $p - quit - - ;"====== old method below ============== - kill array - new msgFName set msgFName=$$UNIQUE^%ZISUTL("/tmp/mjobslist.txt") - new CmdStr set CmdStr="ps -C mumps > """_msgFName_"""" - zsystem CmdStr ;"Launch command in linux OS - ; - ;"get result of execution. (low byte only) -- if wanted - new CmdResult set CmdResult=$ZSYSTEM&255 - if CmdResult'=0 goto MJDone - ; - new FName,FPath - do SplitFNamePath^TMGIOUTL(msgFName,.FPath,.FName,"/") - new resultArray - if $$FTG^%ZISH(FPath,FName,"resultArray(0)",1)=0 goto TLDone - ; - ;"Delete temp info file - new FileSpec set FileSpec(FName)="" - new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - ; - ;"Format resulting array - new i set i=0 - for set i=$order(resultArray(i)) quit:(i'>0) do - . new j set j=$extract(resultArray(i),1,5) - . new ch for do quit:(ch'=" ") - . . set ch=$extract(j,1,1) - . . if ch=" " set j=$extract(j,2,40) - . set array(+j)=resultArray(i) - ; -MJDone quit - - -GetScrnSize(ROWS,COLS) - ;"Purpose: To query the OS and get the dimensions of the terminal window - ;"Input: ROWS,COLS -- Optional. PASS BY REFERENCE. Filled with results - ;"Results: Row^Col e.g. '24^80', or '0^0' if problem. - ;"Note: thanks Bhaskar for figuring this out! - new p set p="myTerm" - open p:(COMMAND="stty -a -F "_$p_"|grep columns":readonly)::"pipe" - new x - for use p read x quit:($zeof)!(x["columns") - close p use $p - set COLS=+$piece(x,"columns ",2) - set ROWS=+$piece(x,"rows ",2) - quit ROWS_"^"_COLS Index: cprs/branches/tmg-cprs/m_files/TMGMISC.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGMISC.m~ (revision 796) +++ (revision ) @@ -1,2271 +1,0 @@ -TMGMISC ;TMG/kst/Misc utility library ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - ;"TMG MISCELLANEOUS FUNCTIONS - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"STARTRPC -- Start up RPCBroker on port 9210 - ;"STOPRPC -- Stop RPCBroker on port 9210 - ;"STOPTSKM -- Stop TaskMan non-interactively - ;"EDITPT(AddOK) - ;"GetPersonClass(PersonClass,ProviderType,Specialty) - ;"$$DocLines(IEN,Chars) -- Count number of lines and chars in a 8925 WP field - ;"$$WPChars(Ptr) - ;"$$RoundUp(n) - ;"$$RoundDn(n) - ;"$$Round(n) - ;"$$InList(Value,ArrayP) -- return if Value is in an array. - ;"$$ListCt(pArray) - ;"$$NodeCt(pArray) -- count all the nodes in an array - ;"$$IndexOf(pArray,value) - ;"ListPack(pArray,StartNum,IncValue) - ;"ListAdd(pArray,index,value) - ;"ListAnd(pArray1,pArray2,pResult) - ;"ListNot(pArray1,pArray2,pResult) - ;"$$DTFormat(FMDate,format) -- format fileman dates - ;"$$CompDOB(DOB1,DOB2) -- compare two dates - ;"BrowseBy(CompArray,ByTag) -- Allow a user to interact with dynamic text tree - ;"$$CompName(Name1,Name2) -- compare two names - ;"$$FormatName(Name) - ;"$$HEXCHR(V) -- Take one BYTE and return HEX Values - ;"$$HEXCHR2(n,digits) -- convert a number (of arbitrary length) to HEX digits - ;"$$HEX2NUM(s) -- convert a string like this $10 to decimal number (e.g.) 16 - ;"$$OR(a,b) ; perform a bitwise OR on operands a and b - ;"ParsePos(pos,label,offset,routine,dmod) - ;"ScanMod(Module,pArray) - ;"ConvertPos(Pos,pArray) - ;"CompArray(pArray1,pArray2) return if two arrays are identical - ;"$$CompABArray(pArrayA,pArrayB,pOutArray) -- FULL compare of two arrays, return diffArray - ;"$$IterTemplate(Template,Prior) - ;"$$NumPieces(s,delim,maxPoss) -- return number of pieces in string - ;"$$LastPiece(s,delim,maxPoss) -- return the last piece of a string - ;"$$ParseLast(s,remainS,delim,maxPoss) -- return the last piece AND the first part of the string - ;"$$Trim1Node(pRef) -- To shorten a reference by one node. - ;"BROWSEASK -- ask user for the name of an array, then display nodes - ;"BRWSASK2 -- Improved... Ask user for the name of an array, then display nodes - ;"BROWSENODES(current,Order,paginate,countNodes) -- display nodes of specified array - ;"BRWSNOD2(curRef,Order,countNodes) -- display nodes of specified array, using Scroll box - ;"ShowNodes(pArray,order,paginate,countNodes) -- display all the nodes of the given array - ;"ShowNod2(pArray,order,countNodes) -- display all the nodes of the given array, using Scroll box - ;"$$IsNumeric(value) -- determine if value is pure numeric. - ;"$$ClipDDigits(Num,digits) -- clip number to specified number of digits - ;"LaunchScreenman(File,FormIEN,RecIEN,Page) -- launching point screenman form - ;"$$NumSigChs --determine how many characters are signficant in a variable name - ;"MkMultList(input,List) -- create a list of entries, given a string containing a list of entries. - ;"MkRangeList(Num,EndNum,List) -- create a list of entries, given a starting and ending number - ;"$$Caller(Code) -- From call stack, return the location of the caller of the function - - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"GetPersonClass(PersonClass,ProviderType,Specialty) - ;"ProcessToken(Token,Output) - ;"$$IsSuffix(s) - ;"$$IsTitle(s) - ;"ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) - ;"CtTemplate(Template) -- return the Count of IEN's stored in a SORT TEMPLATE - - ;"======================================================================= - ;"DEPENDENCIES - ;" TMGDBAPI - ;" TMGIOUTL - ;" TMGDEBUG - ;" TMGSTUTL - ;"======================================================================= - ;"======================================================================= - -STARTRPC ; - ;" -- Start up RPCBroker on port 9210 - WRITE "Starting RPC Broker on port 9210",! - DO STRT^XWBTCP(9210) - WRITE ! - QUIT - ; -STOPRPC ; - ;" -- Stop RPC Broker on port 9210 - WRITE "Stopping RPC Broker on port 9210",! - DO STOP^XWBTCP(9210) - WRITE ! - QUIT - ; -STOPTSKM ; - ;"-- Shut Down Task Managers non-interactively - ;" Taken from STOP^ZTMKU - ; - WRITE !,"Shutting down TaskMan and submanagers." - DO GROUP^ZTMKU("SMAN^ZTMKU(NODE)") - DO GROUP^ZTMKU("SSUB^ZTMKU(NODE)") - WRITE !,"Okay!",! - QUIT - ; -EDITPT(TMGADDOK) - ;"Purpose: To ask for a patient name, and then allow editing - ;"Input: TMGADDOK: if 1, then adding new patients is allowed - ;"Result: none - ; - DO LO^DGUTL - SET DGCLPR="" - NEW DGDIV SET DGDIV=$$PRIM^VASITE - ; - IF DGDIV>0 SET %ZIS("B")=$PIECE($get(^DG(40.8,+DGDIV,"DEV")),U,1) - ; - KILL %ZIS("B") - IF '$data(DGIO),$PIECE(^DG(43,1,0),U,30) do - . SET %ZIS="N",IOP="HOME" - . DO ^%ZIS - ; -A DO ENDREG^DGREG($GET(DFN)) - DO IF (Y<0) GOTO EDITDONE - . WRITE !! - . IF $GET(TMGADDOK)=1 DO - . . SET DIC=2,DIC(0)="ALEQM" - . . SET DLAYGO=2 - . ELSE DO - . . SET DIC=2,DIC(0)="AEQM" - . . SET DLAYGO=0 - . KILL DIC("S") - . DO ^DIC - . KILL DLAYGO - . IF Y<0 QUIT - . SET (DFN,DA)=+Y - . SET DGNEW=$P(Y,"^",3) - . NEW Y - . DO PAUSE^DG10 - . DO BEGINREG^DGREG(DFN) - . IF DGNEW DO NEW^DGRP - ; - IF +$GET(DGNEW) DO - . ;" query CMOR for Patient Record Flag Assignments if NEW patient and - . ;" display results. - . IF $$PRFQRY^DGPFAPI(DFN) DO DISPPRF^DGPFAPI(DFN) - ; - SET (DGFC,CURR)=0 - SET DA=DFN - SET DGFC="^1" - SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0) - ; - SET %ZIS="N",IOP="HOME" - DO ^%ZIS - SET DGELVER=0 - ;"DO EN^DGRPD - ;"IF $data(DGRPOUT) DO GOTO A - ;". DO ENDREG^DGREG($G(DFN)) - ;". DO HL7A08^VAFCDD01 - ;". KILL DFN,DGRPOUT - ; - ;"DO HINQ^DG10 - IF $D(^DIC(195.4,1,"UP")) IF ^("UP") DO ADM^RTQ3 - ; - DO REG^IVMCQ($G(DFN)) ;" send financial query - ; - SET DGRPV=0 - DO EN1^DGRP - ; -EDITDONE - IF $PIECE($GET(^VA(200,DUZ,"TMG")),"^",1)="C" DO - . WRITE @IOF,! ;"clear screen if settings call for this. - ; - QUIT - - -GetPersonClass(PersonClass,ProviderType,Specialty) - ;"Purpose: To look through the PERSON CLASS file and find matching record - ;"Input -- PersonClass -- a value to match against the .01 field (PROVIDER TYPE) - ;" Behavioral Health and Social Service - ;" Chiropractors - ;" Dental Service - ;" Dietary and Nutritional Service - ;" Emergency Medical Service - ;" Eye and Vision Services - ;" Nursing Service - ;" Nursing Service Related - ;" Physicians (M.D. and D.O.) - ;" etc. - ;" -- ProviderType -- a value to match against the 1 field (CLASSIFICATION) - ;" Physician/Osteopath - ;" Resident, Allopathic (includes Interns, Residents, Fellows) - ;" Psychologist - ;" Neuropsychologist - ;" etc. - ;" -- Specialty -- a value to match against the 2 field (AREA OF SPECIALIZATION) - ;"Output -- (via results) - ;"Result -- Returns record number in PERSON CLASS file, OR 0 if not found - - new RecNum,Params - - set Params(0,"FILE")="PERSON CLASS" - set Params(".01")=$get(PersonClass) - set Params("1")=$get(ProviderType) - set Params("2")=$get(Specialty) - - set RecNum=$$RecFind^TMGDBAPI(.Params) - -GPCDone - quit RecNum - - -DocLines(IEN,Chars) - ;"Purpose: To count the number of lines and characters in a WP field - ;" Initially it is targeted at entries in TIU DOCUMENT file. - ;"Input: IEN -- the record number in TIU DOCUMENT to count - ;" Chars -- and OUT parameter. PASS BY REFERENCE - ;"Results: Returns number of lines, (with 1 decimal value) - ;" Also will return character count in Chars, if passed by reference - ;"NOte: This uses the Characters per line parameter value stored in - ;" field .03 of TIU PARAMETERS (in ^TIU(8925.99)) - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") - - new CharsPerLine - new LineCount set LineCount=0 - set Chars=0 - set CharsPerLine=+$piece($get(^TIU(8925.99,1,0)),"^",3) - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"CharsPerLine=",CharsPerLine) - - set WPPtr=$name(^TIU(8925,IEN,"TEXT")) - set Chars=$$WPChars(WPPtr) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Chars=",Chars) - - if CharsPerLine'=0 do - . set LineCount=(((Chars/CharsPerLine)*10)\1)/10 - . ;"new IntLC,LC,Delta - . ;"set LC=Chars\CharsPerLine - . ;"set IntLC=Chars\CharsPerLine ;" \ is integer divide - . ;"set Delta=(LC-IntLC)*10 - . i;"f Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. - . ;"set LineCount=IntLC - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"LineCount=",LineCount) - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"DocLines^TMGMISC") - quit LineCount - - -WPChars(Ptr) - ;"Purpose: To count the number of characters in the WP field - ;" pointed to by the name stored in Ptr - ;"Results: Returns number of characters, including spaces - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") - - new index - new Chars set Chars=0 - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Ptr=",Ptr) - set index=$order(@Ptr@(0)) - for do quit:(index="") - . if index="" quit - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index='",index,"'") - . ;"new s set s=$get(@Ptr@(index,0)) write "s=",s,! - . set Chars=Chars+$length($get(@Ptr@(index,0))) - . set index=$order(@Ptr@(index)) - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WPChars^TMGMISC") - - quit Chars - - - -RoundUp(n) - ;"SCOPE: PUBLIC - ;"Purpose: find the next greatest integer after decimal value of n (round up) - ;" 1.1 --> 2 - ;" 1.0 --> 1 - ;" -2.8 --> 2 - ;"input: n -- decimal or integer value - ;"output an integer, rounded up. - - new result - set result=n\1 - if result 1 - ;" -2.2 --> -2 - ;"input: n -- decimal or integer value - ;"output an integer, rounded down. - - new result - set result=n\1 - quit result - -Round(n) - ;"SCOPE: PUBLIC - ;"Purpose: find the nearest integer from decimal value of n - ;" for values 0.0-0.49 --> 0 - ;" for values 0.5-0.99 --> 1 - ;"input: n -- decimal or integer value - ;"output an integer, rounded to nearest integer - - new result set result=n - new decimal - - set decimal=+(n-(n\1)) - if decimal<0.5 do - . set result=$$RoundDn(n) - else do - . set result=$$RoundUp(n) - - quit result - - -InList(Value,ArrayP) - ;"SCOPE: PUBLIC - ;"Purpose: To return if Value is in an array. Match must be exact (i.e. '=') - ;"Input: Value -- the value to test for. Should not be an array - ;" ArrayP -- the name of the array. e.g. ArrayP="MyArray(""Title"")" - ;"Format of Array: It may be in one of two possible formats: - ;" 1. MyArray("Title")=Value, or - ;" 2. MyArray("Title")="*" <-- a signal that multiple values are given - ;" MyArray("Title",1)=Value1 - ;" MyArray("Title",2)=Value2 - ;" The '1','2', etc may anything - ;"Results: 1 if Value is in list, 0 if not - - new result set result=0 - new index - if ($get(ArrayP)'="")&($data(Value)=1) do - . if @ArrayP'="*" set result=(@ArrayP=$get(Value)) quit - . set index=$order(@ArrayP@("")) quit:(index="") - . for do quit:(index="")!(result=1) - . . if @ArrayP@(index)=Value set result=1 quit - . . set index=$order(@ArrayP@(index)) - -ILDone - quit result - - - ;"IndexOf(pArray,value) - ;" ;"SCOPE: PUBLIC - ;" ;"Purpose: To scan array and return first index holding value - ;" ;"Input: pArray -- PASS BY NAME. Array to scan, in format like this: - ;" ;" @pArray@(1)=value1 - ;" ;" @pArray@(2)=value2 - ;" ;" @pArray@(3)=value3 - ;" ;" @pArray@("some name index 1")=value4 - ;" ;" @pArray@("some name index 2")=value5 - ;" ;" value -- the value to search for - ;" ;"results: returns the index holding the value - ;" - ;" new result set result="" - ;" new done set done=0 - ;" new index set index="" - ;" for set index=$order(@pArray@(index)) quit:(index="")!(done=1) do - ;" . set done=($get(@pArray@(index))=value) - ;" . if done set result=index - ;" - ;"IODone quit result - - -ListCt(pArray) - ;"SCOPE: PUBLIC - ;"Purpose: to count the number of entries in an array - ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. - ;"Output: the number of entries at highest level - ;" e.g. Array("TELEPHONE")=1234 - ;" Array("CAR")=4764 - ;" Array("DOG")=5213 - ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. - ;" The above array would have a count of 3 - ;"Results: returns count, or count up to point of any error - new i,result set result=0 - - do - . new $etrap - . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" - . set i=$order(@pArray@("")) - . if i="" quit - . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" - - quit result - -NodeCt(pArray) - ;"SCOPE: PUBLIC - ;"Purpose: to count all the nodes in an array - ;"Input: pArray -- PASS BY NAME. pointer to (name of) array to test. - ;"Output: the number of entries at highest level - ;" e.g. Array("TELEPHONE")=1234 - ;" Array("CAR")=4764 - ;" Array("DOG")=5213 - ;" Array("DOG","COLLAR")=5213 <-- IS counted - ;" The above array would have a count of 4 - ;"Results: returns count, or count up to point of any error - new result set result=0 - for set pArray=$query(@pArray),result=result+1 quit:(pArray="") - quit result - -IndexOf(pArray,value) - ;"SCOPE: PUBLIC: - ;"Purpose: To search through an array of keys and values, and return 1st index (i.e. key) of value - ;"Input: pArray -- NAME OF array to search, format: - ;" @pArray@(key1)=value1 - ;" @pArray@(key2)=value2 - ;" @pArray@(key3)=value3 - ;" value -- the value to search for - ;"Results: will return key for first found (based on $order sequence),or "" if not found - - new result set result="" - new i set i="" - new done set done=0 - for set i=$order(@pArray@(i)) quit:(i="")!(done=1) do - . if $get(@pArray@(i))=value set result=i,done=1 - - quit result - -ListPack(pArray,StartNum,IncValue) - ;"SCOPE: PUBLIC - ;"Purpose: to take an array with numeric ordering and pack values. - ;" e.g. Array(3)="dog" - ;" Array(5)="cat" - ;" Array(75)="goat" - ;" Will be pack as follows: - ;" Array(1)="dog" - ;" Array(2)="cat" - ;" Array(3)="goat" - ;"Input: pArray -- pointer to (NAME OF) array to pack. - ;" StartNum -- OPTIONAL, default=1. Value to start numbering at - ;" IncValue -- OPTIONAL, default=1. Amount to add to index value each time - ;"Output: array will be altered - ;"Results: none. - ;"Notes: It is assumed that all of the indices are numeric - ;" Nodes that are ALPHA (non-numeric) will be KILLED!! - ;" If nodes have subnodes, they will be preserved. - - new TMGlpArray - new i - new count set count=$get(StartNum,1) - set i=$order(@pArray@("")) - if +i=i for do quit:(+i'=i) - . merge TMGlpArray(count)=@pArray@(i) - . set count=count+$get(IncValue,1) - . set i=$order(@pArray@(i)) - kill @pArray - merge @pArray=TMGlpArray - quit - - -ListTrim(pArray,startIndex,endIndex,CountName) - ;"SCOPE: PUBLIC - ;"Purpose: Take a list with numeric (integer) ordering, and trim (kill) entry - ;" items startIndex...endIndex - ;"Input: pArray -- PASS BY NAME. The array to trim - ;" startIndex -- the first index item to kill. Default=1 - ;" endIndex -- the last index item to kill. Default=1 - ;" CountName -- OPTIONAL. The name of a node that includes the - ;" final count of remaining nodes. Default is "COUNT" - ;"Output: Array items will be killed. Also, a node with the resulting count - ;" of remaining items will be created, with name of CountName. e.g. - ;" INPUT: startIndex=1, endIndex=4 - ;" @pArray@(2)="grape" - ;" @pArray@(3)="orange" - ;" @pArray@(5)="apple" - ;" @pArray@(7)="pear" - ;" @pArray@(9)="peach" - ;" - ;" OUTPUT: - ;" @pArray@(5)="apple" - ;" @pArray@(7)="pear" - ;" @pArray@(9)="peach" - ;" @pArray@("COUNT")=3 - - set startIndex=$get(startIndex,1) - set endIndex=$get(endIndex,1) - set CountName=$get(CountName,"COUNT") - kill @pArray@(CountName) - new i for i=startIndex:1:endIndex kill @pArray@(i) - do ListPack(pArray) - set @pArray@(CountName)=$$ListCt(pArray) - quit - - -ListAdd(pArray,index,value) - ;"SCOPE: PUBLIC - ;"Purpose: To take a simple list and add to end of ist - ;" e.g. Array("Apple")=75 - ;" Array("Pear")=19 - ;" - ;" do ListAdd("Array","Grape",12) --> - ;" - ;" e.g. Array("Apple")=75 - ;" Array("Pear")=19 - ;" Array("Grape")=12 - - ;"Note: function creation aborted, because there is no intrinsic ordering in arrays. I.e. the above would actually - ;" be in this order, as returned by $order(): - ;" e.g. Array("Apple")=75 - ;" Array("Grape")=12 <-- "G" comes before "P" alphabetically - ;" Array("Pear")=19 - - ;"I'll leave this here as a reminder to myself next time. - - quit - - -ListAnd(pArray1,pArray2,pResult) - ;"Purpose: To take two lists, and create a third list that has only those entries that - ;" exist in Array1 AND Array2 - ;"Input: pArray1 : NAME OF array for list 1 - ;" pArray2 : NAME OF array for list 2 - ;" pResult : NAME OF array to results -- any preexisting entries will be killed - ;"Note: only TOP LEVEL nodes are considered, and *value* for pArray1 use for combined value - ;"E.g. of Use - ;" @pArray1@("cat")="feline" - ;" @pArray1@("dog")="canine" - ;" @pArray1@("horse")="equinine" - ;" @pArray1@("bird")="avian" - ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node - ;" - ;" @pArray2@("hog")="porcine" - ;" @pArray2@("horse")="equinine" - ;" @pArray2@("cow")="bovine" - ;" @pArray2@("bird")="flier" <----- note different value for key="bird" - ;" - ;" resulting list: - ;" @pResult@("horse")="equinine" - ;" @pResult@("bird")="avian" <-- note value from pArray1 used. - - new Result - - new i set i=$order(@pArray1@("")) - if i'="" for do quit:(i="") - . if $data(@pArray2@(i))#10 do - . . set Result(i)=$get(@pArray1@(i)) - . set i=$order(@pArray1@(i)) - - kill @pResult - merge @pResult=Result - - quit - - -ListNot(pArray1,pArray2,Verbose) - ;"Purpose: To take two lists, and remove all entries from list 2 from list 1 - ;" exist in Array1 NOT Array2 - ;"Input: pArray1 : NAME OF array for list 1 - ;" pArray2 : NAME OF array for list 2 - ;" Verbose: OPTIONAL. if 1 then verbose output, progress bar etc. - - ;"Note: only TOP LEVEL nodes are considered, and - ;" *value* for pArray1 use for combined value - - ;"E.g. of Use - ;" list 1: - ;" @pArray1@("cat")="feline" - ;" @pArray1@("dog")="canine" - ;" @pArray1@("horse")="equinine" - ;" @pArray1@("bird")="avian" - ;" @pArray1@("bird","weight")=12 <--- will be ignored, not a top level node - ;" - ;" list 2: - ;" @pArray1@("cat")="feline" - ;" @pArray1@("horse")="equinine" - ;" - ;" resulting list: - ;" @pArray1@("dog")="canine" - ;" @pArray1@("bird")="avian" - ;" @pArray1@("bird","weight")=12 - ;" - - new Itr,index - set index=$$ItrAInit^TMGITR(pArray2,.Itr) - if Verbose=1 do PrepProgress^TMGITR(.Itr,20,1,"index") - if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="") - . kill @pArray1@(i) - - quit - - - ;"Note: Sometime, compare this function to $$DATE^TIULS ... I didn't know about this function before! -DTFormat(FMDate,format,Array) - ;"SCOPE: PUBLIC - ;"Purpose: to allow custom formating of fileman dates in to text equivalents - ;"Input: FMDate -- this is the date to work on, in Fileman Format - ;" format -- a formating string with codes as follows. - ;" yy -- 2 digit year - ;" yyyy -- 4 digit year - ;" m - month number without a leading 0. - ;" mm -- 2 digit month number (01-12) - ;" mmm - abreviated months (Jan,Feb,Mar etc.) - ;" mmmm -- full names of months (January,February,March etc) - ;" d -- the number of the day of the month (1-31) without a leading 0 - ;" dd -- 2 digit number of the day of the month - ;" w -- the numeric day of the week (1-7) - ;" ww -- abreviated day of week (Mon,Tue,Wed) - ;" www -- day of week (Monday,Tuesday,Wednesday) - ;" h -- the number of the hour without a leading 0 (1-23) 24-hr clock mode - ;" hh -- 2 digit number of the hour. 24-hr clock mode - ;" H -- the number of the hour without a leading 0 (1-12) 12-hr clock mode - ;" HH -- 2 digit number of the hour. 12-hr clock mode - ;" # -- will display 'am' for hours 1-12 and 'pm' for hours 13-24 - ;" M - the number of minutes with out a leading 0 - ;" MM -- a 2 digit display of minutes - ;" s - the number of seconds without a leading 0 - ;" ss -- a 2 digit display of number of seconds. - ;" allowed punctuation symbols-- ' ' : , / @ .;- (space, colon, comma, forward slash, at symbol,semicolon,period,hyphen) - ;" 'text' is included as is, even if it is same as a formatting code - ;" Other unexpected text will be ignored - ;" - ;" If a date value of 0 is found for a code, that code is ignored (except for min/sec) - ;" - ;" Examples: with FMDate=3050215.183000 (i.e. Feb 5, 2005 @ 18:30 0 sec) - ;" "mmmm d,yyyy" --> "February 5,2005" - ;" "mm d,yyyy" --> "Feb 5,2005" - ;" "'Exactly' H:MM # 'on' mm/dd/yy" --> "Exactly 6:30 pm on 02/05/05" - ;" "mm/dd/yyyy" --> "02/05/2005" - ;" - ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE - ;" The array will be filled with data as follows: - ;" Array(Token)=value for that token (ignores codes such as '/',':' ect) - - ;"Output: Text of date, as specified by above - - new result set result="" - new Token set Token="" - new LastToken set LastToken="" - new ch set ch="" - new LastCh set LastCh="" - new InStr set InStr=0 - new done set done=0 - new i - - if $get(format)="" goto FDTDone - if +$get(FMDate)=0 goto FDTDone - - for i=1:1:$length(format) do quit:done - . set LastCh=ch - . set ch=$extract(format,i) ;"get next char of format string. - . if (ch'=LastCh)&(LastCh'="")&(InStr=0) do ProcessToken(FMDate,.Token,.result,.Array) - . set Token=Token_ch - . if ch="'" do quit - . . if InStr do ProcessToken(FMDate,.Token,.result) - . . set InStr='InStr ;"toggle In-String mode - . if (i=$length(format)) do ProcessToken(FMDate,.Token,.result,.Array) - -FDTDone - quit result - - -ProcessToken(FMDate,Token,Output,Array) - ;"SCOPE: PRIVATE - ;"Purpose: To take tokens and build output following rules specified by DTFormat) - ;"Input: FMDate -- the date to work with - ;" Token -- SHOULD BE PASSED BY REFERENCE. The code as oulined in DTFormat - ;" Output -- SHOULD BE PASSED BY REFERENCE. The cumulative output - ;" Array -- OPTIONAL, if supplied, SHOULD BE PASSED BY REFERENCE - ;" The array will be filled with data as follows: - ;" Array(Token)=value for that token (ignores codes such as '/') - - - if $extract(Token,1,1)="'" do goto PTDone - . new Str set Str=$extract(Token,2,$length(Token)-1) - . set Output=Output_Str - - if Token=" " set Output=Output_Token goto PTDone - if Token="." set Output=Output_Token goto PTDone - if Token=":" set Output=Output_Token goto PTDone - if Token="/" set Output=Output_Token goto PTDone - if Token=";" set Output=Output_Token goto PTDone - if Token="," set Output=Output_Token goto PTDone - if Token="-" set Output=Output_Token goto PTDone - if Token="@" set Output=Output_Token goto PTDone - - if Token="yy" do goto PTDone - . new Year set Year=+$extract(FMDate,1,3) - . if Year=0 quit - . set Year=+$extract(FMDate,2,3) - . if Year<10 set Year="0"_Year - . set Output=Output_Year - . set Array(Token)=Year; - - if Token="yyyy" do goto PTDone - . new Year set Year=+$extract(FMDate,1,3) - . if Year>0 do - . . set Year=Year+1700 - . . set Output=Output_Year - . . set Array(Token)=Year - - if Token="m" do goto PTDone - . new Month set Month=+$extract(FMDate,4,5) - . if Month>0 do - . . set Output=Output_Month - . . set Array(Token)=Month - - if Token="mm" do goto PTDone - . new Month set Month=+$extract(FMDate,4,5) - . if Month=0 quit - . if Month<10 set Month="0"_Month - . set Output=Output_Month - . set Array(Token)=Month - - if Token="mmm" do goto PTDone - . new Month set Month=+$extract(FMDate,4,5) - . if Month=0 quit - . else if Month=1 set Month="Jan" - . else if Month=2 set Month="Feb" - . else if Month=3 set Month="Mar" - . else if Month=4 set Month="Apr" - . else if Month=5 set Month="May" - . else if Month=6 set Month="Jun" - . else if Month=7 set Month="Jul" - . else if Month=8 set Month="Aug" - . else if Month=9 set Month="Sept" - . else if Month=10 set Month="Oct" - . else if Month=11 set Month="Nov" - . else if Month=12 set Month="Dec" - . if +Month=0 do - . . set Output=Output_Month - . . set Array(Token)=Month - - if Token="mmmm" do goto PTDone - . new Month set Month=+$extract(FMDate,4,5) - . if Month=0 quit - . else if Month=1 set Month="January" - . else if Month=2 set Month="February" - . else if Month=3 set Month="March" - . else if Month=4 set Month="April" - . else if Month=5 set Month="May" - . else if Month=6 set Month="June" - . else if Month=7 set Month="July" - . else if Month=8 set Month="August" - . else if Month=9 set Month="September" - . else if Month=10 set Month="October" - . else if Month=11 set Month="November" - . else if Month=12 set Month="December" - . else if +Month=0 do - . . set Output=Output_Month - . . set Array(Token)=Month - - if Token="d" do goto PTDone - . new Day set Day=+$extract(FMDate,6,7) - . if Day>0 do - . . set Output=Output_Day - . . set Array(Token)=Day - - if Token="dd" do goto PTDone - . new Day set Day=+$extract(FMDate,6,7) - . if Day=0 quit - . if Day<10 set Day="0"_Day - . set Output=Output_Day - . set Array(Token)=Day - - if Token="w" do goto PTDone - . new DOW set DOW=$$DOW^XLFDT(FMDate,1) - . if DOW>0 do - . . set Output=Output_DOW - . . set Array(Token)=DOW - - if Token="ww" do goto PTDone - . new DOW set DOW=$$DOW^XLFDT(FMDate,1) - . if (DOW<0)!(DOW>6) quit - . if DOW=0 set DOW="Sun" - . if DOW=1 set DOW="Mon" - . if DOW=2 set DOW="Tue" - . if DOW=3 set DOW="Wed" - . if DOW=4 set DOW="Thur" - . if DOW=5 set DOW="Fri" - . if DOW=6 set DOW="Sat" - . set Output=Output_DOW - . set Array(Token)=DOW - - if Token="www" do goto PTDone - . new DOW set DOW=$$DOW^XLFDT(FMDate) - . if DOW'="day" do - . . set Output=Output_DOW - . . set Array(Token)=DOW - - if Token="h" do goto PTDone - . new Hour set Hour=+$extract(FMDate,9,10) - . if Hour>0 do - . . set Output=Output_Hour - . . set Array(Token)=Hour - - if Token="hh" do goto PTDone - . new Hour set Hour=+$extract(FMDate,9,10) - . if Hour=0 quit - . if Hour<10 set Hour="0"_Hour - . set Output=Output_Hour - . set Array(Token)=Hour - - if Token="H" do goto PTDone - . new Hour set Hour=+$extract(FMDate,9,10) - . if Hour>12 set Hour=Hour-12 - . if Hour>0 do - . . set Output=Output_Hour - . . set Array(Token)=Hour - - if Token="HH" do goto PTDone - . new Hour set Hour=+$extract(FMDate,9,10) - . if Hour=0 quit - . if Hour>12 set Hour=Hour-12 - . if Hour<10 set Hour="0"_Hour - . set Output=Output_Hour - . set Array(Token)=Hour - - if Token="#" do goto PTDone - . new Hour set Hour=+$extract(FMDate,9,10) - . new code - . if Hour=0 quit - . if Hour>12 set code="pm" - . else set code="am" - . set Output=Output_code - . set Array(Token)=code - - new Min set Min=+$extract(FMDate,11,12) - - if Token="M" do goto PTDone - . new Min set Min=+$extract(FMDate,11,12) - . set Output=Output_Min - . set Array(Token)=Min - - if Token="MM" do goto PTDone - . new Min set Min=+$extract(FMDate,11,12) - . if Min<10 set Min="0"_Min - . set Output=Output_Min - . set Array(Token)=Min - - if Token="s" do goto PTDone - . new Sec set Sec=+$extract(FMDate,13,14) - . set Output=Output_Sec - . set Array(Token)=Sec - - if Token="ss" do goto PTDone - . new Sec set Sec=+$extract(FMDate,13,14) - . if Sec<10 set Sec="0"_Sec - . set Output=Output_Sec - . set Array(Token)=Sec - -PTDone - set Token="" - quit - - - - -CompDOB(DOB1,DOB2) - ;"Purpose: to compare two DOB and return if they match, or are similar - ;"Input: DOB1,DOB2 -- the two values to compare (in external format) - ;"Result: 0 - no similarity or equality - ;" 0.25 - doubt similarity - ;" 0.50 - possible similarity - ;" 0.75 - probable similarity - ;" 1 - exact match - ;"Note: I made this function because during lookups, I would get failures with data such as: - ;" WILLIAM,JOHN G JR 05-21-60 - ;" WILLIAM,JOHN G JR 05-11-60 <-- date differs by one digit. - ;"Rules for comparision - ;" if dates differ by 1 digit --> score of 0.75 - ;" if dates differ by an absolute difference of < 1 months --> 0.75 - ;" if dates differ by an absolute difference of < 6 months --> 0.50 - ;" if dates differ by an absolute difference of < 1 year --> 0.25 - ;" if dates differ by 2 digits --> 0.25 - - new DT1,DT2 - new result set result=0 - - new %DT - set X=DOB1 do ^%DT set DT1=Y ;"convert into internal format to avoid format snafu's - set X=DOB2 do ^%DT set DT2=Y - - new DT1array,DT2array - new temp - if DT1=DT2 set result=1 goto CDOBDone - - set temp=$$DTFormat^TMGMISC(DT1,"mm/dd/yy",.DT1array) ;"parse date parts into array. - set temp=$$DTFormat^TMGMISC(DT2,"mm/dd/yy",.DT2array) - - ;"Compare digits - new NumDif set NumDif=0 - new dg1,dg2 - - set dg1=$extract($get(DT1array("dd")),1,1) set dg2=$extract($get(DT2array("dd")),1,1) - if dg1'=dg2 set NumDif=NumDif+1 - set dg1=$extract($get(DT1array("dd")),2,2) set dg2=$extract($get(DT2array("dd")),2,2) - if dg1'=dg2 set NumDif=NumDif+1 - - set dg1=$extract($get(DT1array("mm")),1,1) set dg2=$extract($get(DT2array("mm")),1,1) - if dg1'=dg2 set NumDif=NumDif+1 - set dg1=$extract($get(DT1array("mm")),2,2) set dg2=$extract($get(DT2array("mm")),2,2) - if dg1'=dg2 set NumDif=NumDif+1 - - set dg1=$extract($get(DT1array("yy")),1,1) set dg2=$extract($get(DT2array("yy")),1,1) - if dg1'=dg2 set NumDif=NumDif+1 - set dg1=$extract($get(DT1array("yy")),2,2) set dg2=$extract($get(DT2array("yy")),2,2) - if dg1'=dg2 set NumDif=NumDif+1 - - if NumDif=1 set result=0.75 goto CDOBDone - if NumDif=2 set result=0.50 - - ;"Compare absolute date - new H1,H2,DateDif - set H1=$$FMTH^XLFDT(DT1,1) - set H2=$$FMTH^XLFDT(DT2,1) - set DateDif=$$HDIFF^XLFDT(H1,H2,1) ;"1=results in 'days' - if $$HDIFF^XLFDT(H2,H1)>DateDif set DateDif=$$HDIFF^XLFDT(H2,H1) - - new score set score=0 - if DateDif<30 set score=0.75 - if DateDif<(30*6) set score=0.50 - if DateDif<365 set score=0.25 - - if score>result set result=score - -CDOBDone - quit result - - - -BrowseBy(CompArray,ByTag) - ;"Purpose: Allow a user to interact with dynamic text tree - ;" that will open and close nodes. - ;"Input: CompArray -- array to browse. Should be in this format - ;" CompArray("opening tag",a,b,c,d) - ;" ByTag -- the name to use in for "opening tag") - - new aOpen set aOpen=0 - new bOpen set bOpen=0 - new cOpen set cOpen=0 - - new done set done=0 - new input - - for do quit:(done=1) - . do ShowBy(.CompArray,ByTag,aOpen,bOpen,cOpen) - . read "Enter option:",input:$get(DTIME,3600),! - . if input="" set input=0 - . if +input>0 do - . . if aOpen=0 do - . . . set aOpen=input,bOpen=0,cOpen=0 - . . else if bOpen=0 do - . . . set bOpen=input,cOpen=0 - . . else if cOpen=0 set cOpen=input - . else if input=0 do - . . if cOpen'=0 set cOpen=0 quit - . . if bOpen'=0 set bOpen=0 quit - . . set aOpen=0 - . else if input="^" set done=1 - - quit - - -ShowBy(CompArray,ByTag,aOpen,bOpen,cOpen) - - new a,b,c,d - new acount set acount=0 - new bcount set bcount=0 - new ccount set ccount=0 - new dcount set dcount=0 - - write # - - set a=$order(CompArray(ByTag,"")) - if a'="" for do quit:(a="") - . set acount=acount+1 - . new nexta set nexta=$order(CompArray(ByTag,a)) - . new Aindent - . if (aOpen=0) do - . . if acount<10 write "0" - . . write acount,". " - . else write "... " - . write a,! - . set b=$order(CompArray(ByTag,a,"")) - . if (aOpen=acount)&(b'="") for do quit:(b="") - . . set bcount=bcount+1 - . . new nextb set nextb=$order(CompArray(ByTag,a,b)) - . . new Bindent - . . write " +--" - . . if (bOpen=0) do - . . . if bcount<10 write "0" - . . . write bcount,". " - . . else write "... " - . . write b,! - . . if nextb'="" set Aindent=" | " - . . else set Aindent=" " - . . set c=$order(CompArray(ByTag,a,b,"")) - . . if (bOpen=bcount)&(c'="") for do quit:(c="") - . . . set ccount=ccount+1 - . . . new nextc set nextc=$order(CompArray(ByTag,a,b,c)) - . . . if nextc'="" set Bindent=" | " - . . . else set Bindent=" " - . . . write Aindent," +--" - . . . if (cOpen=0) do - . . . . if ccount<10 write "0" - . . . . write ccount,". " - . . . else write "... " - . . . write c,! - . . . set d=$order(CompArray(ByTag,a,b,c,"")) - . . . if (cOpen=ccount)&(d'="") for do quit:(d="") - . . . . set dcount=dcount+1 - . . . . write Aindent,Bindent," +-- " - . . . . if dcount<10 write "0" - . . . . write dcount,". " - . . . . write d,! - . . . . set d=$order(CompArray(ByTag,a,b,c,d)) - . . . set c=nextc - . . set b=nextb - . set a=nexta - -SBDone - quit - - - -CompName(Name1,Name2) - ;"Purpose: To compare two names, to see if they are the name, or compatible. - ;" e.g. WILLIAMS,J BILL vs. WILLAMS,JOHN BILL, vs. WILLIAMS,JOHN B - ;"Input: Two names to compare - ;"Result: 0 -- if entries conflict - ;" 0.5 -- if entries are consistent (i.e. in example above) - ;" 1 -- if entries completely match - ;"Note: This function WILL IGNORE a suffix. This is because - ;" WILLIAM,BILL 5-1-1950 - ;" WILLIAM,BILL SR 5-1-1950 - ;" would be considered the same person (the date is the determining factor) - ;"Rules: Last names must completely match or --> 0 - ;" If name is exactly the same, then --> 1 - ;" Initial must be same as first letters in name (e.g. N vs. NEWTON) --> 0.5 - - new result set result=1 - - new NArray1,NArray2,TMGMsg - - set Name1=$$FormatName(Name1,1) ;"should convert to standard format. - set Name2=$$FormatName(Name2,1) - - do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) - do STDNAME^XLFNAME(.Name1,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. - - do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) - do STDNAME^XLFNAME(.Name2,"C",.TMGMsg) ;"Doing a second time will ensure Array not in initial format. - - if Name1=Name2 set result=1 goto CompNDone - if Name1("FAMILY")'=Name2("FAMILY") do goto:(result=0) CompNDone - . if $$EN^XUA4A71(Name1("FAMILY"))'=$$EN^XUA4A71(Name2("FAMILY")) set result=0 ;"check soundex equality - - if Name1("GIVEN")'=Name2("GIVEN") do - . if $$EN^XUA4A71(Name1("GIVEN"))=$$EN^XUA4A71(Name2("GIVEN")) quit ;"check soundex equality - . new n1,n2 - . set n1=Name1("GIVEN") - . set n2=Name2("GIVEN") - . if $length(n2)<$length(n1) do ;"ensure length n2>n1 - . . new temp set temp=n2 - . . set n2=n1,n1=temp - . if $extract(n2,1,$length(n1))=n1 set result=0.5 - . else set result=0 - if result=0 goto CompNDone - - if Name1("MIDDLE")'=Name2("MIDDLE") do - . if $$EN^XUA4A71(Name1("MIDDLE"))=$$EN^XUA4A71(Name2("MIDDLE")) quit ;"check soundex equality - . new n1,n2 - . set n1=Name1("MIDDLE") - . set n2=Name2("MIDDLE") - . if $length(n2)<$length(n1) do ;"ensure length n2>n1 - . . new temp set temp=n2 - . . set n2=n1,n1=temp - . if $extract(n2,1,$length(n1))=n1 set result=0.5 - . else set result=0 - if result=0 goto CompNDone - -CompNDone - quit result - - - -FormatName(Name,CutTitle) - ;"Purpose: To ensure patient name is properly formated. - ;" i.e. John G. Doe --> DOE,JOHN G - ;" John G. Doe III --> DOE,JOHN G III - ;" John G. Doe,III --> DOE,JOHN G III - ;" Doe, John G --> DOE,JOHN G - ;" Doe,John g.,III, phd --> DOE,JOHN G III PHD - ;"Input: Name -- the name to be reformated - ;" CutTitle -- OPTIONAL -- if 1, then titles (e.g. MD, PhD etc) will be cut - ;"Results: returns properly formated name - ;"Note: If Name is passed by reference, it will be changed - ;" Also, NO lookup is done in database to ensure name exists - - ;"Note: this function malfunctioned on a patient with name like this: - ;" JOHN A VAN DER BON --> BON,JOHN A VAN DER (should be VAN DER BON,JOHN A) - ;" I don't have a quick for this right now... - ;"Also, Sue St. Clair --> CLAIR,SUE ST this is also wrong. - - ;"FYI: do STDNAME^XLFNAME(.NAME,FLAGS,.ERRARRAY) can also do standardization, - ;" and also parse to component parts. It specifically address the St. Clair issue. - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") - - new NameArray - new MaxNode - new Suffix set Suffix="" - new i,s,lname - new fname set fname="" - new result set result="" - if $data(Name)#10=0 goto FormatNDone - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Person's name initially is: '",Name,"'") - set Name=$translate(Name,"*.","") ;"cleans off any *'s or .'s from initials etc. - if Name[", " do - . new s1,s2 - . set s1=$piece(Name,", ",1) - . set s2=$piece(Name,", ",2) - . if $$IsTitle($$UP^XLFSTR(s2))&($get(CutTitle)=1) do - . . set Name=s1 - . else do - . . set Name=s1_","_s2 - . ;"set Name=$translate(Name,", ",",") ;"Convert 'Doe, John' into 'Doe,John' - set Name=$$UP^XLFSTR(Name) ;"convert to upper case - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After translations, name is: '",Name,"'") - set result=$$FORMAT^DPTNAME(Name,3,30) ;"Convert to 'internal' format - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After $$FORMAT^DPTNAME, name is: '",result,"'") - - ;"Now, test if FORMAT^DPTNAME caused empty name, i.e. - ;" John G Doe --> "" (it wanted Doe,John G) - set lname=$piece(result,",",2) - if $$IsTitle(lname)&($get(CutTitle)=1) do ;"trim off title if not wanted. - . set result=$piece(result,",",1) - . set lname="" - if $$IsSuffix(lname)=1 do - . ;"Here we have 'JOHN DOE,III' --> must be changed to 'DOE,JOHN III' - . set Name=$translate(Name,","," ") ;"First change 'JOHN DOE,III' --> 'JOHN DOE III' - . set result="" ;"signal need to rearrange letters. - if (result="")&(Name'[",") do - . set s=Name - . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) - . set MaxNode=+$get(NameArray("MAXNODE")) - . if MaxNode=0 quit - . if $get(CutTitle)=1 do - . . if $$IsTitle(NameArray(MaxNode)) do - . . . kill NameArray(MaxNode) - . . . set MaxNode=MaxNode-1 - . . . set NameArray("MAXNODE")=MaxNode - . set lname=NameArray(MaxNode) - . if ($$IsSuffix(lname)=1)!($$IsTitle(lname)) do - . . ;"Change JOHN G DOE III --> JOHN G III DOE (order change in array) - . . set lname=NameArray(MaxNode-1) ;"i.e. DOE - . . set Suffix=NameArray(MaxNode) ;"i.e. III - . . set NameArray(MaxNode)=lname - . . set NameArray(MaxNode-1)=Suffix - . set result=lname_"," - . for i=1:1:MaxNode-1 do - . . set result=result_NameArray(i)_" " - - ;"convert potential 'DOE,JOHN G,III, PHD' --> 'DOE,JOHN G III PHD' - set lname=$piece(result,",",1) - set fname=$piece(result,",",2,99) - set fname=$translate(fname,","," ") - set result=lname_","_fname - - set result=$$Trim^TMGSTUTL(result) - - ;"One last run through, after all custom alterations made. - ;"convert potential 'DOE,JOHN G III PHD' --> 'DOE,JOHN G III PHD' - set result=$$FORMAT^DPTNAME(result,3,30) ;"Convert to 'internal' format - -FormatNDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatName^TMGGDFN") - quit result - - -IsSuffix(s) - ;"Purpose: to return whether s is a suffix (i.e. I,II,Jr.,Sr. etc.) - ;"Input: s : the string to check - ;"Result 0 if NOT a suffix, 1 if IS a suffix. - - new result set result=0 - - if (s="I")!(s="II")!(s="III")!(s="JR")!(s="SR") set result=1 - - quit result - - -IsTitle(s) - ;"Purpose: to return whether s is a title (i.e. MD,PHD,JD,DDS etc.) - ;"Input: s : the string to check - ;"Result 0 if NOT a suffix, 1 if IS a suffix. - - new result set result=0 - - if (s="MD")!(s="PHD")!(s="JD")!(s="DDS") set result=1 - if (s="FNP")!(s="GNP")!(s="NP")!(s="PA") set result=1 - if (s="RN")!(s="LPN") set result=1 - - quit result - - - -HEXCHR(V) - ;"Scope: PUBLIC - ;"Take one BYTE and return HEX Values - ;"(from Chris Richardson -- thanks!) - new NV,B1,B2 - set NV="0123456789ABCDEF" - set B1=(V#16)+1 ; "0 to 15 becomes 1 to 16 - set B2=(V\16)+1 - quit $E(NV,B2)_$E(NV,B1) - - -HEXCHR2(n,digits) - ;"SCOPE: PUBLIC - ;"Purpose: convert n to hex characters - ;"Input: n -- the number to convert - ;" digits: (optional) number of digits in output. Leading 0's padded to - ;" front of answer to set number of digits. - ;" e.g. if answer is "A", then - ;" 2 -> mandates at least 2 digits ("0A") - ;" 3->3 digits ("00A") - ;"Note: This function is not as fast as HEXCHR(V) - - new lo - new result set result="" - new ch - set digits=$get(digits,1) - - for do quit:(n=0) - . set lo=n#16 - . if (lo<10) set ch=+lo - . else set ch=$char(55+lo) - . set result=ch_result - . set n=n\16 - - if $length(result) 16 - - new multiplier set multiplier=1 - new result set result=0 - - if $extract(s,1)="$" set s=$extract(s,2,$length(s)) - - for do quit:(s="") - . new sStart,sEnd,n - . set sStart=$extract(s,1,$length(s)-1) - . set sEnd=$extract(s,$length(s)) - . if +sEnd=sEnd set n=sEnd - . else set n=($ascii(sEnd)-65)+16 - . set result=result+(n*multiplier) - . set multiplier=multiplier*16 - . set s=sStart - - quit result - - -OR(a,b) - ;"Scope: PUBLIC - ;"Purpose: to perform a bitwise OR on operands a and 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 - - -ParsePos(pos,label,offset,routine,dmod) - ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts - ;"Input: pos -- the string, as example above - ;" label -- OUT PARAM, PASS BY REF, would return "x" - ;" offset -- OUT PARAM, PASS BY REF, would return "+2" - ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" - ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" - ;"Results: none - ;"Note: results are shortened to 8 characters. - - new s - set s=$get(pos) - set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE - set routine=$piece(s,"^",2) - set routine=$extract(routine,1,8) - set label=$piece(s,"^",1) - set offset=$piece(label,"+",2) - set label=$piece(label,"+",1) - set label=$extract(label,1,8) - - quit - - -ScanMod(Module,pArray) - ;"Purpose: To scan a module and find all the labels/entry points/Entry points - ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") - ;" pArray -- pointer to (NAME OF) array Will be filled like this - ;" pArray(1,"TAG")="Label1" - ;" pArray(1,"OFFSET")=1 - ;" pArray(2,"TAG")="Label2" - ;" pArray(2,"OFFSET")=9 - ;" pArray(3,"TAG")="Label3" etc. - ;" pArray(3,"OFFSET")=15 - ;" pArray("Label1")=1 - ;" pArray("Label2")=2 - ;" pArray("Label3")=3 - ;" - ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", - ;" so use another name. - ;" - ;"Output: Results are put into array - ;"Result: none - - new smIdx set smIdx=1 - new LabelNum set LabelNum=0 - new smLine set smLine="" - if $get(Module)="" goto SMDone - - for do quit:(smLine="") - . new smCh - . set smLine=$text(+smIdx^@Module) - . if smLine="" quit - . set smLine=$$Substitute^TMGSTUTL(smLine,$Char(9)," ") ;"replace tabs for 8 spaces - . set smCh=$extract(smLine,1) - . if (smCh'=" ")&(smCh'=";") do - . . new label - . . set label=$piece(smLine," ",1) - . . set LabelNum=LabelNum+1 - . . set @pArray@(LabelNum,"TAG")=label - . . set @pArray@(LabelNum,"OFFSET")=smIdx - . . set @pArray@(label)=LabelNum - . set smIdx=smIdx+1 - -SMDone - quit - - -ConvertPos(Pos,pArray) - ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into - ;" one that is relative to the start of the file - ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT - ;"Input: Pos -- a position, as returned from $ZPOS - ;" pArray -- pointer to (name of). Array holding holding tag offsets - ;" pArray will be in this format: - ;" pArray("ModuleA",1,"TAG")="ALabel1" - ;" pArray("ModuleA",1,"OFFSET")=1 - ;" pArray("ModuleA",2,"TAG")="ALabel2" - ;" pArray("ModuleA",2,"OFFSET")=9 - ;" pArray("ModuleA","Label1")=1 - ;" pArray("ModuleA","Label2")=2 - ;" pArray("ModuleA","Label3")=3 - ;" pArray("ModuleB",1,"TAG")="BLabel1" - ;" pArray("ModuleB",1,"OFFSET")=4 - ;" pArray("ModuleB",2,"TAG")="BLabel2" - ;" pArray("ModuleB",2,"OFFSET")=23 - ;" pArray("ModuleB","Label1")=1 - ;" pArray("ModuleB","Label2")=2 - ;" pArray("ModuleB","Label3")=3 - ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it - ;"Result: returns the new position line, relative to the start of the file/module - ;" - - new cpS - new cpResult set cpResult="" - new cpRoutine,cpLabel,cpOffset - - set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE - if cpS="" goto CPDone - - set cpRoutine=$piece(cpS,"^",2) - if cpRoutine="" goto CPDone - - set cpS=$piece(cpS,"^",1) - set cpOffset=+$piece(cpS,"+",2) - ;"if cpOffset="" set cpOffset=1 - ;"else set cpOffset=+cpOffset - set cpLabel=$piece(cpS,"+",1) - - if $data(@pArray@(cpRoutine))=0 do - . new p2Array set p2Array=$name(@pArray@(cpRoutine)) - . do ScanMod(cpRoutine,p2Array) - - new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) - if cpIdx=0 goto CPDone - new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") - set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine - -CPDone - quit cpResult - - - - -CompArray(pArray1,pArray2) - ;"Purpose: To return if two arrays are identical - ;" Equality means that all nodes and values are present and equal - ;"Input: Array1 -- PASS BY NAME. The *name of* the first array to be compared - ;" Array1 -- PASS BY NAME. The *name of* the second array to be compared - ;"Output: 1 if two are identical, 0 if not - - new result set result=1 - new index1,index2 - set index1=$order(@pArray1@("")) - set index2=$order(@pArray2@("")) - if (index1="")!(index2="") set result=0 goto CADone - for do quit:(result=0)!(index1="")!(index2="") - . if index2'=index2 set result=0 quit - . if $get(@pArray1@(index1))'=$get(@pArray2@(index2)) set result=0 quit - . if ($data(@pArray1@(index1))'<10)!($data(@pArray2@(index2))'<10) do - . . set result=$$CompArray($name(@pArray1@(index1)),$name(@pArray2@(index2))) - . set index1=$order(@pArray1@(index1)) - . set index2=$order(@pArray2@(index2)) - -CADone quit result - - - -IterTemplate(Template,Prior) - ;"Purpose: To iterate through a SORT TEMPLATE (i.e. provide record numbers held in the template - ;" one at a time. For each time this function is called, one record number (IEN) is returned. - ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) - ;" Prior -- OPTIONAL (default is to return first record), an IEN as returned from this - ;" function during the last call. - ;"Result: Returns the next record found in list, occuring after Prior, or -1 if error or not found - ;" Returns "" if end of list (no next record) - - ;"Example of use: This will list all records held in SORT TEMPLATE record# 809 - ;" set IEN="" - ;" for s IEN=$$IterTemplate^TMGMISC(809,IEN) w IEN,! q:(+IEN'>0) - - set Prior=$get(Prior) - set result=-1 - if +$get(Template)'>0 goto ItTDone - - set result=$order(^DIBT(Template,1,Prior)) - -ItTDone quit result - -CtTemplate(Template) - ;"Purpose: To return the Count of IEN's stored in a SORT TEMPLATE - ;"Input: Template: the IEN of an entry from file SORT TEMPLATE (file# .401) - ;"Result: Returns the count of records held - - new name set name=$name(^DIBT(Template,1)) - quit $$ListCt(name) - - -NumPieces(s,delim,maxPoss) - ;"Purpose: to return the number of pieces in s, using delim as a delimiter - ;"Input: s -- the string to test - ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " - ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 - ;" the function counts DOWN from this number, so if s has more than default, must specify - ;"Result: Returns the number of pieces - ;" e.g. 'this is a test', space delimiter --> returns 4 - ;"Note: ("this is a test",";") --> 1 - ;" ("",";") --> 0 - - ;"NOTICE!!! - ;"After writing this function, I was told that $length(s,delim) will do this. - ;" I will leave this here as a reminder, but it probably shouldn't be used.... - quit $length(s,$get(delim," ")) - - - new i,result set result=0 - if $get(s)="" goto NPsDone - set delim=$get(delim," ") - set maxPoss=+$get(maxPoss,32) - - for result=maxPoss:-1:1 quit:($piece(s,delim,result)'="") - - quit result - -LastPiece(s,delim,maxPoss) - ;"Purpose: to return the last piece of a string - ;"Input: s -- the string to use - ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " - ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) - ;"Results : returns the LAST piece in the string - - new result set result="" - if $get(s)="" goto LPDone - set delim=$get(delim," ") - new n - set n=$length(s,delim) - set result=$piece(s,delim,n) - -LPDone - quit result - -ParseLast(s,remainS,delim,maxPoss) - ;"Purpose: to return the last piece of a string, AND return the first part of the string in remainS - ;"Input: s -- the string to use - ;" remainS -- an OUT parameter. PASS BY REFERENCE. Returns the part of the string up to result - ;" delim -- OPTIONAL -- the delimiter (e.g. ',' or ';' or ' ' etc), default=" " - ;" maxPoss -- OPTIONAL the maximum number of possible pieces, default=32 (see NumPieces function) - ;"Results : returns the LAST piece in the string - - new result set result="" - new tempS set tempS=s ;"in case s passed by reference, and remainS=s (i.e. w $$ParseLast(s,.s) - set remainS="" - set delim=$get(delim," ") - - if $get(tempS)="" goto PLDone - new n - set n=$length(s,delim) - set result=$piece(tempS,delim,n) - if n>1 set remainS=$piece(tempS,delim,1,n-1) - -PLDone - quit result - - - -NPsDone - quit result - - -Trim1Node(pRef) - ;"Purpose: To shorten a reference by one node. - ;" e.g. "Array(567,2342,123)" --> "Array(567,2342)" - ;"Input: pRef -- the NAME OF an array. - ;"Result: will return shortened reference, or "" if problem - ;" If no nodes to trim, just array name will be returnes. - - new result set result=pRef - if pRef="" goto T1NDone - - if $qlength(pRef)>0 set result=$name(@pRef,$qlength(pRef)-1) - goto T1NDone - - ;"Below is an old way I came up with (not as effecient!) - ;"NOT USED. - set result=$qsubscript(pRef,0) - - new numNodes,i - set numNodes=$qlength(pRef) - for i=1:1:(numNodes-1) do - . new node set node=$qsubscript(pRef,i) - . set result=$name(@result@(node)) - -T1NDone - quit result - - -BROWSEASK - ;"Purpose: to ask user for the name of an array, then display nodes - - new current - new order set order=1 ;"default = forward display. - new paginate set paginate=0 ;"no pagination - new countNodes set countNodes=0 ;"no counting - write ! - read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! - if +current=current do - . set current=$get(^DIC(+current,0,"GL")) - . if current="" write "File number not found. Quitting.",! quit - . write "Browsing array: ",current,! - if current="" set current="^" - if current="^" goto BADone - - new % set %=2 ;" default= NO - write "Display in REVERSE order? " - do YN^DICN write ! - if %=1 set order=-1 - if %=-1 goto BADone - - set %=2 - write "Pause after each page? " - do YN^DICN write ! - if %=1 set paginate=1 - if %=-1 goto BADone - - set %=2 - write "Show number of subnodes? " - do YN^DICN write ! - if %=1 set countNodes=1 - if %=-1 goto BADone - - do BROWSENODES(current,order,paginate,countNodes) -BADone - quit - - -BROWSENODES(current,Order,paginate,countNodes) - ;"Purpose: to display nodes of specified array - ;"Input: Current -- The reference to display - ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order - ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page - ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. - - new parent,child - set parent="" - set order=$get(order,1) - set paginate=$get(paginate,0) - set countNodes=$get(countNodes,0) - - new len set len=$length(current) - new lastChar set lastChar=$extract(current,len) - if lastChar'=")" do - . if current'["(" quit - . if lastChar="," set current=$extract(current,1,len-1) - . if lastChar="(" set current=$extract(current,1,len-1) quit - . set current=current_")" - -BNLoop - if current="" goto BNDone - set child=$$ShowNodes(current,order,paginate,countNodes) - if child'="" do - . set parent(child)=current - . set current=child - else set current=$get(parent(current)) - goto BNLoop -BNDone - quit - - -ShowNodes(pArray,order,paginate,countNodes) - ;"Purpose: To display all the nodes of the given array - ;"Input: pArray -- NAME OF array to display - ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order - ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page - ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. - ;"Results: returns NAME OF next node to display (or "" if none) - - new TMGi - new count set count=1 - new Answers - new someShown set someShown=0 - new abort set abort=0 - set paginate=$get(paginate,0) - new pageCount set pageCount=0 - new pageLen set pageLen=20 - set countNodes=$get(countNodes,0) - - write pArray,! - set TMGi=$order(@pArray@(""),order) - if TMGi'="" for do quit:(TMGi="")!(abort=1) - . write count,". +--[",TMGi,"]" - . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" - . write "=",$extract($get(@pArray@(TMGi)),1,40),! - . set someShown=1 - . set Answers(count)=$name(@pArray@(TMGi)) - . set count=count+1 - . new temp read *temp:0 - . if temp'=-1 set abort=1 - . set pageCount=pageCount+1 - . if (paginate=1)&(pageCount>pageLen) do - . . new temp - . . read "Press [ENTER] to continue (^ to stop list)...",temp:$get(DTIME,3600),! - . . if temp="^" set abort=1 - . . set pageCount=0 - . set TMGi=$order(@pArray@(TMGi),order) - - if someShown=0 write " (no data)",! - write !,"Enter # to browse (^ to backup): ^//" - new temp read temp:$get(DTIME,3600),! - - new result set result=$get(Answers(temp)) - - quit result - - -BRWSASK2 - ;"Purpose: Improved... Ask user for the name of an array, then display nodes - - new current - new order set order=1 ;"default = forward display. - new countNodes set countNodes=0 ;"no counting - write ! - read "Enter name of array (or File number) to display nodes in: ",current:$get(DTIME,3600),! - if +current=current do - . set current=$get(^DIC(+current,0,"GL")) - . if current="" write "File number not found. Quitting.",! quit - . write "Browsing array: ",current,! - if current="" set current="^" - if current="^" goto BA2Done - - new % set %=2 ;" default= NO - write "Display in REVERSE order? " do YN^DICN write ! - if %=1 set order=-1 - if %=-1 goto BA2Done - - set %=2 - write "Show number of subnodes? " do YN^DICN write ! - if %=1 set countNodes=1 - if %=-1 goto BA2Done - - do BRWSNOD2(current,order,countNodes) -BA2Done - quit - -BRWSNOD2(curRef,Order,countNodes) - ;"Purpose: to display nodes of specified array - ;"Input: curRef -- The reference to display - ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order - ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page - ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. - set curRef=$$CREF^DILF(curRef) - if curRef="" goto BN2Done - new TMGBRWORDER set TMGBRWORDER=$get(order,1) - new TMGBRWCN set TMGBRWCN=$get(countNodes,0) - if $$ShowNod2(curRef,TMGBRWORDER,TMGBRWCN) -BN2Done quit - -ShowNod2(pArray,order,countNodes) - ;"Purpose: To display all the nodes of the given array - ;" UPDATED function to use Scroller box. - ;"Input: pArray -- NAME OF array to display - ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order - ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. - ;"Results: returns NAME OF next node to display (or "" if none) - - new TMGi,Option - new dispArray,dispI set dispI=1 - set order=$get(order,1) - set countNodes=$get(countNodes,0) - ; - set TMGi="" for set TMGi=$order(@pArray@(TMGi),order) quit:(TMGi="") do - . new s set s=" +---["_TMGi_"]" - . if countNodes=1 set s=s_"("_$$ListCt($name(@pArray@(TMGi)))_")" - . new s2 set s2=$extract($get(@pArray@(TMGi)),1,40) - . if s2'="" set s=s_"="_s2 - . if $data(@pArray@(TMGi))>9 set s=s_" ..." - . set dispArray(dispI,s)=$name(@pArray@(TMGi)),dispI=dispI+1 - if $data(dispArray)=0 set dispArray(dispI,"")="",dispI=dispI+1 - ; - set Option("HEADER",1)="Data for "_pArray - set Option("FOOTER",1,1)="? Help" - set Option("FOOTER",1,2)="LEFT Backup" - set Option("FOOTER",1,3)="RIGHT Browse IN" - set Option("ON SELECT")="HndOnSel^TMGMISC" - set Option("ON CMD")="HndOnCmd^TMGMISC" - ; - write # - do Scroller^TMGUSRIF("dispArray",.Option) - quit pArray - -HndOnSel(pArray,Option,Info) - ;"Purpose: handle ON SELECT event from Scroller^TMGUSRIF, launched by ShowNod2 - ;"Input: pArray,Option,Info -- see documentation in Scroller^TMGUSRIF - ;" Info has this: - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ; - new ref set ref=$get(Info("CURRENT LINE","RETURN")) - if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) - quit - - -HndOnCmd(pArray,Option,Info) - ;"Purpose: handle ON SELECT event from Scroller, launched by ShowNod2 - ;"Input: pArray,Option,Info -- see documentation in Scroller - ;" Info has this: - ;" Info("USER INPUT")=input - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ;" TMGSCLRMSG,TMGBRWORDER,TMGBRWCN - globally scoped variables that are used. - ;"results: none (required to have none) - - new input set input=$$UP^XLFSTR($get(Info("USER INPUT"))) - if input["LEFT" do - . set TMGSCLRMSG="^" - else if input["RIGHT" do - . new ref set ref=$get(Info("CURRENT LINE","RETURN")) - . if ref'="" if $$ShowNod2(ref,TMGBRWORDER,TMGBRWCN) - else if input="?" do - . write !,"Use UP and DOWN cursor keys to select global node",! - . write "LEFT will back up, and RIGHT or ENTER will browse node",! - . write "^ at the ':' prompt will cause a back up of one level",! - . do PressToCont^TMGUSRIF - else if input'="" do - . write !,"Input ",$get(Info("USER INPUT"))," not recognized.",! - . do PressToCont^TMGUSRIF - ; - write # - quit - - -IsNumeric(value) - ;"Purpose: to determine if value is pure numeric. - ;"Note: This will be a more involved test than simply: if +value=value, because - ;" +"00001" is not the same as "1" or 1. Also +"123abc"--> 123, but is not pure numeric - set value=$$Trim^TMGSTUTL(value) ;" trim whitespace - set value=$$TrimL^TMGSTUTL(value,"0") ;"trim leading zeros - quit (value=+value) - - -ClipDDigits(Num,digits) - ;"Purpose: to clip number to specified number of decimal digits - ;" e.g. 1234.9876543 --> 1234.9876 if digits=4 - ;"Input: Num -- the number to process - ;" digits -- the number of allowed decimal digits after the decimal point - ;"Result: returns the number clipped to the specified number of decimals - ;" note: this is a CLIP, not a ROUND function - - new result set result=Num - new decimals set decimals=$extract($piece(Num,".",2),1,digits) - set result=$piece(Num,".",1) - if decimals'="" set result=result_"."_decimals -CDgDone - quit result - - -Diff(File,IENS1,IENS2,Result) - ;"Purpose: to determine how two records differ in a given file - ;"Input: File -- file name or number of file containing records to be compared - ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared - ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared - ;" Result -- PASS BE REFERENCE, and OUT PARAMETER - ;" Format of output Result array. Will only hold differences - ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField - ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField - ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField - ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField - ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName - ;"Note: this will consider only the first 1024 characters of WP fields - ;"Note: For now, multiples (subfiles) will be IGNORED - - new fileNum set fileNum=+$get(File) - if fileNum=0 set fileNum=$$GetFileNum^TMGDBAPI(.File) - new subFileNum - - new field set field=$order(^DD(fileNum,0)) - if +field>0 for do quit:(+field'>0) - . set subFileNum=+$piece($get(^DD(fileNum,field,0)),"^",2) ;"get subfile number, or 0 if not subfile - . if subFileNum>0 do ;"finish later... - . . ;"Here I need to somehow cycle through each record of the subfile and compare THOSE - . . new subResult - . . do DiffSubFile(subFileNum,.IENS1,.IENS2,.subResult) ;"null function for now - . . ;"do some merge between Result and subResult - . else do Diff1Field(fileNum,field,.IENS1,.IENS2,.Result) - . set field=$order(^DD(fileNum,field)) - - quit - - -Diff1Field(File,Field,IENS1,IEN2,Result) - ;"Purpose: to determine how two records differ for one given field - ;"Input: File -- file NUMBER of file containing records to be compared - ;" Field -- Field NUMBER to be evaluated - ;" IENS1 -- the IEN (or IENS if file is a subfile) of the first record to be compared - ;" IENS2 -- the IEN (or IENS if file is a subfile) of the second record to be compared - ;" Result -- PASS BE REFERENCE, and OUT PARAMETER - ;" Format of output Result array. Will only hold differences - ;" e.g. Result(FieldNum,"EXTRA",1)=valueOfField - ;" e.g. Result(FieldNum,"EXTRA",2)=valueOfField - ;" e.g. Result(FieldNum,"CONFLICT",1)=valueOfField - ;" e.g. Result(FieldNum,"CONFLICT",2)=valueOfField - ;" e.g. Result(FieldNum,"FIELD NAMES")=FieldName - ;"Results: none (data returned in Result out parameter) - ;"Note: only first 1023 characters of a WP field will be compared - - new value1,value2,TMGWP1,TMGWP2 - new fieldName set fieldName=$piece($get(^DD(File,Field,0)),"^",1) - - set value1=$$GET1^DIQ(File,IENS1,Field,"","TMGWP1") - set value2=$$GET1^DIQ(File,IENS2,Field,"","TMGWP2") - - if $data(TMGWP1)!$data(TMGWP2) do - . set value1=$$WPToStr^TMGSTUTL("TMGWP1"," ",1023) ;"Turn first 1023 characters into one long string - . set value2=$$WPToStr^TMGSTUTL("TMGWP2"," ",1023) ;"Turn first 1023 characters into one long string - - if value1=value2 goto D1FDone ;"default is no conflict - if (value2="")&(value1'="") do - . set Result(Field,"EXTRA",1)=value1 - . set Result(Field,"FIELD NAME")=fieldName - if (value1="")&(value2'="") do - . set Result(Field,"EXTRA",2)=value2 - . set Result(Field,"FIELD NAME")=fieldName - if (value1'="")&(value2'="") do - . set Result(Field,"CONFLICT",1)=value1 - . set Result(Field,"CONFLICT",2)=value2 - . set Result(Field,"FIELD NAME")=fieldName - -D1FDone - quit - -DiffSubFile(SubFile,IENS1,IENS2,Result) - - quit - - - -Array2XML(pArray,pResult,indent) - ;"Purpose: to convert an array into XML format - ;"Input: pArray -- the NAME OF the array to convert (array can be any format) - ;" pResult -- the NAME OF the output array. - ;" format: - ;" Result(0)="" - ;" Result(1)="Node Value - ;" Result(2)=" Node Value - ;" Result(3)=" Node Value - ;" Result(4)=" Node Value ;"<--- start subnode - ;" Result(5)=" Node Value - ;" Result(6)=" Node Value - ;" Result(7)=" ;"<---- end subnode - ;" Result(8)=" Node Value - ;" indent -- OPTIONAL. if 1, then subnodes have whitespace indent for pretty viewing - ;"Output: pResult is filled - ;"Result: none. - ;"Note: example call do Array2XML("MyArray","MyOutput",1) - - kill @pResult - set @pResult@(0)=0 - if $get(indent)=1 set indent="" - else set indent=-1 - do A2XNode(pArray,pResult,.indent) - set @pResult@(0)=$$XMLHDR^MXMLUTL - - quit - - -A2XNode(pArray,pResult,indent) - ;"Purpose: To do the output for Array2XML - ;"Input: pArray - the NAME OF the array to convert - ;" pResult - the NAME OF the output array. - ;" Format to be as described in Array2XML, which one exception: Result(0)=MaxLine - ;" indent -- OPTIONAL. if numeric value, then subnodes WON't whitespace indent for pretty viewing - ;" otherwise, indent is string holding space to indent - ;"Result: none - - new i,s - set indent=$get(indent) - set i=$order(@pArray@("")) - if i'="" for do quit:(i="") - . set s="" if indent'=-1 set s=indent - . set s=s_""_$get(@pArray@(i)) - . set s=$$SYMENC^MXMLUTL(s) - . if $data(@pArray@(i))>1 do - . . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline - . . set @pResult@(@pResult@(0))=s - . . new subIndent set subIndent=-1 - . . if indent'=-1 set subIndent=indent_" " - . . do A2XNode($name(@pArray@(i)),pResult,subIndent) - . . set s="" if indent'=-1 set s=indent - . . set s=s_"" - . else do - . . set s=s_"" - . set @pResult@(0)=+$get(@pResult@(0))+1 ;"Increment maxline - . set @pResult@(@pResult@(0))=s - . set i=$order(@pArray@(i)) - - quit - - -Up(pArray) - ;"Purpose: Return a NAME of an array that is one level 'up' from the - ;" the current array. This really means one node shorter. - ;" e.g. '^MyVar('plant','tree','apple tree')' --> '^MyVar('plant','tree')' - ;"Results: returns shorten array as above, or "" if error - - new result set result="" - if $get(pArray)="" goto UpDone - set result=$qsubscript(pArray,0) - new i - for i=1:1:$qlength(pArray)-1 do - . set result=$name(@result@($qsubscript(pArray,i))) - -UpDone quit result - - -LaunchScreenman(File,FormIEN,RecIEN,Page) - ;"Purpose: to provide a programatic launching point for displaying a - ;" screenman form for editing a record - ;"Input: File -- the IEN of file to be edited - ;" FormIEN -- the IEN in file FORM (.403) - ;" RecIEN -- the IEN in File to edit - ;" Page -- OPTIONAL, default=1. The starting page of form. - ;"Note: Form should be compiled before calling the function. This can be - ;" achieved by running the form once from ^DDSRUN (or viat Fileman menu) - - new DDSFILE set DDSFILE=File - new DDSRUNDR set DDSRUNDR=FormIEN - new DDSPAGE set DDSPAGE=+$get(Page,1) - new DA set DA=RecIEN - - do REC+9^DDSRUN ;"this goes against SAC conventions. - - quit - - -NumSigChs() - ;"Purpose: To determine how many characters are signficant in a variable name - ;" I.e. older versions of GT.M had only the first 8 characters as - ;" significant. Newer versions allow more characters to be significant. - - new pVar1,pVar2,i - set pVar1="zb",i=2 - new done set done=0 - for do quit:done - . set i=i+1 - . set pVar2=pVar1_"b" - . set pVar1=pVar1_"a" - . new @pVar2,@pVar1 - . set @pVar1=7 - . if $get(@pVar2)=@pVar1 set done=1 - - quit (i-1) - - -SrchReplace(File,Field,Caption) - ;"Purpose: To do a text-based search and replace in all record of - ;" specified file, in the text of the specified file. - ;" Note: this does not work with pointer fields. It would - ;" fail to find the matching text in the pointer value and ignore it. - ;" It does not support subfiles. - ;"Input: File -- the file name or number to work with. - ;" Field -- the field name or number to work with - ;" Caption -- OPTIONAL. A descriptive text of action. - ;"Output: Data in records will be changed via Fileman and errors (if found) - ;" will be written to console. - ;"Results: none. - - if $get(File)="" goto SRDone - if $get(Field)="" goto SRDone - new OKToCont set OKToCont=1 - if +Field'=Field set OKToCont=$$SetFileFldNums^TMGDBAPI(File,Field,.File,.Field) - if OKToCont=0 goto SRDone - - if $get(Caption)'="" do - . write !,!,Caption,! - . write "----------------------------------------------------",!! - - new searchS,replaceS,% -SR1 - write "Enter characters/words to SEARCH for (^ to abort): " - read searchS:$get(DTIME,3600),! - if (searchS="")!(searchS="^") goto SRDone - write "REPLACE with (^ to abort): " - read replaceS:$get(DTIME,3600),! - if (replaceS="^") goto SRDone - write "'",searchS,"'-->'",replaceS,"'",! - set %=1 - write "OK" do YN^DICN write ! - if %=1 goto SR2 - if %=-1 goto SRDone - goto SR1 - -SR2 - new Itr,IEN,CurValue,abort,count - new ref set ref=$get(^DIC(File,0,"GL")) - set ref=$$CREF^DILF(ref) - if ref="" goto SRDone - new node set node=$piece($get(^DD(File,Field,0)),"^",4) - new piece set piece=$piece(node,";",2) - set node=$piece(node,";",1) - - set abort=0,count=0 - set IEN=$$ItrInit^TMGITR(File,.Itr) - do PrepProgress^TMGITR(.Itr,20,0,"IEN") - if IEN'="" for do quit:($$ItrNext^TMGITR(.Itr,.IEN)'>0)!abort - . if $$UserAborted^TMGUSRIF() set abort=1 quit - . set CurValue=$piece($get(@ref@(IEN,node)),"^",piece) - . if CurValue'[searchS quit -SR3 . new newValue set newValue=$$Substitute^TMGSTUTL(CurValue,searchS,replaceS) - . new TMGFDA,TMGMSG - . set TMGFDA(File,IEN_",",Field)=newValue - . do FILE^DIE("K","TMGFDA","TMGMSG") - . do ShowIfDIERR^TMGDEBUG(.TMGMSG) - . set count=count+1 - do ProgressDone^TMGITR(.Itr) - - write count," records changed",! - do PressToCont^TMGUSRIF - -SRDone - quit - - -MkMultList(input,List) - ;"Purpose: To create a list of entries, given a string containing a list of entries. - ;"Input: input -- a string of user input. E.g.: '345,3,12678,78-85,2' or '78-93' or '15' - ;" List -- PASS BY REFERENCE. An OUT PARAMETER. - ;"Output: List will be filled as follows: - ;" List(Entry number)="" - ;" List(Entry number)="" - ;" List(Entry number)="" - ;"Result: 1 if values found, 0 none found, or error encountered - - new result set result=0 - - new i - for i=1:1:$length(input,",") do - . new value set value=$piece(input,",",i) - . if +value=value do - . . set List(value)="" - . . set result=1 - . else if value["-" do - . . new n1,n2 - . . set n1=+$piece(value,"-",1) - . . set n2=+$piece(value,"-",2) - . . set result=$$MkRangeList(n1,n2,.List) - - quit result - - -MkRangeList(Num,EndNum,List) - ;"Purpose: To create a list of entries, given a starting and ending number - ;"Input: Num -- the start entry number - ;" EndNum -- OPTIONAL, the last entry number (if supplied then all values - ;" between Num and Endnum will be added to list - ;" List -- PASS BY REFERENCE. An OUT PARAMETER. - ;"Output: List will be filled as follows: - ;" List(Entry number)="" - ;" List(Entry number)="" - ;" List(Entry number)="" - ;"Result: 1 if value input found, otherwise 0 - - new result set result=0 - set EndNum=$get(EndNum,Num) - if (+Num'=Num)!(+EndNum'=EndNum) goto MkRLDone - - new i - for i=Num:1:EndNum do - . set List(i)="" - . set result=1 - -MkRLDone - quit result - - -Flags(Var,Flag,Mode) - ;"Purpose: To set,delete,or toggle a flag stored in Var - ;"Input: Var -- PASS BY REFERENCE. The variable holding the flags - ;" Flag -- a single character flag to be stored in Var - ;" Mode: should be: 'SET','DEL',or 'TOGGLE'. Default is 'SET' - ;"Results: none - - set Flag=$get(Flag,"SET") - set Var=$get(Var) - if $get(Mode)="TOGGLE" do - . if Var[Flag set Mode="DEL" - . else set Mode="SET" - if $get(Mode)="SET" do - . if Var[Flag quit - . set Var=Var_Flag - if $get(Mode)="DEL" do - . if Var'[Flag quit - . set Var=$piece(Var,Flag,1)_$piece(Var,Flag,2) - - quit - - -CompABArray(pArrayA,pArrayB,pExtraB,pMissingB,pDiff,ProgressFn,IncVar) - ;"Purpose: To compare two arrays, A & B, and return results in OutArray - ;" that specifies how ArrayB differs from ArrayA - ;"Input: pArrayA -- PASS BY NAME. Baseline array to be compared against - ;" pArrayB -- PASS BY NAME. Array to be compare against ArrayA - ;" pExtraB -- PASS BY NAME. An OUT PARAMETER. Array of extra info from B - ;" OPTIONAL. If not provided, then data not filled. - ;" pMissingB -- PASS BY NAME. An OUT PARAMETER. Array of missing info - ;" OPTIONAL. If not provided, then data not filled. - ;" pDiff -- PASS BY NAME. An OUT PARAMETER. Output as below. - ;" OPTIONAL. If not provided, then data not filled. - ;" @pOutArray@("A",node,node,node,...)=different value - ;" @pOutArray@("B",node,node,node,...)=different value - ;" ProgressFn -- OPTIONAL -- M code to exec as a progress indicator - ;" IncVar -- OPTIONAL -- a counter that can be referenced by ProgressFn - ;"Results: 0=OK, 1=aborted - - new indexA,indexB - - set IncVar=+$get(IncVar) - set ProgressFn=$get(ProgressFn) - set pExtraB=$get(pExtraB) - set pMissingB=$get(pMissingB) - set pdiff=$get(pDiff) - new abort set abort=0 - new Compared - - set indexA="" - for set indexA=$order(@pArrayA@(indexA)) quit:(indexA="")!abort do - . set IncVar=IncVar+1 - . if (IncVar#10=1),(ProgressFn'="") do quit:(abort) - . . new $etrap set $etrap="set $etrap="""",$ecode=""""" - . . xecute ProgressFn - . . write !,pArrayA,"(",indexA,") ",! do CUU^TMGTERM(2) ;"temp - . . if $$UserAborted^TMGUSRIF() set abort=1 quit - . if $data(@pArrayB@(indexA))=0 do quit - . . if (pMissingB'="") merge @pMissingB@(pArrayA,indexA)=@pArrayA@(indexA) - . new s1,s2 - . set s1=$get(@pArrayA@(indexA)) - . set s2=$get(@pArrayB@(indexA)) - . if s1'=s2 do - . . if pDiff="" quit - . . if $$TRIM^XLFSTR(s1)=$$TRIM^XLFSTR(s2) quit - . . set @pDiff@("A",pArrayA,indexA)=s1 - . . set @pDiff@("B",pArrayA,indexA)=s2 - . set abort=$$CompABArray($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)),.pExtraB,.pMissingB,.pDiff,.ProgressFn,.IncVar) - . set Compared($name(@pArrayA@(indexA)),$name(@pArrayB@(indexA)))=1 - - new temp set temp=1 - set indexB="" - for set indexB=$order(@pArrayB@(indexB)) quit:(indexB="")!abort do - . set temp=temp+1 - . if (temp#10=1) do quit:(abort) - . . write !,pArrayA,"(",indexB,") ",! do CUU^TMGTERM(2) ;"temp - . . if $$UserAborted^TMGUSRIF() set abort=1 quit - . if $data(@pArrayA@(indexB))=0 do quit - . . if (pExtraB'="") merge @pExtraB@(pArrayA,indexB)=@pArrayB@(indexB) - . if $get(Compared($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB))))=1 do quit ;"already checked - . . new temp - . set abort=$$CompABArray($name(@pArrayA@(indexB)),$name(@pArrayB@(indexB)),.pExtraB,.pMissingB,.pDiff) - - quit abort - - -FixArray(ref) - ;"Purpose: Convert an array like this: - ;" @ref@("^DD(2,.362)",21,1,0) --> @ref@("^DD",2,.362,21,1,0) - ;" @ref@("^DD(2,.362)",21,2,0) --> @ref@("^DD",2,.362,21,2,0) - ;" @ref@("^DD(2,.362)",23,0) --> @ref@("^DD",2,.362,23,0) - ;" @ref@("^DD(2,.362)",23,1,0) --> @ref@("^DD",2,.362,23,1,0) - ;" @ref@("^DD(2,0,""IX"")","ACFL2",2,.312) --> @ref@("^DD",2,0,"IX","ACFL2",2,.312) - ;" @ref@("^DD(2,0,""IX"")","AEXP",2,.351) --> @ref@("^DD",2,0,"IX","AEXP",2,.351) - ;" @ref@("^DD(2,0,""IX"")","TMGS",2,22701) --> @ref@("^DD",2,0,"IX","TMGS",2,22701) - ;" @ref@("^DD(2,0,""PT"")",228.1,.02) --> @ref@("^DD",2,0,"PT",228.1,.02) - ;" @ref@("^DD(2,0,""PT"")",228.2,.02) --> @ref@("^DD",2,0,"PT",228.2,.02) - ;" @ref@("^DD(2,0,""PT"")",19620.92,.08) --> @ref@("^DD",2,0,"PT",19620.92,.08) - ;" @ref@("^DD(2,0,""PT"",115)",.01) --> @ref@("^DD",2,0,"PT",115,.01) - ;"Input: ref -- PASS BY NAME - ;"Output: contents of @ref are converted as above. - ;"Results: none - - new origRef set origRef=ref - new output,s1,i - for set ref=$query(@ref) quit:(ref="") do - . set s1=$qsubscript(ref,1) - . new newRef set newRef="output" - . new startI set startI=1 - . if s1["(" do - . . set startI=2 - . . set newRef=newRef_"("""_$qs(s1,0)_""")" - . . if $qlength(s1)>1 for i=1:1:$qlength(s1) do - . . . set newRef=$name(@newRef@($qsubscript(s1,i))) - . for i=startI:1:$qlength(ref) do - . . new s3 set s3=$qsubscript(ref,i) - . . set newRef=$name(@newRef@(s3)) - . merge @newRef=@ref - - kill @origRef - merge @origRef=output ;"put changes back into original array - - quit - - -Caller(Code) - ;"Purpose: From call stack, return the location of the caller of the function - ;" Note this will not return the address of the function calling - ;" Caller, but instead, the address of the function before that - ;" in the stack. - ;" So a function (A) can call this routine to find out who called it (A). - ;"Input: Code -- OPTIONAL. PASS BY REFERANCE, AN OUT PARAMETER - ;" Filled with line of calling code. - set Code=$STACK($STACK-2,"MCODE") - new result set result=$STACK($STACK-2,"PLACE") - if result="" set result="?" - quit result - Index: cprs/branches/tmg-cprs/m_files/TMGPUTN0.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGPUTN0.m~ (revision 796) +++ (revision ) @@ -1,1339 +1,0 @@ -TMGPUTN0 ;TMG/kst/TIU Document Upload look-up function ;03/25/06; 5/2/10 - ;;1.0;TMG-LIB;**1**;04/25/04 - - ;"TIU Document Upload look-up function - - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"4-25-2004 - - -LOOKUP(DocTitle,Autosign) ; - ;"----------------------------------------------------------------------------------- - ;"Upload look-up function - ;"by Kevin Toppenberg - ;"4-25-2004 - ;" - ;"PURPOSE: - ;"This code is used as look-up code by the TIU document upload routines. - ;"It has a very specific purpose. It was written for uploading documents - ;" from a Medic EMR system. Notes had been dumped out of that system, and - ;" were to be ported into VistA - ;"Each note has a header with patient name, dob, ssnum, chart#, provider - ;"Addendum -- this code will also work with less extensive patient data. - ;" - ;"INPUT - ;" The variable (with global scope) listed below are expected as input. - ;" Not all will be required every time, however. - ;" DocTitle -- this is the type of document type. i.e. 'OFFICE VISIT' - ;" This will be used so that this code can service multiple - ;" types, i.e. NOTE, PRESCRIPTION CALL IN, etc. - ;" Autosign -- [OPTIONAL] if value=1 then document will be created as SIGNED - ;"Results: Document number that uploaded code should be put into is returned in variable Y - ;" - ;" - ;"*How it works*: - ;"A remote computer connects to the server running VistA. This remote computer must be - ;" able to upload a file using kermit. The only way I know to do this is to be on a PC - ;" using a terminal emulator program that has kermit upload ability. - ;"From this remote session, get into the TIU menu system and navigate to the option to - ;" upload a document. Note, one's upload parameters must be set up for this to work. - ;"The remote user will see a #N3, and use this que to acutally upload the file. - ;"After the file is uploaded, it is then processed. Each document specifies what 'type' it is - ;" for example 'OFFICE VISIT' - ;"The server then loads up the parameters for OFFICE VISIT and processes each item in the header. - ;"Here is an example progress note that this file can process - ;"-------------------------------------- - ;"[NewDict]: OFFICE VISIT - ;"Name: JONES,BASKETBALL - ;"Alias: JONES,BOB - ;"DOB: 4/13/71 - ;"Sex: MALE - ;"SSNumber: 555 11 9999 - ;"ChartNumber: 10034 - ;"Date: 7/22/2002 - ;"Location: Peds_Office - ;"Provider: KEVIN TOPPENBERG MD - ;"[TEXT] - ;" - ;" CHIEF COMPLAINT: Follow up blood clot. - ;" - ;" HPI: - ;" 1. BJ was in the emergency room 3 days ago. He was being - ;" evaluated for left lower extremity pain. He said that they did - ;" radiographic studies and told him that he had a blood clot in - ;" .... (snip) - ;" - ;"[END] - ;"-------------------------------------- - ;"[NewDic] tells the system that a document header is starting - ;"'Name' is a CAPTION, and the value for this caption is 'JONES,BASKETBALL' - ;"The upload system will put this value into a variable. In this case, I specified - ;" that the variable name TMGNAME to be used. - ;" - ;"Here are each caption and its cooresponding Variable: - ;"Name <--> TMGNAME - ;"DOB <--> TMGDOB - ;"Sex <--> TMGSEX - ;"SSNumber <--> TMGSSNUM - ;"ChartNumber <--> TMGPTNUM - ;"Date <--> TIUVDT - ;"Provider <--> PERSON - ;"Alias <--> TMGALIAS - ;"Location: <--> TIULOC - ;" - ;"Document Title is passed to function as 'DocTitle' - ;" - ;"After the note has been processed and all the above variables have been set, the server - ;"calls a 'look-up' function. This function is supposed to return the document number where the - ;"text is supposed to be put (the number should be put in Y) - ;" - ;"This look-up function has an extra twist. I am using it to register patients on the fly - ;" if needed. I am doing this because I had about 30,000 patients in my database to transfer, - ;" and I had difficulty getting a separate file with just demographics etc. So, if a patient - ;" is not already in the database, they are registered here. - ;" - ;"Extra note: - ;"When this function is called, the TIU upload process has already set up some variables. - ;"DA = the IEN in 8925.2, i.e. ^TIU(8925.2,DA,"TEXT",0) that the uploaded text was temporarily store in. - ;" In other words, here DA = the serial index number of the document to be uploaded - ;" i.e. 1 for the first, 2 for the second etc. - ;"TIUI = the line index of the beginning of the report to be processed (i.e. the line - ;" that starts with [TEXT] - ;"DUZ = Current user number. - ;"TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params - ;"TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. - - write "+-------------------------------------+",! - write "| Starting upload code... |",! - write "+-------------------------------------+",! - - set BuffNum=$get(DA) ;"Store which upload buffer we are working on. - set BuffIdx=$get(TIUI) ;"Store line number (in upload buffer) we are starting with. - new cMaxNoteWidth set cMaxNoteWidth=60 - - ;"Field (f) constants - new fPatient set fPatient=.02 ;"field .02 = PATIENT - new fVisit set fVisit=.03 ;"field .03 = VISIT - new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE - new fStatus set fStatus=.05 ;"field .05 = STATUS - new fParent set fParent=.06 ;"field .06 = PARENT - new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) - new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) - new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME - new fAuthor set fAuthor=1202 ;"field 1202 = PERSON/DICTATOR - new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer - new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION - new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner - new fAttending set fAttending=1209 ;"field 1209 = ATTENDING - new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION - new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE - new fEnteredBy set fEnteredBy=1302 ;"field 1302 = ENTERED BY (a pointer to file 200) - new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' - new fService set fService=1404 ;"field 1404 = SERVICE - new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by - new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. - new fCharTrans set fCharTrans=22711 ;"field 22711 = CHAR COUNT -- TRANSCRIPTIONIST - new fLineCount set fLineCout=.1 ;"field .1 = LINE COUNT - - ;" Piece (p) constants - new pPatient set pPatient=2 ;"Node 0,piece 2 = PATIENT (field .02) - new pVisit set pVisit=3 ;"Node 0,piece 3 = VISIT (field .03) - new pStrtDate set pStrtDate=7 ;"Node 0,piece 7 = EPISODE BEGIN DATE/TIME (field .07) - new pEndDate set pEndDate=8 ;"Node 0,piece 8 = EPISODE END DATE/TIME (field .08) - new pExpSigner set pExpSigner=4 ;"Node 12,piece 4 = EXPECTED SIGNER (field 1204) - new pHospLoc set pHospLoc=5 ;"Node 12,piece 5 = HOSPITAL LOCATION (field 1205) - new pExpCosign set pExpCosign=8 ;"Node 12,piece 8 = EXPECTED COSIGNER (field 1210) - new pAttending set pAttending=9 ;"Node 12,piece 9 = ATTENDING PHYSICIAN (field 1209) - new pService set pService=4 ;"Node 14,piece 4 = SERVICE (field 1404) - - if $data(cAbort)#10=0 new cAbort set cAbort=0 - - new DBIndent,PriorErrorFound - new Patient - new DocIEN set DocIEN=-1 - new Document - new NewDoc set NewDoc=0 - new result set result=1 ;"cOKToCont - - do PtArrayCreate(.Patient) ;"Load upload info into Patient array - set result=$$DocArrayCreate(.Document) ;"Load upload document info into Document array - if result=cAbort goto LUDone - set Document("DFN")=$$GetDFN^TMGGDFN(.Patient) ;"Store DFN of patient. - if Document("DFN")'>0 set result=cAbort goto LUDone ;"Abort. - set Document("AUTO SIGN")=$get(Autosign,1) ;"default to YES auto-signing - ;"06-19-05 Changed to disable autosigning. If document is - ;" autosigned here, then no prompt for printing elsewhere. - ;"9-1-05 Resuming autosigning. Currently the outside transcriptionists are already - ;" printing the notes before giving them to us for upload. - ;" Changed default to be YES autosign - ;"set Document("AUTO SIGN")=0 ;"override setting passed in... - - set Document("CHARACTER COUNT - TRANSCRIPTIONIST'S")=$$BuffCharCount() ;"Count character prior to any wrapping/merging etc. - set result=$$PrepUploadBuf() ;"Do any word-wrapping etc needed in upload buffer - if result=cAbort goto LUDone - set DocIEN=$$PrepDoc(.Document,.NewDoc) ;"Prepair a document to put upload into. Credits transcription - - set Y=DocIEN - merge TMGDOC=Document ;"Create a global -- will kill after followup code -LUDone - ;"put result into Y. TIU filing system looks for results in Yi - if result=cAbort set Y=-1 - - quit - - - - ;"----------------------------------------------------------------------------------------------- - ;"==============================================================================================- - ;" S U B R O U T I N E S - ;"==============================================================================================- - ;"----------------------------------------------------------------------------------------------- - ;"PtArrayCreate(Array) - ;"DocArrayCreate(Document) - ;"PrepDoc(Document,NewDoc); - ;"GetDocTIEN(Title) - ;"GetLocIEN(Location) - ;"GetService(IEN) - ;"GetProvIEN(Provider) - ;"GetRecord(Document,NewDoc,AskOK,Editable) - ;"DocExists(Document) - ;"BuffCharCount() - ;"PrepUploadBuf() - - ;"NeedsReformat(MaxWidth) - ;"CutNote(Array) - ;"PasteNote(Array,NextNoteI) - ;"CompToBuff(ExistingIEN,UplTIEN,UplDate) - ;"CreateRec(Document) ; - ;"StuffRec(Document,PARENT) - ;"MakeVisit(Document) - ;"FOLLOWUP(DocIEN) ;Post-filing code for PROGRESS NOTES - - -PtArrayCreate(Array) - ;"SCOPE: Private - ;"Purpose: To put global scope vars (i.e. TMGNAME,TMGSSNUM etc) into - ;" an array for easier portability - ;"Input: Array, must be passed by reference - ;" The global-scope variables setup by the upload system, and are used here: - ;" TMGPTNUM,TMGSSNUM,TMGSSNUM,TMGNAME,TMGDOB,TMGSEX - ;"Output: Array is loaded with info, like this: - ;" set Array("SSNUM")="123-45-6789" - ;" set Array("NAME")="DOE,JOHN" - ;" set Array("DOB")=TMGDOB - ;" set Array("PATIENTNUM")="12345677" - ;" set Array("SEX")="M" - ;" set Array("ALIAS")="DOE,JOHNNY" - ;"Results: none - - if $data(TMGPTNUM)#10'=0 do - . set TMGPTNUM=$translate(TMGPTNUM,"PWCI*","") ;"Clean off alpha characters -- not needed. - . ;"set TMGPTNUM=$$Trim^TMGSTUTL(TMGPTNUM) - . set TMGPTNUM=$$FORMAT^DPTNAME(.TMGPTNUM,3,30) ;"Use same input transform as for .01 field of PATIENT file - . set Array("PATIENTNUM")=TMGPTNUM - - if $data(TMGSSNUM)#10'=0 do - . set TMGSSNUM=$translate(TMGSSNUM," /-","") ;"Clean delimiters - . if +TMGSSNUM=0 set TMGSSNUM="" ;was ... "P" - . if (TMGSSNUM="P")!(+TMGSSNUM>0) set Array("SSNUM")=TMGSSNUM - - set Array("NAME")=$$FormatName^TMGMISC(.TMGNAME) - - if $data(TMGALIAS)#10'=0 do - . set TMGALIAS=$translate(TMGALIAS,"*","") - . set TMGALIAS=$$FORMAT^DPTNAME(TMGALIAS,3,30) ;"convert to 'internal' format (strip .'s etc) - . set Array("ALIAS")=TMGALIAS - - if $data(TMGSEX)#10'=0 do - . set TMGSEX=$$UP^XLFSTR($get(TMGSEX)) - . if TMGSEX="M" set TMGSEX="MALE" - . else if TMGSEX="F" set TMGSEX="FEMALE" - . set Array("SEX")=TMGSEX - - if $data(TMGDOB)#10'=0 do - . if +TMGDOB>0 set Array("DOB")=TMGDOB - . else quit - . new CurDate,CurYr - . do DT^DILF("E","T",.CurDate) - . set CurDate=$get(CurDate(0)) - . if CurDate="" quit - . set CurYr=$piece(CurDate,", ",2) - . new DOBYr - . set DOBYr=$piece(TMGDOB,"/",3) - . if DOBYr>CurYr do ;"we have a Y2K problem - . . set DOBYr=DOBYr-100 - . . if DOBYr'>0 quit - . . set TMGDOB=$piece(TMGDOB,"/",1,2)_"/"_DOBYr - . . set Array("DOB")=TMGDOB - - quit - - - -DocArrayCreate(Document) - ;"SCOPE: Private - ;"Purpose: To put TIUVDT etc. etc into an array for easier portibility - ;"Input: Document -- OUT parameter, must be passed by reference - ;" The global-scope variables setup by the upload system are used: - ;" TIUVDT,PERSON,TIULOC, (and also DocTitle) - ;"Output: Document is loaded with info. - ;"Results: 1=OKToCont, or cAbort - - new result set result=1 ;"cOKToCont - - set Document("PROVIDER")=$get(PERSON) - if Document("PROVIDER")="" do goto DACDone - . set result=cAbort - set Document("PROVIDER IEN")=$$GetProvIEN(Document("PROVIDER")) - set Document("LOCATION")=$get(TIULOC,"Main_Office") - set Document("DATE")=$get(TIUVDT) - set Document("TITLE")=$get(DocTitle,"NOTE") - - ;"Decide which transcriptionist is. This will be used for crediting productivity. - ;"If transcriptionist not specified, current user (DUZ) is assumed. - if $data(TMGTRANS)#10=0 set TMGTRANS=$piece($get(^VA(200,DUZ,0)),"^",1) - set Document("TRANSCRIPTIONIST")=$$FormatName^TMGMISC(TMGTRANS) - - if (Document("DATE")="")!(Document("DATE")="00/00/00") do goto DACDone - . set result=cAbort - -DACDone - quit result - - - -PrepDoc(Document,NewDoc); - ;"Scope: PRIVATE. - ;" Addendum 7/25/07. Will be called by RPC call BLANKTIU^TMGRPC1 - ;" to return a blank document - ;"Purpose: Prepair a document to put upload into. - ;"Input: Document -- an array as follows: - ;" Document("DFN")=DFN, the record number of the patient. - ;" Document("PROVIDER IEN")= the IEN of the provider - ;" Document("LOCATION")= the location of the visit - ;" Document("DATE")= the date of the visit. - ;" Document("TITLE")= the title of the note - ;" Document(cVisitStr) an OUT PARAMETER - ;" Document("TRANSCRIPTIONIST") -- the name of the transcriptionist - ;" Document("CHARACTER COUNT - TRANSCRIPTIONIST'S") -- the char count creditable to transcriptionist - ;" NewDoc: OPTIONAL flag, passed back with - ;" NewDoc = 1 if returned docmt is new - ;" NewDoc = 0 if returned docmt already existed, timeout, etc - ;"Results: returns record number (IEN) ready to accept upload (or -1 if failure) - ;" Also Document("DOC IEN") will have this same IEN - ;" NOTE: if result is -1 then errors are passed back in - ;" Document("ERROR") node - ;" Document("ERROR",n)="ERROR.. Stuffing new document." - ;" Document("ERROR","NUM")=n - ;" Document("ERROR","FM INFO")=merge with DIERR array - - ;" PIEN = patient internal entry number - ;" Global-Scope variables expected: - ;" PERSON, TMGSSNUM etc. defined above - ;" TIUVDT expected - ;" TIULOC is also expected (i.e. 'LAUGHLIN_OFFICE') - ;" - ;"Output: will return document number, or -1 if failure. - ;"NOTES: This originated from ^TIUPUTPN - ;" - ;" Look-up code used by router/filer - ;" Required variables: TMGSSNUM, TIUVDT - ;" i.e., TMGSSNUM (Pt SS-Number) and TIUVDT (visit date) must be set prior to call. - ;" - - new cStartDate set cStartDate="EDT" - new cEndDate set cEndDate="LDT" - new cService set cService="SVC" - new cDocType set cDocType="TYPE" - new cDocTIEN set cDocTIEN="TYPE IEN" - new cHspLocIEN set cHspLocIEN="LOC" - new cVstLocIEN set cVstLocIEN="VLOC" - new cVisitStr set cVisitStr="VSTR" - new cVisitIEN set cVisitIEN="VISIT" - new cStopCode set cStopCode="STOP" - - new TMG,DFN - new TIUDAD,TIUEDIT - new TIULDT,TIUXCRP,DocTIEN - new LocIEN - new result set result=-1 - set NewDoc=0 - - set Document(cStartDate)=$$IDATE^TIULC(Document("DATE")) ;"Convert date into internal format - set Document(cEndDate)=Document(cStartDate) ;"For office notes, begin and end dates will be the same. - - ;"Setup DocTIEN -- to be used below as [MAS Movement event type] - ;"Convert Document title into IEN, i.e. OFFICE VISIT --> 128 - set DocTIEN=$$GetDocTIEN(Document("TITLE")) - if +DocTIEN'>0 do goto PrepDocX - . set Document("ERROR",1)="ERROR: Unable to determine note type from title: "_Document("TITLE") - . set Document("ERROR","NUM")=1 - - ;"Purpose: setup Document(cDocType) -- used below as: Title info variable of form: - ;" Setup string in form of: 1^title IEN^title Name - ;" e.g.: 1^128^OFFICE VISIT^OFFICE VISIT - set Document(cDocTIEN)=DocTIEN - set Document(cDocType)=1_"^"_DocTIEN_"^"_$$PNAME^TIULC1(DocTIEN) - - ;"do MAIN^TIUVSIT(.TIU,.DFN,TMGSSNUM,Document(cStartDate),Document(cEndDate),"LAST",0,Document("LOCATION")) - - ;" setup LocIEN from HOSPITAL LOCATION file (#44) - ;" This contains entries like 'Laughlin_Office' - set LocIEN=+$$GetLocIEN(Document("LOCATION")) - if '$data(^SC(LocIEN,0)) do goto PrepDocX ;"^SC(*) is file 44, Hospital Location - . set Document("ERROR",1)="ERROR: Unable to process location: "_Document("LOCATION") - . set Document("ERROR","NUM")=1 - - set Document(cService)=$$GetService(Document("PROVIDER IEN")) ;"i.e. FAMILY PRACTICE - set Document(cVisitStr)="x;x;"_DocTIEN ;"LOC;VDT;VTYP - set Document(cVisitIEN)=0 ;"Visit File IFN - set Document(cHspLocIEN)=LocIEN - set Document(cVstLocIEN)=LocIEN - set Document(cStopCode)=0 ;"0=FALSE, don't worry about stop codes. - - set result=$$GetRecord(.Document,.NewDoc,0) - if result'>0 do goto PrepDocX - . new n set n=+$get(Document("ERROR","NUM"))+1 - . set Document("ERROR",n)="ERROR.. after creating new document." - . set Document("ERROR","NUM")=n - - ;"At this point, any merging has been done (once implemented) - ;"So a character count of now will be a total/combined character count - set Document("CHAR COUNT - TOTAL")=$$BuffCharCount ;"Count character after any wrapping/merging etc. - ;"Now, we need the standard CHARARACTERS/LINE value stored in field .03 of TIU PARAMETERS (in ^TIU(8925.99)) - ;"For my setup, I have only have one record for in this file, so I'll use IEN=1. - new CharsPerLine set CharsPerLine=$piece($get(^TIU(8925.99,1,0)),"^",3) - if CharsPerLine'=0 do - . new IntLC,LC,Delta - . set LC=Document("CHAR COUNT - TOTAL")\CharsPerLine - . set IntLC=Document("CHAR COUNT - TOTAL")\CharsPerLine ;" \ is integer divide - . set Delta=(LC-IntLC)*10 - . if Delta>4 set IntLC=IntLC+1 ;"Round to closest integer value. - . set Document("LINE COUNT")=IntLC - - set result=$$StuffRec(.Document,0) ;"Will load Document("ERROR","FM INFO") with any FM errors - if +$get(result)'>0 do goto PrepDocX - . new n set n=+$get(Document("ERROR","NUM"))+1 - . set Document("ERROR",n)="ERROR.. Stuffing new document." - . set Document("ERROR","NUM")=n - -PrepDocX - quit result ;"result is document # - - -MakeVisit(Document) - ;"Purpose -- to create a new entery in the VISIT file, based on info in Document. - ;"Input -- Document -- array with following info: - ;" Document("DFN")=DFN, the record number of the patient. - ;" Document("PROVIDER")= the provider of care for the note - ;" Document("PROVIDER IEN")= the IEN of the provider - ;" Document("LOCATION")= the location of the visit - ;" Document("DATE")= the date of the visit. - ;"Result -- returns IEN of visit entry - - ;"Note -- this function is not now being used... - - new TMGFDA - ;set TMGFDA(9000010,"?+1,",.01)= ;".01=VISIT/ADMIT DATE&TIME - ;set TMGFDA(9000010,"?+1,",.02)= ;".02=DATE VISIT CREATED - ;set TMGFDA(9000010,"?+1,",.03)="O" ;".02=VISIT TYPE -- O=Other - ;set TMGFDA(9000010,"?+1,",.05)= ;".05=PATIENT NAME - ;set TMGFDA(9000010,"?+1,",15001)="10C1-TEST" ;"15001=VISIT ID - ;LOCATION NAME --> Medical Group of Greeneville - ;SERVICE CATEGORY: A --> AMBULATORY - ;DSS ID: PRIMARY CARE/MEDICINE - ;HOSPITAL LOCATION: Laughlin_Office - ;Created by user: DUZ - quit - - -GetDocTIEN(Title) - ;"Purpose: To return IEN for document *type defination* / Identify document title - ;"Input Title -- the Text Title to look up - ;"Results: Returns the document definition IFN (i.e. Y) - - new DIC,Y,X - new TIUFPRIV set TIUFPRIV=1 - - set DIC=8925.1 - set DIC(0)="M" - set DIC("S")="IF $PIECE(^TIU(8925.1,+Y,0),""^"",4)=""DOC""" - set X=Title - do ^DIC - kill DIC("S") - if $find(Y,"^")>0 set Y=$piece(Y,"^",1) - - quit Y - - -GetLocIEN(Location) - ;"Scope: PRIVATE - ;"Purpose: To return IEN for location - ;"Input: Location -- the Location to look up. - ;"Results: returns LocationIEN (i.e. Y) - - new DIC,X,Y - set DIC=44 ;"file 44 is HOSPITAL LOCATION - set DIC(0)="M" - set X=Location - do ^DIC ;" do a , value is returned in Y - if $find(Y,"^")>0 set Y=$piece(Y,"^",1) - - quit Y - - -GetService(IEN) - ;"Scope: PRIVATE - ;"Purpose: Get the Service for the Provider - ;"Input: IEN -- the IEN of the Provider to look up. - ;"Results: returns the Name of the Service for provider, or "" if not found - - new result set result="" - new node,SvIEN - - if IEN=-1 goto GtSvDone - set node=$get(^VA(200,IEN,5)) ;"^VA(200, is NEW PERSON file - set SvIEN=+$piece(node,"^",1) - if SvIEN=0 goto GtSvDone - set node=$get(^DIC(49,SvIEN,0)) ;"^DIC(49, is the SERVICE/SECTION file - set result=$piece(node,"^",1) - -GtSvDone - quit result - - -GetProvIEN(Provider) - ;"Scope: PRIVATE - ;"Purpose: To return IEN for Provider - ;"Input: Provider -- the Provider to look up. - ;"Results: returns Provider's IEN (i.e. Y), or -1 if not found - - new DIC,X,Y - set DIC=200 ;"file 200 is NEW PERSON - set DIC(0)="M" - set X=Provider - do ^DIC ;" do a , value is returned in Y - if $find(Y,"^")>0 set Y=$piece(Y,"^",1) - - quit Y - - -GetRecord(Document,NewDoc,AskOK,Editable) - ;"Scope: PRIVATE - ;"PURPOSE: - ;" To get a record--either via creating a new one, or returning an existing one - ;" Note: If an existing one is returned, it will be emptied first... - ;" - ;" Note: If I want to merge part of what the doctor creates with what the - ;" transcriptionist uploads, here what I should do - ;" 1. Look for an existing document with same date as document being uploaded. - ;" 2. If found, look in existing document for merge symbols (i.e. {{1}} } - ;" 3. If found, then take code from existing document and current part - ;" of upload buffer, and create a merged document. - ;" 4. Put this merged document back into the upload buffer. - ;" 5. Empty the existing document, and return its IEN from this function - ;" - ;"INPUT: Document -- array with Document("DFN"), Document(cDocType) are REQUIRED. - ;" [Document] --> Visit info array -- SHOULD PASS BE REFERENCE. - ;" Document("DFN") = patient DFN - ;" Document(cVisitStr) = LOC;VDT;VTYP e.g. 'x;x;OFFICE VISIT' - ;" Document(cVisitIEN) = VISIT file IFN e.g. 0, used for field .03 in file 8925. Pointer to file #9000010 - ;" Document(cHspLocIEN) i.e. Hospital location IEN. Used for field 1205 in 8925. Pointer to file #44 - ;" Document(cVstLocIEN) i.e. visit location IEN. Used for field 1211 in 8925. Pointer to file #44 - ;" Document(cStopCode) = mark to defer workload e.g. 0/FALSE=don't worry about stop codes. - ;" USED FOR: Mark record for deferred crediting of stop code (fld #.11) - ;" This boolean field (.11) indicates whether the stop code associated with a new - ;" visit should be credited when the note is completed. - ;" Note: if Document('STOP')="", then not processed. - ;" Document(cDocType)=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT - ;" Document(cDocTIEN)=DocTIEN (a.k.a. title DA) e.g. 128 - ;" Document(cService) e.g.FAMILY PRACTICE - ;" Document(cStartDate) i.e. event begin time - ;" Document(cEndDate) i.e. event end time - ;" [NewDoc] --> flag, passed back with - ;" NewDoc = 1 if returned docmt is new - ;" NewDoc = 0 if returned docmt already existed, timeout, etc - ;" [AskOK] --> Ask user flag, where - ;" AskOK = 1: ask re edit/addend existing docmt - ;" (Interactive List Manager options, TRY docmt def) - ;" AskOK = 0: don't ask (Upload & GUI options) - ;" [Editable]-->flag, passed back with Editable = 1 if returned - ;" PREEXISTING docmt can be edited by Provider. If - ;" preexisting docmt returned and 'Editable, then - ;" docmt cannot be edited by Provider. - ;" - ;"Results: Returns DocIEN -- IEN of document to use, or -1 if error etc. - ;" Also, Document("DOC IEN") is set to DocIEN - ;" Errors will be returned in Document("ERROR") - ;" - ;"Note: Code originally from GETRECNM^TIUEDI3 -- KT 5/25/04 - - new MultOK set MultOK=1 - new DocIEN set DocIEN=-1 - set NewDoc=0 - - if +$get(BuffNum)'=0 set DocIEN=$$DocExists(.Document) ;"avoid error with RPC calls - else set DocIEN=0 - set Document("DOC IEN")=DocIEN - if DocIEN>0 do goto GRDone ;"DocIEN>0 means that the TEXT of the report is an exact match - . kill ^TIU(8925,DocIEN,"TEXT") ;"Kill the TEXT prior report, so we can overwrite it - else do - . set DocIEN=$$CreateRec(.Document) - . set NewDoc=1 - -GRDone ; - if NewDoc,DocIEN'>0 set NewDoc=0 - set Document("DOC IEN")=DocIEN - quit DocIEN ;"DocIEN is document number - - -DocExists(Document) - ;"PURPOSE: To return document IEN, if it already EXISTS for the - ;" given patient, title, and visit. - ;"INPUT: Document -- see documentation of format in $$GetRecord - ;"Results: returns a value for document (i.e. DocIEN), or -1 if no prior doc is found. - ;" - ;"Note: The following documents are ignored: - ;" - docmts of status deleted or retracted - ;" - all docmts if run across a docmt w/ requesting pkg - ;" - If REQEDIT, then also ignore docmts PERSON cannot edit. - ;"Note: If there are more than one, get the smallest DA. - - new DocIEN set DocIEN=-1 - new index - - if $data(^TIU(8925,"C",Document("DFN")))=0 goto DEDone - ;"Scan through all documents for patient (DFN) - set index=$order(^TIU(8925,"C",Document("DFN"),"")) - if index="" goto DEDone - for do quit:(index="") - . new DocCompValue - . set DocCompValue=$$CompToBuff(index,Document(cDocTIEN),Document(cStartDate)) - . if DocCompValue=2 do quit ;"i.e. documents are an exact match - . . ;"For below, the document is the same as the upload buffer. - . . ;"We have found our answer. - . . ;" - . . ;"Below is code I can use to check to see if I SHOULD be editing. - . . ;"------------------------------------------------------ - . . ;"new CANEDIT,CANDel - . . ;"set CANEDIT=+$$CANDO^TIULP(index,"EDIT RECORD",Document("PROVIDER IEN")) - . . ;"set CANDel=+$$CANDO^TIULP(index,"DELETE RECORD",Document("PROVIDER IEN")) - . . ;"if +CANEDIT>0 set DocIEN=index - . . set DocIEN=index set index="" quit - . set index=$order(^TIU(8925,"C",Document("DFN"),index)) - -DEDone - quit DocIEN - - -BuffCharCount() - ;"Purpose: To count the number of characters in the current upload buffer, for the - ;" current document. The upload buffer puts all the documents being uploaded - ;" into one big WP array. This function will count down until the text - ;" signal is found to start the next documnent (e.g. '[NewDict]') - ;"Input: none. However, several global-scope variables are used. - ;" By tracing through the upload code I know that - ;" the following variables are set: - ;" (I saved DA as BuffNum, and TIUI as BuffIdx) - ;" TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params - ;" TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. - ;" BuffIdx = the line index of the beginning of the report to be processed (i.e. the line - ;" that starts with [TEXT] - ;" BuffNum = the index in 8925.2, i.e. ^TIU(8925.2,BuffNum,"TEXT",0) - ;" In other words, here BuffNum = the serial index number of the document to - ;" be uploaded i.e. 1 for the first, 2 for the second etc. - ;"Notes - ;" 8925.2 is file: TIU UPLOAD BUFFER - ;" To detect the beginning of the next document, use - ;" if MyLine[TIUHSIG then abort - ;" I trim of leading and trailing white-space before counting. - ;" But, otherwise spaces will be counted - ;" - ;"Results: Returns character count, or 0 if none found. - - new index - new result set result=0 - if $get(TIUHSIG)="" goto BuffCDone - - set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) - for do quit:(index="") - . if index="" quit - . new s set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) - . if s="" set index="" quit - . if s[TIUHSIG set index="" quit - . set s=$$Trim^TMGSTUTL(.s) - . set result=result+$length(s) - . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) - -BuffCDone - quit result - - - -PrepUploadBuf() - ;"Purpose: Ensure upload buffer is ready for processing - ;"Background: Transcriptionist will upload a large document containing - ;" multiple notes for different patients etc. This entire large - ;" document is stored in the TIU UPLOAD BUFFER file (8925.2) - ;" When this filer code is called, the TIU upload process has already - ;" set up some variables. - ;" DA = the IEN in 8925.2, i.e. ^TIU(8925.2,DA,"TEXT",0) that - ;" the uploaded text was temporarily store in. - ;" (I save DA as BuffNum) - ;" TIUI = the line index of the beginning of the report to - ;" be processed (i.e. the line that starts with [TEXT]) - ;" (I save TIUI as BuffIdx) - ;" TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params - ;" TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. - ;" - ;" I found that transcriptionists were using word-processors that automatically - ;" wrapped the text to a next line. Thus paragraphs were being uploaded as - ;" one very long line. Rather than try to reeducate them to consistantly hit - ;" enter at the end of every line, I chose to automatically wrap the text to - ;" a set width. - ;" - ;" A global-scope var: cMaxNoteWidth is expected to be defined/ - ;" - ;" So, to prepair the upload buffer, I use these steps: - ;" 1. Scan the part of the upload buffer pertaining to the - ;" current note being processed - ;" - This starts with line BuffIdx, and ends with... - ;" - the line containing TIUHSIG (or end of buffer) - ;" See if any line is longer than cMaxNoteWidth characters. - ;" If so, mark for wrapping. - ;" 2. If wrapping needed, extract note to a temporary array - ;" 3. Perform reformatting/wrapping on temp array. - ;" 4. Put temp array back into Upload buffer - ;" - ;"Input: None, but global-scope vars used (see above) - ;"Output: Upload buffer may be changed - ;"Result: 1=OKToCont or cAbort - - new result set result=1 - if $$NeedsReformat(cMaxNoteWidth) do - . new CurNote - . new NextNoteI - . new DoSpecialIndent set DoSpecialIndent=1 ;"I.e. use hanging indents.) - . set NextNoteI=$$CutNote(.CurNote) - . do WordWrapArray^TMGSTUTL(.CurNote,cMaxNoteWidth,DoSpecialIndent) - . set result=$$PasteNote(.CurNote,NextNoteI) -PULBFDone - quit result - - -NeedsReformat(MaxWidth) - ;"Purpose: To scan the single note being processed, to see if - ;" it is too wide (i.e. any line of length > MaxWidth - ;" I had to do this because transcriptionists were using - ;" a wordprocessor that wrapped lines. Then when uploaded - ;" each paragraph became one long line. - ;" Also, will fix extended ASCII characters - ;"Input: MaxWidth The max length of any line (i.e. 80 for 80 chars) - ;" Also depends on global-scope vars - ;"Result: 1= A line was found that is > MaxWidth - ;" 0= no long lines found - - new index - new result set result=0 - if $get(TIUHSIG)="" goto NRFMDone - if $get(MaxWidth)'>0 goto NRFMDone - - set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) - if index'="" for do quit:(index="") - . new s - . set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) - . if s="" set index="" quit - . ;"9/19/06 Added to remove extended ASCII characters - . ;"set s=$translate(s,$c(146)_$c(246)_$c(150)_$c(147)_$c(148),"'--""""") - . if s[TIUHSIG set index="" quit - . if $length(s)>MaxWidth do quit - . . set result=1 - . . set index="" - . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) - -NRFMDone - quit result - - -CutNote(Array) - ;"Purpose: To extract the current note out of the entire upload buffer - ;"Input: Array -- MUST BE PASSED BY REFERENCE. This is an OUT parameter - ;" Array will be loaded with the note, with the first line being - ;" put into Array(1) - ;" Depends on global-scope vars BuffIdx, BuffNum, TIUHSIG, set up elsewhere. - ;"Note: This function empties the lines in TIU UPLOAD BUFFER as it cuts out note. - ;"Result: Returns: - ;" #: index of line containing start of next note. - ;" -1: Error - ;" 0: Note is the last one in the upload buffer, so no next note found - - new index - new LastI set LastI=0 - new result set result=-1 - kill Array - if $get(TIUHSIG)="" goto ExNDone - new ArrayI set ArrayI=0 - new s - new Done set Done=0 - - set index=$order(^TIU(8925.2,BuffNum,"TEXT",BuffIdx)) - - if index'="" for do quit:(index="")!(Done=1) - . set s=$get(^TIU(8925.2,BuffNum,"TEXT",index,0)) - . if s[TIUHSIG set Done=1 quit - . set ArrayI=ArrayI+1 - . set Array(ArrayI)=s - . kill ^TIU(8925.2,BuffNum,"TEXT",index) - . set LastI=index - . set index=$order(^TIU(8925.2,BuffNum,"TEXT",index)) - - set result=+index - if result=0 set result=LastI -ExNDone - quit result - - - -PasteNote(Array,NextNoteI) - ;"Purpose: To put Array back into the upload buffer, at the correct location, - ;"Input: Array -- Best if PASSED BY REFERENCE. - ;" Array is expected to be loaded with the note, with the first line Array(1) - ;" NextNoteI: This is the index, in upload buffer, of the start of the next note. - ;"Depends on global-scope vars BuffIdx, BuffNum, TIUHSIG, set up elsewhere. - ;"Result: 1=OKToCont if all OK, or cAbort if error - - new EntireBuf - new IndexInc set IndexInc=0.01 ;"WP^DIE does not require integer indexes. - new ArrayI,PasteI - new s - new Done set Done=0 - new result set result=cAbort - merge EntireBuf=^TIU(8925.2,BuffNum,"TEXT") - kill EntireBuf(0) ;"remove ^^^^^^ - - set ArrayI=$order(Array("")) - set PasteI=BuffIdx+1 - for do quit:((Done=1)!(ArrayI="")) - . if $data(Array(ArrayI))#10=0 set Done=1 quit - . set s=Array(ArrayI) - . set EntireBuff(PasteI,0)=s - . set PasteI=PasteI+IndexInc - . if PasteI>NextNoteI do quit - . . do ShowError^TMGDEBUG(PriorErrorFound,"Insufficient room to put note back into upload buffer.") - . . set Done=1 - . set ArrayI=$order(Array(ArrayI)) - - Set result=$$WriteWP^TMGDBAPI(8925.2,BuffNum,1,.EntireBuff) - - quit result - - -CompToBuff(ExistingIEN,UplTIEN,UplDate) - ;"PURPOSE: To compare the document being uploaded (i.e. in the file 8925.2, TIU upload buffer) - ;" to documents already existing in database - ;"Input: ExistingIEN -- the document IEN of a pre-existing document in the database. - ;" i.e. ^TIU(8925,ExistingIEN,*) - ;" UplTIEN=The type number of document being uploaded - ;" UplDate -- the date of the document being uploaded. - ;" NOTE: See also global-scope variables below that are REQUIRED - ;" - ;"Output: returns 0 if TEXT or Date different - ;" 1 if TEXT only is the same (Title is different) - ;" 2 if TEXT & Title are same - ;" - ;"------------------------------------------------------------------------------------ - ;"Programming Note: By tracing through the upload code I know that - ;" the following variables are set: - ;" (I saved DA as BuffNum, and TIUI as BuffIdx) - ;"TIUHSIG = [NewDict] .. or whatever it has been set to by user in upload params - ;"TIUBGN = [TEXT] ... or whatever is has be set to by user in upload params. - ;"BuffIdx = the line index of the beginning of the report to be processed (i.e. the line - ;" that starts with [TEXT] - ;"BuffNum = the index in 8925.2, i.e. ^TIU(8925.2,BuffNum,"TEXT",0) - ;" In other words, here BuffNum = the serial index number of the document to be uploaded - ;" i.e. 1 for the first, 2 for the second etc. - ;" Note 8925.2 is file: TIU UPLOAD BUFFER - ;"Note - ;" To detect the beginning of the next document, use - ;" if MyLine[TIUHSIG then abort - - new MaxUplLine - new DocLine,UplLine - new DocData,UplData - new result set result=0 - new MaxDocLine,CompLine - new DocType,DocName - new Break set Break=0 - new DocDate - - ;"First, see if dates are the same. If not, bail out. - set DocDate=$piece(^TIU(8925,ExistingIEN,0),"^",7) - if DocDate'=UplDate goto CompExit ;"Quit with result=0 - - set MaxUplLine=$piece($get(^TIU(8925.2,BuffNum,"TEXT",0)),"^",3) - if MaxUplLine="" goto CompExit - set MaxDocLine=$piece($get(^TIU(8925,ExistingIEN,"TEXT",0)),"^",3) - if MaxDocLine="" goto CompExit - - set UplLine=BuffIdx - set DocLine=0 - - ;"Compare the two documents line by line. - for i=1:1:(MaxUplLine-UplLine) do if Break goto CompExit - . set UplData=$get(^TIU(8925.2,BuffNum,"TEXT",UplLine+i,0)) - . set DocData=$get(^TIU(8925,ExistingIEN,"TEXT",DocLine+i,0),"x") - . if UplData[TIUHSIG set i=MaxUplLine quit - . if UplData'=DocData set Break=1 quit - . quit - - ;"If we have gotten this far, then the text is an identical match. - set result=1 - - ;"Now check to see if the dictation type is the same. - set DocType=$piece($get(^TIU(8925,ExistingIEN,0)),"^",1) - if DocType=UplTIEN set result=2 - -CompExit - quit result - - - ;------------------------------------------------------------------------ -CreateRec(Document) ; - ;"Purpose: Create document record - Returns DA - ;"Input: Document -- an array with document info. See GetRecord for documentation - ;"Ouput: DocIEN (internal entry number) of entry created, or -1 if failure - ;" Errors (if any) returned in Document("ERROR") - ;" - ;"Note: This was originally taken from TIUEDI3 - - ;"new cOKToCont set cOKToCont=1 - new cAbort set cAbort=0 - new result set result=1; "cOKToCont - - new DIC,DLAYGO,X,Y,DIE,DR - - new DocIEN set DocIEN=-1 - new TMGFDA,RecNum,TMGMSG,Flags - set TMGFDA(8925,"+1,",.01)="`"_Document(cDocTIEN) - set Flags="E" - - ;"====================================================== - ;"Call UPDATE^DIE -- add new entries in files or subfiles. - ;"====================================================== - do - . new $etrap set $etrap="do ErrTrp^TMGDBAPI" - . set ^TMP("TMG",$J,"ErrorTrap")=result - . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" - . do UPDATE^DIE(Flags,"TMGFDA","RecNum","TMGMSG") - . set result=^TMP("TMG",$J,"ErrorTrap") - . kill ^TMP("TMG",$J,"ErrorTrap") - ;"====================================================== - ;"====================================================== - - if result'=1 goto CRDone ;"1=cOKToCont - if $data(TMGMSG("DIERR")) do goto CRDone - . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) - . set DocIEN=-1 - . merge Document("ERROR","DIERR")=TMGMSG - do - . new index set index=$order(RecNum("")) - . if index'="" set DocIEN=+$get(RecNum(index)) - if DocIEN=0 set DocIEN=-1 - -CRDone - ;"Now check for failure. DocIEN will equal record number, or -1 if failure - if DocIEN'>0 do goto CRDone - . new n set n=+$get(Document("ERROR","NUM"))+1 - . set Document("ERROR",n)=$piece(Document(cDocType),"^",3)_" record could not be created." - set Document("DOC IEN")=DocIEN - - quit DocIEN - - - - ;------------------------------------------------------------------------ -StuffRec(Document,PARENT) - ;"Purpose: Stuff fixed field data - ;"INPUT: - ;" Document = An array containing information to put into document. - ;" The array should contain the following: - ;" Document("DOC IEN") -- the document IEN - ;" Document("PROVIDER IEN") -- the IEN of the provider - ;" Document("DFN") -- the patient IEN - ;" Document(cVisitIEN) -- a link to a visit entry - ;" Document(cStartDate) -- episode begin date/time - ;" Document(cEndDate) -- episode end date/time - ;" Document(cHspLocIEN) -- hospital location (Document(cVstLocIEN) used NULL) - ;" Document(cVstLocIEN) -- visit location. - ;" Document(cService) -- service (i.e. FAMILY PRACTICE) - ;" Document(cVisitStr) - ;" Document("TRANSCRIPTIONIST") -- the name of the transcriptionist - ;" Document("CHARACTER COUNT - TRANSCRIPTIONIST'S") -- the char count creditable to transcriptionist - ;" Document("LINE COUNT") -- Total line count - ;" PARENT: If we are working with an addendum to a document, then - ;" parent is the internal entry number of the original parent document - ;" Note:DocID can be null if not needed. - ;" Note: I don't ever pass a parent, currently - ;" - ;"NOTE: The following global-scope variables are also referenced - ;" TIUDDT - ;"Results: Passes back document IEN, or -1 if error. - ;" NOTE: if result is -1 then errors are passed back in - ;" Document("ERROR") node - ;" Document("ERROR",n)="ERROR.. Stuffing new document." - ;" Document("ERROR","NUM")=n - ;" Document("ERROR","FM INFO")=merge with DIERR array - - new TMGFDA,TMGMSG - new RefDate - new DocIEN set DocIEN=$get(Document("DOC IEN"),-1) - if DocIEN=-1 goto SfRecDone - new result set result=DocIEN ;"default to success - new ParentDocType - - ;"Field (f) constants - new fPatient set fPatient=.02 ;"field .02 = PATIENT - new fVisit set fVisit=.03 ;"field .03 = VISIT - new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE - new fStatus set fStatus=.05 ;"field .05 = STATUS - new fParent set fParent=.06 ;"field .06 = PARENT - new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) - new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) - new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME - new fAuthor set fAuthor=1202 ;"field 1202 = PERSON/DICTATOR - new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer - new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION - new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner - new fAttending set fAttending=1209 ;"field 1209 = ATTENDING - new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION - new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE - new fEnteredBy set fEnteredBy=1302 ;"field 1302 = ENTERED BY (a pointer to file 200) - new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' - new fService set fService=1404 ;"field 1404 = SERVICE - new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by - new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. - new fCharTrans set fCharTrans=22711 ;"field 22711 = CHAR COUNT -- TRANSCRIPTIONIST - new fLineCount set fLineCount=.1 ;"field .1 = LINE COUNT - - ;"8925=TIU DOCUMENT, the file we will edit - ;"do Set8925Value(.TMGFDA,Document("DFN"),fPatient,1) ;"Will file separatedly below. - do Set8925Value(.TMGFDA,Document(cVisitIEN),fVisit,1) - do Set8925Value(.TMGFDA,Document("PROVIDER IEN"),fAuthor,1) - do Set8925Value(.TMGFDA,Document("PROVIDER IEN"),fExpSigner,1) - do Set8925Value(.TMGFDA,Document("PROVIDER IEN"),fAttending,1) - do Set8925Value(.TMGFDA,Document(cHspLocIEN),fHospLoc,1) - do Set8925Value(.TMGFDA,Document(cVstLocIEN),fVisitLoc,1) - do Set8925Value(.TMGFDA,Document("TRANSCRIPTIONIST"),fEnteredBy,0) ;"VA transcriptionist field - do Set8925Value(.TMGFDA,Document("CHARACTER COUNT - TRANSCRIPTIONIST'S"),fCharTrans,0) - - if $data(Document("LINE COUNT")) do - . do Set8925Value(.TMGFDA,Document("LINE COUNT"),fLineCount,0) - - set ParentDocType=$$DOCCLASS^TIULC1(+$piece(DocIEN,"^",2)) - if +ParentDocType>0 do Set8925Value(.TMGFDA,ParentDocType,fParentDoc,1) - - if $get(Document("AUTO SIGN"))=1 do - . do Set8925Value(.TMGFDA,"COMPLETED",fStatus,0) - . do Set8925Value(.TMGFDA,Document("PROVIDER IEN"),fSignedBy,1) - else do - . do Set8925Value(.TMGFDA,"UNSIGNED",fStatus,0) - - if +$get(PARENT)'>0 do - . ;"do Set8925Value(.TMGFDA,Document("DFN"),fPatient,1) - . do Set8925Value(.TMGFDA,Document(cVisitIEN),fVisit,1) - . do Set8925Value(.TMGFDA,Document(cStartDate),fStartDate,0) - . do Set8925Value(.TMGFDA,Document(cEndDate),fEndDate,0) - . do Set8925Value(.TMGFDA,Document(cService),fService,0) - if +$get(PARENT)>0 do - . new NodeZero set NodeZero=$get(^TIU(8925,+PARENT,0)) - . new Node12 set Node12=$get(^TIU(8925,+PARENT,12)) - . new Node14 set Node14=$get(^TIU(8925,+PARENT,14)) - . ;" - . do Set8925Value(.TMGFDA,PARENT,fParent,1) - . do Set8925Value(.TMGFDA,$piece(NodeZero,"^",pPatient),fPatient,1) - . do Set8925Value(.TMGFDA,$piece(NodeZero,"^",pVisit),fVisit,1) - . do Set8925Value(.TMGFDA,$piece(NodeZero,"^",pStrtDate),fStartDate,0) - . do Set8925Value(.TMGFDA,$piece(NodeZero,"^",pEndDate),fEndDate,0) - . do Set8925Value(.TMGFDA,$piece(Node12,"^",pHospLoc),fHospLoc,1) - . do Set8925Value(.TMGFDA,$piece(Node14,"^",pService),fService,0) - - do Set8925Value(.TMGFDA,$$NOW^TIULC,fEntryDate,0) - do Set8925Value(.TMGFDA,Document(cHspLocIEN),fHospLoc,1) - do Set8925Value(.TMGFDA,Document(cVstLocIEN),fVisitLoc,1) - do Set8925Value(.TMGFDA,Document(cStartDate),fRefDate,0) - do Set8925Value(.TMGFDA,"U",fCapMethod,0) ;" U-->'upload' - ;"do Set8925Value(.TMGFDA,3,fStatus,0) - - kill ^TMG("TMP","EDDIE") - ;"merge ^TMG("TMP","EDDIE","INSIDE DOCUMENT")=Document ;"TEMP!! - merge ^TMG("TMP","EDDIE","FDA")=TMGFDA ;"TEMP!! - - do FILE^DIE("EK","TMGFDA","TMGMSG") - if $data(TMGMSG("DIERR")) do goto SfRecDone - . set result=-1 - . merge Document("ERROR","FM INFO")=TMGMSG("DIERR") - - ;" -- [Mark record for deferred crediting of stop code (fld #.11)]: -- - if +$get(Document("STOP")) do - . do DEFER^TIUVSIT(DocIEN,+$get(Document("STOP"))) - - ;"Try storing .02 field separately to avoid weird filing error - kill TMGFDA - new PtDFN set PtDFN=Document("DFN") - if (+PtDFN'=PtDFN),(PtDFN["`") set PtDFN=$piece(PtDFN,"`",2) - if +PtDFN>0 do - . set TMGFDA(8925,DocIEN_",",.02)=PtDFN - . do FILE^DIE("K","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR")) do - . . set result=-1 - . . merge Document("ERROR","FM INFO")=TMGMSG("DIERR") - -SfRecDone - quit result - - -Set8925Value(TMGFDA,Value,Field,IsIEN) - ;"Purpose: To provide a clean means of loading values into fields, into TMGFDA(8925,DOCIEN) - ;"Input: TMGFDA -- The array to fill - ;" Value -- the value to load - ;" Field -- the field - ;" IsIEN = 1 if value is an IEN - ;"Note: DEPENDS ON GLOBAL-SCOPE VARIABLES: DocIEN,Document - - if ($get(Value)'="")&($data(Field)>0) do - . if $get(IsIEN)>0,$extract(Value,1)'="`" set Value="`"_+Value - . if Value'="`0" set TMGFDA(8925,DocIEN_",",Field)=Value - quit - - - - ;"----------------------------------------------------------------------------------------------- - ;"==============================================================================================- - ;" F O L L O W - U P C O D E - ;"==============================================================================================- - ;"----------------------------------------------------------------------------------------------- - -FOLLOWUP(DocIEN) ;" Post-filing code for PROGRESS NOTES - ;"PURPOSE: - ;" This function is called by the TIU upload document facilities. - ;" it is called after the text has been put into the document - ;" - ;"INPUT: - ;" DocIEN -- is passed a value held in TIUREC("#"), i.e. - ;" do FOLLOWUP^TIUPUTN1(TIUREC("#")). - - write ! - write "+-------------------------------------+",! - write "| Starting Follow-up code... |",! - write "+-------------------------------------+",! - - if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 - if $data(cAbort)#10=0 new cAbort set cAbort=0 - - new DBIndent,PriorErrorFound - new result set result=1 ;" 1=cOKToCont - - new Document merge Document=TMGDOC - - new cStartDate set cStartDate="EDT" - new cEndDate set cEndDate="LDT" - new cService set cService="SVC" - new cDocType set cDocType="TYPE" - new cDocTIEN set cDocTIEN="TYPE IEN" - ;"new cDocIEN set cDocIEN="DOC IEN" - ;"new cPatIEN set cPatIEN="DFN" ;"DFN = Patient IEN - new cHspLocIEN set cHspLocIEN="LOC" - new cVstLocIEN set cVstLocIEN="VLOC" - new cVisitStr set cVisitStr="VSTR" - new cVisitIEN set cVisitIEN="VISIT" - new cStopCode set cStopCode="STOP" - - ;" 'p constants - new pPatient set pPatient=2 ;"Node 0,piece 2 = PATIENT (field .02) - new pVisit set pVisit=3 ;"Node 0,piece 3 = VISIT (field .03) - new pStrtDate set pStrtDate=7 ;"Node 0,piece 7 = EPISODE BEGIN DATE/TIME (field .07) - new pEndDate set pEndDate=8 ;"Node 0,piece 8 = EPISODE END DATE/TIME (field .08) - - new pAuthor set pAuthor=2 ;"Node 12,piece 2 = AUTHOR/DICTATOR (field 1202) - new pExpSigner set pExpSigner=4 ;"Node 12,piece 4 = EXPECTED SIGNER (field 1204) - new pHospLoc set pHospLoc=5 ;"Node 12,piece 5 = field 1205 = HOSPITAL LOCATION - new pAttending set pAttending=9 ;"Node 12,piece 9 = ATTENDING PHYSICIAN (field 1209) - new pExpCosign set pExpCosign=8 ;"Node 12,piece 8 = EXPECTED COSIGNER (field 1210) - new pVstLoc set pVstLoc=11 ;"Node 12,piece 11 = field 1211 = VISIT LOCATION - - ;"Field (f) constants - new fPatient set fPatient=.02 ;"field .02 = PATIENT - new fVisit set fVisit=.03 ;"field .03 = VISIT - new fParentDoc set fParentDoc=.04 ;"field .04 = PARENT DOCUMENT TYPE - new fStatus set fStatus=.05 ;"field .05 = STATUS - new fParent set fParent=.06 ;"field .06 = PARENT - new fStartDate set fStartDate=.07 ;"EPISODE BEGIN DATE/TIME (field .07) - new fEndDate set fEndDate=.08 ;"EPISODE END DATE/TIME (field .08) - new fEntryDate set fEntryDate=1201 ;"field 1201 = ENTRY DATE/TIME - new fAuthor set fAuthor=1202 ;"field 1202 = AUTHOR/DICTATOR - new fExpSigner set fExpSigner=1204 ;"field 1204 = expected Signer - new fHospLoc set fHospLoc=1205 ;"field 1205 = HOSPITAL LOCATION - new fExpCosign set fExpCosign=1208 ;"field 1208 = expected cosigner - new fVisitLoc set fVisitLoc=1211 ;"field 1211 = VISIT LOCATION - new fRefDate set fRefDate=1301 ;"field 1301 = REFERENCE DATE - new fCapMethod set fCapMethod=1303 ;"field 1303 = CAPTURE METHOD; U-->'upload' - new fService set fService=1404 ;"field 1404 = SERVICE - new fNeedCosign set fNeedCosign=1506 ;"field 1506 = cosigniture expected. - new fSignedBy set fSignedBy=1502 ;"field 1502 = signed by - - new TMGFDA,TMGMSG - new DFN - new Attending,ExpSigner,ExpCosign,Author - new BailOut set BailOut=0 - new Node12 set Node12=$get(^TIU(8925,DocIEN,12)) - new NodeZero set NodeZero=$get(^TIU(8925,DocIEN,0)) - if $data(Document)=0 new Document - - set Author=+$piece(Node12,"^",pAuthor) - set Attending=+$piece(Node12,"^",pAttending) - set ExpCosign=+$piece(Node12,"^",pExpCosign) - set ExpSigner=+$piece(Node12,"^",pExpSigner) - - do - . new Signer set Signer=$$WHOSIGNS^TIULC1(DocIEN) - . do Set8925Value(.TMGFDA,$$WHOSIGNS^TIULC1(DocIEN),fExpSigner,1) - - if (Attending>0)&(ExpCosign=0) do - . do Set8925Value(.TMGFDA,$$WHOCOSIG^TIULC1(DocIEN),fExpCosign,1) - - if (ExpCosign>0)&(ExpSigner'=ExpCosign) do - . do Set8925Value(.TMGFDA,1,fNeedCosign,0) - - set result=$$dbWrite^TMGDBAPI(.TMGFDA,1) - if result=-1 goto FUDone - - do RELEASE^TIUT(DocIEN,1) ;"Call function to 'Release Document from transcription' - do AUDIT^TIUEDI1(DocIEN,0,$$CHKSUM^TIULC("^TIU(8925,"_+DocIEN_",""TEXT"")")) ;"Update audit trail - - if '$data(Document) do if (BailOut=1) goto FUDone - . new VstLocIEN,HspLocIEN,StartDate,EndDate - . if $data(NodeZero)#10=0 do quit - . . set BailOut=1 - . set DFN=+$piece(NodeZero,"^",pPatient) - . set StartDate=+$piece(NodeZero,"^",pStrtDate) - . set EndDate=$$FMADD^XLFDT(StartDate,1) - . set Document(cHspLocIEN)=+$piece(Node12,"^",pHospLoc) - . set Document(cVstLocIEN)=+$piece(Node12,"^",pVstLoc) - . set VstLocIEN=Document(cVstLocIEN) - . if VstLocIEN'>0 set VstLocIEN=Document(cHspLocIEN) - . if (DFN>0)&(StartDate>0)&(EndDate>0)&(VstLocIEN>0) do - . . ;"This is an interactive visit .... - . . do MAIN^TIUVSIT(.Document,DFN,"",StartDate,EndDate,"LAST",0,VstLocIEN) - - if $data(Document)=0 goto FUDone - if $data(Document(cVisitStr))#10=0 goto FUDone - if $data(DFN)=0 set DFN=$get(Document("DFN")) if DFN="" goto FUDone - - ;"Note: reviewing the code for ENQ^TIUPXAP1, it appears the following is expected: - ;" .TIU array - ;" DFN -- the patient IEN - ;" DA -- the IEN of the document to work on. - ;" TIUDA -- the doc IEN that was passed to this function. - ;" Note, I'm not sure how DA and TIUDA are used differently. - ;" In fact, if $data(TIUDA)=0, then function uses DA. - ;" Unless I kill TIUDA (which might cause other problems), I don't - ;" know if TIUDA will hold an abherent value. So I'll set to DA - do - . new TIUDA set TIUDA=DocIEN - . new DA set DA=DocIEN - . new TIU merge TIU=Document - . do ENQ^TIUPXAP1 ;" Get/file VISIT - -FUDone ; - kill TMGDOC - quit - - - ;"----------------------------------------------------------------------------------------------- - ;"==============================================================================================- - ;" R E - F I L I N G C O D E - ;"==============================================================================================- - ;"----------------------------------------------------------------------------------------------- - -REFILE - ;"Purpose: Somtimes the upload process fails because of an error in the - ;" upload filing code. Rather than require a re-upload of the file, - ;" this function will trigger a retry of filing the TIU UPLOAD BUFFER - ;" (file 8925.2) - ;"This function is called by menu option TMG REFILE UPLOAD - - new TIUDA set TIUDA="" - new job - new DoRetry set DoRetry="" - new Abort set Abort=0 - new Found set Found=0 - - write !,! - write "------------------------------------------------",! - write " Refiler for failed uploads (i.e. a second try.)",! - write "------------------------------------------------",!,! - - write "Here are all the failed uploads:",!,! - set job=$order(^TIU(8925.2,"B","")) - for do quit:(job="") - . new Buff,NextBuff - . if job="" quit - . set Buff=$order(^TIU(8925.2,"B",job,"")) - . for do quit:(Buff="") - . . if Buff="" quit - . . write "Buffer #"_Buff_" (created by process #"_job_")",! - . . set Found=1 - . . set Buff=$order(^TIU(8925.2,"B",job,Buff)) - . set job=$order(^TIU(8925.2,"B",job)) - - if Found=0 write "(There are no failed uploads to process... Great!)",! - else write "------------------------------------------------",! - - set job=$order(^TIU(8925.2,"B","")) - for do quit:(job="")!(Abort=1) - . new Buff,NextBuff - . if job="" quit - . set Buff=$order(^TIU(8925.2,"B",job,"")) - . for do quit:(Buff="")!(Abort=1) - . . if Buff="" quit - . . if DoRetry'="all" do - . . . write !,"Refile upload buffer #"_Buff_" (created by process #"_job_")? (y/n/all/^) " - . . . read DoRetry:$get(DTIME,300),! - . . else do - . . . new GetKey - . . . read *GetKey:0 - . . . if $get(GetKey)=27 set DoRetry="n" - . . . else write !,!,"Processing upload buffer #",Buff,! - . . if DoRetry="^" set Abort=1 quit - . . if (DoRetry["y")!(DoRetry["Y")!(DoRetry="all") do - . . . set TIUDA=Buff - . . . ;"These is an edited form of MAIN^TIUUPLD - . . . N EOM,TIUERR,TIUHDR,TIULN,TIUSRC,X - . . . I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE - . . . S TIUSRC=$P($G(TIUPRM0),U,9),EOM=$P($G(TIUPRM0),U,11) - . . . I EOM']"",($P(TIUPRM0,U,17)'="k") do quit - . . . . W !,$C(7),$C(7),$C(7),"No End of Message Signal Defined - Contact IRM.",! - . . . S:TIUSRC']"" TIUSRC="R" - . . . S TIUHDR=$P(TIUPRM0,U,10) - . . . I TIUHDR']"" do quit - . . . . W $C(7),$C(7),$C(7),"No Record Header Signal Defined - Contact IRM.",! - . . . new temp set temp=$order(^TIU(8925.2,TIUDA,"TEXT",0)) - . . . write "First line of TEXT=",temp,! - . . . I +$O(^TIU(8925.2,TIUDA,"TEXT",0))>0 do - . . . . write "Calling FILE^TIUUPLD("_TIUDA_")",! - . . . . D FILE^TIUUPLD(TIUDA) - . . . I +$O(^TIU(8925.2,TIUDA,"TEXT",0))'>0 D BUFPURGE^TIUPUTC(TIUDA) - . . set Buff=$order(^TIU(8925.2,"B",job,Buff)) - . set job=$order(^TIU(8925.2,"B",job)) - - write !,"------------------------------------------------",! - write " All done with Refiler",! - write "------------------------------------------------",!,! - -RFDone - Q - - - - Index: cprs/branches/tmg-cprs/m_files/TMGRPC1.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1.m.bak (revision 796) +++ (revision ) @@ -1,1091 +1,0 @@ -TMGRPC1 ;TMG/kst-RPC Functions ;03/25/06 - ;;1.0;TMG-LIB;**1**;08/18/09 - - ;"TMG RPC FUNCTIONS - - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"3/24/07 - - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) - ;"UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) - ;"DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) -- Download drop box file - ;"UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) -- Upload Dropbox File - ;"GETLONG(GREF,IMAGEIEN) - ;"GETDFN(RESULT,RECNUM,RECFIELD,LNAME,FNAME,MNAME,DOB,SEX,SSNUM) - ;"BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) - ;"AUTOSIGN(RESULT,DOCIEN) - ;"FNINFO(RESULT,DFN) -- GET PATIENT DEMOGRAPHICS - ;"PTADD(RESULT,INFO) -- ADD PATIENT - ;"STPTINFO(RESULT,DFN,INFO) -- SET PATIENT DEMOGRAPHICS - ;"GETURLS(RESULT) -- TMG CPRS GET URL LIST - - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"ENCODE(GRef,incSubscr,encodeFn) - ;"DECODE(GRef,incSubscr,decodeFn) - ;"$$HEXCODER(INPUT) ;"encode the input string. Currently using simple hex encoding/ - ;"$$B64CODER(INPUT) ;"encode the input string via UUENCODE (actually Base64) - ;"$$B64DECODER(INPUT) ;"encode the input string via UUDECODE (actually Base64) - - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;"TMGBINF - ;"TMGSTUTL - ;"RGUTUU - ;"======================================================================= - ;"======================================================================= - -DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) - ;"SCOPE: Public - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will ask for a given file, and it will be passed back in the form - ;" of an array (in BASE64 ascii encoding) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to pass back - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;"Output: results are passed out in @GREF - ;" @GREF@(0)=success; 1=success, 0=failure - ;" @GREF@(1..xxx) = actual data - - set FPATH=$get(FPATH) - set FNAME=$get(FNAME) - set LOCIEN=$GET(LOCIEN,1) - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) ;"NOTE: CUSTOM FIELD - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" NOTE: CUSTOM FIELD - - new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) - new StartPath set StartPath=$extract(FPATH,1) - - if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do - . set FPATH=$extract(FPATH,2,1024) - else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do - . set PathRoot=PathRoot_NodeDiv - - set FPATH=PathRoot_FPATH - - set GREF="^TMP(""DOWNLOAD^TMGRPC1"","_$J_")" - - kill @GREF - set @GREF@(0)=$$BFTG^TMGBINF(.FPATH,.FNAME,$name(@GREF@(1)),3) - - do ENCODE($name(@GREF@(1)),3) - - quit - - -UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) - ;"SCOPE: Public - ;"RPC That calls this: TMG UPLOAD FILE - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will provide a file for upload (in BASE64 ascii encoding) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to pass back - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;" ARRAY -- the array that will hold the file, in BASE64 ascii encoding - ;"Output: results are passed out in RESULT: 1^SuccessMessage or 0^FailureMessage - - new result - new resultMsg set resultMsg="1^Successful Upload" - - set ^TMP("UPLOAD^TMGRPC1",$J,"FPATH")=$GET(FPATH) - set ^TMP("UPLOAD^TMGRPC1",$J,"FNAME")=$GET(FNAME) - set ^TMP("UPLOAD^TMGRPC1",$J,"LOCIEN")=$GET(LOCIEN) - - if $data(ARRAY)=0 set resultMsg="0^No data received to upload" goto UpDone - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto UpDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto UpDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) - new StartPath set StartPath=$extract(FPATH,1) - if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do - . set FPATH=$extract(FPATH,2,1024) - else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do - . set PathRoot=PathRoot_NodeDiv - - set FPATH=PathRoot_FPATH - - merge ^TMP("UPLOAD^TMGRPC1",$J,"ENCODED")=ARRAY ;"//TEMP - do DECODE("ARRAY(0)",1) - merge ^TMP("UPLOAD^TMGRPC1",$J,"DECODED")=ARRAY ;"//TEMP - - if $$GTBF^TMGBINF("ARRAY(0)",1,FPATH,FNAME)=0 do - . set resultMsg="0^Error while saving file" - -UpDone - set RESULT=resultMsg - quit - - -DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Download drop box file - ;"SCOPE: Public - ;"RPC That calls this: TMG DOWNLOAD FILE DROPBOX - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will request for the file to be placed into in a 'dropbox' file - ;" location that both the client and server can access. File may be - ;" moved from there to its final destination by the client. - ;" This method alloows file-hiding ability on the server side. - ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename. This - ;" is the path that the file is stored at (relative to a root path, - ;" see comments below). It is NOT the path of the dropbox. - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to be uploaded. Note: This is also the - ;" name of the file to be put into the dropbox. It is the - ;" responsibility of the client to ensure that there is not already - ;" a similarly named file in the dropbox before requesting a file - ;" be put there. It is the responsibility of the client to delete - ;" the file from the drop box. - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 - ;"NOTE RE DROPBOX: - ;" This system is designed for a system where by the server and the client have a - ;" shared filesystem, but the directory paths will be different. For example: - ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ - ;" Windows Client has access to dropbox at: V:\Dropbox\ - - ;"Output: results are 1^Success, or 0^Error Message - - new resultMsg set resultMsg="1^Successful Download" - - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto DnDBxDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto DnDBxDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new DropBox - set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) - if DropBox="" do goto UpDBxDone - . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" - ;"Ensure DropBox ends in a node divider - if $extract(DropBox,$length(DropBox))'=NodeDiv do - . set DropBox=DropBox_NodeDiv - - ;"Ensure PathRoot ends in a node divider - if $extract(PathRoot,$length(PathRoot))'=NodeDiv do - . set PathRoot=PathRoot_NodeDiv - - ;"Ensure Fpath does NOT start in a node divider - if $extract(FPATH,1)=NodeDiv do - . set FPATH=$extract(FPATH,2,1024) - - set FPATH=PathRoot_FPATH - - new SrcNamePath set SrcNamePath=FPATH_FNAME - ;"new DestNamePath set DestNamePath=DropBox_FNAME - - new moveResult - set moveResult=$$Copy^TMGKERNL(SrcNamePath,DropBox) - if moveResult>0 do - . set resultMsg="0^Move failed, returning OS error code: "_moveResult - -DnDBxDone - set RESULT=resultMsg - quit - - -UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Upload Dropbox File - ;"SCOPE: Public - ;"RPC That calls this: TMG UPLOAD FILE DROPBOX - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will put the file in a 'dropbox' file location that both the client - ;" and server can access. File will be moved from there to its final - ;" destination. This will provide file-hiding ability on the server side. - ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename. This - ;" is the path to store the file at. (relative to a root path, - ;" see comments below). It is NOT the path of the dropbox. - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to be uploaded. Note: This is also the - ;" name of the file to be pulled from the dropbox. It is the - ;" responsibility of the client to ensure that there is not already - ;" a similarly named file in the dropbox before depositing a file there. - ;" The server will remove the file from the dropbox, unless there is - ;" an error with the host OS (which will be returned as an error message) - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22700 in file 2005.2 - ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 - ;"NOTE RE DROPBOX: - ;" This system is designed for a system where by the server and the client have a - ;" shared filesystem, but the directory paths will be different. For example: - ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ - ;" Windows Client has access to dropbox at: V:\Dropbox\ - - ;"Output: results are passed out in RESULT: - ;" 1^SuccessMessage or 0^FailureMessage - - new result - new resultMsg set resultMsg="1^Successful Upload" - - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto UpDBxDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto UpDBxDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new DropBox - set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) - if DropBox="" do goto UpDBxDone - . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" - ;"Ensure DropBox ends in a node divider - if $extract(DropBox,$length(DropBox))'=NodeDiv do - . set DropBox=DropBox_NodeDiv - - ;"Ensure PathRoot ends in a node divider - if $extract(PathRoot,$length(PathRoot))'=NodeDiv do - . set PathRoot=PathRoot_NodeDiv - - ;"Ensure Fpath does NOT start in a node divider - if $extract(FPATH,1)=NodeDiv do - . set FPATH=$extract(FPATH,2,1024) - - set FPATH=PathRoot_FPATH - - new SrcNamePath,DestNamePath - set SrcNamePath=DropBox_FNAME - set DestNamePath=FPATH_FNAME - - new moveResult - set moveResult=$$Move^TMGKERNL(SrcNamePath,DestNamePath) - if moveResult>0 do - . set resultMsg="0^Move failed, returning OS error code: "_moveResult - -UpDBxDone - set RESULT=resultMsg - quit - - -ENCODE(GRef,incSubscr,encodeFn) - ;"Purpose: ENCODE a BINARY GLOBAL. - ;"Input: - ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved - ;" (closed root) format. - ;" Note: - ;" At least one subscript must be numeric. This will be the incrementing - ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment - ;" to store each new global node). This subscript need not be the final - ;" subscript. For example, to load into a WORD PROCESSING field, the - ;" incrementing node is the second-to-last subscript; the final subscript - ;" is always zero. - ;" REQUIRED - ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global - ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and - ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third - ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global - ;" reference, such as ^TMP(115,1,x,0). - ;" REQUIRED - ;" encodeFn- (OPTIONAL) the name of a function that will encode a line of data. - ;" e.g. "CODER^ZZZCODER" or "LOCALCODER". The function should - ;" take one input variable (the line of raw binary data), and return a converted - ;" line. e.g. - ;" CODER(INPUT) - ;" ... ;"convert INPUT to RESULT - ;" QUIT RESULT - ;" default value is B64CODER^TMGRPC1 - ;" - ;"Output: @GRef is converted to encoded data - ;"Result: None - - if $get(GRef)="" goto EncodeDone - if $get(incSubscr)="" goto EncodeDone - - set encodeFn=$get(encodeFn,"B64CODER") - - new encoder - set encoder="set temp=$$"_encodeFn_"(.temp)" - - for do quit:(GRef="") - . new temp - . set temp=$get(@GRef) - . if temp="" set GRef="" quit - . xecute encoder ;"i.e. set temp=$$encoderFn(.temp) - . set @GRef=temp - . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) - -EncodeDone - quit - - -HEXCODER(INPUT) - ;"Purpose: to encode the input string. Currently using simple hex encoding/ - quit $$STRB2H^TMGSTUTL(.INPUT,0,1) - - -B64CODER(INPUT) - ;"Purpose: to encode the input string via UUENCODE (actually Base64) - quit $$ENCODE^RGUTUU(.INPUT) - -B64DECODER(INPUT) - ;"Purpose: to encode the input string via UUENCODE (actually Base64) - quit $$DECODE^RGUTUU(.INPUT) - - -DECODE(GRef,incSubscr,decodeFn) - ;"Purpose: ENCODE a BINARY GLOBAL. - ;"Input: - ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved - ;" (closed root) format. - ;" Note: - ;" At least one subscript must be numeric. This will be the incrementing - ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment - ;" to store each new global node). This subscript need not be the final - ;" subscript. For example, to load into a WORD PROCESSING field, the - ;" incrementing node is the second-to-last subscript; the final subscript - ;" is always zero. - ;" REQUIRED - ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global - ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and - ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third - ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global - ;" reference, such as ^TMP(115,1,x,0). - ;" REQUIRED - ;" decodeFn- (OPTIONAL) the name of a function that will decode a line of data. - ;" e.g. "DECODER^ZZZCODER" or "DECODER". The function should take - ;" one input variable (the line of encoded data), and return a decoded line. e.g. - ;" DECODER(INPUT) - ;" ... ;"convert INPUT to RESULT - ;" QUIT RESULT - ;" default value is B64DECODER^TMGRPC1 - ;" - ;"Output: @GRef is converted to decoded data - ;"Result: None - - if $get(GRef)="" goto DecodeDone - if $get(incSubscr)="" goto DecodeDone - set decodeFn=$get(decodeFn,"B64DECODER") - - new decoder - set decoder="set temp=$$"_decodeFn_"(.temp)" - - for do quit:(GRef="") - . new temp - . set temp=$get(@GRef) - . if temp="" set GRef="" quit - . xecute decoder ;"i.e. set temp=$$decoderFn(.temp) - . set @GRef=temp - . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) - -DecodeDone - quit - - -GETLONG(GREF,IMAGEIEN) - ;"SCOPE: Public - ;"Purpose: To provide an entry point for a RPC call from a client. - ;" Will return results of field 11 (LONG DESCRIPTION) from file IMAGE(2005) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" IMAGEIEN-- The IEN (record number) from file 2005 (IMAGE) - ;"Output: results are passed out in @GREF - ;" @GREF@(0) = WP header line: format is: ^^MaxLine^MaxLine^TimeStamp(FM Date/Time Format) - ;" @GREF@(1) = WP line 1 - ;" @GREF@(2) = WP line 2 - ;" @GREF@(3) = WP line 3 - ;" @GREF@(4) = WP line 4 ... etc. - - set GREF="^TMP(""GETLONG^TMGRPC1"","_$J_")" - - kill @GREF - - new i,s,MaxLines,header - set header="" - if +$get(IMAGEIEN)>0 do - . set header=$get(^MAG(2005,IMAGEIEN,3,0)) ;"NOTE: Field 11 held in node 3;0 - set @GREF@(0)=header - set MaxLines=+$piece(header,"^",3) - for i=1:1:MaxLines do - . set @GREF@(i)=$get(^MAG(2005,IMAGEIEN,3,i,0)) - - quit - - - -GETDFN(RESULT,RECNUM,PMS,FNAME,LNAME,MNAME,DOB,SEX,SSNUM,AUTOADD) - ;"Purpose: This is a RPC entry point for looking up a patient. - ;"Input: - ;" RESULT -- an OUT PARAMETER - ;" RECNUM -- Record number from a PMS - ;" PMS -- Which PMS RECNUM refers to (1=Medic,2=Sequel,3=Paradigm) - ;" FNAME -- First Name - ;" LNAME -- Last name - ;" MNAME -- Middle Name or initial - ;" DOB -- Date of birth in EXTERNAL format - ;" SEX -- Patient sex: M or F - ;" SSNUM -- Social security number (digits only) - ;" AUTOADD -- Automatically register patient if needed (if value=1) - ;"Output: Patient may be added to database if AUTOADD=1 - ;"Results: Returns DFN (i.e. IEN in PATIENT file) or -1 if not found or error - - new Patient,TMGFREG - set RESULT=-1 ;"default to not found - - if $get(LNAME)'="" do - . set Patient("NAME")=$get(LNAME) - . if $get(FNAME)'="" set Patient("NAME")=Patient("NAME")_","_FNAME - . if $get(MNAME)'="" set Patient("NAME")=Patient("NAME")_" "_MNAME - set Patient("DOB")=$get(DOB) - set Patient("SEX")=$get(SEX) - set Patient("SSNUM")=$get(SSNUM) -test if $get(AUTOADD)=1 set TMGFREG=1 - - if $get(PMS)=1 set Patient("PATIENTNUM")=$get(RECNUM) ;" <-- Medic account number - if $get(PMS)=2 set Patient("SEQUELNUM")=$get(RECNUM) ;" <-- Sequel or other account number - if $get(PMS)=3 set Patient("PARADIGMNUM")=$get(RECNUM) ;" <-- Paradigm or other account number - - ;"temp - ;"merge ^TMG("TMP","GETDFN","KILLLATER")=Patient - ;"set ^TMG("TMP","GETDFN","KILLLATER","FNAME")=FNAME - ;"set ^TMG("TMP","GETDFN","KILLLATER","LNAME")=LNAME - ;"set ^TMG("TMP","GETDFN","KILLLATER","MNAME")=MNAME - - set RESULT=$$GetDFN^TMGGDFN(.Patient) - - quit - - -BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) - ;"Purpose: To create a new, blank TIU note and return it's IEN - ;"Input: DFN -- IEN in PATIENT file of patient - ;" PERSON -- Provider NAME - ;" LOC -- Location for new document - ;" DOS -- Date of Service - ;" TITLE -- Title of new document - ;"Results: IEN in file 8925 is returned in RESULT, - ;" or -1^ErrMsg1;ErrMsg2... if failure - ;"Note: This functionality probably duplicates that of RPC call: - ;" TIU CREATE NOTE -- found after writing this... - - new Document,Flag - - set Document("DFN")=DFN - set Document("PROVIDER IEN")=$$GetProvIEN^TMGPUTN0(PERSON) - set Document("LOCATION")=$get(LOC) - set Document("DATE")=$get(DOS) - set Document("TITLE")=$get(TITLE) - set Document("TRANSCRIPTIONIST")="" - set Document("CHARACTER COUNT - TRANSCRIPTIONIST'S")=0 - - set RESULT=$$PrepDoc^TMGPUTN0(.Document) - if +RESULT>0 do ;"change capture method from Upload (default) to RPC - . new TMGFDA,TMGMSG - . set TMGFDA(8925,RESULT_",",1303)="R" ;"1303 = capture method. "R" = RPC - . do FILE^DIE("E","TMGFDA","TMGMSG") ;"ignore any errors. - else do - . new i,ErrMsg set ErrMsg="" - . for i=1:1:+$get(Document("ERROR","NUM")) do - . . set ErrMsg=ErrMsg_$get(Document("ERROR",i))_" ||" - . if $data(Document("ERROR","FM INFO"))>0 do - . . new ref set ref="Document(""ERROR"",""FM INFO"")" - . . set ErrMsg=ErrMsg_"FILEMAN SAYS:" - . . for set ref=$query(@ref) quit:(ref="")!(ref'["FM INFO") do - . . . if ErrMsg'="" set ErrMsg=ErrMsg_" ||" - . . . set ErrMsg=ErrMsg_$piece(ref,"DIERR",2)_"="_$get(@ref) - . if ErrMsg="" set ErrMsg="Unknown error" - . set ErrMsg=$translate(ErrMsg,"^","@") - . set $piece(RESULT,"^",2)=ErrMsg - - ;"temp - merge ^TMG("TMP","BLANKTIU","RESULT")=RESULT - merge ^TMG("TMP","BLANKTIU","Document")=Document - - - quit - - -AUTOSIGN(RESULT,DOCIEN) - ;"Purpose: To automatically sign TIU note (8925). - ;"Input: DOCIEN -- the IEN in 8925 of the file to be automatically signed. - ;"Note: This function will not succeed unless field 1303 holds "R" - ;" and an Author found for note - ;"Results: Results passed back in RESULT(0) ARRAY - ;" -1 = failure. 1= success - ;" Any error message is passed back in RESULT("DIERR") - ;"Note: This differs from RPC CALL: TIU SIGN RECORD in that a signiture - ;" code is NOT required - - new TMGFDA,TMGMSG - new AuthorIEN,AuthorName - new CaptureMethod - - set DOCIEN=+$get(DOCIEN) - set RESULT=-1 ;"default to failure - - set CaptureMethod=$piece($get(^TIU(8925,DOCIEN,13)),"^",3) - if CaptureMethod'="R" do goto ASDone - . set RESULT("DIERR")="Unable to auto-sign. Upload-Method was not 'R'." - set AuthorIEN=$piece($get(^TIU(8925,DOCIEN,12)),"^",2) - if AuthorIEN'>0 do goto ASDone - . set RESULT("DIERR")="Unable to find author of document." - set AuthorName=$piece($get(^VA(200,AuthorIEN,0)),"^",1) - - set TMGFDA(8925,DOCIEN_",",.05)="COMPLETED" ;"field .05 = STATUS - set TMGFDA(8925,DOCIEN_",",1501)="NOW" ;"field 1501 = Signed date - set TMGFDA(8925,DOCIEN_",",1502)="`"_AuthorIEN ;"field 1502 = signed by - set TMGFDA(8925,DOCIEN_",",1503)=AuthorName ;"field 1503 = Signature block name - set TMGFDA(8925,DOCIEN_",",1504)="[Scanned image auto-signed]" ;"field 1504 = Signature block title - set TMGFDA(8925,DOCIEN_",",1505)="C" ;C=Chart ;"field 1505 = Signature mode - do FILE^DIE("E","TMGFDA","TMGMSG") - if $data(TMGMSG("DIERR")) do goto ASDone - . merge RESULT("DIERR")=TMGMSG("DIERR") - - set RESULT(0)=1 ;"set success if we got this far. -ASDone - quit - - -DFNINFO(RESULT,DFN) - ;"Purpose: To return array with demographcs details about patient - ;"Input: RESULT (this is the output array) - ;" DFN : The record number in file #2 of the patient to inquire about. - ;"Results: Results passed back in RESULT array. Format as follows: - ;" The results are in format: KeyName=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" IEN=record# - ;" COMBINED_NAME= - ;" LNAME= - ;" FNAME= - ;" MNAME= - ;" PREFIX= - ;" SUFFIX= - ;" DEGREE - ;" DOB= - ;" SEX= - ;" SS_NUM= - ;" ADDRESS_LINE_1= - ;" ADDRESS_LINE_2= - ;" ADDRESS_LINE_3= - ;" CITY= - ;" STATE= - ;" ZIP4= - ;" BAD_ADDRESS= - ;" TEMP_ADDRESS_LINE_1= - ;" TEMP_ADDRESS_LINE_2= - ;" TEMP_ADDRESS_LINE_3= - ;" TEMP_CITY= - ;" TEMP_STATE= - ;" TEMP_ZIP4= - ;" TEMP_STARTING_DATE= - ;" TEMP_ENDING_DATE= - ;" TEMP_ADDRESS_ACTIVE= - ;" CONF_ADDRESS_LINE_1= - ;" CONF_ADDRESS_LINE_2= - ;" CONF_ADDRESS_LINE_3= - ;" CONF_CITY= - ;" CONF_STATE= - ;" CONF_ZIP4= - ;" CONF_STARTING_DATE= - ;" CONF_ENDING_DATE= - ;" CONF_ADDRESS_ACTIVE= - ;" PHONE_RESIDENCE= - ;" PHONE_WORK= - ;" PHONE_CELL= - ;" PHONE_TEMP= - - ;"Note, for the following, there may be multiple entries. # is record number - ;" ALIAS # NAME - ;" ALIAS # SSN - - new TMGFDA,TMGMSG,IENS - set IENS="" - new ptrParts set ptrParts=0 - set DFN=+$get(DFN) - if DFN>0 do - . set ptrParts=+$piece($get(^DPT(DFN,"NAME")),"^",1) ;"ptr to file #20, NAME COMPONENTS - . set IENS=DFN_"," - . do GETS^DIQ(2,IENS,"**","N","TMGFDA","TMGMSG") - - new line set line=0 - set RESULT(line)="IEN="_DFN set line=line+1 - set RESULT(line)="COMBINED_NAME="_$get(TMGFDA(2,IENS,.01)) set line=line+1 - new s set s="" - if ptrParts>0 set s=$get(^VA(20,ptrParts,1)) - set RESULT(line)="LNAME="_$piece(s,"^",1) set line=line+1 - set RESULT(line)="FNAME="_$piece(s,"^",2) set line=line+1 - set RESULT(line)="MNAME="_$piece(s,"^",3) set line=line+1 - set RESULT(line)="PREFIX="_$piece(s,"^",4) set line=line+1 - set RESULT(line)="SUFFIX="_$piece(s,"^",5) set line=line+1 - set RESULT(line)="DEGREE="_$piece(s,"^",5) set line=line+1 - set RESULT(line)="DOB="_$get(TMGFDA(2,IENS,.03)) set line=line+1 - set RESULT(line)="SEX="_$get(TMGFDA(2,IENS,.02)) set line=line+1 - set RESULT(line)="SS_NUM="_$get(TMGFDA(2,IENS,.09)) set line=line+1 - set RESULT(line)="EMAIL="_$get(TMGFDA(2,IENS,.133)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.111)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.112)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.113)) set line=line+1 - set RESULT(line)="CITY="_$get(TMGFDA(2,IENS,.114)) set line=line+1 - set RESULT(line)="STATE="_$get(TMGFDA(2,IENS,.115)) set line=line+1 - if $get(TMGFDA(2,IENS,.1122))'="" do - . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1122)) set line=line+1 - else if $get(TMGFDA(2,IENS,.1116))'="" do - . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1116)) set line=line+1 - set RESULT(line)="BAD_ADDRESS="_$get(TMGFDA(2,IENS,.121)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1211)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.1212)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.1213)) set line=line+1 - set RESULT(line)="TEMP_CITY="_$get(TMGFDA(2,IENS,.1214)) set line=line+1 - set RESULT(line)="TEMP_STATE="_$get(TMGFDA(2,IENS,.1215)) set line=line+1 - set RESULT(line)="TEMP_ZIP4="_$get(TMGFDA(2,IENS,.1216)) set line=line+1 - set RESULT(line)="TEMP_STARTING_DATE="_$get(TMGFDA(2,IENS,.1217)) set line=line+1 - set RESULT(line)="TEMP_ENDING_DATE="_$get(TMGFDA(2,IENS,.1218)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.12105)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1411)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1412)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1413)) set line=line+1 - set RESULT(line)="CONF_CITY="_$get(TMGFDA(2,IENS,.1414)) set line=line+1 - set RESULT(line)="CONF_STATE="_$get(TMGFDA(2,IENS,.1415)) set line=line+1 - set RESULT(line)="CONF_ZIP4="_$get(TMGFDA(2,IENS,.1416)) set line=line+1 - set RESULT(line)="CONF_STARTING_DATE="_$get(TMGFDA(2,IENS,.1417)) set line=line+1 - set RESULT(line)="CONF_ENDING_DATE="_$get(TMGFDA(2,IENS,.1418)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.14105)) set line=line+1 - set RESULT(line)="PHONE_RESIDENCE="_$get(TMGFDA(2,IENS,.131)) set line=line+1 - set RESULT(line)="PHONE_WORK="_$get(TMGFDA(2,IENS,.132)) set line=line+1 - set RESULT(line)="PHONE_CELL="_$get(TMGFDA(2,IENS,.134)) set line=line+1 - set RESULT(line)="PHONE_TEMP="_$get(TMGFDA(2,IENS,.1219)) set line=line+1 - - ;"the GETS doesn't return ALIAS entries, so will do manually: - new Itr,IEN - set IEN=$$ItrInit^TMGITR(2.01,.Itr,DFN_",") - if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0) - . new s set s=$get(^DPT(DFN,.01,IEN,0)) - . if s="" quit - . set RESULT(line)="ALIAS "_IEN_" NAME="_$piece(s,"^",1) set line=line+1 - . set RESULT(line)="ALIAS "_IEN_" SSN="_$piece(s,"^",2) set line=line+1 - . ;"maybe later do something with NAME COMPONENTS in Alias. - - quit - - -STPTINFO(RESULT,DFN,INFO) ;" SET PATIENT INFO - ;"Purpose: To set demographcs details about patient - ;"Input: RESULT (this is the output array) - ;" DFN : The record number in file #2 of the patient to inquire about. - ;" INFO: Format as follows: - ;" The results are in format: INFO("KeyName")=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" If a record should be deleted, its value will be @ - ;" INFO("COMBINED_NAME")= - ;" INFO("PREFIX")= - ;" INFO("SUFFIX")= - ;" INFO("DEGREE")= - ;" INFO("DOB")= - ;" INFO("SEX")= - ;" INFO("SS_NUM")= - ;" INFO("ADDRESS_LINE_1")= - ;" INFO("ADDRESS_LINE_2")= - ;" INFO("ADDRESS_LINE_3")= - ;" INFO("CITY")= - ;" INFO("STATE")= - ;" INFO("ZIP4")= - ;" INFO("BAD_ADDRESS")= - ;" INFO("TEMP_ADDRESS_LINE_1")= - ;" INFO("TEMP_ADDRESS_LINE_2")= - ;" INFO("TEMP_ADDRESS_LINE_3")= - ;" INFO("TEMP_CITY")= - ;" INFO("TEMP_STATE")= - ;" INFO("TEMP_ZIP4")= - ;" INFO("TEMP_STARTING_DATE")= - ;" INFO("TEMP_ENDING_DATE")= - ;" INFO("TEMP_ADDRESS_ACTIVE")= - ;" INFO("CONF_ADDRESS_LINE_1")= - ;" INFO("CONF_ADDRESS_LINE_2")= - ;" INFO("CONF_ADDRESS_LINE_3")= - ;" INFO("CONF_CITY")= - ;" INFO("CONF_STATE")= - ;" INFO("CONF_ZIP4")= - ;" INFO("CONF_STARTING_DATE")= - ;" INFO("CONF_ENDING_DATE")= - ;" INFO("CONF_ADDRESS_ACTIVE")= - ;" INFO("PHONE_RESIDENCE")= - ;" INFO("PHONE_WORK")= - ;" INFO("PHONE_CELL")= - ;" INFO("PHONE_TEMP")= - ;"Note, for the following, there may be multiple entries. # is record number - ;" If a record should be added, it will be marked +1, +2 etc. - ;" INFO("ALIAS # NAME")= - ;" INFO("ALIAS # SSN")= - ;" - ;"Results: Results passed back in RESULT string: - ;" 1 = success - ;" -1^Message = failure - - set RESULT=1 ;"default to success - - ;"kill ^TMG("TMP","RPC") - ;"merge ^TMG("TMP","RPC")=INFO ;"temp... remove later - - new TMGFDA,TMGMSG,IENS - set IENS=DFN_"," - new key set key="" - for set key=$order(INFO(key)) quit:(key="") do - . if key="COMBINED_NAME" set TMGFDA(2,IENS,.01)=INFO("COMBINED_NAME") - . else if +key=key set TMGFDA(2,IENS,key)=INFO(key) - . else if key="DOB" set TMGFDA(2,IENS,.03)=INFO("DOB") - . else if key="SEX" set TMGFDA(2,IENS,.02)=INFO("SEX") - . else if key="SS_NUM" set TMGFDA(2,IENS,.09)=INFO("SS_NUM") - . else if key="ADDRESS_LINE_1" set TMGFDA(2,IENS,.111)=INFO("ADDRESS_LINE_1") - . else if key="ADDRESS_LINE_2" set TMGFDA(2,IENS,.112)=INFO("ADDRESS_LINE_2") - . else if key="ADDRESS_LINE_3" set TMGFDA(2,IENS,.113)=INFO("ADDRESS_LINE_3") - . else if key="CITY" set TMGFDA(2,IENS,.114)=INFO("CITY") - . else if key="STATE" set TMGFDA(2,IENS,.115)=INFO("STATE") - . else if key="ZIP4" set TMGFDA(2,IENS,.1112)=INFO("ZIP4") - . else if key="BAD_ADDRESS" set TMGFDA(2,IENS,.121)=INFO("BAD_ADDRESS") - . else if key="TEMP_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1211)=INFO("TEMP_ADDRESS_LINE_1") - . else if key="TEMP_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1212)=INFO("TEMP_ADDRESS_LINE_2") - . else if key="TEMP_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1213)=INFO("TEMP_ADDRESS_LINE_3") - . else if key="TEMP_CITY" set TMGFDA(2,IENS,.1214)=INFO("TEMP_CITY") - . else if key="TEMP_STATE" set TMGFDA(2,IENS,.1215)=INFO("TEMP_STATE") - . else if key="TEMP_ZIP4" set TMGFDA(2,IENS,.12112)=INFO("TEMP_ZIP4") - . else if key="TEMP_STARTING_DATE" set TMGFDA(2,IENS,.1217)=INFO("TEMP_STARTING_DATE") - . else if key="TEMP_ENDING_DATE" set TMGFDA(2,IENS,.1218)=INFO("TEMP_ENDING_DATE") - . else if key="TEMP_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.12105)=INFO("TEMP_ADDRESS_ACTIVE") - . else if key="CONF_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1411)=INFO("CONF_ADDRESS_LINE_1") - . else if key="CONF_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1412)=INFO("CONF_ADDRESS_LINE_2") - . else if key="CONF_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1413)=INFO("CONF_ADDRESS_LINE_3") - . else if key="CONF_CITY" set TMGFDA(2,IENS,.1414)=INFO("CONF_CITY") - . else if key="CONF_STATE" set TMGFDA(2,IENS,.1415)=INFO("CONF_STATE") - . else if key="CONF_ZIP" set TMGFDA(2,IENS,.1416)=INFO("CONF_ZIP") - . else if key="CONF_STARTING_DATE" set TMGFDA(2,IENS,.1417)=INFO("CONF_STARTING_DATE") - . else if key="CONF_ENDING_DATE" set TMGFDA(2,IENS,.1418)=INFO("CONF_ENDING_DATE") - . else if key="CONF_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.14105)=INFO("CONF_ADDRESS_ACTIVE") - . else if key="PHONE_RESIDENCE" set TMGFDA(2,IENS,.131)=INFO("PHONE_RESIDENCE") - . else if key="PHONE_WORK" set TMGFDA(2,IENS,.132)=INFO("PHONE_WORK") - . else if key="PHONE_CELL" set TMGFDA(2,IENS,.134)=INFO("PHONE_CELL") - . else if key="PHONE_TEMP" set TMGFDA(2,IENS,.1219)=INFO("PHONE_TEMP") - . else if key="EMAIL" set TMGFDA(2,IENS,.133)=INFO("EMAIL") - - if $data(TMGFDA) do - . do FILE^DIE("EKST","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR")) do - . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) - . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") - . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA - - ;"now file Alias info separately - if RESULT=1 do - . new tempArray,index,key2 - . new key set key="" - . for set key=$order(INFO(key)) quit:(key="") do - . . if key["ALIAS" do - . . . set index=$piece(key," ",2) quit:(index="") - . . . set key2=$piece(key," ",3) - . . . set tempArray(index,key2)=INFO(key) - . set index=0 for set index=$order(tempArray(index)) quit:(index="")!(RESULT'=1) do - . . new TMGFDA,TMGMSG,TMGIEN,newRec - . . set newRec=0 - . . set key="" for set key=$order(tempArray(index,key)) quit:(key="")!(RESULT'=1) do - . . . if key="NAME" set TMGFDA(2.01,index_","_DFN_",",.01)=$get(tempArray(index,"NAME")) - . . . if key="SSN" set TMGFDA(2.01,index_","_DFN_",",1)=$get(tempArray(index,"SSN")) - . . . if index["+" set newRec=1 - . . if $data(TMGFDA) do - . . . if newRec=0 do FILE^DIE("EKST","TMGFDA","TMGMSG") - . . . else do UPDATE^DIE("ES","TMGFDA","TMGIEN","TMGMSG") - . . if $data(TMGMSG("DIERR")) do - . . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) - . . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") - . . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA - - quit - -PTADD(RESULT,INFO) ;" ADD PATIENT - ;"Purpose: To add a patient - ;"Input: RESULT (this is the output array) - ;" - ;" INFO: Format as follows: - ;" The results are in format: INFO("KeyName")=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" If a record should be deleted, its value will be @ - ;" INFO("COMBINED_NAME")= - ;" INFO("DOB")= - ;" INFO("SEX")= - ;" INFO("SS_NUM")= - ;" INFO("Veteran")= - ;" INFO("PtType")= - ;"Results: Results passed back in RESULT string: - ;" DFN = success - ;" -1^Message = failure - ;" 0^DFN = already exists - - set RESULT=1 ;"default to success - - kill ^TMG("TMP","RPC") - merge ^TMG("TMP","RPC")=INFO ;"temp... remove later - - new TMGFDA,TMGMSG,IENS,PATIENT,DFN,TMGFREG - ;" set IENS=DFN_"," - new key set key="" - for set key=$order(INFO(key)) quit:(key="") do - . if key="COMBINED_NAME" set PATIENT("NAME")=INFO("COMBINED_NAME") - . else if key="DOB" set PATIENT("DOB")=INFO("DOB") - . else if key="SEX" set PATIENT("SEX")=INFO("SEX") - . else if key="SS_NUM" set PATIENT("SSNUM")=INFO("SS_NUM") - . else if key="Veteran" set PATIENT("VETERAN")=INFO("Veteran") - . else if key="PtType" set PATIENT("PT_TYPE")=INFO("PtType") - set DFN=$$GetDFN^TMGGDFN(.PATIENT) - if DFN=-1 do - . new Entry,result,ErrMsg - . do Pat2Entry^TMGGDFN(.PATIENT,.Entry) - . set DFN=$$AddNewPt^TMGGDFN(.Entry,.ErrMsg) - . ;"set DFN=$$GetDFN^TMGGDFN(.PATIENT) - . if DFN'>0 do - . . set RESULT="-1^ERROR ADDING" ;"should use ErrMsg from above. Fix later - . . set RESULT=RESULT_". "_$$GetErrStr^TMGDEBUG(.ErrMsg) - . else do - .. set RESULT=DFN - else do - . set RESULT="0^"_DFN - - quit - - -GETBARCD(GREF,MESSAGE,OPTION) - ;"SCOPE: Public - ;"RPC that calls this: TMG BARCODE ENCODE - ;"Purpose: To provide an entry point for a RPC call from a client. - ;" A 2D DataMatrix Bar Code will be create and passed to client. - ;" It will not be stored on server - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" MESSAGE-- The text to use to create the barcode - ;" OPTION -- Array that may hold optional settings, as follows: - ;" OPTION("IMAGE TYPE")="jpg" <-- if not specified, then default is "png" - ;"Output: results are passed out in @GREF - ;" @GREF@(0)=success; 1=success, 0=failure - ;" @GREF@(1..xxx) = actual data - - ;"NOTE: dmtxread must be installed on linux host. - ;" I found source code here: - ;" http://sourceforge.net/projects/libdmtx/ - ;" After installing (./configure --> make --> make install), I - ;" copied dmtxread and dmtxwrite, which were found in the - ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs - ;" folders, into a folder on the system path. I chose /usr/bin/ - ;" Also, to achieve compile of above, I had to install required libs. - ;" See notes included with dmtx source code. - - new FileSpec - new file - new FName,FPath - - set GREF="^TMP(""GETBARCD^TMGRPC1"","_$J_")" - kill @GREF - set @GREF@(0)="" ;"default to failure - set MESSAGE=$get(MESSAGE) - if MESSAGE="" goto GBCDone - - ;"Create the barcode and get file name and path - set file=$$MAKEBC^TMGBARC(MESSAGE,.OPTION) - do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") - - ;"Load binary image into global array - set @GREF@(0)=$$BFTG^TMGBINF(.FPath,.FName,$name(@GREF@(1)),3) - - ;"convert binary data to ascii encoded data - do ENCODE($name(@GREF@(1)),3) - - ;"delete temp image file - do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") - set FileSpec(FName)="" - new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - -GBCDone - quit - - -DECODEBC(RESULT,ARRAY,IMGTYPE) - ;"SCOPE: Public - ;"RPC that calls this: TMG BARCODE DECODE - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will upload an image file (.png format only) of a barcode (Datamatrix - ;" format) for decoding. Decoded message is passed back. - ;"Input: RESULT -- an OUT PARAMETER. See output below. - ;" ARRAY -- the array that will hold the image file, in BASE64 ascii encoding - ;" IMGTYPE -- Image type, e.g. "jpg" (Note: don't include any '.') - ;"Output: results are passed out in RESULT: 1^Decoded Message or 0^FailureMessage - - ;"NOTE: dmtxread must be installed on linux host. - ;" I found source code here: - ;" http://sourceforge.net/projects/libdmtx/ - ;" After installing (./configure --> make --> make install), I - ;" copied dmtxread and dmtxwrite, which were found in the - ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs - ;" folders, into a folder on the system path. I chose /usr/bin/ - ;" Also, to achieve compile of above, I had to install required libs. - ;" See notes included with dmtx source code. - ;"NOTE: if image types other than .png will be uploaded, then the linux host - ;" must have ImageMagick utility 'convert' installed for conversion - ;" between image types. - - kill ^TMG("TMP","BARCODE") - ;"set ^TMG("TMP","BARCODE","LOG")=1 ;"temp - - ;"new Stack do GetStackInfo^TMGIDE2(.Stack) - ;"merge ^TMG("TMP","BARCODE","STACK")=Stack - - new resultMsg - if $data(ARRAY)=0 set resultMsg="0^No image data received to decode" goto DBCDone - - new imageType set imageType=$$LOW^XLFSTR($get(IMGTYPE)) - if imageType="" set resultMsg="0^Image type not specified" goto DBCDone - - new imageFName set imageFName="/tmp/barcode."_imageType - set imageFName=$$UNIQUE^%ZISUTL(imageFName) - new FName,FPath,FileSpec - do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") - set FileSpec(FName)="" - - ;"temp... - ;"merge ^TMG("TMP","BARCODE","DATA")=ARRAY - ;"merge ^TMG("TMP","BARCODE","IMGTYPE")=IMGTYPE - - ;"set ^TMG("TMP","BARCODE","LOG")=2 ;"temp - ;"Remove BASE64 ascii encoding - do DECODE("ARRAY(0)",1) - - ;"set ^TMG("TMP","BARCODE","LOG")=3 ;"temp - ;"set ^TMG("TMP","BARCODE","LOG","Orig file: "_FPath_FName)="" - - ;"Save to host file system - if $$GTBF^TMGBINF("ARRAY(0)",1,FPath,FName)=0 do goto DBCDone - . set resultMsg="0^Error while saving file to HFS" - - ;"set ^TMG("TMP","BARCODE","LOG")=4 ;"temp - - ;"convert image file to .png format, if needed - if imageType'="png" do - . set imageFName=$$Convert^TMGKERNL(imageFName,"png") - . if imageFName="" do quit - . . set resultMsg="0^Error while converting image from ."_imageType_" to .png format." - . do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") - . set FileSpec(FName)="" - if imageFName="" goto DBCDone - - ;"set ^TMG("TMP","BARCODE","LOG")=5 ;"temp - - ;"Decode the barcode.png image - new result set result=$$READBC^TMGBARC(imageFName) - if result'="" set resultMsg="1^"_result - else set resultMsg="0^Unable to Decode Image" - - ;"delete temp image file - ;"temp REMOVE COMMENTS LATER TO DELETE FILE. !!!!! - ;"set result=$$DEL^%ZISH(FPath,"FileSpec") - -DBCDone - ;"set ^TMG("TMP","BARCODE","LOG")=6 ;"temp - - set RESULT=resultMsg - quit - - ;"-------------------- -GETURLS(RESULT) - ;"SCOPE: Public - ;"RPC that calls this: TMG CPRS GET URL LIST - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will request URLs to display in custom tabs inside CPRS, in an - ;" imbedded web browser - ;"Input: RESULT -- an OUT PARAMETER. See output below. - ;"Output: results are passed out in RESULT: - ;" RESULT(0)="1^Success" or "0^SomeFailureMessage" - ;" RESULT(1)="Name1^URL#1" ; shows URL#1 in tab #1, named 'Name1' - ;" RESULT(2)="Name2^URL#2" ; etc. - ;" RESULT(3)="Name3^URL#3" - ;" - ;" E.g. RESULT(1)="cnn^www.cnn.com" - ;" RESULT(2)="INFO^192.168.0.1/home.html" - ;" - ;" The number of allowed tabs is determined by code in CPRS - ;" Reference to tab numbers > specified in CPRS will be ignored by CPRS - ;" If a web tab is NOT specified, then the page previously - ;" displayed will be left in place. It will not be cleared. - ;" To clear a given page, a url of "about:blank" will cause a - ;" blank page to be displayed. e.g. - ;" RESULT(3)="^about:blank" - ;" To HIDE a tab on CPRS use this: - ;" RESULT(3)="^" ;triggers tab #3 to be hidden - ;" To have the browser remain UNCHANGED use this: - ;" RESULT(3)="^" ;triggers tab #3 to remain unchanged. - ;" Note: the rationale for this is that the web tab may have info - ;" that should not be refreshed when the patient info is refreshed - ;" i.e. the user may have navigated somewhere, and doesn't want - ;" to loose their location. - ;" --to be implemented. - ;" Note: The other way to do this, as above, is to simply have NO - ;" entry for a given tab. I.e. don't have any value for RESULT(3) - ;" --already implemented. - ;"Notice to others: Below is where code should be added to return - ;" proper URL's to CPRS. This will be called whenever a new patient - ;" is opened, or a Refresh Information is requested. - ;" FYI, 'DFN' should be defined as a globally-scoped variable that can be used - ;" to pass back URLS specific for a given patient. - - set RESULT(0)="1^Success" - set RESULT(1)="CNN^www.cnn.com" - set RESULT(2)="(x)^about:blank" - set RESULT(3)=$GET(^TMG("TMP","RPC","GETURLS")) - set RESULT(4)="" - - ;"kill RESULT - ;"merge RESULT=^TMG("TMP","URLS") ;"TEMP!!! - - quit Index: cprs/branches/tmg-cprs/m_files/TMGRPC1.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1.m~ (revision 796) +++ (revision ) @@ -1,1102 +1,0 @@ -TMGRPC1 ;TMG/kst-RPC Functions ;03/25/06 - ;;1.0;TMG-LIB;**1**;08/18/09 - - ;"TMG RPC FUNCTIONS - - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"3/24/07 - - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) - ;"UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) - ;"DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) -- Download drop box file - ;"UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) -- Upload Dropbox File - ;"GETLONG(GREF,IMAGEIEN) - ;"GETDFN(RESULT,RECNUM,RECFIELD,LNAME,FNAME,MNAME,DOB,SEX,SSNUM) - ;"BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) - ;"AUTOSIGN(RESULT,DOCIEN) - ;"FNINFO(RESULT,DFN) -- GET PATIENT DEMOGRAPHICS - ;"PTADD(RESULT,INFO) -- ADD PATIENT - ;"STPTINFO(RESULT,DFN,INFO) -- SET PATIENT DEMOGRAPHICS - ;"GETURLS(RESULT) -- TMG CPRS GET URL LIST - - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"ENCODE(GRef,incSubscr,encodeFn) - ;"DECODE(GRef,incSubscr,decodeFn) - ;"$$HEXCODER(INPUT) ;"encode the input string. Currently using simple hex encoding/ - ;"$$B64CODER(INPUT) ;"encode the input string via UUENCODE (actually Base64) - ;"$$B64DECODER(INPUT) ;"encode the input string via UUDECODE (actually Base64) - - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;"TMGBINF - ;"TMGSTUTL - ;"RGUTUU - ;"======================================================================= - ;"======================================================================= - -DOWNLOAD(GREF,FPATH,FNAME,LOCIEN) - ;"SCOPE: Public - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will ask for a given file, and it will be passed back in the form - ;" of an array (in BASE64 ascii encoding) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to pass back - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;"Output: results are passed out in @GREF - ;" @GREF@(0)=success; 1=success, 0=failure - ;" @GREF@(1..xxx) = actual data - - set FPATH=$get(FPATH) - set FNAME=$get(FNAME) - set LOCIEN=$GET(LOCIEN,1) - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) ;"NOTE: CUSTOM FIELD - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" NOTE: CUSTOM FIELD - - new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) - new StartPath set StartPath=$extract(FPATH,1) - - if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do - . set FPATH=$extract(FPATH,2,1024) - else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do - . set PathRoot=PathRoot_NodeDiv - - set FPATH=PathRoot_FPATH - - set GREF="^TMP(""DOWNLOAD^TMGRPC1"","_$J_")" - - kill @GREF - set @GREF@(0)=$$BFTG^TMGBINF(.FPATH,.FNAME,$name(@GREF@(1)),3) - - do ENCODE($name(@GREF@(1)),3) - - quit - - -UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) - ;"SCOPE: Public - ;"RPC That calls this: TMG UPLOAD FILE - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will provide a file for upload (in BASE64 ascii encoding) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to pass back - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;" ARRAY -- the array that will hold the file, in BASE64 ascii encoding - ;"Output: results are passed out in RESULT: 1^SuccessMessage or 0^FailureMessage - - new result - new resultMsg set resultMsg="1^Successful Upload" - - set ^TMP("UPLOAD^TMGRPC1",$J,"FPATH")=$GET(FPATH) - set ^TMP("UPLOAD^TMGRPC1",$J,"FNAME")=$GET(FNAME) - set ^TMP("UPLOAD^TMGRPC1",$J,"LOCIEN")=$GET(LOCIEN) - - if $data(ARRAY)=0 set resultMsg="0^No data received to upload" goto UpDone - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto UpDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto UpDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new EndRoot set EndRoot=$extract(PathRoot,$length(PathRoot)) - new StartPath set StartPath=$extract(FPATH,1) - if (EndRoot=NodeDiv)&(StartPath=NodeDiv) do - . set FPATH=$extract(FPATH,2,1024) - else if (EndRoot'=NodeDiv)&(StartPath'=NodeDiv) do - . set PathRoot=PathRoot_NodeDiv - - set FPATH=PathRoot_FPATH - - merge ^TMP("UPLOAD^TMGRPC1",$J,"ENCODED")=ARRAY ;"//TEMP - do DECODE("ARRAY(0)",1) - merge ^TMP("UPLOAD^TMGRPC1",$J,"DECODED")=ARRAY ;"//TEMP - - if $$GTBF^TMGBINF("ARRAY(0)",1,FPATH,FNAME)=0 do - . set resultMsg="0^Error while saving file" - -UpDone - set RESULT=resultMsg - quit - - -DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Download drop box file - ;"SCOPE: Public - ;"RPC That calls this: TMG DOWNLOAD FILE DROPBOX - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will request for the file to be placed into in a 'dropbox' file - ;" location that both the client and server can access. File may be - ;" moved from there to its final destination by the client. - ;" This method alloows file-hiding ability on the server side. - ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename. This - ;" is the path that the file is stored at (relative to a root path, - ;" see comments below). It is NOT the path of the dropbox. - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to be uploaded. Note: This is also the - ;" name of the file to be put into the dropbox. It is the - ;" responsibility of the client to ensure that there is not already - ;" a similarly named file in the dropbox before requesting a file - ;" be put there. It is the responsibility of the client to delete - ;" the file from the drop box. - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to download from - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22701 in file 2005.2 - ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 - ;"NOTE RE DROPBOX: - ;" This system is designed for a system where by the server and the client have a - ;" shared filesystem, but the directory paths will be different. For example: - ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ - ;" Windows Client has access to dropbox at: V:\Dropbox\ - - ;"Output: results are 1^Success^FileSize (in bytes), or 0^Error Message - - new resultMsg set resultMsg="1^Successful Download" - - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto DnDBxDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto DnDBxDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new DropBox - set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) - if DropBox="" do goto UpDBxDone - . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" - ;"Ensure DropBox ends in a node divider - if $extract(DropBox,$length(DropBox))'=NodeDiv do - . set DropBox=DropBox_NodeDiv - - ;"Ensure PathRoot ends in a node divider - if $extract(PathRoot,$length(PathRoot))'=NodeDiv do - . set PathRoot=PathRoot_NodeDiv - - ;"Ensure Fpath does NOT start in a node divider - if $extract(FPATH,1)=NodeDiv do - . set FPATH=$extract(FPATH,2,1024) - - set FPATH=PathRoot_FPATH - - new SrcNamePath set SrcNamePath=FPATH_FNAME - ;"new DestNamePath set DestNamePath=DropBox_FNAME - - new moveResult - set moveResult=$$Copy^TMGKERNL(SrcNamePath,DropBox) - if moveResult>0 do - . set resultMsg="0^Move failed, returning OS error code: "_moveResult - else do - . set resultMsg=resultMsg_"^"_$$FileSize^TMGKERNL(SrcNamePath) - -DnDBxDone - set RESULT=resultMsg - quit - - -UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Upload Dropbox File - ;"SCOPE: Public - ;"RPC That calls this: TMG UPLOAD FILE DROPBOX - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will put the file in a 'dropbox' file location that both the client - ;" and server can access. File will be moved from there to its final - ;" destination. This will provide file-hiding ability on the server side. - ;"Input: RESULT -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" FPATH -- the file path up to, but not including, the filename. This - ;" is the path to store the file at. (relative to a root path, - ;" see comments below). It is NOT the path of the dropbox. - ;" Use '/' to NOT specify any subdirectory - ;" FNAME -- the name of the file to be uploaded. Note: This is also the - ;" name of the file to be pulled from the dropbox. It is the - ;" responsibility of the client to ensure that there is not already - ;" a similarly named file in the dropbox before depositing a file there. - ;" The server will remove the file from the dropbox, unless there is - ;" an error with the host OS (which will be returned as an error message) - ;" LOCIEN-- [optional] -- the IEN from file 2005.2 (network location) to upload to - ;" default value is 1 - ;" Note: For security reasons, all path requests will be considered relative to a root path. - ;" e.g. if user asks for /download/SomeFile.jpg, this function will retrieve: - ;" /var/local/Dir1/Dir2/download/SomeFile.jpg - ;" This root path is found in custom field 22700 in file 2005.2 - ;" Also: dropbox location is obtained from custom field 22702 in file 2005.2 - ;"NOTE RE DROPBOX: - ;" This system is designed for a system where by the server and the client have a - ;" shared filesystem, but the directory paths will be different. For example: - ;" Linux server has dropbox at: /mnt/WinServer/dropbox/ - ;" Windows Client has access to dropbox at: V:\Dropbox\ - - ;"Output: results are passed out in RESULT: - ;" 1^SuccessMessage or 0^FailureMessage - - new result - new resultMsg set resultMsg="1^Successful Upload" - - set FPATH=$get(FPATH) - if FPATH="" set resultMsg="0^No file path received" goto UpDBxDone - set FNAME=$get(FNAME) - if FNAME="" set resultMsg="0^No file name received" goto UpDBxDone - set LOCIEN=$GET(LOCIEN,1); - new GREF - - new PathRoot - set PathRoot=$piece($get(^MAG(2005.2,LOCIEN,22700)),"^",1) - - new NodeDiv - set NodeDiv=$piece($get(^MAG(2005.2,LOCIEN,22701),"/"),"^",1) ;"default is "/" - - new DropBox - set DropBox=$piece($get(^MAG(2005.2,LOCIEN,22702)),"^",1) - if DropBox="" do goto UpDBxDone - . set resultMsg="0^Dropbox location not configured in file 2005.2, IEN "_LOCIEN_", field 22702" - ;"Ensure DropBox ends in a node divider - if $extract(DropBox,$length(DropBox))'=NodeDiv do - . set DropBox=DropBox_NodeDiv - - ;"Ensure PathRoot ends in a node divider - if $extract(PathRoot,$length(PathRoot))'=NodeDiv do - . set PathRoot=PathRoot_NodeDiv - - ;"Ensure Fpath does NOT start in a node divider - if $extract(FPATH,1)=NodeDiv do - . set FPATH=$extract(FPATH,2,1024) - - set FPATH=PathRoot_FPATH - - new SrcNamePath,DestNamePath - set SrcNamePath=DropBox_FNAME - set DestNamePath=FPATH_FNAME - - new moveResult - set moveResult=$$Move^TMGKERNL(SrcNamePath,DestNamePath) - if moveResult>0 do - . set resultMsg="0^Move failed, returning OS error code: "_moveResult - -UpDBxDone - set RESULT=resultMsg - quit - - -ENCODE(GRef,incSubscr,encodeFn) - ;"Purpose: ENCODE a BINARY GLOBAL. - ;"Input: - ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved - ;" (closed root) format. - ;" Note: - ;" At least one subscript must be numeric. This will be the incrementing - ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment - ;" to store each new global node). This subscript need not be the final - ;" subscript. For example, to load into a WORD PROCESSING field, the - ;" incrementing node is the second-to-last subscript; the final subscript - ;" is always zero. - ;" REQUIRED - ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global - ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and - ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third - ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global - ;" reference, such as ^TMP(115,1,x,0). - ;" REQUIRED - ;" encodeFn- (OPTIONAL) the name of a function that will encode a line of data. - ;" e.g. "CODER^ZZZCODER" or "LOCALCODER". The function should - ;" take one input variable (the line of raw binary data), and return a converted - ;" line. e.g. - ;" CODER(INPUT) - ;" ... ;"convert INPUT to RESULT - ;" QUIT RESULT - ;" default value is B64CODER^TMGRPC1 - ;" - ;"Output: @GRef is converted to encoded data - ;"Result: None - - if $get(GRef)="" goto EncodeDone - if $get(incSubscr)="" goto EncodeDone - - set encodeFn=$get(encodeFn,"B64CODER") - - new encoder - set encoder="set temp=$$"_encodeFn_"(.temp)" - - for do quit:(GRef="") - . new temp - . set temp=$get(@GRef) - . if temp="" set GRef="" quit - . xecute encoder ;"i.e. set temp=$$encoderFn(.temp) - . set @GRef=temp - . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) - -EncodeDone - quit - - -HEXCODER(INPUT) - ;"Purpose: to encode the input string. Currently using simple hex encoding/ - quit $$STRB2H^TMGSTUTL(.INPUT,0,1) - - -B64CODER(INPUT) - ;"Purpose: to encode the input string via UUENCODE (actually Base64) - quit $$ENCODE^RGUTUU(.INPUT) - -B64DECODER(INPUT) - ;"Purpose: to encode the input string via UUENCODE (actually Base64) - quit $$DECODE^RGUTUU(.INPUT) - - -DECODE(GRef,incSubscr,decodeFn) - ;"Purpose: ENCODE a BINARY GLOBAL. - ;"Input: - ;" GRef-- Global reference of the SOURCE binary global array, in fully resolved - ;" (closed root) format. - ;" Note: - ;" At least one subscript must be numeric. This will be the incrementing - ;" subscript (i.e. the subscript that $$BIN2WP^TMGBINWP will increment - ;" to store each new global node). This subscript need not be the final - ;" subscript. For example, to load into a WORD PROCESSING field, the - ;" incrementing node is the second-to-last subscript; the final subscript - ;" is always zero. - ;" REQUIRED - ;" incSubscr-- (required) Identifies the incrementing subscript level, for the source global - ;" For example, if you pass ^TMP(115,1,1,0) as the global_ref parameter and - ;" pass 3 as the inc_subscr parameter, $$BIN2GBL will increment the third - ;" subscript, such as ^TMP(115,1,x), but will WRITE notes at the full global - ;" reference, such as ^TMP(115,1,x,0). - ;" REQUIRED - ;" decodeFn- (OPTIONAL) the name of a function that will decode a line of data. - ;" e.g. "DECODER^ZZZCODER" or "DECODER". The function should take - ;" one input variable (the line of encoded data), and return a decoded line. e.g. - ;" DECODER(INPUT) - ;" ... ;"convert INPUT to RESULT - ;" QUIT RESULT - ;" default value is B64DECODER^TMGRPC1 - ;" - ;"Output: @GRef is converted to decoded data - ;"Result: None - - if $get(GRef)="" goto DecodeDone - if $get(incSubscr)="" goto DecodeDone - set decodeFn=$get(decodeFn,"B64DECODER") - - new decoder - set decoder="set temp=$$"_decodeFn_"(.temp)" - - for do quit:(GRef="") - . new temp - . set temp=$get(@GRef) - . if temp="" set GRef="" quit - . xecute decoder ;"i.e. set temp=$$decoderFn(.temp) - . set @GRef=temp - . set GRef=$$NEXTNODE^TMGBINF(GRef,incSubscr,1,1) - -DecodeDone - quit - - -GETLONG(GREF,IMAGEIEN) - ;"SCOPE: Public - ;"Purpose: To provide an entry point for a RPC call from a client. - ;" Will return results of field 11 (LONG DESCRIPTION) from file IMAGE(2005) - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" IMAGEIEN-- The IEN (record number) from file 2005 (IMAGE) - ;"Output: results are passed out in @GREF - ;" @GREF@(0) = WP header line: format is: ^^MaxLine^MaxLine^TimeStamp(FM Date/Time Format) - ;" @GREF@(1) = WP line 1 - ;" @GREF@(2) = WP line 2 - ;" @GREF@(3) = WP line 3 - ;" @GREF@(4) = WP line 4 ... etc. - - set GREF="^TMP(""GETLONG^TMGRPC1"","_$J_")" - - kill @GREF - - new i,s,MaxLines,header - set header="" - if +$get(IMAGEIEN)>0 do - . set header=$get(^MAG(2005,IMAGEIEN,3,0)) ;"NOTE: Field 11 held in node 3;0 - set @GREF@(0)=header - set MaxLines=+$piece(header,"^",3) - for i=1:1:MaxLines do - . set @GREF@(i)=$get(^MAG(2005,IMAGEIEN,3,i,0)) - - quit - - - -GETDFN(RESULT,RECNUM,PMS,FNAME,LNAME,MNAME,DOB,SEX,SSNUM,AUTOADD) - ;"Purpose: This is a RPC entry point for looking up a patient. - ;"Input: - ;" RESULT -- an OUT PARAMETER - ;" RECNUM -- Record number from a PMS - ;" PMS -- Which PMS RECNUM refers to (1=Medic,2=Sequel,3=Paradigm) - ;" FNAME -- First Name - ;" LNAME -- Last name - ;" MNAME -- Middle Name or initial - ;" DOB -- Date of birth in EXTERNAL format - ;" SEX -- Patient sex: M or F - ;" SSNUM -- Social security number (digits only) - ;" AUTOADD -- Automatically register patient if needed (if value=1) - ;"Output: Patient may be added to database if AUTOADD=1 - ;"Results: Returns DFN (i.e. IEN in PATIENT file) or -1 if not found or error - - new Patient,TMGFREG - set RESULT=-1 ;"default to not found - - if $get(LNAME)'="" do - . set Patient("NAME")=$get(LNAME) - . if $get(FNAME)'="" set Patient("NAME")=Patient("NAME")_","_FNAME - . if $get(MNAME)'="" set Patient("NAME")=Patient("NAME")_" "_MNAME - set Patient("DOB")=$get(DOB) - set Patient("SEX")=$get(SEX) - set Patient("SSNUM")=$get(SSNUM) -test if $get(AUTOADD)=1 set TMGFREG=1 - - if $get(PMS)=1 set Patient("PATIENTNUM")=$get(RECNUM) ;" <-- Medic account number - if $get(PMS)=2 set Patient("SEQUELNUM")=$get(RECNUM) ;" <-- Sequel or other account number - if $get(PMS)=3 set Patient("PARADIGMNUM")=$get(RECNUM) ;" <-- Paradigm or other account number - - ;"temp - ;"merge ^TMG("TMP","GETDFN","KILLLATER")=Patient - ;"set ^TMG("TMP","GETDFN","KILLLATER","FNAME")=FNAME - ;"set ^TMG("TMP","GETDFN","KILLLATER","LNAME")=LNAME - ;"set ^TMG("TMP","GETDFN","KILLLATER","MNAME")=MNAME - - set RESULT=$$GetDFN^TMGGDFN(.Patient) - - quit - - -BLANKTIU(RESULT,DFN,PERSON,LOC,DOS,TITLE) - ;"Purpose: To create a new, blank TIU note and return it's IEN - ;"Input: DFN -- IEN in PATIENT file of patient - ;" PERSON -- Provider NAME - ;" LOC -- Location for new document - ;" DOS -- Date of Service - ;" TITLE -- Title of new document - ;"Results: IEN in file 8925 is returned in RESULT, - ;" or -1^ErrMsg1;ErrMsg2... if failure - ;"Note: This functionality probably duplicates that of RPC call: - ;" TIU CREATE NOTE -- found after writing this... - - new Document,Flag - - set ^TMG("TMP","BLANKTIU","DFN")=$G(DFN) - set ^TMG("TMP","BLANKTIU","PERSON")=$G(PERSON) - set ^TMG("TMP","BLANKTIU","LOC")=$G(LOC) - set ^TMG("TMP","BLANKTIU","DOS")=$G(DOS) - set ^TMG("TMP","BLANKTIU","TITLE")=$G(TITLE) - - set Document("DFN")=DFN - set Document("PROVIDER IEN")=$$GetProvIEN^TMGPUTN0(PERSON) - if +LOC=LOC s LOC="`"_LOC - set Document("LOCATION")=$get(LOC) - set Document("DATE")=$get(DOS) - set Document("TITLE")=$get(TITLE) - set Document("TRANSCRIPTIONIST")="" - set Document("CHARACTER COUNT - TRANSCRIPTIONIST'S")=0 - - set RESULT=$$PrepDoc^TMGPUTN0(.Document) - if +RESULT>0 do ;"change capture method from Upload (default) to RPC - . new TMGFDA,TMGMSG - . set TMGFDA(8925,RESULT_",",1303)="R" ;"1303 = capture method. "R" = RPC - . merge ^TMG("TMP","BLANKTIU","TMGFDA")=TMGFDA - . do FILE^DIE("E","TMGFDA","TMGMSG") ;"ignore any errors. - else do - . new i,ErrMsg set ErrMsg="" - . for i=1:1:+$get(Document("ERROR","NUM")) do - . . set ErrMsg=ErrMsg_$get(Document("ERROR",i))_" ||" - . if $data(Document("ERROR","FM INFO"))>0 do - . . new ref set ref="Document(""ERROR"",""FM INFO"")" - . . set ErrMsg=ErrMsg_"FILEMAN SAYS:" - . . for set ref=$query(@ref) quit:(ref="")!(ref'["FM INFO") do - . . . if ErrMsg'="" set ErrMsg=ErrMsg_" ||" - . . . set ErrMsg=ErrMsg_$piece(ref,"DIERR",2)_"="_$get(@ref) - . if ErrMsg="" set ErrMsg="Unknown error" - . set ErrMsg=$translate(ErrMsg,"^","@") - . set $piece(RESULT,"^",2)=ErrMsg - - ;"temp - merge ^TMG("TMP","BLANKTIU","RESULT")=RESULT - merge ^TMG("TMP","BLANKTIU","Document")=Document - - - quit - - -AUTOSIGN(RESULT,DOCIEN) - ;"Purpose: To automatically sign TIU note (8925). - ;"Input: DOCIEN -- the IEN in 8925 of the file to be automatically signed. - ;"Note: This function will not succeed unless field 1303 holds "R" - ;" and an Author found for note - ;"Results: Results passed back in RESULT(0) ARRAY - ;" -1 = failure. 1= success - ;" Any error message is passed back in RESULT("DIERR") - ;"Note: This differs from RPC CALL: TIU SIGN RECORD in that a signiture - ;" code is NOT required - - new TMGFDA,TMGMSG - new AuthorIEN,AuthorName - new CaptureMethod - - set DOCIEN=+$get(DOCIEN) - set RESULT=-1 ;"default to failure - - set CaptureMethod=$piece($get(^TIU(8925,DOCIEN,13)),"^",3) - if CaptureMethod'="R" do goto ASDone - . set RESULT("DIERR")="Unable to auto-sign. Upload-Method was not 'R'." - set AuthorIEN=$piece($get(^TIU(8925,DOCIEN,12)),"^",2) - if AuthorIEN'>0 do goto ASDone - . set RESULT("DIERR")="Unable to find author of document." - set AuthorName=$piece($get(^VA(200,AuthorIEN,0)),"^",1) - - set TMGFDA(8925,DOCIEN_",",.05)="COMPLETED" ;"field .05 = STATUS - set TMGFDA(8925,DOCIEN_",",1501)="NOW" ;"field 1501 = Signed date - set TMGFDA(8925,DOCIEN_",",1502)="`"_AuthorIEN ;"field 1502 = signed by - set TMGFDA(8925,DOCIEN_",",1503)=AuthorName ;"field 1503 = Signature block name - set TMGFDA(8925,DOCIEN_",",1504)="[Scanned image auto-signed]" ;"field 1504 = Signature block title - set TMGFDA(8925,DOCIEN_",",1505)="C" ;C=Chart ;"field 1505 = Signature mode - do FILE^DIE("E","TMGFDA","TMGMSG") - if $data(TMGMSG("DIERR")) do goto ASDone - . merge RESULT("DIERR")=TMGMSG("DIERR") - - set RESULT(0)=1 ;"set success if we got this far. -ASDone - quit - - -DFNINFO(RESULT,DFN) - ;"Purpose: To return array with demographcs details about patient - ;"Input: RESULT (this is the output array) - ;" DFN : The record number in file #2 of the patient to inquire about. - ;"Results: Results passed back in RESULT array. Format as follows: - ;" The results are in format: KeyName=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" IEN=record# - ;" COMBINED_NAME= - ;" LNAME= - ;" FNAME= - ;" MNAME= - ;" PREFIX= - ;" SUFFIX= - ;" DEGREE - ;" DOB= - ;" SEX= - ;" SS_NUM= - ;" ADDRESS_LINE_1= - ;" ADDRESS_LINE_2= - ;" ADDRESS_LINE_3= - ;" CITY= - ;" STATE= - ;" ZIP4= - ;" BAD_ADDRESS= - ;" TEMP_ADDRESS_LINE_1= - ;" TEMP_ADDRESS_LINE_2= - ;" TEMP_ADDRESS_LINE_3= - ;" TEMP_CITY= - ;" TEMP_STATE= - ;" TEMP_ZIP4= - ;" TEMP_STARTING_DATE= - ;" TEMP_ENDING_DATE= - ;" TEMP_ADDRESS_ACTIVE= - ;" CONF_ADDRESS_LINE_1= - ;" CONF_ADDRESS_LINE_2= - ;" CONF_ADDRESS_LINE_3= - ;" CONF_CITY= - ;" CONF_STATE= - ;" CONF_ZIP4= - ;" CONF_STARTING_DATE= - ;" CONF_ENDING_DATE= - ;" CONF_ADDRESS_ACTIVE= - ;" PHONE_RESIDENCE= - ;" PHONE_WORK= - ;" PHONE_CELL= - ;" PHONE_TEMP= - - ;"Note, for the following, there may be multiple entries. # is record number - ;" ALIAS # NAME - ;" ALIAS # SSN - - new TMGFDA,TMGMSG,IENS - set IENS="" - new ptrParts set ptrParts=0 - set DFN=+$get(DFN) - if DFN>0 do - . set ptrParts=+$piece($get(^DPT(DFN,"NAME")),"^",1) ;"ptr to file #20, NAME COMPONENTS - . set IENS=DFN_"," - . do GETS^DIQ(2,IENS,"**","N","TMGFDA","TMGMSG") - - new line set line=0 - set RESULT(line)="IEN="_DFN set line=line+1 - set RESULT(line)="COMBINED_NAME="_$get(TMGFDA(2,IENS,.01)) set line=line+1 - new s set s="" - if ptrParts>0 set s=$get(^VA(20,ptrParts,1)) - set RESULT(line)="LNAME="_$piece(s,"^",1) set line=line+1 - set RESULT(line)="FNAME="_$piece(s,"^",2) set line=line+1 - set RESULT(line)="MNAME="_$piece(s,"^",3) set line=line+1 - set RESULT(line)="PREFIX="_$piece(s,"^",4) set line=line+1 - set RESULT(line)="SUFFIX="_$piece(s,"^",5) set line=line+1 - set RESULT(line)="DEGREE="_$piece(s,"^",5) set line=line+1 - set RESULT(line)="DOB="_$get(TMGFDA(2,IENS,.03)) set line=line+1 - set RESULT(line)="SEX="_$get(TMGFDA(2,IENS,.02)) set line=line+1 - set RESULT(line)="SS_NUM="_$get(TMGFDA(2,IENS,.09)) set line=line+1 - set RESULT(line)="EMAIL="_$get(TMGFDA(2,IENS,.133)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.111)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.112)) set line=line+1 - set RESULT(line)="ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.113)) set line=line+1 - set RESULT(line)="CITY="_$get(TMGFDA(2,IENS,.114)) set line=line+1 - set RESULT(line)="STATE="_$get(TMGFDA(2,IENS,.115)) set line=line+1 - if $get(TMGFDA(2,IENS,.1122))'="" do - . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1122)) set line=line+1 - else if $get(TMGFDA(2,IENS,.1116))'="" do - . set RESULT(line)="ZIP4="_$get(TMGFDA(2,IENS,.1116)) set line=line+1 - set RESULT(line)="BAD_ADDRESS="_$get(TMGFDA(2,IENS,.121)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1211)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_2="_$get(TMGFDA(2,IENS,.1212)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_LINE_3="_$get(TMGFDA(2,IENS,.1213)) set line=line+1 - set RESULT(line)="TEMP_CITY="_$get(TMGFDA(2,IENS,.1214)) set line=line+1 - set RESULT(line)="TEMP_STATE="_$get(TMGFDA(2,IENS,.1215)) set line=line+1 - set RESULT(line)="TEMP_ZIP4="_$get(TMGFDA(2,IENS,.1216)) set line=line+1 - set RESULT(line)="TEMP_STARTING_DATE="_$get(TMGFDA(2,IENS,.1217)) set line=line+1 - set RESULT(line)="TEMP_ENDING_DATE="_$get(TMGFDA(2,IENS,.1218)) set line=line+1 - set RESULT(line)="TEMP_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.12105)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1411)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1412)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_LINE_1="_$get(TMGFDA(2,IENS,.1413)) set line=line+1 - set RESULT(line)="CONF_CITY="_$get(TMGFDA(2,IENS,.1414)) set line=line+1 - set RESULT(line)="CONF_STATE="_$get(TMGFDA(2,IENS,.1415)) set line=line+1 - set RESULT(line)="CONF_ZIP4="_$get(TMGFDA(2,IENS,.1416)) set line=line+1 - set RESULT(line)="CONF_STARTING_DATE="_$get(TMGFDA(2,IENS,.1417)) set line=line+1 - set RESULT(line)="CONF_ENDING_DATE="_$get(TMGFDA(2,IENS,.1418)) set line=line+1 - set RESULT(line)="CONF_ADDRESS_ACTIVE="_$get(TMGFDA(2,IENS,.14105)) set line=line+1 - set RESULT(line)="PHONE_RESIDENCE="_$get(TMGFDA(2,IENS,.131)) set line=line+1 - set RESULT(line)="PHONE_WORK="_$get(TMGFDA(2,IENS,.132)) set line=line+1 - set RESULT(line)="PHONE_CELL="_$get(TMGFDA(2,IENS,.134)) set line=line+1 - set RESULT(line)="PHONE_TEMP="_$get(TMGFDA(2,IENS,.1219)) set line=line+1 - - ;"the GETS doesn't return ALIAS entries, so will do manually: - new Itr,IEN - set IEN=$$ItrInit^TMGITR(2.01,.Itr,DFN_",") - if IEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.IEN)'>0) - . new s set s=$get(^DPT(DFN,.01,IEN,0)) - . if s="" quit - . set RESULT(line)="ALIAS "_IEN_" NAME="_$piece(s,"^",1) set line=line+1 - . set RESULT(line)="ALIAS "_IEN_" SSN="_$piece(s,"^",2) set line=line+1 - . ;"maybe later do something with NAME COMPONENTS in Alias. - - quit - - -STPTINFO(RESULT,DFN,INFO) ;" SET PATIENT INFO - ;"Purpose: To set demographcs details about patient - ;"Input: RESULT (this is the output array) - ;" DFN : The record number in file #2 of the patient to inquire about. - ;" INFO: Format as follows: - ;" The results are in format: INFO("KeyName")=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" If a record should be deleted, its value will be @ - ;" INFO("COMBINED_NAME")= - ;" INFO("PREFIX")= - ;" INFO("SUFFIX")= - ;" INFO("DEGREE")= - ;" INFO("DOB")= - ;" INFO("SEX")= - ;" INFO("SS_NUM")= - ;" INFO("ADDRESS_LINE_1")= - ;" INFO("ADDRESS_LINE_2")= - ;" INFO("ADDRESS_LINE_3")= - ;" INFO("CITY")= - ;" INFO("STATE")= - ;" INFO("ZIP4")= - ;" INFO("BAD_ADDRESS")= - ;" INFO("TEMP_ADDRESS_LINE_1")= - ;" INFO("TEMP_ADDRESS_LINE_2")= - ;" INFO("TEMP_ADDRESS_LINE_3")= - ;" INFO("TEMP_CITY")= - ;" INFO("TEMP_STATE")= - ;" INFO("TEMP_ZIP4")= - ;" INFO("TEMP_STARTING_DATE")= - ;" INFO("TEMP_ENDING_DATE")= - ;" INFO("TEMP_ADDRESS_ACTIVE")= - ;" INFO("CONF_ADDRESS_LINE_1")= - ;" INFO("CONF_ADDRESS_LINE_2")= - ;" INFO("CONF_ADDRESS_LINE_3")= - ;" INFO("CONF_CITY")= - ;" INFO("CONF_STATE")= - ;" INFO("CONF_ZIP4")= - ;" INFO("CONF_STARTING_DATE")= - ;" INFO("CONF_ENDING_DATE")= - ;" INFO("CONF_ADDRESS_ACTIVE")= - ;" INFO("PHONE_RESIDENCE")= - ;" INFO("PHONE_WORK")= - ;" INFO("PHONE_CELL")= - ;" INFO("PHONE_TEMP")= - ;"Note, for the following, there may be multiple entries. # is record number - ;" If a record should be added, it will be marked +1, +2 etc. - ;" INFO("ALIAS # NAME")= - ;" INFO("ALIAS # SSN")= - ;" - ;"Results: Results passed back in RESULT string: - ;" 1 = success - ;" -1^Message = failure - - set RESULT=1 ;"default to success - - ;"kill ^TMG("TMP","RPC") - ;"merge ^TMG("TMP","RPC")=INFO ;"temp... remove later - - new TMGFDA,TMGMSG,IENS - set IENS=DFN_"," - new key set key="" - for set key=$order(INFO(key)) quit:(key="") do - . if key="COMBINED_NAME" set TMGFDA(2,IENS,.01)=INFO("COMBINED_NAME") - . else if +key=key set TMGFDA(2,IENS,key)=INFO(key) - . else if key="DOB" set TMGFDA(2,IENS,.03)=INFO("DOB") - . else if key="SEX" set TMGFDA(2,IENS,.02)=INFO("SEX") - . else if key="SS_NUM" set TMGFDA(2,IENS,.09)=INFO("SS_NUM") - . else if key="ADDRESS_LINE_1" set TMGFDA(2,IENS,.111)=INFO("ADDRESS_LINE_1") - . else if key="ADDRESS_LINE_2" set TMGFDA(2,IENS,.112)=INFO("ADDRESS_LINE_2") - . else if key="ADDRESS_LINE_3" set TMGFDA(2,IENS,.113)=INFO("ADDRESS_LINE_3") - . else if key="CITY" set TMGFDA(2,IENS,.114)=INFO("CITY") - . else if key="STATE" set TMGFDA(2,IENS,.115)=INFO("STATE") - . else if key="ZIP4" set TMGFDA(2,IENS,.1112)=INFO("ZIP4") - . else if key="BAD_ADDRESS" set TMGFDA(2,IENS,.121)=INFO("BAD_ADDRESS") - . else if key="TEMP_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1211)=INFO("TEMP_ADDRESS_LINE_1") - . else if key="TEMP_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1212)=INFO("TEMP_ADDRESS_LINE_2") - . else if key="TEMP_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1213)=INFO("TEMP_ADDRESS_LINE_3") - . else if key="TEMP_CITY" set TMGFDA(2,IENS,.1214)=INFO("TEMP_CITY") - . else if key="TEMP_STATE" set TMGFDA(2,IENS,.1215)=INFO("TEMP_STATE") - . else if key="TEMP_ZIP4" set TMGFDA(2,IENS,.12112)=INFO("TEMP_ZIP4") - . else if key="TEMP_STARTING_DATE" set TMGFDA(2,IENS,.1217)=INFO("TEMP_STARTING_DATE") - . else if key="TEMP_ENDING_DATE" set TMGFDA(2,IENS,.1218)=INFO("TEMP_ENDING_DATE") - . else if key="TEMP_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.12105)=INFO("TEMP_ADDRESS_ACTIVE") - . else if key="CONF_ADDRESS_LINE_1" set TMGFDA(2,IENS,.1411)=INFO("CONF_ADDRESS_LINE_1") - . else if key="CONF_ADDRESS_LINE_2" set TMGFDA(2,IENS,.1412)=INFO("CONF_ADDRESS_LINE_2") - . else if key="CONF_ADDRESS_LINE_3" set TMGFDA(2,IENS,.1413)=INFO("CONF_ADDRESS_LINE_3") - . else if key="CONF_CITY" set TMGFDA(2,IENS,.1414)=INFO("CONF_CITY") - . else if key="CONF_STATE" set TMGFDA(2,IENS,.1415)=INFO("CONF_STATE") - . else if key="CONF_ZIP" set TMGFDA(2,IENS,.1416)=INFO("CONF_ZIP") - . else if key="CONF_STARTING_DATE" set TMGFDA(2,IENS,.1417)=INFO("CONF_STARTING_DATE") - . else if key="CONF_ENDING_DATE" set TMGFDA(2,IENS,.1418)=INFO("CONF_ENDING_DATE") - . else if key="CONF_ADDRESS_ACTIVE" set TMGFDA(2,IENS,.14105)=INFO("CONF_ADDRESS_ACTIVE") - . else if key="PHONE_RESIDENCE" set TMGFDA(2,IENS,.131)=INFO("PHONE_RESIDENCE") - . else if key="PHONE_WORK" set TMGFDA(2,IENS,.132)=INFO("PHONE_WORK") - . else if key="PHONE_CELL" set TMGFDA(2,IENS,.134)=INFO("PHONE_CELL") - . else if key="PHONE_TEMP" set TMGFDA(2,IENS,.1219)=INFO("PHONE_TEMP") - . else if key="EMAIL" set TMGFDA(2,IENS,.133)=INFO("EMAIL") - - if $data(TMGFDA) do - . do FILE^DIE("EKST","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR")) do - . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) - . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") - . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA - - ;"now file Alias info separately - if RESULT=1 do - . new tempArray,index,key2 - . new key set key="" - . for set key=$order(INFO(key)) quit:(key="") do - . . if key["ALIAS" do - . . . set index=$piece(key," ",2) quit:(index="") - . . . set key2=$piece(key," ",3) - . . . set tempArray(index,key2)=INFO(key) - . set index=0 for set index=$order(tempArray(index)) quit:(index="")!(RESULT'=1) do - . . new TMGFDA,TMGMSG,TMGIEN,newRec - . . set newRec=0 - . . set key="" for set key=$order(tempArray(index,key)) quit:(key="")!(RESULT'=1) do - . . . if key="NAME" set TMGFDA(2.01,index_","_DFN_",",.01)=$get(tempArray(index,"NAME")) - . . . if key="SSN" set TMGFDA(2.01,index_","_DFN_",",1)=$get(tempArray(index,"SSN")) - . . . if index["+" set newRec=1 - . . if $data(TMGFDA) do - . . . if newRec=0 do FILE^DIE("EKST","TMGFDA","TMGMSG") - . . . else do UPDATE^DIE("ES","TMGFDA","TMGIEN","TMGMSG") - . . if $data(TMGMSG("DIERR")) do - . . . set RESULT="-1^Filing Error Occured: "_$get(TMGMSG("DIERR",1,"TEXT",1)) - . . . ;"merge ^TMG("TMP","RPC","DIERR")=TMGMSG("DIERR") - . . . ;"merge ^TMG("TMP","RPC","FDA")=TMGFDA - - quit - -PTADD(RESULT,INFO) ;" ADD PATIENT - ;"Purpose: To add a patient - ;"Input: RESULT (this is the output array) - ;" - ;" INFO: Format as follows: - ;" The results are in format: INFO("KeyName")=Value, - ;" There is no set order these will appear. - ;" Here are the KeyName names that will be provided. - ;" If the record has no value, then value will be empty - ;" If a record should be deleted, its value will be @ - ;" INFO("COMBINED_NAME")= - ;" INFO("DOB")= - ;" INFO("SEX")= - ;" INFO("SS_NUM")= - ;" INFO("Veteran")= - ;" INFO("PtType")= - ;"Results: Results passed back in RESULT string: - ;" DFN = success - ;" -1^Message = failure - ;" 0^DFN = already exists - - set RESULT=1 ;"default to success - - kill ^TMG("TMP","RPC") - merge ^TMG("TMP","RPC")=INFO ;"temp... remove later - - new TMGFDA,TMGMSG,IENS,PATIENT,DFN,TMGFREG - ;" set IENS=DFN_"," - new key set key="" - for set key=$order(INFO(key)) quit:(key="") do - . if key="COMBINED_NAME" set PATIENT("NAME")=INFO("COMBINED_NAME") - . else if key="DOB" set PATIENT("DOB")=INFO("DOB") - . else if key="SEX" set PATIENT("SEX")=INFO("SEX") - . else if key="SS_NUM" set PATIENT("SSNUM")=INFO("SS_NUM") - . else if key="Veteran" set PATIENT("VETERAN")=INFO("Veteran") - . else if key="PtType" set PATIENT("PT_TYPE")=INFO("PtType") - set DFN=$$GetDFN^TMGGDFN(.PATIENT) - if DFN=-1 do - . new Entry,result,ErrMsg - . do Pat2Entry^TMGGDFN(.PATIENT,.Entry) - . set DFN=$$AddNewPt^TMGGDFN(.Entry,.ErrMsg) - . ;"set DFN=$$GetDFN^TMGGDFN(.PATIENT) - . if DFN'>0 do - . . set RESULT="-1^ERROR ADDING" ;"should use ErrMsg from above. Fix later - . . set RESULT=RESULT_". "_$$GetErrStr^TMGDEBUG(.ErrMsg) - . else do - .. set RESULT=DFN - else do - . set RESULT="0^"_DFN - - quit - - -GETBARCD(GREF,MESSAGE,OPTION) - ;"SCOPE: Public - ;"RPC that calls this: TMG BARCODE ENCODE - ;"Purpose: To provide an entry point for a RPC call from a client. - ;" A 2D DataMatrix Bar Code will be create and passed to client. - ;" It will not be stored on server - ;"Input: GREF -- OUT PARAM -- the array to pass the result back in (PASSED BY REFERENCE) - ;" MESSAGE-- The text to use to create the barcode - ;" OPTION -- Array that may hold optional settings, as follows: - ;" OPTION("IMAGE TYPE")="jpg" <-- if not specified, then default is "png" - ;"Output: results are passed out in @GREF - ;" @GREF@(0)=success; 1=success, 0=failure - ;" @GREF@(1..xxx) = actual data - - ;"NOTE: dmtxread must be installed on linux host. - ;" I found source code here: - ;" http://sourceforge.net/projects/libdmtx/ - ;" After installing (./configure --> make --> make install), I - ;" copied dmtxread and dmtxwrite, which were found in the - ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs - ;" folders, into a folder on the system path. I chose /usr/bin/ - ;" Also, to achieve compile of above, I had to install required libs. - ;" See notes included with dmtx source code. - - new FileSpec - new file - new FName,FPath - - set GREF="^TMP(""GETBARCD^TMGRPC1"","_$J_")" - kill @GREF - set @GREF@(0)="" ;"default to failure - set MESSAGE=$get(MESSAGE) - if MESSAGE="" goto GBCDone - - ;"Create the barcode and get file name and path - set file=$$MAKEBC^TMGBARC(MESSAGE,.OPTION) - do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") - - ;"Load binary image into global array - set @GREF@(0)=$$BFTG^TMGBINF(.FPath,.FName,$name(@GREF@(1)),3) - - ;"convert binary data to ascii encoded data - do ENCODE($name(@GREF@(1)),3) - - ;"delete temp image file - do SplitFNamePath^TMGIOUTL(file,.FPath,.FName,"/") - set FileSpec(FName)="" - new temp set temp=$$DEL^%ZISH(FPath,"FileSpec") - -GBCDone - quit - - -DECODEBC(RESULT,ARRAY,IMGTYPE) - ;"SCOPE: Public - ;"RPC that calls this: TMG BARCODE DECODE - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will upload an image file (.png format only) of a barcode (Datamatrix - ;" format) for decoding. Decoded message is passed back. - ;"Input: RESULT -- an OUT PARAMETER. See output below. - ;" ARRAY -- the array that will hold the image file, in BASE64 ascii encoding - ;" IMGTYPE -- Image type, e.g. "jpg" (Note: don't include any '.') - ;"Output: results are passed out in RESULT: 1^Decoded Message or 0^FailureMessage - - ;"NOTE: dmtxread must be installed on linux host. - ;" I found source code here: - ;" http://sourceforge.net/projects/libdmtx/ - ;" After installing (./configure --> make --> make install), I - ;" copied dmtxread and dmtxwrite, which were found in the - ;" (installdir)/util/dmtxread/.libs and (installdir)/util/dmtxwrite/.libs - ;" folders, into a folder on the system path. I chose /usr/bin/ - ;" Also, to achieve compile of above, I had to install required libs. - ;" See notes included with dmtx source code. - ;"NOTE: if image types other than .png will be uploaded, then the linux host - ;" must have ImageMagick utility 'convert' installed for conversion - ;" between image types. - - kill ^TMG("TMP","BARCODE") - ;"set ^TMG("TMP","BARCODE","LOG")=1 ;"temp - - ;"new Stack do GetStackInfo^TMGIDE2(.Stack) - ;"merge ^TMG("TMP","BARCODE","STACK")=Stack - - new resultMsg - if $data(ARRAY)=0 set resultMsg="0^No image data received to decode" goto DBCDone - - new imageType set imageType=$$LOW^XLFSTR($get(IMGTYPE)) - if imageType="" set resultMsg="0^Image type not specified" goto DBCDone - - new imageFName set imageFName="/tmp/barcode."_imageType - set imageFName=$$UNIQUE^%ZISUTL(imageFName) - new FName,FPath,FileSpec - do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") - set FileSpec(FName)="" - - ;"temp... - ;"merge ^TMG("TMP","BARCODE","DATA")=ARRAY - ;"merge ^TMG("TMP","BARCODE","IMGTYPE")=IMGTYPE - - ;"set ^TMG("TMP","BARCODE","LOG")=2 ;"temp - ;"Remove BASE64 ascii encoding - do DECODE("ARRAY(0)",1) - - ;"set ^TMG("TMP","BARCODE","LOG")=3 ;"temp - ;"set ^TMG("TMP","BARCODE","LOG","Orig file: "_FPath_FName)="" - - ;"Save to host file system - if $$GTBF^TMGBINF("ARRAY(0)",1,FPath,FName)=0 do goto DBCDone - . set resultMsg="0^Error while saving file to HFS" - - ;"set ^TMG("TMP","BARCODE","LOG")=4 ;"temp - - ;"convert image file to .png format, if needed - if imageType'="png" do - . set imageFName=$$Convert^TMGKERNL(imageFName,"png") - . if imageFName="" do quit - . . set resultMsg="0^Error while converting image from ."_imageType_" to .png format." - . do SplitFNamePath^TMGIOUTL(imageFName,.FPath,.FName,"/") - . set FileSpec(FName)="" - if imageFName="" goto DBCDone - - ;"set ^TMG("TMP","BARCODE","LOG")=5 ;"temp - - ;"Decode the barcode.png image - new result set result=$$READBC^TMGBARC(imageFName) - if result'="" set resultMsg="1^"_result - else set resultMsg="0^Unable to Decode Image" - - ;"delete temp image file - ;"temp REMOVE COMMENTS LATER TO DELETE FILE. !!!!! - ;"set result=$$DEL^%ZISH(FPath,"FileSpec") - -DBCDone - ;"set ^TMG("TMP","BARCODE","LOG")=6 ;"temp - - set RESULT=resultMsg - quit - - ;"-------------------- -GETURLS(RESULT) - ;"SCOPE: Public - ;"RPC that calls this: TMG CPRS GET URL LIST - ;"Purpose: To provide an entry point for a RPC call from a client. The client - ;" will request URLs to display in custom tabs inside CPRS, in an - ;" imbedded web browser - ;"Input: RESULT -- an OUT PARAMETER. See output below. - ;"Output: results are passed out in RESULT: - ;" RESULT(0)="1^Success" or "0^SomeFailureMessage" - ;" RESULT(1)="Name1^URL#1" ; shows URL#1 in tab #1, named 'Name1' - ;" RESULT(2)="Name2^URL#2" ; etc. - ;" RESULT(3)="Name3^URL#3" - ;" - ;" E.g. RESULT(1)="cnn^www.cnn.com" - ;" RESULT(2)="INFO^192.168.0.1/home.html" - ;" - ;" The number of allowed tabs is determined by code in CPRS - ;" Reference to tab numbers > specified in CPRS will be ignored by CPRS - ;" If a web tab is NOT specified, then the page previously - ;" displayed will be left in place. It will not be cleared. - ;" To clear a given page, a url of "about:blank" will cause a - ;" blank page to be displayed. e.g. - ;" RESULT(3)="^about:blank" - ;" To HIDE a tab on CPRS use this: - ;" RESULT(3)="^" ;triggers tab #3 to be hidden - ;" To have the browser remain UNCHANGED use this: - ;" RESULT(3)="^" ;triggers tab #3 to remain unchanged. - ;" Note: the rationale for this is that the web tab may have info - ;" that should not be refreshed when the patient info is refreshed - ;" i.e. the user may have navigated somewhere, and doesn't want - ;" to loose their location. - ;" --to be implemented. - ;" Note: The other way to do this, as above, is to simply have NO - ;" entry for a given tab. I.e. don't have any value for RESULT(3) - ;" --already implemented. - ;"Notice to others: Below is where code should be added to return - ;" proper URL's to CPRS. This will be called whenever a new patient - ;" is opened, or a Refresh Information is requested. - ;" FYI, 'DFN' should be defined as a globally-scoped variable that can be used - ;" to pass back URLS specific for a given patient. - - set RESULT(0)="1^Success" - ;"set RESULT(1)="Yahoo^www.yahoo.com" - ;"set RESULT(2)="(x)^about:blank" - ;"set RESULT(3)="^" - - ;"kill RESULT - ;"merge RESULT=^TMG("TMP","URLS") ;"TEMP!!! - - quit - - ; Index: cprs/branches/tmg-cprs/m_files/TMGRPC1B.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1B.m~ (revision 796) +++ (revision ) @@ -1,83 +1,0 @@ -TMGRPC1B ;TMG/kst-RPC Functions ;3/28/10 - ;;1.0;TMG-LIB;**1**;3/28/10 - ; - ;"TMG RPC FUNCTIONS - ; - ;"Copyright Kevin Toppenberg MD - ;"Released under GNU General Public License (GPL) - ;" - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"EVALTIUO - ;"INSTALL -- Add the RPC's to the OPTION record OR CPRS GUI CHART - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"INSTALL1(RPCNAME) -- Add 1 RPC to the OPTION record OR CPRS GUI CHART - ; - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" DIC, TMGDEBUG - ;"======================================================================= - ;"======================================================================= - ; -EVALTIUO(TMGY,TMGOBJNM) ;"--- DEPRECIATED. Will use 'TIU TEMPLATE GETTEXT' RPC instead - ;"Purpose: To return the resolved text of a TIU Text Object. - ;"Input: TIUY -- This is output result for RPC caller - ;" TMGOBJNM -- This is the name of the TIU TEXT OBJECT to obtain. - ;"Note: lines wrapped at 200 chars length - ;"Results : none - ; - KILL ^TMG("TMP","TABLE") - zshow "*":^TMG("TMP","TABLE") - NEW TMGSTR - SET TMGOBJNM=$GET(TMGOBJNM) - IF TMGOBJNM["|" DO GOTO STOR - . SET TMGSTR="Passed TEXT OBJECT name should not contain '|' character" - SET TMGSTR="|"_TMGOBJNM_"|" - SET TMGSTR=$$BOIL^TIUSRVD(TMGSTR) ;" Execute Boilerplates - ; -STOR NEW REF SET REF=$NAME(^TMP("TMG OBJ EVAL",$J)) - NEW IDX SET IDX=0 - KILL @REF - SET TMGY=REF - FOR DO QUIT:(TMGSTR="") - . NEW SA,SB - . SET (SA,SB)="" - . IF $LENGTH(TMGSTR)>200 DO - . . SET SB=$EXTRACT(TMGSTR,201,999) - . . SET TMGSTR=$EXTRACT(TMGSTR,1,200) - . SET IDX=IDX+1 - . SET @REF@(IDX)=TMGSTR - . SET TMGSTR=SB - QUIT - ; - ; -INSTALL ; - ;"Purpose: to add the RPC's to the OPTION record OR CPRS GUI CHART - DO INSTALL1("TMG EVAL TIU TEXT OBJECT") - QUIT - ; -INSTALL1(RPCNAME) ; - ;"Purpose: to add 1 RPC to the OPTION record OR CPRS GUI CHART - NEW DIC,X,Y,DA - SET DIC="^DIC(19,",DIC(0)="M" - SET X="OR CPRS GUI CHART" - DO ^DIC - IF +Y'>0 DO QUIT - . WRITE "ERROR. Unable to find [OR CPRS GUI CHART] in file OPTION (#19)",! - . NEW TEMP READ "Press [ENTER] to continue...",TEMP:($GET(DTIME,3600)) - . WRITE ! - SET DA(1)=+Y - SET DIC=DIC_DA(1)_",""RPC""," - SET DIC(0)="ML" ;"LAYGO --> add entry if not found - SET X=RPCNAME - DO ^DIC - IF +Y'>0 DO - . WRITE "ERROR. Unable to add or find "_RPCNAME_" for subfile RPC in record",! - . WRITE "OR CPRS GUI CHART in file OPTION (#19)",! - . NEW TEMP READ "Press [ENTER] to continue...",TEMP:($GET(DTIME,3600)) - . WRITE ! - QUIT Index: cprs/branches/tmg-cprs/m_files/TMGRPC1C.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1C.m~ (revision 796) +++ (revision ) @@ -1,278 +1,0 @@ -TMGRPC1C ;TMG/kst-RPC Functions for CPRS for Search functionality ;4/28/10 ; 5/18/10 12:57pm - ;;1.0;TMG-LIB;**1**;4/28/10 - ; - ;"TMG RPC FUNCTIONS - ; - ;"Copyright Kevin Toppenberg MD 4/28/10 - ;"Released under GNU General Public License (GPL) - ;" - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"SRCH(OUT,FILENUM,STR) --A search function, to support calls by RPC from CPRS - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ; - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" DIC, TMGDEBUG - ;"======================================================================= - ;"======================================================================= - ; - ; - ; -SRCH(OUT,FILENUM,STR) ; - ;"Purpose: A search function, to support calls by RPC from CPRS - ;"Input: OUT-- Pass by reference. AN OUT PARAMETER. - ;" FILENUM -- The target file number that resulting IENs will be in - ;" STR -- This is a logic string for searching. See details below. - ;"Results: OUT is filled in. Format: - ;" OUT(0)=1 for success, or -1^Error Message - ;" OUT(IEN)="" - ;" OUT(IEN)="" - ;"Search string examples: - ;" 8925:.02(.01="SMITH,JOHN") - ;" 1234:.01(.03in"32..55") <-- this is a range test - ;" 1234:.99((.01="SMITH,JOHN") OR (.01="SMITH,BILL")) AND 4567:.01(.02'="4/2/10") NOT (1["HAPPY") - ;" -- File specifier. To specify searching in a file OTHER THAN target filenumber, an optional - ;" FILENUM:FLD[:FLD[:FLD...]] may be specified. However, ultimately, this must point back - ;" to the target filenumber. E.g. Search in file 8925, but for each entry found, use the IEN - ;" specified by FLD (or FLDA:FLDB or FLDA:FLDB:FLDC:...) - ;" FILENUM:(...) - ;" The logic is read from left to right, honoring parentheses. If a filenumber - ;" is not specified, then the last specified filenumber is used. - ;" E.g. 1234:.01( LogicA ) OR 234:.99( LogicB ) AND ( LogicC ) - ;" LogicA fields refer to file 1234:.01. - ;" LogicB fields refer to file 234:.99 - ;" LogicA fields refer to file 234:.99 (last specified file number) - ;" E.g. 5678:.01( (LogicA1) OR 5432:.88(LogicA2) NOT (LogicA3) ) or (LogicB) - ;" LogicA1 fields refer to file 5678:.01 - ;" LogicA2 fields refer to file 5432:.88 - ;" LogicA3 fields refer to file 5432:.88 (last specified file number inside parentheses) - ;" LogicB fields refer to file 5678 (last specified file number at same parentheses level) - ;" -- Each individual search term must be enclosed in parentheses, and may contain sub-terms - ;" enclosed in nested parentheses - ;" -- Each individual search term is comprised of: - ;" FIELD then COMPARATOR then VALUE - ;" 1. FIELDS -- can be name or number. This is for currently active file (see below) - ;" may also be FIELDA:FIELDB:... when FIELDA is a pointer, then FIELDB - ;" is taken from the pointed-to field. - ;" 2. COMPARATOR -- can be: - ;" "=" -- means exact match - ;" "'=", "!=", "<>", -- any of these means 'Does not equal' - ;" ">=", "'<" -- means greater-than-or-equal-to (same as not-less-than) - ;" "<=", "'>" -- means less-than-or-equal-to (same sa not-greater-than) - ;" "in","IN","In" -- means field is in specified rage (see Value below) - ;" "[" -- means 'contains'. Interpreted as follows: - ;" -- For Word processor (WP) fields, this means that any line in the entire field - ;" can contain search term, to be matched positive. - ;" -- For free text field, then just text of field is searched. - ;" -- For Date fields .... (FINISH THIS...) - ;" -- For Sets ... (FINISH THIS...) - ;" 3. VALUE -- The search term to search for. Should be in quotes. - ;" Note: if comparator is "IN", then syntax is "Value1..Value2" - ;" There should be a ".." between the two values. - ;" -- Logical combiners of separate search terms allowed are: - ;" "OR" or "|" or "||" - ;" "AND" or "&" or "&&" - ;" "NOT" or "!" or "'" or "ANDNOT" - ;" -- Logic short-circuiting is applied. The algorhythm will try to identify the elements - ;" of the search that will be the fastest, and then work from that set, to make the overall - ;" search better. - ;" -- Searching of subfiles is not currently supported. IMPLEMENT LATER.... - ;"Results: None - ;" - NEW ARRAY,RESULT - SET FILENUM=$GET(FILENUM) - SET ARRAY("FILE")=FILENUM - SET OUT(0)=1 ;"Default to success - SET RESULT=$$PARSESTR(FILENUM,STR,.ARRAY) - ZWR ARRAY - DO PressToCont^TMGUSRIF - quit - IF +RESULT=-1 SET OUT(0)=RESULT GOTO SRCHDN - SET RESULT=$$OPTIMIZ(.ARRAY) - IF +RESULT=-1 SET OUT(0)=RESULT GOTO SRCHDN - SET RESULT=$$DOSRCH(.ARRAY,.OUT) - IF +RESULT=-1 SET OUT(0)=RESULT GOTO SRCHDN -SRCHDN QUIT - ; - ; -PARSESTR(FILENUM,STR,ARRAY,FNUMPTR) ; - ;"Purpose: To take user input, validate it, and parse into an formatted array - ;"Input: STR: This is the user input string. Format as documented in SRCH() above. - ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. - ;" ARRAY(1,"FNUMPTR")= FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that - ;" contain search field, and then fields used to point - ;" back to *TARGET* FILENUM for entire search - ;" ARRAY(1,"FLD")=Fieldnumber to search - ;" ARRAY(1,"COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[" - ;" ARRAY(1,"SRCH")=The value of to be used in search. - ;" ARRAY(2,...) The second search term. - ;" ARRAY(3,...) The third search term (which is comprised of sub terms) - ;" ARRAY(3,1,... The first subterm (same format as higher level) - ;" ARRAY(3,2,... The second subterm (same format as higher level) - ;" ARRAY(n,...) The N'th search term. - ;" ARRAY("SETCOMP",i)= NumA^Combiner^NumB - ;" NumA and NumB refer to seach term number (e.g. 1, 2, ... n above) - ;" If NumA="#", then it means 'the resulting set of results so far' - ;" Combiner will be "AND", "OR", or "NOT" - ;" i is the index variable, and logic should be evaluated in numerical order - ;" FNUMPTR: Will be used when calling self reiteratively. Leave blank in first call. - ;" DON'T pass by reference. This is 'FileNum:FLD[:FLD[:FLD...]] specifier - ;"Results: 1 if OK, or -1^Message if error during processing. - ; - NEW SUBSTRA,SUBSTRB,POS - NEW RESULT SET RESULT=1 ;"default to success - NEW TERMNUM SET TERMNUM=0 - SET FNUMPTR=$GET(FNUMPTR,FILENUM) - NEW LOGICNUM SET LOGICNUM=0 - NEW DONE SET DONE=0 - FOR DO QUIT:(DONE=1)!(+RESULT=-1) - . NEW TEMPARRAY - . SET TERMNUM=TERMNUM+1 - . ;"--- Get file number, if any - . SET STR=$$TRIM^XLFSTR(STR) - . IF +$PIECE(STR,"(",1)>0 DO QUIT:(+RESULT=-1) - . . SET FNUMPTR=$PIECE(STR,"(",1) ;"Convert 1234:.01:.02:(...) --> 1234:.01:.02: - . . IF $EXTRACT(FNUMPTR,$LENGTH(FNUMPTR))=":" SET FNUMPTR=$EXTRACT(FNUMPTR,1,$LENGTH(FNUMPTR)-1) - . . IF $$FNPTR(FNUMPTR)'=FILENUM DO QUIT - . . . SET RESULT="-1^'"_FNUMPTR_"' points to file #"_$$FNPTR(FNUMPTR)_", not file #"_FILENUM_" as expected" - . ;"Split STR --> SUBSTRA + SUBSTRB - . SET SUBSTRA=$$MATCHXTR^TMGSTUTL(STR,"(") - . IF SUBSTRA="" SET DONE=1 QUIT - . SET POS=$FIND(STR,SUBSTRA) ;"Return pos of following character - . SET SUBSTRB=$EXTRACT(STR,POS+1,9999) ;"Should be " [LOGICTERM] [SearchTerm]..." - . ;"Process SUBSTRA, either directly if single term, or recursively if compound term. - . IF $$HNQTSUB^TMGSTUTL(SUBSTRA,"(") DO - . . SET RESULT=$$PARSESTR(FILENUM,SUBSTRA,.TEMPARRAY,FNUMPTR) - . ELSE DO - . . SET RESULT=$$PARSE1(FILENUM,SUBSTRA,FNUMPTR,.TEMPARRAY) - . IF +RESULT=-1 QUIT - . MERGE ARRAY(TERMNUM)=TEMPARRAY - . ;"Now get Logic term connecting this to next term (if any) - . SET SUBSTRB=$$TRIM^XLFSTR(SUBSTRB) ;"Remove opening (and closing) spaces - . NEW LOGICTERM SET LOGICTERM=$$UP^XLFSTR($PIECE(SUBSTRB," ",1)) - . IF LOGICTERM="" SET DONE=1 QUIT - . IF (LOGICTERM="|")!(LOGICTERM="||") SET LOGICTERM="OR" - . ELSE IF (LOGICTERM="&")!(LOGICTERM="&&") SET LOGICTERM="AND" - . ELSE IF (LOGICTERM="!")!(LOGICTERM="'")!(LOGICTERM="ANDNOT") SET LOGICTERM="NOT" - . IF (LOGICTERM="AND")!(LOGICTERM="OR")!(LOGICTERM="NOT") DO - . . NEW CURSET SET CURSET=$SELECT(TERMNUM=1:"1",1:"#") - . . SET LOGICNUM=LOGICNUM+1 - . . SET ARRAY("SETCOMP",LOGICNUM)=CURSET_"^"_LOGICTERM_"^"_(TERMNUM+1) ;"will check later that TERMNUM+1 is supplied - . ELSE DO QUIT - . . SET RESULT="-1^Bad logic term. Expect 'AND', 'OR', or 'NOT'. Found: ["_LOGICTERM_"]" - . SET STR=$PIECE(SUBSTRB," ",2,999) - QUIT RESULT - ; - ; -FNPTR(FNUMPTR) ; - ;"Puprose: To resolve a FNUMPTR, finding ultimate target file - ;"Input: FNUMPTR: Format: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that - ;" contain search field, and then fields used to point to *TARGET* FILENUM - ;"Results: -1^Error message if error, otherwise returns pointed to file - NEW RESULT,FILE,FLD,I,DONE - SET FILE=+$GET(FNUMPTR) - SET RESULT=0 - SET DONE=0 - FOR I=2:1:999 DO QUIT:(+RESULT=-1)!(DONE=1) - . SET FLD=$PIECE(FNUMPTR,":",I) - . IF FLD="" SET DONE=1 QUIT - . IF $DATA(^DD(FILE,FLD,0))=0 DO QUIT - . . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_FILE_"]" - . NEW FLDTYPE SET FLDTYPE=$PIECE(^DD(+FILE,+FLD,0),"^",2) - . IF FLDTYPE'["P" DO QUIT - . . SET RESULT="-1^Field ["_FLD_"] does not point to another file." - . SET FILE=+$PIECE(FLDTYPE,"P",2) - SET RESULT=FILE - QUIT RESULT - ; -PARSE1(FILENUM,STR,FNUMPTR,ARRAY) ; - ;"Purpose: Parse a simple search term (e.g. .01="SMITH,JOHN"). Also validate that field exists in file. - ;"Input: FILENUM -- The TARGET filenumber that the entire search is referencing. - ;" STR: This is part of the user input string to parse - ;" FNUMPTR: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that contain search field, and then - ;" fields used to point back to *TARGET* FILENUM for entire search - ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. - ;" ARRAY("FNUMPTR")=Filenumber that contains field) - ;" ARRAY("FLD")=Fieldnumber to search - ;" ARRAY("COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[","IN" - ;" ARRAY("SRCH")=The value of to be used in search. - ;"NOTE: If field specifies a DATE, then the search value will be converted to FileMan format - ;"Results: 1 if OK, or -1^Message if error during processing. - ;" - NEW RESULT SET RESULT=1 ;"default to success - NEW SAV SET SAV=STR - SET STR=$$TRIM^XLFSTR($GET(STR)) - SET ARRAY("FNUMPTR")=FNUMPTR - NEW FLD SET FLD=+STR - IF $DATA(^DD(+FNUMPTR,FLD,0))=0 DO GOTO PS1DN - . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_+FNUMPTR_"]" - FOR DO QUIT:(+STR=0) - . SET STR=$EXTRACT(STR,$LENGTH(+STR)+1,9999) ;"Strip off field number - . IF $EXTRACT(STR,1)=":" DO ;"Handle '.02:.99:.01' format, as Fileman does. - . . SET STR=$$TrimL^TMGSTUTL(STR,":") - . . IF +STR>0 SET FLD=FLD_":"_+STR - SET ARRAY("FLD")=FLD - NEW FLDTYPE SET FLDTYPE=$PIECE(^DD(+FNUMPTR,+FLD,0),"^",2) - IF (FLD[":"),(FLDTYPE'["P") DO GOTO PS1DN - . SET RESULT="-1^Found fields ["_FLD_"], however field "_+FLD_" is not a pointer in file "_FILENUM - IF FLDTYPE["M" DO GOTO PS1DN - . SET RESULT="-1^Searches in fields that are MULTIPLES not supported" - NEW COMP SET COMP=$PIECE(STR,"""",1) - SET COMP=$$UP^XLFSTR($$TRIM^XLFSTR(COMP)) - IF (COMP="!=")!(COMP="<>") SET COMP="'=" - ELSE IF (COMP=">=") SET COMP="'<" - ELSE IF (COMP="<=") SET COMP="'>" - NEW NOT SET NOT=$EXTRACT(COMP,1) IF NOT'="'" SET NOT="" - IF (COMP="=")!(COMP="[")!(COMP="IN")!(COMP="<")!(COMP=">") DO - . SET ARRAY("COMP")=NOT_COMP - ELSE DO GOTO PS1DN - . SET RESULT="-1^Comparator ["_COMP_"] is not valid" - NEW SRCH SET SRCH=$PIECE(STR,"""",2,999) ;"Will strip off opening quotes - IF $EXTRACT(SRCH,$LENGTH(SRCH))="""" SET SRCH=$EXTRACT(SRCH,1,$LENGTH(SRCH)-1) ;"Strip closing quote - IF FLDTYPE["D" DO ;"Convert search value into a FM date (internal format) - . NEW ADATE SET ADATE=SRCH - . NEW TEMPRSLT SET TEMPRSLT="" - . FOR QUIT:(ADATE="")!(+RESULT=-1) DO - . . NEW X,Y,%DT - . . SET %DT="T" - . . SET X=$PIECE(ADATE,"..",1) - . . SET ADATE=$PIECE(ADATE,"..",2) - . . DO ^%DT - . . IF Y=-1 DO QUIT - . . . SET RESULT="-1^Invalid date: ["_X_"]" - . . . SET SRCH="",ADATE="" - . . IF TEMPRSLT'="" SET TEMPRSLT=TEMPRSLT_".." - . . SET TEMPRSLT=TEMPRSLT_Y - . SET SRCH=TEMPRSLT - ELSE IF FLDTYPE["S" DO ;"Convert FM SET type into internal format - . NEW OUT,TMGMSG - . DO VAL^DIE(+FNUMPTR,"+1,",FLD,"E",SRCH,.OUT,,"TMGMSG") - . SET SRCH=$GET(OUT) - IF SRCH'="" SET ARRAY("SRCH")=SRCH - ELSE DO GOTO PS1DN - . SET RESULT="-1^Search value is invalid" - ; -PS1DN IF +RESULT=-1 SET RESULT=RESULT_", found in ["_SAV_"]" - QUIT RESULT - ; -SRCHSUB(RESULT,TERMS) ; - ;"Purpose: A search function, to support calls by RPC from CPRS - ;"Input: RESULT-- Pass by reference. AN OUT PARAMETER. - ;" TERMS -- Pass by reference. Contains search terms. Format - ;" TERMS("FILE")=FileNumber - ;" TERMS(Field)=Comparator^SearchValue - ;" TERMS(Field)=Comparator^SearchValue - ;" -- Allowed Comparators: "=","[","<", - ;"Results: RESULT is filled in. Format: - ;" RESULT(0)=1 for success, or -1^Error Message - ;" RESULT(IEN)="" - ;" RESULT(IEN)="" - ;"NOTE: When multiple fields are specfied, then search results will combine terms - ;" in an AND fashion. I.e. results only returned that match ALL specified terms. - ; - QUIT Index: cprs/branches/tmg-cprs/m_files/TMGRPC3B.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC3B.m~ (revision 796) +++ (revision ) @@ -1,226 +1,0 @@ -TMGRPC3B ;TMG/kst/Support Functions for GUI_Config ;08/31/08 ; 5/12/10 4:57pm - ;;1.0;TMG-LIB;**1**;08/31/08 - ; - ;"TMG RPC FUNCTIONS for a GUI config program - ; - ;"Kevin Toppenberg MD - ;"GNU Lessor General Public License (LGPL) applies - ;"7/20/08 - ; - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;" - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"GETUSRLT(TMGOUT,TMGPARAMS) -- fill list with users on the system. - ;"GETRECLT(TMGOUT,TMGPARAMS) -- fill list with records in file on the system - ;"GET1USER(TMGOUT,TMGIEN) -- Get one user's record - ;"GET1REC(TMGOUT,TMGPARAMS) -- get one record in file - ;"XTRCTFLD(TMGOUT,TMGARRAY,TMGFLAG) -- convert output from GETS^DIQ into another format - ;"GFLSUBST(TMGOUT,TMGPARAMS) -- return a subset of entries a file's .01 names - ; - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" TMGRPC3* only - ; - ;"======================================================================= - ;"======================================================================= - ; - ;"======================================================================= - ; -GETUSRLT(TMGOUT,TMGPARAMS) ;"GET USER LIST - ;"Purpose: to fill list with users on the system. - ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. - ;" TMGPARAMS -- either "" or "NODISUSER" if not to return DISUSER=YES users - ;"Output: TMGOUT is filled as follows: - ;" TMGOUT(0)="1^Success" or "-1^Message" - ;" TMGOUT(1)=Name^IEN^200^DISUSER DISUSER will be 1 for "Y" or 0 for "N" - ;" TMGOUT(2)=Name^IEN^200^DISUSER - ;"Results: none - ; - NEW TMGACTIVEONLY SET TMGACTIVEONLY=($GET(TMGPARAMS)="NODISUSER") - NEW TMGINDEX SET TMGINDEX=1 - NEW TMGNAME SET TMGNAME="" - FOR SET TMGNAME=$ORDER(^VA(200,"B",TMGNAME)) QUIT:(TMGNAME="") DO - . NEW TMGIEN SET TMGIEN="" - . FOR SET TMGIEN=$ORDER(^VA(200,"B",TMGNAME,TMGIEN)) QUIT:(+TMGIEN'>0) DO - . . NEW TMGDISUSER SET TMGDISUSER=$PIECE($GET(^VA(200,TMGIEN,0)),"^",7) - . . IF (TMGACTIVEONLY)&(TMGDISUSER) QUIT - . . NEW TMGNAME SET TMGNAME=$PIECE($GET(^VA(200,TMGIEN,0)),"^",1) - . . SET TMGOUT(TMGINDEX)=TMGNAME_"^"_TMGIEN_"^200^"_TMGDISUSER - . . SET TMGINDEX=TMGINDEX+1 - ; - SET TMGOUT(0)="1^Success" - ; - QUIT - ; -GETRECLT(TMGOUT,TMGPARAMS) ;"GET RECS LIST - ;"Purpose: to fill list with records in file on the system. - ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. - ;" TMGPARAMS -- Filenumber - ;"Output: TMGOUT is filled as follows: - ;" TMGOUT(0)="1^Success" or "-1^Message" - ;" TMGOUT(1)=.01Value^IEN^FileNum - ;" TMGOUT(2)=.01Value^IEN^FileNum - ;"Results: none - ; - NEW TMGINDEX SET TMGINDEX=1 - NEW TMGNAME SET TMGNAME="" - NEW TMGFNUM SET TMGFNUM=+$GET(TMGPARAMS) - IF TMGFNUM'>0 DO GOTO GRLDONE - . SET TMGOUT(0)="-1^Valid file number not found" - NEW TMGREF SET TMGREF=$GET(^DIC(TMGFNUM,0,"GL")) - SET TMGREF=$$CREF^DILF(TMGREF) - IF TMGREF="" DO GOTO GRLDONE - . SET TMGOUT(0)="-1^Unable to find global reference for file: "_TMGFNUM - NEW TMGLOC,TMGPIECE - SET TMGLOC=$PIECE(^DD(TMGFNUM,.01,0),"^",4) - SET TMGPIECE=$PIECE(TMGLOC,";",2) - SET TMGLOC=$PIECE(TMGLOC,";",1) - FOR SET TMGNAME=$ORDER(@TMGREF@("B",TMGNAME)) QUIT:(TMGNAME="") DO - . NEW TMGIEN SET TMGIEN="" - . FOR SET TMGIEN=$ORDER(@TMGREF@("B",TMGNAME,TMGIEN)) QUIT:(+TMGIEN'>0) DO - . . NEW TMGNAME SET TMGNAME=$PIECE($GET(@TMGREF@(TMGIEN,TMGLOC)),"^",TMGPIECE) - . . SET TMGOUT(TMGINDEX)=TMGNAME_"^"_TMGIEN_"^"_TMGFNUM - . . SET TMGINDEX=TMGINDEX+1 - ; - SET TMGOUT(0)="1^Success" -GRLDONE ; - QUIT - ; -GET1USER(TMGOUT,TMGIEN) ;"GET ONE USER - ;"Purpose: to get record of one user - ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. - ;" TMGIEN -- the IEN in file 200 to get - ;"Output: TMGOUT is filled as follows: - ;" TMGOUT(0)="1^Success" or "-1^Message" - ;" TMGOUT(1)=File^IENS^FieldNum^ExternalValue^DDInfo... - ;" TMGOUT(2)=File^IENS^FieldNum^ExternalValue^DDInfo... - ;"Note: the fields to return are decided HERE - ;"Results: none - ; - NEW TMGIENS SET TMGIENS=+$GET(TMGIEN)_"," - DO GET1REC(.TMGOUT,"200^"_TMGIENS) - QUIT - ; - ; -GET1REC(TMGOUT,TMGPARAMS) ; - ;"Purpose: to get one record in file - ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. - ;" TMGPARAMS: File^IENS - ;" File -- the file or subfile to retrieve from - ;" IENS -- if File is a subfile, then IENS should be full IENS to get (e.g. '2,103,') - ;" if File is not a subfile, then IENS can be just IEN or IEN_"," - ;"Output: TMGOUT is filled as follows: - ;" TMGOUT(0)="1^Success" or "-1^Message" - ;" TMGOUT(1)=File^IENS^FieldNum^ExternalValue^DDInfo... - ;" TMGOUT(2)=File^IENS^FieldNum^ExternalValue^DDInfo... - ;"Note: the fields to return are decided HERE - ;"Results: none - ; - SET TMGOUT(0)="1^Success" ;"default to success - NEW TMGARRAY,TMGMSG - NEW TMGREF SET TMGREF="TMGARRAY" - SET TMGPARAMS=$GET(TMGPARAMS) - SET ^TMG("TMP","RPC","GET1REC")=TMGPARAMS - NEW TMGFILE SET TMGFILE=$PIECE(TMGPARAMS,"^",1) - IF +TMGFILE'>0 DO GOTO GORDONE - . SET TMGOUT(0)="-1^No file number supplied" - NEW TMGIENS SET TMGIENS=$PIECE(TMGPARAMS,"^",2) - IF TMGIENS="" DO GOTO GORDONE - . SET TMGOUT(0)="-1^No IENS supplied" - ; - DO GETS^DIQ(TMGFILE,TMGIENS,"**","IE",TMGREF,"TMGMSG") - ; - IF $DATA(TMGMSG("DIERR")) DO GOTO GORDONE - . SET TMGOUT(0)="-1^See Fileman message" - . SET TMGOUT(1)=$$GETERSTR^TMGRPC3G(.TMGMSG) - ; - DO XTRCTFLD(.TMGOUT,.TMGARRAY,"E") - ; -GORDONE ; - QUIT - ; - ; -XTRCTFLD(TMGOUT,TMGARRAY,TMGFLAG) ;"EXTRACT FIELDS - ;"Purpose: convert output from GETS^DIQ into another format - ; - NEW TMGINDEX SET TMGINDEX=1 - NEW TMGFILE,TMGFIELD,TMGIENS - SET TMGFILE="" - FOR SET TMGFILE=$ORDER(TMGARRAY(TMGFILE)) QUIT:(TMGFILE="") DO - . SET TMGIENS="" - . FOR SET TMGIENS=$ORDER(TMGARRAY(TMGFILE,TMGIENS)) QUIT:(TMGIENS="") DO - . . SET TMGFIELD=0 - . . FOR SET TMGFIELD=$ORDER(^DD(TMGFILE,TMGFIELD)) QUIT:(+TMGFIELD'>0) DO - . . . IF $GET(TMGARRAY(TMGFILE,TMGIENS,TMGFIELD,TMGFLAG))="" DO - . . . . SET TMGARRAY(TMGFILE,TMGIENS,TMGFIELD,TMGFLAG)="" - . . SET TMGFIELD="" - . . FOR SET TMGFIELD=$ORDER(TMGARRAY(TMGFILE,TMGIENS,TMGFIELD)) QUIT:(TMGFIELD="") DO - . . . NEW TMGVALUE SET TMGVALUE=$GET(TMGARRAY(TMGFILE,TMGIENS,TMGFIELD,TMGFLAG)) - . . . NEW TMGDDINFO SET TMGDDINFO=$PIECE($GET(^DD(TMGFILE,TMGFIELD,0)),"^",1,4) - . . . IF $PIECE(TMGDDINFO,"^",2)["D" DO ;"convert data format to one Delphi can use - . . . . IF TMGFLAG="I" QUIT - . . . . NEW X SET X=$GET(TMGARRAY(TMGFILE,TMGIENS,TMGFIELD,"I")) - . . . . SET TMGVALUE=$$FMTE^XLFDT(X,5) - . . . SET TMGOUT(TMGINDEX)=TMGFILE_"^"_TMGIENS_"^"_TMGFIELD_"^"_TMGVALUE - . . . SET TMGOUT(TMGINDEX)=TMGOUT(TMGINDEX)_"^"_TMGDDINFO - . . . SET TMGINDEX=TMGINDEX+1 - ; - QUIT - ; -GFLSUBST(TMGOUT,TMGPARAMS) ;"GET FILE SUBSET - ;"Purpose: to return a subset of entries a file's .01 names - ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. - ;" TMGPARAMS -- FileNum^StartFrom^Direction^maxCount - ;" TMGFNUM - filename file to traverse - ;" StartFrom -- text to $ORDER() from -- OPTIONAL - ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL - ;" maxCt -- OPTIONAL -- the max number of entries to return. - ;"Output: TMGOUT is filled as follows: - ;" TMGOUT(0)="1^Success" or "-1^Message" - ;" TMGOUT(1)=IEN^Value - ;" TMGOUT(2)=IEN^Value - ;" ... - ;"Results: none - ;"NOTE: does NOT work with sub files. - ; - NEW TMGFILE SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) - IF TMGFILE'>0 DO GOTO GFSDONE - . SET TMGOUT(0)="-1^No file number supplied" - NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) - NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) - IF TMGDIR'=-1 SET TMGDIR=1 - NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) - IF TMGMAXCT=0 SET TMGMAXCT=44 - NEW TMGISPTR SET TMGISPTR=($PIECE(^DD(TMGFILE,.01,0),"^",2)["P") - NEW TMGSTARTIEN SET TMGSTARTIEN="" - IF TMGISPTR DO - . IF $LENGTH(TMGFROM,";")>2 SET TMGSTARTIEN=+$PIECE(TMGFROM,";",2) - . IF TMGFROM?1.N1";".E SET TMGFROM=+TMGFROM - ; - NEW TMGI SET TMGI=0 - ;"NEW TMGLAST SET TMGLAST="" - ;"NEW prev SET prev="" - NEW TMGREF SET TMGREF=$GET(^DIC(TMGFILE,0,"GL")) - SET TMGREF=$$CREF^DILF(TMGREF) ;"convert open --> closed reference - IF TMGREF="" DO GOTO GFSDONE - . SET TMGOUT(0)="-1^Unable to obtain global ref for file #"_TMGFILE - ; - FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI'0),(TMGFNUM>0) GOTO IL2 ;"Handle differently - ;"------------------------------------ - FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0) DO - . NEW VALUE SET VALUE="" - . IF (TMGFLD>0),(TMGFNUM>0) SET VALUE=$$GET1^DIQ(TMGFNUM,IEN_",",TMGFLD) - . SET OUT(I)=IEN_"^"_VALUE - . SET I=I+1 - GOTO ILDN - ;"------------------------------------ -IL2 ;"Sort by FLD value, not IEN value - NEW TEMP,VALUE - FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0) DO - . SET VALUE=$$GET1^DIQ(TMGFNUM,IEN_",",TMGFLD) - . SET TEMP(VALUE,IEN)="" - SET VALUE="" - FOR SET VALUE=$ORDER(TEMP(VALUE)) QUIT:(VALUE="") DO - . SET IEN=0 FOR SET IEN=$ORDER(TEMP(VALUE,IEN)) QUIT:(IEN="") DO - . . SET OUT(I)=IEN_"^"_VALUE - . . SET I=I+1 - ;"------------------------------------ -ILDN IF $DATA(OUT)=0 SET OUT(0)="-1^NO RESULTS" - ELSE SET OUT(0)="1^Success" - QUIT - ; -PREPSB(OUT,TMGPARAMS) ;"Prep Subset - ;"Purpose: Prepare an array that can be used by an TORComboBox.NeedData - ;" to return a subset of the results. - ;" NOTE: This should not be called until STATUS() returns #DONE# - ;"Input: OUT -- Passed by REFERENCE. And out array - ;" TMGPARAM -- JOBNUM^Field[;FLD[;FLD...]] - ;" JOBNUM = The job number of task to query - ;" Field... = The desired field number(s). OPTIONAL. DEFAULT is .01 - ;" If more than one supplied, then output is - ;" concatinated. Separate fieldnumbers with ';' - ;"Output: OUT(0)=1^Success or -1^Message - ;"Results: None - NEW JOBNUM SET JOBNUM=+$PIECE(TMGPARAMS,"^",1) - NEW TMGFLDS SET TMGFLDS=$PIECE(TMGPARAMS,"^",2) - IF TMGFLDS="" SET TMGFLDS=".01" - NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) - NEW TMGFNUM SET TMGFNUM=+$GET(@REF@("OUT","FILENUM")) - IF TMGFNUM'>0 DO GOTO PREPDN - . SET OUT(0)="-1^Unable to find file number at "_$NAME(@REF@("OUT","FILENUM")) - NEW IEN SET IEN=0 - NEW VALUE - NEW TMGERR SET TMGERR=0 - FOR SET IEN=$ORDER(@REF@("OUT",IEN)) QUIT:(+IEN'>0)!TMGERR DO - . SET VALUE="" - . NEW I FOR I=1:1:$LENGTH(TMGFLDS,";") DO - . . NEW TMG1FLD SET TMG1FLD=+$PIECE(TMGFLDS,";",I) QUIT:TMG1FLD'>0 - . . SET VALUE=VALUE_$$GET1^DIQ(TMGFNUM,IEN_",",TMG1FLD,,"TMGERR")_" " - . . IF $DATA(TMGERR("DIERR")) DO - . . . SET TMGERR=1 - . . . SET TMGERR("MSG")=$$GetErrStr^TMGDEBUG(.TMGERR) - . SET VALUE=$$TRIM^XLFSTR(VALUE) - . QUIT:VALUE="" - . SET @REF@("B",VALUE,IEN)="" - ;"------------------------------------ - IF TMGERR SET OUT(0)="-1^"_$GET(TMGERR("MSG")) - IF $DATA(@REF@("B"))=0 SET OUT(0)="-1^NO RESULTS" - ELSE SET OUT(0)="1^Success" -PREPDN QUIT - ; -IENDETAL(OUT,TMGPARAMS) ; - ;"Purpose: Return Detail of 1 IEN from from results from background search job. - ;" NOTE: This should not be called until STATUS() returns #DONE# - ;" Example: Imagine that a search has been made for a PATIENT with - ;" an associated TIU DOCUMENT containing "HTN". The primary - ;" goal of the search is to get the IEN of the found PATIENT(s) - ;" However, after finding this patient, one might want to be - ;" able to reference the particular TIU DOCUMENTS leading to - ;" the match. That is the purpose of this function. So, in - ;" the parameters below, the input IEN would be the IEN in - ;" the PATIENT file, and the output would include the file - ;" number for TIU DOCUMENT, and the IEN's of the entries in - ;" this file that lead to the final results - ;"Input: OUT -- Passed by REFERENCE. And out array - ;" TMGPARAM -- JobNum^IEN - ;" JOBNUM -- The job number of task to query - ;" IEN -- The End Search IEN - ;"Output: OUT(0)=status - ;" OUT(index)=FileNum^IENInFile^.01Value - ;" OUT(index)=FileNum^IENInFile^.01Value - ;" OUT(index)=FileNum^IENInFile^.01Value - ;"Results: None - NEW JOBNUM SET JOBNUM=+$PIECE($GET(TMGPARAMS),"^",1) - IF JOBNUM=0 DO GOTO IEDDN - . SET OUT(0)="-1^Invalid Job Number." - NEW SRCHIEN SET SRCHIEN=+$PIECE($GET(TMGPARAMS),"^",2) - IF SRCHIEN=0 DO GOTO IEDDN - . SET OUT(0)="-1^Invalid IEN Number." - NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM,"OUT","DETAILS",SRCHIEN)) - NEW I SET I=1 - NEW FNUM SET FNUM=0 - FOR SET FNUM=$ORDER(@REF@(FNUM)) QUIT:(+FNUM'>0) DO - . NEW SUPIEN SET SUPIEN=0 - . FOR SET SUPIEN=$ORDER(@REF@(FNUM,SUPIEN)) QUIT:(+SUPIEN'>0) DO - . . NEW VALUE SET VALUE=$GET(@REF@(FNUM,SUPIEN)) - . . IF VALUE="" DO - . . . SET VALUE=$$GET1^DIQ(FNUM,SUPIEN_",",.01) - . . . SET @REF@(FNUM,SUPIEN)=VALUE - . . SET OUT(I)=FNUM_"^"_SUPIEN_"^"_VALUE - . . SET I=I+1 - IF $DATA(OUT)=0 SET OUT(0)="-1^NO RESULTS" - ELSE SET OUT(0)="1^Success" -IEDDN QUIT - ; -GETRSLTSB(TMGOUT,TMGPARAMS) ; - ;"Purpose: Get RESULTS list subset, for job number. NOTE: This should - ;" only be called after a successful call to PREPSB^TMGRPCS0() - ;" which will prepair the list. - ;"Input: TMGPARAMS -- JobNum^ListStartValue^direction^MaxCount(optional, def=44) - ;" JobNum -- this is job number of results to return. - ;" ListStartValue -- OPTIONAL -- text to $ORDER() from - ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL - ;" MaxCount -- OPTIONAL. Default is 44 values returned. - ;"Output: TMGRESULTS is filled as follows. - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=IENNum^RequestedFieldNames - ;" TMGRESULT(2)=IENNum^RequestedFieldNames - ;"NOTE: Any files that don't have data are excluded. Subfiles also excluded - ; - NEW JOBNUM SET JOBNUM=+$PIECE(TMGPARAMS,"^",1) - IF JOBNUM'>0 DO GOTO GAFSDN - . SET TMGOUT(0)="-1^No Job Number Supplied" - NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) - NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) - IF TMGDIR'=-1 SET TMGDIR=1 - NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) - IF TMGMAXCT=0 SET TMGMAXCT=44 - ; - NEW TMGREF SET TMGREF=$NAME(^TMP("TMG","TMGSRCH",JOBNUM)) - NEW TMGI SET TMGI=0 - FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI' - ;" INPUT("REQUEST")="cmd^params" Valid values for "cmd" are: - ;" "LAUNCH" -- Start background task for search - ;" params: FileNumber^SearchString <-- See docs for Search String in TMGSRCH.m - ;" "STATUS" -- Get status of background task - ;" params: JobNumber - ;" "IEN LIST" ; was RESULTS - ;" params: JobNumber^Fields - ;" NOTE: If Fields left blank, then NO FIELDS is assumed - ;" "IEN DETAILS" -- Get details of 1 IEN entry - ;" params: JobNumber^IEN - ;" "PREP SUBSET" - ;" params: JobNumber^[Field[;FLD[;FLD...]]] - ;" Field -- The desired field number(s). - ;" OPTIONAL. DEFAULT is .01 - ;" If more than one supplied, then output is - ;" concatinated. Separate fieldnumbers with ';' - ;" "CLEAR" -- clear results from last search. - ;" params: JobNumber - ;" "ALLOWED FILES ENTRY SUBSET" -- get sublist of list .01 fields for allowed files (those pointing into FileNum) - ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple - ;" "FIELD LIST SUBSET" -- get sublist of fields names in file - ;" params: FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple - ;" "RESULTS LIST SUBSET" -- get sublist of search results - ;" params: JobNum^ListStartValue^direction^MaxCount(optional, def=44) - ;"Output: results of this function should be put into TMGRESULTS array. - ;" For cmd: - ;" "LAUNCH" - ;" TMGRESULT(0)=1^JobNumber - ;" "STATUS" - ;" TMGRESULT(0)=1^%Done^Message. <-- Will be '1^100^#DONE#' when task is done. - ;" "IEN LIST" - ;" TMGRESULT(0)=1 if Success or -1^Message" - ;" TMGRESULT(1)=IEN^[Fld Value] <-- Field value returned, if requested - ;" TMGRESULT(2)=IEN^[Fld Value] - ;" etc ... - ;" "PREP SUBSET" - ;" TMGRESULT(0)=1^Success or -1^Message - ;" "CLEAR" - ;" TMGRESULT(0)=1^Success - ;" "ALLOWED FILES ENTRY SUBSET" - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=FileNum^FileName - ;" TMGRESULT(2)=FileNum^FileName - ;" etc ... - ;" "FIELD LIST SUBSET" - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=FLDNum^Name^Info - ;" TMGRESULT(2)=FLDNum^Name^Info - ;" etc ... - ;" "RESULTS LIST SUBSET" - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=IENNum^RequestedFieldNames - ;" TMGRESULT(2)=IENNum^RequestedFieldNames - ;" etc ... - ;"Result: none - ; - NEW TMGCOMMAND,TMGCOMMAND - SET TMGCOMMAND=$$TRIM^XLFSTR($$UP^XLFSTR($PIECE($GET(INPUT("REQUEST")),"^",1))) - SET TMGPARAMS=$$UP^XLFSTR($PIECE($GET(INPUT("REQUEST")),"^",2,199)) - ; - ;"MERGE ^TMG("TMP","RPC","TMGRPCSR",$H,"TMGCOMMAND")=TMGCOMMAND - ;"MERGE ^TMG("TMP","RPC","TMGRPCSR",$H,"TMGPARAMS")=TMGPARAMS - ; - SET TMGRESULT(0)="-1^No command requested." ;"default to error state. - IF TMGCOMMAND="LAUNCH" DO - . DO LAUNCH^TMGRPCS0(.TMGRESULT,TMGPARAMS) - IF TMGCOMMAND="STATUS" DO - . DO STATUS^TMGRPCS0(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="RESULTS" DO - . DO IENLIST^TMGRPCS0(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="PREP SUBSET" DO - . DO PREPSB^TMGRPCS0(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="CLEAR" DO - . DO CLEAR^TMGRPCS0(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="ALLOWED FILES ENTRY SUBSET" DO - . DO GETAFSUB^TMGSRCH1(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="FIELD LIST SUBSET" DO - . DO GETFLDSB^TMGSRCH1(.TMGRESULT,TMGPARAMS) - ELSE IF TMGCOMMAND="RESULTS LIST SUBSET" DO - . DO GETRSLTSB^TMGRPCS0(.TMGRESULT,TMGPARAMS) - ; - QUIT - ; - Index: cprs/branches/tmg-cprs/m_files/TMGSIPH3.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH3.m~ (revision 796) +++ (revision ) @@ -1,755 +1,0 @@ -TMGSIPH3 ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;11/27/09 - ;;1.0;TMG-LIB;**1**;11/27/09 - ; - ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE - ;"Support functions for transferring files from server - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"11/27/09 - ; - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"TRANSFILE(JNUM) -- move a remote file to local machine, overwriting local entries. - ;"GET01FLD(JNUM,FILENUM,IEN) -Get .01 field (internal format) from server. - ;"TRANS1FIL(JNUM,FILENUM) -move a remote file to local machine, overwriting local entries. - ;"QRYSERVER(JNUM) -- display a given reference from the server - ;"TRANSREF(JUNUM) -- move an absolute reference from server to local - ;"ASKNEEDED(JNUM,OUTARRAY,INOUT,OPTIONS) --review records of needed records, and - ;" ask user which file, or - ;" which records to get, and return results of selected in array. - ;" This can handle either the list of needed pointers IN or OUT. - ;"NUMNEEDED(JNUM,INOUT) -- count number of records needed from server. - ;"CHCK4SIM(FILENUM,ARRAY,ANIEN,VALUE01,IENS) -- look at an array and see if there is similar record already on the client. - ;"XTRACT01FLD(ARRAY) ; --remove .01 Field values from array returned from GET RECORD & XREF, and store - ;"GETANDFIXREC(JNUM,FILENUM,IEN,OVERWRITE,TALLY,INOUT) -- request a record from server, and integrate into local vista, - ;" resolving pointers locally to point to newly downloaded record. - ;"HANDLNEEDED(JNUM,INOUT,AUTOMODE) --Ask user which records to get from server, then get them and update - ;" pointer translation table. - - ;"======================================================================= - ;"Dependancies - ;"======================================================================= - ;"TMGUSRIF, XLFSTR - ;"======================================================================= - ; - ; -TRANSFILE(JNUM) - ;"Purpose: to move a remote file to local machine, overwriting local entries. - ;"Input: JNUM -- The job number of the background client process - ;"Results: none - NEW X,Y,DIC,ARRAY,% - SET DIC=1,DIC(0)="MAEQ" -TF1 WRITE "Pick file to transfer COMPLETELY, or to resume transfer from",! - DO ^DIC WRITE ! - IF +Y'>0 DO QUIT:(+Y'>0)!(%=-1) - . SET %=1 - . WRITE "File not found on this client. Do you want to select a file",! - . WRITE "to transfer from the server" DO YN^DICN WRITE ! - . QUIT:(%'=1) - . WRITE "Pick file ON SERVER to transfer COMPLETELY: " - . READ Y,! - . IF Y["^" QUIT - . NEW QUERY,REPLY,ERROR,RESULT - . SET QUERY="DO DIC|1^"_Y - . DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - . IF $DATA(ERROR) WRITE ERROR,! SET Y=0 QUIT - . SET Y=$GET(REPLY(1)) - . IF +Y>0 SET ^TMG("TMGSIPH","DD",+Y,"DIFF")=0 - FOR DO QUIT:(DDOK'=0) - . SET DDOK=$$PREPDD^TMGSIPH1(JNUM,+Y) - . QUIT:(DDOK=1) - . WRITE "Before records can be transferred from the server, the local data",! - . WRITE "dictionary must be made compatible. Must work on this now.",! - . DO PressToCont^TMGUSRIF - . SET DDOK=+$GET(^TMG("TMGSIPH","DD",+Y,"DIFF")) - GOTO TF1:(DDOK'=1) - DO TRANS1FIL(JNUM,+Y) - GOTO TF1 - ; - ; -GET01FLD(JNUM,FILENUM,IEN) ; - ;"Purpose: Get .01 field (internal format) from server, or return previously obtained value. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- The file number to compare. - ;" IEN -- the record to query -- Server-side IEN, not client IEN - ;"Result: returns the .01 value or "" if problem - SET RESULT=$GET(^TMG("TMGSIPH",".01 VALUE",FILENUM,IEN)) - IF RESULT'="" GOTO G1DN - NEW QUERY,REPLY,ERROR,RESULT - SET QUERY="GET .01 FLD|"_FILENUM_"^"_IEN - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) WRITE ERROR,! - SET RESULT=$GET(REPLY(1)) - SET ^TMG("TMGSIPH",".01 VALUE",FILENUM,IEN)=RESULT -G1DN QUIT RESULT - ; - ; -TRANS1FIL(JNUM,FILENUM) ; - ;"Purpose: to move a remote file to local machine, overwriting local entries. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- The file number to transfer. (Not a subfile) - ;"Output: Will set output globals: - ;" ^TMG("TMGSIPH","PT XLAT",FILENUM,RemoteIEN)=LocalIEN - ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,ReferToNodeToBeCorrected,Piece#OfNode)="" - ;"Results: none - ; - NEW MAXNUM - NEW QUERY,ERROR,RESULT,REPLY - SET QUERY="NUMRECS|"_FILENUM - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,15) - IF $DATA(ERROR) WRITE ERROR,! GOTO T1FD - SET MAXNUM=+$GET(REPLY(1)) - IF MAXNUM'>0 DO GOTO T1FD - . WRITE "Error: number of records=",MAXNUM,! - NEW STARTTIME SET STARTTIME=$H - NEW GLREF SET GLREF=$GET(^DIC(FILENUM,0,"GL")) - NEW REF SET REF=$GET(^TMG("TMGSIPH","DOWNLOADED",FILENUM,"#PRIOR RUN#")) - NEW % SET %=1 ;"Default=Y - IF REF'="" DO - . WRITE "Continue transfer of records from point of last run" - . DO YN^DICN WRITE ! - . IF %=2 SET REF="" - IF %=-1 GOTO T1FD - IF REF="" SET REF=$$CREF^DILF(GLREF_""""",") - SET GLREF=$$CREF^DILF(GLREF) - NEW QL SET QL=$QLENGTH(REF) - WRITE "Press ESC to abort...",! - NEW REC SET REC="" - NEW TMGABORT - FOR DO QUIT:(REF="")!(TMGABORT=1) - . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) - . SET QUERY="ORDREF|"_REF - . DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - . IF $DATA(ERROR) DO QUIT - . . WRITE ERROR,! - . . SET REF="" - . IF $DATA(REPLY)=0 SET REF="" QUIT - . DO STOREDATA^TMGSIPHU(.REPLY) - . SET ^TMG("TMGSIPH","DOWNLOADED",FILENUM,"#PRIOR RUN#")=REF - . SET REF=$GET(REPLY(1)) QUIT:(REF="") - . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) - . SET REF=$$QSUBS^TMGSIPHU(REF,QL) - . IF $QSUBSCRIPT(REF,QL)=REC do - . . write "ERROR: Record number didn't increase!",! - . SET REC=$QSUBSCRIPT(REF,QL) - . IF (+REC=REC) DO - . . IF $$REAL1PTOUT^TMGSIPH1(FILENUM,REC) ;"Ignore function result - . . SET ^TMG("TMGSIPH","PT XLAT",FILENUM,REC)=REC ;"remote and local IEN's are same - . . SET ^TMG("TMGSIPH","DOWNLOADED",FILENUM,REC)=REC - . IF (REC#10)=0 DO - . . DO ProgressBar^TMGUSRIF(REC,"Progress: "_REC,0,MAXNUM,70,STARTTIME) -T1FD QUIT - ; - ; -QRYSERVER(JNUM) ; - ;"Purpose: To display a given reference from the server - ;"Input: JNUM -- The job number of the background client process - SET JNUM=+$GET(JNUM) - QUIT:(+JNUM'>0) - NEW QUERY,ERROR,RESULT,REPLY - FOR DO quit:(QUERY="^") - . READ "Enter reference> ",QUERY,! - . IF (QUERY="")!(QUERY="^") SET QUERY="^" QUIT - . ELSE SET QUERY="GET|"_QUERY - . DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,5) - . IF $DATA(ERROR) WRITE ERROR,! - . IF $DATA(REPLY) do - . . WRITE "reply:",! - . . ZWR REPLY - quit - ; - ; -TRANSREF(JNUM) ; - ;"Purpose: To move an absolute reference from server to local - SET JNUM=+$GET(JNUM) - QUIT:(+JNUM'>0) - WRITE "This will allow an arbitrary global to be transferred",! - write "from the server.",! - NEW REF,QUERY,ERROR,RESULT,REPLY,% - FOR DO QUIT:(REF="^") - . READ "Enter reference (e.g. ""^ABC(123,"" or ^ to quit)> ",REF,! - . IF (REF="")!(REF="^") SET REF="^" QUIT - . SET REF=$$CREF^DILF(REF) - . SET QUERY="GET|"_REF - . DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,5) - . IF $DATA(ERROR) WRITE ERROR,! QUIT - . IF $DATA(REPLY) ZWR REPLY WRITE ! - . SET %=1 - . IF $DATA(@REF) DO QUIT:(%'=1) - . . WRITE "WARNING: There is already data locally at ",REF,! - . . WRITE "Do you want to OVERWRITE this local data" - . . SET %=2 - . . DO YN^DICN WRITE ! - . DO STOREDATA^TMGSIPHU(.REPLY) - . WRITE "Data stored locally.",!,! - . KILL REPLY - quit - - - - -ASKNEEDED(JNUM,OUTARRAY,INOUT,OPTIONS) ; - ;"Purpose: To review records of needed records, and ask user which file, or - ;" which records to get, and return results of selected in array. - ;" This can handle either the list of needed pointers IN or OUT. - ;"Input: JNUM -- The job number of the background client process - ;" OUTARRAY -- PASS BY REFERNCE, an OUT PARAMETER. Filled as follows - ;" OUTARRAY(FileNum,RecordNum)="" - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;" OPTIONS -- OPTIONAL default is 0. See SELNEEDED for details. - ;"Results: None. - ;"NOTE: uses ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,RefToNodeToBeCorrected,Piece#OfNode)="" - ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,IEN)="" - ; - NEW REF SET REF=$NAME(^TMG("TMGSIPH","NEEDED RECORDS",INOUT)) - DO SELNEEDED(JNUM,.OUTARRAY,REF,.OPTIONS) - QUIT - ; - ; -SELNEEDED(JNUM,OUTARRAY,REF,OPTIONS) ; - ;"Purpose: To review an array of needed records, and ask user which file, or - ;" which records to get, and return results of selected in array. - ;"Input: JNUM -- The job number of the background client process - ;" OUTARRAY -- PASS BY REFERNCE, an OUT PARAMETER. Filled as follows - ;" OUTARRAY(FileNum,RecordNum)="" - ;" REF -- PASS BY NAME -- The name of the variable holding the records to ask from. Variable - ;" array should have this format: - ;" @REF@(FILENUM,RPTR)="" - ;" @REF@(FILENUM,RPTR)="" - ;" OPTIONS -- OPTIONAL default is 0. If 1, then all records are processed without asking. - ;" OPTIONS("MAP MODE")=1 OPTIONAL, if exists, then different header is displayed - ;" OPTIONS("NUMNEEDED")=1 OPTIONAL, if exists, will only get up to 200 records - ;" OPTIONS("HEADER")=
OPTIONAL. If present, will be used for header display - ;"Results: None. - NEW TMGARRAY,TMGSEL,TMGSEL2 - KILL OUTARRAY - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - NEW FILENUM SET FILENUM="" - NEW AUTOMODE SET AUTOMODE=(+$GET(OPTIONS)=1) - FOR SET FILENUM=$ORDER(@REF@(FILENUM)) QUIT:(+FILENUM'>0) DO - . NEW DISPSTR SET DISPSTR="Get records from REMOTE file #"_FILENUM_" (" - . SET DISPSTR=DISPSTR_$$FILENAME^TMGFMUT2(FILENUM)_")" - . SET TMGARRAY(DISPSTR)=FILENUM - NEW STIME SET STIME=$H - NEW SHOWPROG SET SHOWPROG=0 - NEW TMGCT SET TMGCT=0 - NEW TMGDONE SET TMGDONE=0 - NEW SHORTLST SET SHORTLST=+$GET(OPTIONS("NUMNEEDED")) - NEW HEADER - IF $DATA(OPTIONS("HEADER")) DO - . SET HEADER=$GET(OPTIONS("HEADER")) - ELSE DO - . IF $GET(OPTIONS("MAP MODE"))=1 DO - . . SET HEADER="Select File(s) to MAP to local records in. Press when Done." - . ELSE SET HEADER="Select File(s) to get REMOTE records from. Press when Done." - IF AUTOMODE MERGE TMGSEL=TMGARRAY - ELSE DO Selector^TMGUSRIF("TMGARRAY","TMGSEL",HEADER) - NEW TMGABORT SET TMGABORT=0 - NEW IDX SET IDX="" - FOR SET IDX=$ORDER(TMGSEL(IDX)) QUIT:(IDX="")!TMGABORT!TMGDONE DO - . SET FILENUM=$GET(TMGSEL(IDX)) QUIT:FILENUM="" - . NEW FNAME SET FNAME=$$FILENAME^TMGFMUT2(FILENUM) - . NEW RPTR SET RPTR="" - . KILL TMGARRAY,TMGSEL2 - . NEW RECCT SET RECCT=0 - . NEW SELALL SET SELALL=0 - . NEW ASKED SET ASKED=0 - . IF AUTOMODE=0 WRITE "GETTING NAMES OF RECORDS...",! - . FOR SET RPTR=$ORDER(@REF@(FILENUM,RPTR)) QUIT:(RPTR="")!SELALL!TMGABORT!TMGDONE DO - . . NEW DISPSTR SET DISPSTR="File: "_FNAME_", record #"_$$RJ^XLFSTR(RPTR,6) - . . IF AUTOMODE=0 SET DISPSTR=DISPSTR_" -- "_$$GET01FLD(JNUM,FILENUM,RPTR) - . . SET TMGARRAY(DISPSTR)=RPTR - . . SET RECCT=RECCT+1 - . . SET TMGCT=TMGCT+1 - . . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>10) DO ;"Turn on progress bar after 10 seconds. - . . . SET SHOWPROG=1 - . . IF (SHOWPROG=1),(TMGCT>500) DO - . . . DO ProgressBar^TMGUSRIF(100,"Gathering list of needed records "_RECCT,-1,-1,70,STIME) - . . . SET TMGCT=0 - . . IF (RECCT>200),(ASKED=0) DO - . . . IF SHORTLST SET TMGDONE=1,RECCT=0 QUIT - . . . SET ASKED=1 - . . . IF AUTOMODE=1 QUIT - . . . NEW MENU,USRSLCT - . . . SET MENU(0)="File "_FNAME_" has > 200 records." - . . . SET MENU(1)="Automatically Select ALL records"_$char(9)_"AutoSelALL" - . . . SET MENU(2)="Show LONG list to allow picking individual records"_$char(9)_"SelectList" - . . . NEW DONE SET DONE=0 - . . . FOR DO QUIT:(DONE=1)!(TMGABORT) - . . . . WRITE # - . . . . SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") - . . . . SET DONE=1 - . . . . IF USRSLCT="^" SET TMGABORT=1 QUIT - . . . . IF USRSLCT="AutoSelALL" SET SELALL=1 QUIT - . . . . IF USRSLCT="SelectList" QUIT - . . . . ELSE SET DONE=0 - . IF TMGABORT QUIT - . IF (RECCT=1)!AUTOMODE!SELALL DO - . . NEW TMGSKIP SET TMGSKIP=0 - . . SET TMGCT=0 - . . NEW ONEREC SET ONEREC="" - . . FOR SET ONEREC=$ORDER(@REF@(FILENUM,ONEREC)) QUIT:(ONEREC="")!TMGSKIP DO - . . . SET TMGSEL2(ONEREC)=ONEREC - . . . IF SHORTLST,(TMGCT>200) SET TMGSKIP=1,TMGDONE=1 QUIT - . . . SET TMGCT=TMGCT+1 - . . . SET RECCT=RECCT+1 - . . . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>10) DO ;"Turn on progress bar after 10 seconds. - . . . . SET SHOWPROG=1 - . . . IF (SHOWPROG=1),(TMGCT>500) DO - . . . . DO ProgressBar^TMGUSRIF(100,"Gathering list of needed records "_RECCT,0,100,70,STIME) - . . . . SET TMGCT=0 - . . SET SELALL=1 - . IF SELALL=0 DO - . . IF $GET(OPTIONS("MAP MODE"))=1 DO - . . . SET HEADER="Select records to MAP to local records. Press when Done." - . . ELSE SET HEADER="Select records to get from Server. Press when Done." - . . DO Selector^TMGUSRIF("TMGARRAY","TMGSEL2",HEADER) - . NEW I2 SET I2="" - . FOR SET I2=$ORDER(TMGSEL2(I2)) QUIT:(I2="") DO - . . SET RPTR=$GET(TMGSEL2(I2)) - . . SET OUTARRAY(FILENUM,RPTR)="" - ; - QUIT - ; - ; -NUMNEEDED(JNUM,INOUT) - ;"Purpose: To count number of records needed from server. - ;"Input: JNUM -- The job number of the background client process - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;"Output: Returns the number of records needed. - ;" - NEW GETARRAY,FILENUM,RESULT - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - NEW MODE SET MODE=1,MODE("NUMNEEDED")=1 ;"Will limit number counting to 200 mg - DO ASKNEEDED(JNUM,.GETARRAY,INOUT,.MODE) - SET FILENUM=0 - SET RESULT=0 - NEW TMGCT SET TMGCT=0 - NEW STIME SET STIME=$H - NEW SHOWPROG SET SHOWPROG=0 - FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="") DO - . NEW IEN SET IEN="" - . FOR SET IEN=$ORDER(GETARRAY(FILENUM,IEN),-1) QUIT:(IEN="") DO - . . SET RESULT=RESULT+1 - . . SET TMGCT=TMGCT+1 - . . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>5) DO ;"Turn on progress bar after 5 seconds. - . . . SET SHOWPROG=1 - . . IF (SHOWPROG=1),(TMGCT>1000) DO - . . . DO ProgressBar^TMGUSRIF(100,"Counting records: "_TMGCT,0,100,70) - . . . SET TMGCT=0 - IF TMGCT>200 SET TMGCT=TMGCT_"+" - QUIT TMGCT - ; - ; -CHCK4SIM(FILENUM,ARRAY,ANIEN,VALUE01,IENS) - ;"Purpose: To look at an array, as returned from server, and see if there is - ;" a similar record already on the client. - ;"Input: FILENUM -- the fileman filenumber of file to get from remote server - ;" ARRAY -- The global record array, as returned from server. - ;" ANIEN -- PASS BY REFERENCE. Will be filled with IEN match - ;" If IENS is passed (i.e. if dealing with a subfile), then ANIEN is passed - ;" back in standard IENS format (e.g. '7,1234,') - ;" VALUE01 -- OPTIONAL. This allows a .01 value to be passed. If provided, then - ;" the ARRAY won't be searched for a .01 value. - ;" IENS -- OPTIONAL. If FILENUM is a subfile, then IENS is needed for lookup. - ;" IENS is modified, so **DON'T** PASS BY REFERENCE - ;"Results: 0 if no similar record already on the local server (i.e. NO MATCH) - ;" 1 if a match WAS found. - ;"Output: ANIEN is modified. - ;"NOTE: If .01 field of passed record array matches to 2 or more records, then NO MATCH resulted - ;" Also, if file does not have a "B" cross reference, then NO MATCH resulted. - ;" Also, the first 30 characters (only) are tested for match in "B" xref. - ; - NEW RESULT SET RESULT=0 - SET ANIEN=0 - SET FILENUM=+$GET(FILENUM) ;" If in format of 'SubFile{ParentFile', then strip off parent filenum. - NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) ;"IENS not used if not subfile. - IF GREF="" GOTO C4SDN - NEW BREF SET BREF=GREF_"""B"")" - NEW SAVIENS SET SAVIENS=$GET(IENS) - SET $PIECE(IENS,",",1)="" ;"e.g. '7,2345,' --> ',2345,' to specify parent, but no particular subfile entry - IF $DATA(@BREF)=0 GOTO C4SDN - NEW CGREF SET CGREF=$$CREF^DILF(GREF) - NEW GREFLEN SET GREFLEN=$QLENGTH(CGREF) - NEW VALUE SET VALUE=$GET(VALUE01) - NEW TMGI SET TMGI=0 - FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(VALUE'="") DO ;"Find .01 value - . NEW REF SET REF=$GET(ARRAY(TMGI)) - . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) - . SET TMGI=TMGI+1 - . IF REF="" SET TMGI="" QUIT - . IF $QSUBSCRIPT(REF,GREFLEN+2)'=0 QUIT ;"Only check 0 node. - . IF $QLENGTH(REF)'=(GREFLEN+2) QUIT ;"Only allow ^GREF(xxx,xxx,IEN,0) - . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) - . SET VALUE=$PIECE(VALUE,"^",1) - IF VALUE="" GOTO C4SDN - IF (FILENUM'=9999999.27),$GET(^TMG("TMGSIPH","SKIP CHCK4SIM",FILENUM,VALUE))=1 GOTO C4SDN - NEW TMGOUT,TMGMSG - DO FIND^DIC(FILENUM,IENS,"@;.01I","BOQUX",VALUE,"*","B","","","TMGOUT","TMGMSG") - DO ShowIfDIERR^TMGDEBUG(.TMGOUT) - NEW CT SET CT=+$GET(TMGOUT("DILIST",0)) - IF CT=1 DO - . ;"Ensure matched local record didn't actually come from server - . NEW LPTR SET LPTR=+$GET(TMGOUT("DILIST",2,1)) - . IF $DATA(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)) QUIT - . IF SAVIENS'="" DO - . . SET ANIEN=SAVIENS - . . SET $PIECE(ANIEN,",",1)=LPTR - . ELSE SET ANIEN=LPTR - . SET RESULT=1 - ELSE IF CT>100 DO - . SET ^TMG("TMGSIPH","SKIP CHCK4SIM",FILENUM,VALUE)=1 - ; -C4SDN QUIT RESULT - ; - ; -XTRACT01FLD(ARRAY) ; - ;"Purpose: To remove pointed-to .01 Field values from array returned from GET RECORD & XREF, - ;" and store these for future reference. Removes %PTRSOUT% - ;"Input: ARRAY -- PASS BY REFERENCE. Results returned from GET RECORD & XREF. Format: - ;" ARRAY(1)="=" - ;" ARRAY(2)="=" - ;" ARRAY(3)="=" - ;" ARRAY(4)="=" - - ;" ... - ;" ARRAY(20)="%PTRSOUT%^PointedToFile^IEN^FIELD_VALUE" - ;" ARRAY(21)="%PTRSOUT%^PointedToFile^IEN^FIELD_VALUE" - ;" ... - ;"Results: none - NEW RESULT SET RESULT=0 ;Default to error. - NEW SHOWPG SET SHOWPG=0 - NEW TMGCT SET TMGCT=0 - NEW STIME SET STIME=$H - NEW TMGI SET TMGI="" - FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(+TMGI'>0) DO - . IF (SHOWPG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds. - . . SET SHOWPG=1 - . . SET TMGMIN=$ORDER(ARRAY(0)) - . . SET TMGMAX=$ORDER(ARRAY(""),-1) - . IF (SHOWPG=1),(TMGCT>2000) DO - . . DO ProgressBar^TMGUSRIF(TMGI,"Extracting pointers from server data",TMGMIN,TMGMAX,70,STIME) - . . SET TMGCT=0 - . SET TMGCT=TMGCT+1 - . IF $GET(ARRAY(TMGI))'["%PTRSOUT%" QUIT - . NEW FILENUM SET FILENUM=$PIECE(ARRAY(TMGI),"^",2) - . NEW IEN SET IEN=$PIECE(ARRAY(TMGI),"^",3) - . NEW VALUE SET VALUE=$PIECE(ARRAY(TMGI),"^",4) - . KILL ARRAY(TMGI) - . SET ^TMG("TMGSIPH",".01 VALUE",FILENUM,IEN)=VALUE - QUIT - ; - ; -GETANDFIXREC(JNUM,FILENUM,RPTR,OVERWRITE,TALLY,INOUT) ; - ;"Purpose: To request a record from server, and integrate into local vista, - ;" resolving pointers locally to point to newly downloaded record. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- the fileman filenumber of file to get from remote server - ;" Can be in format of SubFileNum{ParentFileNum{GrandParent.... - ;" RPTR -- The record number on the server to get. - ;" Can be in IENS format, e.g. '7,34532,' if FILENUM is a subfile. - ;" OVERWRITE -- OPTIONAL. If 1, then prior local records may be overwritten. - ;" If '?' then figure out if should overwrite, asking user if needed. - ;" TALLY -- OPTIONAL. PASS BY REFERENCE. An array to keep progress stats. Format: - ;" TALLY("ALREADY LOCAL FOUND")=# - ;" TALLY("DOWNLOADED")=# - ;" TALLY(FILENUM,"NEW REC NEEDED")=# - ;" TALLY("UNNEEDED RECORDS")=# - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;"NOTE: Gobal ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT") used, with format as below: - ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,RefToNodeToBeCorrected,Piece#OfNode)="" - ;" As pointers are resolved, the entries will be KILLED from the above global - ;"Results: 1 if OK, -1 if error, -2 if abort - ; - NEW QUERY,REPLY,ERROR,NEWIEN - NEW RESULT SET RESULT=-1 ;"Default to error - NEW TMGABORT SET TMGABORT=0 - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - SET OVERWRITE=$GET(OVERWRITE) - SET FILENUM=$GET(FILENUM) - NEW ISSUBFIL SET ISSUBFIL=$$ISSUBFIL^TMGFMUT2(+FILENUM) - IF +RPTR'>0 GOTO GAFRD - SET NEWIEN=RPTR ;"Default of not changing IEN - SET FILENUM=+FILENUM IF FILENUM'>0 GOTO GAFRD ;"If subfile, strip parent file number. - NEW LPTR SET LPTR=$GET(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)) - IF (+LPTR>0) DO GOTO GAFR1 ;"Remote records already downloaded, so just link to it. - . SET NEWIEN=LPTR - . SET TALLY("ALREADY LOCAL FOUND")=+$GET(TALLY("ALREADY LOCAL FOUND"))+1 - NEW CONHANDL SET CONHANDL=$GET(^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)) - NEW USELOCAL SET USELOCAL=0 - IF CONHANDL="UseLocal" DO GOTO:(USELOCAL=1) GAF2 - . ;"If pointer is to a file specified as ALWAYS LOCAL, Handle here, if .01 value is known. - . NEW VALUE SET VALUE=$GET(^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR)) - . QUIT:(VALUE="") - . NEW ANIEN - . IF $$CHCK4SIM(FILENUM,,.ANIEN,VALUE,RPTR)=0 QUIT ;"RPTR (as IENS) not used if not subfile. - . IF +ANIEN'>0 QUIT - . SET NEWIEN=ANIEN - . SET USELOCAL=1 - NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,RPTR) ;"RPTR (as IENS) not used if not subfile. - IF GREF="" GOTO GAFRD - NEW ZREF SET ZREF=GREF_"0)" - NEW CGREF SET CGREF=$$CREF^DILF(GREF) - IF ISSUBFIL DO - . NEW REF SET REF=GREF_+RPTR - . SET QUERY="GET REF & FILE XREF|"_REF_"^"_FILENUM_"^"_RPTR - ELSE DO - . SET QUERY="GET RECORD & XREF|"_FILENUM_"^"_RPTR - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) DO GOTO GAFRD - . WRITE ERROR,! - IF $DATA(REPLY)=0 DO GOTO GAFR0 ;"No data on server for record, so zero pointers - . SET NEWIEN=0 - DO XTRACT01FLD(.REPLY) - NEW SIMIEN - IF $$CHCK4SIM(FILENUM,.REPLY,.SIMIEN,,RPTR) DO ;"A prior similar record already is on client. - . SET NEWIEN=SIMIEN ;"If dealing with subfiles, SIMIEN will be in IENS format. - NEW REF SET REF=GREF_+NEWIEN_")" - IF $DATA(@REF) DO - . NEW TEMP SET TEMP=$$GETTARGETIEN^TMGSIPHU(FILENUM,.REPLY,.NEWIEN) - . SET REF=GREF_+NEWIEN_")" ;"NEWIEN might have changed. - . IF TEMP="ABORT" SET RESULT=-2,TMGABORT=1 QUIT - . IF TEMP="USELOCAL" SET USELOCAL=1 QUIT - . IF TEMP="OVERWRITE" DO QUIT ;"OVERWRITE LOCAL RECORD #LPTR (KILL, THEN STORE later) - . . KILL @REF -GAF2 IF ($GET(TMGABORT)=1)!(NEWIEN'>0) GOTO GAFRD - IF USELOCAL=1 DO GOTO GAFR0 - . SET TALLY("ALREADY LOCAL FOUND")=$GET(TALLY("ALREADY LOCAL FOUND"))+1 - IF $$STOREDAS^TMGSIPHU(FILENUM,NEWIEN,.REPLY)=-1 GOTO GAFRD - SET $PIECE(@ZREF,"^",4)=$PIECE($GET(@ZREF),"^",4)+1 ;"Update File Header to reflect added records - IF +NEWIEN>$PIECE(@ZREF,"^",3) SET $PIECE(@ZREF,"^",3)=NEWIEN - IF $$REAL1PTOUT^TMGSIPH1(FILENUM,NEWIEN,.TALLY) ;"Scan for pointers out. Ignore function result - SET ^TMG("TMGSIPH","DOWNLOADED",FILENUM,NEWIEN)=RPTR - SET TALLY("DOWNLOADED")=+$GET(TALLY("DOWNLOADED"))+1 -GAFR0 SET ^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)=NEWIEN ;"Add entry to Pointer translation table. - IF (RPTR'=NEWIEN) SET ^TMG("TMGSIPH","NEED RE-XREF",FILENUM)="" ;"Flag for re-cross referencing again later. - IF USELOCAL=1 SET ^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR,"L")=1 ;"Signal that local record was used -GAFR1 DO UNNEEDPTR^TMGSIPHU(FILENUM,RPTR,NEWIEN,INOUT,.TALLY) - IF INOUT="PTIN" KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,RPTR) - IF $$NEEDPTIN(FILENUM)!(INOUT="PTIN") DO ;"See if pointers IN are needed - . IF LPTR=RPTR QUIT ;"No need for relinking if this record was already local. - . DO GETPTIN^TMGSIPH4(JNUM,FILENUM,RPTR) - SET RESULT=1 -GAFRD IF (RESULT'=-1)&(TMGABORT=1) SET RESULT=-2 - QUIT RESULT - ; - ; -NEEDPTIN(FILENUM) ; - ;"Purpose: To have a centralized location for which files should automatically trigger a request - ;" for pointers-IN - ;"NOTE: - NEW RESULT SET RESULT=0 - IF FILENUM=2 SET RESULT=1 - ELSE IF (FILENUM=9000001) SET RESULT=1 - ELSE IF (FILENUM=8925) SET RESULT=1 - ELSE IF (FILENUM["8925.") SET RESULT=1 - QUIT RESULT - ; - ; -AUTONEEDED(JNUM) ; - ;"Purpose: To automatically get all pointers IN records and also pointers OUT records - ;"Input: JNUM -- The job number of the background client process - ;"Results: None - ; - NEW NPTO,NPTI,TALLY -AN1 SET NPTO=$$NUMNEEDED^TMGSIPH3(JNUM,"PTOUT") - IF NPTO>0 IF $$HANDLNEEDED^TMGSIPH3(JNUM,"PTOUT",1,.TALLY)=-1 GOTO ANDN - SET NPTI=$$NUMNEEDED^TMGSIPH3(JNUM,"PTIN") - IF (NPTO=0)&(NPTI=0) GOTO ANDN - IF NPTI>0 IF $$HANDLNEEDED^TMGSIPH3(JNUM,"PTIN",1,.TALLY)=-1 GOTO ANDN - GOTO AN1 -ANDN IF $DATA(TALLY) WRITE ! ZWR TALLY - ELSE WRITE "No records needed auto-downloading.",! - DO PressToCont^TMGUSRIF - QUIT - ; - ; -HANDLNEEDED(JNUM,INOUT,AUTOMODE,TALLY) ; - ;"Purpose: Ask user which records to get from server, then get them and update - ;" pointer translation table. - ;"Input: JNUM -- The job number of the background client process - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;" AUTOMODE -- OPTIONAL default is 0. If 1, then all records are processed without asking. - ;" TALLY -- OPTIONAL. PASS BY REFERENCE. An array to show downloads. - ;"Results: 1 if OK, -1 if abort. - ; - NEW GETARRAY,FILENUM,IEN,STIME,TMGCT,SHOWPROG,QUERY,ERROR,TMGMAX - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - NEW TMGABORT SET TMGABORT=0 - NEW RESULT SET RESULT=1 ;"Default to success -HN1 DO ASKNEEDED(JNUM,.GETARRAY,INOUT,.AUTOMODE) - IF $DATA(GETARRAY)=0 GOTO HNDN - ;"Process JUST ONE record from each file to begin with, to try to minimize user interaction after that. - SET FILENUM=0 - FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="")!(TMGABORT=1) DO - . QUIT:($$DDOK^TMGSIPH1(JNUM,FILENUM)'=1) - . QUIT:($$PREPXREF^TMGSIPH1(JNUM,FILENUM)'=1) - . SET IEN=$ORDER(GETARRAY(FILENUM,""),-1) QUIT:(IEN="") - . NEW TMP SET TMP=$$GETANDFIXREC(JNUM,FILENUM,IEN,"?",.TALLY,INOUT) - . IF TMP=-2 SET TMGABORT=1 QUIT - . IF TMP=-1 DO HNDLGAFE(FILENUM,IEN,.TMGABORT) QUIT - . KILL GETARRAY(FILENUM,IEN) ;"Prevent reprocessing below - ;"Now loop through ALL the files and records - SET FILENUM=0,SHOWPROG=0 - FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="")!(TMGABORT=1) DO - . QUIT:($$DDOK^TMGSIPH1(JNUM,FILENUM)'=1) - . QUIT:($$PREPXREF^TMGSIPH1(JNUM,FILENUM)'=1) - . SET TMGMAX=-1,STIME=$H,TMGCT=1,IEN="" - . FOR SET IEN=$ORDER(GETARRAY(FILENUM,IEN),-1) QUIT:(IEN="")!(TMGABORT=1) DO - . . IF TMGMAX=-1 SET TMGMAX=IEN - . . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) - . . SET TMGCT=TMGCT+1 - . . NEW TMP SET TMP=$$GETANDFIXREC(JNUM,FILENUM,IEN,"?",.TALLY,INOUT) - . . IF TMP=-2 SET TMGABORT=1 QUIT - . . IF TMP=-1 DO HNDLGAFE(FILENUM,IEN,.TMGABORT) QUIT - . . IF (SHOWPROG=0),(($PIECE($H,",",2)-$PIECE(STIME,",",2))>10) SET SHOWPROG=1 - . . IF SHOWPROG,(TMGCT#10=0) DO - . . . WRITE # - . . . DO ProgressBar^TMGUSRIF(TMGCT,"Progress: "_TMGCT,0,TMGMAX,70,STIME) - . . . IF $DATA(TALLY) WRITE ! ZWR TALLY - IF (AUTOMODE=1)&(TMGABORT'=1) GOTO HN1 ;"Loop back and see if more records are now needed. - ELSE DO - . IF $DATA(TALLY) WRITE ! ZWR TALLY - . DO PressToCont^TMGUSRIF -HNDN IF TMGABORT SET RESULT=-1 - QUIT RESULT - ; - ; -HNDLGAFE(FILENUM,RPTR,TMGABORT) ;" Handle GETANDFIXREC error. - ;"Input: FILENUM -- The file containing the bad record - ;" RPTR -- the IEN of the bad record, on the server - ;" TMGABORT -- PASS BY REFERENCE. An OUT parameter to abort. - WRITE !,"Error encountered processing FILE ",$$FILENAME^TMGFMUT2(FILENUM)," (#"_FILENUM_"), REC #"_IEN,! - NEW % SET %=2 - WRITE "Mark REC #",IEN," in FILE #",FILENUM," as an invalid server record" - DO YN^DICN WRITE ! - IF %=-1 SET TMGABORT=1 - IF %=1 DO BADPTR(FILENUM,IEN) -HGAFEDN QUIT - ; - ; -BADPTR(FILENUM,RPTR) ; - ;"Purpose: To handle a pointer to a bad record on the server. - ;"Input: FILENUM -- The file containing the bad record - ;" RPTR -- the IEN of the bad record, on the server - ;"NOTE: globally-scoped variable TMGABORT may be set. - ;"Results: None - NEW MENU,USRSLCT -LC2 KILL MENU,USRSLCT - SET MENU(0)="Pick Option for Handling INVALID server record" - NEW IDX SET IDX=1 - SET MENU(IDX)="Examine who need this bad record"_$char(9)_"Examine",IDX=IDX+1 - SET MENU(IDX)="Redirect pointer to a different local record"_$char(9)_"RedirToLocal",IDX=IDX+1 - SET MENU(IDX)="Change pointer to a NULL pointer"_$char(9)_"MakeNull",IDX=IDX+1 - SET MENU(IDX)="Backup without making any changes"_$char(9)_"Quit",IDX=IDX+1 - SET MENU(IDX)="Abort"_$char(9)_"Abort",IDX=IDX+1 - ; - WRITE # - SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") - IF USRSLCT="^" GOTO LC3 - IF USRSLCT=0 SET USRSLCT="" - IF USRSLCT="Examine" DO GOTO:(TMGABORT=1) LC3 GOTO LC2 - . NEW ARRAY SET ARRAY(FILENUM,RPTR)="" - . IF $$SHOWNEED^TMGSIPH5(JNUM,.ARRAY)=-1 SET TMGABORT=1 QUIT - IF USRSLCT="RedirToLocal" DO GOTO LC3 - . NEW DIC,X,Y - . SET DIC=FILENUM,DIC(0)="MAEQ" - . DO ^DIC WRITE ! - . IF +Y'>0 QUIT - . SET ^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)=+Y - IF USRSLCT="MakeNull" DO GOTO LC3 - . SET ^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR)=0 - IF USRSLCT="Quit" GOTO LC3 - IF USRSLCT="Abort" SET TMGABORT=1 GOTO LC3 - GOTO LC2 -LC3 QUIT - ; - ; -MAP2LOCAL(JNUM,INOUT) ; - ;"Purpose: Ask user which records to map to local records - ;"Input: JNUM -- The job number of the background client process - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;"Results: None - ; - NEW GETARRAY,FILENUM,IEN,STIME,TMGCT,SHOWPROG,TALLY,QUERY,ERROR,REPLY - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - NEW AUTOMODE SET AUTOMODE=0 - SET AUTOMODE("MAP MODE")=1 - DO ASKNEEDED(JNUM,.GETARRAY,INOUT,.AUTOMODE) - SET FILENUM=0 - SET STIME=$H - SET TMGCT=1,SHOWPROG=0 - NEW TMGABORT SET TMGABORT=0 - FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="")!(TMGABORT=1) DO - . QUIT:($$DDOK^TMGSIPH1(JNUM,FILENUM)'=1) - . QUIT:($$PREPXREF^TMGSIPH1(JNUM,FILENUM)'=1) - . NEW TMGMAX SET TMGMAX=-1,TMGCT=1,STIME=$H - . NEW IEN SET IEN="" - . FOR SET IEN=$ORDER(GETARRAY(FILENUM,IEN),-1) QUIT:(IEN="")!(TMGABORT=1) DO - . . IF TMGMAX=-1 SET TMGMAX=IEN - . . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) - . . SET TMGCT=TMGCT+1 - . . IF (SHOWPROG=0),(($PIECE($H,",",2)-$PIECE(STIME,",",2))>15) SET SHOWPROG=1 - . . IF SHOWPROG,(TMGCT#2=0) DO - . . . WRITE # - . . . DO ProgressBar^TMGUSRIF(TMGCT,"Progress in "_FILENUM_": "_TMGCT,0,TMGMAX,70,STIME) - . . . IF $DATA(TALLY) WRITE ! ZWR TALLY - . . NEW NEWIEN SET NEWIEN=0 - . . IF $$CHCK4SIM(FILENUM,,.NEWIEN,$$GET01FLD(JNUM,FILENUM,IEN))=0 QUIT ;"Is a prior similar record already is on client? - . . SET ^TMG("TMGSIPH","PT XLAT",FILENUM,IEN)=NEWIEN ;"Add entry to Pointer translation table. - . . DO UNNEEDPTR^TMGSIPHU(FILENUM,IEN,NEWIEN,INOUT,.TALLY) - . . IF INOUT="PTIN" KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,IEN) - . . KILL GETARRAY(FILENUM,IEN) - SET RESULT=1 - IF $DATA(GETARRAY) DO - . NEW TMGARRAY,TMGSEL,IEN - . WRITE # - . WRITE "One or more records could not be automatically matched to a local record.",! - . WRITE "Select records to manually looked up.",! - . DO PRESSTOCONT^TMGUSRIF QUIT:$GET(TMGPTCABORT)=1 - . FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="") DO - . . NEW FNAME SET FNAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) - . . SET IEN="" - . . FOR SET IEN=$ORDER(GETARRAY(FILENUM,IEN),-1) QUIT:(IEN="") DO - . . . NEW DISPSTR SET DISPSTR="Get records from REMOTE file #"_FILENUM_" (" - . . . SET DISPSTR="File: "_FNAME_"; Record: "_$$GET01FLD(JNUM,FILENUM,IEN) - . . . SET TMGARRAY(DISPSTR)=FILENUM_"^"_IEN - . NEW HEADER - . SET HEADER="Select Record(s) in file "_FILENUM_" to MAP to local records. Press when Done." - . DO Selector^TMGUSRIF("TMGARRAY","TMGSEL",HEADER) - . IF $DATA(TMGSEL)=0 QUIT - . NEW TMGI SET TMGI="" - . FOR SET TMGI=$ORDER(TMGSEL(TMGI)) QUIT:(TMGI="")!TMGABORT DO - . . NEW ENTRY SET ENTRY=$GET(TMGSEL(TMGI)) - . . SET FILENUM=+ENTRY QUIT:FILENUM'>0 - . . SET IEN=$PIECE(ENTRY,"^",2) - . . NEW X,Y,DIC - . . SET DIC=FILENUM,DIC(0)="MAEQ" - . . SET DIC("A")="Lookup a match for ["_$$GET01FLD(JNUM,FILENUM,IEN)_"]: " - . . NEW DONE SET DONE=0 - . . FOR DO QUIT:(+Y>0)!(DONE)!TMGABORT - . . . NEW % - . . . DO ^DIC WRITE ! - . . . IF +Y>0 DO QUIT:TMGABORT - . . . . SET %=1 - . . . . WRITE "Use [",$PIECE(Y,"^",2),"]" DO YN^DICN WRITE ! - . . . . IF %=-1 SET TMGABORT=1 QUIT - . . . . IF %=2 SET Y=0 QUIT - . . . IF +Y>0 QUIT - . . . SET %=1 - . . . WRITE "Try another lookup" DO YN^DICN WRITE ! - . . . IF %=-1 SET TMGABORT=1 QUIT - . . . IF %=2 SET DONE=1 QUIT - . . IF +Y>0 DO - . . . SET ^TMG("TMGSIPH","PT XLAT",FILENUM,IEN)=+Y ;"Add entry to Pointer translation table. - . . . DO UNNEEDPTR^TMGSIPHU(FILENUM,IEN,+Y,INOUT,.TALLY) - . . . IF INOUT="PTIN" KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,IEN) - . . . KILL GETARRAY(FILENUM,IEN) - . . . SET TALLY("MANUALLY MATCHED TO LOCAL")=+$GET(TALLY("MANUALLY MATCHED TO LOCAL"))+1 - IF $DATA(TALLY) WRITE ! ZWR TALLY - DO PRESSTOCONT^TMGUSRIF - QUIT - ; - ; -GETFILE Index: cprs/branches/tmg-cprs/m_files/TMGSIPH4.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH4.m~ (revision 796) +++ (revision ) @@ -1,363 +1,0 @@ -TMGSIPH4 ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;11/27/09 - ;;1.0;TMG-LIB;**1**;11/27/09 - ; - ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE - ;"Especially functions for pulling 1 record, and all records pointing to it, from server - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"11/27/09 - ; - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"SRVRDIC(JNUM,REPLY) --get a file and value to lookup on server - ;"SRVFDIC(JNUM,FILENUM,REPLY) -- get value to lookup on server, in specified file. - ;"GETNEWFL(JNUM) -- get a novel file DD from the server (one not already present on client) - ;"GETPTIN(JNUM,FILENUM,IEN) -- as server for all pointers IN to a given record. - ;"ASKREC(JNUM,FILENUM,INOUT) --Query user for patient name, and add to ToDo list - ;"TRANSPT(JNUM) -- allow user to completely transfer 1 patient - ;"TRANSREC(JNUM) -- allow user to completely transfer 1 RECORD - ;"GETMSSNG(JNUM,FILENUM,OUTARRAY) ;Return a list of records on server, for given file, that have not been downloaded to client - ;"CHKSPUPD(JNUM) --check a pre-determined set of files for records on server that are not on client - ;"CHKUPDTE(JNUM) -- check files for records on server that are not on client. - ;"CHK1FUPD(JNUM,FILENUM,ALLRECS,TALLY) -- check 1 file for records on server that are not on client. - ;"======================================================================= - ;"Dependancies - ;"======================================================================= - ;"TMGKERN2 - ;"======================================================================= - ; -SRVRDIC(JNUM,REPLY) - ;"Purpose: to get a file and value to lookup on server - ;"Input: JNUM -- The job number of the background client process - ;" REPLY -- PASS BY REFERANCE. An OUT PARAMETER. - ;"Output: REPLY is filled with reply from server (if any). Format: - ;" REPLY("FILE")=FileNumber that search was from. - ;" REPLY(1)= <-- could be 'Thinking' type messages... - ;" ... - ;" REPLY(n)= <-- probably the line to look at if only 1 expected - ;"Result: none - NEW FILE,DIC,X,Y,VALUE - SET DIC=1,DIC(0)="MAEQ" - SET DIC("A")="Enter FILE on server to search in: " - DO ^DIC WRITE ! - IF +Y'>0 SET Y=$$GETNEWFL(JNUM) - IF +Y'>0 QUIT - DO SRVFDIC(JNUM,+Y,.REPLY) - QUIT - ; - ; -SRVFDIC(JNUM,FILENUM,REPLY) - ;"Purpose: to get value to lookup on server, in specified file. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- The fileman file to search in. - ;" REPLY -- PASS BY REFERANCE. An OUT PARAMETER. - ;"Output: REPLY is filled with reply from server (if any). Format: - ;" REPLY("FILE")=FileNumber that search was from. - ;" REPLY(1)= <-- could be 'Thinking' type messages... - ;" ... - ;" REPLY(n)= <-- probably the line to look at if only 1 expected - ;"Result: none - NEW FILE,DIC,X,Y,VALUE - NEW FILENAME SET FILENAME=$$FILENAME^TMGFMUT2(FILENUM) - ;"SET FILENAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) - WRITE "Enter value in ",FILENAME," to search on server for: " - READ VALUE:$GET(DTIME,3600) WRITE ! - IF VALUE["^" QUIT - NEW QUERY,ERROR - KILL REPLY - SET QUERY="DO DIC|"_FILENUM_"^"_VALUE - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) DO QUIT - . WRITE ERROR,! - SET REPLY("FILE")=FILENUM - QUIT - ; - ; -GETNEWFL(JNUM) ; - ;"Purpose: To get a novel file DD from the server (one not already present on client) - ;"Input: JNUM -- The job number of the background client process - ;"Output: Data dictionary for novel file my be downloaded and put into local database. - ;"Result: Returns file number, or -1 if error or abort. - NEW FILENAME,FILENUM,RESULT,I - SET RESULT=-1 ;"Default to failure - WRITE "Enter name of file to search on server for: " - READ FILENAME:$GET(DTIME,3600) WRITE ! - IF (FILENAME["^")!(FILENAME="") GOTO GNFLDN - NEW QUERY,ERROR,REPLY - SET QUERY="DO DIC|1^"_FILENAME - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) DO GOTO GNFLDN - . WRITE ERROR,! - . DO PRESSTOCONT^TMGUSRIF - IF $DATA(REPLY)=0 GOTO GNFLDN - SET REPLY("FILE")=1 - SET I="" FOR SET I=$ORDER(REPLY(I),-1) QUIT:(I="")!(+I=I) - SET FILENUM=$GET(REPLY(I)) - IF +FILENUM'>0 GOTO GNFLDN - SET QUERY="GET|^DIC("_+FILENUM_")" - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) DO GOTO GNFLDN - . WRITE ERROR,! - . DO PRESSTOCONT^TMGUSRIF - DO STOREDATA^TMGSIPHU(.REPLY) - ;"---- Get and fix file header ---- - SET REF=$GET(^DIC(+FILENUM,0,"GL")) - IF REF="" DO GOTO GNFLDN - . WRITE "UNABLE TO GET GLOBAL REFERENCE IN ^DIC(",FILENUM,",0,""GL"")",! - . DO PRESSTOCONT^TMGUSRIF - SET REF=REF - SET QUERY="GET|"_REF_"0)" - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - IF $DATA(ERROR) DO GOTO GNFLDN - . WRITE ERROR,! - . DO PRESSTOCONT^TMGUSRIF - DO STOREDATA^TMGSIPHU(.REPLY) - SET $PIECE(@(REF_"0)","^",3)=$ORDER(@(REF_"""@"")"),-1) ;"most recently added rec # - SET $PIECE(@(REF_"0)","^",4)=$ORDER(@(REF_"""@"")"),-1) ;"supposed to be total num of recs - SET RESULT=$$DDOK^TMGSIPH1(JNUM,FILENUM) ; -GNFLDN QUIT RESULT - ; - ; -GETPTIN(JNUM,FILENUM,IEN) - ;"Purpose: as server for all pointers IN to a given record. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- The fileman file to consider - ;" IEN -- The record number in file. Server-side IEN - ;"Output: Data us stored in: SET ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",OFILE,NEWIEN)="" - ;"Results: none. - NEW QUERY,ERROR,REPLY - SET QUERY="GET PTRS IN|"_FILENUM_"^"_IEN - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) - ;"REPLY -- PASS BY REFERENCE, an OUT PARAMETER. Format: - ;" REPLY(1)=FROMFILE^FROMIENS^FROMFLD - ;" REPLY(2)=FROMFILE^FROMIENS^FROMFLD etc. - IF $DATA(ERROR) DO QUIT - . WRITE ERROR,! - NEW LINE,NEWIEN - FOR LINE=1:1 QUIT:($DATA(REPLY(LINE))=0) DO - . SET NEWIEN=$PIECE(REPLY(LINE),"^",2) - . NEW OFILE SET OFILE=+REPLY(LINE) - . ;"IF NEWIEN["," QUIT ;"pointers IN from subfiles will be gotten with parent records - . IF NEWIEN["," DO - . . NEW PFILE SET PFILE=OFILE - . . FOR SET PFILE=+$GET(^DD(PFILE,0,"UP")) QUIT:PFILE=0 DO - . . . SET OFILE=OFILE_"{"_PFILE - . SET ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",OFILE,NEWIEN)="" - QUIT - ; - ; -ASKREC(JNUM,FILENUM,INOUT) ; - ;"Purpose: Query user for patient name, and add to ToDo list - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- OPTIONAL. The fileman file. If not provided, user will be asked for it. - ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" - ;" ... NOTE: don't use 'PTOUT' ... causes problem because of difference in node numbers... - ;"Result: none - ;"Records that are needed are stored in ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,IEN)="" - SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" - NEW ARRAY,IEN,VALUE,I,REPLY - SET FILENUM=+$GET(FILENUM) - IF FILENUM>0 DO - . DO SRVFDIC(JNUM,FILENUM,.ARRAY) - ELSE DO - . DO SRVRDIC(JNUM,.ARRAY) - . SET FILENUM=+$GET(ARRAY("FILE")) - IF $DATA(ARRAY)=0 GOTO PRDN - SET I="" FOR SET I=$ORDER(ARRAY(I),-1) QUIT:(I="")!(+I=I) - SET VALUE=$GET(ARRAY(I)) - IF +VALUE'>0 GOTO PRDN - IF INOUT="PTIN" DO - . SET ^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,+VALUE)="" - ELSE DO ;".... don't use - . ;"^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,ReferToNodeToBeCorrected,Piece#OfNode)="" - . ;"SET ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,+VALUE)="" - WRITE $PIECE(VALUE,"^",2),! -PRDN QUIT - ; - ; -TRANSPT(JNUM) - ;"Purpose: to allow user to completely transfer 1 patient - ;"Input: JNUM -- The job number of the background client process - ;"Output: Records are downloaded and put into local database. - ;"Result: none - DO ASKREC(JNUM,2) ;"2 = PATIENT file. - NEW TMGABORT SET TMGABORT=0 - NEW HASTASKS SET HASTASKS=1 - FOR QUIT:(HASTASKS=0)!(TMGABORT) DO - . IF $$HANDLNEEDED^TMGSIPH3(JNUM,"PTIN",1)=-1 SET TMGABORT=1 QUIT - . IF $$HANDLNEEDED^TMGSIPH3(JNUM,"PTOUT",1)=-1 SET TMGABORT=1 QUIT - . IF $DATA(^TMG("TMGSIPH","NEEDED RECORDS","PTIN"))>0 QUIT - . IF $DATA(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT"))>0 QUIT - . SET HASTASKS=0 QUIT - QUIT - ; - ; -TRANSREC(JNUM) ; - ;"Purpose: to allow user to completely transfer 1 RECORD - ;"Input: JNUM -- The job number of the background client process - ;"Output: Records are downloaded and put into local database. - ;"Result: none - NEW DIC,X,Y - NEW ARRAY,IEN,VALUE,I,REPLY,TALLY - SET DIC=1,DIC(0)="MAEQN" - DO ^DIC WRITE ! - IF +Y'>0 SET Y=$$GETNEWFL(JNUM) - IF +Y'>0 GOTO TRDN - SET FILENUM=+Y - DO SRVFDIC(JNUM,FILENUM,.ARRAY) - IF $DATA(ARRAY)=0 GOTO TRDN - SET I="" FOR SET I=$ORDER(ARRAY(I),-1) QUIT:(I="")!(+I=I) - SET VALUE=$GET(ARRAY(I)) - NEW IEN SET IEN=+VALUE - IF IEN'>0 GOTO TRDN - WRITE $PIECE(VALUE,"^",2),! - IF $$GETANDFIXREC^TMGSIPH3(JNUM,FILENUM,IEN,"?",.TALLY,"PTOUT") - IF $DATA(TALLY) ZWR TALLY - DO PRESSTOCONT^TMGUSRIF - ; -TRDN QUIT - ; - ; -GETMSSNG(JNUM,FILENUM,OUTARRAY) ; GetMissingRecordIENs - ;"Purpose: Return a list of records on server, for given file, that have not been downloaded to client - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- The Fileman file number. - ;" OUTARRAY -- PASS BY REFERENCE. Prior contents erased. Format: - ;" OUTARRAY(FILENUM,RPTR)="" - ;" OUTARRAY(FILENUM,RPTR)="" - ;"Results: none - KILL OUTARRAY - NEW CT SET CT=0 - NEW QUERY,ERROR,REPLY,SVRHEADER - SET QUERY="GET IEN HDR|"_FILENUM - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) ;"Should get LastIEN^TotalNumIENS - IF $DATA(ERROR) WRITE ERROR,! GOTO GMDN - SET SVRHEADER=$GET(REPLY(1)) IF SVRHEADER="" DO GOTO GMDN - . WRITE "Error getting File headers from server.",! - NEW DONE SET DONE=0 - IF $GET(^TMG("TMGSIPH","RECORDS SYNC",FILENUM))=SVRHEADER DO GOTO:DONE GMDN2 - . WRITE "According to Fileman headers, there are no new records added to file "_FILENUM,! - . WRITE "since last check.",! - . NEW % SET %=2 - . WRITE "Do complete and thorough check again anyway" DO YN^DICN WRITE ! - . SET DONE=(%'=1) - NEW FILENAME SET FILENAME=$$FILENAME^TMGFMUT2(FILENUM) - WRITE !,"Getting a list of all records on server for file ",FILENAME," (#",FILENUM,")",! - SET QUERY="GET IEN LIST|"_FILENUM - DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) ;"Should get list of all IEN's in record on server. - IF $DATA(ERROR) WRITE ERROR,! GOTO GMDN - SET ^TMG("TMGSIPH","RECORDS SYNC",FILENUM)=SVRHEADER - NEW STIME SET STIME=$H - NEW TMGCT SET TMGCT=0 - NEW SHOWPROG SET SHOWPROG=0 - NEW TMGMIN,TMGMAX - NEW TMGABORT SET TMGABORT=0 - NEW TMGI SET TMGI=0 - FOR SET TMGI=$ORDER(REPLY(TMGI)) QUIT:(+TMGI'>0)!TMGABORT DO - . NEW VALUE SET VALUE=$GET(REPLY(TMGI)) ;"Should be IEN^.01 Value (internal format) - . NEW RPTR SET RPTR=+VALUE - . IF +$GET(^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR))'>0 DO - . . IF $DATA(^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR))=0 DO - . . . SET ^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR)=$PIECE(VALUE,"^",2) - . . SET OUTARRAY(FILENUM,RPTR)="" - . . SET CT=CT+1 - . . KILL REPLY(TMGI) - . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) - . SET TMGCT=TMGCT+1 - . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>5) DO ;"Turn on progress bar after 15 seconds. - . . SET SHOWPROG=1 - . . SET TMGMIN=1 - . . SET TMGMAX=$ORDER(REPLY(""),-1) - . IF (SHOWPROG=1),(TMGCT>200) DO - . . DO ProgressBar^TMGUSRIF(TMGI,"Comparing server vs local records in File: "_FILENUM,TMGMIN,TMGMAX,70,STIME) - . . SET TMGCT=0 -GMDN WRITE ! - WRITE CT," records found to be downloaded.",! -GMDN2 QUIT - ; - ; -CHKSPUPD(JNUM) ;" CHECK SPECIAL FILES FOR UPDATE - ;"Purpose: To check a pre-determined set of files for records on server that are not on client. - ;"Input: JNUM -- The job number of the background client process - ;"Output: Records my be downloaded and put into local database. - ;"Result: none - NEW FILENUM,TALLY,TMGABORT - IF $DATA(^TMG("TMGSIPH","TRACKED FILES"))=0 DO - . SET ^TMG("TMGSIPH","TRACKED FILES",8925)=1 - . SET ^TMG("TMGSIPH","TRACKED FILES",120.5)=1 - . SET ^TMG("TMGSIPH","TRACKED FILES",2005)=1 - . SET ^TMG("TMGSIPH","TRACKED FILES",22705.5)=1 - SET TMGABORT=0 - SET FILENUM=0 - FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","TRACKED FILES",FILENUM)) QUIT:(+FILENUM'>0)!TMGABORT DO - . IF $$CHK1FUPD(JNUM,FILENUM,1,.TALLY)=-1 SET TMGABORT=1 - DO AUTONEEDED^TMGSIPH3(JNUM) - IF $DATA(TALLY) ZWR TALLY - DO PRESSTOCONT^TMGUSRIF - QUIT - ; - ; -CHKUPDTE(JNUM,ALLRECS) ; "CHECK FOR UPDATE - ;"Purpose: To check files for records on server that are not on client. - ;"Input: JNUM -- The job number of the background client process - ;" ALLRECS -- OPTIONAL. Default=0. If 1, then all records are automatically selected - ;"Output: Records my be downloaded and put into local database. - ;"Result: none - NEW DIC,X,Y - NEW ARRAY,IEN,TALLY,FILENUM - SET DIC=1,DIC(0)="MAEQN" - WRITE "Enter FILE on server in which to search for new records.",! - WRITE "(If file exists on server, but not on client, enter ^)",! - DO ^DIC WRITE ! - IF +Y'>0 SET Y=$$GETNEWFL(JNUM) - IF +Y'>0 GOTO CHDN - SET FILENUM=+Y - IF $$CHK1FUPD(JNUM,FILENUM,.ALLRECS,.TALLY) ; - IF $DATA(TALLY) ZWR TALLY - DO PRESSTOCONT^TMGUSRIF - ; -CHDN QUIT - ; -CHK1FUPD(JNUM,FILENUM,ALLRECS,TALLY) ;" CHECK 1 FILE FOR UPDATE - ;"Purpose: To check 1 file for records on server that are not on client. - ;"Input: JNUM -- The job number of the background client process - ;" FILENUM -- the file number to check. - ;" ALLRECS -- OPTIONAL. Default=0. If 1, then all records are automatically selected - ;" TALLY -- PASS BY REFERENCE. An array to hold progress of downloaded files. - ;"Output: Records my be downloaded and put into local database. - ;"Result: 1 if OK, -1 if abort - NEW ARRAY,IEN - NEW RESULT SET RESULT=1 - SET ALLRECS=+$GET(ALLRECS) - DO GETMSSNG(JNUM,FILENUM,.ARRAY) - IF ALLRECS'=1 DO PRESSTOCONT^TMGUSRIF - IF $DATA(ARRAY)=0 GOTO CH1DN - NEW SELARRAY,OPTIONS - IF ALLRECS'=1 DO - . SET OPTIONS("HEADER")="Select Server Records Missing Locally to Download when done." - . DO SELNEEDED^TMGSIPH3(JNUM,.SELARRAY,"ARRAY",.OPTIONS) - ELSE DO - . MERGE SELARRAY=ARRAY - NEW STIME SET STIME=$H - NEW TMGCT SET TMGCT=0 - NEW SHOWPROG SET SHOWPROG=0 - NEW TMGMIN,TMGMAX - NEW TMGABORT SET TMGABORT=0 - NEW RPTR SET RPTR="" - FOR SET RPTR=$ORDER(SELARRAY(FILENUM,RPTR)) QUIT:(+RPTR'>0)!TMGABORT DO - . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) - . NEW TMP SET TMP=$$GETANDFIXREC^TMGSIPH3(JNUM,FILENUM,RPTR,"?",.TALLY) - . IF TMP=-1 DO HNDLGAFE^TMGSIPH3(FILENUM,IEN,.TMGABORT) QUIT - . SET TMGCT=TMGCT+1 - . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>5) DO ;"Turn on progress bar after 5 seconds. - . . SET SHOWPROG=1 - . . SET TMGMIN=$ORDER(SELARRAY(FILENUM,0)) - . . SET TMGMAX=$ORDER(SELARRAY(FILENUM,""),-1) - . IF (SHOWPROG=1),(TMGCT>50) DO - . . DO ProgressBar^TMGUSRIF(RPTR,"Getting Records From File: "_FILENUM,TMGMIN,TMGMAX,70,STIME) - . . SET TMGCT=0 - IF $DATA(TALLY) ZWR TALLY - ; -CH1DN IF TMGABORT SET RESULT=-1 - QUIT RESULT Index: cprs/branches/tmg-cprs/m_files/TMGSRCH.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSRCH.m~ (revision 796) +++ (revision ) @@ -1,336 +1,0 @@ -TMGSRCH ;TMG/kst/Search API ; 5/24/10 - ;;1.0;TMG-LIB;**1**;05/19/10 - ; - ;"TMG FILEMAN SEARCH API - ; - ;"Copyright Kevin Toppenberg MD 5/19/10 - ;"Released under GNU General Public License (GPL) - ;" - ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"SRCH(OUT,FILENUM,STR) --A search function, to support calls by RPC from CPRS - ;"BKSRCH(FILENUM,STR) -- designed to be called via JOB --> separate job thread - ;"FMSRCH(OUT,FILENUM,COMPEXPR) --A wrapper for Fileman search call - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"PARSESTR(FILENUM,STR,ARRAY,FNUMPTR) -- Parse user input into formatted array - ;"PARSE1(FILENUM,STR,FNUMPTR,ARRAY) --Parse a simple search term - ;"BKPGFN(MSG,PCT) -- Callable progress function code for background thread. - ;"DOSRCH(PTMGOUT,FILENUM,STR,PGFN) --Common search codes - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" DIC, TMGDEBUG,TMGUSRIF, TMGDBAPI, DIE, XLFSTR, TMGSRCH* - ;"======================================================================= - ;"======================================================================= - ; - ; - ;"======================================================================= - ;" SEARCH STRING DOCUMENTATION - ;"======================================================================= - ;"Search string examples: - ;" 8925:.02(.01="SMITH,JOHN") - ;" 1234:.01(.03in"32..55") <-- this is a range test - ;" 1234:.99((.01="SMITH,JOHN") OR (.01="SMITH,BILL")) AND 4567:.01(.02'="4/2/10") NOT (1["HAPPY") - ;" 8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70)) Targetfile=2 - ;" - ;"SYNTAX: - ;" -- File specifier. To specify searching in a file OTHER THAN target filenumber, an optional - ;" FILENUM:FLD[:FLD[:FLD...]] may be specified. However, ultimately, this must point back - ;" to the target filenumber. E.g. Search in file 8925, but for each entry found, use the IEN - ;" specified by FLD (or FLDA:FLDB or FLDA:FLDB:FLDC:...). NOTE: If just FILENUM is provided - ;" without specifying FLD(s) to point to target filenumber, then the code will find a path - ;" (if possible), using first one found. - ;" FILENUM:(...) - ;" The logic is read from left to right, honoring parentheses. If a filenumber - ;" is not specified, then the last specified filenumber is used. - ;" E.g. 1234:.01( LogicA ) OR 234:.99( LogicB ) AND ( LogicC ) - ;" LogicA fields refer to file 1234:.01. - ;" LogicB fields refer to file 234:.99 - ;" LogicA fields refer to file 234:.99 (last specified file number) - ;" E.g. 5678:.01( (LogicA1) OR 5432:.88(LogicA2) NOT (LogicA3) ) or (LogicB) - ;" LogicA1 fields refer to file 5678:.01 - ;" LogicA2 fields refer to file 5432:.88 - ;" LogicA3 fields refer to file 5432:.88 (last specified file number inside parentheses) - ;" LogicB fields refer to file 5678 (last specified file number at same parentheses level) - ;" -- Each individual search term must be enclosed in parentheses, and may contain sub-terms - ;" enclosed in nested parentheses - ;" -- Each individual search term is comprised of: - ;" FIELD then COMPARATOR then VALUE - ;" 1. FIELDS -- can be name or number. This is for currently active file (see below) - ;" may also be FIELDA:FIELDB:... when FIELDA is a pointer, then FIELDB - ;" is taken from the pointed-to file. If FIELDB is not provided, and FIELDA - ;" is a pointer, then the .01 field of pointed-to-file. Individual field - ;" names may be inclosed in quotes - ;" 2. COMPARATOR -- can be: - ;" "=" -- means exact match - ;" "'=", "<>", -- any of these means Does-not-equal - ;" ">=", "'<" -- means greater-than-or-equal-to (same as not-less-than) - ;" "<=", "'>" -- means less-than-or-equal-to (same sa not-greater-than) - ;" "in","IN","In","{" -- means field is in specified rage (see Value below) - ;" When using IN, if field name is provided by NAME (not number), - ;" then field name should be inclosed in quotes to separate the - ;" letters of the field name from the letters of 'IN'. - ;" "[" -- means 'contains'. Interpreted as follows: - ;" -- For Word processor (WP) fields, this means that any line in the entire field - ;" can contain search term, to be matched positive. - ;" -- For free text field, then just text of field is searched. - ;" 3. VALUE -- The search term to search for. Should be in quotes. - ;" Note: if comparator is "IN", then syntax is "Value1..Value2" - ;" There should be a ".." between the two values. - ;" -- Logical combiners of separate search terms allowed are: - ;" "OR" or "|" or "||" or "!" - ;" "AND" or "&" or "&&" - ;" "NOT" or "'" or "ANDNOT" - ;"======================================================================= - ;"======================================================================= - ; - ; -TEST ; - NEW STR,OUT - ;"SET STR="8925:(STATUS=COMPLETED)&((PATIENT[CUTSHALL)!(PATIENT[CUTSHAW))" - SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" - ;"SET STR="8925:(REPORT TEXT[DM-2) AND 120.5:((VITAL TYPE=PULSE)&(RATE>70))" - ;"SET STR="8925:(REPORT TEXT[HTN) AND 120.5:((VITAL TYPE=PULSE)&(RATE{70..75))" - ;"SET STR="8925:(REPORT TEXT[DM-2)!(REPORT TEXT[HTN)" - ;"WRITE STR,! - ;"DO SRCH(.OUT,2,STR) - ;"NEW CT SET CT=+$GET(OUT("COUNT")) - ;"WRITE "Found ",CT," total matches.",! - ;"DO PressToCont^TMGUSRIF - - DO BKSRCH(2,STR) - NEW STATUS,PCT - NEW REF SET REF=$NAME(^TMP("TMG","TMGSRCH",$J)) - FOR DO QUIT:(STATUS["#DONE#") - . HANG 1 - . SET STATUS=$GET(@REF@("MSG")) - . WRITE "STATUS: ",STATUS,! - ;"IF $DATA(@REF) ZWR @REF - QUIT - ; -SRCH(OUT,FILENUM,STR) ; - ;"Purpose: A search function, to support calls by RPC from CPRS - ;"Input: OUT-- Pass by reference. AN OUT PARAMETER. - ;" FILENUM -- The target file number that resulting IENs will be in - ;" STR -- This is a logic string for searching. See details above. - ;"Results: OUT is filled in. Format: - ;" OUT(0)=1 for success, or -1^Error Message - ;" OUT(IEN)="" - ;" OUT(IEN)="" - ;" OUT("COUNT")=Count of number of found records. - ;"Results: None - ;" - DO DOSRCH("OUT",.FILENUM,.STR) ; -SRCHDN QUIT - ; - ; -BKSRCH(FILENUM,STR) ; - ;"Purpose: this function is designed to be called via JOB, to setup separate job thread - ;" E.g. JOB BKSRCH^TMGTMGSRCH(FILENUM,STR) NEW MSGJOB SET MSGJOB=$ZJOB - ;" NOTE: When job, output MSG will be "#DONE#" (see below) - ;"Input: Filenum: This this is the target file of the search. - ;" STR -- This is the logic string for searching. Format as per SRCH() docs - ;"Output: Output will go into ^TMP("TMG","TMGSRCH",$J,"OUT") - ;" Messages will go into ^TMP("TMG","TMGSRCH",$J,"MSG") - ;" % Done will go into ^TMP("TMG","TMGSRCH",$J,"PCT") - ;"Results: none - NEW PGFN SET PGFN="DO BKPGFN^TMGSRCH(.TMGSTAT,.TMGPCT)" - NEW POUT SET POUT=$NAME(^TMP("TMG","TMGSRCH",$J,"OUT")) - KILL @POUT - DO DOSRCH(POUT,.FILENUM,.STR,PGFN) ; - DO BKPGFN("#DONE#",100) - QUIT ;"This should terminate thread (if called by JOB as above) - ; -BKPGFN(MSG,PCT) ; - ;"Callable progress function code for background thread. - SET ^TMP("TMG","TMGSRCH",$J,"MSG")=$GET(MSG) - SET ^TMP("TMG","TMGSRCH",$J,"PCT")=$GET(PCT) - QUIT - ; - ; -DOSRCH(PTMGOUT,FILENUM,STR,PGFN) ; - ;"Common entry endpoint for search entry tags. See docs in SRCH() - ;"Input: PTMGOUT -- Pass by NAME. The name of the output array - ;" FILENUM -- See SRCH() - ;" STR -- See SRCH() - ;" TMGPGFN -- OPTIONAL. Mumps code that will be called periodically - ;" to allow display of progress of slow searches. - ;" Code may depend on the following variables: - ;" TMGSTAT -- The most recent status text - ;" TMGPCT -- a very gross estimate of % done (0-100%) - ;"Results -- None. - NEW TMGARRAY,RESULT,CT - SET RESULT=$$PARSESTR(.FILENUM,STR,.TMGARRAY) - ; - ;"MERGE ^TMG("TMP","RPC","TMGRPCSR","TMGARRAY")=TMGARRAY ;"TEMP!!! - ; - IF +RESULT=-1 SET @PTMGOUT@(0)=RESULT GOTO DSRCHDN - SET CT=$$ARRYSRCH^TMGSRCH0(FILENUM,PTMGOUT,.TMGARRAY,.PGFN) - SET @PTMGOUT@("COUNT")=CT - SET @PTMGOUT@("FILENUM")=FILENUM - IF $GET(@PTMGOUT@(0))="" SET @PTMGOUT@(0)=1 ;"Success -DSRCHDN QUIT - ; - ; -PARSESTR(FILENUM,STR,ARRAY,FNUMPTR) ; - ;"Purpose: To take user input, validate it, and parse into an formatted array - ;"Input: FILENUM -- The file number that is the target of the search. - ;" STR: This is the user input string. Format as documented in SRCH() above. - ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. - ;" ARRAY(1,"FNUMPTR")= FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that - ;" contain search field, and then fields used to point - ;" back to *TARGET* FILENUM for entire search - ;" ARRAY(1,"FLD")=Fieldnumber to search - ;" ARRAY(1,"COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[", "{", "IN" - ;" ARRAY(1,"SRCH")=The value of to be used in search. - ;" ARRAY(1,"WP")=1 if field is a WP field - ;" ARRAY(2,...) The second search term. - ;" ARRAY(2,"LOGIC")=#^Combiner - ;" # means the set so far. - ;" Combiner will be "AND", "OR", or "NOT" - ;" ARRAY(3,...) The third search term (which is comprised of sub terms) - ;" ARRAY(3,1,... The first subterm (same format as higher level) - ;" ARRAY(3,2,... The second subterm (same format as higher level) - ;" ARRAY(n,...) The N'th search term. - ;" removed-> ARRAY("SETCOMP",i)= NumA^Combiner^NumB - ;" NumA and NumB refer to seach term number (e.g. 1, 2, ... n above) - ;" If NumA="#", then it means 'the resulting set of results so far' - ;" Combiner will be "AND", "OR", or "NOT" - ;" i is the index variable, and logic should be evaluated in numerical order - ;" FNUMPTR: Will be used when calling self reiteratively. Leave blank in first call. - ;" DON'T pass by reference. This is 'FileNum:FLD[:FLD[:FLD...]] specifier - ;"Results: 1 if OK, or -1^Message if error during processing. - ; - NEW SUBSTRA,SUBSTRB,POS - NEW RESULT SET RESULT=1 ;"default to success - NEW TERMNUM SET TERMNUM=0 - SET FILENUM=+$GET(FILENUM) - IF FILENUM'>0 DO GOTO PSDN - . SET RESULT="-1^Target file number not provided." - SET FNUMPTR=$GET(FNUMPTR,FILENUM) - SET ARRAY("FILE")=FILENUM - NEW LOGICNUM SET LOGICNUM=0 - NEW DONE SET DONE=0 - FOR DO QUIT:(DONE=1)!(+RESULT=-1) - . NEW TEMPARRAY - . SET TERMNUM=TERMNUM+1 - . ;"--- Get file number, if any - . SET STR=$$TRIM^XLFSTR(STR) - . IF +$PIECE(STR,"(",1)>0 DO QUIT:(+RESULT=-1) - . . SET FNUMPTR=$PIECE(STR,"(",1) ;"Convert 1234:.01:.02:(...) --> 1234:.01:.02: - . . IF $EXTRACT(FNUMPTR,$LENGTH(FNUMPTR))=":" SET FNUMPTR=$EXTRACT(FNUMPTR,1,$LENGTH(FNUMPTR)-1) - . . IF ($PIECE(FNUMPTR,":",2)="")&(+FNUMPTR'=FILENUM) DO QUIT:(+RESULT=-1) - . . . NEW SAVPTR SET SAVPTR=FNUMPTR - . . . SET FNUMPTR=$PIECE($$PATHTO^TMGSRCH1(+FNUMPTR,FILENUM),"^",1) - . . . IF FNUMPTR="" SET RESULT="-1^Unable to find path to file #"_FILENUM_" from "_SAVPTR - . . ELSE IF $$FNPTR^TMGSRCH1(FNUMPTR)'=FILENUM DO QUIT - . . . SET RESULT="-1^'"_FNUMPTR_"' points to file #"_$$FNPTR^TMGSRCH1(FNUMPTR)_", not file #"_FILENUM_" as expected" - . ;"Split STR --> SUBSTRA + SUBSTRB - . SET SUBSTRA=$$MATCHXTR^TMGSTUTL(STR,"(",,,"(") - . IF SUBSTRA="" SET DONE=1 QUIT - . SET POS=$FIND(STR,SUBSTRA) ;"Return pos of following character - . SET SUBSTRB=$EXTRACT(STR,POS+1,9999) ;"Should be " [LOGICTERM] [SearchTerm]..." - . ;"Process SUBSTRA, either directly if single term, or recursively if compound term. - . IF $$HNQTSUB^TMGSTUTL(SUBSTRA,"(") DO - . . SET RESULT=$$PARSESTR(FILENUM,SUBSTRA,.TEMPARRAY,FNUMPTR) - . . SET ARRAY(TERMNUM,"SUBTERMS")=1 - . ELSE DO - . . SET RESULT=$$PARSE1(FILENUM,SUBSTRA,FNUMPTR,.TEMPARRAY) - . IF +RESULT=-1 QUIT - . SET SUBSTRA="" - . MERGE ARRAY(TERMNUM)=TEMPARRAY - . ;"Now get Logic term connecting this to next term (if any) - . SET SUBSTRB=$$TRIM^XLFSTR(SUBSTRB) ;"Remove opening (and closing) spaces - . NEW LOGICTERM SET LOGICTERM="" - . NEW P,CH - . NEW DNCOMB SET DNCOMB=0 - . FOR P=1:1:$LENGTH(SUBSTRB) DO QUIT:DNCOMB!(+RESULT=-1) - . . SET CH=$$UP^XLFSTR($EXTRACT(SUBSTRB,P)) - . . IF ("&|'!ANDORNOT"'[CH) SET DNCOMB=1 QUIT - . . SET LOGICTERM=LOGICTERM_CH - . SET STR=$EXTRACT(SUBSTRB,$LENGTH(LOGICTERM)+1,9999),SUBSTRB="" - . IF LOGICTERM="" QUIT - . SET LOGICTERM=$$FIXCOMB^TMGSRCH1(LOGICTERM,.RESULT) QUIT:(+RESULT=-1) - . NEW CURSET SET CURSET=$SELECT(TERMNUM=1:"1",1:"#") - . SET LOGICNUM=LOGICNUM+1 - . ;"SET ARRAY("SETCOMP",LOGICNUM)=CURSET_"^"_LOGICTERM_"^"_(TERMNUM+1) ;"will check later that TERMNUM+1 is supplied - . SET ARRAY(TERMNUM+1,"LOGIC")="#^"_LOGICTERM -PSDN QUIT RESULT - ; - ; -PARSE1(FILENUM,STR,FNUMPTR,ARRAY) ; - ;"Purpose: Parse a simple search term (e.g. .01="SMITH,JOHN"). Also validate that field exists in file. - ;"Input: FILENUM -- The TARGET filenumber that the entire search is referencing. - ;" STR: This is part of the user input string to parse - ;" FNUMPTR: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that contain search field, and then - ;" fields used to point back to *TARGET* FILENUM for entire search - ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format as follows. - ;" ARRAY("FNUMPTR")=Filenumber that contains field) - ;" ARRAY("FLD")=Fieldnumber to search - ;" ARRAY("COMP")=Comparator, will be "=", "'=", "'<", or "'>", "[","IN", "{" - ;" ARRAY("SRCH")=The value of to be used in search. - ;" ARRAY("WP")=1 if field is a WP field - ;"NOTE: If field specifies a DATE, then the search value will be converted to FileMan format - ;"Results: 1 if OK, or -1^Message if error during processing. - ;" - NEW RESULT SET RESULT=1 ;"default to success - NEW SAV SET SAV=STR - SET STR=$$TRIM^XLFSTR($GET(STR)) - SET ARRAY("FNUMPTR")=FNUMPTR - NEW FLD,FLDS SET FLDS="" - NEW TMGTFILE SET TMGTFILE=+FNUMPTR - FOR QUIT:("'<>=[:({"[$EXTRACT(STR,1))!(STR="") DO - . SET FLD=$$GETFLD^TMGSRCH1(.STR) ; - . NEW SAVFIL SET SAVFIL=TMGTFILE - . NEW ONEFLD SET ONEFLD=$$FLDNUM^TMGSRCH1(.TMGTFILE,.FLD) - . IF ONEFLD'>0 DO QUIT - . . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_SAVFIL_"]" - . IF FLDS'="" SET FLDS=FLDS_":" - . SET FLDS=FLDS_ONEFLD - IF +RESULT=-1 GOTO PS1DN - SET ARRAY("FLD")=FLDS - IF $$ISWPFLD^TMGDBAPI(+FNUMPTR,+FLDS) SET ARRAY("WP")=1 - NEW FLDTYPE SET FLDTYPE=$PIECE($GET(^DD(+FNUMPTR,+FLDS,0)),"^",2) - IF FLDTYPE["M" DO GOTO PS1DN - . SET RESULT="-1^Searches in fields that are MULTIPLES not supported" - SET STR=$$TRIM^XLFSTR(STR) - NEW COMP - IF $$UP^XLFSTR($EXTRACT(STR,1,3))="'IN" SET COMP="'IN" - ELSE IF $$UP^XLFSTR($EXTRACT(STR,1,2))="IN" SET COMP="IN" - ELSE DO - . SET COMP="" NEW P,CH - . FOR P=1:1:$LENGTH(STR) SET CH=$EXTRACT(STR,P) QUIT:("'!<>=[{"'[CH) SET COMP=COMP_CH - SET STR=$EXTRACT(STR,$LENGTH(COMP)+1,9999) - SET COMP=$$FIXCOMP^TMGSRCH1(COMP,.RESULT) - IF +RESULT=-1 GOTO PS1DN - SET ARRAY("COMP")=COMP - SET STR=$$TRIM^XLFSTR(STR) ;"Remove any spaces after comparator - NEW SRCH SET SRCH=$$TRIM^XLFSTR(STR,,"""") ;"Trim quotes, if any. - IF FLDTYPE["D" DO GOTO:(+RESULT=-1) PS1DN ;"standardized dates - . NEW ADATE SET ADATE=SRCH - . NEW TEMPRSLT SET TEMPRSLT="" - . FOR QUIT:(ADATE="")!(+RESULT=-1) DO - . . IF TEMPRSLT'="" SET TEMPRSLT=TEMPRSLT_".." - . . SET TEMPRSLT=TEMPRSLT_$$STDDATE^TMGSRCH1($PIECE(ADATE,"..",1),.RESULT) - . . IF +RESULT=-1 QUIT - . . SET ADATE=$PIECE(SRCH,"..",2) - . SET SRCH=TEMPRSLT - ELSE IF FLDTYPE["S" DO ;"Convert FM SET type into internal format - . NEW OUT,TMGMSG - . DO VAL^DIE(+FNUMPTR,"+1,",FLD,"E",SRCH,.OUT,,"TMGMSG") - . SET SRCH=$GET(OUT) - IF SRCH'="" SET ARRAY("SRCH")=SRCH - ELSE DO GOTO PS1DN - . SET RESULT="-1^Search value is invalid" - ; -PS1DN IF +RESULT=-1 SET RESULT=RESULT_", found in ["_SAV_"]" - QUIT RESULT - ; - ; -FMSRCH(TMGFILE,TMGCOMPEXPR,TMGOUT,TMGOPTION) ; - QUIT $$FMSRCH^TMGSRCH0(.TMGFILE,.TMGCOMPEXPR,.TMGOUT,.TMGOPTION) - Index: cprs/branches/tmg-cprs/m_files/TMGSRCH0.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSRCH0.m~ (revision 796) +++ (revision ) @@ -1,378 +1,0 @@ -TMGSRCH0 ;TMG/kst/Search API ;05/19/10 ; 5/21/10 6:08pm - ;;1.0;TMG-LIB;**1**;05/19/10 - ; - ;"TMG FILEMAN SEARCH API - ; - ;"Copyright Kevin Toppenberg MD 5/19/10 - ;"Released under GNU General Public License (GPL) - ;" - ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"FMSRCH(OUT,FILENUM,COMPEXPR) --A wrapper for Fileman search call - ;"ARRYSRCH(FILENUM,PRESULT,ARRAY) -- Process parsed array, doing search - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"USRPGFN(TMGPGFN,TMGSTAT) -- Do user Progress Function, if any. - ;"SAMEFILE(PARRAY,STARTNUM,CURFILE) --Return range of search terms that are all in the same Fileman file - ;"COMPEXPR(FILENUM,PARRAY,STARTN,ENDN,SRCHFILE,FIELDS) -- prepair a FILEMAN COMPUTED EXPRSSION from elements in ARRAY - ;"FIXCOMB(COMB) -- Fix COMBINER term - ;"COMP1XP(PARRAY,FIELDS) -- prepair 1 FILEMAN COMPUTED EXPRSSION from elements in ARRAY - ;"FIXSET(TMGRSLT,TARGETFILE,SRCHFILE,FLDS,TMGSET) -- Change output of FMSRCH into needed format. - ;"RESOLV(FILE,FLDSTR,IEN,ERR) -- follow pointer path to final value. - ;"DOCOMB(COMB,TMG1SET,PRESULT) -- combine TMG1SET with @PRESULT based on logical operation COMBiner - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" DIC, TMGDEBUG - ;"======================================================================= - ;"======================================================================= - ; - ; -ARRYSRCH(FILENUM,PRESULT,TMGARRAY,TMGPGFN) ; - ;"Purpose: Process parsed array, doing search on terms, and combining them. - ;"Input: FILENUM -- This is the target file - ;" PRESULT-- Pass by NAME. AN OUT PARAMETER. (see output below) - ;" TMGARRAY -- Pass by reference. Contains search terms. Format - ;" TMGARRAY("FILE")=FileNumber (This is target output file) - ;" TMGARRAY(index,"FLD")=Field to search - ;" TMGARRAY(index,"FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] - ;" TMGARRAY(index,"SRCH")=Value to search for - ;" TMGARRAY(index,"LOGIC",num)=... - ;" TMGARRAY(index,"WP")=1 if field is a WP field - ;" TMGARRAY(index,"COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN - ;" TMGARRAY(index,"SUBTERMS")=1 if has subterms - ;" TMGARRAY(index,indexB,...)... - ;" TMGPGFN -- OPTIONAL. Mumps code that will be called periodically - ;" to allow display of progress of slow searches. - ;" Code may depend on the following variables: - ;" TMGSTAT -- The most recent status text - ;" TMGPCT -- a very gross estimate of % done (0-100%) - ;"Output: PRESULT is filled in. Format: - ;" @PRESULT@(0)=-1^Error Message, if needed - ;" -or- - ;" @PRESULT@(IEN)="" - ;" @PRESULT@(IEN)="" - ;"Result: Returns number of matches found. - NEW ENTRYNUM,ENDNUM,TEMP,TMGEXPR,TMGFLDS,TMGFILE,MAXNUM - NEW CT - KILL @PRESULT - NEW ERR SET ERR=0 - NEW DONE SET DONE=0 - SET MAXNUM=+$ORDER(TMGARRAY("@"),-1) - IF MAXNUM<1 SET MAXNUM=1 ;"Avoid any divide by zero error - SET ENTRYNUM=1 - FOR DO QUIT:(DONE=1)!(+ERR=-1) - . SET TEMP=$$SAMEFILE("TMGARRAY",ENTRYNUM) - . SET ENDNUM=$PIECE(TEMP,"^",2) - . IF ENDNUM NOTE: if WP field is encountered, this is kicked out as NOT - ;" in same file, to overcome LIST^DIC limitation. (REMOVED AFTER LIMITATION FIXED) - ;"Input: PARRAY -- PASS BY NAME. This is ARRAY as passed to DOSRCH - ;" STARTNUM -- OPTIONAL. The index to start consideration of. Default=1 - ;" CURFILE -- OPTIONAL. Used when calling self reiteratively. Leave blank first time. - ;"Result: StartIndex^EndIndex of entries dealing with same file. - ; - SET STARTNUM=$GET(STARTNUM,1) - NEW RESULT SET RESULT=STARTNUM_"^-1" - NEW I SET I=STARTNUM-1 - SET CURFILE=+$GET(CURFILE) - NEW DONE SET DONE=0 - FOR SET I=$ORDER(@PARRAY@(I)) QUIT:(+I'>0)!(DONE=1) DO - . NEW THISFNUM SET THISFNUM=+$GET(@PARRAY@(I,"FNUMPTR")) - . IF $GET(@PARRAY@(I,"SUBTERMS"))=1 DO QUIT:DONE=1 - . . SET THISFNUM=CURFILE - . . NEW TEMP SET TEMP=$$SAMEFILE($NAME(@PARRAY@(I)),1,.THISFNUM) - . . NEW NUM2 SET NUM2=$PIECE(TEMP,"^",2) - . . IF NUM2=-1 SET DONE=1 QUIT - . . IF +$ORDER(@PARRAY@(I,NUM2))>0 SET DONE=1 - . IF (CURFILE>0) DO QUIT:DONE=1 - . . IF (THISFNUM'=CURFILE) SET DONE=1 QUIT - . . ;"IF $GET(@PARRAY@(I,"WP"))=1 SET DONE=1 QUIT - . SET CURFILE=THISFNUM - . SET $PIECE(RESULT,"^",2)=I - QUIT RESULT - ; -COMPEXPR(FILENUM,PARRAY,STARTN,ENDN,SRCHFILE,FIELDS) ; - ;"Purpose: to prepair a FILEMAN COMPUTED EXPRSSION from elements in ARRAY - ;"Input: ARRAY -- Pass by reference. Contains search terms. Format - ;" @PARRAY@("FILE")=FileNumber (This is target output file) - ;" @PARRAY@(index,"FLD")=Field to search - ;" @PARRAY@(index,"FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] - ;" @PARRAY@(index,"SRCH")=Value to search for - ;" @PARRAY@(index,"COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN - ;" @PARRAY@(index,"SUBTERMS")=1 if has subterms - ;" STARTN -- The starting index to consider - ;" ENDN -- the ending index to consider - ;" SRCHFILE --PASS BY REFERENCE. This is the file to search for fields in - ;" FIELDS -- Pass by reference. This is the desired output fields. - ;"Results: Will return a COMPUTED EXPRESSION, or -1^Message - ;" - NEW RESULT SET RESULT="" - NEW I,CURFIL - SET CURFIL=0 - FOR I=STARTN:1:ENDN DO QUIT:(+RESULT=-1) - . IF RESULT'="" DO - . . NEW COMB SET COMB=$PIECE($GET(@PARRAY@(I,"LOGIC")),"^",2) - . . DO FIXCOMB(.COMB) - . . SET RESULT=RESULT_COMB - . IF $GET(@PARRAY@(I,"SUBTERMS"))=1 DO QUIT - . . NEW ENUM SET ENUM=+$ORDER(@PARRAY@(I,"@"),-1) - . . NEW TEMP SET TEMP=$$COMPEXPR(FILENUM,$NAME(@PARRAY@(I)),1,ENUM,.SRCHFILE,.FIELDS) - . . IF +TEMP=-1 SET RESULT=TEMP - . . SET RESULT=RESULT_TEMP - . NEW PRIOREXP SET PRIOREXP=$GET(@PARRAY@(I,"FM COMP EXPR")) - . IF PRIOREXP'="" SET RESULT=RESULT_PRIOREXP QUIT - . NEW FNUMPTR SET FNUMPTR=$GET(@PARRAY@(I,"FNUMPTR")) - . IF FNUMPTR="" DO QUIT - . . SET RESULT="-1^No FNUMPTR found in array. Can't create computed expression" - . IF CURFIL=0 SET CURFIL=+FNUMPTR - . IF CURFIL'=+FNUMPTR DO QUIT - . . SET RESULT="-1^Can't make computed expression involving different files." - . SET SRCHFILE=CURFIL - . NEW EXPR SET EXPR=$$COMP1XP($NAME(@PARRAY@(I)),.FIELDS) - . IF +EXPR=-1 SET RESULT=EXPR QUIT - . SET @PARRAY@(I,"FM COMP EXPR")=EXPR - . SET RESULT=RESULT_EXPR - QUIT RESULT - ; -FIXCOMB(COMB) ; "Fix COMBINER terms - IF COMB="AND" SET COMB="&" - ELSE IF COMB="OR" SET COMB="!" - ELSE IF COMB="NOT" SET COMB="&'" - QUIT - ; -COMP1XP(PARRAY,FIELDS) ; - ;"Purpose: to prepair ONE FILEMAN COMPUTED EXPRSSION from elements in ARRAY - ;"Input: PARRAY -- Pass by NAME. Contains search terms. Format - ;" @PARRAY@("FLD")=Field to search - ;" @PARRAY@("FNUMPTR")=FileNum:FLD[:FLD[:FLD...]] - ;" @PARRAY@("SRCH")=Value to search for (or Value..Value2 if IN comparator) - ;" @PARRAY@("COMP")=comparator Allowed Comparators: =, '=, '<, '>, [, IN - ;" FIELDS -- Pass by reference. This is the desired output fields. - ;"Results: Will return a COMPUTED EXPRESSION, or -1^Message - ; - NEW RESULT SET RESULT="" - NEW FLD SET FLD=$GET(@PARRAY@("FLD")) - IF +FLD=0 DO GOTO CP1DN - . SET RESULT="-1^No field number found" - SET FIELDS=$PIECE($GET(@PARRAY@("FNUMPTR")),":",2,999) - NEW COMP SET COMP=$GET(@PARRAY@("COMP")) - IF COMP="" DO GOTO CP1DN - . SET RESULT="-1^No comparator found" - NEW VALUE SET VALUE=$GET(@PARRAY@("SRCH")) - IF VALUE="" DO GOTO CP1DN - . SET RESULT="-1^No value to search for found." - IF COMP'="IN" DO - . SET RESULT="(#"_FLD_COMP_""""_VALUE_""")" - ELSE DO ;"Handle .01IN"5..10" - . NEW V1,V2 - . SET V1=$PIECE(VALUE,"..",1) - . SET V2=$PIECE(VALUE,"..",2) - . IF (V1="")!(V2="") DO QUIT - . . SET RESULT="-1^Range values (e.g. V1..V2) not found for IN comparator." - . SET RESULT="((#"_FLD_"'<"""_V1_""")&(#"_FLD_"'>"""_V2_"""))" - IF +RESULT=-1 GOTO CP1DN - ; -CP1DN QUIT RESULT - ; -FMSRCH(TMGFILE,TMGCOMPEXPR,TMGOUT,TMGOPTION) ; - ;"Purpose: This is a wrapper for new Fileman search call LIST^DIC - ;"Input: TMGFILE -- File name or number to search in. - ;" TMGFILE(0) -- If FILE refers to a subfile, then FILE(0) must be set to - ;" the IENS that identifies which subfile to search. - ;" If supplied, then FILE should be PASSED BY REFERENCE - ;" TMGCOMPEXPR -- This is a FILEMAN COMPUTED EXPRESSION used for search. - ;" TMGOUT -- PASS BY REFERENCE. an OUT PARAMETER. Pre-existing data killed. - ;" This is array that will be filled with results. - ;" e.g. OUT(IEN)=IEN^FieldValue(s) - ;" If OPTION("BYROOT")=1, then OUT must hold the *name* of a variable to be filled. - ;" e.g. @OUT@(IEN)=IEN^FieldValue(s) - ;" TMGOUT("ERR") -- will be filled with error messages, if encountered - ;" TMGOPTION -- (OPTIONAL) -- Used to past customizations to LIST^DIC. - ;" TMGOPTION("BYROOT") If 1, then TMGOUT holds name of variable to be filled with results. - ;" ** See details in documentation for LIST^DIC for items below ** - ;" TMGOPTION("FIELDS") -- Optional. Fields to return with each entry. - ;" TMGOPTION("FLAGS") -- Optional. Default="PX" Note: "X" will always be passed to LIST^DIC - ;" TMGOPTION("NUMBER") -- Optional. Max number of entries to return. Default is "*" (all) - ;" TMGOPTION("FROM") -- Optional. Index entry from which to begin the list. - ;" TMGOPTION("PART") -- Optional. A partial match restriction. - ;" TMGOPTION("SCREEN") -- Optional. Screening code to apply to each potential entry. - ;" TMGOPTION("ID") -- Optional. Identifier: text to accompany each entry returned in the list. - ;"Results: returns # of matches. - NEW TMGRESULT SET TMGRESULT=0 - SET TMGFILE=$GET(TMGFILE) - IF +TMGFILE'=TMGFILE DO - . NEW X,Y,DIC - . SET DIC=1,DIC(0)="M" - . SET X=TMGFILE - . DO ^DIC - . SET TMGFILE=+Y - NEW TMGIENS SET TMGIENS=$GET(FILE(0)) - NEW TMGFLDS SET TMGFLDS=$GET(TMGOPTION("FIELDS"),"@;") - NEW TMGFLAGS SET TMGFLAGS=$GET(TMGOPTION("FLAGS"),"P") - IF TMGFLAGS'["X" SET TMGFLAGS=TMGFLAGS_"X" - NEW TMGMAX SET TMGMAX=$GET(TMGOPTION("NUMBER"),"*") - NEW TMGFROM MERGE TMGFROM=TMGOPTION("FROM") - NEW TMGPART MERGE TMGPART=TMGOPTION("PART") - NEW TMGSCR SET TMGSCR=$GET(TMGOPTION("SCREEN")) - NEW TMGID SET TMGID=$GET(TMGOPTION("ID")) - SET TMGCOMPEXPR=$GET(TMGCOMPEXPR) - NEW TMGRSLT,TMGMSG - NEW TMGDB,TMGX SET TMGDB=0 ;"Can be changed when stepping through code. - IF TMGDB=1 DO - . SET TMGX="DO LIST^DIC("_TMGFILE_"," - . IF $GET(TMGIENS)'="" SET TMGX=TMGX_""""_TMGIENS_"""" - . SET TMGX=TMGX_","""_TMGFLDS_"""," - . SET TMGX=TMGX_""""_TMGFLAGS_""","""_TMGMAX_"""," - . IF $DATA(TMGFROM) SET TMGX=TMGX_".TMGFROM" - . SET TMGX=TMGX_"," - . IF $DATA(TMGPART) SET TMGX=TMGX_".TMGPART" - . SET TMGX=TMGX_","""_$$QTPROTECT^TMGSTUTL(TMGCOMPEXPR)_"""," - . IF $GET(TMGSCR)'="" SET TMGMAX=TMGMAX_""""_TMGSCR_"""" - . SET TMGX=TMGX_"," - . IF $GET(TMGID)'="" SET TMGMAX=TMGMAX_""""_TMGID_"""" - . SET TMGX=TMGX_"," - . SET TMGX=TMGX_"""TMGRSLT"",""TMGMSG"")" - DO LIST^DIC(TMGFILE,TMGIENS,TMGFLDS,TMGFLAGS,TMGMAX,.TMGFROM,.TMGPART,TMGCOMPEXPR,TMGSCR,TMGID,"TMGRSLT","TMGMSG") - NEW BYROOT SET BYROOT=+$GET(TMGOPTION("BYROOT")) - NEW OUTROOT - IF BYROOT SET OUTROOT=TMGOUT - ELSE SET OUTROOT="TMGOUT" - KILL @OUTROOT - IF $DATA(TMGMSG("DIERR")) DO GOTO FMSDN - . MERGE @OUTROOT@("ERR")=TMGMSG("DIERR") ;"copy in errors, if any - . SET TMGRESULT=0 - MERGE @OUTROOT@(0)=TMGRSLT("DILIST",0) - NEW I SET I=0 - NEW IENPCE SET IENPCE=0 - FOR I=1:1:999 IF $PIECE(TMGRSLT("DILIST",0,"MAP"),"^",I)="IEN" SET IENPCE=I QUIT - SET I=0 FOR SET I=$ORDER(TMGRSLT("DILIST",I)) QUIT:(+I'>0) DO - . NEW VALUE SET VALUE=$GET(TMGRSLT("DILIST",I,0)) - . NEW IEN SET IEN=$PIECE(VALUE,"^",IENPCE) - . SET @OUTROOT@(IEN)=VALUE - MERGE @OUTROOT@("ID")=TMGRSLT("ID") ;"Copy in identifiers, if any - SET TMGRESULT=+$PIECE(TMGRSLT("DILIST",0),"^",1) -FMSDN QUIT TMGRESULT - ; - ; -FIXSET(TMGIN,TARGETFN,SRCHFILE,FLDS,TMG1SET) ; - ;"Purpose: Change output of FMSRCH into needed format. - ;" Note: FMSRCH() won't allow ouput fields in format of .02:.01:.1 etc. - ;"Input: TMGIN -- PASS BY REFERENCE. The results of FMSRCH. Format: - ;" TMGIN(SrchFileIEN)=SrchFileIEN^FieldValue <-- FieldValue is a pointer/IEN - ;" TARGETFN -- The this the target file number. - ;" SRCHFILE -- The file that the results are from. - ;" FLDS -- The desired fields. e.g. .02, or .02:.01 etc. - ;" TMG1SET -- PASS BY REFERENCE. AN OUT PARAMETER. Prior results killed - ;" TMG1SET(SrchFileIEN)="" - ;" TMG1SET(SrchFileIEN)="" - ;" TMG1SET("DETAILS",TargetFileIEN,SrchFileNum,SrchFileIEN) - ;" TMG1SET("DETAILS",TargetFileIEN,SrchFileNum,SrchFileIEN) - ;"Results: 0 if OK, or -1^Message if error. - KILL TMG1SET - NEW RESULT SET RESULT=0 - NEW VALUE - NEW ERR SET ERR=0 - NEW IEN SET IEN=0 - FOR SET IEN=$ORDER(TMGIN(IEN)) QUIT:(+IEN'>0)!(+RESULT=-1) DO - . IF SRCHFILE'=TARGETFN DO - . . SET VALUE=$PIECE($GET(TMGIN(IEN)),"^",2) QUIT:(+VALUE'>0) - . . IF FLDS[":" SET VALUE=$$RESOLV(SRCHFILE,FLDS,VALUE,.ERR) - . ELSE DO - . . SET VALUE=+$GET(TMGIN(IEN)) - . QUIT:(+VALUE'>0) - . IF +ERR=-1 SET RESULT=ERR QUIT - . SET TMG1SET(VALUE)="" - . SET TMG1SET("DETAILS",VALUE,SRCHFILE,IEN)="" ;"<-- Value=IEN in target file, IEN=IEN in SRCHFILE - QUIT RESULT - ; -RESOLV(FILE,FLDSTR,IEN,ERR) ;" NOTE: THIS NEEDS TO BE COMPILED. INEFFECIENT TO DO EACH TIME. - ;"Purpose: To follow pointer path to final value. - ;"Input: FILE -- File that IEN is in. - ;" FLDSTR -- e.g. ".02:.01:10:.01" - ;" IEN -- This is the value in FILE of the first field in FLDSTR (e.g. ".02") - ;" ERR -- PASS BY REFERENCE. AN OUT PARAMETER. -1^Err Msg, if any - ;"Result: Returns resolved value (INTERNAL FORMAT) - NEW P2FILE,INFO - SET ERR="" - NEW RESULT SET RESULT="" - IF FLDSTR[":" DO GOTO:(+ERR=-1) RLVDN - . NEW ZNODE SET ZNODE=$GET(^DD(FILE,+FLDSTR,0)) - . IF ZNODE="" DO QUIT - . . SET ERR="-1^Can't find declaration in DD for File #"_FILE_", FLD #"_+FLDSTR - . SET INFO=$PIECE(ZNODE,"^",2) - . SET P2FILE=+$PIECE(INFO,"P",2) - . IF P2FILE'>0 DO QUIT - . . SET ERR="-1^File #"_FILE_", FLD #"_+FLDSTR_" is not a pointer field." - . NEW ROOT SET ROOT="^"_$PIECE(ZNODE,"^",3)_IEN_")" - . NEW NEXTFLDS SET NEXTFLDS=$PIECE(FLDSTR,":",2,999) - . SET ZNODE=$GET(^DD(P2FILE,+NEXTFLDS,0)) - . NEW NODE SET NODE=$PIECE($PIECE(ZNODE,"^",4),";",1) - . NEW PCE SET PCE=$PIECE($PIECE(ZNODE,"^",4),";",2) - . NEW NEXTIEN SET NEXTIEN=$PIECE($GET(@ROOT@(NODE)),"^",PCE) - . SET RESULT=$$RESOLV(P2FILE,NEXTFLDS,NEXTIEN,.ERR) - ELSE SET RESULT=IEN -RLVDN QUIT RESULT - ; -DOCOMB(COMB,TMG1SET,PRESULT) ; - ;"Purpose: combine TMG1SET with @PRESULT based on logical operation COMBiner - ;"Input: COMB= &, !, &' - ;" TMG1SET -- PASS BY REFERENCE. - ;" PRESULT -- PASS BY NAME. - IF COMB="!" MERGE @PRESULT=TMG1SET - ELSE IF COMB="&" DO - . NEW TEMPSET - . NEW I SET I=0 - . FOR SET I=$ORDER(TMG1SET(I)) QUIT:(+I'>0) DO - . . IF $DATA(@PRESULT@(I))=0 QUIT - . . SET TEMPSET(I)="" - . . MERGE TEMPSET("DETAILS",I)=TMG1SET("DETAILS",I) - . . MERGE TEMPSET("DETAILS",I)=@PRESULT@("DETAILS",I) - . KILL @PRESULT MERGE @PRESULT=TEMPSET - ELSE IF COMB="&'" DO - . NEW I SET I=0 - . FOR SET I=$ORDER(TMG1SET(I)) QUIT:(+I'>0) DO - . . KILL @PRESULT@(I) ;"Remove any entry in TMG1SET from @PRESULT@ - . KILL @PRESULT MERGE @PRESULT=TEMPSET - QUIT - Index: cprs/branches/tmg-cprs/m_files/TMGSRCH1.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSRCH1.m~ (revision 796) +++ (revision ) @@ -1,337 +1,0 @@ -TMGSRCH1 ;TMG/kst/Search API ; 5/26/10 - ;;1.0;TMG-LIB;**1**;05/19/10 - ; - ;"TMG FILEMAN SEARCH API - ; - ;"Copyright Kevin Toppenberg MD 5/19/10 - ;"Released under GNU General Public License (GPL) - ;" - ;"NOTE: this function depends on new version of LIST^DIC, from G. Timpson Patch - ;"======================================================================= - ;" RPC -- Public Functions. - ;"======================================================================= - ;"FNPTR(FNUMPTR) -- Resolve a FNUMPTR, finding ultimate target file - ;"PATHTO(FROMFILE,TOFILE,COUNT) -- Find a 'path' of fields that gets from file A -->B - ;"FLDNUM(TMGFILE,TMGNAME) --Turn a field name into number, and change FILE to pointed-to-file - ;"======================================================================= - ;"PRIVATE API FUNCTIONS - ;"======================================================================= - ;"GETFLD(STR) -- Separate field name from comparator - ;"FIXCOMP(COMP,ERR) --Standardize value comparators, e.g. <> becomes '= - ;"FIXCOMB(COMB,ERR) --Standardize expression combiners, e.g. | becomes OR - ;"STDDATE(TMGDATE,ERR) --Standardized date, or report error - ;"======================================================================= - ;"======================================================================= - ;"Dependencies: - ;" DIC, TMGDEBUG - ;"======================================================================= - ;"======================================================================= - ; - ; -FNPTR(FNUMPTR) ; - ;"Puprose: To resolve a FNUMPTR, finding ultimate target file - ;"Input: FNUMPTR: Format: FNUM:FLDA[:FLDB[:FLDC...]] FNUM is filenumber that - ;" contain search field, and then fields used to point to *TARGET* FILENUM - ;"Results: -1^Error message if error, otherwise returns pointed to file - NEW RESULT,FILE,FLD,I,DONE - SET FILE=+$GET(FNUMPTR) - SET RESULT=0 - SET DONE=0 - FOR I=2:1:999 DO QUIT:(+RESULT=-1)!(DONE=1) - . SET FLD=$PIECE(FNUMPTR,":",I) - . IF FLD="" SET DONE=1 QUIT - . IF $DATA(^DD(FILE,FLD,0))=0 DO QUIT - . . SET RESULT="-1^Field ["_FLD_"] was not found in file ["_FILE_"]" - . NEW FLDTYPE SET FLDTYPE=$PIECE(^DD(+FILE,+FLD,0),"^",2) - . IF FLDTYPE'["P" DO QUIT - . . SET RESULT="-1^Field ["_FLD_"] does not point to another file." - . SET FILE=+$PIECE(FLDTYPE,"P",2) - SET RESULT=FILE - QUIT RESULT - ; -PATHTO(FROMFILE,TOFILE,COUNT) ; - ;"Purpose: to find a "path" of fields that gets from file A -->B (if possible) - ;" E.g. From TIU DOCUMENT to PATIENT would yield ".01:.01", meaning - ;" that the .01 field of TIU DOCUMENT-->IHS PATIENT, and - ;" .01 field of IHS PATIEN-->PATIENT - ;"Input: FROMFILE -- The starting file number - ;" TOFILE -- The target file number - ;" COUNT -- used when calling self reiteratively. Leave blank on first call. - ;"Note: This fill only allow the length of the path to be 3 links long. - ;" Also, the search is stopped after the first link is found. - ;" NOTE: If the file link is changed to be longer than 3, then - ;" GETAFSUB() must also be changed - ;"Results: Returns field link, e.g. ".01;2;.01" - SET COUNT=+$GET(COUNT) - NEW RESULT SET RESULT="" - SET FROMFILE=+$GET(FROMFILE) - NEW FLD SET FLD=0 - FOR SET FLD=$ORDER(^DD(FROMFILE,FLD)) QUIT:(+FLD'>0)!(RESULT'="") DO - . NEW INFO SET INFO=$PIECE($GET(^DD(FROMFILE,FLD,0)),"^",2) - . IF INFO'["P" QUIT - . NEW PT SET PT=+$PIECE(INFO,"P",2) - . IF PT=FROMFILE QUIT ;"ignore pointers to self - . IF PT=TOFILE SET RESULT=FROMFILE_":"_FLD_"->"_TOFILE QUIT - . IF COUNT>2 QUIT - . NEW TEMP SET TEMP=$$PATHTO(PT,TOFILE,COUNT+1) - . IF TEMP'="" SET RESULT=FROMFILE_":"_FLD_"->"_TEMP - IF COUNT=0 DO - . NEW TEMP,I - . SET TEMP="" - . FOR I=1:1:$LENGTH(RESULT,"->") DO - . . NEW PART SET PART=$PIECE(RESULT,"->",I) - . . NEW PART2 SET PART2=$PIECE(PART,":",2) - . . IF PART2="" QUIT - . . IF TEMP'="" SET TEMP=TEMP_":" - . . SET TEMP=TEMP_PART2 - . SET RESULT=FROMFILE_":"_TEMP_"^"_RESULT - QUIT RESULT - ; - ; -GETFLD(STR) ; - ;"Purpose: To separate field name from comparator - ;"Input: STR -- PASS BY REFERENCE -- the string to pull field from - ;"Results: returns extracted field. - NEW FLD - IF +STR>0 DO - . SET FLD=+STR - . SET STR=$PIECE(STR,FLD,2,999) - ELSE DO - . IF $EXTRACT(STR,1)="""" DO - . . SET FLD=$$MATCHXTR^TMGSTUTL(STR,"""",,,"""") - . . IF FLD'="" SET STR=$EXTRACT(STR,$LENGTH(FLD)+3,9999) - . ELSE DO - . . SET FLD="" - . . NEW P FOR P=1:1:$LENGTH(STR) QUIT:"'<>=[:{"[$EXTRACT(STR,P) DO - . . . SET FLD=FLD_$EXTRACT(STR,P) - . . IF FLD'="" SET STR=$EXTRACT(STR,$LENGTH(FLD)+1,9999) - QUIT FLD - ; -FLDNUM(TMGFILE,TMGNAME) ; - ;"Purpose: To turn a field name into number, and change FILE to pointed-to-file - ;"Input: TMGFILE -- PASS BY REFERENCE. Input is current file. Output is new pointed-to-file - ;" TMGNAME -- PASS BY REFERENCE. The field name to look up. Name will be cleaned up. - NEW DIC,X,Y SET Y=0 - IF TMGNAME="" SET TMGFILE=0 GOTO FLDNDN - SET DIC="^DD("_+TMGFILE_"," - SET TMGNAME=$$TRIM^XLFSTR(TMGNAME,," ") - SET TMGNAME=$$TRIM^XLFSTR(TMGNAME,,"""") - SET X=TMGNAME - DO ^DIC - IF +Y'>0 GOTO FLDNDN - NEW INFO SET INFO=$PIECE($GET(^DD(+TMGFILE,+Y,0)),"^",2) - IF INFO'["P" SET TMGFILE=0 GOTO FLDNDN - SET TMGFILE=+$PIECE(INFO,"P",2) -FLDNDN QUIT +Y - ; -FIXCOMP(COMP,ERR) ; - ;"Purpose: to standardize value comparators, e.g. <> becomes '= - NEW RESULT SET RESULT="" - IF COMP="=" SET RESULT=COMP GOTO FCDN - NEW COMPSAV SET COMPSAV=COMP - SET COMP=$$UP^XLFSTR(COMP) - IF (COMP="<>") SET COMP="'=" - ELSE IF (COMP=">=") SET COMP="'<" - ELSE IF (COMP="<=") SET COMP="'>" - ELSE IF (COMP="{") SET COMP="IN" - NEW NOT - SET NOT=$EXTRACT(COMP,1) IF NOT="'" SET COMP=$EXTRACT(COMP,2,999) - ELSE SET NOT="" - IF (COMP="=")!(COMP="[")!(COMP="IN")!(COMP="<")!(COMP=">") DO - . SET RESULT=NOT_COMP - ELSE SET ERR="-1^'"_COMPSAV_"' is not a valid comparator." -FCDN QUIT RESULT - ; -FIXCOMB(COMB,ERR) ; - ;"Purpose: to standardize expression combiners, e.g. | becomes OR - NEW COMBSAV SET COMBSAV=COMB - IF (COMB="|")!(COMB="||")!(COMB="!") SET COMB="OR" - ELSE IF (COMB="&")!(COMB="&&") SET COMB="AND" - ELSE IF (COMB="'")!(COMB="ANDNOT") SET COMB="NOT" - IF (COMB'="AND")&(COMB'="OR")&(COMB'="NOT") SET COMB="" - IF COMB="" SET ERR="-1^'"_COMBSAV_"' is not a valid set combiner." - QUIT COMB - ; -STDDATE(TMGDATE,ERR) ; - ;"Purpose: return a standardized date, or report error - NEW X,Y,%DT - NEW RESULT SET RESULT="" - SET %DT="T" - SET X=TMGDATE - DO ^%DT - IF Y=-1 SET ERR="-1^Invalid date: ["_X_"]" - ELSE SET RESULT=$$FMTE^XLFDT(Y,5) - QUIT RESULT - ; -GETAFSUB(TMGOUT,TMGPARAMS) ;"GET ALLOW FILES SUBSET - ;"Purpose: For a given file to be searched, return sublist of allowed - ;" related files which can be used as search terms. NOTE: only - ;" files that point back to the original search file are allowed. - ;" NOTE: This function will return not only files that point - ;" directly back to search file, but also files that point to - ;" other files that point to search file. In fact, there can - ;" be a distance of 3 files between returned file and search file. - ;" If this allowed distance of 3 files is changed, then PATHTO() - ;" must also be changed. - ;" NOTE: Subfiles not currently supported - ;"Input: TMGPARAMS -- FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple - ;" FileNum -- this is the search file, results must point back to this - ;" ListStartValue -- OPTIONAL -- text to $ORDER() from - ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL - ;" MaxCount -- OPTIONAL. Default is 44 values returned. - ;" Simple -- OPTIONAL Default is 0 (false). If 1, then - ;" a very limited list of files returned, with - ;" more user-friendly pseudo names - ;"Output: TMGRESULTS is filled as follows. - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=IEN^FileName - ;" TMGRESULT(2)=IEN^FileName - ;"NOTE: Any files that don't have data are excluded. - NEW TMGFILE SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) - IF TMGFILE'>0 DO GOTO GAFSDN - . SET TMGOUT(0)="-1^No file number supplied" - NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) - NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) - IF TMGDIR'=-1 SET TMGDIR=1 - NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) - IF TMGMAXCT=0 SET TMGMAXCT=44 - NEW TMGSIMPLE SET TMGSIMPLE=+$PIECE(TMGPARAMS,"^",5) - ; - IF (TMGFILE=2),(TMGSIMPLE=1) DO GOTO GAFS0 - . SET TMGOUT(1)="2^1. PATIENT INFO" - . SET TMGOUT(2)="8925^2. NOTES" - . SET TMGOUT(3)="120.5^3. VITALS" - . SET TMGOUT(4)="9000010^4. VISIT" - . SET TMGOUT(5)="9000010.18^5. LINKED CPT CODE" - ; - NEW TMGREF SET TMGREF=$NAME(^TMP("TMG","TMGSRCH",$J,"ALLOWED FILES",TMGFILE)) - IF $DATA(@TMGREF)=0 DO - . DO SETUPLS(TMGREF,TMGFILE) - NEW TMGSTARTIEN SET TMGSTARTIEN="" - NEW TMGI SET TMGI=0 - FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI'0) DO - . SET NAME=$PIECE($GET(^DIC(AFILE,0)),"^",1) QUIT:NAME="" - . SET GL=$GET(^DIC(AFILE,0,"GL")) QUIT:(GL="") - . SET GL=GL_"0)" NEW INFO SET INFO=$GET(@GL) - . NEW NUMRECS SET NUMRECS=+$PIECE(INFO,"^",4) QUIT:NUMRECS'>0 - . SET @POUT@("B",NAME,AFILE)="" - . IF CT<3 DO SETUPLS(POUT,AFILE,CT+1) - QUIT - ; -GETFLDSB(TMGOUT,TMGPARAMS) ; - ;"Purpose: Get FIELD list subset, for file - ;"Input: TMGPARAMS -- FileNum^ListStartValue^direction^MaxCount(optional, def=44)^Simple - ;" FileNum -- this is the file to get fields in - ;" ListStartValue -- OPTIONAL -- text to $ORDER() from - ;" Direction -- $ORDER(xx,Direction) direction (should be 1 or -1) -- OPTIONAL - ;" MaxCount -- OPTIONAL. Default is 44 values returned. - ;" Simple -- OPTIONAL Default is 0 (false). If 1, then - ;" a very limited list of files returned, with - ;" more user-friendly pseudo names - ;"Output: TMGRESULTS is filled as follows. - ;" TMGRESULT(0)="1^Success" or "-1^Message" - ;" TMGRESULT(1)=FldNum^Name^InfoNodes2-4 - ;" TMGRESULT(2)=FldNum^Name^InfoNodes2-4 - ;"NOTE: Any files that don't have data are excluded. Subfiles also excluded - NEW TMGFILE SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) - IF TMGFILE'>0 DO GOTO GFSBDN - . SET TMGOUT(0)="-1^No file number supplied" - NEW TMGFROM SET TMGFROM=$PIECE(TMGPARAMS,"^",2) - NEW TMGDIR SET TMGDIR=$PIECE(TMGPARAMS,"^",3) - IF TMGDIR'=-1 SET TMGDIR=1 - NEW TMGMAXCT SET TMGMAXCT=+$PIECE(TMGPARAMS,"^",4) - IF TMGMAXCT=0 SET TMGMAXCT=44 - NEW TMGSIMPLE SET TMGSIMPLE=+$PIECE(TMGPARAMS,"^",5) - ; - NEW TMGI SET TMGI=0 - NEW HANDLED SET HANDLED=0 - IF TMGSIMPLE DO - . IF TMGFILE=2 DO ;"2^PATIENT INFO" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^NAME" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".02^SEX" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^DATE OF BIRTH" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".033^AGE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^MARITAL STATUS" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^OCCUPATION" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".09^SOCIAL SECURITY NUMBER" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".114^CITY" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".115^STATE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".116^ZIP CODE" - . . SET HANDLED=1 - . IF TMGFILE=8925 DO ;"8925^NOTES" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^TYPE OF NOTE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^STATUS" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^BEGINNING DATE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".08^ENDING DATE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="2^NOTE TEXT" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1201^CREATION DATE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1202^AUTHOR/DICTATOR" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1204^EXPECTED SIGNER" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1211^VISIT LOCATION" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1502^SIGNED BY" - . . SET HANDLED=1 - . IF TMGFILE=120.5 DO ;"120.5^VITALS" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^DATE/TIME TAKEN" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^VITAL TYPE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^LOCATION" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1.2^VALUE" - . . SET HANDLED=1 - . IF TMGFILE=9000010 DO ;"9000010^VISIT" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^DATE/TIME" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".03^TYPE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".22^LOCATION" - . . SET HANDLED=1 - . IF TMGFILE=9000010.18 DO ;"9000010.18^LINKED CPT CODE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".01^CPT NAME" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".04^PROVIDER NARRATIVE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".05^DIAGNOSIS" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)=".07^PRINCIPLE PROCEDURE" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="1204^ENCOUNTER PROVIDER" - . . SET TMGI=TMGI+1 SET TMGOUT(TMGI)="80201^CATEGORY" - . . SET HANDLED=1 - IF HANDLED DO ADDINFO(TMGFILE,.TMGOUT) GOTO GFSB0 - ; - NEW TMGREF SET TMGREF=$NAME(^DD(TMGFILE)) - FOR SET TMGFROM=$ORDER(@TMGREF@("B",TMGFROM),TMGDIR) QUIT:(TMGFROM="")!(TMGI'0)!(TMGI'0,($$ISWPFLD^TMGDBAPI(TMGFILE,TMGFLD)=0) QUIT ;"Don't return subfile fields (for now) - . . SET TMGI=TMGI+1 - . . SET TMGOUT(TMGI)=TMGFLD_"^"_TMGFROM_"^"_INFO - ; -GFSB0 SET TMGOUT(0)="1^Success" -GFSBDN QUIT - ; -ADDINFO(TMGFILE,TMGOUT); - ;"Purpose: To add INFO to field entries, as created in GETFLDSB - NEW I SET I=0 - FOR SET I=$ORDER(TMGOUT(I)) QUIT:(+I'>0) DO - . NEW ENTRY SET ENTRY=$GET(TMGOUT(I)) QUIT:(ENTRY="") - . NEW TMGFLD SET TMGFLD=+ENTRY - . NEW INFO SET INFO=$PIECE($GET(^DD(TMGFILE,TMGFLD,0)),"^",2,4) - . SET TMGOUT(I)=ENTRY_"^"_INFO - QUIT Index: cprs/branches/tmg-cprs/m_files/TMGSTUTL.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSTUTL.m.bak (revision 796) +++ (revision ) @@ -1,1518 +1,0 @@ -TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06 - ;;1.0;TMG-LIB;**1**;09/01/05 - - ;"TMG STRING UTILITIES - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"CleaveToArray^TMGSTUTL(Text,Divider,Array) - ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 - ;"CleaveStr^TMGSTUTL(Text,Divider,PartB) - ;"SplitStr^TMGSTUTL(Text,Width,PartB) - ;"SetStrLen^TMGSTUTL(Text,Width) - ;"$$NestSplit^TMGSTUTL(Text,OpenBracket,CloseBracket,SBefore,S,SAfter) - ;"$$Substitute^TMGSTUTL(S,Match,NewValue) - ;"$$FormatArray^TMGSTUTL(InArray,OutArray,Divider) - ;"$$Trim^TMGSTUTL(S,TrimCh) ; --> or use $$TRIM^XLFSTR - ;"$$TrimL^TMGSTUTL(S,TrimCh) - ;"$$TrimR^TMGSTUTL(S,TrimCh) - ;"$$TrimRType^TMGSTUTL(S,type) - ;"$$NumLWS^TMGSTUTL(S) - ;"$$MakeWS^TMGSTUTL(n) - ;"WordWrapArray^TMGSTUTL(.Array,Width,SpecialIndent) - ;"SplitLine^TMGSTUTL(s,.LineArray,Width) - ;"WriteWP^TMGSTUTL(NodeRef) - ;"$$LPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$RPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$Center^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$Clip^TMGSTUTL(S,width) - ;"$$STRB2H^TMGSTUTL(s,F) Convert a string to hex characters - ;"$$CapWords^TMGSTUTL(S,Divider) ;"capitalize the first character of each word in a string - ;"$$LinuxStr^TMGSTUTL(S) ;"Convert string to a valid linux filename - ;"StrToWP^TMGSTUTL(s,pArray,width,DivCh,InitLine) ;"wrap long string into a WP array - ;"$$WPToStr^TMGSTUTL(pArray,DivCh,MaxLen,InitLine) - ;"Comp2Strs(s1,s2) -- compare two strings and assign an arbritrary score to their similarity - ;"$$PosNum(s,[Num],LeadingSpace) -- return position of a number in a string - ;"IsNumeric(s) -- deterimine if word s is a numeric - ;"ScrubNumeric(s) -- remove numeric words from a sentence - ;"Pos(subStr,s,count) -- return the beginning position of subStr in s - ;"DiffPos(s1,s2) -- Return the position of the first difference between s1 and s2 - ;"DiffWords(Words1,Words2) -- Return index of first different word between Words arrays - ;"SimStr(s1,p1,s2,p2) -- return matching string in s1 and s2, starting at position p1,p2 - ;"SimWord(Words1,p1,Words2,p2) -- return the matching words in both words array 1 and 2, starting - ;" at word positions p1 and p2. - ;"SimPos(s1,s2) -- return the first position that two strings are similar. - ;"SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) -- return the first position that two word arrays - ;" are similar. This means the first index in Words array 1 that matches to words in Words array 2. - ;"DiffStr(s1,s2,DivChr) -- Return how s1 differs from s2. - ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 - ;"$$QtProtect(s) -- Protects quotes by converting all quotes do double quotes (" --> "") - ;"$$InQt(s,Pos) -- return if a character at position P is inside quotes in s - ;"$$GetWord(s,Pos,OpenDiv,CloseDiv) -- extract a word from a sentance, bounded by OpenDiv,CloseDiv - ;"$$CmdChStrip(s) -- Strips all characters < #32 from string. - ;"$$StrBounds(s,p) -- return position of end of string - ;"NonWhite(s,p) -- return index of first non-whitespace character - ;"Pad2Pos(Pos,ch) -- return a padding string from current $X up to Pos, using ch - - ;"======================================================================= - ;"Dependancies - ;" uses TMGDEBUG for debug messaging. - ;"======================================================================= - ;"======================================================================= - - ;"------------------------------------------------------------------------ - ;"FYI, String functions in XLFSTR module: - ;"------------------------------------------------------------------------ - ;"$$CJ^XLFSTR(s,i[,p]) -- Returns a center-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$LJ^XLFSTR(s,i[,p]) -- Returns a left-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$RJ^XLFSTR(s,i[,p]) -- Returns a right-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$INVERT^XLFSTR(s) -- returns an inverted string (i.e. "ABC"-->"CBA") - ;"$$LOW^XLFSTR(s) -- returns string with all letters converted to lower-case - ;"$$UP^XLFSTR(s) -- returns string with all letters converted to upper-case - ;"$$TRIM^XLFSTR(s,[LRFlags],[char]) - ;"$$REPEAT^XLFSTR(s,Count) -- returns a string that is a repeat of s Count times - ;"$$REPLACE^XLFSTR(s,.spec) -- Uses a multi-character $TRanslate to return a - ;" string with the specified string replaced - ;" s=input string, spec=array passed by reference - ;" spec format: - ;" spec("Any_Search_String")="Replacement_String" - ;"$$STRIP^XLFSTR(s,Char) -- returns string striped of all instances of Char - - ;"======================================================================= - -CleaveToArray(Text,Divider,Array,InitIndex) - ;"Purpose: To take a string, delineated by 'divider' and - ;" to split it up into all its parts, putting each part - ;" into an array. e.g.: - ;" This/Is/A/Test, with '/' divider would result in - ;" Array(1)="This" - ;" Array(2)="Is" - ;" Array(3)="A" - ;" Array(4)="Test" - ;" Array(cMaxNode)=4 ;cMaxNode="MAXNODE" - ;"Input: Text - the input string -- should NOT be passed by reference. - ;" Divider - the delineating string - ;" Array - The array to receive output **SHOULD BE PASSED BY REFERENCE. - ;" InitIndex - OPTIONAL -- The index of the array to start with, i.e. 0 or 1. Default=1 - ;"Output: Array is changed, as outlined above - ;"Result: none - ;"Notes: Note -- Text is NOT changed (unless passed by reference, in - ;" which case the next to the last piece is put into Text) - ;" Array is killed, the filled with data **ONLY** IF DIVISIONS FOUND - ;" Limit of 256 nodes - ;" if cMaxNode is not defined, "MAXNODE" will be used - - set DBIndent=$get(DBIndent,0) - do DebugEntry^TMGDEBUG(.DBIndent,"CleaveToArray") - - set InitIndex=$get(InitIndex,1) - new PartB - new count set count=InitIndex - set cMaxNode=$get(cMaxNode,"MAXNODE") - - kill Array ;"Clear out any old data - -C2ArLoop - if '(Text[Divider) do goto C2ArDone - . set Array(count)=Text ;"put it all into first line. - . set Array(cMaxNode)=1 - do CleaveStr(.Text,Divider,.PartB) - set Array(count)=Text - set Array(cMaxNode)=count - set count=count+1 - if '(PartB[Divider) do goto C2ArDone - . set Array(count)=PartB - . set Array(cMaxNode)=count - else do goto C2ArLoop - . set Text=$get(PartB) - . set PartB="" - -C2ArDone - do DebugExit^TMGDEBUG(.DBIndent,"CleaveToArray") - quit - - -CleaveStr(Text,Divider,PartB) - ;"Purpse: To take a string, delineated by 'Divider' - ;" and to split it into two parts: Text and PartB - ;" e.g. Text="Hello\nThere" - ;" Divider="\n" - ;" Function will result in: Text="Hello", PartB="There" - ;"Input: Text - the input string **SHOULD BE PASSED BY REFERENCE. - ;" Divider - the delineating string - ;" PartB - the string to get second part **SHOULD BE PASSED BY REFERENCE. - ;"Output: Text and PartB will be changed - ;" Function will result in: Text="Hello", PartB="There" - ;"Result: none - - set DBIndent=$get(DBIndent,0) - do DebugEntry^TMGDEBUG(.DBIndent,"CleaveStr") - - do DebugMsg^TMGDEBUG(DBIndent,"Text=",Text) - - if '$data(Text) goto CSDone - if '$Data(Divider) goto CSDone - set PartB="" - - new PartA - - if Text[Divider do - . set PartA=$piece(Text,Divider,1) - . set PartB=$piece(Text,Divider,2,256) - . set Text=PartA - - do DebugMsg^TMGDEBUG(DBIndent,"After Processing, Text='",Text,"', and PartB='",PartB,"'") -CSDone - do DebugExit^TMGDEBUG(.DBIndent,"CleaveStr") - quit - - -SplitStr(Text,Width,PartB) - ;"PUBLIC FUNCTION - ;"Purpose: To a string into two parts. The first part will fit within 'Width' - ;" the second part is what is left over - ;" The split will be inteligent, so words are not divided (splits at a space) - ;"Input: Text = input text. **Should be passed by reference - ;" Width = the constraining width - ;" PartB = the left over part. **Should be passed by reference - ;"output: Text and PartB are modified - ;"result: none. - - new Len - set Width=$get(Width,80) - new SpaceFound set SpaceFound=0 - new SplitPoint set SplitPoint=Width - set Text=$get(Text) - set PartB="" - - set Len=$length(Text) - if Len>Width do - . new Ch - . for SplitPoint=SplitPoint:-1:1 do quit:SpaceFound - . . set Ch=$extract(Text,SplitPoint,SplitPoint) - . . set SpaceFound=(Ch=" ") - . if 'SpaceFound set SplitPoint=Width - . set s1=$extract(Text,1,SplitPoint) - . set PartB=$extract(Text,SplitPoint+1,1024) ;"max String length=1024 - . set Text=s1 - else do - - quit - - - -SetStrLen(Text,Width) - ;"PUBLIC FUNCTION - ;"Purpose: To make string exactly Width in length - ;" Shorten as needed, or pad with terminal spaces as needed. - ;"Input: Text -- should be passed as reference. This is string to alter. - ;" Width -- the desired width - ;"Results: none. - - set Text=$get(Text) - set Width=$get(Width,80) - new result set result=Text - new i,Len - - set Len=$length(result) - if Len>Width do - . set result=$extract(result,1,Width) - else if Len "ABC$$$DEF" - ;" Substitute("ABC###DEF","###","$") --> "ABC$DEF" - ;"Result: returns altered string (if any alterations indicated) - ;"Output: S is altered, if passed by reference. - - new spec - set spec($get(Match))=$get(NewValue) - set S=$$REPLACE^XLFSTR(S,.spec) - - quit S - - -FormatArray(InArray,OutArray,Divider) - ;"PUBLIC FUNCTION - ;"Purpose: The XML parser does not recognize whitespace, or end-of-line - ;" characters. Thus many lines get lumped together. However, if there - ;" is a significant amount of text, then the parser will put the text into - ;" several lines (when get attrib text called etc.) - ;" SO, this function is to take an array composed of input lines (each - ;" with multiple sublines clumped together), and format it such that each - ;" line is separated in the array. - ;" e.g. Take this input array" - ;" InArray(cText,1)="line one\nline two\nline three\n - ;" InArray(cText,2)="line four\nline five\nline six\n - ;" and convert to: - ;" OutArray(1)="line one" - ;" OutArray(2)="line two" - ;" OutArray(3)="line three" - ;" OutArray(4)="line four" - ;" OutArray(5)="line five" - ;" OutArray(6)="line six" - ;"Input: InArray, best if passed by reference (faster) -- see example above - ;" Note: expected to be in format: InArray(cText,n) - ;" OutArray, must be passed by reference-- see example above - ;" Divider: the character(s) that divides lines ("\n" in this example) - ;"Note: It is expected that InArray will be index by integers (i.e. 1, 2, 3) - ;" And this should be the case, as that is how XML functions pass back. - ;" Limit of 256 separate lines on any one InArray line - ;"Output: OutArray is set, any prior data is killed - ;"result: 1=OK to continue, 0=abort - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatArray") - - new result set result=cOKToCont - new InIndex - new OutIndex set OutIndex=1 - new TempArray - new Done - - kill OutArray ;"remove any prior data - - if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Input array:") - if DEBUG do ArrayDump^TMGDEBUG("InArray") - - if $data(Divider)=0 do goto FADone - . set result=cAbort - - set Done=0 - for InIndex=1:1 do quit:Done - . if $data(InArray(cText,InIndex))=0 set Done=1 quit - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Converting line: ",InArray(cText,InIndex)) - . do CleaveToArray^TMGSTUTL(InArray(cText,InIndex),Divider,.TempArray,OutIndex) - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Resulting temp array:") - . if DEBUG do ArrayDump^TMGDEBUG("TempArray") - . set OutIndex=TempArray(cMaxNode)+1 - . kill TempArray(cMaxNode) - . merge OutArray=TempArray - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"OutArray so far:") - . if DEBUG do ArrayDump^TMGDEBUG("OutArray") - -FADone - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatArray") - quit result - - - -TrimL(S,TrimCh) - ;"Purpose: To a trip a string of leading white space - ;" i.e. convert " hello" into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - new result set result=$get(S) - new Ch set Ch="" - for do quit:(Ch'=TrimCh) - . set Ch=$extract(result,1,1) - . if Ch=TrimCh set result=$extract(result,2,1024) - - quit result - - -TrimR(S,TrimCh) - ;"Purpose: To a trip a string of trailing white space - ;" i.e. convert "hello " into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"TrimR") - - new result set result=$get(S) - new Ch set Ch="" - new L - - for do quit:(Ch'=TrimCh) - . set L=$length(result) - . set Ch=$extract(result,L,L) - . if Ch=TrimCh do - . . set result=$extract(result,1,L-1) - - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"TrimR") - quit result - -Trim(S,TrimCh) - ;"Purpose: To a trip a string of leading and trailing white space - ;" i.e. convert " hello " into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - ;"NOTE: this function could be replaced with $$TRIM^XLFSTR - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"Trim") - - new result set result=$get(S) - set result=$$TrimL(.result,TrimCh) - set result=$$TrimR(.result,TrimCh) - - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"Trim") - quit result - -TrimRType(S,type) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: trim characters on the right of the string of a specified type. - ;" Goal, to be able to distinguish between numbers and strings. - ;" i.e. "1234<=" --> "1234" by trimming strings - ;"Input: S -- The string to work on - ;" type -- the type of characters to TRIM: N for numbers,C for non-numbers (characters) - ;"Results : modified string - - set tempS=$get(S) - set type=$$UP^XLFSTR($get(type)) goto:(type="") TRTDone - new done set done=0 - for quit:(tempS="")!done do - . new c set c=$extract(tempS,$length(tempS)) - . new cType set cType="C" - . if +c=c set cType="N" - . if type["N" do - . . if cType="N" set tempS=$extract(tempS,1,$length(tempS)-1) quit - . . set done=1 - . else if type["C" do - . . if cType="C" set tempS=$extract(tempS,1,$length(tempS)-1) quit - . . set done=1 - . else set done=1 - -TRTDone quit tempS - -NumLWS(S) - ;"Scope: PUBLIC FUNCTION - ;":Purpose: To count the number of white space characters on the left - ;" side of the string - - new result set result=0 - new i,ch - set S=$get(S) - - for i=1:1:$length(S) do quit:(ch'=" ") - . set ch=$extract(S,i,i) - . if ch=" " set result=result+1 - - quit result - - -MakeWS(n) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: Return a whitespace string that is n characters long - - new result set result="" - set n=$get(n,0) - if n'>0 goto MWSDone - - new i - for i=1:1:n set result=result_" " - -MWSDone - quit result - - -WordWrapArray(Array,Width,SpecialIndent) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: To take an array and perform word wrapping such that - ;" no line is longer than Width. - ;" This function is really designed for reformatting a Fileman WP field - ;"Input: Array MUST BE PASSED BY REFERENCE. This contains the array - ;" to be reformatted. Changes will be made to this array. - ;" It is expected that Array will be in this format: - ;" Array(1)="Some text on the first line." - ;" Array(2)="Some text on the second line." - ;" Array(3)="Some text on the third line." - ;" Array(4)="Some text on the fourth line." - ;" or - ;" Array(1,0)="Some text on the first line." - ;" Array(2,0)="Some text on the second line." - ;" Array(3,0)="Some text on the third line." - ;" Array(4,0)="Some text on the fourth line." - ;" Width -- the limit on the length of any line. Default value=70 - ;" SpecialIndent : if 1, then wrapping is done like this: - ;" " This is a very long line......" - ;" will be wrapped like this: - ;" " This is a very - ;" " long line ... - ;" Notice that the leading space is copied subsequent line. - ;" Also, a line like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" will be wrapped like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" Notice that a pattern '#. ' causes the wrapping to match the start of - ;" of the text on the line above. - ;" The exact rules for matching this are as follows: - ;" (FirstWord?.N1".")!(FirstWord?1.3E1".") - ;" i.e. any number of digits, followed by "." - ;" OR 1-4 all upper-case characters followed by a "." - ;" This will allow "VIII. " pattern but not "viii. " - ;" HOWEVER, might get confused with a word, like "NOTE. " - ;" - ;" This, below, is not dependant on SpecialIndent setting - ;" Also, because some of the lines have already partly wrapped, like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" "and this is a line that has already wrapped. - ;" So when the first line is wrapped, it would look like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" "and this is a line that has already wrapped. - ;" But is should look like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long...and this is a line - ;" " that has already wrapped. - ;" But the next line SHOULD NOT be pulled up if it is the start - ;" of a new paragraph. I will tell by looking for #. paattern. - - - ;"Result -- none - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WordWrapArray^TMGSTUTL") - new tempArray set tempArray="" ;"holds result during work. - new tindex set tindex=0 - new index - set index=$order(Array("")) - new s - new residualS set residualS="" - new AddZero set AddZero=0 - set Width=$get(Width,70) - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop") - - if index'="" for do quit:((index="")&(residualS="")) - . set s=$get(Array(index)) - . if s="" do - . . set s=$get(Array(index,0)) - . . set AddZero=1 - . if residualS'="" do ;"See if should join to next line. Don't if '#. ' pattern - . . new FirstWord set FirstWord=$piece($$Trim(s)," ",1) - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"First Word: ",FirstWord) - . . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern - . . . ;"Here we have the next line is a new paragraph, so don't link to residualS - . . . set tindex=tindex+1 - . . . if AddZero=0 set tempArray(tindex)=residualS - . . . else set tempArray(tindex,0)=residualS - . . . set residualS="" - . if $length(residualS)+$length(s)'<256 do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ERROR -- string too long.") - . set s=residualS_s - . set residualS="" - . if $length(s)>Width do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Long line: ",s) - . . new LineArray - . . new NumLines - . . set NumLines=$$SplitLine(.s,.LineArray,Width,.SpecialIndent) - . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("LineArray") - . . set s="" - . . new LineIndex - . . for LineIndex=1:1:NumLines do - . . . set tindex=tindex+1 - . . . if AddZero=0 set tempArray(tindex)=LineArray(LineIndex) - . . . else set tempArray(tindex,0)=LineArray(LineIndex) - . . ;"long wrap probably continues into next paragraph, so link together. - . . if NumLines>2 do - . . . if AddZero=0 set residualS=tempArray(tindex) set tempArray(tindex)="" - . . . else set residualS=tempArray(tindex,0) set tempArray(tindex,0)="" - . . . set tindex=tindex-1 - . else do - . . set tindex=tindex+1 - . . if AddZero=0 set tempArray(tindex)=s - . . else set tempArray(tindex,0)=s - . set index=$order(Array(index)) - else do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Array appears empty") - - - kill Array - merge Array=tempArray - - if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent," WordWrapArray^TMGSTUTL") - quit - - -SplitLine(s,LineArray,Width,SpecialIndent,Indent) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: To take a long line, and wrap into an array, such that each - ;" line is not longer than Width. - ;" Line breaks will be made at spaces, unless there are no spaces in - ;" the entire line (in which case, the line will be divided at Width). - ;"Input: s= string with the long line. **If passed by reference**, then - ;" it WILL BE CHANGED to equal the last line of array. - ;" LineArray -- MUST BE PASSED BY REFERENCE. This OUT variable will - ;" receive the resulting array. - ;" Width = the desired wrap width. - ;" SpecialIndent [OPTIONAL]: if 1, then wrapping is done like this: - ;" " This is a very long line......" - ;" will be wrapped like this: - ;" " This is a very - ;" " long line ... - ;" Notice that the leading space is copied subsequent line. - ;" Also, a line like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" will be wrapped like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" Notice that a pattern '#. ' causes the wrapping to match the start - ;" of the text on the line above. - ;" Indent [OPTIONAL]: Any absolute amount that all lines should be indented by. - ;" This could be used if this long line is continuation of an - ;" indentation above it. - ;"Result: resulting number of lines (1 if no wrap needed). - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SplitLine") - - new result set result=0 - kill LineArray - if ($get(s)="")!($get(Width)'>0) goto SPDone - new index set index=0 - new p,tempS,splitPoint - - new PreSpace set PreSpace=$$NeededWS(s,.SpecialIndent,.Indent) - - if ($length(s)>Width) for do quit:($length(s)'>Width) - . for splitPoint=1:1:Width do quit:($length(tempS)>Width) - . . set tempS=$piece(s," ",1,splitPoint) - . . ;"write "tempS>",tempS,! - . if splitPoint>1 do - . . set tempS=$piece(s," ",1,splitPoint-1) - . . set s=$piece(s," ",splitPoint,Width) - . else do - . . ;"We must have a word > Width with no spaces--so just divide - . . set tempS=$extract(s,1,Width) - . . set s=$extract(s,Width+1,999) - . set index=index+1 - . set LineArray(index)=tempS - . set s=PreSpace_s - . ;"write "tempS>",tempS,! - . ;"write "s>",s,! - - set index=index+1 - set LineArray(index)=s - - set result=index - -SPDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SplitLine") - quit result - - - -NeededWS(S,SpecialIndent,Indent) - ;"Scope: PRIVATE - ;"Purpose: Evaluate the line, and create the white space string - ;" need for wrapped lines - ;"Input: s -- the string to eval. i.e. - ;" " John is very happy today ... .. .. .. .." - ;" or " 1. John is very happy today ... .. .. .. .." - ;" SpecialIndent -- See SplitLine() discussion - ;" Indent -- See SplitLine() discussion - - new result set result="" - if $get(S)="" goto NdWSDone - - new WSNum - set WSNum=+$get(Indent,0) - set WSNum=WSNum+$$NumLWS(S) - - if $get(SpecialIndent)=1 do - . new ts,FirstWord - . set ts=$$TrimL(.S) - . set FirstWord=$piece(ts," ",1) - . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern - . . set WSNum=WSNum+$length(FirstWord) - . . set ts=$piece(ts," ",2,9999) - . . set WSNum=WSNum+$$NumLWS(.ts)+1 - - set result=$$MakeWS(WSNum) - -NdWSDone - quit result - - -WriteWP(NodeRef) - ;"Purpose: Given a reference to a WP field, this function will print it out. - ;"INput: NodeRef -- the name of the node to print out. - ;" For example, "^PS(50.605,1,1)" - ;"Modification: 2/10/06 -- I removed need for @NodeRef@(0) to contain data. - - new i - ;"if $get(@NodeRef@(0))="" goto WWPDone - set i=$order(@NodeRef@(0)) - if i'="" for do quit:(i="") - . new OneLine - . set OneLine=$get(@NodeRef@(i)) - . if OneLine="" set OneLine=$get(@NodeRef@(i,0)) - . write OneLine,! - . set i=$order(@NodeRef@(i)) - -WWPDone quit - - -LPad(S,width) - ;"Purpose: To add space ("pad") string S such that final width is per specified with. - ;" space is added to left side of string - ;"Input: S : the string to pad. - ;" width : the desired final width - ;"result: returns resulting string - ;"Example: LPad("$5.23",7)=" $5.23" - - quit $$RJ^XLFSTR(.S,.width," ") - -RPad(S,width) - ;"Purpose: To add space ("pad") string S such that final width is per specified with. - ;" space is added to right side of string - ;"Input: S : the string to pad. - ;" width : the desired final width - ;"result: returns resulting string - ;"Example: RPad("$5.23",7)="$5.23 " - - quit $$LJ^XLFSTR(.S,.width," ") - -Center(S,width) - ;"Purpose: to return a center justified string - - quit $$CJ^XLFSTR(.S,.width," ") - -Clip(S,width) - ;"Purpose: to ensure that string S is no longer than width - - new result set result=$get(S) - if result'="" set result=$extract(S,1,width) -ClipDone - quit result - - -STRB2H(s,F,noSpace) - ;"Convert a string to hex characters) - ;"Input: s -- the input string (need not be ascii characters) - ;" F -- (optional) if F>0 then will append an ascii display of string. - ;" noSpace -- (Optional) if >0 then characters NOT separated by spaces - ;"result -- the converted string - - new i,ch - new result set result="" - - for i=1:1:$length(s) do - . set ch=$extract(s,i) - . set result=result_$$HEXCHR^TMGMISC($ascii(ch)) - . if +$get(noSpace)=0 set result=result_" " - - if $get(F)>0 set result=result_" "_$$HIDECTRLS^TMGSTUTL(s) - quit result - - -HIDECTRLS(s) - ;"hide all unprintable characters from a string - new i,ch,byte - new result set result="" - for i=1:1:$length(s) do - . set ch=$e(s,i) - . set byte=$ascii(ch) - . if (byte<32)!(byte>122) set result=result_"." - . else set result=result_ch - - quit result - - - -CapWords(S,Divider) - ;"Purpose: convert each word in the string: 'test string' --> 'Test String', 'TEST STRING' --> 'Test String' - - ;"Input: S -- the string to convert - ;" Divider -- [OPTIONAL] the character used to separate string (default is ' ' [space]) - ;"Result: returns the converted string - - new s2,part - new result set result="" - set Divider=$get(Divider," ") - - set s2=$$LOW^XLFSTR(S) - - for i=1:1 do quit:part="" - . set part=$piece(s2,Divider,i) - . if part="" quit - . set $extract(part,1)=$$UP^XLFSTR($extract(part,1)) - . if result'="" set result=result_Divider - . set result=result_part - - quit result - - -LinuxStr(S) - ;"Purpose: convert string to a valid linux filename - ;" e.g. 'File Name' --> 'File\ Name' - - quit $$Substitute(.S," ","\ ") - - - -NiceSplit(S,Len,s1,s2,s2Min,DivCh) - ;"Purpose: to split S into two strings, s1 & s2 - ;" Furthermore, s1's length must be <= length. - ;" and the split will be made at spaces - ;"Input: S -- the string to split - ;" Len -- the length limit of s1 - ;" s1 -- PASS BY REFERENCE, an OUT parameter - ;" receives first part of split - ;" s2 -- PASS BY REFERENCE, an OUT parameter - ;" receives the rest of string - ;" s2Min -- OPTIONAL -- the minimum that - ;" length of s2 can be. Note, if s2 - ;" is "", then this is not applied - ;" DivCH -- OPTIONAL, default is " ". - ;" This is the character to split words by - ;"Output: s1 and s2 is filled with data - ;"Result: none - - set (s1,s2)="" - if $get(DivCh)="" set DivCh=" " - - if $length(S)'>Len do goto NSpDone - . set s1=S - - new i - new done - for i=200:-1:1 do quit:(done) - . set s1=$piece(S,DivCh,1,i)_DivCh - . set s2=$piece(S,DivCh,i+1,999) - . set done=($length(s1)'>Len) - . if done,+$get(s2Min)>0 do - . . if s2="" quit - . . set done=($length(s2)'0) - . set OneLine=$get(@pArray@(i)) - . if OneLine="" set OneLine=$get(@pArray@(i,0)) - . if OneLine="" quit - . set Len=$length(result)+$length(DivCh) - . if Len+$length(OneLine)>MaxLen do - . . set OneLine=$extract(OneLine,1,(MaxLen-Len)) - . set result=result_OneLine_DivCh - . set Len=Len+$length(OneLine) - . set i=$order(@pArray@(i)) - - quit result; - - -Comp2Strs(s1,s2) - ;"Purpose: To compare two strings and assign an arbritrary score to their similarity - ;"Input: s1,s2 -- The two strings to compare - ;"Result: a score comparing the two strings - ;" 0.5 point for every word in s1 that is also in s2 (case specific) - ;" 0.25 point for every word in s1 that is also in s2 (not case specific) - ;" 0.5 point for every word in s2 that is also in s1 (case specific) - ;" 0.25 point for every word in s2 that is also in s1 (not case specific) - ;" 1 points if same number of words in string (compared each way) - ;" 2 points for each word that is in the same position in each string (case specific) - ;" 1.5 points for each word that is in the same position in each string (not case specific) - - new score set score=0 - new Us1 set Us1=$$UP^XLFSTR(s1) - new Us2 set Us2=$$UP^XLFSTR(s2) - - new i - for i=1:1:$length(s1," ") do - . if s2[$piece(s1," ",i) set score=score+0.5 - . else if Us2[$piece(Us1," ",i) set score=score+0.25 - . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 - . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 - - for i=1:1:$length(s2," ") do - . if s1[$piece(s2," ",i) set score=score+0.5 - . else if Us1[$piece(Us2," ",i) set score=score+0.25 - . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 - . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 - - if $length(s1," ")=$length(s2," ") set score=score+2 - - quit score - - -PosNum(s,Num,LeadingSpace) - ;"Purpose: To return the position of the first Number in a string - ;"Input: S -- string to check - ;" Num -- OPTIONAL, default is 0-9 numbers. number to look for. - ;" LeadingSpace -- OPTIONAL. If 1 then looks for " #" or " .#", not just "#" - ;"Results: -1 if not found, otherwise position of found digit. - - new result set result=-1 - new Leader set Leader="" - if $get(LeadingSpace)=1 set Leader=" " - - if $get(Num) do goto PNDone - . set result=$find(s,Leader_Num)-1 - - new temp,i,decimalFound - for i=0:1:9 do - . set decimalFound=0 - . set temp=$find(s,Leader_i) - . if (temp=0)&(Leader'="") do - . . set temp=$find(s,Leader_"."_i) - . . if temp>-1 set decimalFound=1 - . if temp>-1 set temp=temp-$length(Leader_i) - . if decimalFound set temp=temp-1 - . if (temp>0)&((temp0)&(Leader=" ") set result=result+1 - quit result - - -IsNumeric(s) - ;"Purpose: To deterimine if word s is a numeric - ;" Examples of numeric words: - ;" 10, N-100, 0.5%, 50000UNT/ML - ;" the test will be if the word contains any digit 0-9 - ;"Results: 1 if is a numeric word, 0 if not. - - quit ($$PosNum(.s)>0) - - -ScrubNumeric(s) - ;"Purpose: This is a specialty function designed to remove numeric words - ;" from a sentence. E.g. - ;" BELLADONNA ALK 0.3/PHENOBARB 16MG CHW TB --> BELLADONNA ALK /PHENOBARB CHW TB - ;" ESTROGENS,CONJUGATED 2MG/ML INJ (IN OIL) --> ESTROGENS,CONJUGATED INJ (IN OIL) - - new Array,i,result - set s=$$Substitute(s,"/MG","") - set s=$$Substitute(s,"/ML","") - set s=$$Substitute(s,"/"," / ") - set s=$$Substitute(s,"-"," - ") - do CleaveToArray(s," ",.Array) - new ToKill - set i=0 for set i=$order(Array(i)) quit:+i'>0 do - . if (Array(i)="MG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MCG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MEQ")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="%")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MM")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if $$IsNumeric(Array(i))=0 quit - . set ToKill(i)=1 - . new tempS set tempS=$get(Array(i-1)) - . if (tempS="/")!(tempS="-") set ToKill(i-1)=1 - . if (tempS="NO")!(tempS="#") set ToKill(i-1)=1 - - set i=0 for set i=$order(Array(i)) quit:+i'>0 do - . if $get(ToKill(i))=1 kill Array(i) - - set i="",result="" - for set i=$order(Array(i)) quit:+i'>0 do - . set result=result_Array(i)_" " - - set result=$$Trim(result) - set result=$$Substitute(result," / ","/") - set result=$$Substitute(result," - ","-") - - quit result - - -Pos(subStr,s,count) - ;"Purpose: return the beginning position of subStr in s - ;"Input: subStr -- the string to be searched for in s - ;" s -- the string to search - ;" count -- OPTIONAL, the instance to return pos of (1=1st, 2=2nd, etc.) - ;" if count=2 and only 1 instance exists, then 0 returned - ;"Result: the beginning position, or 0 if not found - ;"Note: This function differs from $find in that $find returns the pos of the - ;" first character AFTER the subStr - - set count=$get(count,1) - new result set result=0 - new instance set instance=1 -PS1 - set result=$find(s,subStr,result+1) - if result>0 set result=result-$length(subStr) - if count>instance set instance=instance+1 goto PS1 - - quit result - - -ArrayPos(array,s) - ;"Purpose: return the index position of s in array - - ;"... - - quit - -DiffPos(s1,s2) - ;"Purpose: Return the position of the first difference between s1 and s2 - ;"Input -- s1, s2 : The strings to compare. - ;"result: the position (in s1) of the first difference, or 0 if no difference - - new l set l=$length(s1) - if $length(s2)>l set l=$length(s2) - new done set done=0 - new i for i=1:1:l do quit:(done=1) - . set done=($extract(s1,1,i)'=$extract(s2,1,i)) - new result set result=0 - if done=1 set result=i - quit result - - -DiffWPos(Words1,Words2) - ;"Purpose: Return the index of the first different word between Words arrays - ;"Input: Words1,Words2 -- the array of words, such as would be made - ;" by CleaveToArray^TMGSTUTL - ;"Returns: Index of first different word in Words1, or 0 if no difference - - new l set l=+$get(Words1("MAXNODE")) - if +$get(Words2("MAXNODE"))>l set l=+$get(Words2("MAXNODE")) - new done set done=0 - new i for i=1:1:l do quit:(done=1) - . set done=($get(Words1(i))'=$get(Words2(i))) - new result - if done=1 set result=i - else set result=0 - quit result - - -SimStr(s1,p1,s2,p2) - ;"Purpose: return the matching string in both s1 and s2, starting - ;" at positions p1 and p2. - ;" Example: s1='Tom is 12 years old', p1=7 - ;" s2='Bill will be 12 years young tomorrow' p2=13 - ;" would return ' 12 years ' - - new ch1,ch2,offset,result,done - set result="",done=0 - for offset=0:1:9999 do quit:(done=1) - . set ch1=$extract(s1,p1+offset) - . set ch2=$extract(s2,p2+offset) - . if (ch1=ch2) set result=result_ch1 - . else set done=1 - quit result - - -SimWord(Words1,p1,Words2,p2) - ;"Purpose: return the matching words in both words array 1 and 2, starting - ;" at word positions p1 and p2. This function is different from - ;" SimStr in that it works with whole words - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words1("MAXNODE")=7 - ;" This will return 3, (where '12 years' starts) - ;" if p1=3 and p2=4 would return '12 years' - ;"Note: A '|' will be used as word separator when constructing result - ;"Input: Words1,Words2 -- the array of words, such as would be made - ;" by CleaveToArray^TMGSTUTL. e.g. - ;" p1,p2 -- the index of the word in Words array to start with - ;"result: (see example) - - new w1,w2,offset,result,done - set result="",done=0 - for offset=0:1:$get(Words1("MAXNODE")) do quit:(done=1) - . set w1=$get(Words1(offset+p1)) - . set w2=$get(Words2(offset+p2)) - . if (w1=w2)&(w1'="") do - . . if (result'="") set result=result_"|" - . . set result=result_w1 - . else set done=1 - quit result - - -SimPos(s1,s2,DivStr,pos1,pos2,MatchStr) - ;"Purpose: return the first position that two strings are similar. This means - ;" the first position in string s1 that characters match in s2. A - ;" match will be set to mean 3 or more characters being the same. - ;" Example: s1='Tom is 12 years old' - ;" s2='Bill will be 12 years young tomorrow' - ;" This will return 7, (where '12 years' starts) - ;"Input: s1,s2 -- the two strings to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result - ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result - ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result - ;"Results: Pos1^Pos2^MatchStr Pos1=position in s1, Pos2=position in s2, - ;" MatchStr=the matching Str - - set DivStr=$get(DivStr,"^") - new startPos,subStr,found,s2Pos - set found=0,s2Pos=0 - for startPos=1:1:$length(s1) do quit:(found=1) - . set subStr=$extract(s1,startPos,startPos+3) - . set s2Pos=$$Pos(subStr,s2) - . set found=(s2Pos>0) - - new result - if found=1 do - . set pos1=startPos,pos2=s2Pos - . set MatchStr=$$SimStr(s1,startPos,s2,s2Pos) - else do - . set pos1=0,pos2=0,MatchStr="" - - set result=pos1_DivStr_pos2_DivStr_MatchStr - - quit result - - -SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) - ;"Purpose: return the first position that two word arrays are similar. This means - ;" the first index in Words array 1 that matches to words in Words array 2. - ;" A match will be set to mean the two words are equal - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words2("MAXNODE")=7 - ;" This will return 3, (where '12 years' starts) - ;"Input: Words1,Words2 -- the two arrays to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result - ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result - ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result - ;"Results: Pos1^Pos2^MatchStr Pos1=position in Words1, Pos2=position in Words2, - ;" MatchStr=the first matching Word or phrase - ;" Note: | will be used as a word separator for phrases. - - set DivStr=$get(DivStr,"^") - new startPos,word1,found,w2Pos - set found=0,s2Pos=0 - for startPos=1:1:+$get(Words1("MAXNODE")) do quit:(found=1) - . set word1=$get(Words1(startPos)) - . set w2Pos=$$IndexOf^TMGMISC($name(Words2),word1) - . set found=(w2Pos>0) - - if found=1 do - . set p1=startPos,p2=w2Pos - . set MatchStr=$$SimWord(.Words1,p1,.Words2,p2) - else do - . set p1=0,p2=0,MatchStr="" - - new result set result=p1_DivStr_p2_DivStr_MatchStr - - quit result - - -DiffStr(s1,s2,DivChr) - ;"Purpose: Return how s1 differs from s2. E.g. - ;" s1='Today was the birthday of Bill and John' - ;" s2='Yesterday was the birthday of Tom and Sue' - ;" results='Today^1^Bill^26^John^35' - ;" This means that 'Today', starting at pos 1 in s1 differs - ;" from s2. And 'Bill' starting at pos 26 differs from s2 etc.. - ;"Input: s1,s2 -- the two strings to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;"Results: DiffStr1^pos1^DiffStr2^pos2^... - - set DivChr=$get(DivChr,"^") - new result set result="" - new offset set offset=0 - new p1,p2,matchStr,matchLen - new diffStr,temp -DSLoop - set temp=$$SimPos(s1,s2,DivChr,.p1,.p2,.matchStr) - ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str - if p1=0 set:(s1'="") result=result_s1_DivChr_(+offset) goto DSDone - - set matchLen=$length(matchStr) - - if p1>1 do - . set diffStr=$extract(s1,1,p1-1) - . set result=result_diffStr_DivChr_(1+offset)_DivChr - set offset=offset+(p1+matchLen-1) - set s1=$extract(s1,p1+matchLen,9999) ;"trim s1 - set s2=$extract(s2,p2+matchLen,9999) ;"trim s2 - goto DSLoop -DSDone - quit result - - -DiffWords(Words1,Words2,DivChr) - ;"Purpose: Return how Word arrays Words1 differs from Words2. E.g. - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words1("MAXNODE")=7 - ;" - ;" s1='Today was the birthday of Bill and John' - ;" s2='Yesterday was the birthday of Tom and Sue' - ;" results='Tom is^1^old^5' - ;" This means that 'Tom is', starting at pos 1 in Words1 differs - ;" from Words2. And 'old' starting at pos 5 differs from Words2 etc.. - ;"Input: Words1,Words2 -- PASS BY REFERENCE. The two word arrays to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;"Note: The words in DiffStr are divided by "|" - ;"Results: DiffStr1A>DiffStr1B^pos1>pos2^DiffStr2A>DiffStr2B^pos1>pos2^... - ;" The A DiffStr would be what the value is in Words1, and - ;" the B DiffStr would be what the value is in Words2, or @ if deleted. - - set DivChr=$get(DivChr,"^") - new result set result="" - new trimmed1,trimmed2 set trimmed1=0,trimmed2=0 - new p1,p2,matchStr,matchLen - new diffStr1,diffStr2,temp - new tWords1,tWords2 - merge tWords1=Words1 - merge tWords2=Words2 - new i,len1,len2,trimLen1,trimLen2 - new diffPos1,diffPos2 - set len1=+$get(tWords1("MAXNODE")) - set len2=+$get(tWords2("MAXNODE")) -DWLoop - set temp=$$SimWPos(.tWords1,.tWords2,DivChr,.p1,.p2,.matchStr) - ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str - - ;"Possible return options: - ;" p1=p2=0 -- two strings have nothing in common - ;" p1=p2=1 -- first word of each string is the same - ;" p1=p2=X -- words 1..(X-1) differ from each other. - ;" p1>p2 -- e.g. EXT REL TAB --> XR TAB - ;" p1 EXT REL TAB - - if (p1=0)&(p2=0) do - . set diffStr1=$$CatArray(.tWords1,1,len1,"|") - . set diffStr2=$$CatArray(.tWords2,1,len2,"|") - . set trimLen1=len1,trimLen2=len2 - . set diffPos1=1+trimmed1 - . set diffPos2=1+trimmed2 - else if (p1=1)&(p2=1) do - . set diffStr1="@",diffStr2="@" - . set trimLen1=1,trimLen2=1 - . set diffPos1=0,diffPos2=0 - else do - . set diffStr1=$$CatArray(.tWords1,1,p1-1,"|") - . set diffStr2=$$CatArray(.tWords2,1,p2-1,"|") - . set trimLen1=p1-1,trimLen2=p2-1 - . set diffPos1=1+trimmed1,diffPos2=1+trimmed2 - - if diffStr1="" set diffStr1="@" - if diffStr2="" set diffStr2="@" - - if '((diffStr1="@")&(diffStr1="@")) do - . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr - . set result=result_diffStr1_">"_diffStr2_DivChr - . set result=result_diffPos1_">"_diffPos2 - - do ListTrim^TMGMISC("tWords1",1,trimLen1,"MAXNODE") - do ListTrim^TMGMISC("tWords2",1,trimLen2,"MAXNODE") - set trimmed1=trimmed1+trimLen1 - set trimmed2=trimmed2+trimLen2 - - if ($get(tWords1("MAXNODE"))=0)&($get(tWords2("MAXNODE"))=0) goto DWDone - goto DWLoop - -DWDone - quit result - -CatArray(Words,i1,i2,DivChr) - ;"Purpose: For given word array, return contatenated results from index1 to index2 - ;"Input: Words -- PASS BY REFERENCE. Array of Words, as might be created by CleaveToArray - ;" i1 -- the index to start concat at - ;" i2 -- the last index to include in concat - ;" DivChr -- OPTIONAL. The character to used to separate words. Default=" " - - new result set result="" - set DivChr=$get(DivChr," ") - new i for i=i1:1:i2 do - . new word set word=$get(Words(i)) - . if word="" quit - . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr - . set result=result_word - quit result - - -QtProtect(s) - ;"Purpose: Protects quotes by converting all quotes do double quotes (" --> "") - ;"Input : s -- The string to be modified. Original string is unchanged. - ;"Result: returns a string with all instances of single instances of quotes - ;" being replaced with two quotes. - - new tempS - set tempS=$$Substitute($get(s),"""""","<^@^>") ;"protect original double quotes - set tempS=$$Substitute(tempS,"""","""""") - set tempS=$$Substitute(tempS,"<^@^>","""""") ;"reverse protection - quit tempS - - -GetStrPos(s,StartPos,P1,P2) ;"INCOMPLETE!! - ;"Purpose: return position of start and end of a string (marked by starting - ;" and ending quote. Search is started at StartPos. - ;" Example: if s='She said "Hello" to Bill', and StartPos=1 - ;" then P1 should be returned as 10, and P2 as 16 - ;"Input: s -- the text to be - ;" StartPos -- the position to start the search at. Optional: default=1 - ;" P1 -- PASS BY REFERENCE, an Out Parameter - ;" P2 -- PASS BY REFERENCE, an Out Parameter - ;"Results: None - ;"Output: P1 and P2 are returned as per example above, or 0 if not quotes in text - - set P1=0,P2=0 - if s'["""" goto GSPDone - set StartPos=+$get(StartPos,1) - new tempS set tempS=$extract(s,StartPos,$length(s)) - set tempS=$$Substitute(tempS,"""""",$char(1)_$char(1)) - - ;"FINISH... NOT COMPLETED... -GSPDone - quit - -InQt(s,Pos) - ;"Purpose: to return if a given character, in string(s), is insided quotes - ;" e.g. s='His name is "Bill," OK?' and if p=14, then returns 1 - ;" (note the above string is usually stored as: - ;" "His name is ""Bill,"" OK?" in the text editor, BUT in the - ;" strings that will be passed here I will get only 1 quote character - ;"Input: s -- the string to scan - ;" Pos -- the position of the character in question - ;"Results: 0 if not inside quotes, 1 if it is. - ;"NOTE: if Pos points to the bounding quotes, the result is 0 - new inQt set inQt=0 - if (Pos>$length(s))!(Pos<1) goto IQtDone - new p set p=$find(s,"""")-1 - if p returns "'Purple'" - ;"Input: s -- the string containing the source sentence - ;" Pos -- the index of a character anywhere inside desired word. - ;" OpenDiv -- OPTIONAL, default is " " this is what marks the start of the word. - ;" NOTE: if $length(OpenDiv)>1, then OpenDiv is considered - ;" to be a SET of characters, any of which can be used - ;" as a opening character. - ;" CloseDiv -- OPTIONAL, default is " " this is what marks the end of the word. - ;" NOTE: if $length(CloseDiv)>1, then CloseDiv is considered - ;" to be a SET of characters, any of which can be used - ;" as a closing character. - ;"Results: returns desired word, or "" if problem. - ; - new result set result="" - set OpenDiv=$get(OpenDiv," ") - set CloseDiv=$get(CloseDiv," ") - set Pos=+$get(Pos) if Pos'>0 goto GWdDone - new p1,p2,len,i - set len=$length(s) - for p2=Pos:1:len if CloseDiv[$extract(s,p2) set p2=p2-1 quit - for p1=Pos:-1:1 if OpenDiv[$extract(s,p1) set p1=p1+1 quit - set result=$extract(s,p1,p2) -GWdDone quit result - -CmdChStrip(s) - ;"Purpose: Strip all characters < #32 from string. - new Codes,i,result - set Codes="" - for i=1:1:31 set Codes=Codes_$char(i) - set result=$translate(s,Codes,"") - quit result - -StrBounds(s,p) - ;"Purpose: given position of start of string, returns index of end of string - ;"Input: s -- the string to eval - ;" p -- the index of the start of the string - ;"Results : returns the index of the end of the string, or 0 if not found. - new result set result=0 - for p=p+1:1 quit:(p>$length(s))!(result>0) do - . if $extract(s,p)'="""" quit - . set p=p+1 - . if $extract(s,p)="""" quit - . set result=p-1 - quit result - -NonWhite(s,p) - ;"Purpose: given starting position, return index of first non-whitespace character - ;" Note: either a " " or a TAB [$char(9)] will be considered a whitespace char - ;"result: returns index if non-whitespace, or index past end of string if none found. - new result,ch,done - for result=p:1 quit:(result>$length(s)) do quit:done - . set ch=$extract(s,result) - . set done=(ch'=" ")&(ch'=$char(9)) - quit result - -Pad2Pos(Pos,ch) - ;"Purpose: return a string that can be used to pad from the current $X - ;" screen cursor position, up to Pos, using char Ch (optional) - ;"Input: Pos -- a screen X cursor position, i.e. from 1-80 etc (depending on screen width) - ;" ch -- Optional, default is " " - ;"Result: returns string of padded characters. - new width set width=+$get(Pos)-$X if width'>0 set width=0 - quit $$LJ^XLFSTR("",width,.ch) - Index: cprs/branches/tmg-cprs/m_files/TMGSTUTL.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSTUTL.m~ (revision 796) +++ (revision ) @@ -1,1730 +1,0 @@ -TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06 - ;;1.0;TMG-LIB;**1**;09/01/05 - - ;"TMG STRING UTILITIES - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - ;"CleaveToArray^TMGSTUTL(Text,Divider,Array) - ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 - ;"CleaveStr^TMGSTUTL(Text,Divider,PartB) - ;"SplitStr^TMGSTUTL(Text,Width,PartB) - ;"SetStrLen^TMGSTUTL(Text,Width) - ;"$$NestSplit^TMGSTUTL(Text,OpenBracket,CloseBracket,SBefore,S,SAfter) - ;"$$Substitute^TMGSTUTL(S,Match,NewValue) - ;"$$FormatArray^TMGSTUTL(InArray,OutArray,Divider) - ;"$$Trim^TMGSTUTL(S,TrimCh) ; --> or use $$TRIM^XLFSTR - ;"$$TrimL^TMGSTUTL(S,TrimCh) - ;"$$TrimR^TMGSTUTL(S,TrimCh) - ;"$$TrimRType^TMGSTUTL(S,type) - ;"$$NumLWS^TMGSTUTL(S) - ;"$$MakeWS^TMGSTUTL(n) - ;"WordWrapArray^TMGSTUTL(.Array,Width,SpecialIndent) - ;"SplitLine^TMGSTUTL(s,.LineArray,Width) - ;"WriteWP^TMGSTUTL(NodeRef) - ;"$$LPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$RPad^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$Center^TMGSTUTL(S,width) ;"NOTE: should use XLFSTR fn below - ;"$$Clip^TMGSTUTL(S,width) - ;"$$STRB2H^TMGSTUTL(s,F) Convert a string to hex characters - ;"$$CapWords^TMGSTUTL(S,Divider) ;"capitalize the first character of each word in a string - ;"$$LinuxStr^TMGSTUTL(S) ;"Convert string to a valid linux filename - ;"StrToWP^TMGSTUTL(s,pArray,width,DivCh,InitLine) ;"wrap long string into a WP array - ;"$$WPToStr^TMGSTUTL(pArray,DivCh,MaxLen,InitLine) - ;"Comp2Strs(s1,s2) -- compare two strings and assign an arbritrary score to their similarity - ;"$$PosNum(s,[Num],LeadingSpace) -- return position of a number in a string - ;"IsNumeric(s) -- deterimine if word s is a numeric - ;"ScrubNumeric(s) -- remove numeric words from a sentence - ;"Pos(subStr,s,count) -- return the beginning position of subStr in s - ;"DiffPos(s1,s2) -- Return the position of the first difference between s1 and s2 - ;"DiffWords(Words1,Words2) -- Return index of first different word between Words arrays - ;"SimStr(s1,p1,s2,p2) -- return matching string in s1 and s2, starting at position p1,p2 - ;"SimWord(Words1,p1,Words2,p2) -- return the matching words in both words array 1 and 2, starting - ;" at word positions p1 and p2. - ;"SimPos(s1,s2) -- return the first position that two strings are similar. - ;"SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) -- return the first position that two word arrays - ;" are similar. This means the first index in Words array 1 that matches to words in Words array 2. - ;"DiffStr(s1,s2,DivChr) -- Return how s1 differs from s2. - ;"CatArray(Words,i1,i2,DivChr) -- return concat array from index1 to index2 - ;"$$QtProtect(s) -- Protects quotes by converting all quotes do double quotes (" --> "") - ;"$$InQt(s,Pos) -- return if a character at position P is inside quotes in s - ;"$$HNQTSUB(s,SubStr) --Same as $$HasNonQtSub - ;"$$HasNonQtSub(s,SubStr) -- return if string s contains SubStr, but not inside quotes. - ;"$$GetWord(s,Pos,OpenDiv,CloseDiv) -- extract a word from a sentance, bounded by OpenDiv,CloseDiv - ;"$$MATCHXTR(s,DivCh,Group,Map) -- Same as $$MatchXtract - ;"$$MatchXtract(s,DivCh,Group,Map) -- extract a string bounded by DivCh, honoring matching encapsulators - ;"MapMatch(s,Map) -- map a string with nested braces, parentheses etc (encapsulators) - ;"$$CmdChStrip(s) -- Strips all characters < #32 from string. - ;"$$StrBounds(s,p) -- return position of end of string - ;"NonWhite(s,p) -- return index of first non-whitespace character - ;"Pad2Pos(Pos,ch) -- return a padding string from current $X up to Pos, using ch - ;"HTML2TXT(Array) -- Take WP array that is HTML formatted, and strip

, and return in a format of 1 line per array node. - ;"TrimTags(lineS) -- cut out HTML tags (e.g. <...>) from lineS, however, is protected - ;"$$IsHTML(IEN8925) --specify if the text held in the REPORT TEXT field in record IEN8925 is HTML markup - - ;"======================================================================= - ;"Dependancies - ;" uses TMGDEBUG for debug messaging. - ;"======================================================================= - ;"======================================================================= - - ;"------------------------------------------------------------------------ - ;"FYI, String functions in XLFSTR module: - ;"------------------------------------------------------------------------ - ;"$$CJ^XLFSTR(s,i[,p]) -- Returns a center-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$LJ^XLFSTR(s,i[,p]) -- Returns a left-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$RJ^XLFSTR(s,i[,p]) -- Returns a right-justified string - ;" s=string, i=field size, p(optional)=pad character - ;"$$INVERT^XLFSTR(s) -- returns an inverted string (i.e. "ABC"-->"CBA") - ;"$$LOW^XLFSTR(s) -- returns string with all letters converted to lower-case - ;"$$UP^XLFSTR(s) -- returns string with all letters converted to upper-case - ;"$$TRIM^XLFSTR(s,[LRFlags],[char]) - ;"$$REPEAT^XLFSTR(s,Count) -- returns a string that is a repeat of s Count times - ;"$$REPLACE^XLFSTR(s,.spec) -- Uses a multi-character $TRanslate to return a - ;" string with the specified string replaced - ;" s=input string, spec=array passed by reference - ;" spec format: - ;" spec("Any_Search_String")="Replacement_String" - ;"$$STRIP^XLFSTR(s,Char) -- returns string striped of all instances of Char - - ;"======================================================================= - -CleaveToArray(Text,Divider,Array,InitIndex) - ;"Purpose: To take a string, delineated by 'divider' and - ;" to split it up into all its parts, putting each part - ;" into an array. e.g.: - ;" This/Is/A/Test, with '/' divider would result in - ;" Array(1)="This" - ;" Array(2)="Is" - ;" Array(3)="A" - ;" Array(4)="Test" - ;" Array(cMaxNode)=4 ;cMaxNode="MAXNODE" - ;"Input: Text - the input string -- should NOT be passed by reference. - ;" Divider - the delineating string - ;" Array - The array to receive output **SHOULD BE PASSED BY REFERENCE. - ;" InitIndex - OPTIONAL -- The index of the array to start with, i.e. 0 or 1. Default=1 - ;"Output: Array is changed, as outlined above - ;"Result: none - ;"Notes: Note -- Text is NOT changed (unless passed by reference, in - ;" which case the next to the last piece is put into Text) - ;" Array is killed, the filled with data **ONLY** IF DIVISIONS FOUND - ;" Limit of 256 nodes - ;" if cMaxNode is not defined, "MAXNODE" will be used - - set DBIndent=$get(DBIndent,0) - do DebugEntry^TMGDEBUG(.DBIndent,"CleaveToArray") - - set InitIndex=$get(InitIndex,1) - new PartB - new count set count=InitIndex - set cMaxNode=$get(cMaxNode,"MAXNODE") - - kill Array ;"Clear out any old data - -C2ArLoop - if '(Text[Divider) do goto C2ArDone - . set Array(count)=Text ;"put it all into first line. - . set Array(cMaxNode)=1 - do CleaveStr(.Text,Divider,.PartB) - set Array(count)=Text - set Array(cMaxNode)=count - set count=count+1 - if '(PartB[Divider) do goto C2ArDone - . set Array(count)=PartB - . set Array(cMaxNode)=count - else do goto C2ArLoop - . set Text=$get(PartB) - . set PartB="" - -C2ArDone - do DebugExit^TMGDEBUG(.DBIndent,"CleaveToArray") - quit - - -CleaveStr(Text,Divider,PartB) - ;"Purpse: To take a string, delineated by 'Divider' - ;" and to split it into two parts: Text and PartB - ;" e.g. Text="Hello\nThere" - ;" Divider="\n" - ;" Function will result in: Text="Hello", PartB="There" - ;"Input: Text - the input string **SHOULD BE PASSED BY REFERENCE. - ;" Divider - the delineating string - ;" PartB - the string to get second part **SHOULD BE PASSED BY REFERENCE. - ;"Output: Text and PartB will be changed - ;" Function will result in: Text="Hello", PartB="There" - ;"Result: none - - set DBIndent=$get(DBIndent,0) - do DebugEntry^TMGDEBUG(.DBIndent,"CleaveStr") - - do DebugMsg^TMGDEBUG(DBIndent,"Text=",Text) - - if '$data(Text) goto CSDone - if '$Data(Divider) goto CSDone - set PartB="" - - new PartA - - if Text[Divider do - . set PartA=$piece(Text,Divider,1) - . set PartB=$piece(Text,Divider,2,256) - . set Text=PartA - - do DebugMsg^TMGDEBUG(DBIndent,"After Processing, Text='",Text,"', and PartB='",PartB,"'") -CSDone - do DebugExit^TMGDEBUG(.DBIndent,"CleaveStr") - quit - - -SplitStr(Text,Width,PartB) - ;"PUBLIC FUNCTION - ;"Purpose: To a string into two parts. The first part will fit within 'Width' - ;" the second part is what is left over - ;" The split will be inteligent, so words are not divided (splits at a space) - ;"Input: Text = input text. **Should be passed by reference - ;" Width = the constraining width - ;" PartB = the left over part. **Should be passed by reference - ;"output: Text and PartB are modified - ;"result: none. - - new Len - set Width=$get(Width,80) - new SpaceFound set SpaceFound=0 - new SplitPoint set SplitPoint=Width - set Text=$get(Text) - set PartB="" - - set Len=$length(Text) - if Len>Width do - . new Ch - . for SplitPoint=SplitPoint:-1:1 do quit:SpaceFound - . . set Ch=$extract(Text,SplitPoint,SplitPoint) - . . set SpaceFound=(Ch=" ") - . if 'SpaceFound set SplitPoint=Width - . set s1=$extract(Text,1,SplitPoint) - . set PartB=$extract(Text,SplitPoint+1,1024) ;"max String length=1024 - . set Text=s1 - else do - - quit - - - -SetStrLen(Text,Width) - ;"PUBLIC FUNCTION - ;"Purpose: To make string exactly Width in length - ;" Shorten as needed, or pad with terminal spaces as needed. - ;"Input: Text -- should be passed as reference. This is string to alter. - ;" Width -- the desired width - ;"Results: none. - - set Text=$get(Text) - set Width=$get(Width,80) - new result set result=Text - new i,Len - - set Len=$length(result) - if Len>Width do - . set result=$extract(result,1,Width) - else if Len "ABC$$$DEF" - ;" Substitute("ABC###DEF","###","$") --> "ABC$DEF" - ;"Result: returns altered string (if any alterations indicated) - ;"Output: S is altered, if passed by reference. - - new spec - set spec($get(Match))=$get(NewValue) - set S=$$REPLACE^XLFSTR(S,.spec) - - quit S - - -FormatArray(InArray,OutArray,Divider) - ;"PUBLIC FUNCTION - ;"Purpose: The XML parser does not recognize whitespace, or end-of-line - ;" characters. Thus many lines get lumped together. However, if there - ;" is a significant amount of text, then the parser will put the text into - ;" several lines (when get attrib text called etc.) - ;" SO, this function is to take an array composed of input lines (each - ;" with multiple sublines clumped together), and format it such that each - ;" line is separated in the array. - ;" e.g. Take this input array" - ;" InArray(cText,1)="line one\nline two\nline three\n - ;" InArray(cText,2)="line four\nline five\nline six\n - ;" and convert to: - ;" OutArray(1)="line one" - ;" OutArray(2)="line two" - ;" OutArray(3)="line three" - ;" OutArray(4)="line four" - ;" OutArray(5)="line five" - ;" OutArray(6)="line six" - ;"Input: InArray, best if passed by reference (faster) -- see example above - ;" Note: expected to be in format: InArray(cText,n) - ;" OutArray, must be passed by reference-- see example above - ;" Divider: the character(s) that divides lines ("\n" in this example) - ;"Note: It is expected that InArray will be index by integers (i.e. 1, 2, 3) - ;" And this should be the case, as that is how XML functions pass back. - ;" Limit of 256 separate lines on any one InArray line - ;"Output: OutArray is set, any prior data is killed - ;"result: 1=OK to continue, 0=abort - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"FormatArray") - - new result set result=cOKToCont - new InIndex - new OutIndex set OutIndex=1 - new TempArray - new Done - - kill OutArray ;"remove any prior data - - if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Input array:") - if DEBUG do ArrayDump^TMGDEBUG("InArray") - - if $data(Divider)=0 do goto FADone - . set result=cAbort - - set Done=0 - for InIndex=1:1 do quit:Done - . if $data(InArray(cText,InIndex))=0 set Done=1 quit - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Converting line: ",InArray(cText,InIndex)) - . do CleaveToArray^TMGSTUTL(InArray(cText,InIndex),Divider,.TempArray,OutIndex) - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"Resulting temp array:") - . if DEBUG do ArrayDump^TMGDEBUG("TempArray") - . set OutIndex=TempArray(cMaxNode)+1 - . kill TempArray(cMaxNode) - . merge OutArray=TempArray - . if DEBUG>0 do DebugMsg^TMGDEBUG(DBIndent,"OutArray so far:") - . if DEBUG do ArrayDump^TMGDEBUG("OutArray") - -FADone - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"FormatArray") - quit result - - - -TrimL(S,TrimCh) - ;"Purpose: To a trip a string of leading white space - ;" i.e. convert " hello" into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - new result set result=$get(S) - new Ch set Ch="" - for do quit:(Ch'=TrimCh) - . set Ch=$extract(result,1,1) - . if Ch=TrimCh set result=$extract(result,2,1024) - - quit result - - -TrimR(S,TrimCh) - ;"Purpose: To a trip a string of trailing white space - ;" i.e. convert "hello " into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"TrimR") - - new result set result=$get(S) - new Ch set Ch="" - new L - - for do quit:(Ch'=TrimCh) - . set L=$length(result) - . set Ch=$extract(result,L,L) - . if Ch=TrimCh do - . . set result=$extract(result,1,L-1) - - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"TrimR") - quit result - -Trim(S,TrimCh) - ;"Purpose: To a trip a string of leading and trailing white space - ;" i.e. convert " hello " into "hello" - ;"Input: S -- the string to convert. Won't be changed if passed by reference - ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " - ;"Results: returns modified string - ;"Note: processing limitation is string length=1024 - - ;"NOTE: this function could be replaced with $$TRIM^XLFSTR - - set DEBUG=$get(DEBUG,0) - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set TrimCh=$get(TrimCh," ") - - if DEBUG>0 do DebugEntry^TMGDEBUG(.DBIndent,"Trim") - - new result set result=$get(S) - set result=$$TrimL(.result,TrimCh) - set result=$$TrimR(.result,TrimCh) - - if DEBUG>0 do DebugExit^TMGDEBUG(.DBIndent,"Trim") - quit result - -TrimRType(S,type) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: trim characters on the right of the string of a specified type. - ;" Goal, to be able to distinguish between numbers and strings. - ;" i.e. "1234<=" --> "1234" by trimming strings - ;"Input: S -- The string to work on - ;" type -- the type of characters to TRIM: N for numbers,C for non-numbers (characters) - ;"Results : modified string - - set tempS=$get(S) - set type=$$UP^XLFSTR($get(type)) goto:(type="") TRTDone - new done set done=0 - for quit:(tempS="")!done do - . new c set c=$extract(tempS,$length(tempS)) - . new cType set cType="C" - . if +c=c set cType="N" - . if type["N" do - . . if cType="N" set tempS=$extract(tempS,1,$length(tempS)-1) quit - . . set done=1 - . else if type["C" do - . . if cType="C" set tempS=$extract(tempS,1,$length(tempS)-1) quit - . . set done=1 - . else set done=1 - -TRTDone quit tempS - -NumLWS(S) - ;"Scope: PUBLIC FUNCTION - ;":Purpose: To count the number of white space characters on the left - ;" side of the string - - new result set result=0 - new i,ch - set S=$get(S) - - for i=1:1:$length(S) do quit:(ch'=" ") - . set ch=$extract(S,i,i) - . if ch=" " set result=result+1 - - quit result - - -MakeWS(n) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: Return a whitespace string that is n characters long - - new result set result="" - set n=$get(n,0) - if n'>0 goto MWSDone - - new i - for i=1:1:n set result=result_" " - -MWSDone - quit result - - -WordWrapArray(Array,Width,SpecialIndent) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: To take an array and perform word wrapping such that - ;" no line is longer than Width. - ;" This function is really designed for reformatting a Fileman WP field - ;"Input: Array MUST BE PASSED BY REFERENCE. This contains the array - ;" to be reformatted. Changes will be made to this array. - ;" It is expected that Array will be in this format: - ;" Array(1)="Some text on the first line." - ;" Array(2)="Some text on the second line." - ;" Array(3)="Some text on the third line." - ;" Array(4)="Some text on the fourth line." - ;" or - ;" Array(1,0)="Some text on the first line." - ;" Array(2,0)="Some text on the second line." - ;" Array(3,0)="Some text on the third line." - ;" Array(4,0)="Some text on the fourth line." - ;" Width -- the limit on the length of any line. Default value=70 - ;" SpecialIndent : if 1, then wrapping is done like this: - ;" " This is a very long line......" - ;" will be wrapped like this: - ;" " This is a very - ;" " long line ... - ;" Notice that the leading space is copied subsequent line. - ;" Also, a line like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" will be wrapped like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" Notice that a pattern '#. ' causes the wrapping to match the start of - ;" of the text on the line above. - ;" The exact rules for matching this are as follows: - ;" (FirstWord?.N1".")!(FirstWord?1.3E1".") - ;" i.e. any number of digits, followed by "." - ;" OR 1-4 all upper-case characters followed by a "." - ;" This will allow "VIII. " pattern but not "viii. " - ;" HOWEVER, might get confused with a word, like "NOTE. " - ;" - ;" This, below, is not dependant on SpecialIndent setting - ;" Also, because some of the lines have already partly wrapped, like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" "and this is a line that has already wrapped. - ;" So when the first line is wrapped, it would look like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" "and this is a line that has already wrapped. - ;" But is should look like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long...and this is a line - ;" " that has already wrapped. - ;" But the next line SHOULD NOT be pulled up if it is the start - ;" of a new paragraph. I will tell by looking for #. paattern. - - - ;"Result -- none - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WordWrapArray^TMGSTUTL") - new tempArray set tempArray="" ;"holds result during work. - new tindex set tindex=0 - new index - set index=$order(Array("")) - new s - new residualS set residualS="" - new AddZero set AddZero=0 - set Width=$get(Width,70) - - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Starting loop") - - if index'="" for do quit:((index="")&(residualS="")) - . set s=$get(Array(index)) - . if s="" do - . . set s=$get(Array(index,0)) - . . set AddZero=1 - . if residualS'="" do ;"See if should join to next line. Don't if '#. ' pattern - . . new FirstWord set FirstWord=$piece($$Trim(s)," ",1) - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"First Word: ",FirstWord) - . . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern - . . . ;"Here we have the next line is a new paragraph, so don't link to residualS - . . . set tindex=tindex+1 - . . . if AddZero=0 set tempArray(tindex)=residualS - . . . else set tempArray(tindex,0)=residualS - . . . set residualS="" - . if $length(residualS)+$length(s)'<256 do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ERROR -- string too long.") - . set s=residualS_s - . set residualS="" - . if $length(s)>Width do - . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Long line: ",s) - . . new LineArray - . . new NumLines - . . set NumLines=$$SplitLine(.s,.LineArray,Width,.SpecialIndent) - . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("LineArray") - . . set s="" - . . new LineIndex - . . for LineIndex=1:1:NumLines do - . . . set tindex=tindex+1 - . . . if AddZero=0 set tempArray(tindex)=LineArray(LineIndex) - . . . else set tempArray(tindex,0)=LineArray(LineIndex) - . . ;"long wrap probably continues into next paragraph, so link together. - . . if NumLines>2 do - . . . if AddZero=0 set residualS=tempArray(tindex) set tempArray(tindex)="" - . . . else set residualS=tempArray(tindex,0) set tempArray(tindex,0)="" - . . . set tindex=tindex-1 - . else do - . . set tindex=tindex+1 - . . if AddZero=0 set tempArray(tindex)=s - . . else set tempArray(tindex,0)=s - . set index=$order(Array(index)) - else do - . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Array appears empty") - - - kill Array - merge Array=tempArray - - if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Array") - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent," WordWrapArray^TMGSTUTL") - quit - - -SplitLine(s,LineArray,Width,SpecialIndent,Indent) - ;"Scope: PUBLIC FUNCTION - ;"Purpose: To take a long line, and wrap into an array, such that each - ;" line is not longer than Width. - ;" Line breaks will be made at spaces, unless there are no spaces in - ;" the entire line (in which case, the line will be divided at Width). - ;"Input: s= string with the long line. **If passed by reference**, then - ;" it WILL BE CHANGED to equal the last line of array. - ;" LineArray -- MUST BE PASSED BY REFERENCE. This OUT variable will - ;" receive the resulting array. - ;" Width = the desired wrap width. - ;" SpecialIndent [OPTIONAL]: if 1, then wrapping is done like this: - ;" " This is a very long line......" - ;" will be wrapped like this: - ;" " This is a very - ;" " long line ... - ;" Notice that the leading space is copied subsequent line. - ;" Also, a line like this: - ;" " 1. Here is the beginning of a paragraph that is very long..." - ;" will be wrapped like this: - ;" " 1. Here is the beginning of a paragraph - ;" " that is very long..." - ;" Notice that a pattern '#. ' causes the wrapping to match the start - ;" of the text on the line above. - ;" Indent [OPTIONAL]: Any absolute amount that all lines should be indented by. - ;" This could be used if this long line is continuation of an - ;" indentation above it. - ;"Result: resulting number of lines (1 if no wrap needed). - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SplitLine") - - new result set result=0 - kill LineArray - if ($get(s)="")!($get(Width)'>0) goto SPDone - new index set index=0 - new p,tempS,splitPoint - - new PreSpace set PreSpace=$$NeededWS(s,.SpecialIndent,.Indent) - - if ($length(s)>Width) for do quit:($length(s)'>Width) - . for splitPoint=1:1:Width do quit:($length(tempS)>Width) - . . set tempS=$piece(s," ",1,splitPoint) - . . ;"write "tempS>",tempS,! - . if splitPoint>1 do - . . set tempS=$piece(s," ",1,splitPoint-1) - . . set s=$piece(s," ",splitPoint,Width) - . else do - . . ;"We must have a word > Width with no spaces--so just divide - . . set tempS=$extract(s,1,Width) - . . set s=$extract(s,Width+1,999) - . set index=index+1 - . set LineArray(index)=tempS - . set s=PreSpace_s - . ;"write "tempS>",tempS,! - . ;"write "s>",s,! - - set index=index+1 - set LineArray(index)=s - - set result=index - -SPDone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SplitLine") - quit result - - - -NeededWS(S,SpecialIndent,Indent) - ;"Scope: PRIVATE - ;"Purpose: Evaluate the line, and create the white space string - ;" need for wrapped lines - ;"Input: s -- the string to eval. i.e. - ;" " John is very happy today ... .. .. .. .." - ;" or " 1. John is very happy today ... .. .. .. .." - ;" SpecialIndent -- See SplitLine() discussion - ;" Indent -- See SplitLine() discussion - - new result set result="" - if $get(S)="" goto NdWSDone - - new WSNum - set WSNum=+$get(Indent,0) - set WSNum=WSNum+$$NumLWS(S) - - if $get(SpecialIndent)=1 do - . new ts,FirstWord - . set ts=$$TrimL(.S) - . set FirstWord=$piece(ts," ",1) - . if (FirstWord?.N1".")!(FirstWord?1.4U1".") do ;"match for '#.' pattern - . . set WSNum=WSNum+$length(FirstWord) - . . set ts=$piece(ts," ",2,9999) - . . set WSNum=WSNum+$$NumLWS(.ts)+1 - - set result=$$MakeWS(WSNum) - -NdWSDone - quit result - - -WriteWP(NodeRef) - ;"Purpose: Given a reference to a WP field, this function will print it out. - ;"INput: NodeRef -- the name of the node to print out. - ;" For example, "^PS(50.605,1,1)" - ;"Modification: 2/10/06 -- I removed need for @NodeRef@(0) to contain data. - - new i - ;"if $get(@NodeRef@(0))="" goto WWPDone - set i=$order(@NodeRef@(0)) - if i'="" for do quit:(i="") - . new OneLine - . set OneLine=$get(@NodeRef@(i)) - . if OneLine="" set OneLine=$get(@NodeRef@(i,0)) - . write OneLine,! - . set i=$order(@NodeRef@(i)) - -WWPDone quit - - -LPad(S,width) - ;"Purpose: To add space ("pad") string S such that final width is per specified with. - ;" space is added to left side of string - ;"Input: S : the string to pad. - ;" width : the desired final width - ;"result: returns resulting string - ;"Example: LPad("$5.23",7)=" $5.23" - - quit $$RJ^XLFSTR(.S,.width," ") - -RPad(S,width) - ;"Purpose: To add space ("pad") string S such that final width is per specified with. - ;" space is added to right side of string - ;"Input: S : the string to pad. - ;" width : the desired final width - ;"result: returns resulting string - ;"Example: RPad("$5.23",7)="$5.23 " - - quit $$LJ^XLFSTR(.S,.width," ") - -Center(S,width) - ;"Purpose: to return a center justified string - - quit $$CJ^XLFSTR(.S,.width," ") - -Clip(S,width) - ;"Purpose: to ensure that string S is no longer than width - - new result set result=$get(S) - if result'="" set result=$extract(S,1,width) -ClipDone - quit result - - -STRB2H(s,F,noSpace) - ;"Convert a string to hex characters) - ;"Input: s -- the input string (need not be ascii characters) - ;" F -- (optional) if F>0 then will append an ascii display of string. - ;" noSpace -- (Optional) if >0 then characters NOT separated by spaces - ;"result -- the converted string - - new i,ch - new result set result="" - - for i=1:1:$length(s) do - . set ch=$extract(s,i) - . set result=result_$$HEXCHR^TMGMISC($ascii(ch)) - . if +$get(noSpace)=0 set result=result_" " - - if $get(F)>0 set result=result_" "_$$HIDECTRLS^TMGSTUTL(s) - quit result - - -HIDECTRLS(s) - ;"hide all unprintable characters from a string - new i,ch,byte - new result set result="" - for i=1:1:$length(s) do - . set ch=$e(s,i) - . set byte=$ascii(ch) - . if (byte<32)!(byte>122) set result=result_"." - . else set result=result_ch - - quit result - - - -CapWords(S,Divider) - ;"Purpose: convert each word in the string: 'test string' --> 'Test String', 'TEST STRING' --> 'Test String' - - ;"Input: S -- the string to convert - ;" Divider -- [OPTIONAL] the character used to separate string (default is ' ' [space]) - ;"Result: returns the converted string - - new s2,part - new result set result="" - set Divider=$get(Divider," ") - - set s2=$$LOW^XLFSTR(S) - - for i=1:1 do quit:part="" - . set part=$piece(s2,Divider,i) - . if part="" quit - . set $extract(part,1)=$$UP^XLFSTR($extract(part,1)) - . if result'="" set result=result_Divider - . set result=result_part - - quit result - - -LinuxStr(S) - ;"Purpose: convert string to a valid linux filename - ;" e.g. 'File Name' --> 'File\ Name' - - quit $$Substitute(.S," ","\ ") - - - -NiceSplit(S,Len,s1,s2,s2Min,DivCh) - ;"Purpose: to split S into two strings, s1 & s2 - ;" Furthermore, s1's length must be <= length. - ;" and the split will be made at spaces - ;"Input: S -- the string to split - ;" Len -- the length limit of s1 - ;" s1 -- PASS BY REFERENCE, an OUT parameter - ;" receives first part of split - ;" s2 -- PASS BY REFERENCE, an OUT parameter - ;" receives the rest of string - ;" s2Min -- OPTIONAL -- the minimum that - ;" length of s2 can be. Note, if s2 - ;" is "", then this is not applied - ;" DivCH -- OPTIONAL, default is " ". - ;" This is the character to split words by - ;"Output: s1 and s2 is filled with data - ;"Result: none - - set (s1,s2)="" - if $get(DivCh)="" set DivCh=" " - - if $length(S)'>Len do goto NSpDone - . set s1=S - - new i - new done - for i=200:-1:1 do quit:(done) - . set s1=$piece(S,DivCh,1,i)_DivCh - . set s2=$piece(S,DivCh,i+1,999) - . set done=($length(s1)'>Len) - . if done,+$get(s2Min)>0 do - . . if s2="" quit - . . set done=($length(s2)'0) - . set OneLine=$get(@pArray@(i)) - . if OneLine="" set OneLine=$get(@pArray@(i,0)) - . if OneLine="" quit - . set Len=$length(result)+$length(DivCh) - . if Len+$length(OneLine)>MaxLen do - . . set OneLine=$extract(OneLine,1,(MaxLen-Len)) - . set result=result_OneLine_DivCh - . set Len=Len+$length(OneLine) - . set i=$order(@pArray@(i)) - - quit result; - - -Comp2Strs(s1,s2) - ;"Purpose: To compare two strings and assign an arbritrary score to their similarity - ;"Input: s1,s2 -- The two strings to compare - ;"Result: a score comparing the two strings - ;" 0.5 point for every word in s1 that is also in s2 (case specific) - ;" 0.25 point for every word in s1 that is also in s2 (not case specific) - ;" 0.5 point for every word in s2 that is also in s1 (case specific) - ;" 0.25 point for every word in s2 that is also in s1 (not case specific) - ;" 1 points if same number of words in string (compared each way) - ;" 2 points for each word that is in the same position in each string (case specific) - ;" 1.5 points for each word that is in the same position in each string (not case specific) - - new score set score=0 - new Us1 set Us1=$$UP^XLFSTR(s1) - new Us2 set Us2=$$UP^XLFSTR(s2) - - new i - for i=1:1:$length(s1," ") do - . if s2[$piece(s1," ",i) set score=score+0.5 - . else if Us2[$piece(Us1," ",i) set score=score+0.25 - . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 - . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 - - for i=1:1:$length(s2," ") do - . if s1[$piece(s2," ",i) set score=score+0.5 - . else if Us1[$piece(Us2," ",i) set score=score+0.25 - . if $piece(s1," ",i)=$piece(s2," ",i) set score=score+1 - . else if $piece(Us1," ",i)=$piece(Us2," ",i) set score=score+1.5 - - if $length(s1," ")=$length(s2," ") set score=score+2 - - quit score - - -PosNum(s,Num,LeadingSpace) - ;"Purpose: To return the position of the first Number in a string - ;"Input: S -- string to check - ;" Num -- OPTIONAL, default is 0-9 numbers. number to look for. - ;" LeadingSpace -- OPTIONAL. If 1 then looks for " #" or " .#", not just "#" - ;"Results: -1 if not found, otherwise position of found digit. - - new result set result=-1 - new Leader set Leader="" - if $get(LeadingSpace)=1 set Leader=" " - - if $get(Num) do goto PNDone - . set result=$find(s,Leader_Num)-1 - - new temp,i,decimalFound - for i=0:1:9 do - . set decimalFound=0 - . set temp=$find(s,Leader_i) - . if (temp=0)&(Leader'="") do - . . set temp=$find(s,Leader_"."_i) - . . if temp>-1 set decimalFound=1 - . if temp>-1 set temp=temp-$length(Leader_i) - . if decimalFound set temp=temp-1 - . if (temp>0)&((temp0)&(Leader=" ") set result=result+1 - quit result - - -IsNumeric(s) - ;"Purpose: To deterimine if word s is a numeric - ;" Examples of numeric words: - ;" 10, N-100, 0.5%, 50000UNT/ML - ;" the test will be if the word contains any digit 0-9 - ;"Results: 1 if is a numeric word, 0 if not. - - quit ($$PosNum(.s)>0) - - -ScrubNumeric(s) - ;"Purpose: This is a specialty function designed to remove numeric words - ;" from a sentence. E.g. - ;" BELLADONNA ALK 0.3/PHENOBARB 16MG CHW TB --> BELLADONNA ALK /PHENOBARB CHW TB - ;" ESTROGENS,CONJUGATED 2MG/ML INJ (IN OIL) --> ESTROGENS,CONJUGATED INJ (IN OIL) - - new Array,i,result - set s=$$Substitute(s,"/MG","") - set s=$$Substitute(s,"/ML","") - set s=$$Substitute(s,"/"," / ") - set s=$$Substitute(s,"-"," - ") - do CleaveToArray(s," ",.Array) - new ToKill - set i=0 for set i=$order(Array(i)) quit:+i'>0 do - . if (Array(i)="MG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MCG")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MEQ")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="%")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if (Array(i)="MM")&($get(ToKill(i-1))=1) set ToKill(i)=1 quit - . if $$IsNumeric(Array(i))=0 quit - . set ToKill(i)=1 - . new tempS set tempS=$get(Array(i-1)) - . if (tempS="/")!(tempS="-") set ToKill(i-1)=1 - . if (tempS="NO")!(tempS="#") set ToKill(i-1)=1 - - set i=0 for set i=$order(Array(i)) quit:+i'>0 do - . if $get(ToKill(i))=1 kill Array(i) - - set i="",result="" - for set i=$order(Array(i)) quit:+i'>0 do - . set result=result_Array(i)_" " - - set result=$$Trim(result) - set result=$$Substitute(result," / ","/") - set result=$$Substitute(result," - ","-") - - quit result - - -Pos(subStr,s,count) - ;"Purpose: return the beginning position of subStr in s - ;"Input: subStr -- the string to be searched for in s - ;" s -- the string to search - ;" count -- OPTIONAL, the instance to return pos of (1=1st, 2=2nd, etc.) - ;" if count=2 and only 1 instance exists, then 0 returned - ;"Result: the beginning position, or 0 if not found - ;"Note: This function differs from $find in that $find returns the pos of the - ;" first character AFTER the subStr - - set count=$get(count,1) - new result set result=0 - new instance set instance=1 -PS1 - set result=$find(s,subStr,result+1) - if result>0 set result=result-$length(subStr) - if count>instance set instance=instance+1 goto PS1 - - quit result - - -ArrayPos(array,s) - ;"Purpose: return the index position of s in array - - ;"... - - quit - -DiffPos(s1,s2) - ;"Purpose: Return the position of the first difference between s1 and s2 - ;"Input -- s1, s2 : The strings to compare. - ;"result: the position (in s1) of the first difference, or 0 if no difference - - new l set l=$length(s1) - if $length(s2)>l set l=$length(s2) - new done set done=0 - new i for i=1:1:l do quit:(done=1) - . set done=($extract(s1,1,i)'=$extract(s2,1,i)) - new result set result=0 - if done=1 set result=i - quit result - - -DiffWPos(Words1,Words2) - ;"Purpose: Return the index of the first different word between Words arrays - ;"Input: Words1,Words2 -- the array of words, such as would be made - ;" by CleaveToArray^TMGSTUTL - ;"Returns: Index of first different word in Words1, or 0 if no difference - - new l set l=+$get(Words1("MAXNODE")) - if +$get(Words2("MAXNODE"))>l set l=+$get(Words2("MAXNODE")) - new done set done=0 - new i for i=1:1:l do quit:(done=1) - . set done=($get(Words1(i))'=$get(Words2(i))) - new result - if done=1 set result=i - else set result=0 - quit result - - -SimStr(s1,p1,s2,p2) - ;"Purpose: return the matching string in both s1 and s2, starting - ;" at positions p1 and p2. - ;" Example: s1='Tom is 12 years old', p1=7 - ;" s2='Bill will be 12 years young tomorrow' p2=13 - ;" would return ' 12 years ' - - new ch1,ch2,offset,result,done - set result="",done=0 - for offset=0:1:9999 do quit:(done=1) - . set ch1=$extract(s1,p1+offset) - . set ch2=$extract(s2,p2+offset) - . if (ch1=ch2) set result=result_ch1 - . else set done=1 - quit result - - -SimWord(Words1,p1,Words2,p2) - ;"Purpose: return the matching words in both words array 1 and 2, starting - ;" at word positions p1 and p2. This function is different from - ;" SimStr in that it works with whole words - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words1("MAXNODE")=7 - ;" This will return 3, (where '12 years' starts) - ;" if p1=3 and p2=4 would return '12 years' - ;"Note: A '|' will be used as word separator when constructing result - ;"Input: Words1,Words2 -- the array of words, such as would be made - ;" by CleaveToArray^TMGSTUTL. e.g. - ;" p1,p2 -- the index of the word in Words array to start with - ;"result: (see example) - - new w1,w2,offset,result,done - set result="",done=0 - for offset=0:1:$get(Words1("MAXNODE")) do quit:(done=1) - . set w1=$get(Words1(offset+p1)) - . set w2=$get(Words2(offset+p2)) - . if (w1=w2)&(w1'="") do - . . if (result'="") set result=result_"|" - . . set result=result_w1 - . else set done=1 - quit result - - -SimPos(s1,s2,DivStr,pos1,pos2,MatchStr) - ;"Purpose: return the first position that two strings are similar. This means - ;" the first position in string s1 that characters match in s2. A - ;" match will be set to mean 3 or more characters being the same. - ;" Example: s1='Tom is 12 years old' - ;" s2='Bill will be 12 years young tomorrow' - ;" This will return 7, (where '12 years' starts) - ;"Input: s1,s2 -- the two strings to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result - ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result - ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result - ;"Results: Pos1^Pos2^MatchStr Pos1=position in s1, Pos2=position in s2, - ;" MatchStr=the matching Str - - set DivStr=$get(DivStr,"^") - new startPos,subStr,found,s2Pos - set found=0,s2Pos=0 - for startPos=1:1:$length(s1) do quit:(found=1) - . set subStr=$extract(s1,startPos,startPos+3) - . set s2Pos=$$Pos(subStr,s2) - . set found=(s2Pos>0) - - new result - if found=1 do - . set pos1=startPos,pos2=s2Pos - . set MatchStr=$$SimStr(s1,startPos,s2,s2Pos) - else do - . set pos1=0,pos2=0,MatchStr="" - - set result=pos1_DivStr_pos2_DivStr_MatchStr - - quit result - - -SimWPos(Words1,Words2,DivStr,p1,p2,MatchStr) - ;"Purpose: return the first position that two word arrays are similar. This means - ;" the first index in Words array 1 that matches to words in Words array 2. - ;" A match will be set to mean the two words are equal - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words2("MAXNODE")=7 - ;" This will return 3, (where '12 years' starts) - ;"Input: Words1,Words2 -- the two arrays to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;" pos1 -- OPTIONAL, an OUT PARAMETER. Returns Pos1 from result - ;" pos2 -- OPTIONAL, an OUT PARAMETER. Returns Pos2 from result - ;" MatchStr -- OPTIONAL, an OUT PARAMETER. Returns MatchStr from result - ;"Results: Pos1^Pos2^MatchStr Pos1=position in Words1, Pos2=position in Words2, - ;" MatchStr=the first matching Word or phrase - ;" Note: | will be used as a word separator for phrases. - - set DivStr=$get(DivStr,"^") - new startPos,word1,found,w2Pos - set found=0,s2Pos=0 - for startPos=1:1:+$get(Words1("MAXNODE")) do quit:(found=1) - . set word1=$get(Words1(startPos)) - . set w2Pos=$$IndexOf^TMGMISC($name(Words2),word1) - . set found=(w2Pos>0) - - if found=1 do - . set p1=startPos,p2=w2Pos - . set MatchStr=$$SimWord(.Words1,p1,.Words2,p2) - else do - . set p1=0,p2=0,MatchStr="" - - new result set result=p1_DivStr_p2_DivStr_MatchStr - - quit result - - -DiffStr(s1,s2,DivChr) - ;"Purpose: Return how s1 differs from s2. E.g. - ;" s1='Today was the birthday of Bill and John' - ;" s2='Yesterday was the birthday of Tom and Sue' - ;" results='Today^1^Bill^26^John^35' - ;" This means that 'Today', starting at pos 1 in s1 differs - ;" from s2. And 'Bill' starting at pos 26 differs from s2 etc.. - ;"Input: s1,s2 -- the two strings to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;"Results: DiffStr1^pos1^DiffStr2^pos2^... - - set DivChr=$get(DivChr,"^") - new result set result="" - new offset set offset=0 - new p1,p2,matchStr,matchLen - new diffStr,temp -DSLoop - set temp=$$SimPos(s1,s2,DivChr,.p1,.p2,.matchStr) - ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str - if p1=0 set:(s1'="") result=result_s1_DivChr_(+offset) goto DSDone - - set matchLen=$length(matchStr) - - if p1>1 do - . set diffStr=$extract(s1,1,p1-1) - . set result=result_diffStr_DivChr_(1+offset)_DivChr - set offset=offset+(p1+matchLen-1) - set s1=$extract(s1,p1+matchLen,9999) ;"trim s1 - set s2=$extract(s2,p2+matchLen,9999) ;"trim s2 - goto DSLoop -DSDone - quit result - - -DiffWords(Words1,Words2,DivChr) - ;"Purpose: Return how Word arrays Words1 differs from Words2. E.g. - ;" Example: - ;" Words1(1)=Tom Words2(1)=Bill - ;" Words1(2)=is Words2(2)=will - ;" Words1(3)=12 Words2(3)=be - ;" Words1(4)=years Words2(4)=12 - ;" Words1(5)=old Words2(5)=years - ;" Words1("MAXNODE")=5 Words2(6)=young - ;" Words2(7)=tomorrow - ;" Words1("MAXNODE")=7 - ;" - ;" s1='Today was the birthday of Bill and John' - ;" s2='Yesterday was the birthday of Tom and Sue' - ;" results='Tom is^1^old^5' - ;" This means that 'Tom is', starting at pos 1 in Words1 differs - ;" from Words2. And 'old' starting at pos 5 differs from Words2 etc.. - ;"Input: Words1,Words2 -- PASS BY REFERENCE. The two word arrays to compare - ;" DivStr -- OPTIONAL, the character to use to separate the answers - ;" in the return string. Default is '^' - ;"Note: The words in DiffStr are divided by "|" - ;"Results: DiffStr1A>DiffStr1B^pos1>pos2^DiffStr2A>DiffStr2B^pos1>pos2^... - ;" The A DiffStr would be what the value is in Words1, and - ;" the B DiffStr would be what the value is in Words2, or @ if deleted. - - set DivChr=$get(DivChr,"^") - new result set result="" - new trimmed1,trimmed2 set trimmed1=0,trimmed2=0 - new p1,p2,matchStr,matchLen - new diffStr1,diffStr2,temp - new tWords1,tWords2 - merge tWords1=Words1 - merge tWords2=Words2 - new i,len1,len2,trimLen1,trimLen2 - new diffPos1,diffPos2 - set len1=+$get(tWords1("MAXNODE")) - set len2=+$get(tWords2("MAXNODE")) -DWLoop - set temp=$$SimWPos(.tWords1,.tWords2,DivChr,.p1,.p2,.matchStr) - ;"Returns: Pos1^Pos2^MatchStr Pos1=pos in s1, Pos2=pos in s2, MatchStr=the matching Str - - ;"Possible return options: - ;" p1=p2=0 -- two strings have nothing in common - ;" p1=p2=1 -- first word of each string is the same - ;" p1=p2=X -- words 1..(X-1) differ from each other. - ;" p1>p2 -- e.g. EXT REL TAB --> XR TAB - ;" p1 EXT REL TAB - - if (p1=0)&(p2=0) do - . set diffStr1=$$CatArray(.tWords1,1,len1,"|") - . set diffStr2=$$CatArray(.tWords2,1,len2,"|") - . set trimLen1=len1,trimLen2=len2 - . set diffPos1=1+trimmed1 - . set diffPos2=1+trimmed2 - else if (p1=1)&(p2=1) do - . set diffStr1="@",diffStr2="@" - . set trimLen1=1,trimLen2=1 - . set diffPos1=0,diffPos2=0 - else do - . set diffStr1=$$CatArray(.tWords1,1,p1-1,"|") - . set diffStr2=$$CatArray(.tWords2,1,p2-1,"|") - . set trimLen1=p1-1,trimLen2=p2-1 - . set diffPos1=1+trimmed1,diffPos2=1+trimmed2 - - if diffStr1="" set diffStr1="@" - if diffStr2="" set diffStr2="@" - - if '((diffStr1="@")&(diffStr1="@")) do - . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr - . set result=result_diffStr1_">"_diffStr2_DivChr - . set result=result_diffPos1_">"_diffPos2 - - do ListTrim^TMGMISC("tWords1",1,trimLen1,"MAXNODE") - do ListTrim^TMGMISC("tWords2",1,trimLen2,"MAXNODE") - set trimmed1=trimmed1+trimLen1 - set trimmed2=trimmed2+trimLen2 - - if ($get(tWords1("MAXNODE"))=0)&($get(tWords2("MAXNODE"))=0) goto DWDone - goto DWLoop - -DWDone - quit result - -CatArray(Words,i1,i2,DivChr) - ;"Purpose: For given word array, return contatenated results from index1 to index2 - ;"Input: Words -- PASS BY REFERENCE. Array of Words, as might be created by CleaveToArray - ;" i1 -- the index to start concat at - ;" i2 -- the last index to include in concat - ;" DivChr -- OPTIONAL. The character to used to separate words. Default=" " - - new result set result="" - set DivChr=$get(DivChr," ") - new i for i=i1:1:i2 do - . new word set word=$get(Words(i)) - . if word="" quit - . set:(result'="")&($extract(result,$length(result))'=DivChr) result=result_DivChr - . set result=result_word - quit result - - -QtProtect(s) - ;"Purpose: Protects quotes by converting all quotes do double quotes (" --> "") - ;"Input : s -- The string to be modified. Original string is unchanged. - ;"Result: returns a string with all instances of single instances of quotes - ;" being replaced with two quotes. - - new tempS - set tempS=$$Substitute($get(s),"""""","<^@^>") ;"protect original double quotes - set tempS=$$Substitute(tempS,"""","""""") - set tempS=$$Substitute(tempS,"<^@^>","""""") ;"reverse protection - quit tempS - - -GetStrPos(s,StartPos,P1,P2) ;"INCOMPLETE!! - ;"Purpose: return position of start and end of a string (marked by starting - ;" and ending quote. Search is started at StartPos. - ;" Example: if s='She said "Hello" to Bill', and StartPos=1 - ;" then P1 should be returned as 10, and P2 as 16 - ;"Input: s -- the text to be - ;" StartPos -- the position to start the search at. Optional: default=1 - ;" P1 -- PASS BY REFERENCE, an Out Parameter - ;" P2 -- PASS BY REFERENCE, an Out Parameter - ;"Results: None - ;"Output: P1 and P2 are returned as per example above, or 0 if not quotes in text - - set P1=0,P2=0 - if s'["""" goto GSPDone - set StartPos=+$get(StartPos,1) - new tempS set tempS=$extract(s,StartPos,$length(s)) - set tempS=$$Substitute(tempS,"""""",$char(1)_$char(1)) - - ;"FINISH... NOT COMPLETED... -GSPDone - quit - -InQt(s,Pos) - ;"Purpose: to return if a given character, in string(s), is insided quotes - ;" e.g. s='His name is "Bill," OK?' and if p=14, then returns 1 - ;" (note the above string is usually stored as: - ;" "His name is ""Bill,"" OK?" in the text editor, BUT in the - ;" strings that will be passed here I will get only 1 quote character - ;"Input: s -- the string to scan - ;" Pos -- the position of the character in question - ;"Results: 0 if not inside quotes, 1 if it is. - ;"NOTE: if Pos points to the bounding quotes, the result is 0 - new inQt set inQt=0 - if (Pos>$length(s))!(Pos<1) goto IQtDone - new p set p=$find(s,"""")-1 - if p returns "hungry" - ;"Example: s="Find('Purple')", Pos=8, OpenDiv="(", CloseDiv=")" --> returns "'Purple'" - ;"Input: s -- the string containing the source sentence - ;" Pos -- the index of a character anywhere inside desired word. - ;" OpenDiv -- OPTIONAL, default is " " this is what marks the start of the word. - ;" NOTE: if $length(OpenDiv)>1, then OpenDiv is considered - ;" to be a SET of characters, any of which can be used - ;" as a opening character. - ;" CloseDiv -- OPTIONAL, default is " " this is what marks the end of the word. - ;" NOTE: if $length(CloseDiv)>1, then CloseDiv is considered - ;" to be a SET of characters, any of which can be used - ;" as a closing character. - ;"Results: returns desired word, or "" if problem. - ; - new result set result="" - set OpenDiv=$get(OpenDiv," ") - set CloseDiv=$get(CloseDiv," ") - set Pos=+$get(Pos) if Pos'>0 goto GWdDone - new p1,p2,len,i - set len=$length(s) - for p2=Pos:1:len if CloseDiv[$extract(s,p2) set p2=p2-1 quit - for p1=Pos:-1:1 if OpenDiv[$extract(s,p1) set p1=p1+1 quit - set result=$extract(s,p1,p2) -GWdDone quit result - -MATCHXTR(s,DivCh,Group,Map) - ;"Purpose: Provide a SAAC compliant (all upper case) entry point) for MatchXtract - quit $$MatchXtract(.s,.DivCh,.Group,.Map) - ; -MatchXtract(s,DivCh,Group,Map) - ;"Purpose to extract a string bounded by DivCh, honoring matching encapsulators - ;"Note: the following markers are honored as paired encapsulators: - ;" ( ), { }, | |, < >, # #, [ ], - ;" To specify which set to use, DivCh should specify only OPENING character - ;"E.g. DivCh="{" - ;" s="Hello {There}" --> return "There" - ;" s="Hello {There {nested braces} friend}" --> return "There {nested braces} friend" - ;" DivCh="|" - ;" s="Hello |There|" --> "There" - ;" s="Hello |There{|friend|}|" --> "There{|friend|}" - ;" Notice that the second "|" was not paired to the first, because an opening brace was first. - ;"Input: s -- The string to evaluate - ;" DivCh -- The opening character of the encapsulator to use - ;" Group -- OPTIONAL. Default is 1. If line has more than one set of encapsulated entries, which group to get from - ;" Map -- OPTIONAL. PASS BY REFERENCE. If function is to be called multiple times, - ;" then a prior Map variable can be passed to speed processing. - ;"Results: Returns extracted string. - if $data(Map)=0 do MapMatch(s,.Map) - set Group=$get(Group,1) - set DivCh=$get(DivCh) - new Result set Result="" - new i set i=0 - for set i=$order(Map(Group,i)) quit:(i="")!(Result'="") do - . if DivCh'=$get(Map(Group,i)) quit - . new p,j - . for j=1,2 set p(j)=+$get(Map(Group,i,"Pos",j)) - . set Result=$extract(s,p(1)+1,p(2)-1) - quit Result - -MapMatch(s,Map) - ;"Purpose to map a string with nested braces, parentheses etc (encapsulators) - ;"Note: the following markers are honored as paired encapsulators: - ;" ( ), { }, | |, < >, # #, - ;"Input: s -- string to evaluate - ;" Map -- PASS BY REFERENCE. An OUT PARAMETER. Prior values are killed. Format: - ;" Map(Group,Depth)=OpeningSymbol - ;" Map(Group,Depth,"Pos",1)=index of opening symbol - ;" Map(Group,Depth,"Pos",2)=index of paired closing symbol - ;"E.g. s="Hello |There{|friend|}|" - ;" Map(1,1)="|" - ;" Map(1,1,"Pos",1)=7 - ;" Map(1,1,"Pos",2)=23 - ;" Map(1,2)="{" - ;" Map(1,2,"Pos",1)=13 - ;" Map(1,2,"Pos",2)=22 - ;" Map(1,3)="|" - ;" Map(1,3,"Pos",1)=14 - ;" Map(1,3,"Pos",2)=21 - ;"Eg. s="Hello |There{|friend|}| This is more (and I (want { to say} !) OK?)" - ;" map(1,1)="|" - ;" map(1,1,"Pos",1)=7 - ;" map(1,1,"Pos",2)=23 - ;" map(1,2)="{" - ;" map(1,2,"Pos",1)=13 - ;" map(1,2,"Pos",2)=22 - ;" map(1,3)="|" - ;" map(1,3,"Pos",1)=14 - ;" map(1,3,"Pos",2)=21 - ;" map(2,1)="(" - ;" map(2,1,"Pos",1)=39 - ;" map(2,1,"Pos",2)=68 - ;" map(2,2)="(" - ;" map(2,2,"Pos",1)=46 - ;" map(2,2,"Pos",2)=63 - ;" map(2,3)="{" - ;" map(2,3,"Pos",1)=52 - ;" map(2,3,"Pos",2)=60 - ;"Results: none - new Match,Depth,i,Group - set Match("(")=")" - set Match("{")="}" - set Match("[")="]" - set Match("|")="|" - set Match("<")=">" - set Match("#")="#" - kill Map - set Depth=0,Group=1 - for i=1:1:$length(s) do - . new ch set ch=$extract(s,i) - . if ch=$get(Map(Group,Depth,"Closer")) do quit - . . set Map(Group,Depth,"Pos",2)=i - . . kill Map(Group,Depth,"Closer") - . . set Depth=Depth-1 - . . if Depth=0 set Group=Group+1 - . if $data(Match(ch))=0 quit - . set Depth=Depth+1 - . set Map(Group,Depth)=ch - . set Map(Group,Depth,"Closer")=Match(ch) - . set Map(Group,Depth,"Pos",1)=i - quit - -CmdChStrip(s) - ;"Purpose: Strip all characters < #32 from string. - new Codes,i,result - set Codes="" - for i=1:1:31 set Codes=Codes_$char(i) - set result=$translate(s,Codes,"") - quit result - -StrBounds(s,p) - ;"Purpose: given position of start of string, returns index of end of string - ;"Input: s -- the string to eval - ;" p -- the index of the start of the string - ;"Results : returns the index of the end of the string, or 0 if not found. - new result set result=0 - for p=p+1:1 quit:(p>$length(s))!(result>0) do - . if $extract(s,p)'="""" quit - . set p=p+1 - . if $extract(s,p)="""" quit - . set result=p-1 - quit result - -NonWhite(s,p) - ;"Purpose: given starting position, return index of first non-whitespace character - ;" Note: either a " " or a TAB [$char(9)] will be considered a whitespace char - ;"result: returns index if non-whitespace, or index past end of string if none found. - new result,ch,done - for result=p:1 quit:(result>$length(s)) do quit:done - . set ch=$extract(s,result) - . set done=(ch'=" ")&(ch'=$char(9)) - quit result - -Pad2Pos(Pos,ch) - ;"Purpose: return a string that can be used to pad from the current $X - ;" screen cursor position, up to Pos, using char Ch (optional) - ;"Input: Pos -- a screen X cursor position, i.e. from 1-80 etc (depending on screen width) - ;" ch -- Optional, default is " " - ;"Result: returns string of padded characters. - new width set width=+$get(Pos)-$X if width'>0 set width=0 - quit $$LJ^XLFSTR("",width,.ch) - -HTML2TXT(Array) - ;"Purpose: text a WP array that is HTML formatted, and strip

, and - ;" return in a format of 1 line per array node. - ;"Input: Array -- PASS BY REFERENCE. This array will be altered. - ;"Results: none - ;"NOTE: This conversion causes some loss of HTML tags, so a round trip - ;" conversion back to HTML would fail. - ;"Called from: TMGTIUOJ.m - - new outArray,outI - set outI=1 - - ;"Clear out confusing non-breaking spaces. - new spec - set spec(" ")=" " - set spec("<")="<" - set spec(">")=">" - set spec("&")="&" - set spec(""")="""" - new line set line=0 - for set line=$order(Array(line)) quit:(line="") do - . new lineS set lineS=$get(Array(line,0)) - . set Array(line,0)=$$REPLACE^XLFSTR(lineS,.spec) - - new s2 set s2="" - new line set line=0 - for set line=$order(Array(line)) quit:(line="") do - . new lineS set lineS=s2_$get(Array(line,0)) - . set s2="" - . for do quit:(lineS'["<") - . . if (lineS["

")&($piece(lineS,"

",1)'["
") do quit - . . . set outArray(outI,0)=$piece(lineS,"

",1) - . . . set outI=outI+1 - . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. - . . . set outI=outI+1 - . . . set lineS=$piece(lineS,"

",2,999) - . . if (lineS["

")&($piece(lineS,"

",1)'["
") do quit - . . . set outArray(outI,0)=$piece(lineS,"

",1) - . . . set outI=outI+1 - . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. - . . . set outI=outI+1 - . . . set lineS=$piece(lineS,"

",2,999) - . . if (lineS["")&($piece(lineS,"",1)'["
") do quit - . . . set outArray(outI,0)=$piece(lineS,"",1) ;" _"" - . . . set outI=outI+1 - . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break. - . . . set outI=outI+1 - . . . set lineS=$piece(lineS,"",2,999) - . . if lineS["
" do quit - . . . set outArray(outI,0)=$piece(lineS,"
",1) - . . . set outI=outI+1 - . . . set lineS=$piece(lineS,"
",2,999) - . . set s2=lineS,lineS="" - . set s2=s2_lineS - if s2'="" do - . set outArray(outI,0)=s2 - . set outI=outI+1 - - kill Array - merge Array=outArray - quit - - -TrimTags(lineS) - ;"Purpose: To cut out HTML tags (e.g. <...>) from lineS, however, is protected - ;"Input: lineS : the string to work on. - ;"Results: the modified string - ;"Called from: TMGTIUOJ.m - new result,key,spec - set spec("")="[no data]" - set result=$$REPLACE^XLFSTR(lineS,.spec) - for quit:((result'["<")!(result'[">")) do - . new partA,partB - . set partA=$piece(result,"<",1) - . new temp set temp=$extract(result,$length(partA)+1,999) - . set partB=$piece(temp,">",2,99) - . set result=partA_partB - quit result - -IsHTML(IEN8925) - ;"Purpose: to specify if the text held in the REPORT TEXT field is HTML markup - ;"Input: IEN8925 -- record number in file 8925 - ;"Results: 1 if HTML markup, 0 otherwise. - ;"Note: This is not a perfect test. - ; - new result set result=0 - new Done set Done=0 - new line set line=0 - for set line=$order(^TIU(8925,IEN8925,"TEXT",line)) quit:(line="")!Done do - . new lineS set lineS=$$UP^XLFSTR($get(^TIU(8925,IEN8925,"TEXT",line,0))) - . if (lineS["") set Done=1,result=1 quit - quit result - Index: cprs/branches/tmg-cprs/m_files/TMGTEST.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTEST.m~ (revision 796) +++ (revision ) @@ -1,870 +1,0 @@ -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:2 do - .for j=1:1:2 do - ..for k=1:1:2 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 Index: cprs/branches/tmg-cprs/m_files/TMGTICK2.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTICK2.m.bak (revision 796) +++ (revision ) @@ -1,246 +1,0 @@ -TMGTICKL ;TMG/kst-Tickler Text Object Support Files;09/04/08 - ;;1.0;TMG-LIB;**1**;09/05/08 - - ;"--------------------------------------------------------------------------- - ;"PUBLIC FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"GETMSG(DocIEN,WPArray) -- retrieve tickler message in document. - ;"FLMSG(IEN) -- return the first line of the tickler message - ;"SELTCKLS(SelArray) -- Browse tickler messages and return array of IEN's selected. - ;"REUSER -- Allow browsing for a set of Tickler files, and reassigning the target user - ;"REDATE -- Allow browsing for a set of Tickler files, and reassigning the due date - ;"BROWSE -- Browse tickler messages. - ;"$$SELTICKLERS(SelArray) -- Browse tickler messages and return array of IEN's selected. - ;"--------------------------------------------------------------------------- - ;"PRIVATE FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"Dependencies: - ;" IENSelector^TMGUSRIF - ;" --> SELECT^%ZVEMKT - ;" --> ItrAInit^TMGITR - ;" Menu^TMGUSRIF - ;" ShowDIERR^TMGDEBUG - -FLMSG(IEN) - ;"Purpose: To return the first line of the tickler message - ;"NOTE: !!! DON'T REMOVE THIS FUNCTION. It is called by the computed field, - ;" FIRST LINE OF MESSAGE (field #5) in file 22705.5 (TICKLER FILE MESSAGES) - ;"Input: IEN: IEN in file 22705.5 - ;"Output: Returns first line, or "" if null - - new result set result="" - new DocIEN set DocIEN=+$piece($get(^TMG(22705.5,IEN,0)),"^",4) - if DocIEN>0 do - . new WPArray - . new temp set temp=$$GETMSG(DocIEN,.WPArray) - . set result=$get(WPArray(1)) - quit result - - -GETMSG(DocIEN,WPArray) - ;"Purpose: To retrieve the message for a tickler message in document. - ;"Note: It is expected that the Tickler text structure will be: - ;" - ;" ======= [TICKLER MESSGE] ======= - ;" #DUE#: Put-DUE-DATE-here - ;" ================================ - ;" Message: ... - ;" - ;" ================================ - ;" - ;" And specifically, the key elements are: - ;" 1. Entire Tickler starts with [TICKLER MESSGE] - ;" 2. Message starts on line after =========== - ;" 3. Messge ends with line with =========== - ;" If no closing =========== found, message extends to end of document - ;" - ;"Input: DocIEN -- IEN in 8925 - ;" WPArray -- PASS BY REFERENCE, an OUT PARAMETER. Returns message. Format: - ;" WPArray(1)='1st list' - ;" WPArray(2)='2nd line' etc... - ;"Result: 1 if found, 0 if not. - - new found,line set (found,line)=0 - for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!found do - . set found=($get(^TIU(8925,DocIEN,"TEXT",line,0))["[TICKLER MESSGE]") - . if found do - . . new done set done=0 - . . new lineText set lineText="" - . . for quit:done set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!done do - . . . set done=$get(^TIU(8925,DocIEN,"TEXT",line,0))["=====" - . . set done=0 - . . new wpIndex set wpIndex=1 - . . for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!done do - . . . set done=$get(^TIU(8925,DocIEN,"TEXT",line,0))["=====" - . . . if done quit - . . . set WPArray(wpIndex)=$get(^TIU(8925,DocIEN,"TEXT",line,0)) - . . . set wpIndex=wpIndex+1 - - quit found - - -SELTICKLERS(SelArray) - ;"Browse tickler messages and return array of IEN's selected. - ;"Input: SelArray -- PASS BY REFERENCE. An OUT ARRAY. - ;"Output: SelArray is filled as follows: - ;" SelArray(IEN)=DispLineNumber - ;" SelArray(IEN)=DispLineNumber - ;"Results: 1 if aborted, otherwise 0 - - new abort set abort=0 - kill SelArray - new Menu,usrChoice - set Menu(0)="Pick Display Order for Selector" - set Menu(1)="User Name; Status; Due Date; Patient Name"_$C(9)_"3;2;1;.01^20;10;15;20" - set Menu(2)="Patient Name; Status; User Name; Due Date"_$C(9)_".01;2;3;1^20;10;20;15" - set Menu(3)="Due Date; Patient Name; Status; User Name"_$C(9)_"1;.01;2;3^15;20;10;20" - set Menu(4)="Note Date; Patient Name; Status; User Name"_$C(9)_"4;.01;2;3^15;20;10;15" - set Menu(5)="Status; Due Date; Patient Name; User Name"_$C(9)_"2;1;.01;3^10;15;20;20" - - set usrChoice=$$Menu^TMGUSRIF(.Menu,3) - if usrChoice="^" goto SELTDONE - - new fields,widths - set fields=$piece(usrChoice,"^",1) - set widths=$piece(usrChoice,"^",2) - - new IENArray - new IEN set IEN=0 - for set IEN=$order(^TMG(22705.5,IEN)) quit:(+IEN'>0) set IENArray(IEN)="" - new Header set Header="Pick Tickler Messages. Press when done." - do IENSelector^TMGUSRIF("IENArray","SelArray",22705.5,fields,widths,Header,fields) - - new % set %=1 - write "Review tickler messages for selected entries?" do YN^DICN write ! - if %=-1 set abort=1 goto SELTDONE - if %=1 do DispTicklers(.SelArray) - -SELTDONE - quit abort - - -BROWSE - ;"Purpose: To browse tickler messages - ;"Results: none - - new SelArray,abort - write ! - set abort=$$SELTICKLERS(.SelArray) - - write "Goodbye.",! - quit - - -DispTicklers(IENArray) - ;"Purpose: Display a list of tickler messages - ;"Input: IENArray. PASS BY REFERENCE. format: - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;"Results: None - - new count set count=0 - new abort set abort=0 - new TklIEN set TklIEN="" - for set TklIEN=$order(SelArray(TklIEN)) quit:(TklIEN="")!abort do - . set count=count+1 - . write "----------------------------------",! - . write "STATUS: ",$$GET1^DIQ(22705.5,TklIEN,2),! - . write "DUE DATE: ",$$GET1^DIQ(22705.5,TklIEN,1),! - . write "PATIENT: ",$$GET1^DIQ(22705.5,TklIEN,.01),! - . write "DOCUMENT: ",$$GET1^DIQ(22705.5,TklIEN,.05)," (#",$$GET1^DIQ(22705.5,TklIEN,.05,"I"),")",! - . write "DOC DATE: ",$$GET1^DIQ(22705.5,TklIEN,4),! - . write "USER: ",$$GET1^DIQ(22705.5,TklIEN,3),! - . write "MESSAGE (1st line):",!," ",$$GET1^DIQ(22705.5,TklIEN,5),! - . if count#3=0 do - . . new temp read "Press Enter to Continue",temp:$get(DTIME,3600),! - . . set abort=(temp="^") - - if count=0 write "(No items to display.)",! - write ! - quit - - -REUSER ;"Reassign Tickler File Recipient User - ;"Purpose: to allow browsing for a set of Tickler files, and reassigning the target user - ;"Result: none - - new numErrors set numErrors=0 - new NumProcessed set NumProcessed=0 - - write !," -= REASSIGN RECIPIENT USER FOR TICKLER MESSAGES =-",!,! - write "You will next be able to select tickler messages to reassign.",! - write "Note: Only change tickler messages with a PENDING status.",! - write " Changing others will have no effect.",!,! - do PressToCont^TMGUSRIF - - if $$SELTICKLERS(.SelArray)=1 goto REUDONE - - if $data(SelArray)=0 goto REUDONE - new % set %=2 - write "Pick new recipient user for the selected tickler messages?" - do YN^DICN write ! - if %'=1 goto REUDONE - - new DIC set DIC=200 - set DIC(0)="MAEQ" - set DIC("A")="Select new RECIPIENT USER: " - do ^DIC write ! - if +Y'>0 goto REUDONE - - new IEN set IEN="" - for set IEN=$order(SelArray(IEN)) quit:(IEN="") do - . set NumProcessed=NumProcessed+1 - . new TMGFDA,TMGMSG - . set TMGFDA(22705.5,IEN_",",3)=+Y - . do FILE^DIE("","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR"))>0 do - . . do ShowDIERR^TMGDEBUG(.TMGMSG) - . . set numErrors=numErrors+1 - -REUDONE - write !,NumProcessed," tickler message file entries processed.",! - if NumProcessed>0 write numErrors," errors encountered.",! - write "Goodbye",! - quit - - -REDATE ;"Reassign Due Dates for Tickler File - ;"Purpose: to allow browsing for a set of Tickler files, and reassigning due date - ;"Result: none - - write !," -= REASSIGN DUE DATE FOR TICKLER MESSAGES =-",!,! - write "You will next be able to select tickler messages to change.",! - write "Note: Only change tickler messages with a PENDING status.",! - write " Changing others will have no effect.",!,! - do PressToCont^TMGUSRIF - - if $$SELTICKLERS(.SelArray)=1 goto REDDONE - - new numErrors set numErrors=0 - new NumProcessed set NumProcessed=0 - if $data(SelArray)=0 goto REUDONE - new % set %=2 - write "Pick new DUE DATE for the selected tickler messages?" - do YN^DICN write ! - if %'=1 goto REDDONE - - new DIR,X,Y - set DIR(0)="DO",DIR("A")="Enter new DUE DATE (^ to abort)" - do ^DIR write ! - if +Y'>0 goto REDDONE - - new IEN set IEN="" - for set IEN=$order(SelArray(IEN)) quit:(IEN="") do - . set NumProcessed=NumProcessed+1 - . new TMGFDA,TMGMSG - . set TMGFDA(22705.5,IEN_",",1)=+Y - . do FILE^DIE("","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR"))>0 do - . . do ShowDIERR^TMGDEBUG(.TMGMSG) - . . set numErrors=numErrors+1 - -REDDONE - write !,NumProcessed," tickler message file entries processed.",! - if NumProcessed>0 write numErrors," errors encountered.",! - write "Goodbye",! - quit Index: cprs/branches/tmg-cprs/m_files/TMGTICK2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTICK2.m~ (revision 796) +++ (revision ) @@ -1,357 +1,0 @@ -TMGTICKL ;TMG/kst-Tickler Text Object Support Files;09/04/08 - ;;1.0;TMG-LIB;**1**;09/05/08 - - ;"--------------------------------------------------------------------------- - ;"PUBLIC FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"GETMSG(DocIEN,WPArray) -- retrieve tickler message in document. - ;"FLMSG(IEN) -- return the first line of the tickler message - ;"SELTCKLS(SelArray) -- Browse tickler messages and return array of IEN's selected. - ;"REUSER -- Allow browsing for a set of Tickler files, and reassigning the target user - ;"REDATE -- Allow browsing for a set of Tickler files, and reassigning the due date - ;"BROWSE -- Browse tickler messages. - ;"$$SELTICKLERS(SelArray) -- Browse tickler messages and return array of IEN's selected. - ;"CLEANDON -- remove tickler messages that have been completed, thus no longer needed. - ;"CLEANOPH -- remove tickler messages that have been orphaned, thus no longer needed. - ;"DispTicklers(IENArray) -- Display a list of tickler messages - - ;"--------------------------------------------------------------------------- - ;"PRIVATE FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"Dependencies: - ;" IENSelector^TMGUSRIF - ;" --> SELECT^%ZVEMKT - ;" --> ItrAInit^TMGITR - ;" Menu^TMGUSRIF - ;" ShowDIERR^TMGDEBUG - -FLMSG(IEN) - ;"Purpose: To return the first line of the tickler message - ;"NOTE: !!! DON'T REMOVE THIS FUNCTION. It is called by the computed field, - ;" FIRST LINE OF MESSAGE (field #5) in file 22705.5 (TICKLER FILE MESSAGES) - ;"Input: IEN: IEN in file 22705.5 - ;"Output: Returns first line, or "" if null - - new result set result="" - new DocIEN set DocIEN=+$piece($get(^TMG(22705.5,IEN,0)),"^",4) - if DocIEN>0 do - . new WPArray - . new temp set temp=$$GETMSG(DocIEN,.WPArray) - . set result=$get(WPArray(1)) - quit result - - -GETMSG(DocIEN,WPArray) - ;"Purpose: To retrieve the message for a tickler message in document. - ;"Note: It is expected that the Tickler text structure will be: - ;" - ;" ======= [TICKLER MESSGE] ======= - ;" #DUE#: Put-DUE-DATE-here - ;" ================================ - ;" Message: ... - ;" - ;" ================================ - ;" - ;" And specifically, the key elements are: - ;" 1. Entire Tickler starts with [TICKLER MESSGE] - ;" 2. Message starts on line after =========== - ;" 3. Messge ends with line with =========== - ;" If no closing =========== found, message extends to end of document - ;" - ;"Input: DocIEN -- IEN in 8925 - ;" WPArray -- PASS BY REFERENCE, an OUT PARAMETER. Returns message. Format: - ;" WPArray(1)='1st list' - ;" WPArray(2)='2nd line' etc... - ;"Result: 1 if found, 0 if not. - - new found,line set (found,line)=0 - for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!found do - . set found=($get(^TIU(8925,DocIEN,"TEXT",line,0))["[TICKLER MESSGE]") - . if found do - . . new done set done=0 - . . new lineText set lineText="" - . . for quit:done set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!done do - . . . set done=$get(^TIU(8925,DocIEN,"TEXT",line,0))["=====" - . . set done=0 - . . new wpIndex set wpIndex=1 - . . for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!done do - . . . set done=$get(^TIU(8925,DocIEN,"TEXT",line,0))["=====" - . . . if done quit - . . . set WPArray(wpIndex)=$get(^TIU(8925,DocIEN,"TEXT",line,0)) - . . . set wpIndex=wpIndex+1 - - quit found - - -BROWSE - ;"Purpose: To browse tickler messages - ;"Results: none - - new SelArray,abort - write ! - set abort=$$SELTICKLERS(.SelArray) - if abort goto BWDN - new % set %=1 - write "Review tickler messages for selected entries?" do YN^DICN write ! - if %=-1 set abort=1 goto SELTDONE - if %=1 do DispTicklers(.SelArray) - write "Goodbye.",! -BWDN quit - - -DELTICKL ; - ;"Purpose: allow user to pick tickler message to delete. - new SelArray - write ! - new % set %=2 - write "Select tickler messages to DELETE" do YN^DICN write ! - if %'=1 goto DTDN - set abort=$$SELTICKLERS(.SelArray) - if abort goto DTDN - if $data(SelArray)=0 goto DTDN - - set %=1 - write "Review tickler messages for selected entries?" do YN^DICN write ! - if %=-1 goto DTDN - if %=1 do DispTicklers(.SelArray) - - set %=2 - write "Delete selected tickler messages" do YN^DICN write ! - if %=-1 goto DTDN - new DelCt set DelCt=0 - if %=1 do - . set DelCt=$$DELSET(.SelArray) - . write DelCt," tickler messages deleted.",! - - write "Goodbye.",! - do PressToCont^TMGUSRIF -DTDN quit - - - -SELTICKLERS(SelArray) - ;"Browse tickler messages and return array of IEN's selected. - ;"Input: SelArray -- PASS BY REFERENCE. An OUT ARRAY. - ;"Output: SelArray is filled as follows: - ;" SelArray(IEN)=DispLineNumber - ;" SelArray(IEN)=DispLineNumber - ;"Results: 1 if aborted, otherwise 0 - - new abort set abort=0 - kill SelArray - write !,"== TICKER MESSAGES BROWSER ==",!! - new % set %=2 - write "View COMPLETED ticker messages " DO YN^DICN write ! - if %=-1 goto SELTDONE - new HideCompl set HideCompl=(%=2) - - new Menu,usrChoice - new LineCt set LineCt=1 - set Menu(0)="Pick Display Order for Selector" - if HideCompl do - . set Menu(LineCt)="User Name; Due Date; Patient Name"_$C(9)_"3;1;.01;2^20;15;20;10",LineCt=LineCt+1 - . set Menu(LineCt)="Patient Name; User Name; Due Date"_$C(9)_".01;3;1;2^20;20;15;10",LineCt=LineCt+1 - . set Menu(LineCt)="Due Date; Patient Name; User Name"_$C(9)_"1;.01;3;2^15;20;20;10",LineCt=LineCt+1 - . set Menu(LineCt)="Note Date; Patient Name; User Name"_$C(9)_"4;.01;3;2^15;20;10;15",LineCt=LineCt+1 - else do - . set Menu(LineCt)="User Name; Status; Due Date; Patient Name"_$C(9)_"3;2;1;.01^20;10;15;20",LineCt=LineCt+1 - . set Menu(LineCt)="Patient Name; Status; User Name; Due Date"_$C(9)_".01;2;3;1^20;10;20;15",LineCt=LineCt+1 - . set Menu(LineCt)="Due Date; Patient Name; Status; User Name"_$C(9)_"1;.01;2;3^15;20;10;20",LineCt=LineCt+1 - . set Menu(LineCt)="Note Date; Patient Name; Status; User Name"_$C(9)_"4;.01;2;3^15;20;10;15",LineCt=LineCt+1 - . set Menu(LineCt)="Status; Due Date; Patient Name; User Name"_$C(9)_"2;1;.01;3^10;15;20;20",LineCt=LineCt+1 - - set usrChoice=$$Menu^TMGUSRIF(.Menu,3) - if usrChoice="^" goto SELTDONE - - new fields,widths - set fields=$piece(usrChoice,"^",1) - set widths=$piece(usrChoice,"^",2) - - new IENArray - new IEN set IEN=0 - for set IEN=$order(^TMG(22705.5,IEN)) quit:(+IEN'>0) do - . new status - . set status=$piece($get(^TMG(22705.5,IEN,0)),"^",3) - . if (status="C"),(HideCompl=1) quit - . set IENArray(IEN)="" - . - new Header set Header="Pick Tickler Messages. Press when done." - do IENSelector^TMGUSRIF("IENArray","SelArray",22705.5,fields,widths,Header,fields) -SELTDONE - quit abort - - -CLEANDON ; - ;"Purpose: to remove tickler messages that have been completed, thus no longer needed. - ;"Results: None - write !,"== CLEAN UP COMPLETED TICKER MESSAGES ==",!! - new % set %=2 - write "DELETE all COMPLETED ticker messages " DO YN^DICN write ! - if %'=1 goto DELDONE - do GetStatusSet("C",.IENArray) ; - new DelCt set DelCt=$$DELSET(.IENArray) - write DelCt," completed tickler messages deleted.",! -DELDONE quit - -CLEANOPH ; - ;"Purpose: to remove tickler messages that have been orphaned, thus no longer needed. - ;"NOTE: An orphan note is created when a user launches a tickler object in a note, but - ;" then removes the text, so that the note does not actually have a tickler in it. - ;"Results: None - new abort set abort=0 - New IENArray - write !,"== CLEAN UP ORPHANED TICKER MESSAGES ==",!! - write "Note: An ORPHAN ticker message occurs when a user launches",! - write " the tickler text object from in CPRS, but then deletes",! - write " it, so that the note does not actually have a tickler",! - write " message in it. There should be no harm in doing this.",!,! - new % set %=2 - write "DELETE all ORPHANED ticker messages " DO YN^DICN write ! - if %'=1 goto ORPHDONE - do GetStatusSet("O",.IENArray) ; - new DelCt set DelCt=$$DELSET(.IENArray) - write DelCt," orphaned tickler messages deleted.",! - do PressToCont^TMGUSRIF -ORPHDONE quit - -GetStatusSet(Status,IENArray) ; - ;"Purpose: return a set of entries with given status. - ;"Input: Status -- the internal form of desired status. - ;" IENArray. PASS BY REFERENCE. format as below. - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - new IEN set IEN=0 - for set IEN=$order(^TMG(22705.5,IEN)) quit:(+IEN'>0) do - . new ThisStat set ThisStat=$piece($get(^TMG(22705.5,IEN,0)),"^",3) - . if (ThisStat=Status) set IENArray(IEN)="" - quit - -DELSET(IENArray) ; - ;"Purpose: To delete the specified Tickler Entries. - ;"Input: IENArray. PASS BY REFERENCE. format as below. - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;" NOTe: All included entries will be deleted with NO confirmation. - ;"Results: returns number of deleted entries. - ; - new DIK set DIK="^TMG(22705.5," - new DA - new DelCt set DelCt=0 - new IEN set IEN=0 - for set IEN=$order(IENArray(IEN)) quit:(+IEN'>0) do - . set DA=IEN do ^DIK - . set DelCt=DelCt+1 - quit DelCt - -DispTicklers(IENArray) - ;"Purpose: Display a list of tickler messages - ;"Input: IENArray. PASS BY REFERENCE. format: - ;" IENArray(IEN)="" - ;" IENArray(IEN)="" - ;"Results: None - - new count set count=0 - new abort set abort=0 - new TklIEN set TklIEN="" - for set TklIEN=$order(SelArray(TklIEN)) quit:(TklIEN="")!abort do - . set count=count+1 - . write "----------------------------------",! - . write "STATUS: ",$$GET1^DIQ(22705.5,TklIEN,2),! - . write "DUE DATE: ",$$GET1^DIQ(22705.5,TklIEN,1),! - . write "PATIENT: ",$$GET1^DIQ(22705.5,TklIEN,.01),! - . write "DOCUMENT: ",$$GET1^DIQ(22705.5,TklIEN,.05)," (#",$$GET1^DIQ(22705.5,TklIEN,.05,"I"),")",! - . write "DOC DATE: ",$$GET1^DIQ(22705.5,TklIEN,4),! - . write "USER: ",$$GET1^DIQ(22705.5,TklIEN,3),! - . write "MESSAGE (1st line):",!," ",$$GET1^DIQ(22705.5,TklIEN,5),! - . if count#3=0 do - . . new temp read "Press Enter to Continue",temp:$get(DTIME,3600),! - . . set abort=(temp="^") - - if count=0 write "(No items to display.)",! - write ! - quit - - -REUSER ;"Reassign Tickler File Recipient User - ;"Purpose: to allow browsing for a set of Tickler files, and reassigning the target user - ;"Result: none - - new numErrors set numErrors=0 - new NumProcessed set NumProcessed=0 - - write !," -= REASSIGN RECIPIENT USER FOR TICKLER MESSAGES =-",!,! - write "You will next be able to select tickler messages to reassign.",! - write "Note: Only change tickler messages with a PENDING status.",! - write " Changing others will have no effect.",!,! - do PressToCont^TMGUSRIF - - if $$SELTICKLERS(.SelArray)=1 goto REUDONE - - if $data(SelArray)=0 goto REUDONE - new % set %=2 - write "Pick new recipient user for the selected tickler messages?" - do YN^DICN write ! - if %'=1 goto REUDONE - - new DIC set DIC=200 - set DIC(0)="MAEQ" - set DIC("A")="Select new RECIPIENT USER: " - do ^DIC write ! - if +Y'>0 goto REUDONE - - new IEN set IEN="" - for set IEN=$order(SelArray(IEN)) quit:(IEN="") do - . set NumProcessed=NumProcessed+1 - . new TMGFDA,TMGMSG - . set TMGFDA(22705.5,IEN_",",3)=+Y - . do FILE^DIE("","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR"))>0 do - . . do ShowDIERR^TMGDEBUG(.TMGMSG) - . . set numErrors=numErrors+1 -REUDONE - write !,NumProcessed," tickler message file entries processed.",! - if NumProcessed>0 write numErrors," errors encountered.",! - write "Goodbye",! - quit - - -REDATE ;"Reassign Due Dates for Tickler File - ;"Purpose: to allow browsing for a set of Tickler files, and reassigning due date - ;"Result: none - - write !," -= REASSIGN DUE DATE FOR TICKLER MESSAGES =-",!,! - write "You will next be able to select tickler messages to change.",! - write "Note: Only change tickler messages with a PENDING status.",! - write " Changing others will have no effect.",!,! - do PressToCont^TMGUSRIF - - if $$SELTICKLERS(.SelArray)=1 goto REDDONE - - new numErrors set numErrors=0 - new NumProcessed set NumProcessed=0 - if $data(SelArray)=0 goto REUDONE - new % set %=2 - write "Pick new DUE DATE for the selected tickler messages?" - do YN^DICN write ! - if %'=1 goto REDDONE - - new DIR,X,Y - set DIR(0)="DO",DIR("A")="Enter new DUE DATE (^ to abort)" - do ^DIR write ! - if +Y'>0 goto REDDONE - - new IEN set IEN="" - for set IEN=$order(SelArray(IEN)) quit:(IEN="") do - . set NumProcessed=NumProcessed+1 - . new TMGFDA,TMGMSG - . set TMGFDA(22705.5,IEN_",",1)=+Y - . do FILE^DIE("","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR"))>0 do - . . do ShowDIERR^TMGDEBUG(.TMGMSG) - . . set numErrors=numErrors+1 - -REDDONE - write !,NumProcessed," tickler message file entries processed.",! - if NumProcessed>0 write numErrors," errors encountered.",! - write "Goodbye",! - quit Index: cprs/branches/tmg-cprs/m_files/TMGTICKL.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTICKL.m.bak (revision 796) +++ (revision ) @@ -1,462 +1,0 @@ -TMGTICKL ;TMG/kst-Tickler Text objects for use in CPRS ;08/27/08 - ;;1.0;TMG-LIB;**1**;08/27/08 - - ;"TMG Tickler text object and surrounding support code. - ;" - ;"These are bits of code that return text to be included in progress notes etc. - ;"They are called when the user puts text like this in a note: - ;" ... Mrs. Jone's vitals today are |VITALS|, measured in the office... - ;" 'VITALS' would be a TIU TEXT OBJECT, managed through menu option TIUFJ CREATE OBJECTS MGR - - ;"--------------------------------------------------------------------------- - ;"PUBLIC FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"$$TICKLER^TMGTICKL(DFN,.TIU) -- Entry point for TIU Text object caller - ;"HANDLE^TMGTICKL -- entry point for Task to handle tickler messages, called at scheduled intervals - ;"ERRSHOW^TMGTICKL -- Handle Alerts, showing details about error. - - ;"--------------------------------------------------------------------------- - ;"PRIVATE FUNCTIONS - ;"--------------------------------------------------------------------------- - ;"$$HasTickler(DocIEN,DateStr) -- return if TIU DOCUMENT contains the signals for a TICKLER message. - ;"SendAddendum(DocIEN,AuthorIEN,TklIEN,TMGWP) -- place an addendum to the specified note with message - ;"SendErrAddendum(DocIEN,TklIEN,TMGMSG) -- send an addendum to note showing database error. - ;"SendAlert(UserIEN,TklIEN,Msg,TMGMSG) -- send a message alert to the user (for error reporting) - ;"RecheduleTask -- reschedule task for handling the next cycle of tickler messages. - ;"PressToCont -- provide a 'press key to continue' action - ;"GetErrStr(ErrArray) -- convert a standard DIERR array into a string for output - - ;"--------------------------------------------------------------------------- - ;"--------------------------------------------------------------------------- - -TICKLER(DFN) - ;"Purpose: A call point for TIU objects, to launch a tickler for the given note. - ;"Input: DFN -- the patient's unique ID (record#) - ;"Result: returns text that will be put into the note in CPRS - - new result - - set DFN=+$get(DFN) - if DFN=0 do goto TKDone - . set result="ERROR: DFN not defined. Contact IT support (Source: TMGTICKL.m)" - - set result="" - set result=result_" ======= [TICKLER MESSGE] ======="_$CHAR(13)_$CHAR(10) - set result=result_" #DUE#: Put-DUE-DATE-here "_$CHAR(13)_$CHAR(10) - set result=result_" ================================"_$CHAR(13)_$CHAR(10) - set result=result_" Message: ... "_$CHAR(13)_$CHAR(10) - set result=result_" "_$CHAR(13)_$CHAR(10) - set result=result_" ================================"_$CHAR(13)_$CHAR(10) - set result=result_$CHAR(13)_$CHAR(10) - - ;"Create an entry in TMG TICKLER file, for later processing. - ;"Processing will need to wait until after document is signed, so that due date is fixed. - new TMGFDA,TMGMSG,TMGIEN - set TMGFDA(22705.5,"+1,",.01)=DFN ;"IEN in PATIENT file - set TMGFDA(22705.5,"+1,",2)="U" ;"U=Unsigned - set TMGFDA(22705.5,"+1,",3)=DUZ ;"Current user - - do UPDATE^DIE("","TMGFDA","TMGIEN","TMGMSG") - if $data(TMGMSG("DIERR")) do goto TKDone - . set result="ERROR: Fileman error creating Tickler Message. Contact IT support (Source: TMGTICKL.m)" - . set result=result_$$GetErrStr(.TMGMSG) - -TKDone quit result - - -HANDLE - ;"Purpose: An entry point for Taskman Task to handle tickler messages - ;" This will be called at scheduled intervals - - do RecheduleTask - - new X,%,TMGFDA,TMGMSG - do NOW^%DTC ;"get current time into % - set TMGFDA(22705.4,"1,",3)=% - do FILE^DIE("","TMGFDA","TMGMSG") ;"set time of last scan in 22705.4 - - new DIC,Y - set DIC=8925.6 ;"TIU STATUS file - set X="COMPLETED" - DO ^DIC - new StatusIEN set StatusIEN=+Y - if StatusIEN'>0 do goto HandlDone - . do SendAlert(DUZ,0,"Tickler Error: Can't find IEN for 'COMPLETED' status") - - ;"For each TMG TICKLER entry that is UNSIGNED, and missing a DOCUMENT - ;"pointer, a scan of all a patient's documents is carried out, looking - ;"for one with a Tickler Message that has not already been noted. When - ;"found, the DOCUMENT pointer is stored. Search is by date, in - ;"reverse chronological order (most recent first). - new TklIEN set TklIEN=0 - for set TklIEN=$order(^TMG(22705.5,"S","U",TklIEN)) quit:(+TklIEN'>0) do - . new found set found=0 - . new DocIEN set DocIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",4) - . if DocIEN>0 quit ;"Document for this Tickler already found, so don't search again. SHOULDN'T EVER HAPPEN - . new PtIEN set PtIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",1) - . new UserIEN set UserIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",5) - . new DateStr set DateStr="" - . new DocClIEN set DocClIEN=0 - . ;"Note: ADCPT xref --> Patient,Doc CLASS,Status,InverseRefDate,DocIEN - . for set DocClIEN=$order(^TIU(8925,"ADCPT",PtIEN,DocClIEN)) quit:(+DocClIEN'>0)!found do - . . new RefDate set RefDate="" - . . for set RefDate=$order(^TIU(8925,"ADCPT",PtIEN,DocClIEN,StatusIEN,RefDate)) quit:(RefDate="")!found do - . . . set DocIEN="" - . . . for set DocIEN=$order(^TIU(8925,"ADCPT",PtIEN,DocClIEN,StatusIEN,RefDate,DocIEN)) quit:(+DocIEN'>0)!found do - . . . . ;"DocIEN should be a COMPLETED document for patient - . . . . if $data(^TMG(22705.5,"C",DocIEN)) quit ;"document already linked by another tickler - . . . . if $$HasTickler(DocIEN,.DateStr)=0 quit - . . . . set found=1 - . . . . new TMGFDA,TMGMSG - . . . . set TMGFDA(22705.5,TklIEN_",",.05)="`"_DocIEN - . . . . set TMGFDA(22705.5,TklIEN_",",2)="S" ;"S=SIGNED - . . . . set TMGFDA(22705.5,TklIEN_",",1)=DateStr - . . . . do FILE^DIE("E","TMGFDA","TMGMSG") - . . . . if $data(TMGMSG("DIERR"))=0 quit ;"no errors, so we are done here... - . . . . do SendErrAddendum(DocIEN,TklIEN,.TMGMSG) - . if found=0 do ;"no match COMPLETED document found for TICKLER entry - . . ;"Check if patient has any non-COMPLETED documents, if so, wait longer - . . set DocIEN="" - . . for set DocIEN=$order(^TIU(8925,"C",PtIEN,DocIEN)) quit:(+DocIEN'>0)!found do - . . . set found=(+$piece($get(^TIU(8925,DocIEN,0)),"^",5)=StatusIEN) - . . if found=0 do ;"TICKLER entry doesn't refer to any real message (must have been deleted in CPRS) - . . . new TMGFDA,TMGMSG - . . . set TMGFDA(22705.5,TklIEN_",",2)="O" ;"O=ORPHANED - . . . do FILE^DIE("E","TMGFDA","TMGMSG") - . . . if $data(TMGMSG("DIERR"))=0 quit ;"no errors, so we are done here... - . . . do SendErrAddendum(DocIEN,TklIEN,.TMGMSG) - - ;"Scan all TMG TICKLER entries that have a status of SIGNED, - ;"and if the due date has arrived,then process. Change status to COMPLETED, and - ;"create an new document that is an ADDENDUM to the document. - ;"Send message 'Your message is now due' etc... - ;"ADDENDUM: I changed the external text of status (S)/SIGNED to be 'PENDING' for user clarity - set TklIEN=0 - for set TklIEN=$order(^TMG(22705.5,"S","S",TklIEN)) quit:(+TklIEN'>0) do - . new DocIEN set DocIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",4) - . new AuthorIEN set AuthorIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",5) ;"0;5 = USER - . new X,X1,X2,%,%Y,DueDateT,NowDateT - . set (X1,DueDateT)=$piece(^TMG(22705.5,TklIEN,0),"^",2) ;" 0;2 = DUE DATE, Field 1 - . do NOW^%DTC set (X2,NowDateT)=% - . do ^%DTC ;"returns X=X1-X2 (ie X=DUE-NOW); If %Y=, dates were imprecise and unworkable. - . if %Y=0 do quit - . . if DocIEN'>0 set X=0 quit ;"Bigger problem exists, will be reported below. - . . set s(1)="**Error Processing Dates for Tickler Message**" - . . set s(2)="(This note may be edited or deleted--until signed.)" - . . set s(3)="Date found was imprecise and unworkable, or '#DUE#:' text was not found." - . . set s(4)="TO FIX: Please create an addendum to the original note and add a NEW TICKLER message." - . . do SendAddendum(DocIEN,AuthorIEN,TklIEN,.s) - . . ;"If we don't specified the tickler to be Completed, the error will be sent repeatedly - . . new TMGFDA,TMGMSG - . . set TMGFDA(22705.5,TklIEN_",",2)="C" ;"C=COMPLETED - . . do FILE^DIE("","TMGFDA","TMGMSG") - . . if $data(TMGMSG("DIERR"))=0 quit ;"no errors, so we are done here... - . . do SendErrAddendum(DocIEN,TklIEN,.TMGMSG) - . if X'<1 quit ;"Tickler not yet due, so wait longer. - . new waitMore set waitMore=0 - . if X=0 do quit:waitMore=1 - . . new dueTime set dueTime=$$LJ^XLFSTR($piece(DueDateT,".",2),6,"0") - . . new nowTime set nowTime=$$LJ^XLFSTR($piece(NowDateT,".",2),6,"0") - . . if dueTime>nowTime set waitMore=1 - . ;"Success! Tickler is due. Send addendum - . if DocIEN=0 do quit - . . do SendAlert(AuthorIEN,TklIEN,"Can't find Document for Tickler record. (Shouldn't happen). Check TMGTICKL.m") - . new s - . set s(1)=" " - . set s(2)=" * * Tickler message due date has arrived * * " - . set s(3)="================================================" - . set s(4)=" This note may be edited if needed until signed" - . set s(5)=" " - . set s(6)=" Please note original tickler message." - . set s(7)=" " - . do SendAddendum(DocIEN,AuthorIEN,TklIEN,.s) - . new TMGFDA,TMGMSG - . set TMGFDA(22705.5,TklIEN_",",2)="C" ;"C=COMPLETED - . do FILE^DIE("","TMGFDA","TMGMSG") - . if $data(TMGMSG("DIERR"))=0 quit ;"no errors, so we are done here... - . do SendErrAddendum(DocIEN,TklIEN,.TMGMSG) - -HandlDone - quit - - -HasTickler(DocIEN,DateStr) - ;"Purpose: To determine if the REPORT TEXT for the TIU DOCUMENT (DocIEN) WP field - ;" contains the string that signals a TICKLER message. - ;" Notice: The string matched here *same* string as is found in TICKLER() - ;"Input: DocIEN -- IEN in 8925 - ;" DateStr -- PASS BY REFERENCE, an OUT PARAMETER - ;" Returns Due Date *String* from '#DUE#: - ;" on line AFTER [TICKLER MESSAGE] - ;"Result: 1 if found, 0 if not. - - set DateStr="" - new found,line set (found,line)=0 - for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!found do - . set found=($get(^TIU(8925,DocIEN,"TEXT",line,0))["[TICKLER MESSGE]") - . new done set done=0 - . if found for set line=$order(^TIU(8925,DocIEN,"TEXT",line)) quit:(+line'>0)!done do - . . if $get(^TIU(8925,DocIEN,"TEXT",line,0))'["#DUE#:" quit - . . set done=1 - . . set DateStr=$piece(^TIU(8925,DocIEN,"TEXT",line,0),"#DUE#:",2) - . . new ch for set ch=$extract(DateStr,1) quit:(ch'=" ") do ;"trim off leading spaces - . . . set DateStr=$extract(DateStr,2,200) - . . for quit:(DateStr'["@ ") do ;"handle 'mm/dd/yy @ time' format (i.e. spaces after @) - . . . new spec set spec("@ ")="@" - . . . set DateStr=$$REPLACE^XLFSTR(DateStr,.spec) - - quit found - - -SendAddendum(DocIEN,AuthorIEN,TklIEN,TMGWP) - ;"Purpose: To place an addendum to the specified note (or the note's parent if - ;" the note is itself already an addendum. - ;"Input: DocIEN -- IEN in 8925 - ;" AuthorIEN -- IEN in 200 of author - ;" TklIEN -- Tickler IEN 22705.5 - ;" TMGWP --PASS BY REFERENCE. message to put in addendum. - ;" e.g. TMGWP(1)="First line of text." - ;" TMGWP(2)="Second line of text." - ;"Result: 1 if successful, 0 if error. <--- NO. No result returned. - - new result set result=1 ;"default to success. - - new parentIEN set parentIEN=+$piece($get(^TIU(8925,DocIEN,0)),"^",6) ;"0;6= FIELD .06, PARENT - if parentIEN>0 set DocIEN=parentIEN - new PtIEN set PtIEN=+$piece($get(^TMG(22705.5,TklIEN,0)),"^",1) - new visitIEN set visitIEN=+$piece($get(^TIU(8925,DocIEN,0)),"^",3) - new locIEN set locIEN=+$piece($get(^TIU(8925,DocIEN,12)),"^",11) - new HlocIEN set HlocIEN=+$piece($get(^TIU(8925,DocIEN,12)),"^",5) - new divIEN set divIEN=+$piece($get(^TIU(8925,DocIEN,12)),"^",12) - new serviceIEN set serviceIEN=+$piece($get(^TIU(8925,DocIEN,14)),"^",4) - - new DIC,X,Y - set DIC=8925.1 - set DIC("S")="I $P(^(0),U,4)=""DOC""" ;"screen for Type=Title - set X="ADDENDUM" - do ^DIC - if +Y'>0 do goto SendADone - . set result=0 - . do SendAlert(AuthorIEN,TklIEN,"Unable to find ADDENDUM Title for Tickler Note") - new docTypeIEN set docTypeIEN=+Y - - set DIC("S")="I $P(^(0),U,4)=""DC""" ;"screen for Type=Class - set X="ADDENDUM" - do ^DIC - if +Y'>0 do goto SendADone - . set result=0 - . do SendAlert(AuthorIEN,TklIEN,"Unable to find ADDENDUM class for Tickler Note") - new DocClassIEN set DocClassIEN=+Y - - new TMGFDA,TMGMSG,TMGIEN - set TMGFDA(8925,"+1,",.01)="`"_docTypeIEN ;".01 = DOCUMENT TYPE - set TMGFDA(8925,"+1,",.02)="`"_PtIEN ;".02 = PATIENT - set TMGFDA(8925,"+1,",.03)="`"_visitIEN ;".03 = VISIT - set TMGFDA(8925,"+1,",.04)="`"_DocClassIEN;".04 = PARENT DOCUMENT TYPE - set TMGFDA(8925,"+1,",.05)="UNSIGNED" ;".05 = STATUS - set TMGFDA(8925,"+1,",.06)="`"_DocIEN ;".06 = PARENT - set TMGFDA(8925,"+1,",.07)="NOW" ;".07 = EPISODE BEGIN DATE/TIME - set TMGFDA(8925,"+1,",.13)="A" ;".13 = VISIT TYPE - set TMGFDA(8925,"+1,",1201)="NOW" ;"1201 = ENTRY DATE/TIME - set TMGFDA(8925,"+1,",1202)="`"_AuthorIEN ;"1202 = AUTHOR/DICTATOR - set TMGFDA(8925,"+1,",1204)="`"_AuthorIEN ;"1204 = EXPECTED SIGNER - set TMGFDA(8925,"+1,",1205)="`"_HlocIEN ;"1205 = HOSPITAL LOCATION - set TMGFDA(8925,"+1,",1211)="`"_locIEN ;"1211 = VISIT LOCATION - set TMGFDA(8925,"+1,",1212)="`"_divIEN ;"1212 = DIVISION - set TMGFDA(8925,"+1,",1301)="NOW" ;"1301 = REFERENCE DATE - set TMGFDA(8925,"+1,",1302)="`"_AuthorIEN ;"1302 = ENTERED BY - set TMGFDA(8925,"+1,",1303)="direct" ;"1303 = CAPTURE METHOD - set TMGFDA(8925,"+1,",1404)="`"_serviceIEN;"1404 = SERVICE - set TMGFDA(8925,"+1,",1506)="NO" ;"1506 = COSIGNATURE NEEDED - - do UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") - - if $data(TMGMSG("DIERR")) do goto SendADone - . set result=0 - . do SendAlert(AuthorIEN,TklIEN,"Error creating Tickler addendum.",.TMGMSG) - - new newDocIEN set newDocIEN=TMGIEN(1) - Do SEND^TIUALRT(newDocIEN) ;"create alert regarding note needing to be signed. - - kill TMGMSG - do WP^DIE(8925,newDocIEN_",",2,"","TMGWP","TMGMSG") - - if $data(TMGMSG("DIERR")) do goto SendADone - . set result=0 - . do SendAlert(AuthorIEN,TklIEN,"Error filing message into Tickler addendum.",.TMGMSG) - -SendADone - ;"quit result - quit - - -SendErrAddendum(DocIEN,TklIEN,TMGMSG) - ;"Purpose: to send an addendum to note showing database error. - ;"Input: DocIEN: the document that should have the addendum added. - ;" TklIEN: the IEN of the tickler record - ;" TMGMSG: PASS BY REFERENCE. The error array, as returned by fileman. - ;"result: none. - - new ErrStr - set ErrStr(1)="Database error encountered handling tickler message." - set ErrStr(2)="Note: This may be deleted..." - set ErrStr(3)=$$GetErrStr(.TMGMSG) - new AuthorIEN set AuthorIEN=$piece($get(^TMG(22705.5,TklIEN,0)),"^",5) - do SendAddendum(DocIEN,AuthorIEN,TklIEN,.ErrStr) - quit - - -SendAlert(UserIEN,TklIEN,Msg,TMGMSG) - ;"Purpose: to send a message alert to the user (for error reporting) - ;"Input: UserIEN -- IEN in 200, the target of the message - ;" TklIEN -- the IEN of the tickler message - ;" Msg -- the message to send. **ONLY UP TO 80 characters** - ;" No ^ allowed in the message! - ;" TMGMSG -- OPTIONAL, PASS BY REFERENCE. - ;" An error array as created by Fileman. - ;"results: none - - ;"initialize vars for alert code - new XQA,XQAARCH,XQADATA,XQAFLG,XQAGUID,XQAID,XQAMSG - new XQAOPT,XQAROU,XQASUPV,XQASURO,XQATEXT - - set XQADATA=TklIEN_"^"_Msg - if $data(TMGMSG) set XQADATA=XQADATA_"^"_$$GetErrStr(.TMGMSG) - set XQA(UserIEN)="" - set XQAMSG=Msg - set XQAROU="ERRSHOW^TMGTICKL" - - do SETUP^XQALERT ;"send the alert - - quit - -ERRSHOW - ;"Purpose: To show details about error. - ;"Input: Global-scoped variable XQADATA will hold TklIEN^Msg^FMErrStr - ;" Note: TklIEN could be 0 - ;"Results: none - - write !,! - write "Notice: There was an error processing a tickler message.",! - write "This notice is to provide as much detail as is possible,",! - write "so that the tickler message does not get lost.",!,! - - new TklIEN,Msg,FMErrStr - - if $data(XQADATA)=0 do goto ErShDone - . write "But XQADATA doesn't hold info(??). Aborting.",! - . do PressToCont - - set TklIEN=+$piece(XQADATA,"^",1) - set Msg=$piece(XQADATA,"^",2) - set FMErrStr=$piece(XQADATA,"^",3) - - write "The error message was:",! - write Msg,! - do PressToCont - - if TklIEN>0 do - . write ! - . write "PATIENT:",$$GET1^DIQ(22705.5,TklIEN,.01),! - . write "DOCUMENT:",$$GET1^DIQ(22705.5,TklIEN,.05)," (#",$$GET1^DIQ(22705.5,TklIEN,.05,"I"),")",! - . write "DUE DATE:",$$GET1^DIQ(22705.5,TklIEN,1),! - . write "AUTHOR:",$$GET1^DIQ(22705.5,TklIEN,3),! - . write "AUTHOR:",$$GET1^DIQ(22705.5,TklIEN,3),! - . write "TICKLER STATUS:",$$GET1^DIQ(22705.5,TklIEN,2),! - . write "1st LINE OF MESSAGE:",$$GET1^DIQ(22705.5,TklIEN,5),! - . do PressToCont - - if FMErrStr'="" do - . write !,"The Fileman (database) error message was:",! - . write FMErrStr,! - . do PressToCont - - write !,! - write "Hopefully this will be enough information for you",! - write "to fix the tickler message.",! - write "Please follow up on this NOW....",! - write "This will be the *only* reminder!",!! - do PressToCont - -ErShDone - quit - - -RecheduleTask - ;"Purpose: to set up task to periodically handle tickler messages. - ;"Result: None - - new temp set temp=1 - if temp=0 quit ;"a debugging measure so that launching a duplicate task can be avoided - - new ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU - new ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK - - set ZTRTN="HANDLE^TMGTICKL" - set ZTDESC="TMG TICKLER MESSAGES HANDLER" - set ZTIO="" - - new hrInterval set hrInterval=+$piece($get(^TMG(22705.4,1,0)),"^",2) ;"0;2=Interval - if hrInterval<1 do goto SchTDone - . do SendAlert(DUZ,0,"Tickler Error: Interval (field #1) in file 22705.4 < 1 hr") - . set ZTSK=0 - - new X,Y,%,%DT - set %DT="XR" set X="NOW+"_hrInterval_"H" do ^%DT - set ZTDTH=Y ;"schedule time. - - do ^%ZTLOAD -SchTDone - set $piece(^TMG(22705.4,1,0),"^",3)=ZTSK ;"there are no XRefs on this field, and I own it... - quit - - -;"=========================================================================== -;"Below are copies of functions from TMG Libarary, put here to avoid dependancies -;"=========================================================================== - -PressToCont - ;"Purpose: to provide a 'press key to continue' action - - write "----- Press Key To Continue -----" - new ch read ch:$get(DTIME,3600) - write ! - quit - - -GetErrStr(ErrArray) - ;"Purpose: convert a standard DIERR array into a string for output - ;"Input: ErrArray -- PASS BY REFERENCE. example: - ;" array("DIERR")="1^1" - ;" array("DIERR",1)=311 - ;" array("DIERR",1,"PARAM",0)=3 - ;" array("DIERR",1,"PARAM","FIELD")=.02 - ;" array("DIERR",1,"PARAM","FILE")=2 - ;" array("DIERR",1,"PARAM","IENS")="+1," - ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers." - ;" array("DIERR","E",311,1)="" - ;"Results: returns one long equivalent string from above array. - ;"Note: This is a copy of the function GetErrStr^TMGDEBUG - ;" I copied it here so that this file has no TMG* dependencies. - - new ErrStr - new TMGIDX - new ErrNum - - set ErrStr="" - for ErrNum=1:1:+$get(ErrArray("DIERR")) do - . set ErrStr=ErrStr_"Fileman says: '" - . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") " - . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT","")) - . if TMGIDX'="" for do quit:(TMGIDX="") - . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" " - . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX)) - . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do - . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0)) - . . set ErrStr=ErrStr_"Details: " - . . for do quit:(TMGIDX="") - . . . if TMGIDX="" quit - . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" " - . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX)) - - quit ErrStr Index: cprs/branches/tmg-cprs/m_files/TMGTIUO2.m~ =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTIUO2.m~ (revision 796) +++ (revision ) @@ -1,135 +1,0 @@ -TMGTIU02 ;TMG/TIU Text Object Expansion Fns;04/15/10 - ;;1.0;TMG-LIB;**1**;04/15/10 - ; - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"04/15/10 - ; - ;"======================================================================= - ;"PUBLIC FUNCTIONS - ;"======================================================================= - ; - ;"======================================================================= - ;"PRIVATE FUNCTIONS - ;"======================================================================= - ; - ;"======================================================================= - ; -GETPTFLD(DFN,PARAM) ; - ;"Purpose: This is the server-side code for the TIU TEXT OBJECT, which - ;" will allow the user to retrieve a field from the PATIENT file. - ;"NOTE: This requires that patch TMG-CPRS-TEXTOBJ-PARAM*1.0*1 or later - ;" be installed, to allow passing in of parameters from the CPRS client. - ;"Input: DFN -- This should be the IEN of the currently open patient - ;" Param -- Field(s)^Flags^FormatString. Details below - ;" Field(s) -- required. Options for input: - ;" - A single field number or name - ;" - A list of field numbers (or names), separated by semicolons - ;" - A range of field numbers (or names), in the form M:N, - ;" where M and N are the end points of the inclusive range. - ;" All field numbers within this range are retrieved. - ;" - A '*' for all fields at the top level (no sub-multiple record). - ;" - A '**' for all fields including all fields and data in sub-multiple fields. - ;" - Field number (or name) of a multiple followed by an * to indicate all - ;" fields and records in the sub-multiple for that field. - ;" Invalid field names will be ignored - ;" Flags -- Optional. - ;" - 'F' -- include field name in results with value. e.g. "AGE: 43" instead of just "43" - ;" - This flag is ignored if a FormatString is provided (see below) - ;" - 'S' -- Keep all data values on a single line, separated by ';'. - ;" - If flag not provided, and multiple data fields are requested, - ;" - then the default is that each data value will be separated by a - ;" - CRLF [$C(13)_$C(10)] - ;" - This flag is ignored if a FormatString is provided (see below) - ;" - 'R' -- Resolve fields to NAMES, even if a field NUMBER was used for input request - ;" - Note: this will affect the sorting order of the output (see FormatString - ;" - info below). I.e. if R not specified, and field NUMBERS are used for input, - ;" - then results will be returned in numerical field number order by default. - ;" - If R is specified, then field numbers are converted to field NAMES, and that - ;" - is used to determine the order of output. - ;" - 'N' -- Don't return values for empty fields. This is helpful if ALL fields - ;" - were requested via '*' - ;" FormatString -- A string to determine how results are passed back.... - ;" NOTE: without a format string, results will be passed back in the order returned - ;" by fileman. I.e. if user requested fields "SEX;.01;AGE", then Fileman will - ;" place results into an array, which MUMPS will sort alphabetically, e.g. - ;" .01, then AGE, then SEX. If "*" fields are requested, it would be even - ;" more complex - ;" Format: e.g. "Any arbitrary text %FieldNameOrNum% more text %FieldNameOrNum% ..." - ;" (The goal was to follow the method used by printf in the c language.) - ;" - Any arbitrary text can be included. - ;" - Field numbers or names should be enclosed by the '%' character - ;" These will be replaced with actual data values. - ;" - '\n' can be included to specify line breaks - ;" - '%%' will be used to show a '%' in the output text - ;" - Invalid, or non-matching, field names/numbers will be ignored. - ;" - ;"Results: returns a string that will be sent back to CPRS, to be included in a text note - ;"NOTE: I have chosen to make this function work with only file 2 (PATIENT FILE). I think - ;" it could be a security violation if any CPRS user was able to look at any arbitrary file. - ;" - ;"Examples of PARAM inputs: - ;" '.01' -- returns .01 field, which is the patients NAME, e.g. "SMITH,JOHN A" - ;" 'NAME' -- returns same value as above, e.g. "SMITH,JOHN A" - ;" 'NAME^F' -- e.g result "NAME: SMITH,JOHN A" - ;" 'NAME;SEX;AGE^F' --> "AGE: 34"_$C(13)_$C(10)_"NAME: SMITH,JOHN A"_$C(13)_$C(10)_"SEX: MALE" - ;" 'NAME;SEX;AGE^S' --> "34; SMITH,JOHN A; MALE" - ;" 'NAME;SEX;AGE^^"NAME: %NAME%, %AGE% yrs., %SEX%"' --> "NAME: SMITH,JOHN A, 34 YRS., MALE" - ;" - NEW TMGFLDS,TMGFLAGS - NEW TMGFILE SET TMGFILE=2 - NEW RESULT SET RESULT="" - SET PARAM=$GET(PARAM) - SET TMGFLDS=$PIECE(PARAM,"^",1) - IF TMGFLDS="" DO GOTO GPDN - . SET RESULT="ERROR: No input parameter. Example of use: |TMG PATIENT FLD{AGE}|" - SET DFN=$GET(DFN) - IF +DFN'>0 DO GOTO GPDN - . SET RESULT="ERROR: Internal patient value DFN not defined. Contact IRM" - NEW TMGIENS SET TMGIENS=DFN_"," - SET TMGFLAGS="" - NEW TMGTEMP SET TMGTEMP=$$UP^XLFSTR($PIECE(PARAM,"^",2)) - IF TMGTEMP["N" SET TMGFLAGS=TMGFLAGS_"N" - IF TMGTEMP["F" SET TMGFLAGS=TMGFLAGS_"R" - NEW TMGFORMAT SET TMGFORMAT=$PIECE(PARAM,"^",3) - NEW TMGOUT,TMGMSG - DO GETS^DIQ(TMGFILE,TMGIENS,TMGFLDS,TMGFLAGS,"TMGOUT","TMGMSG") - IF $DATA(TMGMSG("DIERR")) DO GOTO GPDN - . SET RESULT=$$GetErrStr^TMGDEBUG(.TMGMSG) - NEW FLD,FLDNAME - SET FLD="" - IF TMGFORMAT="" DO - . FOR SET FLD=$ORDER(TMGOUT(TMGFILE,TMGIENS,FLD)) QUIT:(FLD="") DO - . . IF $DATA(TMGOUT(TMGFILE,TMGIENS,FLD,0)) QUIT ;"For now, WP fields are not supported. Could add later if needed. - . . NEW VALUE SET VALUE=$GET(TMGOUT(TMGFILE,TMGIENS,FLD)) - . . IF VALUE="",TMGTEMP["N" QUIT - . . IF RESULT'="" DO - . . . IF TMGTEMP["S" SET RESULT=RESULT_"; " - . . . ELSE SET RESULT=RESULT_$CHAR(13)_$CHAR(10) - . . IF TMGTEMP["F" DO - . . . IF FLD'=+FLD SET FLDNAME=FLD - . . . ELSE SET FLDNAME=$PIECE($GET(^DD(TMGFILE,FLD,0)),"^",1) - . . . SET RESULT=RESULT_FLDNAME_": " - . . SET RESULT=RESULT_VALUE - ELSE DO ;"Handle format strings. - . SET RESULT=TMGFORMAT - . FOR QUIT:(RESULT'["%") DO - . . NEW SUBA,SUBB - . . SET SUBA=$PIECE(RESULT,"%",1) - . . SET FLD=$PIECE(RESULT,"%",2) - . . SET SUBB=$PIECE(RESULT,"%",3,999) - . . NEW VALUE - . . IF FLD="" SET VALUE="<@!@>" ;"protect %%, later convert back to '%' - . . ELSE SET VALUE=$GET(TMGOUT(TMGFILE,TMGIENS,FLD)) - . . IF VALUE="" DO - . . . IF FLD=+FLD DO - . . . . SET FLD=$PIECE($GET(^DD(TMGFILE,FLD,0)),"^",1) ;"Convert # to name - . . . ELSE DO - . . . . SET FLD=$ORDER(^DD(TMGFILE,"B",FLD,"")) ;"Convert name to # - . . . IF FLD'="" SET VALUE=$GET(TMGOUT(TMGFILE,TMGIENS,FLD)) - . . . IF VALUE="" SET VALUE="??" - . . SET RESULT=SUBA_VALUE_SUBB - . NEW TMGALT SET TMGALT("<@!@>")="%" - . SET RESULT=$$REPLACE^XLFSTR(RESULT,.TMGALT) - ; -GPDN QUIT RESULT Index: cprs/branches/tmg-cprs/m_files/TMGUSRIF.m.bak =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGUSRIF.m.bak (revision 796) +++ (revision ) @@ -1,1228 +1,0 @@ -TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06 - ;;1.0;TMG-LIB;**1**;07/12/05 - - ;"TMG USER INTERFACE API FUNCTIONS - ;"Kevin Toppenberg MD - ;"GNU General Public License (GPL) applies - ;"7-12-2005 - - ;"======================================================================= - ;" API -- Public Functions. - ;"======================================================================= - - ;"PopupArray^TMGUSRIF(IndentW,Width,Array,Modal) - ;"PopupBox^TMGUSRIF(Header,Text,[Width]) - ;"ProgressBar^TMGUSRIF(value,label,min,max,width,startTime) - ;"PressToCont^TMGUSRIF - ;"$$KeyPressed^TMGUSRIF(wantChar,waitTime) - ;"$$Read^TMGUSRIF(Terminators,timeOut,Num,initialVal) -- custom read function with custom terminators - ;"$$UserAborted^TMGUSRIF() - ;"Selector(pArray,pResults,Header) -- select from an array - ;"Slctor2(pArray,pResults,Header) -- select from an array (different input) - ;"IENSelector(pIENArray,pResults,File,Field,Header,Sort) - ;"Menu(Options,defChoice,.UserRaw) - ;"Scroller(pArray,Option) -- Provide a scroll box interfact - - ;"======================================================================= - ;"Private Functions - ;"======================================================================= - ;"XPopupArray(Array,Modal) - ;"ProgTest - - ;"======================================================================= - ;"======================================================================= - ;"DEPENDENCIES - ;"TMGDEBUG,TMGSTUTL,TMGXDLG - ;"======================================================================= - -PopupArray(IndentW,Width,Array,Modal) - ;"PUBLIC FUNCTION - ;"Purpose: To draw a box, of specified Width, and display text - ;"Input: IndentW = width of indent amount (how far from left margin) - ;" Width = desired width of box. - ;" Header = one line of text to put in header of popup box - ;" Array: an array in following format: - ;" Array(0)=Header - ;" Array(1)=Text line 1 - ;" Array(2)=Text line 2 - ;" ... - ;" Array(n)=Text line n - ;" Modal - really only has meaning for those time when - ;" box will be passed to GUI X dialog box. - ;" Modal=1 means stays in foreground, - ;" 0 means leave box up, continue script execution. - ;"Note: Text will be clipped to fit in box. - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupArray") - - set cModal=$get(cModal,"MODAL") - set cDialog=$get(cModal,"UseDialog") - set Modal=$get(Modal,cModal) - new Header - new Text set Text="" - new index,i,S - - ;"Scan array for any needed data substitution i.e. {{...}} - new tempresult - set index=$order(Array("")) - for do quit:index="" - . set S=Array(index) - . ;"set tempresult=$$CheckSubstituteData(.S) ;"Do any data lookup needed - . set Array(index)=S - . set index=$order(Array(index)) - - if $get(DispMode(cDialog)) do goto PUADone - . do XPopupArray(.Array,Modal) - - set IndentW=$get(IndentW,1) ;"default indent=1 - set Header=$get(Array(0)," ") - set Width=$get(Width,40) ;"default=40 - - write ! - ;"Draw top line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "=" - write "+",! - - ;"Draw Header line - do SetStrLen^TMGSTUTL(.Header,Width-4) - for i=1:1:IndentW write " " - write "| ",Header," |..",! - - ;"Draw divider line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "-" - write "+ :",! - - ;"Put out message - set index=$order(Array(0)) -PUBLoop - if index="" goto BtmLine - set S=$get(Array(index)," ") - do SetStrLen^TMGSTUTL(.S,Width-4) - for i=1:1:IndentW write " " - write "| ",S," | :",! - set index=$order(Array(index)) - goto PUBLoop - -BtmLine - ;"Draw Bottom line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "=" - write "+ :",! - - ;"Draw bottom shaddow - for i=1:1:IndentW write " " - write " " - write ":" - for i=1:1:(Width-2) write "." - write ".",! - - write ! - -PUADone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupArray") - quit - - - -XPopupArray(Array,Modal) - ;"Purpose -- to pass the older text popup box onto a X GUI box - - new Title - new Text - new index - new S set S="" - new OneLine - new result - - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set cModal=$get(cModal,"MODAL") - - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"XPopupArray") - - set Title=$get(Array(0)) - set index=$order(Array(0)) - set Modal=$get(Modal,cModalMode) -XPL1 - if index="" goto XPL2 - set OneLine=$get(Array(index)," ") - set OneLine=$translate(OneLine,"""","'") - set S=S_OneLine_"\n" - set index=$order(Array(index)) - goto XPL1 -XPL2 - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Title=",Title) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Text=",S) - set result=$$Msg^TMGXDLG(Title,S,0,0,Modal) - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"XPopupArray") - quit - - - - -PopupBox(Header,Text,Width) - ;"PUBLIC FUNCTION - ;"Purpose: To provide easy text output box - ;"Input: Header -- a short string for header - ;" Text - the text to display - ;" [Width] -- optional width specifier. Value=0 same as not specified - ;" (DBIndent) -- uses a var with global scope (if defined) for indent amount - ;"Note: If text width not specified, and Text is <= 60, - ;" then all will be put on one line. - ;" Otherwise, width is set to 60, and text is wrapped. - ;" Also, text of the message can contain "\n", which will be interpreted - ;" as a new-line character. - ;"Result: none - - - ;"Note: This function can't be exported to a separate package because of dependancies - - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupBox") - - set cNewLn=$get(cNewLn,"\n") - new TextOut - new TextI set TextI=0 - new PartB set PartB="" - new PartB1 set PartB1="" - set Width=+$get(Width,0) - - set TextOut(TextI)=Header - set TextI=TextI+1 - - if Width=0 do - . new HeaderBased - . new NumLines - . new HLen set HLen=$length(Header)+4 - . new TLen set TLen=$length(Text)+4 - . if TLen>HLen do - . . set Width=TLen - . . set HeaderBased=0 - . else do - . . set Width=HLen - . . set HeaderBased=1 - . if Width>75 set Width=75 - . set NumLines=TLen/Width - . if TLen#Width>0 set NumLines=NumLines+1 - . if (NumLines>1)&(HeaderBased=0) do - . . set Width=(TLen\NumLines)+4 - . . if Width75 set Width=75 - -PUWBLoop ;"Load string up into Text array, to pass to PopupArray - if Text[cNewLn do - . do CleaveStr^TMGSTUTL(.Text,cNewLn,.PartB1) - do SplitStr^TMGSTUTL(.Text,(Width-4),.PartB) - set PartB=PartB_PartB1 set PartB1="" - set TextOut(TextI)=Text - set TextI=TextI+1 - if $length(PartB)>0 do goto PUWBLoop - . set Text=PartB - . set PartB="" - - do PopupArray(.DBIndent,Width,.TextOut) - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupBox") - quit - - -ProgressBar(value,label,min,max,width,startTime) - ;"Purpose: to draw a progress bar on a line of the screen - ;"Input: - ;" value -- the current value to graph out - ;" label -- OPTIONAL -- a label to describe progres. Default="Progress" - ;" max -- OPTIONAL -- the max number that value will be. Default is 100 - ;" min -- OPTIONAL -- the minimal number that value will be. Default is 0 - ;" width -- OPTIONAL -- the number of characters that the progress bar - ;" will be in width. Default is 70 - ;" startTime -- OPTIONAL -- start time of process. If provided, it will - ;" be used to determine remaining time. Format should be same as $H - ;"Note: will use global ^TMP("TMG","PROGRESS-BAR",$J) - ;"Note: bar will look like this: - ;" Progress: 27%-------->|-----------------------------------| - ;" - ;"Result: None - - ;"FYI -- The preexisting way to do this, from Dave Whitten - ;" - ;"Did you try using the already existing function to do this? - ;"ie: try out this 'mini program' - ;">; need to set up vars like DUZ,DTIME, IO, IO(0), etc. - ;" D INIT^XPDID - ;" S XPDIDTOT=100 - ;" D TITLE^XPDID("hello world") - ;" D UPDATE^XPDID(50) - ;" F AJJ=90:1:100 D UPDATE^XPDID(I) - ;" D EXIT^XPDID() - ;" - ;"The XPDID routine does modify the scroll region and make the - ;"application seem a bit more "GUI"-like, by the way... - ;" - ;"David - - new NakedRef set NakedRef=$$LGR^TMGIDE ;"save naked reference - do ;"Turn off cursor display, to prevent flickering - . new $etrap set $etrap="" - . xecute ^%ZOSF("TRMOFF") - - set max=+$get(max,100),min=+$get(min,0) - set width=+$get(width,70) - set label=$get(label,"Progress") - - new premark,i,postmark,pct - if (max-min)=0 set pct=0 - else set pct=(value-min)/(max-min) - if pct>1 set pct=1 - if pct<0 set pct=0 - if (pct<1)&($get(startTime)="") set startTime=$H - - ;"set startTime=+$get(startTime) - set startTime=$get(startTime) ;" +$get 61053,61748 --> 61053 - new pRefCt set pRefCt=$name(^TMP("TMG","PROGRESS-BAR",$J)) - new curRate set curRate="" - if $get(@pRefCt@("START-TIME"))=startTime do - . new interval set interval=$get(@pRefCt@("SAMPLING","INTERVAL"),10) - . set curRate=$get(@pRefCt@("LATEST-RATE")) - . new count set count=$get(@pRefCt@("SAMPLING","COUNT"))+1 - . if count#interval=0 do - . . new deltaT,deltaV - . . set deltaT=$$HDIFF^XLFDT($H,$get(@pRefCt@("SAMPLING","REF-TIME")),2) - . . if deltaT=0 set interval=interval*2 - . . else if deltaT>1000 set interval=interval\1.5 - . . set deltaV=value-$get(@pRefCt@("SAMPLING","VALUE COUNT")) - . . if deltaV>0 set curRate=deltaT/deltaV ;"dT/dValue - . . else set curRate="" - . . set @pRefCt@("LATEST-RATE")=curRate - . . set @pRefCt@("SAMPLING","REF-TIME")=$H - . . set @pRefCt@("SAMPLING","VALUE COUNT")=value - . set @pRefCt@("SAMPLING","COUNT")=count#interval - . set @pRefCt@("SAMPLING","INTERVAL")=interval - else do - . kill @pRefCt - . set @pRefCt@("START-TIME")=startTime - . set @pRefCt@("SAMPLING","COUNT")=0 - . set @pRefCt@("SAMPLING","REF-TIME")=$H - . set @pRefCt@("SAMPLING","VALUE COUNT")=value - - new timeStr set timeStr=" " - new remainingT set remainingT="" - new delta set delta=0 - - if curRate'="" do - . new remainV set remainV=(max-value) - . if remainV'<0 do - . . set remainingT=curRate*remainV - . else do - . . set delta=-1,remainingT=$$HDIFF^XLFDT($H,startTime,2) - else if $data(startTime) do - . if pct=0 quit - . set timeStr="" - . set delta=$$HDIFF^XLFDT($H,startTime,2) - . if delta<0 set remainingT=-delta ;"just report # sec's overrun. - . set remainingT=delta*((1/pct)-1) - - if remainingT'="" do - . new days set days=remainingT\86400 ;"86400 sec per day. - . if days>5 set timeStr=" " quit - . set remainingT=remainingT#86400 - . new hours set hours=remainingT\3600 ;"3600 sec per hour - . set remainingT=remainingT#3600 - . new mins set mins=remainingT\60 ;"60 sec per min - . new secs set secs=(remainingT#60)\1 - . if days>0 set timeStr=timeStr_days_"d, " - . if hours>0 set timeStr=timeStr_hours_"h:" - . if (min=0)&(secs=0) do - . . set timeStr=" " - . else do - . . set timeStr=timeStr_mins_":" - . . if secs<10 set timeStr=timeStr_"0" - . . set timeStr=timeStr_secs_" " - . if delta<0 set timeStr="+"_timeStr ;"just report # sec's overrun. - - ;"set width=width-$length(label)-10 ;"was 9 - set width=width-$length(label)-($length(timeStr)+1) - set premark=(width*pct)\1 - set postmark=width-premark - - new barberPole set barberPole=+$get(@pRefCt@("BARBER POLE")) - if $get(@pRefCt@("BARBER POLE","LAST INC"))'=$H do - . set barberPole=(barberPole-1)#4 - . set @pRefCt@("BARBER POLE")=barberPole ;"should be 0,1,2, or 3) - . set @pRefCt@("BARBER POLE","LAST INC")=$H - - write label,":" - if pct<1 write " " - if pct<0.1 write " " - write (pct*100)\1,"% " - for i=0:1:premark-1 do - . if (barberPole+i)#4=0 write "~" - . else write "-" - write ">|" - for i=1:1:(postmark-1) write "-" - if postmark>0 write "| " - write timeStr - - ;"write $char(13) set $X=0 - write ! - do CUU^TMGTERM(1) - -PBDone - do ;"Turn cursor display back on. - . ;"new $etrap set $etrap="" - . ;"xecute ^%ZOSF("TRMON") - . ;"U $I:(TERMINATOR=$C(13,127)) - - new discard set discard=$get(@NakedRef) ;"reset naked reference. - quit - - -PressToCont - ;"Purpose: to provide a 'press key to continue' action - ;"result: none - ;"Output: will set TMGPTCABORT=1 if user entered ^ - - write "----- Press Key To Continue -----" - new ch set ch=$$KeyPressed^TMGUSRIF(0,240) - if (ch=94) set TMGPTCABORT=1 ;"set abort user entered ^ - else kill TMGPTCABORT - write ! - quit - - -UserAborted(AbortLabel) - ;"Purpose: Checks if user pressed ESC key. If so, then ask if abort wanted - ;"Note: return is immediate. - ;"Returns: 1 if user aborted, 0 if not. - - new result set result=0 - if $$KeyPressed=27 do - . new % set %=2 - . write !,"Abort" - . if $get(AbortLabel)'="" do - . . write " "_AbortLabel - . do YN^DICN write ! - . set result=(%=1) - - quit result - - -KeyPressed(wantChar,waitTime) - ;"Purpose: to check for a keypress - ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value - ;" waitTime -- OPTIONAL, default is 0 (immediate return) - ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) - ;"Note: this does NOT wait for user to press key - - new temp - set waitTime=$get(waitTime,0) - read *temp:waitTime - if $get(wantChar)=1 set temp=$char(temp) - quit temp - - -Read(Terminators,timeOut,Num,initialVal,EscKey) - ;"Purpose: a custom read function with custom terminators - ;"Input: Terminators -- OPTIONAL Flags to specify characters that will signal that - ;" the user is done with input. Flags as follows: - ;" r = return/enter - ;" t = tab - ;" s = space - ;" e = escape - ;" b = backspace - ;" NONE = no terminators - ;" e.g. 'rte' means that if user enters a return, tab, or escape - ;" then input it ended, and characters (up to, but not including - ;" terminator) entered are returned. - ;" e.g. 'NONE' --> NO terminators. NOTE: MUST supply a number - ;" characters to read, or endless loop will result. - ;" If Terminator="", then default value of 'r' is used - ;" timeOut -- Optional -- the allowed lengh of time to wait before timeout. - ;" default value is 999,999 seconds (~11 days) - ;" Num -- OPTIONAL -- a number of characters to read, e.g. 5 to read just - ;" 5 characters (or less than 5 if terminator encountered) - ;" initialVal-- OPTIONAL -- This can be a value that presents the output - ;" It also allows editing of former inputs. Note: this function - ;" assumes that initialValue has been printed to the screen before - ;" calling this function. - ;" EscKey-- OPTIONAL -- PASS BY REFERENCE, an OUT PARAMETER - ;" if Terminator includes "e", then EscKey will be filled - ;" with a translated value for esc sequence, e.g. UP - ;" (as found in ^XUTL("XGKB",*)) - ;" - ;"Result: returns characters read. - - new result set result=$get(initialVal) - set timeOut=+$get(timeOut,999999) - new len set len=0 - set Num=$get(Num) - set Terminators=$get(Terminators) - if Terminators="" set Terminators="r" - else if Terminators="NONE" set Terminators="" - new temp - new done set done=0 - set EscKey="" - - ;"NOTE, I could rewrite this to use built in terminators functions... - ;"e.g. U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))" - -RLoop xecute ^%ZOSF("EOFF") ;"echo off - if Terminators["e" use $I:ESCAPE - read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a') - if Terminators["e" use $I:NOESCAPE - xecute ^%ZOSF("EON") - if (temp=13)&(Terminators["r") do - . set done=1 - else if (temp=9)&(Terminators["t") do - . set done=1 - else if (temp=32)&(Terminators["s") do - . set done=1 - else if (temp=27)&(Terminators["e") do - . set EscKey=$get(^XUTL("XGKB",$ZB)) - . set done=1 - else if (temp=127)&(Terminators["b") do - . set done=1 - else if (temp'=-1) do - . if temp=127 do quit - . . if result="" quit - . . set result=$extract(result,1,$length(result)-1) - . . write $char(8)," ",$char(8) - . set result=result_$char(temp) - . write $char(temp) - . if Num="" quit - . if $length(result)'<+Num set done=1 - - if 'done goto RLoop - - quit result - - -IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray) - ;"Purpose: to allow selecting records from an IEN array - ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from - ;" format: - ;" @pIENArray@(IEN)="" - ;" @pIENArray@(IEN)="" - ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array WILL be KILLED first - ;" Format of returned array: Only those valuse that user selected will - ;" be aded to list - ;" @pResults@(IEN)=DisplayLineNumber - ;" @pResults@(IEN)=DisplayLineNumber - ;" File: The file that IEN's are from. - ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default - ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1". - ;" Widths: Optional. The widths of the columns to display Fields in. - ;" Format: e.g. "10;12;24" for three colums of widths: - ;" Sequence must match sequence given in Fields - ;" Default is to evenly space colums - ;" Header -- OPTIONAL -- A header text to show. - ;" SortFlds -- OPTIONAL -- Provide sorting fields - ;" Format: 'FldNum1;FldNum2;FldNum3...' - ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE, - ;" This variable will be filled with the NAME of the array - ;" used for displaying the array. The FIRST time this function - ;" is called, this variable should = "". On SUBSEQUENT calls, - ;" if this variable holds the name of a variable (a reference), then - ;" that array will be used, rather than taking the time to create - ;" the display array again. Format of array: - ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... - ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... - ;" Note: The LineNumber is the same number as the DisplayLineNumber - ;" returned in @pResults@(IEN)=DisplayLineNUmber - ;"Results: none - - if $get(pResults)'="" kill @pResults - new PreSelArray - new ref - if $get(SaveArray)="" do - . set ref=$name(^TMP("VEE",$J)) - . kill @ref - . set SaveArray=ref - else do goto IS1 ;"Skip recreating array if SaveArray holds reference - . set ref=SaveArray - - new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT")) - kill @ref2 - if $get(Header)'="" set @ref@("HD")=Header - set Sort=$get(Sort,0) - set IOM=$get(IOM,80) - set Fields=$get(Fields,".01") - set Widths=$get(Widths) - new Sort set Sort=($data(SortFlds)'=0) - - ;"Setup FldArray. Format: - ;" FldArray=number of colums - ;" FldArray(Sequence#)=field;fieldWidth - ;" FldArray(Sequence#)=field;fieldWidth - ;" FldArray(Sequence#)=field;fieldWidth - new FldArray,i - set FldArray=0 - new WRemain set WRemain=IOM - for i=1:1:$length(Fields,";") do - . new Fld,W - . set Fld=$piece(Fields,";",i) - . if Fld="" quit - . set W=+$piece(Widths,";",i) - . if W=0 do - . . if FldArray>0 set W=IOM/FldArray - . . else set W=20 ;"some arbitrary number - . if W>WRemain set W=WRemain ;"this isn't perfect - . set WRemain=WRemain-W - . if WRemain<1 set WRemain=1 - . set FldArray(i)=Fld_";"_W - . set FldArray=FldArray+1 - - new Itr,IEN,name,PriorErrorFound - new abort set abort=0 - new order set order=1 - new IENPreSelected - write "Prepairing list to display..." - set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr) - do PrepProgress^TMGITR(.Itr,100,0,"IEN") - write ! - if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1) - . new TMGOUT,TMGMSG,IENS,showS,i - . set showS="" - . set IENS=IEN_"," - . new tempFields - . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0) - . new i for i=1:1:FldArray do - . . if showS'="" set showS=showS_"|" - . . new Fld,tempS - . . set Fld=$piece(FldArray(i),";",1) - . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG") - . . if $data(TMGMSG("DIERR")) do set abort=1 quit - . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) - . . new W set W=$piece(FldArray(i),";",2) - . . set tempS=$extract(tempS,1,W) - . . if Sort set tempFields(Fld)=tempS - . . set showS=showS_$$LJ^XLFSTR(tempS,W," ") - . if Sort=0 do - . . set @ref@(order)=IEN_$char(9)_showS - . . if IENPreSelected set PreSelArray(order)="" - . . set order=order+1 - . else do - . . new tempRef set tempRef=ref2 - . . for i=1:1:$length(SortFlds,";") do - . . . new oneFld set oneFld=$piece(SortFlds,";",i) - . . . new F set F=$get(tempFields(oneFld)) - . . . if F="" quit - . . . set tempRef=$name(@tempRef@(F)) - . . set @tempRef@(IEN)=IEN_$char(9)_showS - . . if IENPreSelected set @tempRef@(IEN,"SEL")="" - . . ;"Sets up sorted variable as follows: - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - do ProgressDone^TMGITR(.Itr) - write ! - - if abort=1 goto ISDone - -IES1 if Sort=1 do - . write "Sorting... " - . set order=1 - . new tempRef2 set tempRef2=ref2 - . new showS,NumNodes,Done - . set Done=0 - . for do quit:(tempRef2="")!(Done=1) - . . set tempRef2=$query(@tempRef2) - . . if (tempRef2="") quit - . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit - . . . set PreSelArray(order-1)="" - . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit - . . set showS=$get(@tempRef2) - . . set @ref@(order)=showS - . . set order=order+1 - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" @ref@("HD")=Header to display - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") -IS1 - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - write "Passing off to selector..." - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format results - new Itr2,index - set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2) - if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="") - . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1) - . set @pResults@(s)=index - - kill ^TMP("VPE","SELECT",$J) - if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT") - -ISDone - quit - - -Selector(pArray,pResults,Header) - ;"Purpose: Interface with VPE Selector code to select from an array - ;"Input: pArray -- NAME OF array holding items to be selected from - ;" Expected format: - ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional - ;" @pArray@("Display Choice Words")=ReturnValue - ;" @pArray@("Display Choice Words")=ReturnValue - ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array will NOT be KILLED first - ;" Format of returned array: Only those valuse that user selected will be returned - ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional - ;" @pResults@("Display Choice Words")=ReturnValue - ;" @pResults@("Display Choice Words")=ReturnValue - ;" Header -- OPTIONAL -- A header text to show. - - new ref set ref=$name(^TMP("VEE",$J)) - kill @ref - if $get(pArray)="" goto SelDone - if $get(pResults)="" goto SelDone - - new PreSelArray - - ;"First set up array of options - new DispWords,RtnValue - new order set order=1 - set DispWords=$order(@pArray@("")) - if DispWords'="" for do quit:(DispWords="") - . set RtnValue=$get(@pArray@(DispWords),"") - . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) - . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected - . set order=order+1 - . set DispWords=$order(@pArray@(DispWords)) - - if $get(Header)'="" set @ref@("HD")=Header - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") - - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format selected options. - new index set index=$order(^TMP("VPE","SELECT",$J,"")) - if index'="" for do quit:(index="") - . new s,s1,s2 - . set s=$get(^TMP("VPE","SELECT",$J,index)) - . set s1=$piece(s,$char(9),1) - . set s2=$piece(s,$char(9),2) - . set @pResults@(s2)=s1 - . set index=$order(^TMP("VPE","SELECT",$J,index)) - - kill ^TMP("VPE","SELECT",$J) - kill @ref - -SelDone - quit - - -Slctor2(pArray,pResults,Header) - ;"Purpose: Interface with VPE Selector code to select from an array - ;" Note: This allows a different format of input. In Selector() above, - ;" it is NOT possible to have two similar Display Words with - ;" different return values. E.g. two drugs with LISINOPRIL, but - ;" different IEN return values. This fn allows this - ;"Input: pArray -- NAME OF array holding items to be selected from - ;" Expected format: - ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required - ;" @pArray@("Display Choice Words",ReturnValue)="" - ;" @pArray@("Display Choice Words",ReturnValue)="" - ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array will NOT be KILLED first - ;" Format of returned array: Only those values that user selected will be returned - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" Header -- OPTIONAL -- A header text to show. - - new ref set ref=$name(^TMP("VEE",$J)) - kill @ref - if $get(pArray)="" goto Sl2Done - if $get(pResults)="" goto Sl2Done - - new PreSelArray - - ;"First set up array of options - new DispWords,RtnValue - new order set order=1 - set DispWords="" - for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do - . set RtnValue="" - . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do - . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) - . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected - . . set order=order+1 - - if $get(Header)'="" set @ref@("HD")=Header - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") - - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format selected options. - new index set index=$order(^TMP("VPE","SELECT",$J,"")) - if index'="" for do quit:(index="") - . new s,s1,s2 - . set s=$get(^TMP("VPE","SELECT",$J,index)) - . set s1=$piece(s,$char(9),1) - . set s2=$piece(s,$char(9),2) - . set @pResults@(s2,s1)="" - . set index=$order(^TMP("VPE","SELECT",$J,index)) - - kill ^TMP("VPE","SELECT",$J) - kill @ref - -Sl2Done - quit - - - - -Menu(Options,defChoice,UserRaw) - ;"Purpose: to provide a simple menuing system - ;"Input: Options -- PASS BY REFERENCE - ;" Format: - ;" Options(0)=Header Text <--- optional, default is MENU - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue - ;" defChoice: OPTIONAL, the default menu value - ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input - ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort - - new result set result="^" - new s,fg,bg - new width set width=50 - new line set $piece(line,"=",width+1)="" -MNU1 - if $data(Options(-1,"COLOR")) do - . set fg=$get(Options(-1,"COLOR","fg"),0) - . set bg=$get(Options(-1,"COLOR","bg"),1) - . do VCOLORS^TMGTERM(fg,bg) - write line,! - write $get(Options(0),"MENU"),$$Pad2Pos^TMGSTUTL(width),! - write line,! - write "Options:",$$Pad2Pos^TMGSTUTL(width),! - - new DispNumber set DispNumber=$order(Options(0)) - if DispNumber'="" for do quit:(DispNumber="") - . set s=$get(Options(DispNumber)) - . write $$RJ^XLFSTR(DispNumber,4),".",$$Pad2Pos^TMGSTUTL(6) - . if $data(Options(DispNumber,"COLOR")) do - . . set fg=$get(Options(DispNumber,"COLOR","fg"),0) - . . set bg=$get(Options(DispNumber,"COLOR","bg"),1) - . . do VCOLORS^TMGTERM(fg,bg) - . write $piece(s,$char(9),1),$$Pad2Pos^TMGSTUTL(width) - . if $data(Options(DispNumber,"COLOR")) do - . . do VTATRIB^TMGTERM(0) ;"Reset colors - . write " ",! - . set DispNumber=$order(Options(DispNumber)) - - write line,! - - set defChoice=$get(defChoice,"^") - new input - write "Enter selection (^ to abort): ",defChoice,"// " - read input:$get(DTIME,3600),! - if input="" set input=defChoice - set UserRaw=input - if input="^" goto MNUDone - - set s=$get(Options(input)) - if s="" set s=$get(Options($$UP^XLFSTR(input))) - ;"if s="" write "??",!! goto MNU1 - set result=$piece(s,$char(9),2) - if result="" set result=input - -MNUDone - if $data(Options(-1,"COLOR")) do VTATRIB^TMGTERM(0) ;"Reset colors - quit result - - -ProgTest - ;"Purpose: test progress bar. - new i,u,max - set max=1000 - for i=0:1:max do - . do ProgressBar(i,"%",1,max) - for i=0:1:max do - . do ProgressBar(i,"%",1,max) - quit - - -Scroller(pArray,Option) - ;"Purpose: Provide a scroll box - ;"Input: pArray -- PASS BY NAME. format: - ;" @pArray@(1,DisplayText)=Return Text <-- note: must be numbered 1,2,3 etc. - ;" @pArray@(2,DisplayText)=Return Text - ;" @pArray@(3,DisplayText)=Return Text - ;" NOTE: if Display text contains {{name}} then name is taken as color directive - ;" Example: 'Here is {{BOLD}}something{{NORM}} to see.' - ;" if NAME is not defined in Option("COLORS",NAME), it is ignored - ;" Option -- PASS BY REFERENCE. format: - ;" Option("HEADER",1)=Header line text - ;" Option("HEADER",2)=More Header line text (any number of lines) - ;" Option("FOOTER",1)=Footer line text <--- Option 1 - ;" Option("FOOTER",1,1)=linePart <--- Option 2 (these will be all strung together to make one footer line. - ;" Option("FOOTER",1,2)=linePart (can be used to display switches etc) - ;" Option("FOOTER",2)=More footer line text (any number of lines) - ;" Option("SHOW INDEX")=1 Optional. If 1, then index is shown. - ;" Option("SCRN WIDTH")= Optional screen width. (default is terminal width) - ;" ---- Colors (optional) ------ - ;" Option("COLORS","NORM")=FG^BG -- default foreground (FG) and background(colors) - ;" If not provided, White on Blue used. - ;" Option("COLORS","HIGH")=FG^BG -- Highlight colors. If not provided, White on Cyan used. - ;" Option("COLORS","HEADER")=FG^BG Header color. NORM used if not provided - ;" Option("COLORS","FOOTER")=FG^BG Footer color. NORM used if not provided - ;" Option("COLORS","TOP LINE")=FG^BG Top line color. NORM used if not provided - ;" Option("COLORS","BOTTOM LINE")=FG^BG Bottom line color. NORM used if not provided - ;" Option("COLORS","INDEX")=FG^BG Index color. NORM used if not provided - ;" Option("COLORS",SomeName)=FG^BG e.g. : - ;" Option("COLORS","BOLD")=15^0 (Any arbitrary name OK, matched to {{name}} in text) - ;" Option("COLORS","HIGH")=10^@ - ;" If BG="@", then default BG used. This may be used anywhere except for defining NORM - ;" ---- events ---- - ;" Option("ON SELECT")="FnName^Module" -- code to call based on user input - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ;" Option("ON CHANGING")="FnName^Module" -- code to execute for number entry - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ;" Info("NEXT LINE","NUMBER")=next line number. Used for ON CHANGING to show the line about to be selected - ;" Info("ALLOW CHANGE")=1, <--- RETURN RESULT. Change to 0 to disallow move. - ;" Option("ON CMD")="FnName^Module" -- code to execute for number entry - ;" Info("USER INPUT")=UserTypedInput - ;" NOTES about events. Functions will be called as follows: - ;" do FnName^Module(pArray,.Option,.Info) - ;" pArray and Option are the same data received by this function - ;" -- thus Option can be used to can other custom information. - ;" Info has extra info as outlined above. - ;" If functions may set a globally-scoped var named TMGSCLRMSG to communicate back - ;" if TMGSCLRMSG="^" then Scroller will exit - ;"Result: none - - new scrnW,scrnH,scrnLine,spaceLine,topLine,sizeHdr,sizeFtr - new entryCt,lineCt,EscKey,dispHt,highLine,showIdx - new needRefresh,Info - set topLine=1 - set highLine=5 - new TMGSCLRMSG set TMGSCLRMSG="" - - set scrnW=+$get(Option("SCRN WIDTH")) - if scrnW'>0 do - . if $$GetScrnSize^TMGKERNL(,.scrnW) - . set scrnW=+scrnW-4 - if scrnW'>0 set scrnW=$get(IOM,66)-2 - ;"set scrnW=$get(IOM,60)-2 - set scrnH=$get(IOSL,25)-2 - - if $get(Option("COLORS","NORM"))="" set Option("COLORS","NORM")="14^4" ;"white on blue - if $get(Option("COLORS","HIGH"))="" set Option("COLORS","HIGH")="14^6" ;"white on cyan - if $get(Option("COLORS","HEADER"))="" set Option("COLORS","HEADER")=Option("COLORS","NORM") - if $get(Option("COLORS","FOOTER"))="" set Option("COLORS","FOOTER")=Option("COLORS","NORM") - if $get(Option("COLORS","TOP LINE"))="" set Option("COLORS","TOP LINE")=Option("COLORS","NORM") - if $get(Option("COLORS","BOTTOM LINE"))="" set Option("COLORS","BOTTOM LINE")=Option("COLORS","NORM") - if $get(Option("COLORS","INDEX"))="" set Option("COLORS","INDEX")=Option("COLORS","NORM") - - new i set i="" - for set i=$order(Option("COLORS",i)) quit:(i="") do - . new colors set colors=$get(Option("COLORS",i)) - . new FG set FG=$piece(colors,"^",1) if FG="" set FG=0 - . new BG set BG=$piece(colors,"^",2) if BG="" set BG=1 - . set Option("COLORS",i,"FG")=FG - . set Option("COLORS",i,"BG")=BG - -Full set scrnLine="" set $piece(scrnLine,"-",scrnW)="-" - set spaceLine="" set $piece(spaceLine," ",scrnW)=" " - set sizeHdr=$$ListCt^TMGMISC($name(Option("HEADER")))+1 - set sizeFtr=$$ListCt^TMGMISC($name(Option("FOOTER")))+1 - set entryCt=$$ListCt^TMGMISC(pArray) - set EscKey="" - set dispHt=scrnH-sizeHdr-sizeFtr - if topLine>entryCt set topLine=entryCt - if highLine>entryCt set highLine=entryCt - set showIdx=($get(Option("SHOW INDEX"))=1) - -Draw do HOME^TMGTERM - if $data(Option("HEADER")) do - . do SetColor("HEADER",.Option) - . new i set i="" - . for set i=$order(Option("HEADER",i)) quit:(i="") do - . . write $$CJ^XLFSTR($get(Option("HEADER",i)),scrnW),! - set lineCt=topLine - - ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - do SetColor("TOP LINE",.Option) - write scrnLine,! - do SetColor("NORM",.Option) - for quit:(lineCt=(dispHt+topLine-1)) do - . ;"if lineCt=highLine do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background - . ;"else do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - . if lineCt=highLine do SetColor("HIGH",.Option) - . else do SetColor("NORM",.Option) - . new s set s="" - . if showIdx do - . . do SetColor("INDEX",.Option) - . . write $$RJ^XLFSTR(lineCt,3)_"." - . . if lineCt=highLine do SetColor("HIGH",.Option) - . . else do SetColor("NORM",.Option) - . . write " " - . new text,textA,textB,textColor - . set text=$order(@pArray@(lineCt,"")) - . for quit:(text'["{{")!($X' TextA{{Color}}Text - . . if $X+$length(textA)>scrnW do - . . . write $extract(textA,1,(scrnW-$X-3))_"..." - . . else write textA - . . do SetColor(textColor,.Option) - . write text - . write $extract(spaceLine,1,(scrnW-$X)) - . do SetColor("RESET") write ! - . ;"if showIdx set s=$$RJ^XLFSTR(lineCt,3)_". " - . ;"set s=$$LJ^XLFSTR(s_$order(@pArray@(lineCt,"")),scrnW) - . ;"if $length(s)>scrnW set s=$extract(s,1,scrnW-3)_"..." - . ;"write s,! - . set lineCt=lineCt+1 - ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - do SetColor("BOTTOM LINE",.Option) - write scrnLine,! - do SetColor("FOOTER",.Option) - ;"do VTATRIB^TMGTERM(0) ;"reset colors - if $data(Option("FOOTER")) do - . new i set i="" - . for set i=$order(Option("FOOTER",i)) quit:(i="") do - . . new j set j=$order(Option("FOOTER",i,"")) - . . if j'="" do - . . . new oneLine set oneLine="",j="" - . . . for set j=$order(Option("FOOTER",i,j)) quit:(j="") do - . . . . set oneLine=oneLine_$get(Option("FOOTER",i,j))_" | " - . . . write $$LJ^XLFSTR(oneLine,scrnW),! - . . else write $$LJ^XLFSTR($get(Option("FOOTER",i)),scrnW),! - - set Info("CURRENT LINE","NUMBER")=highLine - set Info("CURRENT LINE","TEXT")=$order(@pArray@(highLine,"")) - set Info("CURRENT LINE","RETURN")=$get(@pArray@(highLine,Info("CURRENT LINE","TEXT"))) - - do SetColor("RESET") - write $$LJ^XLFSTR(": ",scrnW),! - do CUU^TMGTERM(1) write ": " - set needRefresh=0 -UsrIn set input=$$Read("re",,,,.EscKey) - if (input="")&(EscKey="") set EscKey="CR" - if EscKey="UP" set input="UP^1" - if EscKey="PREV" set input="UP^15" - if EscKey="DOWN" set input="DOWN^1" - if EscKey="NEXT" set input="DOWN^15" - if EscKey="CR" do goto Lp2 - . new codeFn set codeFn=$get(Option("ON SELECT")) quit:(codeFn="") - . set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . xecute codeFn - . set needRefresh=2 - if input="^" goto ScrlDone - if (input["^") do goto Lp2 - . if $piece(input,"^",1)="UP" do - . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . . new codeFn set codeFn=$get(Option("ON CHANGING")) - . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . . set Info("ALLOW CHANGE")=1 - . . set needRefresh=1 - . . new j for j=1:1:+$piece(input,"^",2) do - . . . if highLine>topLine do - . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set highLine=highLine-1 - . . . else if topLine>1 do - . . . . set Info("NEXT LINE","NUMBER")=(topLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set topLine=topLine-1,highLine=topLine - . else if $piece(input,"^",1)="DOWN" do - . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . . new codeFn set codeFn=$get(Option("ON CHANGING")) - . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . . set Info("ALLOW CHANGE")=1 - . . set needRefresh=1 - . . new j for j=1:1:+$piece(input,"^",2) do - . . . if highLine<(topLine+dispHt-2) do - . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set highLine=highLine+1 - . . . else if (topLine+dispHt-2)0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupArray") - - set cModal=$get(cModal,"MODAL") - set cDialog=$get(cModal,"UseDialog") - set Modal=$get(Modal,cModal) - new Header - new Text set Text="" - new index,i,S - - ;"Scan array for any needed data substitution i.e. {{...}} - new tempresult - set index=$order(Array("")) - for do quit:index="" - . set S=Array(index) - . ;"set tempresult=$$CheckSubstituteData(.S) ;"Do any data lookup needed - . set Array(index)=S - . set index=$order(Array(index)) - - if $get(DispMode(cDialog)) do goto PUADone - . do XPopupArray(.Array,Modal) - - set IndentW=$get(IndentW,1) ;"default indent=1 - set Header=$get(Array(0)," ") - set Width=$get(Width,40) ;"default=40 - - write ! - ;"Draw top line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "=" - write "+",! - - ;"Draw Header line - do SetStrLen^TMGSTUTL(.Header,Width-4) - for i=1:1:IndentW write " " - write "| ",Header," |..",! - - ;"Draw divider line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "-" - write "+ :",! - - ;"Put out message - set index=$order(Array(0)) -PUBLoop - if index="" goto BtmLine - set S=$get(Array(index)," ") - do SetStrLen^TMGSTUTL(.S,Width-4) - for i=1:1:IndentW write " " - write "| ",S," | :",! - set index=$order(Array(index)) - goto PUBLoop - -BtmLine - ;"Draw Bottom line - for i=1:1:IndentW write " " - write "+" - for i=1:1:(Width-2) write "=" - write "+ :",! - - ;"Draw bottom shaddow - for i=1:1:IndentW write " " - write " " - write ":" - for i=1:1:(Width-2) write "." - write ".",! - - write ! - -PUADone - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupArray") - quit - - - -XPopupArray(Array,Modal) - ;"Purpose -- to pass the older text popup box onto a X GUI box - - new Title - new Text - new index - new S set S="" - new OneLine - new result - - set cOKToCont=$get(cOKToCont,1) - set cAbort=$get(cAbort,0) - set cModal=$get(cModal,"MODAL") - - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"XPopupArray") - - set Title=$get(Array(0)) - set index=$order(Array(0)) - set Modal=$get(Modal,cModalMode) -XPL1 - if index="" goto XPL2 - set OneLine=$get(Array(index)," ") - set OneLine=$translate(OneLine,"""","'") - set S=S_OneLine_"\n" - set index=$order(Array(index)) - goto XPL1 -XPL2 - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Title=",Title) - if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Text=",S) - set result=$$Msg^TMGXDLG(Title,S,0,0,Modal) - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"XPopupArray") - quit - - - - -PopupBox(Header,Text,Width) - ;"PUBLIC FUNCTION - ;"Purpose: To provide easy text output box - ;"Input: Header -- a short string for header - ;" Text - the text to display - ;" [Width] -- optional width specifier. Value=0 same as not specified - ;" (DBIndent) -- uses a var with global scope (if defined) for indent amount - ;"Note: If text width not specified, and Text is <= 60, - ;" then all will be put on one line. - ;" Otherwise, width is set to 60, and text is wrapped. - ;" Also, text of the message can contain "\n", which will be interpreted - ;" as a new-line character. - ;"Result: none - - - ;"Note: This function can't be exported to a separate package because of dependancies - - - if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupBox") - - set cNewLn=$get(cNewLn,"\n") - new TextOut - new TextI set TextI=0 - new PartB set PartB="" - new PartB1 set PartB1="" - set Width=+$get(Width,0) - - set TextOut(TextI)=Header - set TextI=TextI+1 - - if Width=0 do - . new HeaderBased - . new NumLines - . new HLen set HLen=$length(Header)+4 - . new TLen set TLen=$length(Text)+4 - . if TLen>HLen do - . . set Width=TLen - . . set HeaderBased=0 - . else do - . . set Width=HLen - . . set HeaderBased=1 - . if Width>75 set Width=75 - . set NumLines=TLen/Width - . if TLen#Width>0 set NumLines=NumLines+1 - . if (NumLines>1)&(HeaderBased=0) do - . . set Width=(TLen\NumLines)+4 - . . if Width75 set Width=75 - -PUWBLoop ;"Load string up into Text array, to pass to PopupArray - if Text[cNewLn do - . do CleaveStr^TMGSTUTL(.Text,cNewLn,.PartB1) - do SplitStr^TMGSTUTL(.Text,(Width-4),.PartB) - set PartB=PartB_PartB1 set PartB1="" - set TextOut(TextI)=Text - set TextI=TextI+1 - if $length(PartB)>0 do goto PUWBLoop - . set Text=PartB - . set PartB="" - - do PopupArray(.DBIndent,Width,.TextOut) - - if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupBox") - quit - - -ProgressBar(value,label,min,max,width,startTime) - ;"Purpose: to draw a progress bar on a line of the screen - ;"Input: - ;" value -- the current value to graph out - ;" label -- OPTIONAL -- a label to describe progres. Default="Progress" - ;" max -- OPTIONAL -- the max number that value will be. Default is 100 - ;" if max=-1 and min=-1 then turn on spin mode (see below) - ;" min -- OPTIONAL -- the minimal number that value will be. Default is 0 - ;" if max=-1 and min=-1 then turn on spin mode (see below) - ;" width -- OPTIONAL -- the number of characters that the progress bar - ;" will be in width. Default is 70 - ;" startTime -- OPTIONAL -- start time of process. If provided, it will - ;" be used to determine remaining time. Format should be same as $H - ;"Note: will use global ^TMP("TMG","PROGRESS-BAR",$J) - ;"Note: bar will look like this: - ;" Progress: 27%-------->|-----------------------------------| (Time) - ;"Note--Spin Mode: To show motion without knowing the max amount, a spin mode is needed. - ;" Progress: |-----<==>--------------------------------------| - ;" And the bar will move back and forth. - ;" In this mode, value is ignored and is thus optional. - ;" To use this mode, set max=-1,min=-1 - ;"Result: None - - ;"FYI -- The preexisting way to do this, from Dave Whitten - ;" - ;"Did you try using the already existing function to do this? - ;"ie: try out this 'mini program' - ;">; need to set up vars like DUZ,DTIME, IO, IO(0), etc. - ;" D INIT^XPDID - ;" S XPDIDTOT=100 - ;" D TITLE^XPDID("hello world") - ;" D UPDATE^XPDID(50) - ;" F AJJ=90:1:100 D UPDATE^XPDID(I) - ;" D EXIT^XPDID() - ;" - ;"The XPDID routine does modify the scroll region and make the - ;"application seem a bit more "GUI"-like, by the way... - ;" - ;"David - - new NakedRef set NakedRef=$$LGR^TMGIDE ;"save naked reference - do ;"Turn off cursor display, to prevent flickering - . new $etrap set $etrap="" - . xecute ^%ZOSF("TRMOFF") - - new premark,i,postmark,pct - new pRefCt set pRefCt=$name(^TMP("TMG","PROGRESS-BAR",$J)) - set max=+$get(max,100),min=+$get(min,0) - set width=+$get(width,70) - set label=$get(label,"Progress") - - new spinMode set spinMode=((max=-1)&(min=-1)) - if spinMode goto Spin1 ;"<-- skip all this for spin mode - - if (max-min)=0 set pct=0 - else set pct=(value-min)/(max-min) - if pct>1 set pct=1 - if pct<0 set pct=0 - if (pct<1)&($get(startTime)="") set startTime=$H - - set startTime=$get(startTime) ;" +$get 61053,61748 --> 61053 - - new barberPole set barberPole=+$get(@pRefCt@("BARBER POLE")) - if $get(@pRefCt@("BARBER POLE","LAST INC"))'=$H do - . set barberPole=(barberPole-1)#4 - . set @pRefCt@("BARBER POLE")=barberPole ;"should be 0,1,2, or 3) - . set @pRefCt@("BARBER POLE","LAST INC")=$H - - new curRate set curRate="" - if $get(@pRefCt@("START-TIME"))=startTime do - . new interval set interval=$get(@pRefCt@("SAMPLING","INTERVAL"),10) - . set curRate=$get(@pRefCt@("LATEST-RATE")) - . new count set count=$get(@pRefCt@("SAMPLING","COUNT"))+1 - . if count#interval=0 do - . . new deltaT,deltaV - . . set deltaT=$$HDIFF^XLFDT($H,$get(@pRefCt@("SAMPLING","REF-TIME")),2) - . . if deltaT=0 set interval=interval*2 - . . else if deltaT>1000 set interval=interval\1.5 - . . set deltaV=value-$get(@pRefCt@("SAMPLING","VALUE COUNT")) - . . if deltaV>0 set curRate=deltaT/deltaV ;"dT/dValue - . . else set curRate="" - . . set @pRefCt@("LATEST-RATE")=curRate - . . set @pRefCt@("SAMPLING","REF-TIME")=$H - . . set @pRefCt@("SAMPLING","VALUE COUNT")=value - . set @pRefCt@("SAMPLING","COUNT")=count#interval - . set @pRefCt@("SAMPLING","INTERVAL")=interval - else do - . kill @pRefCt - . set @pRefCt@("START-TIME")=startTime - . set @pRefCt@("SAMPLING","COUNT")=0 - . set @pRefCt@("SAMPLING","REF-TIME")=$H - . set @pRefCt@("SAMPLING","VALUE COUNT")=value - - new timeStr set timeStr=" " - new remainingT set remainingT="" - new delta set delta=0 - - if curRate'="" do - . new remainV set remainV=(max-value) - . if remainV'<0 do - . . set remainingT=curRate*remainV - . else do - . . set delta=-1,remainingT=$$HDIFF^XLFDT($H,startTime,2) - else if $data(startTime) do - . if pct=0 quit - . set timeStr="" - . set delta=$$HDIFF^XLFDT($H,startTime,2) - . if delta<0 set remainingT=-delta ;"just report # sec's overrun. - . set remainingT=delta*((1/pct)-1) - - if remainingT'="" do - . new days set days=remainingT\86400 ;"86400 sec per day. - . if days>5 set timeStr=" " quit - . set remainingT=remainingT#86400 - . new hours set hours=remainingT\3600 ;"3600 sec per hour - . set remainingT=remainingT#3600 - . new mins set mins=remainingT\60 ;"60 sec per min - . new secs set secs=(remainingT#60)\1 - . if days>0 set timeStr=timeStr_days_"d, " - . if hours>0 set timeStr=timeStr_hours_"h:" - . if (min=0)&(secs=0) do - . . set timeStr=" " - . else do - . . set timeStr=timeStr_mins_":" - . . if secs<10 set timeStr=timeStr_"0" - . . set timeStr=timeStr_secs_" " - . if delta<0 set timeStr="+"_timeStr ;"just report # sec's overrun. - else set timeStr="?? Time" - - set width=width-$length(label)-($length(timeStr)+1) - set premark=(width*pct)\1 - set postmark=width-premark - - if (max-min)=0 set pct=0 - else set pct=(value-min)/(max-min) - if pct>1 set pct=1 - if pct<0 set pct=0 - if (pct<1)&($get(startTime)="") set startTime=$H - - - write label,":" - if pct<1 write " " - if pct<0.1 write " " - write (pct*100)\1,"% " - for i=0:1:premark-1 do - . if (barberPole+i)#4=0 write "~" - . else write "-" - write ">|" - for i=1:1:(postmark-1) write "-" - if postmark>0 write "| " - write timeStr - - goto PBD1 - -Spin1 - new spinBar set spinBar=+$get(@pRefCt@("SPIN BAR")) - new spinDir set spinDir=+$get(@pRefCt@("SPIN BAR","DIR")) ;"1=forward, -1=backwards - if spinDir=0 set spinDir=1 - set spinBar=spinBar+spinDir - if spinBar>100 do - . set spinDir=-1 - . set spinBar=100 - if spinBar<0 do - . set spinDir=1 - . set spinBar=0 - set @pRefCt@("SPIN BAR")=spinBar - set @pRefCt@("SPIN BAR","DIR")=spinDir - set @pRefCt@("SPIN BAR","LAST INC")=$H - - new marker set marker="<=>" - set width=width-$length(label)-$length(marker) - set pct=spinBar/100 - set premark=(width*pct)\1 - set postmark=width-premark - - write label," |" - for i=0:1:premark-1 write "-" - write marker - for i=1:1:(postmark-1) write "-" - if pct<1 write "-" - write "|" - -PBD1 - ;"write $char(13) set $X=0 - write ! - do CUU^TMGTERM(1) - -PBDone - do ;"Turn cursor display back on. - . ;"new $etrap set $etrap="" - . ;"xecute ^%ZOSF("TRMON") - . ;"U $I:(TERMINATOR=$C(13,127)) - - ;"new discard set discard=$get(@NakedRef) ;"reset naked reference. - quit - -PRESSTOCONT ;" Alternative entry point -PressToCont ; - ;"Purpose: to provide a 'press key to continue' action - ;"result: none - ;"Output: will set TMGPTCABORT=1 if user entered ^ - - write "----- Press Key To Continue -----" - new ch set ch=$$KeyPressed^TMGUSRIF(0,240) - if (ch=94) set TMGPTCABORT=1 ;"set abort user entered ^ - else kill TMGPTCABORT - write ! - quit - - -UserAborted(AbortLabel) - ;"Purpose: Checks if user pressed ESC key. If so, then ask if abort wanted - ;"Note: return is immediate. - ;"Returns: 1 if user aborted, 0 if not. - - new result set result=0 - if $$KeyPressed=27 do - . new % set %=2 - . write !,"Abort" - . if $get(AbortLabel)'="" do - . . write " "_AbortLabel - . do YN^DICN write ! - . set result=(%=1) - - quit result - - -KeyPressed(wantChar,waitTime) - ;"Purpose: to check for a keypress - ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value - ;" waitTime -- OPTIONAL, default is 0 (immediate return) - ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) - ;"Note: this does NOT wait for user to press key - - new temp - set waitTime=$get(waitTime,0) - read *temp:waitTime - if $get(wantChar)=1 set temp=$char(temp) - quit temp - - -Read(Terminators,timeOut,Num,initialVal,EscKey) - ;"Purpose: a custom read function with custom terminators - ;"Input: Terminators -- OPTIONAL Flags to specify characters that will signal that - ;" the user is done with input. Flags as follows: - ;" r = return/enter - ;" t = tab - ;" s = space - ;" e = escape - ;" b = backspace - ;" NONE = no terminators - ;" e.g. 'rte' means that if user enters a return, tab, or escape - ;" then input it ended, and characters (up to, but not including - ;" terminator) entered are returned. - ;" e.g. 'NONE' --> NO terminators. NOTE: MUST supply a number - ;" characters to read, or endless loop will result. - ;" If Terminator="", then default value of 'r' is used - ;" timeOut -- Optional -- the allowed lengh of time to wait before timeout. - ;" default value is 999,999 seconds (~11 days) - ;" Num -- OPTIONAL -- a number of characters to read, e.g. 5 to read just - ;" 5 characters (or less than 5 if terminator encountered) - ;" initialVal-- OPTIONAL -- This can be a value that presents the output - ;" It also allows editing of former inputs. Note: this function - ;" assumes that initialValue has been printed to the screen before - ;" calling this function. - ;" EscKey-- OPTIONAL -- PASS BY REFERENCE, an OUT PARAMETER - ;" if Terminator includes "e", then EscKey will be filled - ;" with a translated value for esc sequence, e.g. UP - ;" (as found in ^XUTL("XGKB",*)) - ;" - ;"Result: returns characters read. - - new result set result=$get(initialVal) - set timeOut=+$get(timeOut,999999) - new len set len=0 - set Num=$get(Num) - set Terminators=$get(Terminators) - if Terminators="" set Terminators="r" - else if Terminators="NONE" set Terminators="" - new temp - new done set done=0 - set EscKey="" - - ;"NOTE, I could rewrite this to use built in terminators functions... - ;"e.g. U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))" - -RLoop xecute ^%ZOSF("EOFF") ;"echo off - if Terminators["e" use $I:ESCAPE - read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a') - if Terminators["e" use $I:NOESCAPE - xecute ^%ZOSF("EON") - if (temp=13)&(Terminators["r") do - . set done=1 - else if (temp=9)&(Terminators["t") do - . set done=1 - else if (temp=32)&(Terminators["s") do - . set done=1 - else if (temp=27)&(Terminators["e") do - . set EscKey=$get(^XUTL("XGKB",$ZB)) - . set done=1 - else if (temp=127)&(Terminators["b") do - . set done=1 - else if (temp'=-1) do - . if temp=127 do quit - . . if result="" quit - . . set result=$extract(result,1,$length(result)-1) - . . write $char(8)," ",$char(8) - . set result=result_$char(temp) - . write $char(temp) - . if Num="" quit - . if $length(result)'<+Num set done=1 - - if 'done goto RLoop - - quit result - - -IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray) - ;"Purpose: to allow selecting records from an IEN array - ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from - ;" format: - ;" @pIENArray@(IEN)="" - ;" @pIENArray@(IEN)="" - ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array WILL be KILLED first - ;" Format of returned array: Only those valuse that user selected will - ;" be aded to list - ;" @pResults@(IEN)=DisplayLineNumber - ;" @pResults@(IEN)=DisplayLineNumber - ;" File: The file number that IEN's are from. - ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default - ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1". - ;" Widths: Optional. The widths of the columns to display Fields in. - ;" Format: e.g. "10;12;24" for three colums of widths: - ;" Sequence must match sequence given in Fields - ;" Default is to evenly space colums - ;" Header -- OPTIONAL -- A header text to show. - ;" SortFlds -- OPTIONAL -- Provide sorting fields - ;" Format: 'FldNum1;FldNum2;FldNum3...' - ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE, - ;" This variable will be filled with the NAME of the array - ;" used for displaying the array. The FIRST time this function - ;" is called, this variable should = "". On SUBSEQUENT calls, - ;" if this variable holds the name of a variable (a reference), then - ;" that array will be used, rather than taking the time to create - ;" the display array again. Format of array: - ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... - ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... - ;" Note: The LineNumber is the same number as the DisplayLineNumber - ;" returned in @pResults@(IEN)=DisplayLineNUmber - ;"Results: none - - if $get(pResults)'="" kill @pResults - new PreSelArray - new ref - if $get(SaveArray)="" do - . set ref=$name(^TMP("VEE",$J)) - . kill @ref - . set SaveArray=ref - else do goto IS1 ;"Skip recreating array if SaveArray holds reference - . set ref=SaveArray - - new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT")) - kill @ref2 - if $get(Header)'="" set @ref@("HD")=Header - set Sort=$get(Sort,0) - set IOM=$get(IOM,80) - set Fields=$get(Fields,".01") - set Widths=$get(Widths) - new Sort set Sort=($data(SortFlds)'=0) - set File=$get(File) - ;"Setup FldArray. Format: - ;" FldArray=number of colums - ;" FldArray(Sequence#)=field;fieldWidth - ;" FldArray(Sequence#)=field;fieldWidth - ;" FldArray(Sequence#)=field;fieldWidth - new FldArray,i - set FldArray=0 - new WRemain set WRemain=IOM - for i=1:1:$length(Fields,";") do - . new Fld,W - . set Fld=$piece(Fields,";",i) - . if Fld="" quit - . set W=+$piece(Widths,";",i) - . if W=0 do - . . if FldArray>0 set W=IOM/FldArray - . . else set W=20 ;"some arbitrary number - . if W>WRemain set W=WRemain ;"this isn't perfect - . set WRemain=WRemain-W - . if WRemain<1 set WRemain=1 - . set FldArray(i)=Fld_";"_W - . set FldArray=FldArray+1 - - new Itr,IEN,name,PriorErrorFound - new abort set abort=0 - new order set order=1 - new IENPreSelected - write "Prepairing list to display..." - set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr) - do PrepProgress^TMGITR(.Itr,100,0,"IEN") - write ! - if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1) - . new TMGOUT,TMGMSG,IENS,showS,i - . set showS="" - . set IENS=IEN_"," - . new tempFields - . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0) - . new i for i=1:1:FldArray do - . . if showS'="" set showS=showS_"|" - . . new Fld,tempS - . . set Fld=$piece(FldArray(i),";",1) - . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG") - . . if (i=1),$piece($get(^DD(File,Fld,0)),"^",2)["D" do ;"format dates for sorting if in column 1 - . . . new %DT,X,Y - . . . set X=tempS - . . . do ^%DT ;"X in, Y out - . . . set tempS=$$DTFormat^TMGMISC(Y,"yyyy mm/dd") ;"make dates sort numerically - . . if $data(TMGMSG("DIERR")) do set abort=1 quit - . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) - . . new W set W=$piece(FldArray(i),";",2) - . . set tempS=$extract(tempS,1,W) - . . if Sort set tempFields(Fld)=tempS - . . set showS=showS_$$LJ^XLFSTR(tempS,W," ") - . if Sort=0 do - . . set @ref@(order)=IEN_$char(9)_showS - . . if IENPreSelected set PreSelArray(order)="" - . . set order=order+1 - . else do - . . new tempRef set tempRef=ref2 - . . for i=1:1:$length(SortFlds,";") do - . . . new oneFld set oneFld=$piece(SortFlds,";",i) - . . . new F set F=$get(tempFields(oneFld)) - . . . if F="" quit - . . . set tempRef=$name(@tempRef@(F)) - . . set @tempRef@(IEN)=IEN_$char(9)_showS - . . if IENPreSelected set @tempRef@(IEN,"SEL")="" - . . ;"Sets up sorted variable as follows: - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' - do ProgressDone^TMGITR(.Itr) - write ! - - if abort=1 goto ISDone - -IES1 if Sort=1 do - . write "Sorting... " - . set order=1 - . new tempRef2 set tempRef2=ref2 - . new showS,NumNodes,Done - . set Done=0 - . for do quit:(tempRef2="")!(Done=1) - . . set tempRef2=$query(@tempRef2) - . . if (tempRef2="") quit - . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit - . . . set PreSelArray(order-1)="" - . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit - . . set showS=$get(@tempRef2) - . . set @ref@(order)=showS - . . set order=order+1 - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" @ref@("HD")=Header to display - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") -IS1 - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - write "Passing off to selector..." - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format results - new Itr2,index - set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2) - if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="") - . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1) - . set @pResults@(s)=index - - kill ^TMP("VPE","SELECT",$J) - if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT") - -ISDone - quit - - -Selector(pArray,pResults,Header) - ;"Purpose: Interface with VPE Selector code to select from an array - ;"Input: pArray -- NAME OF array holding items to be selected from - ;" Expected format: - ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional - ;" @pArray@("Display Choice Words")=ReturnValue - ;" @pArray@("Display Choice Words")=ReturnValue - ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array will NOT be KILLED first - ;" Format of returned array: Only those valuse that user selected will be returned - ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional - ;" @pResults@("Display Choice Words")=ReturnValue - ;" @pResults@("Display Choice Words")=ReturnValue - ;" Header -- OPTIONAL -- A header text to show. - ;"Results: None - new ref set ref=$name(^TMP("VEE",$J)) - kill @ref - if $get(pArray)="" goto SelDone - if $get(pResults)="" goto SelDone - - new PreSelArray - - ;"First set up array of options - new DispWords,RtnValue - new order set order=1 - set DispWords=$order(@pArray@("")) - if DispWords'="" for do quit:(DispWords="") - . set RtnValue=$get(@pArray@(DispWords),"") - . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) - . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected - . set order=order+1 - . set DispWords=$order(@pArray@(DispWords)) - - if $get(Header)'="" set @ref@("HD")=Header - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") - - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format selected options. - new index set index=$order(^TMP("VPE","SELECT",$J,"")) - if index'="" for do quit:(index="") - . new s,s1,s2 - . set s=$get(^TMP("VPE","SELECT",$J,index)) - . set s1=$piece(s,$char(9),1) - . set s2=$piece(s,$char(9),2) - . set @pResults@(s2)=s1 - . set index=$order(^TMP("VPE","SELECT",$J,index)) - - kill ^TMP("VPE","SELECT",$J) - kill @ref - -SelDone - quit - - -Slctor2(pArray,pResults,Header) - ;"Purpose: Interface with VPE Selector code to select from an array - ;" Note: This allows a different format of input. In Selector() above, - ;" it is NOT possible to have two similar Display Words with - ;" different return values. E.g. two drugs with LISINOPRIL, but - ;" different IEN return values. This fn allows this - ;"Input: pArray -- NAME OF array holding items to be selected from - ;" Expected format: - ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required - ;" @pArray@("Display Choice Words",ReturnValue)="" - ;" @pArray@("Display Choice Words",ReturnValue)="" - ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator - ;" pResults -- NAME OF array to have results returned in - ;" ** Note: Prior contents of array will NOT be KILLED first - ;" Format of returned array: Only those values that user selected will be returned - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" @pResults@("Display Choice Words",ReturnValue)="" - ;" Header -- OPTIONAL -- A header text to show. - - new ref set ref=$name(^TMP("VEE",$J)) - kill @ref - if $get(pArray)="" goto Sl2Done - if $get(pResults)="" goto Sl2Done - - new PreSelArray - - ;"First set up array of options - new DispWords,RtnValue - new order set order=1 - set DispWords="" - for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do - . set RtnValue="" - . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do - . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) - . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected - . . set order=order+1 - - if $get(Header)'="" set @ref@("HD")=Header - - ;"Note: Rules of use: - ;" ref must=^TMP("VEE",$J) - ;" Each line should be in this format: - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue - ;" Note: if DisplayValue is to be divided into colums, then - ;" use | character to separate - ;" Results come back in: - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue - ;" To preselect entries, provide an array like this: - ;" array(number)="" <-- number is same number as above, shows selected - ;" array(number)="" - ;" array(number)="" - ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") - - new NumberLines set NumberLines=0 ;"1--> number each line - new AddNew set AddNew=0 ;"1-> Allow adding new entry - - D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") - - ;"Format selected options. - new index set index=$order(^TMP("VPE","SELECT",$J,"")) - if index'="" for do quit:(index="") - . new s,s1,s2 - . set s=$get(^TMP("VPE","SELECT",$J,index)) - . set s1=$piece(s,$char(9),1) - . set s2=$piece(s,$char(9),2) - . set @pResults@(s2,s1)="" - . set index=$order(^TMP("VPE","SELECT",$J,index)) - - kill ^TMP("VPE","SELECT",$J) - kill @ref - -Sl2Done - quit - - - -MENU(Options,defChoice,UserRaw) - QUIT $$Menu(.Options,.defChoice,.UserRaw) - -Menu(Options,defChoice,UserRaw) - ;"Purpose: to provide a simple menuing system - ;"Input: Options -- PASS BY REFERENCE - ;" Format: - ;" Options(0)=Header Text <--- optional, default is MENU - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue - ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue - ;" defChoice: OPTIONAL, the default menu value - ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input - ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort - - new result set result="^" - new s,fg,bg - new width set width=50 - new line set $piece(line,"=",width+1)="" -MNU1 - if $data(Options(-1,"COLOR")) do - . set fg=$get(Options(-1,"COLOR","fg"),0) - . set bg=$get(Options(-1,"COLOR","bg"),1) - . do VCOLORS^TMGTERM(fg,bg) - write line,! - write $get(Options(0),"MENU"),$$Pad2Pos^TMGSTUTL(width),! - write line,! - write "Options:",$$Pad2Pos^TMGSTUTL(width),! - - new DispNumber set DispNumber=$order(Options(0)) - if DispNumber'="" for do quit:(DispNumber="") - . set s=$get(Options(DispNumber)) - . write $$RJ^XLFSTR(DispNumber,4),".",$$Pad2Pos^TMGSTUTL(6) - . if $data(Options(DispNumber,"COLOR")) do - . . set fg=$get(Options(DispNumber,"COLOR","fg"),0) - . . set bg=$get(Options(DispNumber,"COLOR","bg"),1) - . . do VCOLORS^TMGTERM(fg,bg) - . write $piece(s,$char(9),1),$$Pad2Pos^TMGSTUTL(width-1) - . if $data(Options(DispNumber,"COLOR")) do - . . do VTATRIB^TMGTERM(0) ;"Reset colors - . write " ",! - . set DispNumber=$order(Options(DispNumber)) - - write line,! - - set defChoice=$get(defChoice,"^") - new input - write "Enter selection (^ to abort): ",defChoice,"// " - read input:$get(DTIME,3600),! - if input="" set input=defChoice - set UserRaw=input - if input="^" goto MNUDone - - set s=$get(Options(input)) - if s="" set s=$get(Options($$UP^XLFSTR(input))) - ;"if s="" write "??",!! goto MNU1 - set result=$piece(s,$char(9),2) - if result="" set result=input - -MNUDone - if $data(Options(-1,"COLOR")) do VTATRIB^TMGTERM(0) ;"Reset colors - quit result - - -ProgTest - ;"Purpose: test progress bar. - new i,u,max - set max=100 - for i=0:1:max do - . do ProgressBar(i,"%",1,max) - . hang 0.25 - quit - - -SpinTest - ;"Purpose: test progress bar. - new i,u,max - set max=3000 - for i=0:10:max do - . do ProgressBar(i," "_i,-1,-1) - . hang 0.1 - quit - - -Scroller(pArray,Option) - ;"Purpose: Provide a scroll box - ;"Input: pArray -- PASS BY NAME. format: - ;" @pArray@(1,DisplayText)=Return Text <-- note: must be numbered 1,2,3 etc. - ;" @pArray@(2,DisplayText)=Return Text - ;" @pArray@(3,DisplayText)=Return Text - ;" NOTE: if Display text contains {{name}} then name is taken as color directive - ;" Example: 'Here is {{BOLD}}something{{NORM}} to see.' - ;" if NAME is not defined in Option("COLORS",NAME), it is ignored - ;" Option -- PASS BY REFERENCE. format: - ;" Option("HEADER",1)=Header line text - ;" Option("HEADER",2)=More Header line text (any number of lines) - ;" Option("FOOTER",1)=Footer line text <--- Option 1 - ;" Option("FOOTER",1,1)=linePart <--- Option 2 (these will be all strung together to make one footer line. - ;" Option("FOOTER",1,2)=linePart (can be used to display switches etc) - ;" Option("FOOTER",2)=More footer line text (any number of lines) - ;" Option("SHOW INDEX")=1 Optional. If 1, then index is shown. - ;" Option("SCRN WIDTH")= Optional screen width. (default is terminal width) - ;" ---- Colors (optional) ------ - ;" Option("COLORS","NORM")=FG^BG -- default foreground (FG) and background(colors) - ;" If not provided, White on Blue used. - ;" Option("COLORS","HIGH")=FG^BG -- Highlight colors. If not provided, White on Cyan used. - ;" Option("COLORS","HEADER")=FG^BG Header color. NORM used if not provided - ;" Option("COLORS","FOOTER")=FG^BG Footer color. NORM used if not provided - ;" Option("COLORS","TOP LINE")=FG^BG Top line color. NORM used if not provided - ;" Option("COLORS","BOTTOM LINE")=FG^BG Bottom line color. NORM used if not provided - ;" Option("COLORS","INDEX")=FG^BG Index color. NORM used if not provided - ;" Option("COLORS",SomeName)=FG^BG e.g. : - ;" Option("COLORS","BOLD")=15^0 (Any arbitrary name OK, matched to {{name}} in text) - ;" Option("COLORS","HIGH")=10^@ - ;" If BG="@", then default BG used. This may be used anywhere except for defining NORM - ;" ---- events ---- - ;" Option("ON SELECT")="FnName^Module" -- code to call based on user input - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ;" Option("ON CHANGING")="FnName^Module" -- code to execute for number entry - ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line - ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line - ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line - ;" Info("NEXT LINE","NUMBER")=next line number. Used for ON CHANGING to show the line about to be selected - ;" Info("ALLOW CHANGE")=1, <--- RETURN RESULT. Change to 0 to disallow move. - ;" Option("ON CMD")="FnName^Module" -- code to execute for number entry - ;" Info("USER INPUT")=UserTypedInput - ;" NOTES about events. Functions will be called as follows: - ;" do FnName^Module(pArray,.Option,.Info) - ;" pArray and Option are the same data received by this function - ;" -- thus Option can be used to can other custom information. - ;" Info has extra info as outlined above. - ;" If functions may set a globally-scoped var named TMGSCLRMSG to communicate back - ;" if TMGSCLRMSG="^" then Scroller will exit - ;"Result: none - - new scrnW,scrnH,scrnLine,spaceLine,topLine,sizeHdr,sizeFtr - new entryCt,lineCt,EscKey,dispHt,highLine,showIdx - new needRefresh,Info - set topLine=1 - set highLine=5 - new TMGSCLRMSG set TMGSCLRMSG="" - - set scrnW=+$get(Option("SCRN WIDTH")) - if scrnW'>0 do - . if $$GetScrnSize^TMGKERNL(,.scrnW) - . set scrnW=+scrnW-4 - if scrnW'>0 set scrnW=$get(IOM,66)-2 - ;"set scrnW=$get(IOM,60)-2 - set scrnH=$get(IOSL,25)-2 - - if $get(Option("COLORS","NORM"))="" set Option("COLORS","NORM")="14^4" ;"white on blue - if $get(Option("COLORS","HIGH"))="" set Option("COLORS","HIGH")="14^6" ;"white on cyan - if $get(Option("COLORS","HEADER"))="" set Option("COLORS","HEADER")=Option("COLORS","NORM") - if $get(Option("COLORS","FOOTER"))="" set Option("COLORS","FOOTER")=Option("COLORS","NORM") - if $get(Option("COLORS","TOP LINE"))="" set Option("COLORS","TOP LINE")=Option("COLORS","NORM") - if $get(Option("COLORS","BOTTOM LINE"))="" set Option("COLORS","BOTTOM LINE")=Option("COLORS","NORM") - if $get(Option("COLORS","INDEX"))="" set Option("COLORS","INDEX")=Option("COLORS","NORM") - - new i set i="" - for set i=$order(Option("COLORS",i)) quit:(i="") do - . new colors set colors=$get(Option("COLORS",i)) - . new FG set FG=$piece(colors,"^",1) if FG="" set FG=0 - . new BG set BG=$piece(colors,"^",2) if BG="" set BG=1 - . set Option("COLORS",i,"FG")=FG - . set Option("COLORS",i,"BG")=BG - -Full set scrnLine="" set $piece(scrnLine,"-",scrnW)="-" - set spaceLine="" set $piece(spaceLine," ",scrnW)=" " - set sizeHdr=$$ListCt^TMGMISC($name(Option("HEADER")))+1 - set sizeFtr=$$ListCt^TMGMISC($name(Option("FOOTER")))+1 - set entryCt=$$ListCt^TMGMISC(pArray) - set EscKey="" - set dispHt=scrnH-sizeHdr-sizeFtr - if topLine>entryCt set topLine=entryCt - if highLine>entryCt set highLine=entryCt - set showIdx=($get(Option("SHOW INDEX"))=1) - -Draw do HOME^TMGTERM - if $data(Option("HEADER")) do - . do SetColor("HEADER",.Option) - . new i set i="" - . for set i=$order(Option("HEADER",i)) quit:(i="") do - . . write $$CJ^XLFSTR($get(Option("HEADER",i)),scrnW),! - set lineCt=topLine - - ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - do SetColor("TOP LINE",.Option) - write scrnLine,! - do SetColor("NORM",.Option) - for quit:(lineCt=(dispHt+topLine-1)) do - . ;"if lineCt=highLine do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background - . ;"else do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - . if lineCt=highLine do SetColor("HIGH",.Option) - . else do SetColor("NORM",.Option) - . new s set s="" - . if showIdx do - . . do SetColor("INDEX",.Option) - . . write $$RJ^XLFSTR(lineCt,3)_"." - . . if lineCt=highLine do SetColor("HIGH",.Option) - . . else do SetColor("NORM",.Option) - . . write " " - . new text,textA,textB,textColor - . set text=$order(@pArray@(lineCt,"")) - . for quit:(text'["{{")!($X' TextA{{Color}}Text - . . if $X+$length(textA)>scrnW do - . . . write $extract(textA,1,(scrnW-$X-3))_"..." - . . else write textA - . . do SetColor(textColor,.Option) - . write text - . write $extract(spaceLine,1,(scrnW-$X)) - . do SetColor("RESET") write ! - . ;"if showIdx set s=$$RJ^XLFSTR(lineCt,3)_". " - . ;"set s=$$LJ^XLFSTR(s_$order(@pArray@(lineCt,"")),scrnW) - . ;"if $length(s)>scrnW set s=$extract(s,1,scrnW-3)_"..." - . ;"write s,! - . set lineCt=lineCt+1 - ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background - do SetColor("BOTTOM LINE",.Option) - write scrnLine,! - do SetColor("FOOTER",.Option) - ;"do VTATRIB^TMGTERM(0) ;"reset colors - if $data(Option("FOOTER")) do - . new i set i="" - . for set i=$order(Option("FOOTER",i)) quit:(i="") do - . . new j set j=$order(Option("FOOTER",i,"")) - . . if j'="" do - . . . new oneLine set oneLine="",j="" - . . . for set j=$order(Option("FOOTER",i,j)) quit:(j="") do - . . . . set oneLine=oneLine_$get(Option("FOOTER",i,j))_" | " - . . . write $$LJ^XLFSTR(oneLine,scrnW),! - . . else write $$LJ^XLFSTR($get(Option("FOOTER",i)),scrnW),! - - set Info("CURRENT LINE","NUMBER")=highLine - set Info("CURRENT LINE","TEXT")=$order(@pArray@(highLine,"")) - set Info("CURRENT LINE","RETURN")=$get(@pArray@(highLine,Info("CURRENT LINE","TEXT"))) - - do SetColor("RESET") - write $$LJ^XLFSTR(": ",scrnW),! - do CUU^TMGTERM(1) write ": " - set needRefresh=0 -UsrIn set input=$$Read("re",,,,.EscKey) - if (input="")&(EscKey="") set EscKey="CR" - if EscKey="UP" set input="UP^1" - if EscKey="PREV" set input="UP^15" - if EscKey="DOWN" set input="DOWN^1" - if EscKey="NEXT" set input="DOWN^15" - if EscKey="CR" do goto Lp2 - . new codeFn set codeFn=$get(Option("ON SELECT")) quit:(codeFn="") - . set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . xecute codeFn - . set needRefresh=2 - if input="^" goto ScrlDone - if (input["^") do goto Lp2 - . if $piece(input,"^",1)="UP" do - . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . . new codeFn set codeFn=$get(Option("ON CHANGING")) - . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . . set Info("ALLOW CHANGE")=1 - . . set needRefresh=1 - . . new j for j=1:1:+$piece(input,"^",2) do - . . . if highLine>topLine do - . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set highLine=highLine-1 - . . . else if topLine>1 do - . . . . set Info("NEXT LINE","NUMBER")=(topLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set topLine=topLine-1,highLine=topLine - . else if $piece(input,"^",1)="DOWN" do - . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" - . . new codeFn set codeFn=$get(Option("ON CHANGING")) - . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" - . . set Info("ALLOW CHANGE")=1 - . . set needRefresh=1 - . . new j for j=1:1:+$piece(input,"^",2) do - . . . if highLine<(topLine+dispHt-2) do - . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) - . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 - . . . . set highLine=highLine+1 - . . . else if (topLine+dispHt-2)