Index: cprs/branches/tmg-cprs/m_files/TMGFMUT2.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGFMUT2.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGFMUT2.m (revision 896) @@ -0,0 +1,581 @@ +TMGFMUT2 ;TMG/kst/Fileman utility functions ;02/19/10 + ;;1.0;TMG-LIB;**1**;02/19/10 + ; + ;"TMG FILEMAN-UTILITY FUNCTIONS + ;"(c) Kevin Toppenberg MD + ;"Released under: GNU General Public License (GPL) + ;"2/19/10 + ; + ;"======================================================================= + ;"NOTE: This module will provide pointer tools that are different than found + ;" if ^TMGFMUT. The approach here will be to create tables of pointer + ;" relationships, and then allow faster analysis from the tables. This + ;" recognizes that such tables can rapidly become out of sync with the + ;" actual data. Thus the tools will only be valid on a system at rest (i.e. + ;" no users on the system). They could be used for system maint. overnight + ;" etc. + ;" Several of the routines here are called from ^TMGSIPH* + ;"Data is stored here: + ;"^TMG("PTXREF","OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)="" + ;"^TMG("PTXREF","IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)="" + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"PREPPTO(FILENUM,FLD,ARRAY) -- set up an easy to use array of potential pointers out from a file. + ;"SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS) -- scan a given file and create an array with all pointers INTO that file. + ;"KILLPTIX -- delete the last run of PT XREF, so it can be refreshened. + ;"GETPTIN(PARAMS,OUT,PGFN) --get a listing of all pointers INTO requested record + ;"BAKXREF(PARAMS,PGFN) --Make a xref of cross-references (a backward xref) + ;"BAKSXREF(PARAMS,PGFN)-- Make a xref of cross-references (a backward xref) **OF SUBFILES** + ;"GETXRAGE --Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification + ;"GETGL(SUBFILENUM,IENDEPTH) --return a reference 'GL' string for subfiles. + ;"GETGREF(FILENUM,IENS) -- To return a reference to a ** SUBFILE ** + ;"IENCOMBO(REF,IENDEPTH,IEN) --set up global vars IEN(2),IEN(3),... etc, as needed for next combo when cycling through subfile arrays. + ;"TOPFILEN(FILENUM) -- Return the highest level of filenumber. + ;"ISSUBFIL(FILENUM) -- Return if a file is a subfile. + ;"GETIENS(IEN) --Turn IEN Array into IENS + ;"IENS2IEN(IENS,IEN) -- Turn IENS into IEN Array, opposite of GETIENS function + ;"GETSPFN(FILENUM) -- Turn a subfile number into 'SubFileNum{ParentFileNum{GrandParentFileNum....' + ;"HASPTR(FILENUM) --Return if file contains fields that are pointers to other files + ;"HASPTRSF(FILENUM) -- Return if file contains subfiles (or sub-subfiles) that contain pointers to other files) + ;"FILENAME(FILENUM) -- turn a (SUB)File number into a file name. + ;"======================================================================= + ;" API - Private Functions + ;"======================================================================= + ;"TESTSPTO -- test out PT XREF setup. + ;"HNDLPTIX(FILENUM,PGFN) -- prepair PT XREF for all records pointing INTO specified file. + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGKERN2, TMGUSRIF + ;"======================================================================= + ; +PREPPTO(FILENUM,FLD,ARRAY) ; + ;"Purpose: To set up an easy to use array of potential pointers out from a file. + ;"Input: FILENUM-- the filenumber to evaluate + ;" FLD -- the field to check for. + ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format + ;" ARRAY(GREF,ENTRY) + ;" Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V]^FromFile^Fromfield^ONEREF + ;" ONEREF will have multipe 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. + ;"NOTE: This function was originally coppied from SETPTOUT^TMGSIPH1 + ; + IF +$GET(FILENUM)'=FILENUM GOTO SPODN + NEW IENDEPTH SET IENDEPTH=1 + NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL")) + IF (REF=""),$DATA(^DD(FILENUM,0,"UP")) DO + . SET REF=$$GETGL(FILENUM,.IENDEPTH) + IF REF="" GOTO SPODN + NEW GREF SET GREF=REF + IF GREF["IEN," SET GREF=$PIECE(GREF,"IEN,",1) + NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0)) + NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2) + IF (FLDTYPE'["P")&(FLDTYPE'["V") GOTO SPODN + NEW LOC SET LOC=$PIECE(ZNODE,"^",4) + NEW NODE SET NODE=$PIECE(LOC,";",1) + NEW PCE SET PCE=+$PIECE(LOC,";",2) + IF +NODE'=NODE SET NODE=""""_NODE_"""" + NEW ONEREF,SUBSCR + SET SUBSCR=$SELECT((IENDEPTH>1):"("_IENDEPTH_")",1:"") + SET ONEREF=REF_"IEN"_SUBSCR_","_NODE_")" + NEW P2FILE SET P2FILE=0 + NEW VREC SET VREC=0 + NEW DONE SET DONE=0 + FOR DO QUIT:(DONE=1) + . NEW ISVIRT SET ISVIRT="" + . NEW P2REF + . IF FLDTYPE["V" DO QUIT:(DONE=1) + . . SET VREC=+$ORDER(^DD(FILENUM,FLD,"V",VREC)) + . . IF VREC=0 SET DONE=1 QUIT + . . SET P2FILE=+$GET(^DD(FILENUM,FLD,"V",VREC,0)) + . . SET ISVIRT="V" + . . SET P2REF=$PIECE($GET(^DIC(P2FILE,0,"GL")),"^",2) + . ELSE DO + . . SET P2FILE=+$PIECE(FLDTYPE,"P",2) + . . SET P2REF=$PIECE(ZNODE,"^",3) + . . SET DONE=1 + . NEW ENTRY + . SET ENTRY=PCE_"^"_P2FILE_"^"_P2REF_"^"_IENDEPTH_"^"_ISVIRT_"^"_FILENUM_"^"_FLD_"^"_ONEREF + . SET ARRAY(GREF,ENTRY)="" +SPODN QUIT + ; + ; +GETIENS(IEN) ;"Turn IEN Array into IENS + NEW RESULT SET RESULT=IEN + NEW I SET I=1 + FOR SET I=$ORDER(IEN(I)) QUIT:(+I'>0) DO + . SET RESULT=$GET(IEN(I))_","_RESULT + IF RESULT["," SET RESULT=RESULT_"," + QUIT RESULT + ; + ; +IENS2IEN(IENS,IEN) ; + ;"Purpose: Turn IENS into IEN Array, opposite of GETIENS function + ;"Input: IENS - an IENS string to convert. E.g. '7,2342," + ;" IEN -- PASS BY REFERENCE. An OUT PARAMETER. + ;"Results: None. + KILL IEN + SET IENS=$GET(IENS) + NEW LEN SET LEN=$LENGTH(IENS,",")-1 + NEW I FOR I=1:1:LEN DO + . NEW IDX SET IDX=(LEN-I+1) + . NEW VALUE SET VALUE=$PIECE(IENS,",",I) + . IF IDX>1 SET IEN(IDX)=VALUE + . ELSE SET IEN=VALUE + QUIT + ; + ; +SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS) + ;"Purpose: To scan a given file and create an array with all pointers INTO that file. + ;" NOTE: The output will be a snapshot of the database that will quickly be out + ;" of date if/when the database changes. + ;"Input: FILENUM -- the Fileman file number to test. This is that file that other records will point TO + ;" DESTREF -- OPTIONAL. PASS BY NAME. The name of an array to store output into. + ;" MUST BE IN CLOSED FORMAT. If not specified, then ^TMG("PTXREF" will be used. + ;" PGFN -- OPTIONAL. + ;" A string of mumps code that will be executed once for every 100 records that are scanned. + ;" The following variables will be defined for use. + ;" TMGCT -- The total number of that have been scanned so far. + ;" TMGFNAME -- The file that is currently begin scanned. + ;" TMGIEN -- Record number in the current file being scanned. + ;" TMGMAX -- Max record number in the current file being scanned. + ;" TMGMIN -- Min record number in the current file being scanned. + ;" PGFREQ --OPTIONAL. The number of records that must be scanned before the Progress Fn + ;" code is called. Default = 100. + ;" LIMITS -- OPTIONAL. If $DATA(LIMITS("REF"))'=0 then REF should be an array with format: + ;" LIMITS("REF")= + ;" @aREF@(FILENUM,IEN)="" <-- Forms a set that will limit search. Only these entries are considered. + ;" @aREF@(FILENUM,IEN)="" <-- + ;"Result: none. + NEW RESULT SET RESULT=0 + SET FILENUM=+$GET(FILENUM) GOTO:(FILENUM=0) SPODN + SET DESTREF=$GET(DESTREF,$NAME(^TMG("PTXREF"))) + SET PGFN=$GET(PGFN,"QUIT") + SET PGFREQ=+$GET(PGFREQ) IF PGFREQ'>0 SET PGFREQ=100 + NEW LIMITREF SET LIMITREF=$GET(LIMITS("REF")) + SET LIMITS=(LIMITREF'="") + ; + ;"Build up ARRAY, an easy to use array of potential pointers OUT from a file. + ;"NOTE: Only files that point INTO FILENUM will be put into this array. + NEW ARRAY + NEW FROMFILE SET FROMFILE=0 ;"OtherFile + FOR SET FROMFILE=$ORDER(^DD(FILENUM,0,"PT",FROMFILE)) QUIT:(+FROMFILE'>0) DO + . NEW FLD SET FLD=0 + . FOR SET FLD=$ORDER(^DD(FILENUM,0,"PT",FROMFILE,FLD)) QUIT:(+FLD'>0) DO + . . DO PREPPTO(FROMFILE,FLD,.ARRAY) ; + ; + ;"Now, cycle through possible pointers to look for real pointers. + SET @DESTREF@("TIMESTAMP")=$H + NEW ABORT SET ABORT=0 + NEW TMGCT SET TMGCT=0 + NEW GREF SET GREF="" + FOR SET GREF=$ORDER(ARRAY(GREF)) QUIT:(GREF="")!ABORT DO + . NEW TEMPN SET TEMPN=0 + . NEW SKIP SET SKIP=0 + . NEW FOUND SET FOUND=0 + . FOR SET TEMPN=$ORDER(^DIC(TEMPN)) QUIT:(+TEMPN'>0)!FOUND DO ;"Get filenumber of GREF + . . IF $GET(^DIC(TEMPN,0,"GL"))'=GREF QUIT + . . SET FOUND=1 + . . SET @DESTREF@("OUT",TEMPN)=$H + . IF SKIP QUIT + . NEW REF SET REF=$$CREF^DILF(GREF) + . NEW TMGMAX SET TMGMAX=$ORDER(@REF@("+"),-1) + . NEW TMGMIN SET TMGMIN=$ORDER(@REF@(0)) + . NEW SKIP SET SKIP=0 + . NEW IEN SET IEN=0 + . FOR SET IEN=$ORDER(@REF@(IEN)) QUIT:(+IEN'>0)!ABORT!SKIP DO + . . IF LIMITS DO QUIT:SKIP ;"If running on client side, only look at downloaded records. + . . . IF $DATA(@LIMITREF@(TEMPN,IEN))'=0 QUIT + . . . SET SKIP=1 + . . NEW INFO SET INFO="" + . . FOR SET INFO=$ORDER(ARRAY(GREF,INFO)) QUIT:(INFO="")!ABORT DO + . . . NEW PCE SET PCE=$PIECE(INFO,"^",1) + . . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4) + . . . NEW ONREF SET ONEREF=$PIECE(INFO,"^",8,99) + . . . NEW TEMP SET TEMP=IEN KILL IEN SET IEN=TEMP ;"clear subscripts + . . . FOR QUIT:($$IENCOMBO(ONEREF,IENDEPTH,.IEN)'=1)!ABORT DO + . . . . NEW FROMFILE SET FROMFILE=$PIECE(INFO,"^",6) + . . . . SET TMGCT=TMGCT+1 + . . . . IF TMGCT#PGFREQ=0 DO + . . . . . SET ABORT=$$UserAborted^TMGUSRIF() QUIT:ABORT + . . . . . NEW TMGFNAME SET TMGFNAME=$PIECE($GET(^DIC(FROMFILE,0)),"^",1) + . . . . . NEW TMGIEN SET TMGIEN=IEN + . . . . . NEW $ETRAP SET $ETRAP="W ""(Invalid M Code!. Error Trapped.)"" S $ETRAP="""",$ECODE=""""" + . . . . . XECUTE PGFN + . . . . NEW PT SET PT=$PIECE($GET(@ONEREF),"^",PCE) ;"$$IENCOMBO sets up IEN(n).. needed for @REF + . . . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V") + . . . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3) + . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF) + . . . . SET PT=+PT QUIT:(PT'>0) + . . . . NEW IENS SET IENS=$$GETIENS(.IEN) + . . . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2) + . . . . NEW FROMFLD SET FROMFLD=$PIECE(INFO,"^",7) + . . . . SET @DESTREF@("OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)="" + . . . . SET @DESTREF@("IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)="" + QUIT + ; + ; +TESTSPTO + ;"Purpose: test out PT XREF setup. + NEW X,Y,DIC + SET DIC=1,DIC(0)="MAEQ" + DO ^DIC WRITE ! + IF +Y'>0 QUIT + NEW TMGSTIME SET TMGSTIME=$H + NEW PGFN SET PGFN="DO ProgressBar^TMGUSRIF(TMGIEN,TMGFNAME,TMGMIN,TMGMAX,60,TMGSTIME)" + DO SETPTOUT(+Y,$NAME(^TMG("PTXREF")),PGFN,500) + WRITE !,"Quitting normally.",! + QUIT + ; + ; +KILLPTIX ; + ;"Purpose: To delete the last run of PT XREF, so it can be refreshened. + KILL ^TMG("PTXREF") + QUIT + ; + ; +HNDLPTIX(FILENUM,PGFN) ; + ;"Purpose: To prepair PT XREF for all records pointing INTO specified file. + ;"Input: FILENUM -- The fileman file number to get pointers INTO. + ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress. + ;"Result: None + SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 QUIT + NEW TMGSTIME SET TMGSTIME=$H + DO SETPTOUT(FILENUM,$NAME(^TMG("PTXREF")),.PGFN,3000,CLSIDE) + SET ^TMG("PTXREF","IN",FILENUM)=$H + SET ^TMG("PTXREF")=$H + QUIT + ; + ; +GETPTIN(PARAMS,OUT,PGFN) ; + ;"Purpose: To get a listing of all pointers INTO requested record + ;"Input: PARAMS -- this is FILENUM^IEN + ;" OUT -- PASS BY REFERNCE. Will be filled as with format: + ;" OUT(1)=FROMFILE^FROMIENS^FROMFLD + ;" OUT(2)=FROMFILE^FROMIENS^FROMFLD + ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress. + ;" ... + NEW FILENUM SET FILENUM=+$PIECE(PARAMS,"^",1) + NEW TMGCT SET TMGCT=1 + NEW IEN SET IEN=+$PIECE(PARAMS,"^",2) + IF $DATA(^TMG("PTXREF","IN",FILENUM))'>0 DO HNDLPTIX(FILENUM,.PGFN) + NEW FROMFILE,FROMIENS,FROMFLD + SET (FROMFILE,FROMIENS,FROMFLD)=0 + FOR SET FROMFILE=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE)) QUIT:(+FROMFILE'>0) DO + . FOR SET FROMIENS=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS)) QUIT:(+FROMIENS'>0) DO + . . FOR SET FROMFLD=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS,FROMFLD)) QUIT:(+FROMFLD'>0) DO + . . . SET OUT(TMGCT)=FROMFILE_"^"_FROMIENS_"^"_FROMFLD + . . . SET TMGCT=TMGCT+1 + QUIT + ; + ; +BAKXREF(PARAMS,PGFN) ; + ;"Purpose: Make a xref of cross-references (a backward xref) + ;"Input: PARAMS -- This is FILENUM^[KEEP] + ;" FILENUM -- The fileman file to work with + ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists. + ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress. + ;" The following globally-scoped variables will be available for use: + ;" FILENUM,INDEX + ;"Output: ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)= + ;" e.g. ^TMG("PTXREF","XREFS",FILENUM,113,"^VA(200,""A"",8870804679,113)")=6188 + ;"Result: none. + SET PARAMS=$GET(PARAMS) + SET FILENUM=$PIECE(PARAMS,"^",1) IF +FILENUM'>0 GOTO BXDN + IF FILENUM["{" DO BAKSXREF(.PARAMS,.PGFN) GOTO BXDN + IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXDN + SET PGFN=$GET(PGFN) + NEW STIME SET STIME=$H + NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + IF GREF="" QUIT ;"Happened for file 799.6 + NEW GRLEN SET GRLEN=$LENGTH(GREF) + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + NEW GREFQLEN SET GREFQLEN=$QLENGTH(CGREF) + NEW REF SET REF=$QUERY(@CGREF@("@")) + NEW INDEX,LASTINDEX SET LASTINDEX="" + NEW DELAYCT SET DELAYCT=500 ;"ensure fires at least once to avoid timeout with many quick XREFS + NEW DONE SET DONE=0 + KILL ^TMG("PTXREF","XREFS",FILENUM) + IF $GET(^TMG("PTXREF"))="" SET ^TMG("PTXREF")=$H + SET ^TMG("PTXREF","XREFS",FILENUM)=$H + FOR QUIT:(REF="") DO + . SET DELAYCT=DELAYCT+1 + . IF (DELAYCT>500),(PGFN'="") DO + . . SET DELAYCT=0 + . . IF ($PIECE($H,",",2)-STIME)<5 QUIT + . . SET STIME=$PIECE($H,",",2) + . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE=""""" + . . XECUTE PGFN + . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT + . NEW IEN SET IEN=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . SET ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)=$GET(@REF) + . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1) + . IF INDEX'=LASTINDEX DO + . . SET LASTINDEX=INDEX + . . SET STIME=$PIECE($H,",",2) + . . SET DELAYCT=0 + . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE=""""" + . . XECUTE PGFN + . SET REF=$QUERY(@REF) +BXDN QUIT + ; + ; +BAKSXREF(PARAMS,PGFN) ; + ;"Purpose: Make a xref of cross-references (a backward xref) **OF SUBFILES** + ;"Input: PARAMS -- This is FILENUM^[KEEP] + ;" FILENUM -- subfilenum{parentfilenum{grandparent.... + ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists. + ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress. + ;" The following globally-scoped variables will be available for use: + ;" FILENUM,INDEX + ;"Output: ^TMG("PTXREF","XREFS",SUBFILENUM,IENS,REF)= + ;"Result: none. + SET PARAMS=$GET(PARAMS) + SET FILENUM=+$PIECE(PARAMS,"^",1) ;"Just get the subfile number. + IF FILENUM'>0 GOTO BXSDN + IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXSDN + SET PGFN=$GET(PGFN) + NEW IEN SET IEN=0 + NEW INDEX SET INDEX="" + NEW IENDEPTH SET IENDEPTH="" + NEW GREF SET GREF=$$GETGL(FILENUM,.IENDEPTH) ;" e.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1, (open format) + IF GREF="" QUIT ;"Happened for file 799.6 + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + NEW J FOR J=1:1:IENDEPTH SET IEN(J)=1 ;"dummy values to satisfy $QLENGTH on line below + NEW GREFQLEN SET GREFQLEN=$QLENGTH($NAME(@CGREF)) + NEW DELAYCT SET DELAYCT=999 + ;"NOTE: IENCOMBO is only for getting subfile combos. It doesn't modify IEN. So I need + ;"to manually cycle between all the records of the top-most file. Use GETTOPFILEN^TMGFMUT2 to get this. + NEW TOPFILE SET TOPFILE=+$$TOPFILEN(FILENUM) + NEW TOPREF SET TOPREF=$GET(^DIC(TOPFILE,0,"GL")) + IF TOPREF="" GOTO BXSDN + KILL IEN SET IEN=0 + SET TOPREF=$$CREF^DILF(TOPREF) + FOR SET IEN=$ORDER(@TOPREF@(IEN)) QUIT:(+IEN'>0) DO + . FOR DO QUIT:(OKCOMBO=0) + . . SET DELAYCT=DELAYCT+1 + . . IF (DELAYCT>500),(PGFN'="") DO + . . . SET DELAYCT=0 + . . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE=""""" + . . . XECUTE PGFN + . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(CGREF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @CGREF + . . QUIT:(OKCOMBO=0) + . . NEW GREF SET GREF=$$OREF^DILF($NAME(@CGREF)) ;"resolve IEN vars into actual numbers + . . NEW GRLEN SET GRLEN=$LENGTH(GREF) + . . NEW REF SET REF=$NAME(@CGREF@("@")) + . . FOR DO QUIT:(REF="") + . . . SET REF=$QUERY(@REF) + . . . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT + . . . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1) ;"set up for use by PGFN + . . . NEW PTR SET PTR=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . . . NEW TMPIEN MERGE TMPIEN=IEN + . . . SET TMPIEN(IENDEPTH+1)=PTR + . . . NEW IENS SET IENS=$$GETIENS(.TMPIEN) + . . . SET ^TMG("PTXREF","XREFS",FILENUM,IENS,REF)=$GET(@REF) + . KILL IEN("DONE"),IEN("INIT") +BXSDN QUIT + ; + ; +GETXRAGE() ; + ;"Purpose: Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification + ;"Results: 0 if not currently defined, otherwise number of HOURS since setup. + NEW LASTT SET LASTT=$GET(^TMG("PTXREF","TIMESTAMP")) + NEW DELTAT SET DELTAT=0 + IF LASTT'="" SET DELTAT=$$HDIFF^XLFDT($H,LASTT,2)\(60*60) + QUIT DELTAT + ; + ; +GETGL(SUBFILENUM,IENDEPTH) ; + ;"Purpose: To return a reference 'GL' string for subfiles. + ;" E.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1, + ;"INPUT: SUBFILENUM -- The sub file number + ;" IENDEPTH -- PASS BY REFERENCE. Should be 1 on first call + ;"Results: Returns an OPEN reference. + NEW RESULT SET RESULT="" + SET IENDEPTH=+$GET(IENDEPTH)+1 + NEW UPFILE SET UPFILE=+$GET(^DD(SUBFILENUM,0,"UP")) + IF UPFILE'>0 DO GOTO IDN + . SET RESULT=$GET(^DIC(SUBFILENUM,0,"GL")) + NEW UPFLD SET UPFLD=+$ORDER(^DD(UPFILE,"SB",SUBFILENUM,"")) + IF UPFLD'>0 GOTO IDN + NEW NODE SET NODE=$PIECE(^DD(UPFILE,UPFLD,0),"^",4) + SET NODE=$PIECE(NODE,";",1) + IF +NODE'=NODE SET NODE=""""_NODE_"""" + SET RESULT=NODE_"," + NEW GREF SET GREF=$GET(^DIC(UPFILE,0,"GL")) + NEW NUM2 SET NUM2=IENDEPTH + IF GREF="" SET GREF=$$GETGL(UPFILE,.IENDEPTH) + SET RESULT=GREF_"#"_$CHAR(64+NUM2)_"#,"_RESULT +IDN NEW I,TMGSPEC + FOR I=1:1:IENDEPTH DO + . IF I=IENDEPTH SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN" + . ELSE SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN("_(IENDEPTH-I+1)_")" + SET RESULT=$$REPLACE^XLFSTR(RESULT,.TMGSPEC) +IDN2 QUIT RESULT + ; + ; +GETGREF(FILENUM,IENS) ; + ;"Purpose: To return a reference to a file or a subfile + ;" This function differs from GETGL in that REF from GETGREFhere has actual record numbers + ;" put in, while REF from GETGL has variable names (e.g. IEN(2)) in it. + ;"Input: IENS -- A standard IENS string to locate subfile. Not used unless FILENUM is a subfile. + ;" NOTE: the lowest level IEN is not used. e.g. '7,22345,' --> 7 is not used + ;"Returns : an OPEN format reference. + NEW GREF + NEW IENDEPTH SET IENDEPTH=1 + SET GREF=$$GETGL(FILENUM,.IENDEPTH) + IF $$ISSUBFIL(FILENUM)=0 GOTO GGRDN + SET GREF=$$CREF^DILF(GREF) + NEW IEN DO IENS2IEN(.IENS,.IEN) + SET GREF=$NAME(@GREF) ;"Lock IEN value(s) from IENS into GREF + SET GREF=$$OREF^DILF(GREF) +GGRDN QUIT GREF + ; + ; +IENCOMBO(REF,IENDEPTH,IEN) ; + ;"Purpose: To set up global vars IEN(2),IEN(3),... etc, as needed for next combo when + ;" cycling through subfile arrays. + ;"Input: REF -- the is the potential pointer reference, as stored in ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO) + ;" e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C") (and IENDEPTH would be 3 for this example) + ;" IENDEPTH -- The number of variables to consider. I.e if value=3, then REF will + ;" contain IEN,IEN(2),IEN(3) + ;" IEN -- PASS BY REFERENCE. This variable will serve as an array to store the + ;" information needed to create the next valid set of variables needed + ;" to make use of the reference. NOTE: The value of IEN itself (e.g. IEN=4), + ;" is not modified. + ;"Results: 1 if a new valid IEN combo has been set up. + ;" 0 if there are no more subfile entries. + ;" + ;"NOTE!!!: If IENDEPTH=3, then this function will fail if there are records for depth 1,2, but not 3 + ;" Needs debugging... + ;" + ; + NEW RESULT SET RESULT=0 ;"Default to invalid + IF $DATA(IEN("DONE")) GOTO ICODN + IF IENDEPTH=1 DO GOTO ICODN + . SET IEN("DONE")=1 + . SET RESULT=1 + NEW I + SET RESULT=1 ;"Default to valid + IF $DATA(IEN("ORDS"))=0 DO + . FOR I=2:1:IENDEPTH SET IEN("ORDS",I)=$$CREF^DILF($PIECE(REF,"IEN("_I_")",1)) + IF +$GET(IEN("INIT"))=0 DO + . SET IEN("INIT")=1 + . NEW INVALID SET INVALID=0 + . NEW POS FOR POS=2:1:IENDEPTH DO QUIT:(INVALID=1) + . . IF $GET(IEN(POS))'="" QUIT + . . NEW TEMPREF SET TEMPREF=IEN("ORDS",POS) + . . SET IEN(POS)=+$ORDER(@TEMPREF@(0)) + . . IF IEN(POS)'>0 SET INVALID=1 + . IF (POS=IENDEPTH),(INVALID=0) SET RESULT=1 + ELSE DO ;"At this point, IEN(n),IEN(n+1),... vars should be set to last valid combo. + . SET I=IENDEPTH + . NEW REF,NODE + . FOR DO QUIT:(I<2)!(I=IENDEPTH) + . . SET REF=IEN("ORDS",I) + . . SET IEN(I)=$ORDER(@REF@(IEN(I))) + . . IF (IEN(I)="") SET I=I-1 QUIT ;"reached last record at this level, so backup up level + . . IF (I0 SET RESULT=0 +ICODN QUIT RESULT + ; + ; +TOPFILEN(FILENUM) ; + ;"Purpose: Return the highest level of filenumber. I.e. if subfile, then return parent + ;" parent filenumber. If sub-sub-file, then return higest file number that is + ;" not a sub file. + ;" If FILENUM is not a subfile, then just return same FILENUM + ;"Results: 0 if problem, or Top-most filenumber. + NEW RESULT SET RESULT=0 + IF +$GET(FILENUM)'=FILENUM GOTO TFNDN + FOR QUIT:$DATA(^DD(FILENUM,0,"UP"))=0 DO + . SET FILENUM=+$GET(^DD(FILENUM,0,"UP")) + SET RESULT=FILENUM +TFNDN QUIT RESULT + ; + ; +ISSUBFIL(FILENUM) ; + ;"Purpose: Return if a file is a subfile. + ;"Input: FILENUM -- a File, or Subfile, number + ;"Result: 1 if file is a subfile + QUIT ($DATA(^DD(FILENUM,0,"UP"))>0) + ; + ; +HASPTRSF(FILENUM) ;" HAS POINTER-CONTAINING SUBFILES + ;"Purpose: Return if file contains subfiles (or sub-subfiles) that contain pointers to other files) + ;"Input: FILENUM -- The file number to investigatge + ;"Results: 1 if has pointer subfiles. + ;"; + NEW RESULT SET RESULT=0 + NEW FLD SET FLD=0 + FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO + . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0)) + . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2) + . IF (+FLDTYPE'>0) QUIT + . NEW SUBFILEN SET SUBFILEN=+FLDTYPE + . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT + . SET RESULT=$$HASPTR(SUBFILEN) + QUIT RESULT + ; + ; +HASPTR(FILENUM) ;" HAS POINTER fields + ;"Purpose: Return if file contains fields that are pointers to other files + ;"Input: FILENUM -- The file number to investigatge + ;"Results: 1 if has pointer subfiles. + ;" + NEW RESULT SET RESULT=($DATA(^DD(FILENUM,0,"PT"))'=0) + IF RESULT GOTO HPDN + NEW FLD SET FLD=0 + FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO + . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0)) + . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2) + . IF +$PIECE(FLDTYPE,"P",2)>0 SET RESULT=1 QUIT + . IF (+FLDTYPE'>0) QUIT + . NEW SUBFILEN SET SUBFILEN=+FLDTYPE + . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT + . SET RESULT=$$HASPTRSF(SUBFILEN) +HPDN QUIT RESULT + ; + ; +FILENAME(FILENUM) ; + ;"Purpose: to turn a File number into a file name. ALSO, turn input with format of + ;" SubfileNumber{ParentFileNumber into a meaningful name too. + ;"Input: FILENUM: A file number, or a SubfileNumber{ParentFileNumber + ;"Result: returns name or name{name{name + ;" + IF (FILENUM'["{"),$$ISSUBFIL(+FILENUM) DO + . SET FILENUM=$$GETSPFN(FILENUM) + NEW RESULT SET RESULT="" + NEW I + FOR I=1:1:$LENGTH(FILENUM,"{") DO + . NEW ANUM SET ANUM=$PIECE(FILENUM,"{",I) + . NEW PFILE SET PFILE=+$GET(^DD(ANUM,0,"UP")) + . NEW ANAME + . IF PFILE=0 DO + . . SET ANAME=$PIECE($GET(^DIC(ANUM,0)),"^",1) + . ELSE DO + . . SET ANAME=$PIECE($GET(^DD(ANUM,0)),"^",1) + . . SET ANAME=$PIECE(ANAME,"SUB-FIELD",1) + . . SET ANAME=$$TRIM^XLFSTR(ANAME) + . IF RESULT'="" SET RESULT=RESULT_"{" + . SET RESULT=RESULT_ANAME + QUIT RESULT + ; + ; +GETSPFN(FILENUM) ;" Get Special Filenum + ;"Purpose: Turn a subfile number into a 'special' subfilenumber, in format of: + ;" SubFileNum{ParentFileNum{GrandParentFileNum.... + ;"Results: 0 if problem, or Top-most filenumber. + NEW RESULT SET RESULT="" + NEW FN SET FN=FILENUM + FOR DO QUIT:FN=0 + . IF RESULT'="" SET RESULT=RESULT_"{" + . SET RESULT=RESULT_FN + . SET FN=+$GET(^DD(FN,0,"UP")) + QUIT RESULT + ; + ; Index: cprs/branches/tmg-cprs/m_files/TMGIDE.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE.m (revision 896) @@ -0,0 +1,1034 @@ +TMGIDE ;TMG/kst/A debugger/tracer for GT.M ;03/25/06 ; 5/14/10 6:17pm + ;;1.0;TMG-LIB;**1**;03/29/09 + + ;" A Debug/Tracer for GT.M + ;" + ;" K. Toppenberg + ;" (c) 4-13-2005 + ;" License: LGPL Applies + ;" + ;" + ;" This program will launch a shell for the TMG STEP TRAP debugger + ;" It provides the user with a prompt, like this: + ;" + ;" (^ to quit) IDE> + ;" + ;" Any valid M code may be entered here. To use the tracing + ;" ability, launch a function, like this: + ;" + ;" (^ to quit) IDE>do ^MyFunction + ;" + ;" + ;" Dependancies: + ;" Uses TMGIDE2,TMGTERM,TMGUSRIF + ;" ^DIM,XGF,XINDX7,XINDX8,XINDEX <-- VA code + ;" %ZVEM* (if available) + ;" + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"Start^TMGIDE -- launch Debugger + ;"BKPT^TMGIDE -- set a breakpoint + ;"KBKPT^TMGIDE -- kill (release) breakpoint + + ;"======================================================================= + ;"PRIVATE API FUNCTIONS + ;"======================================================================= + ;"Prompt + ;"ShutDown + ;"ParsePos(pos,label,offset,routine,dmod) + ;"ConvertPos(Pos,pArray) + ;"ScanMod(Module,pArray) + ;"BROWSENODES(current,Order,paginate,countNodes) + ;"ShowNodes(pArray,order,paginate,countNodes) + ;"ListCt(pArray) + ;"TrimL(S,TrimCh) + ;"TrimR(S,TrimCh) + ;"Trim(S,TrimCh) + ;"Substitute(S,Match,NewValue) + ;"REPLACE(IN,SPEC) + ;"DebugWrite(DBIndent,s,AddNewline) + ;"DebugIndent(DBIndentForced) + ;"$$ArrayDump(ArrayP,TMGIDX,indent) + ;"ExpandLine(Pos) + ;"CREF(X) + ;"LGR() + ;"UP(X) + ;"READ(XGCHARS,XGTO) + ;"READ2(XGCHARS,XGTO) + + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + +START +Start + ;"Purpose: To Launch debugger. This is the entry point + ; + new tmgDbgOptions + set tmgDbgOptions("TRACE")=0 ;"Turn off trace record by default + set tmgDbgOptions("VARTRACE")=0 ;"Turn off trace vars by default + kill ^TMG("TMGIDE",$J,"TRACE") ;"Delete former trace record when starting new run + kill ^TMG("TMGIDE",$J,"VARTRACE") ;"Delete former var trace record when starting new run + ; + set $ZSTEP="" ;"Temporarily clear, in case active from prior run. <-- doesn't work... + do EnsureEnv ;"Ensure fileman environment setup. + do ClrDeadInfo ;"clear out any old data from dead jobs. + ;"Set up variables with global scope (used by TMGIDE2) + if $$GetScrnSize^TMGKERNL(,.TMGScrWidth) + if $get(TMGScrWidth)="" set TMGScrWidth=$get(IOM,66)-1 + if $get(TMGScrHeight)="" set TMGScrHeight=10 + set TMGLROffset=0 + set TMGTrap=1 + set tmgStepMode="into" + set tmgRunMode=1 + set TMGZTRAP=$ZTRAP + + new TMGdbgHideList + set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) + kill @TMGdbgHideList + if 1=1 do + . set @TMGdbgHideList@("TMGIDE*")="" + else do + . set @TMGdbgHideList@("TMGIDE")="" + . set @TMGdbgHideList@("TMGIDE1")="" + . set @TMGdbgHideList@("TMGIDE2")="" + . set @TMGdbgHideList@("TMGIDE3")="" + . set @TMGdbgHideList@("TMGIDE4")="" + . set @TMGdbgHideList@("TMGIDE5")="" + . ;"set @TMGdbgHideList@("TMGIDE6")="" + set @TMGdbgHideList@("TMGTERM")="" + set @TMGdbgHideList@("TMGSTUTL")="" + set @TMGdbgHideList@("X*")="" + set @TMGdbgHideList@("%*")="" + ;"set @TMGdbgHideList@("DI*")="" + set @TMGdbgHideList@("%ZVE")="" + set @TMGdbgHideList@("%ZVEMK")="" + set @TMGdbgHideList@("XLFSTR")="" + set @TMGdbgHideList@("XGF")="" + set @TMGdbgHideList@("XGKB")="" + + do SetGlobals^TMGTERM + do EnsureBreakpoints^TMGIDE2() + do InitColors^TMGIDE6 + + new UsrSlct +M1 new Menu + set Menu(0)="Welcome to the TMG debugging environment" + set Menu(1)="Start debugger in THIS window."_$char(9)_"AllInOne" + set Menu(2)="Start debugger CONTROLLER for another Process."_$char(9)_"StartController" + set Menu(3)="Debug, SENDING control to a Controller."_$char(9)_"StartSender" + set Menu(4)="Set a custom breakpoint"_$char(9)_"SetBreakpoint" + set Menu(5)="Kill a custom breakpoint"_$char(9)_"KillBreakpoint" + set Menu(6)="Debug ANOTHER PROCESS"_$char(9)_"Interrupt" + set Menu(7)="KILL ANOTHER PROCESS"_$char(9)_"KillOther" + set Menu(8)="Run ^ZJOB"_$char(9)_"ZJob" + set Menu(9)="View TRACE log from last run"_$char(9)_"Trace" + + set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") + kill Menu ;"Prevent from cluttering variable table during debug run + + if UsrSlct="AllInOne" goto MenuDone + if UsrSlct="StartController" do Controller^TMGIDE3 goto M1 + if UsrSlct="StartSender" do Sender^TMGIDE4() goto M1 + if UsrSlct="SetBreakpoint" do BKPT goto M1 + if UsrSlct="KillBreakpoint" do KBKPT goto M1 + if UsrSlct="Interrupt" do PICKINTR^TMGIDE5 goto M1 + if UsrSlct="KillOther" do KillOther goto M1 + if UsrSlct="ZJob" do ^ZJOB goto M1 + if UsrSlct="Trace" do ShowTrace^TMGIDE6 goto M1 + if UsrSlct="^" goto Done + if UsrSlct=0 set UsrSlct="" + goto M1 + +MenuDone + do + . new i for i=1:1:10 write ! + write !,"Welcome to the TMG debugging environment",! + write "Enter any valid M command...",! + do SetErrTrap + do Prompt("AllInOne") +Done + do ShutDown + quit + + ;"------------------------------------------------------------------- +SetErrTrap + set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break" + set $ZSTATUS="" + quit + +Prompt(Mode) + ;"Purpose: to interact with user and run through code. + ;"Mode: OPTIONAL: Default is 'AllInOne' + ;" AllInOne --> debug output to same window + ;" SendOut --> debug output to Controller widow + + set Mode=$get(Mode,"AllInOne") + new ideBlankLine + new HxI set HxI="" + new TMGdbgLine set TMGdbgLine="" + new TMGlastline + set tmgStepMode="into" + do SetupVars + do INITKB^XGF() ;"set up keyboard input escape code processing + +Ppt2 do CHA^TMGTERM(1) write ideBlankLine + do CHA^TMGTERM(1) write "(^ to quit) //",TMGdbgLine + ; + set TMGdbgLine=$$Read^TMGUSRIF("er",1200,,TMGdbgLine,.tmgXGRT) + do INITKB^XGF() + do TranslateKeys(.TMGdbgLine,tmgXGRT) + ; + if TMGdbgLine="?" do ShowHelp goto Ppt2 + if TMGdbgLine="" set TMGdbgLine=$$GetHx(.HxI,1) goto Ppt2 + if TMGdbgLine="" set TMGdbgLine=$$GetHx(.HxI,-1) goto Ppt2 + if TMGdbgLine="^" set $ZSTEP="" goto PptDne + ; + write ! + do SaveHx(TMGdbgLine) + ; + set tmgRunMode=1 ;"1=Step-by-step mode + set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" + zstep into + ;"consider wrapping the following line in an error trap. But would have to be cleared + ;" somehow to allow QUIT command... + xecute TMGdbgLine + set $ZSTEP="" ;"turn off step capture + write ! + ; + if '$data(ideBlankLine) do SetupVars ;"without out this, crash after running ^XUP + set TMGdbgLine="",HxI="" + set tmgStepMode="into" + goto Ppt2 ;"loop for prompt again. +PptDne quit + +TranslateKeys(UsrInput,tmgXGRT) + ;"Purpose: translate input keys into a standard output. + ;"Input: UsrInput -- PASS BY REFERENCE. + set tmgXGRT=$get(tmgXGRT) + if tmgXGRT="UP" set UsrInput="A" + if tmgXGRT="DOWN" set UsrInput="Z" + if tmgXGRT="RIGHT" set UsrInput="]" + if tmgXGRT="LEFT" set UsrInput="[" + if (UsrInput="") set UsrInput="" + if (UsrInput="A") set UsrInput="" + if (UsrInput="") set UsrInput="" + if (UsrInput="Z") set UsrInput="" + if (UsrInput="") set UsrInput="" + if (UsrInput="[") set UsrInput="" + if (UsrInput="") set UsrInput="" + if (UsrInput="]") set UsrInput="" + ;" + if UsrInput="" set UsrInput="" + if UsrInput="" set UsrInput="" + if UsrInput="" set UsrInput="^" + quit + +GetHx(HxI,Dir) + ;"Purpose: to retrieve saved Hx + ;"Input: HxI -- PASS BY REFERENCE. IN and OUT parameter + ;" This is index of last command retrieved (or should pass as "" if first time) + ;" Dir -- Optional. Default=1. + ;" 1 = get previous history item + ;" -1 = get next history item + ;"Result: returns history item line + new result set result="" + new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY")) + set HxI=$order(@HxRef@(HxI),$get(Dir,1)) + if HxI'="" set result=$get(@HxRef@(HxI)) + quit result + +SaveHx(OneLine) + ;"Purpose: To provide interface to saving command line hx. + ;"Input: OneLine -- the line to store + ;"Output: Will store hx as follows: + ;" ^TMG('TMGIDE',$J,'CMD HISTORY',1)=1st line of Hx + ;" ^TMG('TMGIDE',$J,'CMD HISTORY',2)=2nd line of Hx + ;" ... + new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY")) + new HxI set HxI=+$order(@HxRef@(""),-1) + if $get(@HxRef@(HxI))'=OneLine do + . set @HxRef@(HxI+1)=OneLine + quit + +ShowHelp + write !,"Here you should enter any valid M command, as would normally be",! + write "entered at a GTM> prompt.",! + write " Examples: WRITE ""HELLO"",! or DO ^TMGTEST",! + quit + +SetupVars + set Mode=$get(Mode,"AllInOne") + set $piece(ideBlankLine," ",78)=" " + set TMGlastLine="" + set HxShowNum=0 + quit + +EnsureEnv + ;"Purpose: So ensure Fileman variables setup. + if $text(DT^DICRW)'="" do + . do DT^DICRW ;"ensure fileman's required variables are in place + if +$get(DUZ)'>0 do + . write "Entering TMG IDE. But first, let's set up an environment..." + . new DIC set DIC=200 + . set DIC(0)="MAEQ" + . set DIC("A")="Please type your name: " + . set DIC("?")="Please enter your user name, to setup environmental variables." + . do ^DIC write ! + . if +Y'>0 quit + . do DUZ^XUP(+Y) + quit + + +ClrDeadInfo + ;"Purpose: to clear out any info from dead (prior) runs + new LiveJobs + do MJOBS^TMGKERNL(.LiveJobs) + new JNum set JNum="" + for set JNum=$order(^TMG("TMGIDE",JNum)) quit:(+JNum'>0) do + . if $get(TMGDEBUG) write "Job ",JNum," is " + . if $data(LiveJobs(JNum)) do quit + . . if $get(TMGDEBUG) write "still alive.",! + . if $get(TMGDEBUG) write "still dead... killing it's info.",! + . kill ^TMG("TMGIDE",JNum) + quit + +KillOther + ;"Purpose: To show currently running jobs, and allow user to kill on + ;"Called from TMGIDE + ; + new array +K1 kill array + do MJOBS^TMGKERNL(.array) + kill array($J) ;"don't show this process + new Menu,UsrSlct + new i,j set i="",j=1 + for set i=$order(array(i)) quit:(i="") do + . set Menu(j)="Job "_$get(array(i))_$char(9)_i + . set j=j+1 + if $data(Menu)=0 do goto KODone + set Menu(0)="Pick Job to Kill/Terminate" + set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") + if UsrSlct="^" goto KODone + if UsrSlct=0 set UsrSlct="" goto K1 + if UsrSlct=+UsrSlct do KillPID^TMGKERNL(UsrSlct) goto K1 + goto K1 +KODone quit + + + ;"------------------------------------------------------------------- +ShutDown + do KillGlobals^TMGTERM + kill tmgStepMode ;" 2/10/06 kt + kill ^TMP("TMGIDE",$J,"MODULES") + do VTATRIB^TMGTERM(0) + do RESETKB^XGF ;"turn off XGF escape key processing code. + write "Leaving TMG debugging environment. Goodbye.",! + quit + + ;"------------------------------------------------------------------- +BKPT + ;"Purpose: To ask user for an address, and set a breakpoint there + ;" This can be done from GTM prompt, and debugger will be launched + ;" when this address is reached during normal execution. + + read "Enter breakpoint (e.g. Label+8^MyFunct): ",Pos,! + do SetBreakpoint^TMGIDE2(Pos) + set $ZTRAP="" ;"This makes sure that Fileman error trap is not active + quit + + +KBKPT + ;"Purpose: To ask user for an address, and kill (release) breakpoint there + ;" This can be done from GTM prompt + + read "Enter breakpoint to be killed (released) (e.g. Label+8^MyFunct): ",Pos,! + do RelBreakpoint^TMGIDE2(Pos) + quit + + + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + ;"Support Functions + ;" + ;"Note: I copied functions from other modules trying to reduce dependencies + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + +ParsePos(pos,label,offset,routine,dmod) + ;"NOTE: Duplicate of function in TMGMISC + ;"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) //kt remove 3/1/08, new GTM needs > 8 chars + set label=$piece(s,"^",1) + set offset=$piece(label,"+",2) + set label=$piece(label,"+",1) + ;"set label=$extract(label,1,8) //kt remove 3/1/08, new GTM needs > 8 chars + + quit + + +ConvertPos(Pos,pArray) + ;"NOTE: Duplicate of function in TMGMISC + ;"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="" do goto CPDone + . write "Parse error: Nothing before $ in",cpS,! + + set cpRoutine=$piece(cpS,"^",2) + if cpRoutine="" do goto CPDone + . write "Parse error: No routine specified in: ",cpS,! + + 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 do goto CPDone + . ;"write "Parse error: Can't find ",cpRoutine,",",cpLabel," in stored source code.",! + new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") + set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine + +CPDone + quit cpResult + + +RelConvertPos(Pos,ViewOffset,pArray) + ;"Purpose: to convert a positioning line from one that is relative to + ;" the start of the file to one that is relative to the + ;" last tag/label + ;" e.g. +32^MYFUNCT --> START+8^MYFUNCT + ;" I.e. this function in the OPPOSITE of ConvertPos + ;"Input: Pos -- a position, as returned from $ZPOS + ;" ViewOffset -- the offset from the Pos to get pos for + ;" pArray -- pointer to (name of). Array holding holding tag offsets + ;" see Description in ConvertPos() + ;"Result: returns the new position line, relative to the start of the last tag/label + + ;"write !,"Here in RelConvertPos. Pos=",Pos," ViewOffset=",ViewOffset,! + new zbRelPos,zbLabel,zbOffset,zbRoutine + do ParsePos^TMGIDE(Pos,.zbLabel,.zbOffset,.zbRoutine) + set zbRelPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine + new zbTemp set zbTemp=zbRelPos + ;"5/27/07 I don't know why following line was here. Removing. + ;"It was breaking the setting of breakpoints. I wonder if I have now + ;"broken conditional breakpoints... Figure that out later... + ;"set zbRelPos=$$ConvertPos^TMGIDE(zbRelPos,pArray) + if zbRelPos="" do + . write "Before ConvertPos, zbRelPos=",zbTemp,! + . write "Afterwards, zbRelPos=""""",! + ;"write "Done RelConvertPos. Result=",zbRelPos,! + quit zbRelPos + + +ScanMod(Module,pArray) + ;"NOTE: Duplicate of function in TMGMISC + ;"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 + ;"look for a var with global scope to see how how many characters are significant to GT.M + if $get(zbSigNameLen)="" do + . set zbSigNameLen=$$NumSigChs^TMGMISC() + + for do quit:(smLine="") + . new smCh + . set smLine=$text(+smIdx^@Module) + . if smLine="" quit + . set smLine=$$Substitute(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 label=$piece(label,"(",1) ;"MyFunct(X,Y) --> MyFunct + . . set label=$extract(label,1,zbSigNameLen) + . . set LabelNum=LabelNum+1 + . . set @pArray@(LabelNum,"TAG")=label + . . set @pArray@(LabelNum,"OFFSET")=smIdx + . . set @pArray@(label)=LabelNum + . set smIdx=smIdx+1 + +SMDone + quit + + + +BROWSENODES(current,Order,paginate,countNodes) + ;"NOTE: Duplicate of function in TMGMISC + ;"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) + ;"NOTE: Duplicate of function in TMGMISC + ;"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 zbTemp read *zbTemp:0 + . if zbTemp'=-1 set abort=1 + . set pageCount=pageCount+1 + . if (paginate=1)&(pageCount>pageLen) do + . . new zbTemp + . . read "Press [ENTER] to continue (^ to stop list)...",zbTemp:$get(DTIME,3600),! + . . if zbTemp="^" 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 zbTemp read zbTemp:$get(DTIME,3600),! + + new result set result=$get(Answers(zbTemp)) + + quit result + + +ListCt(pArray) + ;"NOTE: Duplicate of function in TMGMISC + ;"SCOPE: PUBLIC + ;"Purpose: to count the number of entries in an array + ;"Input: 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 + 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 + + +TrimL(S,TrimCh) + ;"NOTE: Duplicate of function in TMGSTUTL + ;"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 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 do + . . set result=$extract(result,2,1024) + quit result + + +TrimR(S,TrimCh) + ;"NOTE: Duplicate of function in TMGSTUTL + ;"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 TrimCh=$get(TrimCh," ") + + 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) + + quit result + + +Trim(S,TrimCh) + ;"NOTE: Duplicate of function in TMGSTUTL + ;"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 + + set TrimCh=$get(TrimCh," ") + + new result set result=$get(S) + set result=$$TrimL(.result,TrimCh) + set result=$$TrimR(.result,TrimCh) + + quit result + + + +Substitute(S,Match,NewValue) + ;"NOTE: Duplicate of function in TMGSTUTL + ;"PUBLIC FUNCTION + ;"Purpose: to look for all instances of Match in S, and replace with NewValue + ;"Input: S - string to alter. Altered if passed by reference + ;" Match -- the sequence to look for, i.e. '##' + ;" NewValue -- what to replace Match with, i.e. '$$' + ;"Note: This is different than $translate, as follows + ;" $translate("ABC###DEF","###","*") --> "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(S,.spec) + quit S + + +REPLACE(IN,SPEC) ;"See $$REPLACE in MDC minutes. + ;"Taken from REPLACE^XLFSTR + quit:'$D(IN) "" + quit:$D(SPEC)'>9 IN + N %1,%2,%3,%4,%5,%6,%7,%8 + set %1=$L(IN) + set %7=$J("",%1) + set %3="" + set %6=9999 + for set %3=$order(SPEC(%3)) quit:%3="" set %6(%6)=%3,%6=%6-1 + for %6=0:0 set %6=$O(%6(%6)) quit:%6'>0 set %3=%6(%6) do:$D(SPEC(%3))#2 RE1 + set %8="" + for %2=1:1:%1 do RE3 + quit %8 +RE1 set %4=$L(%3) + set %5=0 for S %5=$F(IN,%3,%5) Q:%5<1 D RE2 + Q +RE2 Q:$E(%7,%5-%4,%5-1)["X" S %8(%5-%4)=SPEC(%3) + F %2=%5-%4:1:%5-1 S %7=$E(%7,1,%2-1)_"X"_$E(%7,%2+1,%1) + Q +RE3 I $E(%7,%2)=" " S %8=%8_$E(IN,%2) Q + S:$D(%8(%2)) %8=%8_%8(%2) + Q + + +KeyPress(wantChar,waitTime) + ;"NOTE: Duplicate of function in TMGUSRIF + ;"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 zbTemp + set waitTime=$get(waitTime,0) + read *zbTemp:waitTime + if $get(wantChar)=1 set zbTemp=$char(zbTemp) + quit zbTemp + + + +DebugWrite(DBIndent,s,AddNewline) + ;"NOTE: Duplicate of function in TMGDEBUG + ;"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 TMGDEBUG=$get(TMGDEBUG,0) + if TMGDEBUG=0 quit + if (TMGDEBUG=2)!(TMGDEBUG=3),$data(DebugFile) use DebugFile + write s + if $get(AddNewline)=1 write ! + if (TMGDEBUG=2)!(TMGDEBUG=3) use $PRINCIPAL + quit + + +DebugIndent(DBIndentForced) + ;"NOTE: Duplicate of function in TMGDEBUG + ;"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) + ;"NOTE: Duplicate of function in TMGDEBUG + ;"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 to display, i.e. "^VA(200)" + ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) + ;" 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 + ;"Result: 0=OK to continue, 1=user aborted display + + new result set result=0 + if $$UserAborted^TMGUSRIF set result=1 goto ADDone + new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" + +AD1 if $data(ArrayP)=0 goto ADDone + new abort set abort=0 + if (ArrayP["@") do goto:(abort=1) ADDone + . new zbTemp set zbTemp=$piece($extract(ArrayP,2,99),"@",1) + . if $data(zbTemp)#10=0 set abort=1 + ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. + new X set X="SET zbTemp=$GET("_ArrayP_")" + set X=$$UP(X) + do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. + if $get(X)="" goto ADDone + + 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="" if result=1 goto ADDone + . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) + . if tTMGIDX="" set indent(indent)=0 + . new tIndent merge tIndent=indent + . set result=$$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 + quit result + + +ExpandLine(Pos) + ;"NOTE: Duplicate of function in TMGDEBUG + ;"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(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(Pos,"CodeArray") + . do ParsePos(Pos,.label,.offset,.RTN,.dmod) + + if RTN="" goto ELDone + + do BUILD^XINDX7 + set ^UTILITY($J,RTN)="" + do LOAD^XINDEX + set CCN=0 + do + . new I + . for I=1:1:+^UTILITY($J,1,RTN,0,0) set 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 + . set LIN=^(LC,0),ML=0,IDT=10 + . set LO=LC-1 + . do CD^XINDX8 + + kill AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY + + set IOSL=tIOSL ;"restore saved IOSL +ELDone + quit + + + +CREF(X) + ;"Taken from CREF^DILF --> ENCREF^DIQGU + ;"Convert an open reference to a closed reference + new L,X1,X2,X3 + set X1=$piece(X,"(") + set X2=$piece(X,"(",2,99) + set L=$length(X2) + set X3=$translate($extract(X2,L),",)") + set X2=$extract(X2,1,(L-1))_X3 + + quit X1_$select(X2]"":"("_X2_")",1:"") + + +LGR() + ;"Taken from LGR^%ZOSV + ;" Last global reference ($REFERENCE) + quit $R + +UP(X) + ;"Taken from UP^XLFSTR + quit $translate(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + + +READ() + ;"Purpose: To read user input, with knowledge of arrow keys + ;" This will use VPE keyboard handling if available, otherwise XGF stuff + ;"Result: Will return all user input up to a terminator (RETURN, or a special key) + ;" See code in %ZVEMKRN for possible code returns. format + + ;"9/3/06 -- don't use VPE keyboard anymore + quit $$OLDREAD(,604800) ;"set timeout to 1 week (604800 secs). + + if $text(+0^%ZVEMKRN)="" quit $$OLDREAD() + + new key,FnKey + new done set done=0 + new result set result="" + + for do quit:(done=1) + . ;"READ^%ZVEMKRN(PROMPT,LENGTH,NOECHO) ; + . ;"PROMPT Display prompt. + . ;"LENGTH Maximum # of characters user may enter. + . ;"NOECHO 1=Do not echo what user types. + . set key=$$READ^%ZVEMKRN("",1,0) + . set FnKey=$get(VEE("K")) + . if FnKey="" set done=1,FnKey="" quit + . if (FnKey="")!(FnKey="") do + . . set result=$extract(result,1,$length(result)-1) + . . write $char(8)_" "_$char(8) ;"a backspace char + . . set FnKey="" set key="" + . if FnKey'="" set key=FnKey,done=1 + . if key'="" set result=result_key + + quit result + + +OLDREAD(XGCHARS,XGTO) + ;"Taken from READ^XGF + ;"read the keyboard + ;"XGCHARS:number of chars to read, XGTO:timeout + quit $$READ2($G(XGCHARS),$G(XGTO)) + + +READ2(XGCHARS,XGTO) ;"Taken from READ^XGKB + ;"Purpose: Read a number of characters, using escape processing. + ;"Input: XGCHARS -- number of characters to read + ;" XGTO -- timeout (optional). + ;"Result -- User input is returned. + ;" -- Char that terminated the read will be in tmgXGRT + ;" e.g. "UP" + ;" "PREV" + ;" "DOWN" + ;" "NEXT" + ;" "RIGHT" + ;" "LEFT" + + N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence + K DTOUT + S tmgXGRT="" + D:$G(XGTO)="" ;set timeout value if one wasn't passed + . I $D(XGT) D Q ;if timers are defined + . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers + . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window + . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name + . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever + . S XGTO=$G(DTIME,600) + ; + I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read + E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible + S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ + ; + S:$L($ZB) tmgXGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any + I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out + . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") + E I $L(tmgXGRT),$D(^TMP("XGKEY",$J,tmgXGRT)) X ^(tmgXGRT) ;do some action + ; this really should be handled by keyboard mapping -- later + Q S Index: cprs/branches/tmg-cprs/m_files/TMGIDE2.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE2.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE2.m (revision 896) @@ -0,0 +1,1091 @@ +TMGIDE2 ;TMG/kst/A debugger/tracer for GT.M (core functionality) ;03/25/06 + ;;1.0;TMG-LIB;**1**;03/23/09 + + ;" GT.M TRAP STEP + ;" + ;" K. Toppenberg + ;" 4-13-2005 + ;" License: GPL Applies + ;" + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + ;" This code module will allow tracing through code. + ;" It is used as follows: + ;" + ;" set $ZSTEP="do STEPTRAP^TMGIDE2($ZPOS) zstep into zcontinue" + ;" zstep into + ;" do ^MyFunction ;"<--- put the function you want to trace here + ;" + ;" set $ZSTEP="" ;"<---turn off step capture + ;" quit + ;" + ;" + ;" Dependencies: + ;" Uses: ^TMGTERM,^TMGIDE + ;" + ;"Notes: + ;" This function will be called inbetween lines of the main + ;" program that is being traced. Thus this function can't do + ;" anything that might change the environment of the main + ;" program. + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"STEPTRAP(tmgIDEPos,TMGMsg) + ;"ErrTrap(tmgIDEPos) + + ;"======================================================================= + ;"PRIVATE API FUNCTIONS + ;"======================================================================= + ;"EvalWatches + ;"BlankLine + ;"ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset) + ;"GetStackInfo(Stack,tmgOrigIDEPos) + ;"SetBreakpoint(pos,Condition) + ;"RelBreakpoint(pos) + + ;"======================================================================= + ;"======================================================================= + + +STEPTRAP(tmgIDEPos,TMGMsg) + ;"Purpose: This is the line that is called by GT.M for each zstep event. + ;" It will be used to display the current code execution point, and + ;" query user as to plans for future execution: run/step/ etc. + ;"Input: tmgIDEPos -- a text line containing position, as returned bye $ZPOS + ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info. + ;" If TMGMsg=1, then this function was called without the + ;" $ZSTEP value set, so this function should set it. + ;"Global-scoped vars used: + ;" tmgDbgRemoteJob = remote $J if controlling a remote process + ;" Won't exist (or will be 0) otherwise. + ;" tmgRunMode -- + ;" tmgStepMode -- + ;" TMGScrHeight -- + ;" TMGScrWidth -- + ;" TMGLROffset -- + ;" TMGdbgHideList (an array REF) -- holds modules to hide + ;"Result: desired mode for next time: + ;" 1=step into + ;" 2=step over + ;" 3-step outof + ;" (anything else) -- stop debugging. <-- I think... + ;" 0-->signals request to stop when remote debugging. + + ;"tmgRunMode: 0=running mode (NOTE: tmgRunMode comes from tmgRunMode) + ;" 1=stepping mode + ;" 2=Don't show code + ;" 3=running SLOW mode + ;" -1=quit + new tmgdbgTruth set tmgdbgTruth=$TEST ;"save initial value of $TEST + if $ZTRAP'["^TMG" do SetErrTrap^TMGIDE ;"ensure no redirecting of error trap + new tmgDbgResult set tmgDbgResult=1 ;"1=step into, 2=step over + new tmgDbgNakedRef set tmgDbgNakedRef=$$LGR^TMGIDE ;"save naked reference + set tmgDbgHangTime=+$get(tmgDbgHangTime,0.25) + + set tmgRunMode=$get(tmgRunMode,1) + ;"Keep track of changes to variable system table + if (tmgRunMode'=0)&(+$get(tmgDbgOptions("VARTRACE"))=1) do RecordVTrace^TMGIDE6 + set tmgStepMode=$get(tmgStepMode,"into") + + set tmgDbgRemoteJob=+$get(tmgDbgRemoteJob) + new TMGdbgJNum set TMGdbgJNum=$J + if tmgDbgRemoteJob set TMGdbgJNum=tmgDbgRemoteJob + new ArrayName set ArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES")) + new %TMG set %TMG=$get(%) + + new tpBlankLine,tpAction,tpKeyIn,tpI,tpDone + new ViewOffset set ViewOffset=0 + + new savedIO,savedX,savedY + set savedIO=$IO + set savedX=$X,savedY=$Y + + new ScrHeight,ScrWidth,LROffset + set ScrHeight=$get(TMGScrHeight,10) + set ScrWidth=+$get(TMGScrWidth) + if (ScrWidth'>0)!(tmgRunMode=1) do ;"If pause after every show, take time to check dimensions. + . if $$GetScrnSize^TMGKERNL(,.ScrWidth) + . set TMGScrWidth=ScrWidth + set LROffset=$get(TMGLROffset,0) + use $P:(WIDTH=ScrWidth:NOWRAP) ;"reset IO to the screen + + set tpBlankLine=" " + for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " + + new relPos set relPos=tmgIDEPos + new tmgOrigIDEPos set tmgOrigIDEPos=tmgIDEPos + new tempPos set tempPos=$$ConvertPos^TMGIDE(tmgIDEPos,ArrayName) + if tempPos'="" set tmgIDEPos=tempPos + + ;"don't show hidden modules (setup in TMGIDE module) + if $$ShouldSkip($piece(tmgIDEPos,"^",2)) goto SPDone + ;"Record trace, if not a hidden module + if +$get(tmgDbgOptions("TRACE"))=1 do RecordTrace^TMGIDE6(tmgOrigIDEPos) + + ;"Note: Conditional Breakpoints: I will have to try to get this working later. + ;"I have it such that the condition is recognized. But now I need to + ;"Differientate between stepping through code, and a breakpoint from + ;"a full speed run. + new stpSkip set stpSkip=0 + if $$IsBreakpoint(tmgIDEPos) do ;"goto:(stpSkip=1) SPDone + . new ifS set ifS=$$GetBrkCond(tmgIDEPos) if ifS="" quit + . new $etrap set $etrap="write ""ERROR in breakpoint condition code."",! quit" + . if (@ifS=0) set stpSkip=1 + . if @ifS write "Condition FOUND!!" ;"do PressToCont^TMGUSRIF + + do VCUSAV2^TMGTERM + new CsrOnBreakline set CsrOnBreakline=0 + if tmgRunMode'=2 do ;"2=Don't show code + . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) + . write CsrOnBreakline,! ;"temps + else do + . do CUP^TMGTERM(1,2) + write tpBlankLine,! + write tpBlankLine,! + do CUU^TMGTERM(2) + if tmgRunMode'=1 do ;"Not stepping mode + . write tpBlankLine,! + . do CUU^TMGTERM(1) + . do EvalWatches + . write "(Press any key to pause" + . if tmgRunMode=3 write "; '+' for faster, '-' for slower)",! + . else write ")",! + . read *tpKeyIn:0 + . if tmgRunMode=3 do + . . if tpKeyIn=43 set tmgDbgHangTime=tmgDbgHangTime/2 ;"43= '+' + . . else if tpKeyIn=45 set tmgDbgHangTime=tmgDbgHangTime*2 ;"45= '-' + . . hang tmgDbgHangTime + . if (tpKeyIn>0) set tmgRunMode=1 + if tmgRunMode'=2 do ;"2=Don't show code + . do CmdPrompt ;"display prompt and interact with user + do VCULOAD2^TMGTERM + ; +SPDone ;"Finish up and return to GTM execution + if tmgStepMode="into" set tmgDbgResult=1 + if tmgStepMode="over" set tmgDbgResult=2 + if tmgStepMode="outof" set tmgDbgResult=3 + + + if $get(TMGMsg)=1 do ;"call was without $ZSTEP set, so we should set it. + . new code set code="N TMGTrap " + . set code=code_"S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) " + . set code=code_"zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof " + . set code=code_"zcontinue" + . ;"set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof zcontinue" + . set $ZSTEP=code + . zstep:(tmgDbgResult=1) into + . zstep:(tmgDbgResult=2) over + . zstep:(tmgDbgResult=3) outof + + + ;"Restore environment + if $data(savedIO) use savedIO ;"turn IO back to what it was when coming into this function. + set $X=+$get(savedX),$Y=+$get(savedY) ;"Restore screen POS variables. + set %=%TMG + if tmgDbgNakedRef'["""""" do ;"If holds "" index, skip over + . new discard set discard=$get(@tmgDbgNakedRef) ;"restore naked reference. + if tmgdbgTruth ;"This will restore initial value of $TEST + quit tmgDbgResult + ;"============================================================================ + +CmdPrompt + ;"Purpose: Display the command prompt, and handle user input + ;"Note: uses some variables with global scope, because this code block + ;" was simply cut out of main routine above. + ;"Result: None + if tmgRunMode'=1 quit ;"Only interact with user if in stepping mode (1) + new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" + new tpDone set tpDone=0 + for do quit:tpDone=1 + . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) + . new tempi for tempi=1:1:2 write tpBlankLine,! ;"create empty space below display. + . do CUU^TMGTERM(2) + . if CsrOnBreakline=1 do + . . new ifS set ifS=$$GetBrkCond($$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName)) + . . if ifS'="" write "Breakpoint test: [",ifS,"]",! + . write "}" + . do EvalWatches + . set $X=1 + . write "Action (? for help): " + . write "step "_$$UP^TMGIDE(tmgStepMode)_"// " + . do ClrLine + . set tpAction=$$READ^TMGIDE() write ! + . if tpAction="" set tpAction=$$UP^TMGIDE($extract(tmgStepMode,1,1)) + . new origAction set origAction=tpAction + . do TranslateKeys(.tpAction,$get(tmgXGRT)) + . set tpDone=("RLIHOXTQ"[tpAction) + . if tpAction="R" set tmgRunMode=0 quit ;"Run Quickly + . if tpAction="L" set tmgRunMode=3 quit ;"Run slowly + . if tpAction="H" set tmgRunMode=2 quit ;"HIDE + . if tpAction="I" set tmgStepMode="into" quit ;"Step INTO + . if tpAction="O" set tmgStepMode="over" quit ;"Step OVER + . if tpAction="T" set tmgStepMode="outof" quit ;"Step OUTOF + . if tpAction="X" do HndlDone quit ;"Turn off debugger (keep running) + . if tpAction="Q" do HndlQuit quit ;"Quit from debugger (stop running) + . if tpAction="M" do HndlMCode quit ;"Execute M code + . if tpAction="B" do HndlSetBrk quit ;"Toggle a breakpoint at current location + . if tpAction="E" do HndlExpand quit ;"Expand line + . if tpAction="W" do HndlWatch(origAction) quit ;"Watch + . if tpAction="C" do HndlCstBrk quit ;"Custom breakpoint + . if tpAction="J" do HndlJmpDisp(.tmgIDEPos,.ViewOffset) quit ;"Jump to new display location + . if tpAction="BC" do HndlBrkCond quit ;"Enter a breakpoint condition (IF code) + . if $$MoveKey(tpAction) quit + . if tpAction="+" set TMGScrWidth=$get(TMGScrWidth)+1 quit + . if tpAction="-" set:(TMGScrWidth>10) TMGScrWidth=$get(TMGScrWidth)-1 quit + . if tpAction="=" do HndlScrW quit + . if tpAction="CLS" write # quit + . if tpAction="TABLE" do HndlTable quit + . if tpAction["SHOW" do HndlShow quit + . if tpAction["BROWSE" do HndlBrowse quit + . if tpAction["NODES" do HndlNodes quit + . if tpAction["STACK" do HndlStack(.tmgIDEPos,.ViewOffset) quit + . if tpAction["RESYNC" kill @ArrayName quit + . if tpAction["HIDE" do SetupSkips quit + . if tpAction["FULL" do FULL^VALM1,INITKB^XGF() quit + . if tpAction["UCASE" do HndlToggleMode("UCASE") quit + . if tpAction["LCASE" do HndlToggleMode("LCASE") quit + . if tpAction["XCMD" do HndlToggleMode("XCMD") quit + . if tpAction["SCMD" do HndlToggleMode("SCMD") quit + . if tpAction["TRACE" do ShowTrace^TMGIDE6 quit + . if tpAction["TVDIFF" do HndlToggleMode("VARTRACE") quit + . if tpAction["VDIFF" do ShowVTrace^TMGIDE6 quit + . if tpAction["COLORS" do EditColors^TMGIDE6 quit + . if tpAction["INITKB" do INITKB^XGF() quit ;"set up keyboard input escape code processing + . else do HndlHelp quit + quit + +BlankLine ; + write tpBlankLine + do CHA^TMGTERM(1) ;"move to x=1 on this line + quit + +ClrLine ; + ;"Purpose: clear out line + new loop + new tempX set tempX=$X + for loop=1:1:20 write " " + for loop=1:1:20 write $char(8) ;"backspace + set $X=tempX + quit + +TranslateKeys(tpAction,tmgXGRT) + ;"Purpose: translate input keys into a standard output. + ;"Input: tpAction -- PASS BY REFERENCE. + set tpAction=$$UP^TMGIDE(tpAction) + set tmgXGRT=$get(tmgXGRT) + if tmgXGRT="UP" set tpAction="A" + if tmgXGRT="PREV" set tpAction="AA" + if tmgXGRT="DOWN" set tpAction="Z" + if tmgXGRT="NEXT" set tpAction="ZZ" + if tmgXGRT="RIGHT" set tpAction="]" + if tmgXGRT="LEFT" set tpAction="[" + if (tpAction="") set tpAction="" + if (tpAction="A") set tpAction="" + if (tpAction="AA") set tpAction="" + if (tpAction="") set tpAction="" + if (tpAction="Z") set tpAction="" + if (tpAction="ZZ") set tpAction="" + if (tpAction="") set tpAction="" + if (tpAction="[") set tpAction="" + if (tpAction="[[") set tpAction="" + if (tpAction="") set tpAction="" + if (tpAction="]") set tpAction="" + if (tpAction="]]") set tpAction="" + if (tpAction="^") set tpAction="Q" + if "wW"[$piece(tpAction," ",1) set tpAction="W" + quit + +MoveKey(tpAction) + ;"Purpose: Handle movement keys + ;"result: 1 if tpAction is a movement key, 0 otherwise + if (tpAction="") do quit 1 + . set ViewOffset=ViewOffset-1 + if (tpAction="") do quit 1 + . set ViewOffset=ViewOffset+1 + if (tpAction="") do quit 1 + . set ViewOffset=ViewOffset-1 + . set ViewOffset=ViewOffset-ScrHeight+2; + if (tpAction="") do quit 1 + . set ViewOffset=ViewOffset+1 + . set ViewOffset=ViewOffset+ScrHeight-2; + if (tpAction="") do quit 1 + . if LROffset>1 set LROffset=LROffset-1 + if (tpAction="") do quit 1 + . set LROffset=0 + if tpAction="" do quit 1 + . if LROffset=0 set LROffset=1 + . set LROffset=LROffset+1 + if (tpAction="") do quit 1 + . if LROffset=0 set LROffset=1 + . set LROffset=LROffset+20 + quit 0 + +EvalWatches + ;"Purpose: Run code that evaluates watches. + if $get(tmgWatchLine)'="" do + . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" + . xecute tmgWatchLine + if $data(tmgDgbWatches("*")) do ShowVTrace^TMGIDE6 + write ! + quit + +HndlMCode ; + ;"Purpose: Handle option to execute arbitrary code. + do CUU^TMGTERM(1) + do CHA^TMGTERM(1) ;"move to x=1 on this line + write tpBlankLine,! + do CUU^TMGTERM(1) + set tpLine=$$Trim^TMGIDE($piece(origAction," ",2,999)) + if tpLine="" read " enter M code (^ to cancel): ",tpLine,! + if (tpLine'="^") do + . if +$get(tmgDbgRemoteJob) do RemoteXecute(tpLine) quit + . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" + . write ! ;"get below bottom line for output. + . xecute tpLine + quit + +HndlShow; + ;"Purpose: Handle option to show a variable. + do Box + do SetColors("NORM") + do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) + new varName set varName=$$Trim^TMGSTUTL($extract(origAction,5,999)) + if +$get(tmgDbgRemoteJob) set varName=$$GetRemoteVar(varName) + write ! ;"get below bottom line for output. + new zbTemp set zbTemp=0 + if varName["$" do + . new tempCode + . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" + . write varName,"='" + . set tempCode="do DebugWrite(1,"_varName_")" + . xecute tempCode + . write "' " + else if varName'="" do + . set varName=$$CREF^TMGIDE(varName) ;"convert open to closed format + . set zbTemp=$$ArrayDump^TMGIDE(varName) + if zbTemp=0 do + . do SetColors("Highlight") + . do PressToCont^TMGUSRIF + do SetColors("Reset") + quit + +HndlToggleMode(Mode) + ;"Purpose: Toggle UCASE or LCASE in Options + ;"This will effect the translation of all commands into forced Upper Case + ;"or forced Lowercase, or leave as found if both options are set to 0 + quit:($get(Mode)="") + set tmgDbgOptions(Mode)='+$get(tmgDbgOptions(Mode)) + write "Mode for " + if "UCASE,LCASE,XCMD,SCMD"[Mode do + . write "forcing " + . write $select(Mode="UCASE":"UPPER case",Mode="LCASE":"LOWER case",1:"") + . write $select(Mode="XCMD":"expansion",Mode="SCMD":"shortening",1:"") + . write " of mumps command " + if "TRACE"[Mode do + . write "recording TRACE of execution " + write "turned: " + write $select(tmgDbgOptions(Mode)=0:"OFF",1:"ON")," ",! + if tmgDbgOptions(Mode)=1 do + . if Mode="UCASE" set tmgDbgOptions("LCASE")=0 + . if Mode="LCASE" set tmgDbgOptions("UCASE")=0 + . if Mode="XCMD" set tmgDbgOptions("SCMD")=0 + . if Mode="SCMD" set tmgDbgOptions("XCMD")=0 + ;"do PressToCont^TMGUSRIF + quit + +HndlWatch(tpAction) ; + ;"Purpose: Handle option to add watch + do CUU^TMGTERM(1) + do CHA^TMGTERM(1) ;"move to x=1 on this line + write tpBlankLine,! + do CUU^TMGTERM(1) + write !,tpAction ;"TEMP! + if (tpAction["+")!(tpAction["-") do + . new watchVar + . if (tpAction["+") do + . . set watchVar=$$Trim^TMGIDE($piece(origAction,"+",2)) + . . if watchVar="" quit + . . if watchVar="^" set watchVar="tmgDbgNakedRef" + . . set tmgDgbWatches(watchVar)="" + . . if watchVar="*" write "Watching variable CHANGES" + . else if (tpAction["-") do + . . set watchVar=$$Trim^TMGIDE($piece(origAction,"-",2)) + . . if watchVar="" quit + . . if watchVar="^" set watchVar="tmgDbgNakedRef" + . . kill tmgDgbWatches(watchVar) + . set tmgWatchLine="" + . new v set v="" + . for set v=$order(tmgDgbWatches(v)) quit:(v="") do + . . if v="*" quit ;" this signal for watching CHANGES handled elsewhere. + . . set tmgWatchLine=tmgWatchLine_" write """_v_" =["",$get("_v_"),""], """ + else do + . kill tmgDgbWatches + . new tempCode + . read "Enter M code (^ to cancel): ",tempCode,! + . if tempCode'="^" set tmgWatchLine=tempCode + quit + +HndlQuit ; + ;"Purpose: To create a crash, so can quit debugger, OR if in Remote + ;" mode, then do same thing as 'X' command + if +$get(tmgDbgRemoteJob) goto HndlDone ;"quit will occur from there + kill @ArrayName + set $etrap="" ;"remove error trap + write !!!!!!!!!!! + write "CREATING AN ARTIFICIAL ERROR TO STOP EXECUTION.",! + write "--->Enter 'ZGOTO' from the GTM> prompt to clear error.",!! + set $ZSTEP="" ;"turn off step capture + xecute "write CrashNonVariable" + quit + +HndlDone ; + ;"Purpose: To turn off the debugger, allowing program to continue full speed. + ;"Globally-scoped vars uses: tmgDbgResult, tmgStepMode + if +$get(tmgDbgRemoteJob) do + . new temp set temp=$$MessageOut("DONE") + . set tmgStepMode="DONE" + . set tmgDbgResult=0 ;"Will signal to stop looking for remote messages in TMGIDE3 + else do + . set $ZSTEP="" ;"Turn off debugger + set TMGMsg=0 ;"ensure $ZSTEP is not turned back on. + quit + + +HndlScrW ; + ;"Purpose: Handle option to set screen width + new tempWidth + read "Enter screen width: ",tempWidth,! + if (+tempWidth>10) set TMGScrWidth=tempWidth,ScrWidth=tempWidth + set tpBlankLine=" " + for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " + write # ;"clear screen + do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) ;"<---- not working! + quit + +HndlExpand ; + ;"Purpose: handle option to expand one mumps like of code. + new expPos,zbLabel,zbOffset,zbRoutine + do ParsePos^TMGIDE(tmgIDEPos,.zbLabel,.zbOffset,.zbRoutine) + set expPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine + write ! + do ExpandLine^TMGIDE(expPos) + new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) + quit + +HndlStack(ShowPos,ViewOffset) ; + ;"Purpose: Handle option to show and interact with stack. + ;"Input: ShowPos -- OPTIONAL. PASS BY REFERENCE. Will be changed to user selected value. + ;" ViewOffset -- OPTIONAL. PASS BY REFERENCE. Will be changed to 0 if user selects new Pos. + ;"Globally scoped vars used: tmgOrigIDEPos + write ! ;"get below bottom line for output. + new Stack do GetStackInfo(.Stack,tmgOrigIDEPos) + new Menu set Menu(0)="Pick Stack Entry to BROWSE TO" + new menuI set menuI=1 + new TMGi for TMGi=1:1 quit:($get(Stack(TMGi))="") do + . new $etrap set $etrap="set $etrap="""",$ecode=""""" + . new addr set addr=$piece($$TRIM^XLFSTR(Stack(TMGi))," ",2) + . new txt set txt=$$TRIM^XLFSTR($text(@addr)) + . set txt=$$TRIM^XLFSTR(txt,$char(9)) + . new line set line=addr_" Code: "_txt + . if $length(line)>TMGScrWidth set line=$extract(line,1,TMGScrWidth-10)_"..." + . set Menu(menuI)=line_$char(9)_addr + . set menuI=menuI+1 + new UsrSlct set UsrSlct=$$Menu^TMGUSRIF(.Menu) + write "User selection: [",UsrSlct,"]",! + if (UsrSlct["^")&($length(UsrSlct)>1) do + . set ShowPos=UsrSlct + . set ViewOffset=0 + write # ;"clr screen. + quit + +HndlNodes ; + ;"Purpse: Handle option to browse a variable by nodes. + new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) + write ! ;"get below bottom line for output. + do BRWSASK2^TMGMISC + quit + +HndlBrowse ; + ;"Purpose: Handle option to browse a variable. + new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) + write ! ;"get below bottom line for output. + do BRWSNOD2^TMGMISC(varName) + quit + +HndlBrkCond ; + ;"Purpose: Handle option to browse conditional break + write "Enter an IF condition. Examples: 'A=1' or '$$FN1^MOD(A)=2'",! + read "Enter IF condition (^ to cancel, @ to delete): ",tpLine,! + if (tpLine="^") quit + new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) + do SetBrkCond(brkPos,tpLine) + quit + +HndlCstBrk ; + ;"Purpose: Set a custom breakpoint + new brkPos + read !,"Enter breakpoint (e.g. Label+8^MyFunct): ",brkPos,! + do SetBreakpoint(brkPos) + quit + +HndlSetBrk ; + ;"Purpose: Set breakpoint at current point + ;"write !,"Trying to determine correct breakpoint. relPos=",relPos," ViewOffset=",ViewOffset,! + new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) + ;"write "brkPos=",brkPos,! + if brkPos="" write "relPos=",relPos," view offset=",ViewOffset," ArrayName=",ArrayName,! + do ToggleBreakpoint(brkPos) + quit + +HndlTable ; + ;"Purpose: Handle option for Table command + if +$get(tmgDbgRemoteJob) do + . new temp set temp=$$MessageOut("TABLE") + . if temp="" quit + . new i set i="" + . for set i=$order(@temp@(i)) quit:(i="") do + . . new j set j="" + . . for set j=$order(@temp@(i,j)) quit:(j="") do + . . . write $get(@temp@(i,j)),! + else do + . write ! ;"get below bottom line for output. + . zshow "*" + new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) + quit + +HndlJmpDisp(ShowPos,ViewOffset) + ;"Purpose: to allow user to enter in a location to show in code displayer + ;"Input: ShowPos : PASS BY REFERENCE. The new location to change to + ;" ViewOffset : PASS BY REFERECE. Will be changed to 0 if ShowPos changed. + new tempLoc + write "(Example: MYLABL+2^MYCODE)",! + write "Enter location to jump display to: " + read tempLoc:$get(DTIME,999),! + if (tempLoc'="^")&(tempLoc["^")&(tempLoc'[" ") do + . if $TEXT(@tempLoc)'="" do + . . set ShowPos=tempLoc + . . set ViewOffset=0 + . else do + . . write "Sorry. No code found at ",tempLoc,! + . . do PressToCont^TMGUSRIF + quit + ; +HndlHelp ; + ;"Purpose: Handle option for help. + do Box + do SetColors("NORM") + do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) + do HlpWrite(" {L} : Run sLow mode | {M} : exec M code | {SHOW [var]} : show [var]") + do HlpWrite(" {O} : Step OVER line | {I} : step INTO line | {STACK} : stack show/jump") + do HlpWrite(" {R} : Run | {T} Step OUT | {H} : Hide debug code | {CLS} : clear screen") + do HlpWrite(" {B} : Toggle Brkpoint | {C} : Custom breakpoint| {BC} : breakpoint code") + do HlpWrite(" {W} : Set watch code | {W +MyVar} :Watch MyVar| {W -MyVar} :Remove watch") + do HlpWrite(" {A},{AA} : Scroll up | {Z},{ZZ} : Scroll down | {W +^} : Add Naked Ref") + do HlpWrite(" {[},{[[} : Scroll left | {]},{]]} : Scroll right | {W +*} : Watch Var changes") + do HlpWrite(" {X} : Turn off debug | {Q} : Abort | {BROWSE} [var] : browse [var]") + do HlpWrite(" {-},{+} : Screen width | {=} : Enter width | {HIDE} : manage/hide modules") + do SetColors("SPECIAL") + do PressToCont^TMGUSRIF + do Box + do SetColors("NORM") + do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) + do HlpWrite(" {TABLE} : Symbol table | {NODES} : Browse var | {INITKB} : restore key fn") + do HlpWrite(" {J} : Jump display | {FULL} : Undo Scrl Zone | {E} : expand current line") + do HlpWrite(" {UCASE} : Force U Case | {LCASE} : Force L Case | {COLORS} : Edit colors ") + do HlpWrite(" {XCMD} : Force ExpndCmd| {SCMD} : Force ShrtnCmd | {TRACE} : Show Trace ") + do HlpWrite(" {VDIFF} : Show Var Chng| {TVDIFF} Toggle TraceVar| {RESYNC} : sync display ") + ;"write HlpWrite(" "),! + do SetColors("SPECIAL") + do PressToCont^TMGUSRIF + do SetColors("Reset") + quit + ; +HlpWrite(line) + for quit:($length(line)'>0) do + . if $find(line,"{")>0 do + . . new part set part=$piece(line,"{",1) + . . do SetColors("NORM") + . . write part + . . set line=$piece(line,"{",2,999) + . . set part=$piece(line,"}",1) + . . do SetColors("SPECIAL") + . . write part + . . set line=$piece(line,"}",2,999) + . else do + . . do SetColors("NORM") + . . write line,! + . . set line="" + do SetColors("NORM") + quit + +ErrTrap(tmgIDEPos) + ;"Purpose: This is the line that is called by GT.M for each ztrap event. + ;" It will be used to display the current code execution point + if $$ShouldSkip($piece(tmgIDEPos,"^",2)) DO + . write !,"Error at ",$P($ZSTATUS,",",2)," -- in code that debugger can't display.",! + . write "Error is: ",$P($ZSTATUS,",",3,99),! + . write !,"Dropping to command line via BREAK",! + . BREAK + new ScrHeight,ScrWidth + set ScrHeight=$get(TMGScrHeight,10) + set ScrWidth=$get(TMGScrWidth,70) + do VCUSAV2^TMGTERM + do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,0) +ETDone do VCULOAD2^TMGTERM + quit + + +ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset,CsrOnBreakline) + ;"Purpose: This will display code at the top of the screen + ;"Input: ShowPos -- string like this: X+2^ROUTINE[$DMOD] + ;" ScrWidth -- width of code display (Num of columns) + ;" ScrHeight -- height of code display (number of rows) + ;" Wipe -- OPTIONAL. if 1, then code area is wiped blank + ;" ViewOffset -- OPTIONAL. If a value is supplied, then + ;" the display will be shifted up or down (i.e. to view + ;" code other than at the point of execution) + ;" Positive numbers will scroll page downward. + ;" LROffset -- OPTIONAL. if value > 0 then the display + ;" of each line will begin with this number character. + ;" (i.e. will shift screen so that long lines can be seen.) + ;" 0->no offset; 1->no offset (start at character 1); 2->offset 1 + ;" CsrOnBreakline -- OPTIONAL. PASS BY REFERENCE. Will return 1 + ;" if cursor is on a break line, otherwise 0 + + new cdLoop,scRoutine,scLabel,scOffset,scS + new LastRou,LastLabel,LastOffset + new dbFGColor,bBGColor,nlFGColor,nlBGColor + new StartOffset,scCursorLine,cbLineLen + new zBreakIdx set zBreakIdx=-1 + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + new zArrayName set zArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES")) + set ScrWidth=$get(ScrWidth,80) + set ScrHeight=$get(ScrHeight,10) + set LROffset=+$get(LROffset,1) + new ideBlankLine set $piece(ideBlankLine," ",ScrWidth-1)="" + do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) + if $get(Wipe)=1 do goto SCDone ;"Blank screen and then quit + . do SetColors("Reset") + . for cdLoop=0:1:ScrHeight+1 write ideBlankLine,! + + set scS=$piece(ShowPos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE + do ParsePos^TMGIDE(scS,.scLabel,.scOffset,.scRoutine) + if scRoutine="" do goto SCDone + . write !,!,"Error -- invalid position provided to ShowCode routine: ",ShowPos,! + . write "scS=",scS,! + + ;"setup to show a symbol for breakpoint + new zbS set zbS="" + for set zbS=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",zbS)) quit:(zbS="") do + . new zbRoutine,zbLabel,zbOffset + . new tempPos set tempPos=$$ConvertPos^TMGIDE(zbS,zArrayName) + . do ParsePos^TMGIDE(tempPos,.zbLabel,.zbOffset,.zbRoutine) + . if zbRoutine'=scRoutine quit + . if zbLabel'=scLabel quit + . set zBreakIdx(zbOffset)=1 + + if scOffset>(ScrHeight) set StartOffset=(scOffset-ScrHeight)+2 + else set StartOffset=0 + set StartOffset=StartOffset+$get(ViewOffset) + + ;"====Draw the top line ========================================== + do SetColors("NORM") + write "=== " + do SetColors("SPECIAL") + set scS="Routine: "_scLabel_"^"_scRoutine_" " + if $data(tmgOrigIDEPos) set scS=scS_"("_tmgOrigIDEPos_")" + else set scS=scS_"("_ShowPos_")" + write scS + do SetColors("NORM") + write " " + for cdLoop=1:1:ScrWidth-$length(scS)-5 write "=" + do SetColors("NORM") + write ! + + set CsrOnBreakline=0 + for cdLoop=StartOffset:1:(StartOffset+ScrHeight) do + . do SetColors("NORM") + . do SetTempBkColor("Reset") + . new cbLine,cbRef,cbCursor,cBrkLine + . set cBrkLine=$data(zBreakIdx(cdLoop)) + . set cbRef=scLabel_"+"_cdLoop_"^"_scRoutine + . set cbLine=$text(@cbRef) + . set cbLine=$$Substitute^TMGIDE(cbLine,$Char(9)," ") + . if LROffset>0 set cbLine=$extract(cbLine,LROffset,999) + . set scCursorLine=scOffset+$get(ViewOffset) + . new cHighCsrPos set cHighCsrPos=(cdLoop=scCursorLine) + . new cHighExecPos set cHighExecPos=(cdLoop=scOffset) + . if cHighCsrPos do SetTempBkColor("Highlight") + . if cHighExecPos do SetTempBkColor("HighExecPos") + . if cBrkLine do + . . if (cHighCsrPos=0)&(cHighExecPos=0) do + . . . do SetTempBkColor("HighBkPos") + . . else do + . . . do SetTempBkColor("BkPos") + . . . set CsrOnBreakline=1 + . write $select(cdLoop=scOffset:">",cBrkLine:"#",1:" ") + . do SetColors("SPECIAL") + . if cdLoop>0 write "+"_cdLoop_$select(cdLoop<10:" ",1:"") + . else write " " + . do SetColors("NORM") + . if $length(cbLine)>(ScrWidth-1) set cbLine=$extract(cbLine,1,ScrWidth-4)_"..." + . set cbLineLen=$length(cbLine) + . new StartPos set StartPos=$X + . if $get(TMGDEBUG) write cbLine ;"temp + . else set cbLineLen=$$ShowLine^TMGIDE6(cbLine,.tmgDbgOptions,ScrWidth-StartPos) + . write $extract(ideBlankLine,cbLineLen,ScrWidth-StartPos-1) + . do SetTempBkColor("Reset"),SetColors("NORM") + . write ! + + ;"Draw bottom line. + do SetColors("NORM") + ;"do SetColors("SPECIAL") + for cdLoop=1:1:ScrWidth write "~" + ;"do SetColors("NORM") + write ! +SCDone ; + do VTATRIB^TMGTERM(0) ;"reset colors + quit + +SetTempBkColor(mode) + set mode=$get(mode) quit:mode="" + new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) + if mode="Reset" kill @ref@("TEMP BACKGROUND") quit + if "Highlight,HighExecPos,BkPos,HighBkPos"'[mode quit + if $data(@ref)=0 do InitColors^TMGIDE6 + new bg set bg=$get(@ref@(mode)) + if bg="" quit + set @ref@("TEMP BACKGROUND")=bg + quit + ; +SetColors(mode) + ;"Purpose: set colors in central location + ;"Input: Mode -- the mode to change the colors to + ;" bg -- OPTIONAL -- the default background. Default=15 + set mode=$get(mode,"Reset") if mode="" set mode="Reset" + new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) + if $data(@ref)=0 do InitColors^TMGIDE6 + if mode="Reset" do VTATRIB^TMGTERM(0) goto SCDn ;"reset colors + new colorSet merge colorSet=@ref@(mode) ;"Get colors for mode + new fg set fg=$get(colorSet("fg"),15) + new bg set bg=$get(colorSet("bg"),15) + if (bg="@") do + . set bg=$get(@ref@("TEMP BACKGROUND"),"@") + . if bg="@" set bg=$get(@ref@("BACKGROUND"),0) + if fg=bg do + . if (fg<15) set fg=fg+1 + . else if (fg>0) set fg=fg-1 + do VCOLORS^TMGTERM(fg,bg) +SCDn quit; + ; +Box ; + ;"Purpose: Draw a box on the top of the screen. + ;"Globals Scope Vars used: ScrWidth,ScrHeight + set ScrWidth=$get(ScrWidth,80) + set ScrHeight=$get(ScrHeight,10) + new ideBlankLine set $piece(ideBlankLine," ",ScrWidth)=" " + new ideBarLine set $piece(ideBarLine,"=",ScrWidth)="=" + do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) + do SetColors("Highlight") + write ideBarLine,! + do SetColors("NORM") + new cdLoop for cdLoop=0:1:ScrHeight+1 write ideBlankLine,! + do SetColors("Reset") + quit + ; +GetStackInfo(Stack,ExecPos) + ;"Purpose: to query GTM and get back filtered Stack information + ;"Input: Stack -- PASS BY REFERENCE. An array to received back info. Old info is killed + ;" ExecPos -- OPTIONAL. Current execution position + kill Stack + new i,count set count=1 + if $STACK<3 quit ;"0-2 are steps getting into debugger + for i=0:1:$STACK do ;"was 3:1: + . new s set s=$STACK(i,"PLACE") + . if s["TMGIDE" quit + . if s["GTM$DMOD" quit + . if s="@" set s=s_""""_$STACK(i,"MCODE")_"""" + . if s=$get(ExecPos) set s=s_" <--Current execution point" ;",i=$STACK+1 + . set Stack(count)=$STACK(i)_" "_s + . set count=count+1 + quit + + +ToggleBreakpoint(pos,condition) + ;"Purpose: to set or release the GT.M breakpoint at position + ;"Input: pos -- the position to alter + ;" condition -- OPTIONAL -- should be contain valid M code such that + ;" if @condition is valid. Examples: + ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 + ;"write "Here in ToggleBreakoint",! + if $$IsBreakpoint(pos) do + . ;"write " calling RelBreakpoint",! + . do RelBreakpoint(pos) + else do + . ;"write "calling Set breakpoint",! + . do SetBreakpoint(pos,.condition) + quit + +IsBreakpoint(pos) + ;"Purpose: to determine if position is a breakpoint pos + + ;"Note: I am concerned that pos might contain a name longer than 8 chars + ;" and might give a false result, or ^TMP(...) might hold a name + ;" longer than 8 chars. + ;" BUT, if I just cut name off at 8 chars, it might not work well + ;" with GTM v5 + new result set result=0 + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + if $get(pos)'="" set result=$data(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)) + quit (result'=0) + + +EnsureBreakpoints() + ;"Purpose: When an module is recompiled, GT.M drops the breakpoints for + ;" that module. However, the breakpoints are still stored for this + ;" debugger, meaning that the lines will still be highlighted etc, + ;" --but they don't work. This function will go through stored + ;" breakpoints and again register them with GT.M + + new pos set pos="" + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + for set pos=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)) quit:(pos="") do + . do SetBreakpoint(pos) + quit + + +SetBreakpoint(pos,condition) + ;"Purpose: set the GT.M breakpoint to pos position + ;"Input: pos -- the position to alter + ;" condition -- OPTIONAL -- should be contain valid M code such that + ;" if @condition is valid. Examples: + ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 + ;"Globally scoped var used: + ;" tmgDbgRemoteJob-- OPTIONAL -- if controlling a remote process, then = $J of that process + ;" and action should not be done locally. + if $get(pos)="" do goto SBkDone + . write "?? no position specified ??",! + ; + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)="" + do SetBrkCond(pos,.condition) + ; + if $get(tmgDbgRemoteJob) do + . new temp set temp=$$MessageOut("BKPOS "_pos_" "_$get(condition)) + . write "Results from remote process=",temp,! + else do + . new brkLine set brkLine=pos_":""n tmg s tmgRunMode=1 s tmg=$$STEPTRAP^TMGIDE2($ZPOS,1)""" + . new $etrap + . set $etrap="K ^TMG(""TMGIDE"",$J,""ZBREAK"",pos) S $ETRAP="""",$ECODE=""""" + . ZBREAK @brkLine +SBkDone quit + + +SetBrkCond(pos,condition) + ;"Purpose: A standardized SET for condition. + ;"Input: pos -- + ;" condition -- + if $get(condition)="" quit + if $get(pos)="" quit + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + if condition="@" kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF") + else set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")=condition + if $$IsBreakpoint(pos)=0 do SetBreakpoint(pos) + quit + + +GetBrkCond(pos) + ;"Purpose: A standardized GET for condition. + ;"Results: returns condition code, or "" + new result set result="" + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + set:(pos'="") result=$get(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")) + quit result + +RelBreakpoint(pos) + ;"Purpose: to release a GT.M breakpoint at position + new TMGdbgJNum set TMGdbgJNum=$J + if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob + kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos) + if $get(tmgDbgRemoteJob) do goto SBkDone + . new temp set temp=$$MessageOut("RELBKPOS "_pos) + else do + . new brkLine set brkLine=pos_":""zcontinue""" + . ZBREAK @brkLine + ;"write "released breakpoint at: ",pos,! + quit + + +ShouldSkip(module) + ;"Purpose: to see if module is in hidden list + new result set result=0 + if $get(TMGdbgHideList)="" goto SSKDone + + new HideMod set HideMod="" + for set HideMod=$order(@TMGdbgHideList@(HideMod)) quit:(HideMod="")!(result=1) do + . if (module=HideMod) set result=1 quit + . if HideMod'["*" quit + . new tempMod set tempMod=$extract(HideMod,1,$find(HideMod,"*")-2) + . new trimModule set trimModule=$extract(module,1,$length(tempMod)) + . set result=(trimModule=tempMod) +SSKDone + quit result + + +SetupSkips + ;"Purpose: to manage modules that are to be skipped over. + ;"Input: none. But this modifies variable @TMGdbgHideList with global scope + ;"results: none + + ;"For some reason, this gets lost at times.... + if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) + + new menu,option + set menu(0)="Pick Options for Hiding/Showing Modules" + set menu(1)="SHOW current hidden list"_$c(9)_"SHOW" + set menu(2)="ADD module to hidden list"_$c(9)_"ADD" + set menu(3)="REMOVE module from hidden list"_$c(9)_"REMOVE" + set menu(4)="Done."_$c(9)_"^" + +StSkp set option=$$Menu^TMGUSRIF(.menu) + if option="SHOW" do ShowSkip + if option="ADD" do AddSkip + if option="REMOVE" do RmSkip + if option="^" goto StSkDone + goto StSkp + +StSkDone + quit + +AddSkip + ;"Purpose: to allow user to Add a module to hidden list + ;"Input: none. But this modifies variable @TMGdbgHideList with global scope + ;"results: none + +ASKP1 write "Enter name of module to add to hidden list (? for help, ^ to abort)",! + new mod + read "Enter module: ",mod:$get(DTIME,3600),! + if mod="?" do goto ASKP1 + . write "Some modules of the code are not helpful to debugging one's code.",! + . write "For example, if one did not ever want to trace into the code stored",! + . write "in DIC, then DIC would be added as a module to be hidden. Then, when",! + . write "debugging one's own code, all traces into ^DIC would be skipped over.",! + . write "If only part of the name is specified, then ALL modules starting with",! + . write "this name will be excluded.",! + . do PressToCont^TMGUSERIF + if mod="^" goto ASDone + write "Add '",mod,"' as a module to be skipped over" + new % set %=1 + do YN^DICN + if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) + if %=1 set @TMGdbgHideList@(mod)="" + +ASDone + quit + +RmSkip + ;"Purpose: to allow user to remove a module from hidden list + ;"Input: none. But this modifies variable @TMGdbgHideList with global scope + ;"results: none + + new menu,option,idx +RmL1 kill menu + set idx=0 + new mod set mod="" + ;"Load menu with current list. + for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do + . set idx=idx+1,menu(idx)=mod_$c(9)_mod + if $data(menu)=0 goto RmSkipDone + . write "--The list is currently empty--" + . do PressToCont^TMGUSRIF + set idx=idx+1 + set menu(idx)="Done"_$c(9)_"^" + set menu(0)="Pick Module to remove from hidden list" + set option=$$Menu^TMGUSRIF(.menu) + if option="^" goto RmSkipDone + kill @TMGdbgHideList@(option) + goto RmL1 + +RmSkipDone + quit + + +ShowSkip + ;"Purpose: to show the hidden list + ;"Input: none. But this uses variable @TMGdbgHideList with global scope + ;"results: none + + new mod set mod="" + if $data(@TMGdbgHideList)>0 do + . for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do + . . write " ",mod,! + else do + . write "--The list is currently empty--" + do PressToCont^TMGUSRIF + quit + + + ;"============================================= + ;" Code for when controlling another process + ;"============================================= + +MessageOut(Msg,timeOutTime,ignoreReply) + ;"Purpose: For use when in remote-control debugging mode. This will + ;" send a message to SENDER, not waiting for a reply + ;"Input: Msg -- the message to send + ;" timeOutTime -- OPTIONAL, default is 2 seconds + ;" ignoreReply -- OPTIONAL, default is 0 (don't ignore) + ;"Output: the returned message, or "" if timed out or no reply, or ignoreReply=1 + + set timeOutTime=$get(timeOutTime,2) + set ignoreReply=$get(ignoreReply,0) + new result set result="" + set Msg="[CMD] "_$get(Msg) + set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg + set ^TMG("TMGIDE","CONTROLLER","MSG-IN")="" + if (ignoreReply=0) for do quit:(result'="")!(timeOutTime<0) + . set result=$get(^TMG("TMGIDE","CONTROLLER","MSG-IN")) + . if (result'="") quit + . set timeOutTime=timeOutTime-0.1 + . set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg + . hang 0.1 + if $piece(result," ",1)="[RSLT]" do + set result=$piece(result," ",2,999) + else do + . write !,"Unexpected reply: ",result,! + . do PressToCont^TMGUSRIF + . set result="" + + quit result + + +GetRemoteVar(varName) + ;"Purpose: Pass varName to remote process, have it evaluated there, and + ;" then passed back back here for display. + ;"Input: varName -- expression (variable name, or function) to be evaluated. + new temp set temp=$$MessageOut("EVAL "_$get(varName)) + kill @varName + if (temp="")!(temp[" ") do goto GMVD + . write !,"Unexpected var name back: [",temp,"]",! + . set temp="" + merge @varName=@temp +GMVD quit varName + + +RemoteXecute(MCode) + ;"Purpose: Pass M Code to remote process for execution there. + ;"Input: A line of M code, as entered by user. + ;"Results: none + ;"Output: Any IO of M code should be shown in other process's IO + new temp set temp=$$MessageOut("XECUTE "_$get(MCode)) + quit Index: cprs/branches/tmg-cprs/m_files/TMGIDE3.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE3.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE3.m (revision 896) @@ -0,0 +1,235 @@ +TMGIDE3 ;TMG/kst/A debugger/tracer for GT.M (Controller code) ;04/14/08 + ;;1.0;TMG-LIB;**1**;03/23/09 + + ;" TMG IDE Debugger Controller + ;" + ;" K. Toppenberg + ;" 4-14-2008 + ;" License: GPL Applies + ;" + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + ;"Notes: HOW DOES IT ALL WORK? + ;" + ;"Here is how the system fits together: + ;" + ;"Below is what happens in the CONTROLLING job + ;"================================================= + ;" -- LaunchIntr^TMGIDE5(JobNum) sets up a signaling global and then + ;" creates a 'mupip intrpt JobNum', then starts listening + ;" in Controller^TMGIDE3 for communication from the interrupted job. + ;" (See below about how this communication gets started) + ;" -- Controller^TMGIDE3 polls a communicating global location and can talk back + ;" and forth with the other job. When it gets a message to + ;" DO TRAP %ZPOS, it then calls STEPTRAP^TMGIDE2, and returns + ;" the result of that function back to the other job. + ;" -- STEPTRAP^TMGIDE2 is the same interface as the prior debugger. It shows + ;" the code, allows the user to move around, and interact + ;" with the code. If the user wants to query variables + ;" in the other process, then a message is sent out, and + ;" a copy of that variable is passed back here for display. + ;" If the user wants to modify the other environment, then + ;" arbitrary M code can be entered by the user, and it is passed + ;" to the other job for execution in that job process space. + ;" When ready to execute the next line of code, then STEPTRAP + ;" quits with a result signalling a zstep INTO or OVER. + ;" + ;"Below is what happens in the OTHER job + ;"================================================= + ;" -- mupip intrpt JobNum --> causes the specified job to execute the code + ;" stored in $ZINTERRUPT. For VistA (or if setup in + ;" in an environmental script during GT.M launch), this + ;" code is to run JOBEXAM^ZU (slightly customized) + ;" -- JOBEXAM^ZU --> looks for signaling global, and if found runs INTERUPT^TMGIDE5 + ;" -- INTERUPT^TMGIDE5 --> sets up $ZSTEP and then calls ZSTEP INTO and + ;" quits out of the $ZINTERRUPT code. + ;" -- ZSTEP --> causes GT.M to execute the code in $ZSTEP before performing + ;" the next line of mumps code for the program that was + ;" running at the time the interrupt request was received. + ;" -- $ZSTEP holds instruction to run $$STEPTRAP^TMGIDE4($ZPOS) + ;" -- STEPTRAP^TMGIDE4 --> sends message to CONTROLLING JOB and waits for reply. + ;" Reply will either be a request from the user for more + ;" information from this job, or a final reply that allows + ;" execution to continue, either by a step INTO, OVER, or + ;" a plain ZCONTINUE (which will stop further code-stepping) + + +Controller + ;"Purpose: This code will wait for messages from the executing process, and + ;" will display the code as it changes, and send messages back to + ;" all the user to control the process remotely. + + ;"Notice: There are + + ;"A globally-scoped var that will be checked in STEPTRAP^TMGIDE2 + if +$get(tmgDbgRemoteJob)'>0 set tmgDbgRemoteJob=1 + + ;"write # + new i for i=1:1:12 write ! + write "=== TMG IDE Controller (Job# "_$JOB_") ===",!,! + write "Waiting for action from SENDING (Remote) process (ESC to abort)",! + new msgRef set msgRef=$name(^TMG("TMGIDE","CONTROLLER")) + kill @msgRef + set @msgRef@("JOB")=$JOB + + new Msg,UsrInput,Cmd + new hangDelay set hangDelay=0.2 + + new ideBlankLine set $piece(ideBlankLine," ",78)=" " + ;"new HxSize set HxSize=8 ;"hard codes in history length of 8 + new TMGdbgLine + new TMGlastline set TMGlastLine="" + new HxShowNum set HxShowNum=0 + new HxLine,HxLineMax,HxLineCur + do INITKB^XGF() ;"set up keyboard input escape code processing + ; +Init set @msgRef@("STATUS")="AVAIL" + set @msgRef@("MSG-OUT")="" + new TMGstartH set TMGstartH=$piece($H,",",2) + new tempCh,% + ; +Loop set Msg=$get(@msgRef@("MSG-IN")) + set Cmd=$piece(Msg," ",1) + ; + if Cmd="INQ" do HndlINQ(Msg) goto Loop + if Cmd="LISTEN" do HndlListen(Msg) goto Loop + if Cmd="DONE" do HndlDone(Msg) goto LstnDone ;"This is when SENDER signals a quit. + if Cmd="WRITE" do HndlWrite(Msg) goto Loop + if Cmd="DO" goto:($$HndlDo(Msg)'=0) Loop goto LstnDone ;"Leave if CONTROLLER signals a quit + if Cmd="READ" do HndlRead(Msg) goto Loop + if Cmd="NEED" do HndlNeed(Msg) goto Loop + ; + ;"Checking UserAborted grabs keystrokes, and prevents user from getting out of RUN mode + ;"in ^TMGIDE2, so only check here after an X second delay. + if $piece($H,",",2)-TMGstartH<2 goto Loop + read *tempCh:0 + if tempCh'=27 goto Loop + write !,"Abort From Remote Debugging Controller" + set TMGstartH=$piece($H,",",2) + set %=2 do YN^DICN write ! + if %'=1 goto Loop + ; +LstnDone ; + write !,"Quitting.",! + kill @msgRef + kill tmgDbgRemoteJob + quit + ; +;"------------------------------- +;"------------------------------- + ; +ACK SET @msgRef@("MSG-OUT")="ACK "_$J + SET @msgRef@("MSG-IN")="" + QUIT + +HndlINQ(Msg) ;"Expects 'INQ ' + ;"write "Msg=",Msg,! ;"temp!! + set tmgDbgRemoteJob=+$piece(Msg," ",2) + do ACK + quit + +HndlListen(Msg) + new JobToControl + set JobToControl=+$piece(Msg," ",3) + set @msgRef@("STATUS")="LISTENING TO "_JobToControl + set @msgRef@("MSG-OUT")=@msgRef@("STATUS") + DO ACK + quit + +HndlWrite(Msg) + write $piece(Msg," ",2,99),! + DO ACK + quit + +HndlDo(Msg) + ;"Purpose: Handle message from interrupted application to DO something. + ;"Result: 1 = OK to continue + ;" 0 = should quit controller. + new result set result=1 ;"default to continue + new msgResult set msgResult="" + if $piece(Msg," ",2)="PROMPT" do + . set msgResult=$$Prompt() + else if $piece(Msg," ",2)="TRAP" do + . new idePos set idePos=$piece(Msg," ",3) + . new TMGMsg set TMGMsg=$piece(Msg," ",4) + . set msgResult=$$STEPTRAP^TMGIDE2(idePos,TMGMsg) + . if msgResult=0 set result=0 ;"STEPTRAP result of 0 means to stop controller. + set @msgRef@("MSG-OUT")=msgResult + set @msgRef@("MSG-IN")="" + set TMGstartH=$piece($H,",",2) ;"restart timer countdown before allowing user input. + quit result + +HndlDone(Msg) + DO ACK + quit + +HndlRead(Msg) + new result + write $piece(Msg," ",2,99) + read result:$get(DTIME,3600),! + if result="" set result="" + set @msgRef@("MSG-OUT")=result + set @msgRef@("MSG-IN")="" + quit + +HndlNeed(Msg) + set SndJob=+$piece(Msg," ",3) + set @MsgRef@("STATUS")="CONTROLLING "_SndJob + set @MsgRef@("MSG-OUT")=@MsgCtrlRef@("STATUS") + quit + +;"------------------------------------------------------------------- + +Prompt() + ;"Purpose: to interact with user and run through code. + + ;"new i write # for i=1:1:12 write ! + write "=== TMG IDE Controller ===",!,! + +Ppt2 + set HxShowNum=+$get(HxShowNum) + set TMGStepMode="into" ;"kt added 5/3/06 + set HxLine=$get(^TMG("TMGIDE","CMD HISTORY",$J,HxShowNum)) + set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) + + write "Remote command (^ to quit): " + if HxShowNum=0 write "^// " + else write "// ",HxLine + + set TMGdbgLine=$$READ^TMGIDE() ;"$$READ^XGF ;"returns line terminator in tmgXGRT + set tmgXGRT=$get(tmgXGRT) ;"ensure existence + if TMGdbgLine="?" do goto Ppt2 + . write !,"Here you should enter any valid M command, as would normally",! + . write "entered at a GTM> prompt.",! + . write " examples: WRITE ""HELLO"",! or DO ^TMGTEST",! + + if (TMGdbgLine="")&(HxShowNum>0) set TMGdbgLine=HxLine + + if (tmgXGRT="DOWN")!(tmgXGRT="RIGHT")!(TMGdbgLine="]") do goto Ppt2 + . set HxShowNum=HxShowNum-1 + . if HxShowNum<0 set HxShowNum=HxLineMax + . ;"write "setting HxShowNum=",HxShowNum,! + . do CHA^TMGTERM(1) write ideBlankLine do CHA^TMGTERM(1) + + if (tmgXGRT="UP")!(tmgXGRT="LEFT")!(TMGdbgLine="[") do goto Ppt2 + . set HxShowNum=HxShowNum+1 + . if HxShowNum>HxLineMax set HxShowNum=0 + . ;"write "setting HxShowNum=",HxShowNum,! + . do CHA^TMGTERM(1) write ideBlankLine do CHA^TMGTERM(1) + + if TMGdbgLine="" set TMGdbgLine="^" + write ! + + ;"Save Cmd history + set HxLineCur=$get(^TMG("TMGIDE","CMD HISTORY",$J,"CUR"),0) ;"<-- points to last used, not next avail + set HxLineMax=$get(^TMG("TMGIDE","CMD HISTORY",$J,"MAX"),0) ;"equals buffer size AFTER it fills + set HxLineCur=HxLineCur+1 + ;"if HxLineCur>HxSize set HxLineCur=1 + set ^TMG("TMGIDE","CMD HISTORY",$J,HxLineCur)=TMGdbgLine + set ^TMG("TMGIDE","CMD HISTORY",$J,"CUR")=HxLineCur + if HxLineCur>HxLineMax do + . set HxLineMax=HxLineCur + . set ^TMG("TMGIDE","CMD HISTORY",$J,"MAX")=HxLineMax + ;"write "Saving line in #",HxLineCur," Max=",HxLineMax,! + + quit TMGdbgLine Index: cprs/branches/tmg-cprs/m_files/TMGIDE4.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE4.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE4.m (revision 896) @@ -0,0 +1,203 @@ +TMGIDE4 ;TMG/kst/A debugger/tracer for GT.M (Sender code) ;04/14/08 + ;;1.0;TMG-LIB;**1**;03/23/09 + + ;" TMG IDE Debugger Sender + ;" + ;" K. Toppenberg + ;" 4-14-2008 + ;" License: GPL Applies + ;" + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + ;"Notes: HOW DOES IT ALL WORK? See TMGIDE3.m notes + + +Sender(Quiet) + ;"Purpose: This code will be run from process to be debugged. It will + ;" be controlled by another Controlling process. + ;"Input: Quiet : OPTIONAL. If 1 then no TMGIDE extra output from this SENDER + + new TMGdbgResult,TMGdbgXLine + set Quiet=+$get(Quiet) + new MsgSndRef set MsgSndRef=$name(^TMG("TMGIDE","SENDER")) + new % set %=2 ;"default NO + if $data(@MsgSndRef)'=0 do + . if Quiet set %=2 + . else do + . . write "Is another debugging process already running" + . . do YN^DICN write ! + . quit:(%'>0) ;"abort + . if %=2 kill @MsgSndRef quit + . write "OK to kill debug info and start over" + . set %=1 do YN^DICN write ! + . if %=1 kill @MsgSndRef quit + . set %=-1 + if (%'>0) goto SD2 ;"quit + + if 'Quiet write "Waiting up to 60 sec for a CONTROLLER process..." + if $$MessageOut("INQ "_$J,60)="" goto SendDone + if 'Quiet write " OK",! + set TMGdbgResult=$$MessageOut("WRITE Welcome to the TMG debugging environment",,0) + set TMGdbgResult=$$MessageOut("WRITE Enter any valid M command...",,0) +SendL1 + if 'Quiet write !,!,"=== TMG IDE Sender (Job# ",$J,") ===",!,! + if 'Quiet write "Waiting for command from Controller window... (^ to abort)" +SendL2 + set TMGdbgXLine=$$MessageOut("DO PROMPT",9999,0) + if TMGdbgXLine="" goto SendL2 + if TMGdbgXLine="^" goto SendDone + + if 'Quiet write ! + set TMGRunMode=1 ;"1=Step-by-step mode + set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE4($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" + + zstep into + xecute TMGdbgXLine ;"<-- NOTE: step *INTO* this line. Shouldn't return from this until final QUIT of that process + set $ZSTEP="" ;"turn off step capture + goto SendL1 + +SendDone + if 'Quiet write !,"Sending DONE.." + new TMGtemp set TMGtemp=$$MessageOut("DONE",1) + if 'Quiet write TMGtemp,! + kill ^TMG("TMGIDE","SENDER") +SD2 ; + quit + +HndlCmd(Msg) + ;"Purpose: When the user enters a command from the prompt in the controlling process, then that command will be + ;" forwarded here. + new Cmd,result + set result="" + set Cmd=$piece(Msg," ",2) + set Msg=$piece(Msg," ",3,999) + if Cmd="BKPOS" set result=$$HndlBkPos(Msg) goto HCDone + if Cmd="RELBKPOS" set result=$$HndlRelBkPos(Msg) goto HCDone + if Cmd="EVAL" set result=$$HndlEval(Msg) goto HCDone + if Cmd="XECUTE" set result=$$HndlXCod(Msg) goto HCDone + if Cmd="TABLE" set result=$$HndlTable(Msg) goto HCDone + if Cmd="DONE" set result="OK",$ZSTEP="" goto HCDone ;"turn off debugger + ; +HCDone quit "[RSLT] "_result + +HndlEval(Msg) + ;"Purpose: to evaluate a local variable and pass result back to remote controller + new varName set varName=Msg + new result set result="" + new ref set ref=$name(^TMG("TMGIDE","CONTROLLER","MSG-IN","VAR")) + kill @ref + if varName["$" do + . new tempCode,$etrap,tempValue + . set $etrap="set $etrap="""",$ecode=""""" + . set tempcode="set tempValue="_varName + . xecute tempCode + . merge @ref=tempValue + else if varName'="" do + . new tempCode,$etrap,tempValue + . set $etrap="set $etrap="""",$ecode=""""" + . set varName=$$CREF^TMGIDE(varName) ;" convert open to closed format + . merge ^TMG("TMGIDE","CONTROLLER","MSG-IN","VAR")=@varName + set result=ref + + quit result + +HndlTable(Msg) + ;"Purpose: to copy symbol table to a global, so controller can display. + new ref set ref=$name(^TMG("TMGIDE","CONTROLLER","MSG-IN","VAR")) + kill @ref + zshow "*":@ref + quit ref + + +HndlBkPos(Msg) + ;"Purpose: To set a breakpoint in running code, as specified by remote controller. + ;"Input Msg: Format: ' ' (Condition is optional) + ; + ;"write "Here in HndlBkPos^TMGIDE4. Msg=",Msg,! + new result set result=0 + new pos set pos=$piece(Msg," ",1) + if pos="" goto HBPD + new condition set condition=$piece(Msg," ",2) + new brkLine set brkLine=pos_":""n tmg set tmg=$$STEPTRAP^TMGIDE4($ZPOS,1)""" + ;"write "About to set ZBREAK code: [",brkLine,"]",! + do + . new $etrap set $etrap="SET $ETRAP="""",$ECODE=""""" + . ZBREAK @brkLine + . set result=1 +HBPD quit result + +HndlRelBkPos(msg) ; + ;"Purpose: release a breakpoint. + ;"Input Msg: Format: '' + new result set result=0 + new pos set pos=$piece(Msg," ",1) + if pos'="" do + . new brkLine set brkLine=pos_":""zcontinue""" + . ZBREAK @brkLine + . set result=1 + quit result + +HndlXCod(MCode) + ;"Purpose: To excute code in this proccess, based on request from controlling process + ;"Result: 1 if error, 0 if OK + new result set result=1 ;"default to error + do + . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" + . xecute MCode + . set result=0 + quit result + + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ +STEPTRAP(idePos,TMGMsg) + ;"Purpose: This is the line that is called by GT.M for each zstep event. + ;" It will be used to display the current code execution point, and + ;" query user as to plans for future execution: run/step/ etc. + ;"Input: idePos -- a text line containing position, as returned bye $ZPOS + ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info. + ;" If TMGMsg=1, then this function was called without the + ;" $ZSTEP value set, so this function should set it. + ;"Result: 1=further execution should be via ZSTEP INTO + ;" 2=further execution should be via ZSTEP OVER + ;" (Anything else) -->further execution should be via ZCONTINUE + + new TMGdbgResult,TMGdbgMsg + set TMGMsg="DO TRAP "_idePos_" "_$get(TMGMsg) +STP2 set TMGdbgResult=$$MessageOut(TMGMsg,9999,0) + + ;"Check if message reply which is actually a request for more info + if $piece(TMGdbgResult," ",1)="[CMD]" do goto STP2 + . new temp set temp=$$HndlCmd(TMGdbgResult) + . set TMGMsg=temp + + quit TMGdbgResult + + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + +MessageOut(Msg,timeOutTime,ignoreReply) + ;"Purpose: to send message to Controller, and return the reply, or time out + ;"Input: Msg -- the message to send + ;" timeOutTime -- OPTIONAL, default is 2 seconds + ;" ignoreReply -- OPTIONAL, default is 0 + ;"Output: the returned message, or "" if timed out or no reply, or ignoreReply=1 + + set timeOutTime=$get(timeOutTime,2) + set ignoreReply=$get(ignoreReply,0) + new result set result="" + set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")="" ;"clear any old message + set ^TMG("TMGIDE","CONTROLLER","MSG-IN")=Msg ;"DON'T DELETE THIS LINE + if (ignoreReply=0) for do quit:(result'="")!(timeOutTime<0) + . set result=$get(^TMG("TMGIDE","CONTROLLER","MSG-OUT")) + . if (result'="") quit + . set timeOutTime=timeOutTime-0.1 + . set ^TMG("TMGIDE","CONTROLLER","MSG-IN")=Msg + . hang 0.1 + . if $$UserAborted^TMGUSRIF("from MessageOut^TMGIDE4") set timeOutTime=-1,result="^" + + if timeOutTime<0 do + . new tempResult set tempResult=$$KeyPressed^TMGUSRIF(1,1) + . if tempResult="^" set result="^" + + quit result + Index: cprs/branches/tmg-cprs/m_files/TMGIDE5.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE5.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE5.m (revision 896) @@ -0,0 +1,84 @@ +TMGIDE5 ;TMG/kst/GT/M debugger Interrupt handler code ;03/18/09 + ;;1.0;TMG-LIB;**1**;03/23/09 + ; + ;" TMG IDE Debugger Interrupt handler code + ;" + ;" K. Toppenberg + ;" 3/18/09 + ;" License: GPL Applies + ;" + ;"------------------------------------------------------------ + ;"PUBLIC API + ;"------------------------------------------------------------ + ;"PICKINTR -- show currently running jobs, and allow user to start debugging them + ;"INTERUPT -- respond to mupip intrpt, assigning control to a remote process + + ;"------------------------------------------------------------ + ;"PRIVATE API + ;"------------------------------------------------------------ + ;"LaunchIntr(JobNum) -- create interrupt message to job, then start listening + ;" for requests for control from interrupted process + ;"------------------------------------------------------------ + ;"Dependencies + ;" TMGIDE4 + ;" TMGKERNL + ;" %ZISUTL + ;" TMGUSRIF + +PICKINTR + ;"Purpose: To show currently running jobs, and allow user to start + ;" debugging them (tapping into process currently running) + ;"Called from TMGIDE + ; + new array + do MJOBS^TMGKERNL(.array) + kill array($J) ;"don't show this process + new Menu,UsrSlct + new i,j set i="",j=1 + for set i=$order(array(i)) quit:(i="") do + . set Menu(j)="Job "_$get(array(i))_$char(9)_i + . set j=j+1 + if $data(Menu)=0 do goto PIDone + set Menu(0)="Pick Job to Debug" + ; +M1 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") + ; + if UsrSlct="^" goto PIDone + if UsrSlct=0 set UsrSlct="" goto M1 + if UsrSlct=+UsrSlct do LaunchIntr(UsrSlct) + goto M1 + ; +PIDone quit + ; +LaunchIntr(JobNum) + ;"Purpose: To create interrupt message to job, then start listening + ;" for requests for control from interrupted process + if +$get(JobNum)'>0 quit + set tmgDbgRemoteJob=JobNum + set ^XUTL("XUSYS","TMG COMMAND")="INTRPT" + zsystem "mupip intrpt "_JobNum + do Controller^TMGIDE3 ;"launch the controller + set ^XUTL("XUSYS","TMG COMMAND")="" + quit + ; +INTERUPT + ;"Purpose: To respond to mupip interrupt for a process, turning control + ;" over to a remote control process + ;"NOTE: This will be called by a modified version of JOBEXAM^ZU + if $get(TMGDEBUG) write !,"Sending INQ to connect to remote controller..." + new TMGR set TMGR=$$MessageOut^TMGIDE4("INQ "_$J,30) + if TMGR="" goto Int2 + if $get(TMGDEBUG) do + . write ! + . write "*****************************************************",! + . write "* INTERRUPT RECEIVED. Transferring control to *",! + . write "* a remote controller. That is process ",$$LJ^XLFSTR($piece(TMGR," ",2),5),?52,"*",! + . write "* *",! + . write "* Please switch to that process window for control. *",! + . write "*****************************************************",! + set TMGR=$$MessageOut^TMGIDE4("WRITE Notice: Controlling interrupted job #"_$J,,0) + set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE4($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" + set TMGStepMode="into" + zstep into quit +Int2 quit + ; Index: cprs/branches/tmg-cprs/m_files/TMGIDE6.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGIDE6.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGIDE6.m (revision 896) @@ -0,0 +1,655 @@ +TMGIDE6 ;TMG/kst/GT/M debugger Code Coloration ;4/4/09, 5/27/10 + ;;1.0;TMG-LIB;**1**;4/4/09 + ; + ;" TMG IDE Code Coloration + ;" + ;" K. Toppenberg + ;" 4/4/09 + ;" License: GPL Applies + ;" + ;"------------------------------------------------------------ + ;"PUBLIC API + ;"------------------------------------------------------------ + ;"ShowLine(line,Options,BkColor) -- Encode and write out a line of code with colors + ;"WriteMLine(line,BkColor) -- write out markup line, converting tags into colors + ;"MarkupLine(line,Options) -- add markup tags that will allow coloration. + + ;"------------------------------------------------------------ + ;"PRIVATE API + ;"------------------------------------------------------------ + + ;"------------------------------------------------------------ + ;"------------------------------------------------------------ + +temp + new tempPos,pos,offset + set pos="^PSOORFIN" + new Options + set Options("XCMD")=1 + set Options("LCASE")=1 + for offset=50:1:58 do + . set tempPos="+"_offset_pos + . new line set line=$text(@tempPos) + . write offset,": " if $$ShowLine(line,.Options,40) write ! + do VTATRIB^TMGTERM(0) ;"Reset colors + quit + + +ShowPos(Pos) + ;"A temp function to show out code at a given position. + new line set line=$text(@Pos) + write Pos,": " if $$ShowLine(line) write ! + quit + + +ShowLine(line,Options,MaxChar) + ;"Purpose: to encode and write out a line of code with colors + ;"Input: line -- the code line to show + ;" Options -- See MarkupLine for format + ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written. + ;"Results: returns the actual number of chars written to screen. + new temp set temp=$$MarkupLine(line,.Options) + ;"write "{",$get(MaxChar),"}" + new result set result=$$WriteMLine(temp,.MaxChar) + quit result + +WriteMLine(line,MaxChar) + ;"Purpose: to write out markup line, converting tags into colors) + ;"Input: line -- the text to show, created by MarkupLine. DON'T pass by reference + ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written. + ;"result: number of actual characters written to screen (removing tags) + new result set result=0 + set MaxChar=$get(MaxChar,9999) + for quit:($length(line)'>0)!(result>MaxChar) do + . new p set p=$find(line,"{C") + . if p>0 do ;"start color found + . . new partS set partS=$extract(line,1,p-3) + . . do SetColors^TMGIDE2("NORM") + . . do DoWrite(partS,.result,MaxChar) + . . ;"write partS set result=result+$length(partS) + . . set line=$extract(line,p-2,999) + . . new code set code=$$GetWord^TMGSTUTL(line,1,"{","}") + . . set line=$extract(line,$length(code)+3,999) ;"shorten to after color tag onward + . . new mode set mode=$piece(code,":",2) + . . do SetColors^TMGIDE2(mode) + . . set p=$find(line,"{C/}") ;"look for close color directive + . . if p>0 do + . . . set partS=$extract(line,1,p-5) ;"get text up to closing color + . . . do DoWrite(partS,.result,MaxChar) + . . . ;"write partS set result=result+$length(partS) + . . . do SetColors^TMGIDE2("NORM") + . . . set line=$extract(line,p,999) ;"shorten to next segment after closing color onward + . . else do + . . . do DoWrite(line,.result,MaxChar) + . . . ;"write line set result=result+$length(line) + . . . set line="" + . else do + . . do DoWrite(line,.result,MaxChar) + . . ;"write line set result=result+$length(line) + . . set line="" + quit result + +DoWrite(s,CurLen,MaxLen) + ;"Purpose: To do a controlled write to the screen. + ;"Input: s -- the text to write + ;" CurLen -- PASS BY REFERENCE. Current Num chars that have been written + ;" MaxLen -- the limit to chars that can be written to screen. + new len set len=$length(s) + if CurLen+len>MaxLen do + . set s=$extract(s,1,(MaxLen-CurLen)) + . set len=$length(s) + write s + set CurLen=CurLen+len + quit + +MarkupLine(line,Options) + ;"Purpose: To take an arbitrary line of code and add markup tags + ;" that will allow coloration. + ;"Input : line -- the line of code to consider. DON'T pass by reference. + ;" Options -- PASS BY REFERENCE. OPTIONAL. Format + ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands) + ;" Options('UCASE')=1 --> turn commands into UPPER CASE + ;" Options('LCASE')=1 --> turn commands into LOWER CASE + ;" Options('Tab')=8 --> e.g. turn $char(9) into 8 spaces (Default is 5) + ;"Results : returns line with markup added. Format: + ;" {C:Name}...{C/}aaaa bbb ccc{C:Name2}ddddd{C/} + ;" 'Name' will be one of the following: + ;" LABEL -- for a code label + ;" CMD -- for a command, e.g. IF F GOTO ELSE etc. + ;" FN -- anything starting with $$ + ;" MOD -- e.g. ^MYMODULE + ;" IFN -- intrinsic function, i.e. starting with $ + ;" STR -- a string + ;" PC -- a post-conditional + ;" # -- a comment + new result set result="" + new token,cmd,arg,tabStr,p,ch + new tabLen set tabLen=$get(Options("Tab"),5) + set $piece(tabStr," ",tabLen)="" + set line=$get(line) + set line=$translate(line,$char(9),tabStr) ;"turn tabs into spaces + if $extract(line,1)'=" " do + . set token=$piece(line," ",1) + . set line=$piece(line," ",2,999) + . set result="{C:LABEL}"_token_"{C/} " + for p=1:1 quit:(p>$length(line))!($extract(line,p)'=" ") + set result=result_$extract(line,1,p-1) ;"get leading space + set line=$extract(line,p,999) + new comment set comment="" + ;"Extract comments first... + set p=1 for set p=$find(line,";",p) quit:(p'>0) do + . if $$InQt^TMGSTUTL(line,p-1) quit + . set comment=$extract(line,p-1,999) + . set comment="{C:#}"_comment_"{C/}" + . set line=$extract(line,1,p-2) + ;"====== Loop to get COMMAND ARG pairs ====" + for quit:($length(line)'>0) do + . for set ch=$extract(line,1) quit:(" ."'[ch)!(ch="") do + . . set result=result_ch,line=$extract(line,2,999) + . quit:(line="") + . set token=$$NextBlock(.line) + . if token[":" do + . . set cmd=$$NextBlock(.token,":") + . . set result=result_$$HndlCmd(cmd,.Options)_"{C:PC}:{C/}" + . . set result=result_$$HndlArgs(token)_" " + . else do + . . set result=result_$$HndlCmd(token,.Options)_" " + . set arg=$$NextBlock(.line) + . set arg=$$HndlArgs(arg) + . set result=result_arg_" " + ; + set result=result_comment ;"add back comment (if any) + quit result + ; +HndlArgs(Args) + ;"Purpose: to return a formatted arguments text + ;"Input: Args -- the text that supplies arguments to a command, OR + ;" the text that is post-conditional code + ;"results: returns the Args with markup code. + new p set p=1 + for set p=$find(Args,"$$",p) quit:(p'>0) do quit:(p'>0) ;"Handle functions + . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit + . new fnName set fnName="$$"_$$GetWord^TMGSTUTL(Args,p,"$","():^= _") + . new partA,partB + . set partA=$extract(Args,1,p-3) + . set partB=$extract(Args,p-2+$length(fnName),999) + . set Args=partA_"{C:FN}"_fnName_"{C/}"_partB + . set p=p+6+$length(fnName) ;"6=length of {C:FN} + set p=1 + for set p=$find(Args,"$",p) quit:(p'>0) do quit:(p'>0) ;"Handle intrinsic functions + . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit + . if $extract(Args,p)="$" set p=p+1 quit ;"avoid $$ matches + . new fnName set fnName="$"_$$GetWord^TMGSTUTL(Args,p,"$","():,= _") + . new partA,partB + . set partA=$extract(Args,1,p-2) + . set partB=$extract(Args,p-1+$length(fnName),999) + . set Args=partA_"{C:IFN}"_fnName_"{C/}"_partB + . set p=p+7+$length(fnName) ;"7=length of {C:IFN} + set p=1 + for set p=$find(Args,"^",p) quit:(p'>0) do quit:(p'>0);"Handle Modules + . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit + . new modName set modName="^"_$$GetWord^TMGSTUTL(Args,p,"^","():,= _") + . new partA,partB + . set partA=$extract(Args,1,p-2) + . set partB=$extract(Args,p-1+$length(modName),999) + . set Args=partA_"{C:MOD}"_modName_"{C/}"_partB + . set p=p+7+$length(modName) ;"7=length of {C:MOD} + set p=1 + for set p=$find(Args,"""",p) quit:(p'>0) do ;"Handle Strings + . new p2 + . if $extract(Args,p)="""" set p2=p + . else set p2=$$StrBounds^TMGSTUTL(Args,p) + . if p2=0 set p=999 quit + . new partA,partB,partC + . set partA=$extract(Args,1,p-2) + . set partB=$extract(Args,p-1,p2) + . set partC=$extract(Args,p2+1,999) + . set Args=partA_"{C:STR}"_partB_"{C/}"_partC + . set p=p+7+$length(partB) ;"7=length of {C:STR} + quit Args + + +HndlCmd(Cmd,Options) + ;"Purpose: Return formatted command + ;"Input: Cmd -- the mumps command + ;" Options -- OPTIONAL. Format: + ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands) + ;" Options('SCMD')=1 --> turn IF --> I etc. (shrink commands) + ;" Options('UCASE')=1 --> turn commands into UPPER CASE + ;" Options('LCASE')=1 --> turn commands into LOWER CASE + ;"Results: returns the command with markup code + new result set result="" + set Cmd=$get(Cmd) + new tempCmd set tempCmd=$$UP^XLFSTR(Cmd) + if $get(Options("XCMD")) do + . if tempCmd="AB" set Cmd="ABLOCK" quit + . if tempCmd="A" set Cmd="ASSIGN" quit + . if tempCmd="ASTA" set Cmd="ASTART" quit + . if tempCmd="ASTO" set Cmd="ASTOP" quit + . if tempCmd="AUNB" set Cmd="AUNBLOCK" quit + . if tempCmd="B" set Cmd="BREAK" quit + . if tempCmd="C" set Cmd="CLOSE" quit + . if tempCmd="D" set Cmd="DO" quit + . if tempCmd="E" set Cmd="ELSE" quit + . if tempCmd="ESTA" set Cmd="ESTART" quit + . if tempCmd="ESTO" set Cmd="ESTOP" quit + . if tempCmd="ETR" set Cmd="ETRIGGER" quit + . if tempCmd="F" set Cmd="FOR" quit + . if tempCmd="G" set Cmd="GOTO" quit + . ;"if tempCmd="H" set Cmd="HALT" quit + . ;"if tempCmd="H" set Cmd="HANG" quit + . if tempCmd="I" set Cmd="IF" quit + . if tempCmd="J" set Cmd="JOB" quit + . if tempCmd="K" set Cmd="KILL" quit + . if tempCmd="KS" set Cmd="KSUBSCRIPTS" quit + . if tempCmd="KV" set Cmd="KVALUE" quit + . if tempCmd="L" set Cmd="LOCK" quit + . if tempCmd="M" set Cmd="MERGE" quit + . if tempCmd="N" set Cmd="NEW" quit + . if tempCmd="O" set Cmd="OPEN" quit + . if tempCmd="Q" set Cmd="QUIT" quit + . if tempCmd="R" set Cmd="READ" quit + . if tempCmd="RL" set Cmd="RLOAD" quit + . if tempCmd="RS" set Cmd="RSAVE" quit + . if tempCmd="S" set Cmd="SET" quit + . if tempCmd="TC" set Cmd="TCOMMIT" quit + . if tempCmd="TH" set Cmd="THEN" quit + . if tempCmd="TRE" set Cmd="TRESTART" quit + . if tempCmd="TRO" set Cmd="TROLLBACK" quit + . if tempCmd="TS" set Cmd="TSTART" quit + . if tempCmd="U" set Cmd="USE" quit + . if tempCmd="V" set Cmd="VIEW" quit + . if tempCmd="W" set Cmd="WRITE" quit + . if tempCmd="X" set Cmd="XECUTE" quit + . if tempCmd="ZWR" set Cmd="ZWRITE" quit + if $get(Options("SCMD")) do + . if tempCmd="ABLOCK" set Cmd="AB" quit + . if tempCmd="ASSIGN" set Cmd="A" quit + . if tempCmd="ASTART" set Cmd="ASTA" quit + . if tempCmd="ASTOP" set Cmd="ASTO" quit + . if tempCmd="AUNBLOCK" set Cmd="AUNB" quit + . if tempCmd="BREAK" set Cmd="B" quit + . if tempCmd="CLOSE" set Cmd="C" quit + . if tempCmd="DO" set Cmd="D" quit + . if tempCmd="ELSE" set Cmd="E" quit + . if tempCmd="ESTART" set Cmd="ESTA" quit + . if tempCmd="ESTOP" set Cmd="ESTO" quit + . if tempCmd="ETRIGGER" set Cmd="ETR" quit + . if tempCmd="FOR" set Cmd="F" quit + . if tempCmd="GOTO" set Cmd="G" quit + . if tempCmd="HALT" set Cmd="H" quit + . if tempCmd="HANG" set Cmd="H" quit + . if tempCmd="IF" set Cmd="I" quit + . if tempCmd="JOB" set Cmd="J" quit + . if tempCmd="KILL" set Cmd="K" quit + . if tempCmd="KSUBSCRIPTS" set Cmd="KS" quit + . if tempCmd="KVALUE" set Cmd="KV" quit + . if tempCmd="LOCK" set Cmd="L" quit + . if tempCmd="MERGE" set Cmd="M" quit + . if tempCmd="NEW" set Cmd="N" quit + . if tempCmd="OPEN" set Cmd="O" quit + . if tempCmd="QUIT" set Cmd="Q" quit + . if tempCmd="READ" set Cmd="R" quit + . if tempCmd="RLOAD" set Cmd="RL" quit + . if tempCmd="RSAVE" set Cmd="RS" quit + . if tempCmd="SET" set Cmd="S" quit + . if tempCmd="TCOMMIT" set Cmd="TC" quit + . if tempCmd="THEN" set Cmd="TH" quit + . if tempCmd="TRESTART" set Cmd="TRE" quit + . if tempCmd="TROLLBACK" set Cmd="TRO" quit + . if tempCmd="TSTART" set Cmd="TS" quit + . if tempCmd="USE" set Cmd="U" quit + . if tempCmd="VIEW" set Cmd="V" quit + . if tempCmd="WRITE" set Cmd="W" quit + . if tempCmd="XECUTE" set Cmd="X" quit + . if tempCmd="ZWRITE" set Cmd="ZWR" quit + if $get(Options("UCASE")) set Cmd=$$UP^XLFSTR(Cmd) + if $get(Options("LCASE")) set Cmd=$$LOW^XLFSTR(Cmd) + set result="{C:CMD}"_Cmd_"{C/}" + quit result + +NextBlock(line,Div) + ;"Purpose: to return from the begining to the next space. Space is + ;" discarded. + ;" e.g. line='This is a test', then function will return 'This' + ;" and line will be changed to be 'is a test' + ;" e.g. line='quit:(test) do' will return 'quit:(test)' + ;" and line will be changed to ' do' (with 1 space) + ;" e.g. line=' do' will return '' + ;" and line will be changed to 'do' + ;" e.g. line='test' will return 'test' + ;" and line will be changed to '' + ;" NO e.g. line='..test' will return '...' + ;" NO and line will be changed to 'test' + ;"Input: line -- PASS BY REFERENCE + ;" Div -- the divider of blocks. OPTIONAL. Default=" " + ;"Result: the first block, see above. + new result set result="" + set Div=$get(Div," ") + new done set done=0 + new p set p=1 + for do quit:(done) + . set p=$find(line,Div,p) + . if p'>0 set result=line,line="",done=1 quit + . if $$InQt^TMGSTUTL(line,p-1) quit + . set result=$extract(line,1,p-2) + . set line=$extract(line,p,999) + . set done=1 + quit result + ; +InitColors + ;"Purpose: to establish tmgDbgOptions globally-scoped var for colors, + new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) + ;"write "$DATA(@ref)=",$DATA(@ref),! + new refMaster set refMaster=$name(^TMG("TMGIDE","COLORS")) + ;"write "refMaster=",refMaster,! + ;"write "$DATA(@refMaster)=",$DATA(@refMaster),! + ;"write "here is dump...",! + ;"zwr ^TMG("TMGIDE","COLORS",*) + ;"do PressToCont^TMGUSRIF + if ($data(@ref)=0) do + . if ($data(@refMaster)'=0) do + . . merge @ref=^TMG("TMGIDE","COLORS") ;"copy master into job's + . else do + . . if $data(TMGcBlack)=0 do SetGlobals^TMGTERM + . . set @ref@("BACKGROUND")=TMGcBlue + . . set @ref@("HighExecPos")=TMGcGrey + . . set @ref@("HighBkPos")=TMGcBRed + . . set @ref@("BkPos")=TMGcRed + . . set @ref@("Highlight")=TMGcFGBWhite + . . ;"----------------------------------- + . . set @ref@("LABEL","fg")=TMGcBYellow + . . set @ref@("LABEL","bg")=TMGcRed + . . set @ref@("SPECIAL","fg")=TMGcBYellow + . . set @ref@("SPECIAL","bg")=TMGcRed + . . ;"----------------------------------- + . . set @ref@("NORM","fg")=TMGcFGBWhite + . . set @ref@("NORM","bg")="@" ;"signal to use current background color + . . set @ref@("CMD","fg")=TMGcBRed + . . set @ref@("CMD","bg")="@" + . . set @ref@("FN","fg")=TMGcBCyan + . . set @ref@("FN","bg")="@" + . . set @ref@("MOD","fg")=TMGcBBlue + . . set @ref@("MOD","bg")="@" + . . set @ref@("IFN","fg")=TMGcRed + . . set @ref@("IFN","bg")="@" + . . set @ref@("STR","fg")=TMGcBMagenta + . . set @ref@("STR","bg")="@" + . . set @ref@("PC","fg")=TMGcBRed + . . set @ref@("PC","bg")="@" + . . set @ref@("#","fg")=TMGcBYellow + . . set @ref@("#","bg")="@" + . . merge @refMaster=@ref + quit + ; +EditColors + ;"Purpose: Enable Edit Colors + write # + new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) + new Menu,Menu2,UsrSlct,UsrSlct2,UsrRaw,fg,bg,ct + set ct=1 + set Menu(0)="Pick Color to Edit" + set Menu(ct)="Window Background color"_$char(9)_"BACKGROUND",ct=ct+1 + set Menu(ct)="Current Execution Position Background Color"_$char(9)_"HighExecPos",ct=ct+1 + set Menu(ct)="Highlighted Breakpoint Background Color"_$char(9)_"HighBkPos",ct=ct+1 + set Menu(ct)="Breakpoint Background Color"_$char(9)_"BkPos",ct=ct+1 + set Menu(ct)="Highlight Background Color"_$char(9)_"Highlight",ct=ct+1 + + set Menu(ct)="Label Foreground & Background Color"_$char(9)_"LABEL",ct=ct+1 + set Menu(ct)="'Special' Foreground & Background Color"_$char(9)_"SPECIAL",ct=ct+1 + + set Menu(ct)="Normal Text Foreground Color"_$char(9)_"NORM",ct=ct+1 + set Menu(ct)="Command Foreground Color"_$char(9)_"CMD",ct=ct+1 + set Menu(ct)="Functions Foreground Color"_$char(9)_"FN",ct=ct+1 + set Menu(ct)="Module/Global reference Foreground Color"_$char(9)_"MOD",ct=ct+1 + set Menu(ct)="Mumps intrinsic functions Foreground Color"_$char(9)_"IFN",ct=ct+1 + set Menu(ct)="String Foreground Color"_$char(9)_"STR",ct=ct+1 + set Menu(ct)="Post-conditional Foreground Color"_$char(9)_"PC",ct=ct+1 + set Menu(ct)="Comments Foreground Color"_$char(9)_"#",ct=ct+1 + new i +M1 set i=0 + for set i=$order(Menu(i)) quit:(i="") do + . new bg,fg + . new mode set mode=$piece(Menu(i),$char(9),2) + . if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[mode do + . . set bg=$get(@ref@(mode)) + . . set fg=$select(bg=0:7,1:10) + . else do + . . set fg=$get(@ref@(mode,"fg")) + . . set bg=$get(@ref@(mode,"bg")) + . . if bg="@" set bg=$get(@ref@("BACKGROUND"),0) + . set Menu(i,"COLOR","fg")=fg + . set Menu(i,"COLOR","bg")=bg + ; + set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^",.UsrRaw) + if UsrSlct="^" goto ECDn + if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[UsrSlct do goto M1 + . set @ref@(UsrSlct)=$$PickBGColor^TMGTERM() + if UsrSlct=0 set UsrSlct="" goto M1 + if "SPECIAL,LABEL"'[UsrSlct do goto M1 + . new bg set bg=$get(@ref@("BACKGROUND"),0) + . write "Setting bg=",bg,! + . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),bg) + + new Label set Label=$get(Menu(UsrRaw)) + kill Menu2 + set Menu2(0)="For "_$piece(Label,$char(9),1)_"..." + set Menu2(1)="Edit Foreground color"_$char(9)_"fg" + set Menu2(2)="Edit Background color"_$char(9)_"bg" + set Menu2(3)="Edit BOTH colors"_$char(9)_"fg&bg" + write ! +M2 set fg=+$get(@ref@(UsrSlct,"fg"),1) + set bg=+$get(@ref@(UsrSlct,"bg"),0) + do VCOLORS^TMGTERM(fg,bg) + write "Here are the current colors..." + do VTATRIB^TMGTERM(0) ;"Reset colors + write ! + set UsrSlct2=$$Menu^TMGUSRIF(.Menu2,"^",.UsrRaw) + if UsrSlct2="^" goto M1 + +M3 if UsrSlct2="fg" do goto M2 + . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),@ref@(UsrSlct,"bg")) + if UsrSlct2="bg" do goto M2 + . set @ref@(UsrSlct,"bg")=$$PickBGColor^TMGTERM(@ref@(UsrSlct,"bg")) + if UsrSlct2="fg&bg" do goto M2 + . do PickColors^TMGTERM(.fg,.bg) + . set @ref@(UsrSlct,"fg")=fg + . set @ref@(UsrSlct,"bg")=bg + goto M2 + +ECDn + new % set %=2 + write "Set current colors as default" + do YN^DICN + if %=1 do + . kill ^TMG("TMGIDE","COLORS") + . merge ^TMG("TMGIDE","COLORS")=^TMG("TMGIDE",$J,"COLORS") + quit + ; + ; +TestColors + do InitColors + new mode + for mode="Highlight","HighExecPos","BkPos","HighBkPos","SPECIAL","NORM","LABEL","CMD","FN","MOD","IFN","STR","PC","#" do + . do SetColors^TMGIDE2(mode) + . write "Here is text for ",mode,"...." + . do SetColors^TMGIDE2("Reset") + . write ! + quit + + + ;"============== Code for TRACE functionality ================= + +ShowTrace + ;"Purpose: to show current trace record of execution. + ;"if $get(tmgDbgOptions("TRACE"))=1 quit + new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE")) + if $data(@ref) do + . write "SHOW TRACE RECORDS:",! + . new NumRecs set NumRecs=$order(@ref@(""),-1) + . write NumRecs," trace lines to display",! + . new count set count=1 + . new % set %=1 + . write "Also display code for each line" do YN^DICN write ! + . if %=-1 quit + . new showCode set showCode=(%=1) + . new Colorize set Colorize=0 + . if %=1 do quit:(%=-1) + . . set %=1 write "Colorize code" do YN^DICN write ! + . . set Colorize=(%=1) + . new %ZIS + . set %ZIS("A")="Enter Output Device: " + . set %ZIS("B")="HOME" + . do ^%ZIS ;"standard device call + . if POP do quit + . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") + . use IO + . new i set i="" + . for set i=$order(@ref@(i)) quit:(i="")!($get(TMGPTCABORT)=1) do + . . new s set s=$get(@ref@(i)) + . . write s + . . if showCode do + . . . new pos set pos=$piece(s,".",$length(s,".")) + . . . if pos="" write " ??",! quit + . . . ;"write "pos=",pos,! + . . . new code + . . . do + . . . . new $etrap set $etrap="set code=""Error -- ""_pos,$etrap="""",$ecode=""""" + . . . . set code=$text(@pos) + . . . write ?25,":" + . . . new x for x=1:1:$length(s,".")-1 write " " + . . . if Colorize do + . . . . if $$ShowLine(code,.tmgDbgOptions) + . . . . do SetColors^TMGIDE2("Reset") + . . . else write code + . . . write ! + . . else write " ",! + . . ;"set count=count+1 + . . if count>20 do + . . . do PressToCont^TMGUSRIF ;" will set TMGPTCABORT=1 if user entered ^ + . . . do CUU^TMGTERM(1) + . . . write " ",! + . . . do CUU^TMGTERM(1) + . . . set count=1 + else do + . write "(No Trace record found)",! + do ^%ZISC ;" Close the output device + do PressToCont^TMGUSRIF + quit + +RecordTrace(ExecPos) + ;"Purpose: To keep trace record of execution as program runs. + ;"Input:ExecPos -- Current execution position + new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE")) + new Stack do GetStackInfo^TMGIDE2(.Stack,ExecPos) + new str set str=$$StackStr(.Stack) + new i set i=+$get(@ref)+1 + set @ref@(i)=str + set @ref=i + quit + +StackStr(Stack) + ;"Purpose: Turn stack array into a single string + ;"Input: Stack -- PASS BY REFERENCE, Numbered array, as created by GetStackInfo^TMGIDE2 + ;"Result: returns string with latest position, with + ;" a "." leading for each level of indenction. + ;" + new result set result="" + new count set count=+$order(Stack(""),-1) + if count>0 do + . new x for x=1:1:(count-1) set result=result_"." + . new s set s=$get(Stack(count)) + . if s[" <--" set s=$piece(s," <--",1) + . if s[" " set s=$piece(s," ",2) + . set result=result_s + quit result + + ;"============== Code for VAR TRACING functionality ================= + +ShowVTrace + ;"Purpose: Output changes from last step + new tmgRefNum set tmgRefNum=+$order(^TMG("TMGIDE",$J,"VARTRACE","DELTA",""),-1) + new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum)) + new TMG set TMG(1)="ADDED^Additions",TMG(2)="KILLED^Kills",TMG(3)="CHANGED^Changes" + new i for i=1,2,3 do + . new node set node=$piece(TMG(i),"^",1) + . new title set title=$piece(TMG(i),"^",2) + . if $data(@tmgRefDelta@(node)) do + . . write title,": " + . . new varname set varname="" + . . for set varname=$order(@tmgRefDelta@(node,varname)) quit:(varname="") do + . . . write varname,"=",$get(@tmgRefDelta@(node,varname))," ; " + . . write ! + quit + + +RecordVTrace + ;"Purpose: To keep a trace of changes to the system variable table. + new tmgFullRef set tmgFullRef=$name(^TMG("TMGIDE",$J,"VARTRACE","FULL")) + new tmgRefNum set tmgRefNum=+$order(@tmgFullRef@(""),-1)+1 + if tmgRefNum'>0 goto RVTDn + new tmgRefCurF set tmgRefCurF=$name(@tmgFullRef@(tmgRefNum)) + new tmgRefPriorF set tmgRefPriorF=$name(@tmgFullRef@(tmgRefNum-1)) + new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum)) + do StoreVars(tmgRefCurF) + if $data(@tmgRefPriorF) do + . do DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta) + . kill @tmgRefPriorF +RVTDn quit + +StoreVars(tmgRef) + ;"Purpose: To copy system variable table to a storage area + ;"Input: Ref -- the NAME of the global to store table at + ;"Results: none + ;"NOTICE: all vars beginning with "tmg" are NOT shown. + new tmgArray zshow "V":tmgArray ;"copy system table to local variable + new idx set idx=0 + for set idx=$order(tmgArray("V",idx)) quit:(idx="") do + . new s set s=tmgArray("V",idx) + . new varname set varname=$piece(s,"=",1) + . quit:(varname="")!($extract(varname,1,3)="tmg") + . new value set value=$p(s,"=",2,999) + . set @tmgRef@(varname)=value ;"reformat and store in a global var + quit + +DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta) + ;"Purpose: To create a record that shows difference between tmgRefCurF and + ;" tmgRefPriorF, and stores the difference + ;"Note: Possible differences: + ;" 1. New record has a new variable, not previously in existence + ;" 2. New record has same variable, but changed value + ;" 3. New record does NOT have variable that previously existed. + ;"Input: tmgRefCurF -- reference of current full variable store + ;" tmgRefPriorF -- reference of prior full viariable store + ;" tmgRefDelta -- reference to store changes to. Output Format: + ;" @tmgRefDelta@('ADDED',varname)=value + ;" @tmgRefDelta@('KILLED',varname)="" + ;" @tmgRefDelta@('CHANGED',varname)=new value + ;"Result: None. But any prior entry in @tmgRefDelta is deleted and changed as above. + ; + kill @tmgRefDelta + new varname + ;"First look for additions and changes + set varname="" + for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do + . if $data(@tmgRefPriorF@(varname)) do quit + . . if $get(@tmgRefPriorF@(varname))'=$get(@tmgRefCurF@(varname)) do + . . . set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname)) + . set @tmgRefDelta@("ADDED",varname)=$get(@tmgRefCurF@(varname)) + ; + ;"Next, look for deletions + set varname="" + for set varname=$order(@tmgRefPriorF@(varname)) quit:(varname="") do + . if $data(@tmgRefCurF@(varname)) quit + . set @tmgRefDelta@("KILLED",varname)=$get(@tmgRefPriorF@(varname)) + ; + quit + ;";"Finally, look for changes + ;"set varname="" + ;"for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do + ;". if $data(@tmgRefPriorF@(varname))=0 quit + ;". if $get(@tmgRefPriorF@(varname))=$get(@tmgRefCurF@(varname)) quit + ;". set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname)) + ;"quit + + ;"================================================================ Index: cprs/branches/tmg-cprs/m_files/TMGKERN2.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGKERN2.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGKERN2.m (revision 896) @@ -0,0 +1,419 @@ +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 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"RUNSERVER(PORT,TMGMSGFN,TMGVERBOSE) --open up a socket that will listen to requests from a client. + ;"SEND(MSG) -- funnel all writing back to the client through this, so checksums can be calc'd + ;"ASK(MSG) -- funnel all writing to server through this function, so that checksums can calc'd + ;"DEBUGMSG(NOTE) ; + ;"RUNCLIENT(HOST,PORT) --Establish a connection with specified server. Then maintain connection, sending queries to server, and returning results. + ;"MSGCLIENT(JNUM,TMGQUERY,REPLY,ERROR,TIMEOUT) -- send messages to background client. + ;"CLEARBUF(JNUM,ERROR) -- remove all messages from message buffer. + ;"RUNMONITOR --Show DEBUG messages as they are added. + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGUSRIF + ;"======================================================================= + ; +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. + ;" NOTE: Any output that the handler function wants to go back + ;" to the client should be sent to SEND^TMGKERN2(MSG), so + ;" that error checking and self-correction can urr. + ;" 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 #DONE# to signal done. + ;" + NEW RESULT,TMGDELIM,TMGTCPDEV,TMGTIMEOUT + NEW TMGCLIENT,TMGANSWR,TMGCODE + KILL ^TMG("TMP","LOG","TCP") + ; + 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=60 + SET TMGCODE="DO "_TMGMSGFN_"(TMGCLIENT)" + SET TMGVERBOSE=+$GET(TMGVERBOSE) + ; + IF TMGVERBOSE DO + . WRITE "Starting server. Trying to connect to client..." + OPEN TMGTCPDEV:(ZLISTEN=PORT_":TCP":attach="server":DELIMITER=TMGDELIM:NOWRAP):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) + DO SEND("#HELLO#") + ; + IF TMGVERBOSE DO + . USE $P + . WRITE " Connected!",! + . WRITE "Press [ESC] multiple times to abort (and wait up to 60 sec).",! + . WRITE "Press '?' to see server output.",! + . WRITE "RUNNING SERVER..." + . USE TMGTCPDEV +L1 ;"Main Listen-Reply loop + NEW TMGCLIENT,TMGI,TMGDONE,TMGLEN + SET TMGDONE=-1,TMGI=1 + NEW TMGSHOWOUT SET TMGSHOWOUT=0 + DO DEBUGMSG("Starting main listen-reply loop") + FOR DO QUIT:(TMGDONE>0)!(TMGCLIENT="#BYE#") + . USE $P + . NEW USERKEY + . READ *USERKEY:0 + . SET TMGDONE=(USERKEY=27) + . IF TMGDONE DO QUIT + . . DO SEND("#BYE#") + . . USE TMGTCPDEV + . SET:(USERKEY=63) TMGSHOWOUT=1 ;"63='?' Turn on showing ouput on console. + . SET:(USERKEY=33) TMGSHOWOUT=0 ;"33='!' Turn off showing ouput on console. + . USE TMGTCPDEV + . READ TMGCLIENT:TMGTIMEOUT + . IF ($TEST=0)!(TMGCLIENT="") DO QUIT + . . DO DEBUGMSG("$TEST=0 or TMGCLIENT='', so quitting") + . . SET TMGDONE=TMGDONE+1 + . . DO SEND("#BYE#") + . . SET TMGCLIENT="#BYE#" + . ;"Check for valud query from client. + . SET TMGLEN=+$PIECE(TMGCLIENT,$CHAR(255),2) + . SET TMGCLIENT=$PIECE(TMGCLIENT,$CHAR(255),1) + . IF TMGLEN'=$LENGTH(TMGCLIENT) DO QUIT + . . DO DEBUGMSG("Length doesn't match checksup, so asking for resend") + . . DO SEND("#RESEND#") + . DO DEBUGMSG("TMGCLIENT="_TMGCLIENT) + . IF TMGCLIENT="#ENQ#" DO SEND("#ACK#") QUIT + . IF TMGCLIENT="#BYE#" DO SEND("#BYE#") QUIT + . ELSE DO SEND("#GOTQUERY#") + . SET TMGI=TMGI+1 + . DO + . . NEW $ETRAP + . . SET $ETRAP="W """",!,$ZSTATUS,!,""#BYE"",! set $etrap="""",$ecode=""""" + . . SET TMGMSGSUM=0 + . . ;"DO DEBUGMSG("About to execute handler code") + . . XECUTE TMGCODE + . . ;"DO DEBUGMSG("Back from handler code") + . USE TMGTCPDEV ;"Ensure handler didn't redirect $IO + . ;"Send message to indicate done sending reply (will allow multi line responses) + . ;"Also append a count of total number of characters that have been sent, for error checking. + . DO DEBUGMSG("Sending back a DONE and total for amount sent: "_TMGMSGSUM) + . DO SEND("#DONE#^"_TMGMSGSUM) + . IF (TMGDONE>0) DO DEBUGMSG("NOTE: TMGDONE is > 0") + . IF (TMGCLIENT="#BYE#") DO DEBUGMSG("NOTE: TMGCLIENT = '#BYE#'") + ; + DO DEBUGMSG("Closing socket") + CLOSE TMGTCPDEV + ; +RSVRDN USE $P + DO DEBUGMSG("Quitting RUNSERVER") + IF TMGVERBOSE DO + . WRITE "Quitting ",$SELECT((RESULT=1):"normally",1:"with errors"),! + QUIT RESULT + ; + ; +SEND(MSG) ; + ;"Purpose: To funnel all writing back to the client through this function, so that + ;" checksums can be calculated for error checking... + ;"Input: MSG -- The message to write out + ;"NOTE: Will use globally scoped variable (on server side) TMGMSGSUM + ;" It is expected that RUNSERVER will set this to 0 before passing control + ;" over to a message handler. + ; + IF 1=0 DO + . NEW NUM SET NUM=+$GET(^TMG("TMP","LOG","TCP",0)) + . SET NUM=NUM+1 + . SET ^TMG("TMP","LOG","TCP",NUM,"NB")=$H_" SENDING; "_MSG + . SET ^TMG("TMP","LOG","TCP",0)=NUM + ; + WRITE MSG,! + SET TMGMSGSUM=+$GET(TMGMSGSUM)+$LENGTH(MSG) + IF $GET(TMGSHOWOUT)=1 DO + . USE $P + . WRITE "('!' to hide) ",MSG,! + . NEW USERKEY + . READ *USERKEY:0 + . SET TMGDONE=(USERKEY=27) + . SET:(USERKEY=33) TMGSHOWOUT=0 ;"33='!' Turn off showing ouput on console. + . USE TMGTCPDEV + QUIT + ; + ; +ASK(MSG) ; + ;"Purpose: To funnel all writing to server through this function, so that + ;" checksums can be maintained for error checking... + ;"Input: MSG -- The message to write out + IF 1=0 DO + . NEW NUM SET NUM=+$GET(^TMG("TMP","LOG","TCP",0)) + . SET NUM=NUM+1 + . SET ^TMG("TMP","LOG","TCP",NUM,"ASK")=$H_"; "_MSG + . SET ^TMG("TMP","LOG","TCP",0)=NUM + ; + WRITE MSG_$CHAR(255)_$LENGTH(MSG),! + QUIT + ; + ; +DEBUGMSG(NOTE) ;f + IF 1=0 DO + . NEW NUM SET NUM=+$GET(^TMG("TMP","LOG","TCP",0)) + . SET NUM=NUM+1 + . SET ^TMG("TMP","LOG","TCP",NUM,"NB")=$H_"; "_NOTE + . SET ^TMG("TMP","LOG","TCP",0)=NUM + quit + ; + ; +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. + ;"!!NOTICE!! -- This can't be used to transfer binary files, because $char(255) is used + ;" as a signalling character for error checking. + ;" + NEW RESULT,TMGDELIM,TMGTCPDEV,TMGTIMEOUT + ;"Setup vars + SET TMGTCPDEV="client$"_$JOB + SET TMGTIMEOUT=30 + KILL ^TMG("TMP","TCP",$J,"RESULT") + KILL ^TMG("TMP","LOG","TCP") + 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 + DO DEBUGMSG("NOTE: Job number="_$JOB) + DO DEBUGMSG("Starting to open connection with server") + OPEN TMGTCPDEV:(CONNECT=HOST_":"_PORT_":TCP":ATTACH="client":DELIMITER=$CHAR(13):NOWRAP):TMGTIMEOUT:"SOCKET" + IF $TEST=0 DO GOTO RCLDN + . SET RESULT="-1^Error on OPEN of SOCKET" + DO DEBUGMSG("Open succeeded.") + USE TMGTCPDEV + ;"Make sure server is ready to send information. + NEW TMGI,SRVREPLY + DO DEBUGMSG("Starting read (up to 3 tries), waiting for #HELLO#") + 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" + DO DEBUGMSG("We got a #HELLO# alright. Great!") + 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 NTIME,STIME SET STIME=$PIECE($H,",",2) + NEW TMGQUERY SET TMGQUERY="" + NEW TMGIDLE SET TMGIDLE=0 + NEW TMGABORT SET TMGABORT=0 + DO DEBUGMSG("About to start main loop for messaging") + FOR DO QUIT:(TMGQUERY="#BYE#")!(SRVREPLY="#BYE#")!(TMGABORT=1) + . IF SRVREPLY'="#RESEND#" DO + . . SET TMGI=$ORDER(@TSREF@("")) + . . IF TMGI="" DO ;"Start idle handling + . . . SET TMGQUERY="" + . . . SET NTIME=$PIECE($H,",",2) + . . . IF (NTIME-STIME)<15 DO QUIT + . . . . IF TMGIDLE HANG 0.5 ;"This loop was taking 90+% of CPU othewise. + . . . SET TMGQUERY="#ENQ#" ;"send an ENQ every 15 seconds of idleness. + . . . SET STIME=$PIECE($H,",",2) ;"Reset idle counter + . . . SET TMGIDLE=1 ;"If idle for 15 seconds, then turn on idle mode. Will take 0.5 sec to turn off + . . ELSE DO + . . . SET TMGIDLE=0 + . . . SET TMGQUERY=$get(@TSREF@(TMGI)) ;"Get query from user + . . . KILL @TSREF@(TMGI) + . . . SET STIME=$PIECE($H,",",2) ;"Reset idle counter + . . . IF $DATA(@TSREF)'=0 DO + . . . . NEW I SET I="" + . . . . FOR SET I=$order(@TSREF@(I)) QUIT:(I="") DO + . . . . . DO DEBUGMSG("Left over messages found!: "_$get(@TSREF@(I))) + . IF TMGQUERY="" QUIT + . USE TMGTCPDEV + . DO ASK(TMGQUERY) ;"Send out query to server. + . ;"Check for acknowledgement from server of query. + . READ SRVREPLY:TMGTIMEOUT ;"read reply. + . ;"IF ($TEST=0)!(SRVREPLY="")!(SRVREPLY="#BYE#") DO QUIT + . IF ($TEST=0)!(SRVREPLY="#BYE#") DO QUIT + . . SET TMGABORT=1 + . . DO DEBUGMSG("1: Got bad or #BYE# reply, so quitting (Setting TMGABORT=1)") + . IF SRVREPLY="#ACK#" DO QUIT + . ;"Now process server reply to query. + . IF SRVREPLY="#RESEND" QUIT ;"Server replied with RESEND, so will ask query again + . IF SRVREPLY="#GOTQUERY#" FOR DO QUIT:(SRVREPLY="#BYE#")!(SRVREPLY="#DONE#")!(TMGABORT=1) + . . READ SRVREPLY:TMGTIMEOUT ;"read reply. + . . ;"IF ($TEST=0)!(SRVREPLY="")!(SRVREPLY="#BYE#") DO QUIT + . . IF ($TEST=0)!(SRVREPLY="#BYE#") DO QUIT + . . . DO DEBUGMSG("2: Got bad or #BYE# reply, so quitting (Setting TMGABORT=1)") + . . . SET TMGABORT=1 ;"Got NULL or bad or #BYE# reply, so setting quitting " + . . IF SRVREPLY="" QUIT ;"Ignore null replies (i.e. server sent a blank line) ?? good idea ?? + . . IF SRVREPLY["#DONE#" DO ;"Cut off checksum, but DO store #DONE# + . . . DO DEBUGMSG("Got an #DONE#. Later I should check on checksum") + . . . ;"Later check on checksum + . . . SET SRVREPLY="#DONE#" + . . SET TMGI=+$ORDER(@FSREF@(""),-1) + . . SET @FSREF@(TMGI+1)=SRVREPLY + DO DEBUGMSG("Done with loop, so sending #BYE#") + DO DEBUGMSG("TMGQUERY="_TMGQUERY) + DO DEBUGMSG("SRVREPLY="_SRVREPLY) + DO DEBUGMSG("TMGABORT="_TMGABORT) + DO ASK("#BYE#") ;"Done with loop and exiting, so sending #BYE#" + CLOSE TMGTCPDEV + ; +RCLDN USE $P + KILL ^TMG("TMP","TCP",$J) + HALT ;"(quit background process) + ; + ; +MSGCLIENT(JNUM,TMGQUERY,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 + ;" TMGQUERY -- 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 + ;"Will set globally-scoped variable TMGABORT=1 if timeout or other error + ; + KILL ERROR,REPLY + NEW RESULT SET RESULT="" + SET JNUM=+$GET(JNUM) + IF JNUM'>0 SET ERROR="-1^BAD JOB NUMBER" GOTO MSGDN + SET TMGQUERY=$GET(TMGQUERY) + IF TMGQUERY="" SET ERROR="-1^NO QUERY PROVIDED" GOTO MSGDN + SET TIMEOUT=+$GET(TIMEOUT,1) + NEW SHOWPROG SET SHOWPROG=0 + NEW NTIME,STIME SET STIME=$PIECE($H,",",2) + KILL ^TMG("TMP","TCP",JNUM,"FS") ;"Clear message buffer before communication + NEW TMGI SET TMGI=+$ORDER(^TMG("TMP","TCP",JNUM,"TS",""),-1) + SET ^TMG("TMP","TCP",JNUM,"TS",TMGI+1)=TMGQUERY + IF TMGQUERY="#BYE#" GOTO MSGDN + NEW LINECT SET LINECT=1 + NEW TMGCT SET TMGCT=0 + NEW REPLYI SET REPLYI=1 + NEW STIME SET STIME=$PIECE($H,",",2) + NEW USERKEY + NEW TMGSHOWOUT SET TMGSHOWOUT=0 + NEW ONELINE SET ONELINE="" + FOR DO QUIT:(ONELINE="#DONE#") + . SET TMGI=$ORDER(^TMG("TMP","TCP",JNUM,"FS","")) + . READ *USERKEY:0 + . ;"SET TMGDONE=(USERKEY=27) QUIT:TMGDONE + . SET:(USERKEY=63) TMGSHOWOUT=1 ;"63='?' Turn on showing ouput on console. + . SET:(USERKEY=33) TMGSHOWOUT=0 ;"33='!' Turn off showing ouput on console. + . IF TMGI="" DO QUIT + . . SET NTIME=$PIECE($H,",",2) + . . IF (NTIME-STIME)'15) DO ;"Turn on progress bar after 15 seconds. + . . SET SHOWPROG=1 + . IF (SHOWPROG=1),(TMGCT>1000) DO + . . DO ProgressBar^TMGUSRIF(100,"Receiving Data ('?' to monitor): "_LINECT,-1,-1,70) + . . SET TMGCT=0 +MSGDN ; + KILL ^TMG("TMP","TCP",JNUM,"FS") ;"Clear message buffer after communication + QUIT + ; + ; +CLEARBUF(JNUM,ERROR) ; + ;"Purpose: To remove all messages from message buffer. + ;"Input: JNUM -- The job number of the background client process + ;" ERROR -- PASS BY REFERENCE, AN OUT PARAMETER. Prior data killed. + ;" If error, filled with -1^Message. + ;"Result: None + ; + KILL ERROR + SET JNUM=+$GET(JNUM) + IF JNUM'>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 + ; + ; +RUNMONITOR ; + ;"Purpose: This is a debugging routine. If run in a separate process, it will + ;" show DEBUG messages as they are added. + NEW NUM,TMGDONE,MSG,MAX + SET TMGDONE=0 + FOR NUM=1:1 DO QUIT:(TMGDONE>0) + . READ *TMGDONE:0 + . SET MAX=+$GET(^TMG("TMP","LOG","TCP",0)) + . IF NUM>MAX SET NUM=MAX QUIT + . NEW NODE SET NODE=$ORDER(^TMG("TMP","LOG","TCP",NUM,"")) + . WRITE NODE,": ",$GET(^TMG("TMP","LOG","TCP",NUM,NODE)),! + QUIT + ; Index: cprs/branches/tmg-cprs/m_files/TMGKERNL.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGKERNL.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGKERNL.m (revision 896) @@ -0,0 +1,581 @@ +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) + ;"$$mkdir(Dir) -- provide a shell for the Linux command 'mkdir' + ;"$$rmdir(Dir) -- provide a shell for the Linux command 'rmdir' + ;"$$Convert^TMGKERNL(FPathName,NewType) -- convert a graphic image to new type + ;"$$XLTLANG(Phrase,langPair) -- execute a linux OS call to convert a phrase into another spoken language + ;"$$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 + ;"IOCapON -- redirect IO to a HFS file, so that it can be captured. + ;"IOCapOFF(pOutArray) -- restore IO channel to that prior IOCapON was called, and return captured output in OutArray + ;"KillPID(JobNum) -- send message to MUPIP to kill Job + ;"MJOBS(array) -- execute a linux OS call to get list of all 'mumps' jobs using: 'ps -C mumps' + ;"$$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 + + +FileSize(FullNamePath) + ;"Purpose: To return the size of the file, in bytes. + ;"Input: FullNamePath: The filename to act on. + ;"Result: -1 if error, or returns size in bytes + + new result set result=-1 + new p set p="myTerm" + open p:(COMMAND="stat --format=%s "_FullNamePath:readonly)::"pipe" + use p + new x read x + close p use $p + ;"write "reply was :",x,! + if x'["cannot stat" set result=+x + 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 '24^60' as a default 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" + ;"open p:(COMMAND="stty -a |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) + if (COLS=0)&(ROWS=0) do + . set COLS=60,ROWS=24 + quit ROWS_"^"_COLS Index: cprs/branches/tmg-cprs/m_files/TMGRPC1.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGRPC1.m (revision 896) @@ -0,0 +1,735 @@ +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) ; Depreciated MOVED to TMGRPC1C + ;"UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) ; Depreciated MOVED to TMGRPC1C + ;"DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ; Depreciated MOVED to TMGRPC1C + ;"UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ; Depreciated MOVED to TMGRPC1C + ;"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) ; Depreciated MOVED to TMGRPC1C + ;"DECODE(GRef,incSubscr,decodeFn) ; Depreciated MOVED to TMGRPC1C + ;"$$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) + GOTO DOWNLOAD+1^TMGRPC1C + ; +UPLOAD(RESULT,FPATH,FNAME,LOCIEN,ARRAY) + GOTO UPLOAD+1^TMGRPC1C + ; +DOWNDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Download drop box file + GOTO DOWNDROP+1^TMGRPC1C + ; +UPLDDROP(RESULT,FPATH,FNAME,LOCIEN) ;"i.e. Upload Dropbox File + GOTO UPLDDROP+1^TMGRPC1C + ; +ENCODE(GRef,incSubscr,encodeFn) ;"Purpose: ENCODE a BINARY GLOBAL. + GOTO ENCODE+1^TMGRPC1C + ; +DECODE(GRef,incSubscr,decodeFn) ;"Purpose: ENCODE a BINARY GLOBAL. + GOTO DECODE+1^TMGRPC1C + ; +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 + + kill ^TMG("TMP","BLANKTIU") + 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, acs 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)="MerkMedicus^http://www.merckmedicus.com/pp/us/hcp/hcp_home.jsp" + set RESULT(2)="Pathgroup^http://pathgroup.com/" + set RESULT(3)="AAFP^http://search.aafp.org/search?access=p&output=xml_no_dtd&site=a&filter=0&ie=UTF-8&oe=UTF-8&client=aafp&proxystylesheet=aafp&proxycustom=%3CADVANCED/%3E" + set RESULT(4)="EMedicine^http://emedicine.medscape.com/" + + ;"kill RESULT + ;"merge RESULT=^TMG("TMP","URLS") ;"TEMP!!! + + quit + + ; Index: cprs/branches/tmg-cprs/m_files/TMGRPC1A.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGRPC1A.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGRPC1A.m (revision 896) @@ -0,0 +1,156 @@ +TMGRPC1A ;TMG/kst-RPC Functions ;2/11/10, 6/19/10 + ;;1.0;TMG-LIB;**1**;2/11/10 + ; + ;"TMG RPC FUNCTIONS + ; + ;"Copyright Kevin Toppenberg MD + ;"Released under GNU General Public License (GPL) + ;" + ;"======================================================================= + ;" RPC -- Public Functions. + ;"======================================================================= + ;"SETINIVL(RESULT,SECTION,KEY,VALUE) ;Entry point for TMG INIFILE SET + ;"GETINIVL(RESULT,SECTION,KEY,DEFAULT) ;Entry point for TMG INIFILE GET + ; + ;"======================================================================= + ;"PRIVATE API FUNCTIONS + ;"======================================================================= + ; + ;"======================================================================= + ;"======================================================================= + ;"Dependencies: + ;" DIC, TMGDEBUG + ;"======================================================================= + ;"======================================================================= + ; +SETINIVL(RESULT,SECTION,KEY,VALUE) ; + ;"SCOPE: Public + ;"RPC that calls this: TMG INIFILE SET + ;"Purpose: To provide an entry point for a RPC call from a client. The client + ;" will use this instead of TIniFile object in Delphi. + ;" Note: Since all data are of type string in Mumps, this will work only with strings. + ;" and type casting will have to take place in client. + ;"Input: RESULT -- an OUT PARAMETER. See output below. + ;" SECTION -- String of 'Section' to store setting in (corresponds to section in TIniFile) + ;" KEY -- String of Key value. (corresponds to Ident/Key in TIniFile) + ;" VALUE -- String of Value to set + ;"Note: Because this is a shared resource, it is expected that the client will use + ;" User.Name as the Section value. + ;" Also, any prior value will be overwritten. + ;"Output: Will return RESULT="1^Success", or -1^Error Message" + SET RESULT="1^Success" + IF $GET(SECTION)="" SET RESULT="-1^No value passed for SECTION" QUIT + IF $GET(KEY)="" SET RESULT="-1^No value passed for KEY" QUIT + SET VALUE=$GET(VALUE) + NEW X,Y,DIC,IEN,IEN2 + SET DIC=22710,DIC(0)="LM" ;"Find SECTION if previously added. + SET X=SECTION + DO ^DIC SET IEN=+Y + IF IEN'>0 DO ;"For some reason LAYGO doesn't work when called by RPC + . NEW TMGFDA,TMGIEN,TMGMSG + . SET TMGFDA(22710,"+1,",.01)=SECTION + . DO UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") + . IF $DATA(TMGMSG("DIERR")) DO QUIT + . . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG) + . SET IEN=+$GET(TMGIEN(1)) + IF +RESULT=-1 GOTO SIDN + IF IEN'>0 SET RESULT="-1^Error establishing SECTION: ["_SECTION_"]" QUIT + SET DA(1)=IEN,DIC(0)="LM",DIC="^TMG(22710,"_IEN_",1," + SET X=KEY + DO ^DIC SET IEN2=+Y + IF IEN2'>0 DO ;"For some reason LAYGO sometimes doesn't work when called by RPC + . NEW TMGFDA,TMGIEN,TMGMSG + . SET TMGFDA(22710.01,"+1,"_IEN_",",.01)=KEY + . DO UPDATE^DIE("E","TMGFDA","TMGIEN","TMGMSG") + . IF $DATA(TMGMSG("DIERR")) DO QUIT + . . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG) + . SET IEN2=+$GET(TMGIEN(1)) + IF +RESULT=-1 GOTO SIDN + IF IEN2'>0 SET RESULT="-1^Error establishing KEY: ["_KEY_"]" QUIT + NEW TMGFDA,TMGMSG + IF VALUE="" SET VALUE="@" + SET TMGFDA(22710.01,IEN2_","_IEN_",",1)=VALUE + DO FILE^DIE("E","TMGFDA","TMGMSG") + IF $DATA(TMGMSG("DIERR")) DO GOTO SIDN + . SET RESULT="-1^"_$$GetErrStr^TMGDEBUG(.TMGMSG) +SIDN QUIT + ; + ; +GETINIVL(RESULT,SECTION,KEY,DEFAULT) ; + ;"SCOPE: Public + ;"RPC that calls this: TMG INIFILE GET + ;"Purpose: To provide an entry point for a RPC call from a client. The client + ;" will use this instead of TIniFile object in Delphi. + ;" Note: Since all data are of type string in Mumps, this will work only with strings. + ;" and type casting will have to take place in client. + ;"Input: RESULT -- an OUT PARAMETER. See output below. + ;" SECTION -- String of 'Section' to store setting in (corresponds to section in TIniFile) + ;" KEY -- String of Key value. (corresponds to Ident/Key in TIniFile) + ;" DEFAULT -- The value to be returned, if no value found. + ;"Note: Because this is a shared resource, it is expected that the client will use + ;" User.Name as the Section value. + ;" Also, any prior value will be overwritten. + ;"Output: Will return RESULT="1^", or -1^Error Message" + IF $GET(SECTION)="" SET RESULT="-1^No value passed for SECTION" QUIT + IF $GET(KEY)="" SET RESULT="-1^No value passed for KEY" QUIT + SET DEFAULT=$GET(DEFAULT) + NEW X,Y,DIC,IEN,IEN2 + SET DIC=22710,X=SECTION + DO ^DIC SET IEN=+Y + IF IEN'>0 SET RESULT="1^"_DEFAULT QUIT + SET DA(1)=IEN,DIC="^TMG(22710,"_IEN_",1," + SET X=KEY + DO ^DIC SET IEN2=+Y + IF IEN2'>0 SET RESULT="1^"_DEFAULT QUIT + NEW VALUE SET VALUE=$GET(^TMG(22710,IEN,1,IEN2,1),DEFAULT) + IF VALUE'=DEFAULT SET VALUE=$PIECE(VALUE,"^",1) + SET RESULT="1^"_VALUE + QUIT + ; + ; +CONVERT + ;"Purpose: A temp function to convert between the old storage method and the new. + ;"Data was stored in: ^TMG("INIDATA",Section,Key,Vaue) + NEW SECTION,KEY,VALUE + SET SECTION="" + FOR SET SECTION=$ORDER(^TMG("INIDATA",SECTION)) QUIT:(SECTION="") DO + . SET KEY="" + . FOR SET KEY=$ORDER(^TMG("INIDATA",SECTION,KEY)) QUIT:(KEY="") DO + . . SET VALUE=$GET(^TMG("INIDATA",SECTION,KEY)) + . . NEW RESULT + . . DO SETINIVL(.RESULT,SECTION,KEY,VALUE) ; + . . IF +RESULT>0 KILL ^TMG("INIDATA",SECTION,KEY) QUIT + . . WRITE "Error trying to store SECTION=",SECTION,"; KEY=",KEY,"; VALUE=",VALUE,! + . . WRITE " -- ",$PIECE(RESULT,"^",2),! + QUIT +; +; +INSTALL ; + ;"Purpose: to add the RPC's 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="TMG INIFILE GET" + DO ^DIC + IF +Y'>0 DO + . WRITE "ERROR. Unable to add or find TMG INIFILE GET 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 ! + SET X="TMG INIFILE SET" + DO ^DIC + IF +Y'>0 DO + . WRITE "ERROR. Unable to add or find TMG INIFILE SET 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/TMGSIPH.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH.m (revision 896) @@ -0,0 +1,201 @@ +TMGSIPH ;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 + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"LAUNCHSERVER --Main entry point for launching server for Siphon + ;"LAUNCHCLIENT ; -- Main entry point for launching client for Siphon + + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGKERN2,TMGUSRIF + ;"======================================================================= + ; + ;"Note: The following globals are used. + ;" + ;"^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF,ENTRY)="" + ;" ; 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. + ;"^TMG("TMGSIPH","NEED RE-XREF",FILENUM)="" + ;"^TMG("TMGSIPH","RE-XREF DONE",FILENUM,IEN)="" + ;"^TMG("TMGSIPH","DOWNLOADED",FILENUM,LocalIEN)=RemoteIEN + ;"^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,ReferToNodeToBeCorrected,INFO)="" + ;" INFO=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;"^TMG("TMGSIPH","NEEDED RECORDS","PTIN",FILENUM,IEN)="" + ;"^TMG("TMGSIPH","OVERWRITTEN",REF)=@REF + ;"^TMG("TMGSIPH","PT XLAT",FILENUM,RemoteIEN)=LocalIEN + ;" ;Note: if FILENUM is subfile, DON'T store in 123.02{123 format. Just use 123.02 + ;"^TMG("TMGSIPH","ALWAYS OVERWRITE LOCAL",FILENUM)="" + ;"^TMG("TMGSIPH","RECORDS SYNC",FILENUM)=LastIEN^TotalNumIENS (header entries from server-side file) + ;"^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR)=Value (internal format) + ;" + ;"----- On server side, this array is used + ;"^TMG("PTXREF","OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)="" + ;"^TMG("PTXREF","IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)="" + ;"^TMG("PTXREF","XREFS",FILENUM,PTR,REF)=$GET(@REF) + ;"^TMG("TMGSIPH",".01 VALUE",FILENUM,IEN)=VALUE ;.01 value from record IEN (server-side IEN) + + ; +LAUNCHSERVER ; + ;"Purpose: Main entry point for launching server for Siphon + NEW RESULT + SET RESULT=$$RUNSERVER^TMGKERN2(6321,"HANDLMSG^TMGSIPH0",1) + QUIT + ; + ; +LAUNCHCLIENT ; + ;"Purpose: Main entry point for launching client for Siphon + JOB RUNCLIENT^TMGKERN2("localhost",6321) + NEW MSGJOB SET MSGJOB=$ZJOB + NEW TMGOWSAVE + WRITE "Background task to talk to server launched in job #",MSGJOB,! + NEW RESULT + NEW COUNT SET COUNT=1 +LC1 HANG 0.5 + SET RESULT=$GET(^TMG("TMP","TCP",MSGJOB,"RESULT")) + SET COUNT=COUNT+1 + IF COUNT>60 DO QUIT ;"60 * 0.5 = 30 seconds timeout + . WRITE "ERROR: Timeout waiting for client in job #",MSGJOB," to connect to server",! + IF RESULT="" GOTO LC1 + IF +RESULT'=1 GOTO LC3 + ; + WRITE " =====================================================",! + WRITE " = =",! + WRITE " = -= TMG SIPHON =- =",! + WRITE " = =",! + WRITE " = Transfer data from one VistA instance to another =",! + WRITE " = =",! + WRITE " =====================================================",!,! + WRITE "NOTE: There should be NO other VistA users on the server,",! + WRITE "as they might make unexpected and unmanagable changes to",! + WRITE "the server database, interfering with the transfer process.",!,! + NEW % SET %=2 + WRITE "Make a backup copy of local records if/when overwriting" + DO YN^DICN WRITE !,! + IF %=-1 GOTO LC3 + SET TMGOWSAVE=(%=1) ;"Used in STOREDAS^TMGSIPHU + DO MSGCLIENT^TMGKERN2(MSGJOB,"GET XREF AGE",.REPLY,.ERROR,5) + IF $DATA(ERROR) WRITE ERROR,! + NEW XRAGE SET XRAGE=+$GET(REPLY(1)) + SET %=1 + IF XRAGE>0 DO GOTO:(%=-1) LC3 + . WRITE "Transfer information was last altered on the server ",XRAGE,"+",! + . WRITE "hrs ago. This should be refereshed if there has been any",! + . WRITE "change to records on the the server database in the interrum.",! + . WRITE "Refreshing can add up-front time to the transfer, but is",! + . WRITE "important for data integrety.",!,! + . WRITE "DELETE old info now and recreate during transfers" + . NEW % SET %=1 IF XRAGE<2 SET %=2 + . DO YN^DICN WRITE ! + . IF %'=1 QUIT + . DO MSGCLIENT^TMGKERN2(MSGJOB,"WIPE PT XREF",.REPLY,.ERROR,5) + . IF $DATA(ERROR) WRITE ERROR,! + . ELSE WRITE "OK. Old transfer information deleted on server.",!,! + ; + NEW MENU,USRSLCT,TMP +LC2 KILL MENU,USRSLCT + SET MENU(0)="Pick Option for Siphoning information" + NEW IDX SET IDX=1 + SET MENU(IDX)="Transfer One (1) File (by record)"_$char(9)_"TransFilebyRecs",IDX=IDX+1 + SET MENU(IDX)="Transfer One (1) patient"_$char(9)_"TransPatient",IDX=IDX+1 + SET MENU(IDX)="Transfer One (1) record"_$char(9)_"TransRecord",IDX=IDX+1 + NEW NPTO SET NPTO=$$NUMNEEDED^TMGSIPH3(MSGJOB,"PTOUT") + NEW NPTI SET NPTI=$$NUMNEEDED^TMGSIPH3(MSGJOB,"PTIN") + IF NPTO>0 DO + . SET MENU(IDX)="Work on Unresolved Pointers OUT ("_NPTO_" pending)"_$char(9)_"ResolveNeededPointersOUT",IDX=IDX+1 + . SET MENU(IDX)="AUTO MODE. Get all Unresolved Pointers OUT ("_NPTO_" pending)"_$char(9)_"ALLResolveNeededPointersOUT",IDX=IDX+1 + IF NPTI>0 DO + . SET MENU(IDX)="Work on Unresolved Pointers IN ("_NPTI_" pending)"_$char(9)_"ResolveNeededPointersIN",IDX=IDX+1 + . SET MENU(IDX)="AUTO MODE. Get all Unresolved Pointers IN ("_NPTI_" pending)"_$char(9)_"ALLResolveNeededPointersIN",IDX=IDX+1 + IF (NPTO>0)&(NPTI>0) DO + . SET MENU(IDX)="IN & OUT AUTO MODE. Get all Unresolved Pointers IN & OUT"_$char(9)_"ALLResolveNeededPointersINOUT",IDX=IDX+1 + SET MENU(IDX)=""_$char(9)_"Utility",IDX=IDX+1 + ; + WRITE # + SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") + IF USRSLCT="^" GOTO LC3 + IF USRSLCT=0 SET USRSLCT="" + IF USRSLCT="ResolveNeededPointersOUT" SET TMP=$$HANDLNEEDED^TMGSIPH3(MSGJOB,"PTOUT",0) GOTO LC2 + IF USRSLCT="ResolveNeededPointersIN" SET TMP=$$HANDLNEEDED^TMGSIPH3(MSGJOB,"PTIN",0) GOTO LC2 + IF USRSLCT="ALLResolveNeededPointersOUT" SET TMP=$$HANDLNEEDED^TMGSIPH3(MSGJOB,"PTOUT",1) GOTO LC2 + IF USRSLCT="ALLResolveNeededPointersIN" SET TMP=$$HANDLNEEDED^TMGSIPH3(MSGJOB,"PTIN",1) GOTO LC2 + IF USRSLCT="ALLResolveNeededPointersINOUT" DO AUTONEEDED^TMGSIPH3(MSGJOB) GOTO LC2 + IF USRSLCT="TransPatient" DO TRANSPT^TMGSIPH4(MSGJOB) GOTO LC2 + IF USRSLCT="TransRecord" DO TRANSREC^TMGSIPH4(MSGJOB) GOTO LC2 + IF USRSLCT="TransFilebyRecs" DO CHKUPDTE^TMGSIPH4(MSGJOB,1) GOTO LC2 + IF USRSLCT="Utility" DO UTILITY(MSGJOB) GOTO LC2 + GOTO LC2 + ; +LC3 DO MSGCLIENT^TMGKERN2(MSGJOB,"#BYE#",.REPLY,.ERROR,5) + IF $DATA(ERROR) WRITE ERROR,! + HANG 0.5 + NEW Jobs + DO MJOBS^TMGKERNL(.Jobs) + IF $DATA(Jobs(MSGJOB)) do + . WRITE "Background client #",MSGJOB," seems hung!",! + . WRITE "Try typing [ESC] in server process. When the server quits",! + . WRITE "the background client should quit normally.",! + . DO PressToCont^TMGUSRIF + KILL ^TMG("TMP","TCP",MSGJOB) + QUIT + ; + ; +UTILITY(MSGJOB) ; + ;"Purpose: To have utility menu + ;" + NEW MENU,USRSLCT +U2 KILL MENU,USRSLCT + SET MENU(0)="Pick UTILITY Option for Siphoning information" + NEW IDX SET IDX=1 + SET MENU(IDX)="Work with data dictionaries"_$char(9)_"DataDict",IDX=IDX+1 + SET MENU(IDX)="Query server global reference entries"_$char(9)_"QueryServer",IDX=IDX+1 + SET MENU(IDX)="Transfer server global reference entry"_$char(9)_"TransGlobal",IDX=IDX+1 + SET MENU(IDX)="Re-Index files transferred"_$char(9)_"RE-XREF",IDX=IDX+1 + SET MENU(IDX)="AUTO check for NEW records in set server files"_$char(9)_"AutoCheckForNewRecords",IDX=IDX+1 + SET MENU(IDX)="Check for NEW records in server file"_$char(9)_"CheckForNewRecords",IDX=IDX+1 + SET MENU(IDX)="Check for pointers IN to downloaded records"_$char(9)_"CheckForPointersIN",IDX=IDX+1 + NEW NPTO SET NPTO=$$NUMNEEDED^TMGSIPH3(MSGJOB,"PTOUT") + NEW NPTI SET NPTI=$$NUMNEEDED^TMGSIPH3(MSGJOB,"PTIN") + IF NPTO>0 DO + . SET MENU(IDX)="EXAMINE Unresolved Pointers OUT ("_NPTO_" pending)"_$char(9)_"ExaminePointersOUT",IDX=IDX+1 + . SET MENU(IDX)="PREVIEW Unresolved Pointers OUT ("_NPTO_" pending)"_$char(9)_"PreviewPointersOUT",IDX=IDX+1 + . SET MENU(IDX)="UN-NEED Unresolved Pointers OUT ("_NPTO_" pending)"_$char(9)_"UnneedPointersOUT",IDX=IDX+1 + . SET MENU(IDX)="MAP Unresolved Pointers OUT ("_NPTO_" pending) to LOCAL records"_$char(9)_"MapPointersOUTtoLocal",IDX=IDX+1 + SET MENU(IDX)="Show Information nodes"_$char(9)_"ShowInfoNodes",IDX=IDX+1 + SET MENU(IDX)="Show Local Data Dictionary Browser"_$char(9)_"VPE-DD",IDX=IDX+1 + SET MENU(IDX)="Delete a record that has been downloaded"_$char(9)_"DeleteADownloadedRec",IDX=IDX+1 + ;"SET MENU(IDX)="do FIX"_$char(9)_"FIX",IDX=IDX+1 + SET MENU(IDX)="Transfer Entire File (BLOCK COPY)/ Auto-resume Transfer"_$char(9)_"TransferFile",IDX=IDX+1 + ; + WRITE # + SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") + IF USRSLCT="^" GOTO U3 + IF USRSLCT=0 SET USRSLCT="" + IF USRSLCT="DataDict" DO COMPALLD^TMGSIPH1(MSGJOB) GOTO U2 + IF USRSLCT="QueryServer" DO QRYSERVER^TMGSIPH3(MSGJOB) GOTO U2 + IF USRSLCT="TransGlobal" DO TRANSREF^TMGSIPH3(MSGJOB) GOTO U2 + IF USRSLCT="ExaminePointersOUT" DO EXAMNEED^TMGSIPH5(MSGJOB,"PTOUT") GOTO U2 + IF USRSLCT="MapPointersOUTtoLocal" DO MAP2LOCAL^TMGSIPH3(MSGJOB) GOTO U2 + IF USRSLCT="UnneedPointersOUT" DO KILLNEED^TMGSIPH5(MSGJOB,"PTOUT") GOTO U2 + IF USRSLCT="PreviewPointersOUT" DO PREVIEW^TMGSIPH5(MSGJOB,"PTOUT") GOTO U2 + IF USRSLCT="ShowInfoNodes" DO BROWSENODES^TMGMISC($NAME(^TMG("TMGSIPH"))) GOTO U2 + IF USRSLCT="VPE-DD" DO ^%ZVEMD GOTO U2 + IF USRSLCT="CheckForNewRecords" DO CHKUPDTE^TMGSIPH4(MSGJOB) GOTO U2 + IF USRSLCT="AutoCheckForNewRecords" DO CHKSPUPD^TMGSIPH4(MSGJOB) GOTO U2 + IF USRSLCT="CheckForPointersIN" DO CHKPTIN^TMGSIPH5(MSGJOB) GOTO U2 + IF USRSLCT="RE-XREF" DO XRFILES^TMGSIPH6 GOTO U2 + IF USRSLCT="DeleteADownloadedRec" DO DELREC^TMGSIPH5 GOTO U2 + ;"IF USRSLCT="FIX" DO FIXSUBFILES^TMGFIX(MSGJOB) GOTO U2 + IF USRSLCT="TransferFile" DO TRANSFILE^TMGSIPH3(MSGJOB) GOTO LC2 + + ; +U3 QUIT + ; Index: cprs/branches/tmg-cprs/m_files/TMGSIPH0.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH0.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH0.m (revision 896) @@ -0,0 +1,355 @@ +TMGSIPH0 ;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 + ;"----===== SERVER-SIDE CODE ====------ + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"HANDLMSG(MESSAGE) -- A message handler for communication between VistA instances. + ; + ;"======================================================================= + ;" API -- Private Functions. + ;"======================================================================= + ;"HANDLGET(REF) --A handler for GET command between VistA instances. Get a ^global node + ;"HANDLGDD(FILENUM) -- Return Data Dictionary information about specified file. + ;"GETSUBDD(SUBFILENUM) -- Return DD information about subfiles (and sub-subfiles) + ;"HANDLORD(REF) --A handler for ORDREF command between VistA instances. Will get ^Global node that is $ORDER'd after REF + ;"HANDLNRS(FILENUM) -- Return the highest record number in given file. + ;"HANDGRXR(PARAMS) -- Return one record, and associated cross-reference entries + ;"SENDFLDS(FILENUM,IEN) -- send any .01 fields VALUES of any pointers OUT + ;"HANDLDIC(PARAMS) -- Do a ^DIC lookup in file for value. + ;" + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"DILF, XLFSTR, TMGSIPHU, TMGKERN2, TMGFMUT2 + ;"======================================================================= + ; + ;"============================================================= + ;" Below will be core of server-side request handler. + ;"============================================================= +HANDLMSG(MESSAGE) ; + ;"Purpose: A message handler for communication between VistA instances. + ;"Input MESSAGE -- This is the message send from the client, who will be asking for + ;" information and records etc from this instance. + ;" Format: 'Command|parameters' + ;" ----------------------- + ;" GET|REF -- Get a ^global node + ;" GET DD|FILENUM -- return Data Dictionary information about specified file. + ;" ORDREF|REF -- Get ^Global node that is $ORDER'd after REF + ;" NUMRECS|FILENUM -- Return the highest record number in given file + ;" PT XREF|FILENUM -- Prepair PT XREF for all records pointing INTO specified file. + ;" WIPE PT XREF| -- Delete the last run of PT XREF, so it can be refreshened. + ;" PREP XREFS|FILENUM^[1] -- Make a xref of cross-references (a backward xref) + ;" GET REF & FILE XREF|REF^FILENUM^IENS -- Return one reference, and associated FILENUM cross-reference entries + ;" GET RECORD & XREF|FILENUM^IEN -- Return one record, and associated cross-reference entries + ;" GET PTRS IN|FILENUM^IEN -- Get a listing of all pointers INTO requested record + ;" DO DIC|FILENUM^VALUE -- Do a ^DIC lookup in file for value. + ;" GET XREF AGE -- Get age of server-side PT xrefs etc, in HOURS + ;" GET .01 FLD|FILENUM^IEN -- Return INTERNAL format of .01 field. Doesn't support subfiles. + ;" DUMP REC|FILENUM^IENS^SHOWEMPTY -- Display dump of server record. + ;" GET IEN LIST|FILENUM -- Get a listing of all records (IEN's) in specified file. + ;" GET IEN HDR|FILENUM -- Get Last IEN,HighestIEN from file header. + ;" ----------------------- + ;"Results: None + ; + NEW CMD SET CMD=$$UP^XLFSTR($PIECE(MESSAGE,"|",1)) + SET CMD=$$TRIM^XLFSTR(CMD) + NEW PARAMS SET PARAMS=$$TRIM^XLFSTR($PIECE(MESSAGE,"|",2,99)) + DO DEBUGMSG^TMGKERN2("In HANDLMSG. CMD="_CMD_" & PARAMS="_PARAMS) + DO + . NEW $ETRAP SET $ETRAP="write ""#ERROR TRAPPED# "",$ZSTATUS,! set $etrap="""",$ecode=""""" + . IF CMD="GET" DO HANDLGET(PARAMS) QUIT + . IF CMD="GET DD" DO HANDLGDD(PARAMS) QUIT + . IF CMD="ORDREF" DO HANDLORD(PARAMS) QUIT + . IF CMD="NUMRECS" DO HANDLNRS(PARAMS) QUIT + . IF CMD="PT XREF" DO HNDLPTIX^TMGSIPH2(PARAMS) QUIT + . IF CMD="WIPE PT XREF" DO KILLPTIX^TMGFMUT2 QUIT + . IF CMD="GET PTRS IN" DO GETPTIN^TMGSIPH2(PARAMS) QUIT + . IF CMD="PREP XREFS" DO BAKXREF^TMGSIPH2(PARAMS) QUIT + . IF CMD="GET RECORD & XREF" DO HANDGRXR(PARAMS) QUIT + . IF CMD="GET REF & FILE XREF" DO HANDGRFX(PARAMS) QUIT + . IF CMD="DO DIC" DO HANDLDIC(PARAMS) QUIT + . IF CMD="GET XREF AGE" DO GETXRAGE^TMGSIPH2 QUIT + . IF CMD="GET .01 FLD" DO GET01FLD^TMGSIPH2(PARAMS) QUIT + . IF CMD="DUMP REC" DO DUMPREC(PARAMS) QUIT + . IF CMD="GET IEN LIST" DO HANDIENL^TMGSIPH2(PARAMS) QUIT + . IF CMD="GET IEN HDR" DO HANDLIENHDR^TMGSIPH2(PARAMS) QUIT + . ELSE DO + . . DO SEND^TMGKERN2("Got: ["_MESSAGE_"]. Server is $JOB="_$JOB) + QUIT + ;"============================================================= + ;"============================================================= + ; +HANDLGET(REF) ; + ;"Purpose: A handler for GET command between VistA instances. Get a ^global node + ;"Input --REF -- reference to a global. May be in Open or Closed format + ;"Results: none + ;"Output: Will write output to current device (should be socket to other instance) + ; + NEW OREF SET OREF=$$OREF^DILF(REF) + NEW LEN SET LEN=$LENGTH(OREF) + SET REF=$$CREF^DILF(REF) + NEW DONE SET DONE=0 + FOR DO QUIT:(DONE>0) + . IF $DATA(@REF)#10 DO + . . DO SEND^TMGKERN2(REF_"=") + . . DO SEND^TMGKERN2("="_$GET(@REF)) + . SET REF=$QUERY(@REF) + . IF (REF="")!($QSUBSCRIPT(REF,1)="") SET DONE=1 QUIT + . IF $EXTRACT(REF,1,LEN)'=OREF SET DONE=1 QUIT + QUIT + ; + ; +HANDLGDD(FILENUM) ; "Handle Get DD + ;"Purpose: to return Data Dictionary information about specified file. + SET FILENUM=+$GET(FILENUM) + NEW REF SET REF=$NAME(^DD(FILENUM)) + DO HANDLGET(REF) + SET REF=$NAME(^DIC(FILENUM)) + DO HANDLGET(REF) + ;"Get nodes from INDEX file + NEW IDX SET IDX="" + FOR SET IDX=$ORDER(^DD("IX","B",FILENUM,IDX)) QUIT:(IDX="") DO + . SET REF=$NAME(^DD("IX",IDX)) + . DO HANDLGET(REF) + NEW FLD SET FLD=0 + FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0) DO + . NEW PT SET PT=+$PIECE($GET(^DD(FILENUM,FLD,0)),"^",2) + . QUIT:(PT'>0) + . IF $DATA(^DD(PT,0,"UP")) DO GETSUBDD(PT) + QUIT + ; + ; +GETSUBDD(SUBFILENUM) + ;"Purpose: Return DD information about subfiles (and sub-subfiles) + NEW REF SET REF=$NAME(^DD(SUBFILENUM)) + DO HANDLGET(REF) + NEW PT SET PT=+$PIECE($GET(^DD(SUBFILENUM,0)),"^",2) + QUIT:(PT'>0) + IF $DATA(^DD(PT,0,"UP")) DO GETSUBDD(PT) + QUIT + ; + ; +HANDLORD(REF) ; + ;"Purpose: A handler for ORDREF command between VistA instances. + ;" Will get ^Global node that is $ORDER'd after REF + ;" e.g. ^TIU(8925,"") --> returns node ^TIU(8925,0, + ;" ^TIU(8925, --> returns node ^TIU(8925.1, + ;"Input --REF -- reference to a global. May be in Open or Closed format + ;"Results: none + ;"Output: Will write output to current device (should be socket to other VistA instance) + ;" + NEW CREF SET CREF=$$CREF^DILF(REF) + SET REF=$$ORDREF^TMGSIPHU(CREF) + IF REF'="" DO HANDLGET(REF) + QUIT + ; + ; +HANDLNRS(FILENUM) ; + ;"Purpose: Return the highest record number in given file. + ;"Input: FILENUM -- The fileman number of the file to return info for. + ;"Results: None + DO SEND^TMGKERN2($$GETNUMREC^TMGSIPHU(FILENUM)) + QUIT + ; + ; +HANDGRFX(PARAMS) ;" Handler for GET REF & FILE XREF|REF^FILENUM^IENS + ;"Purpose: Return one reference, and associated FILENUM cross-reference entries + ;" Note: It is anticipated that this will be used to get subfile entries. + ;"Input: PARAMS : REF^FILENUM^IENS + ;" REF -- should be in OPEN format (ending in a ',') + ;" FILENUM -- the subfile number. + ;" IENS -- A standard IENS string + ;"Output: Will write output to current device (should be socket). Format + ;" = + ;" = + ;" = + ;" = + ;" ... + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + ;" ... + ;"Result: none + ;"NOTE: This function will assume that an xref of all the cross-references has + ;" already been set up by calling BAKXREF^TMGSIPH1(FILENUM). This can be + ;" triggered on the client side by calling QUERY="PREP XREFS|" + SET PARAMS=$GET(PARAMS) + NEW GREF SET GREF="^"_$PIECE(PARAMS,"^",2) ;"Ref itself has a ^ in it. + NEW FILENUM SET FILENUM=$PIECE(PARAMS,"^",3) + NEW IENS SET IENS=$PIECE(PARAMS,"^",4) + DO HANDLGET(GREF) ; + ;"Now send XRef entries for IEN. + DO BAKXREF^TMGSIPH2(FILENUM_"^1") ;"organize XRefs if needed, keeping current orangization array + NEW REF SET REF="" + FOR SET REF=$ORDER(^TMG("PTXREF","XREFS",FILENUM,IENS,REF)) QUIT:(REF="") DO + . DO SEND^TMGKERN2(REF_"=") + . DO SEND^TMGKERN2("="_$GET(^TMG("PTXREF","XREFS",FILENUM,IENS,REF))) + DO SENDFLDS(FILENUM,IENS) ;"Send values of .01 fields for all pointers OUT from record + QUIT + ; + ; +HANDGRXR(PARAMS) ; + ;"Purpose: Return one record, and associated cross-reference entries + ;"Input: PARAMS : Filenumber^IEN + ;"Output: Will write output to current device (should be socket). Format + ;" = + ;" = + ;" = + ;" = + ;" ... + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + ;" ... + ;"Result: none + ;"NOTE: This function will assume that an xref of all the cross-references has + ;" already been set up by calling BAKXREF^TMGSIPH1(FILENUM). This can be + ;" triggered on the client side by calling QUERY="PREP XREFS|" + ; + NEW FILENUM,IEN + SET PARAMS=$GET(PARAMS) + SET FILENUM=+PARAMS + SET IEN=$PIECE(PARAMS,"^",2) + IF (FILENUM'>0)!(IEN'>0) QUIT + NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + IF GREF="" QUIT + DO HANDLGET(GREF_IEN_",") ; + ;"Now send XRef entries for IEN. + NEW REF SET REF="" + DO BAKXREF^TMGSIPH2(FILENUM_"^1") ;"organize XRefs if needed, keeping current orangization array + FOR SET REF=$ORDER(^TMG("PTXREF","XREFS",FILENUM,IEN,REF)) QUIT:(REF="") DO + . DO SEND^TMGKERN2(REF_"=") + . DO SEND^TMGKERN2("="_$GET(^TMG("PTXREF","XREFS",FILENUM,IEN,REF))) + DO SENDFLDS(FILENUM,IEN) ;"Send values of .01 fields for all pointers OUT from record +HGXDN QUIT + ; + ; +SENDFLDS(FILENUM,IEN) ; + ;"Purpose to send any .01 fields VALUES of any pointers OUT + ;"Input: FILENUM -- the file containing the record to be scanned + ;" IEN -- The record number being scanned. + ;"Results: none + ;"Output: Values will be sent to client via SEND^TMGKERN2. Format as follows: + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE + NEW TALLY + KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM) + IF $$REAL1PTOUT^TMGSIPH1(FILENUM,IEN,.TALLY)=1 DO + . NEW REF SET REF="" + . FOR SET REF=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF)) QUIT:(REF="") DO + . . NEW INFO SET INFO="" + . . FOR SET INFO=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO)) QUIT:(INFO="") DO + . . . NEW PCE SET PCE=+INFO + . . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2) + . . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3) + . . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4) + . . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V") + . . . NEW TEMP SET TEMP=IEN KILL IEN SET IEN=TEMP ;"kill subnodes + . . . NEW OKCOMBO + . . . FOR DO QUIT:(OKCOMBO=0) + . . . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(REF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @REF + . . . . QUIT:(OKCOMBO=0) + . . . . NEW PT SET PT=$PIECE($GET(@REF),"^",PCE) + . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF) + . . . . SET PT=+PT QUIT:(PT'>0) + . . . . NEW VALUE SET VALUE=$$FLD01^TMGSIPH2(P2FILE_"^"_PT) ; + . . . . DO SEND^TMGKERN2("%PTRSOUT%^"_P2FILE_"^"_PT_"^"_VALUE) + . . . KILL IEN("DONE"),IEN("INIT") + ;"KILL ^TMG("TMGSIPH","UNRESOLVED",FILENUM) + KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM) + KILL ^TMG("TMGSIPH","DD",FILENUM) + QUIT + ; + ; +HANDLDIC(PARAMS) ; + ;"Purpose: Do a ^DIC lookup in file for value. + ;"Input: Params: this is FILENUM^LOOKUPVALUE + ;"Result: Will send back value of Y to client + SET PARAMS=$GET(PARAMS) + NEW DIC SET DIC=+$PIECE(PARAMS,"^",1) + NEW Y,X SET X=$PIECE(PARAMS,"^",2) + SET DIC(0)="M" + DO ^DIC + DO SEND^TMGKERN2(Y) + QUIT + ; + ; +DUMPREC(PARAMS) ; + ;"Purpose: To do a record dump of a server-side record, sending output back to client + ;"Input: Params -- FILENUM^IENS^SHOWEMPTY + NEW FILENUM,IENS,SHOWEMPTY + SET PARAMS=$GET(PARAMS) + SET FILENUM=+PARAMS + SET IENS=$PIECE(PARAMS,"^",2) + IF (FILENUM'>0)!(IENS'>0) QUIT + SET SHOWEMPTY=+$PIECE(PARAMS,"^",3) + NEW OPTION + SET OPTION("WRITE REC FN")="WRLABEL^TMGSIPH0" + SET OPTION("WRITE FLD FN")="WFLABEL^TMGSIPH0" + SET OPTION("WRITE LINE FN")="WLINE^TMGSIPH0" + SET OPTION("WRITE WP LINE")="WWPLINE^TMGSIPH0" + NEW TMGDUMPS ;"Will be used with global scope + DO DumpRec2^TMGDEBUG(FILENUM,IENS,SHOWEMPTY,,.OPTION) + QUIT + ; + ; +WRLABEL(IEN,ENDER) + ;"Purpose: To actually write out labels for record starting and ending. + ;"Input: IEN -- the IEN (record number) of the record + ;" ENDER -- OPTIONAL if 1, then ends field. + ;"Note: also uses globally scoped variable TMGDUMPS + ;"Results: none. + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 + SET TMGDUMPS=$GET(TMGDUMPS) + IF +$GET(ENDER)>0 DO + . IF TMGDUMPS="" SET TMGDUMPS="." + ELSE SET TMGDUMPS=TMGDUMPS_" Multiple Entry #"_IEN + DO SEND^TMGKERN2(TMGDUMPS) + SET TMGDUMPS="" + QUIT + ; +WFLABEL(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. + ;"Note: also uses globally scoped variable TMGDUMPS + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 + ;"To write out or + SET TMGDUMPS=$GET(TMGDUMPS) + IF +$GET(ENDER)>0 DO + . IF TMGDUMPS="" SET TMGDUMPS="." + . DO SEND^TMGKERN2(TMGDUMPS) + . SET TMGDUMPS="" + ELSE DO + . IF $GET(FIELD)'="" SET TMGDUMPS=TMGDUMPS_$$RJ^XLFSTR(FIELD,6," ")_"-" + . IF $GET(LABEL)'="" SET TMGDUMPS=TMGDUMPS_LABEL_" " + . ;"IF $GET(TYPE)'="" SET TMGDUMPS=TMGDUMPS_"type="""_TYPE_""" " + . SET TMGDUMPS=TMGDUMPS_": " + QUIT + ; +WLINE(LINE) + ;"Purpose: To actually write out labels for record starting and ending. + ;"Input: Line -- The line of text to be written out. + ;"Note: also uses globally scoped variable TMGDUMPS + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 + SET TMGDUMPS=$GET(TMGDUMPS)_$GET(LINE) + QUIT + ; +WWPLINE(LINE) + ;"Purpose: To actually write out line from WP field + ;"Input: Line -- The line of text to be written out. + ;"Note: also uses globally scoped variable TMGDUMPS + ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2 + SET TMGDUMPS=$GET(TMGDUMPS)_$GET(LINE) + IF TMGDUMPS="" SET TMGDUMPS="." + DO SEND^TMGKERN2(TMGDUMPS) + SET TMGDUMPS="" + QUIT Index: cprs/branches/tmg-cprs/m_files/TMGSIPH1.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH1.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH1.m (revision 896) @@ -0,0 +1,663 @@ +TMGSIPH1 ;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 working with the data dictionaries. + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"COMPALLD(JNUM) --ask user for file name and compare data dictionaries. + ;"DDOK(JNUM,FILENUM) --check that data dictionary is ready, interacting with user as needed + ;"PREPDD(JNUM,FILENUM) --Ensure the data dictonary is ready for the local client + ;"COMPDD(JNUM,FILENUM,ARRAY) --compare data dictionary from Remote to local machine. + ;"PROCESSDIFF(FILENUM,ARRAY) -- take array of differences (as created by COMPDD) and see if user wants to copy remote changes to local machine. + ;"HASFLDMISS(ARRAY) -- determine if file has fields missing in local machine. + ;"ADDFLDMISSING(ARRAY) --allow user to pick filed to add to local data dictionary. + ;"ADD1FLD(FILENUM,FLD,ARRAY) --add all the nodes for file (or subfile) field to local data dictionary. + ;"VFLDMISSING(ARRAY) --display fields missing in local machine. + ;"GETMISFLD(ARRAY,MISFLDS) --display fields missing in local machine. + ;"VIEW1FLDMISSING(FILENUM,FLD,ARRAY) --show the data for 1 field to be displayed. + ;"HASWMISSING(ARRAY) -- determine if there are any Nodes missing in local machine. + ;"VIEWMISSING(ARRAY) -- display Nodes missing in local machine. + ;"ADDMISSING(ARRAY) -- add remote changes into this machine, if wanted. + ;"HASDIFF(ARRAY) -- determine if there are values that differ between remote and local VistA + ;"VIEWDIFF(ARRAY) -- display values that differ between remote and local VistA + ;"RSLVDIFF(ARRAY) -- allow storing values that differ between remote and local VistA + ;"SETPTOUT(FILENUM) --set up an easy to use array of potential pointers out from a file. + ;"SETALLPTO -- To cycle through ALL files and call SETPTOUT for each file. + ;"REAL1PTOUT(FILENUM,IEN,TALLY) --compare 1 record in the specified file that has been downloaded from the + ;" server, but not yet processed, and look for actual pointers out. + ;" If pointers out refer to records already gotten from server, then pointer is + ;" fixed immediately. Otherwise pointer is added to list of fixes needed. + ;"REALPTOUT(FILENUM) -- DEPRECIATED --compare all recorda in the specified file and look for actual pointers out. + ;"PREPXREF(JNUM,FILENUM) -- ask the server to pepair organized cross references. + + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGKERN2, TMGUSRIF + ;"======================================================================= + ; +COMPALLD(JNUM) ; + ;"Purpose: ask user for file name and compare data dictionaries. + ;"Input: JNUM -- The job number of the background client process + ;" + NEW X,Y,DIC,ARRAY + SET DIC=1,DIC(0)="MAEQ" +LCAD DO ^DIC WRITE ! + IF +Y'>0 QUIT + DO COMPDD(JNUM,+Y,.ARRAY) + DO PROCESSDIFF(+Y,.ARRAY) + ;"GOTO LCAD + QUIT + ; + ; +DDOK(JNUM,FILENUM) ; + ;"Purpose: To check that data dictionary is ready, interacting with user as needed + ;"Input: JNUM -- The job number of the background client process + ;" FILENUM -- The file number to work on, or subfilenumber{parentfilenumber{grandparent... + ;"Results : 1 if DD is ready. -1 if user aborted. + ;"NOTE: globally-scoped var TMGABORT may be set to 1 to cause drop back to main menu. + NEW DDOK SET DDOK=0 + SET FILENUM=+$GET(FILENUM) ;"if subfile, strip parent filenumber + FOR DO QUIT:(DDOK'=0)!($GET(TMGABORT)=1) + . SET DDOK=+$GET(^TMG("TMGSIPH","DD",FILENUM,"DIFF")) + . 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 ;"will set global-scope var TMGPTCABORT if aborted. + . IF $GET(TMGPTCABORT)=1 SET DDOK=-1,TMGABORT=1 QUIT + . SET DDOK=$$PREPDD(JNUM,FILENUM) + QUIT DDOK + ; + ; +PREPDD(JNUM,FILENUM) ; + ;"Purpose: Ensure the data dictonary is ready for the local client + ;"Input: JNUM -- The job number of the background client process + ;" FILENUM -- The file number to work on + ;"Results : 1 if DD is ready. 0 or -1 if user aborted. + ;"NOTE: globally-scoped var TMGABORT may be set to 1 to cause drop back to main menu. + NEW ARRAY,RESULT + SET RESULT=$GET(^TMG("TMGSIPH","DD",FILENUM,"DIFF")) + IF RESULT=1 GOTO PDDN ;"Signal that DD has been resolved + DO COMPDD(JNUM,FILENUM,.ARRAY) + IF $DATA(ARRAY) DO + . DO PROCESSDIFF(FILENUM,.ARRAY) + . SET RESULT=+$GET(^TMG("TMGSIPH","DD",FILENUM,"DIFF")) ;"Signal that DD has been looked at + ELSE DO + . SET ^TMG("TMGSIPH","DD",FILENUM,"DIFF")=1 ;"Signal that DD has been looked at + . SET RESULT=1 +PDDN QUIT RESULT + ; + ; +COMPDD(JNUM,FILENUM,ARRAY) ; + ;"Purpose: To compare data dictionary from Remote to local machine. + ;"Input: JNUM -- The job number of the background client process + ;" FILENUM -- The file number to compare. + ;" ARRAY -- Pass by REFERENCE, an OUT PARAMETER. + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("DIFF VALUE",NodeStr,"L")=LocalValue + ;" ARRAY("DIFF VALUE",NodeStr,"R")=RemoteValue + ;"Results: none + NEW QUERY,ERROR,RESULT,REPLY + KILL ARRAY + SET FILENUM=+$GET(FILENUM) + SET ARRAY("FILE")=FILENUM + SET QUERY="GET DD|"_FILENUM + DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,5) + IF $DATA(ERROR) WRITE ERROR,! GOTO CDDD + NEW TMGI SET TMGI=1 + NEW REF,VALUE + FOR DO SET TMGI=TMGI+2 QUIT:(REF="") + . SET REF=$GET(REPLY(TMGI)) QUIT:(REF="") + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) ;"Cleave terminal "=" + . SET VALUE=$GET(REPLY(TMGI+1)) + . SET VALUE=$EXTRACT(VALUE,2,$LENGTH(VALUE)) + . IF $DATA(@REF)=0 DO QUIT + . . SET ARRAY("MISSING NODE",REF)=VALUE + . IF $GET(@REF)'=VALUE DO QUIT + . . SET ARRAY("DIFF VALUE",REF,"L")=$GET(@REF) + . . SET ARRAY("DIFF VALUE",REF,"R")=VALUE +CDDD QUIT + ; + ; +PROCESSDIFF(FILENUM,ARRAY) ; + ;"Purpose: To take array of differences (as created by COMPDD) and + ;" see if user wants to copy remote changes to local machine. + ;"Input -- FILENUM -- The Fileman file number + ;" ARRAY -- Pass by REFERENCE. As created by COMPDD + ;"Result: None + ;"NOTE: globally-scoped var TMGABORT may be set to 1 to cause drop back to main menu. + ; + NEW MENU,USRSLCT,IDX,% + NEW FNAME SET FNAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) +CD1 KILL MENU + SET IDX=1 + SET MENU(0)="Pick Option for Comparing Differences in File #"_$get(ARRAY("FILE"))_" "_FNAME + IF $$HASFLDMISS(.ARRAY) DO + . SET MENU(IDX)="View missing local FIELDS"_$char(9)_"ViewFldMissing" SET IDX=IDX+1 + . SET MENU(IDX)="Add missing local FIELDS"_$char(9)_"AddFldMissing" SET IDX=IDX+1 + IF $$HASWMISSING(.ARRAY) DO + . SET MENU(IDX)="View missing local nodes"_$char(9)_"ViewMissing" SET IDX=IDX+1 + . SET MENU(IDX)="Add missing local nodes"_$char(9)_"AddMissing" SET IDX=IDX+1 + IF $$HASDIFF(.ARRAY) DO + . SET MENU(IDX)="View conflicts between remote and local VistA"_$char(9)_"ViewDiff" SET IDX=IDX+1 + . SET MENU(IDX)="Resolve conflicts between remote and local VistA"_$char(9)_"ResolveDiff" SET IDX=IDX+1 + IF IDX>1 DO + . SET MENU(IDX)="Launch local data dictionary browser"_$char(9)_"VPEDD" SET IDX=IDX+1 + ELSE DO GOTO CDDN2 + . SET ^TMG("TMGSIPH","DD",FILENUM,"DIFF")=1 + . ;"WRITE "Local Data Dictionary is OK. Nothing to be done.",! + . ;"DO PressToCont^TMGUSRIF + SET MENU(IDX)="DONE with fixing differences"_$char(9)_"Done" SET IDX=IDX+1 + SET MENU(IDX)="ABORT entire process"_$char(9)_"Abort" SET IDX=IDX+1 + ; + WRITE # + WRITE "********************************************************************",! + WRITE "File name: "_FNAME,! + WRITE "Before records can be transferred from the server, the local data",! + WRITE "dictionary must be made compatible. Please work on this now.",! + WRITE "********************************************************************",! + SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") + IF USRSLCT="^" GOTO CDDONE + IF USRSLCT=0 SET USRSLCT="" + ; + IF USRSLCT="ViewFldMissing" DO VFLDMISSING(.ARRAY) GOTO CD1 + IF USRSLCT="AddFldMissing" DO ADDFLDMISSING(.ARRAY) GOTO CD1 + IF USRSLCT="ViewMissing" DO VIEWMISSING(.ARRAY) GOTO CD1 + IF USRSLCT="AddMissing" DO ADDMISSING(.ARRAY) GOTO CD1 + IF USRSLCT="ViewDiff" DO VIEWDIFF(.ARRAY) GOTO CD1 + IF USRSLCT="ResolveDiff" DO RSLVDIFF(.ARRAY) GOTO CD1 + IF USRSLCT="VPEDD" DO ^%ZVEMD GOTO CD1 + IF USRSLCT="Done" SET %=1 GOTO CDDN1 + IF USRSLCT="Abort" SET TMGABORT=1 GOTO CDDN2 + ; +CDDONE SET %=2 + WRITE "Have all conflicts for this file been resolved (^ to abort)" + DO YN^DICN WRITE ! +CDDN1 IF %=1 SET ^TMG("TMGSIPH","DD",FILENUM,"DIFF")=1 ;"Signal that DD has been processed + ELSE IF %=-1 SET ^TMG("TMGSIPH","DD",FILENUM,"DIFF")=-1 ;"Signal of abort + ELSE SET ^TMG("TMGSIPH","DD",FILENUM,"DIFF")=0 ;"Signal that DD needs processing +CDDN2 QUIT + ; + ; +HASFLDMISS(ARRAY) ; + ;"Purpose: to determine if file has fields missing in local machine. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;"Results: 1 if has missing fields, 0 if not + NEW MISFLDS + DO GETMISFLD(.ARRAY,.MISFLDS) + NEW FOUND SET FOUND=0 + NEW FILENUM SET FILENUM=0 + FOR SET FILENUM=$ORDER(MISFLDS(FILENUM)) QUIT:(FILENUM'>0)!FOUND DO + . NEW FLDNAME SET FLDNAME="" + . FOR SET FLDNAME=$ORDER(MISFLDS(FILENUM,FLDNAME)) QUIT:(FLDNAME="")!FOUND DO + . . SET FOUND=1 + QUIT (FOUND=1) + ; + ; +ADDFLDMISSING(ARRAY) ; + ;"Purpose: To allow user to pick filed to add to local data dictionary. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + NEW MISFLDS + DO GETMISFLD(.ARRAY,.MISFLDS) + NEW ABORT SET ABORT=0 + NEW FILENUM SET FILENUM=0 + FOR SET FILENUM=$ORDER(MISFLDS(FILENUM)) QUIT:(FILENUM'>0)!ABORT DO + . NEW MENU,USRSLCT + . SET MENU(0)="Pick FIELD to add to local data dictionary, File #"_FILENUM + . NEW I SET I=1 + . NEW FLDNAME SET FLDNAME="" + . FOR SET FLDNAME=$ORDER(MISFLDS(FILENUM,FLDNAME)) QUIT:(FLDNAME="") DO + . . NEW FLD SET FLD=$GET(MISFLDS(FILENUM,FLDNAME)) + . . SET MENU(I)="Field "_FLDNAME_" ("_FLD_")"_$char(9)_FLD + . . SET I=I+1 + . NEW DONE SET DONE=0 + . FOR DO QUIT:DONE + . . IF $ORDER(MENU(0))="" SET DONE=1 QUIT + . . WRITE # + . . SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") + . . IF USRSLCT="^" SET (DONE,ABORT)=1 QUIT + . . IF USRSLCT="" SET DONE=1 QUIT + . . IF +USRSLCT>0 IF $$ADD1FLD(FILENUM,+USRSLCT,.ARRAY) DO + . . . NEW J SET J=0 + . . . FOR SET J=$ORDER(MENU(J)) QUIT:(J="") DO + . . . . IF MENU(J)[($CHAR(9)_+USRSLCT) KILL MENU(J) + QUIT + ; + ; +ADD1FLD(FILENUM,FLD,ARRAY) ; + ;"Purpose: To add all the nodes for file (or subfile) field to local data dictionary. + ;"Input: FILENUM -- The Fileman file + ;" FLD -- The fieldman field to add + ;" ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;"Result: 1 if added, 0 if not + NEW RESULT SET RESULT=0 + NEW REF SET REF="" + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="") DO + . IF $QSUBSCRIPT(REF,0)'="^DD" QUIT + . IF $QSUBSCRIPT(REF,1)'=FILENUM QUIT + . NEW SUB2 SET SUB2=$QSUBSCRIPT(REF,2) + . NEW SUB3 SET SUB3=$QSUBSCRIPT(REF,3) + . NEW LASTSUB SET LASTSUB=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . NEW VALUE SET VALUE=$GET(ARRAY("MISSING NODE",REF)) + . NEW ADD SET ADD=0 + . IF (SUB2'=+SUB2),(LASTSUB=FLD) SET ADD=1 ;"Handle xrefs + . IF SUB2=FLD SET ADD=1 + . IF FLD="*" SET ADD=1 + . IF SUB2=0 DO + . . NEW SUB3 SET SUB3=$QSUBSCRIPT(REF,3) + . . IF (SUB3="ID"),(LASTSUB=FLD) SET ADD=1 ;"Write identifier nodes + . . IF (SUB3="IX"),(LASTSUB=FLD) SET ADD=1 ;"Indexes + . . IF (SUB3="PT"),(LASTSUB=FLD) SET ADD=1 ;"Pointers IN to file + . . ELSE DO + . . . NEW TEMP SET TEMP=1 ;"Breakpoint to see what is NOT being handled. + . IF ADD'=1 QUIT + . IF SUB3=0,SUB2>0 DO + . . NEW PT SET PT=+$PIECE(VALUE,"^",2) + . . NEW SUBREF SET SUBREF=$NAME(^DD(PT,0)) + . . IF $DATA(ARRAY("MISSING NODE",SUBREF)) IF $$ADD1FLD(PT,"*",.ARRAY) + . SET @REF=VALUE + . WRITE "ADDED ",REF,! + . KILL ARRAY("MISSING NODE",REF) + . SET RESULT=1 + WRITE !,"Done.",! + DO PressToCont^TMGUSRIF + QUIT RESULT + ; + ; +VFLDMISSING(ARRAY) ; + ;"Purpose: to display fields missing in local machine. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + NEW NAME,FOUND + WRITE "The following FIELDS are present on the remote VistA, but",! + WRITE "are missing from the local machine.",!,! + NEW MISFLDS + DO GETMISFLD(.ARRAY,.MISFLDS) + NEW FOUND SET FOUND=0 + NEW ABORT SET ABORT=0 + NEW FILENUM SET FILENUM=0 + FOR SET FILENUM=$ORDER(MISFLDS(FILENUM)) QUIT:(FILENUM'>0)!ABORT DO + . NEW MENU,USRSLCT + . SET MENU(0)="Pick FIELD to examine in File #"_FILENUM + . NEW I SET I=1 + . NEW FLDNAME SET FLDNAME="" + . FOR SET FLDNAME=$ORDER(MISFLDS(FILENUM,FLDNAME)) QUIT:(FLDNAME="") DO + . . NEW FLD SET FLD=$GET(MISFLDS(FILENUM,FLDNAME)) + . . SET MENU(I)="Field "_FLDNAME_" ("_FLD_")"_$char(9)_FLD + . . SET I=I+1 + . IF I>1 SET FOUND=1 + . ELSE QUIT + . NEW DONE SET DONE=0 + . FOR DO QUIT:DONE + . . WRITE # + . . SET USRSLCT=$$MENU^TMGUSRIF(.MENU,"^") + . . IF USRSLCT="^" SET (DONE,ABORT)=1 QUIT + . . IF USRSLCT="" SET DONE=1 QUIT + . . IF +USRSLCT>0 DO VIEW1FLDMISSING(FILENUM,+USRSLCT,.ARRAY) + IF FOUND=0 DO + . WRITE "<>",! + . DO PressToCont^TMGUSRIF + QUIT + ; + ; +GETMISFLD(ARRAY,MISFLDS) ; + ;"Purpose: to display fields missing in local machine. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" MISFLDS -- PASS BY REFERENCE, AN OUT PARAMETER. Format: + ;" MISFLDS(FILENUM,FIELDNAME)=FieldNumber + NEW REF,VALUE,FOUND + NEW FLD,LASTFLD SET LASTFLD="" + SET REF="" + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="") DO + . IF $QSUBSCRIPT(REF,0)'="^DD" QUIT + . SET FLD=$QSUBSCRIPT(REF,2) + . QUIT:(FLD=LASTFLD) + . IF $QSUBSCRIPT(REF,3)'=0 QUIT + . SET LASTFLD=FLD + . NEW FILENUM SET FILENUM=$QSUBSCRIPT(REF,1) + . NEW FLDNAME SET FLDNAME=$PIECE($GET(ARRAY("MISSING NODE",REF)),"^",1) + . QUIT:(FLDNAME="") + . SET MISFLDS(FILENUM,FLDNAME)=FLD + QUIT + ; + ; +VIEW1FLDMISSING(FILENUM,FLD,ARRAY) ; + ;"Purpose: To show the data for 1 field to be displayed. + ;"Input: FILENUM -- The Fileman file + ;" FLD -- The fieldman field to add + ;" ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + NEW LINECT SET LINECT=0 + SET NAME="",FOUND=0 + NEW REF SET REF="" + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="") DO + . IF $QSUBSCRIPT(REF,0)'="^DD" QUIT + . IF $QSUBSCRIPT(REF,1)'=FILENUM QUIT + . NEW SUB2 SET SUB2=$QSUBSCRIPT(REF,2) + . NEW LASTSUB SET LASTSUB=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . NEW ADD SET ADD=0 + . IF (SUB2'=+SUB2),(LASTSUB=FLD) SET ADD=1 ;"Handle xrefs + . IF SUB2=0 DO + . . NEW SUB3 SET SUB3=$QSUBSCRIPT(REF,3) + . . IF (SUB3="ID"),(LASTSUB=FLD) SET ADD=1 ;"Write identifier nodes + . . IF (SUB3="IX"),(LASTSUB=FLD) SET ADD=1 ;"Indexes + . . IF (SUB3="PT"),(LASTSUB=FLD) SET ADD=1 ;"Pointers IN to file + . IF SUB2=FLD SET ADD=1 + . IF ADD'=1 QUIT + . WRITE REF,"=",$GET(ARRAY("MISSING NODE",REF)),! + . SET FOUND=1 + . SET LINECT=LINECT+1 + . IF LINECT=23 SET LINECT=0 DO PressToCont^TMGUSRIF + WRITE !,"Done.",! + IF FOUND=0 WRITE "<>",! + DO PressToCont^TMGUSRIF + QUIT + ; + ; +HASWMISSING(ARRAY) ; + ;"Purpose: to determine if there are any Nodes missing in local machine. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;"Results: 1 if has data, 0 if not + NEW REF,VALUE,FOUND + NEW LINECT SET LINECT=0 + SET REF="",FOUND=0 + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="") DO + . SET FOUND=1 + QUIT (FOUND=1) + ; + ; +VIEWMISSING(ARRAY) ; + ;"Purpose: to display Nodes missing in local machine. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + ;" ARRAY("MISSING NODE",NodeStr)=RemoteValue + NEW REF,VALUE,FOUND + WRITE "The following nodes are present on the remote VistA, but",! + WRITE "are missing from the local machine.",!,! + NEW LINECT SET LINECT=0 + SET REF="",FOUND=0 + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="")!($GET(TMGPTCABORT)=1) DO + . SET FOUND=1 + . WRITE REF,"=",$GET(ARRAY("MISSING NODE",REF)),! + . SET LINECT=LINECT+1 + . IF LINECT=23 SET LINECT=0 DO PressToCont^TMGUSRIF + IF FOUND=0 WRITE "<>",! + IF $GET(TMGPTCABORT)'=1 DO PressToCont^TMGUSRIF + QUIT + ; +ADDMISSING(ARRAY) ; + ;"Purpose: To add remote changes into this machine, if wanted. + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + NEW ASKARRAY,SELARRAY + NEW REF SET REF="" + FOR SET REF=$ORDER(ARRAY("MISSING NODE",REF)) QUIT:(REF="") DO + . NEW VALUE SET VALUE=$GET(ARRAY("MISSING NODE",REF)) + . SET VALUE=$EXTRACT(VALUE,1,70-$LENGTH(REF)) + . SET ASKARRAY(REF_"="_VALUE)=REF + NEW HDR SET HDR="Pick Nodes to be added to local data dictionary. when done." + DO Selector^TMGUSRIF("ASKARRAY","SELARRAY",HDR) + NEW TMGI SET TMGI="" + FOR SET TMGI=$ORDER(SELARRAY(TMGI)) QUIT:(TMGI="") DO + . SET REF=$GET(SELARRAY(TMGI)) + . NEW VALUE SET VALUE=$GET(ARRAY("MISSING NODE",REF)) + . SET @REF=VALUE + . WRITE "ADDED ",REF,! + . KILL ARRAY("MISSING NODE",REF) + WRITE !,"Done.",! + DO PressToCont^TMGUSRIF + QUIT + ; +HASDIFF(ARRAY) ; + ;"Purpose: to determine if there are values that differ between remote and local VistA + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("DIFF VALUE",NodeStr,"L")=LocalValue + ;" ARRAY("DIFF VALUE",NodeStr,"R")=RemoteValue + NEW REF,FOUND + SET REF="",FOUND=0 + FOR SET REF=$ORDER(ARRAY("DIFF VALUE",REF)) QUIT:(REF="")!(FOUND) DO + . SET FOUND=1 + QUIT (FOUND=1) + ; +VIEWDIFF(ARRAY) ; + ;"Purpose: to display values that differ between remote and local VistA + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("DIFF VALUE",NodeStr,"L")=LocalValue + ;" ARRAY("DIFF VALUE",NodeStr,"R")=RemoteValue + NEW REF,VALUE,FOUND + WRITE "The following nodes DIFFER between remote and local VistAs",!,! + SET REF="",FOUND=0 + FOR SET REF=$ORDER(ARRAY("DIFF VALUE",REF)) QUIT:(REF="") DO + . SET FOUND=1 + . WRITE REF,! + . WRITE " Local: ",$GET(ARRAY("DIFF VALUE",REF,"L")),! + . WRITE " Remote:",$GET(ARRAY("DIFF VALUE",REF,"R")),! + IF FOUND=0 WRITE "<>",! + DO PressToCont^TMGUSRIF + QUIT + ; +RSLVDIFF(ARRAY) ; + ;"Purpose: To allow storing values that differ between remote and local VistA + ;"Input -- ARRAY -- Pass by REFERENCE. As created by COMPDD + ;" ARRAY("DIFF VALUE",NodeStr,"L")=LocalValue + ;" ARRAY("DIFF VALUE",NodeStr,"R")=RemoteValue + NEW REF,VALUE,FOUND,% + WRITE "The following nodes DIFFER between remote and local VistAs",!,! + SET REF="",FOUND=0,%=2 + FOR SET REF=$ORDER(ARRAY("DIFF VALUE",REF)) QUIT:(REF="")!(%=-1) DO + . SET FOUND=1 + . WRITE REF,! + . WRITE " Local: ",$GET(ARRAY("DIFF VALUE",REF,"L")),! + . WRITE " Remote:",$GET(ARRAY("DIFF VALUE",REF,"R")),! + . SET %=2 + . WRITE "Overwrite LOCAL value with REMOTE" DO YN^DICN WRITE ! + . IF %=2 KILL ARRAY("DIFF VALUE",REF) + . IF %'=1 QUIT + . SET @REF=$GET(ARRAY("DIFF VALUE",REF,"R")) + . WRITE " OVERWRITTEN",! + . KILL ARRAY("DIFF VALUE",REF) + IF FOUND=0 WRITE "<>",! + DO PressToCont^TMGUSRIF + QUIT + ; + ; +SETPTOUT(FILENUM) ; + ;"Purpose: To set up an easy to use array of potential pointers out from a file. + ;"Input: FILENUM-- the filenumber to evaluate + ;"Output: Data will be stored in ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF,ENTRY) + ;" ; Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;" ; ONEREF will have multipe 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. + ;"Results: 1= success, -1=error + ; + NEW RESULT SET RESULT=-1 + IF +$GET(FILENUM)'=FILENUM GOTO SPODN + NEW IENDEPTH SET IENDEPTH=1 + NEW ISSUBFIL SET ISSUBFIL=0 + NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL")) + IF (REF=""),$DATA(^DD(FILENUM,0,"UP")) DO + . SET REF=$$GETGL^TMGFMUT2(FILENUM,.IENDEPTH) + . SET ISSUBFIL=1 + IF REF="" GOTO SPODN + KILL ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT") ;"If FILENUM is subfile, nothing to kill... + NEW FLD SET FLD=0 + FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0) DO + . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0)) + . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2) + . IF (FLDTYPE'["P")&(FLDTYPE'["V")&(+FLDTYPE'>0) QUIT + . IF $PIECE($GET(^DD(+FLDTYPE,.01,0)),"^",2)["W" QUIT ;"WP fields look like subfiles, but really aren't + . NEW LOC SET LOC=$PIECE(ZNODE,"^",4) + . NEW NODE SET NODE=$PIECE(LOC,";",1) + . NEW PCE SET PCE=+$PIECE(LOC,";",2) + . IF +NODE'=NODE SET NODE=""""_NODE_"""" + . NEW ONEREF,SUBSCR + . SET SUBSCR=$SELECT((IENDEPTH>1):"("_IENDEPTH_")",1:"") + . SET ONEREF=REF_"IEN"_SUBSCR_","_NODE_")" + . NEW P2FILE + . NEW VREC SET VREC=0 + . NEW DONE SET DONE=0 + . FOR DO QUIT:(DONE=1) + . . NEW ISVIRT SET ISVIRT="" + . . NEW P2REF + . . SET P2FILE=0 + . . IF FLDTYPE["V" DO QUIT:(DONE=1) + . . . SET VREC=+$ORDER(^DD(FILENUM,FLD,"V",VREC)) + . . . IF VREC=0 SET DONE=1 QUIT + . . . SET P2FILE=+$GET(^DD(FILENUM,FLD,"V",VREC,0)) + . . . SET ISVIRT="V" + . . . SET P2REF=$PIECE($GET(^DIC(P2FILE,0,"GL")),"^",2) + . . ELSE DO QUIT:(P2FILE=0) + . . . IF +FLDTYPE>0 IF $$SETPTOUT(+FLDTYPE) SET DONE=1 QUIT ;"Handle subfile. + . . . SET P2FILE=+$PIECE(FLDTYPE,"P",2) + . . . SET P2REF=$PIECE(ZNODE,"^",3) + . . . SET DONE=1 + . . NEW ENTRY SET ENTRY=PCE_"^"_P2FILE_"^"_P2REF_"^"_IENDEPTH_"^"_ISVIRT + . . SET ^TMG("TMGSIPH","DD",$$TOPFILEN^TMGFMUT2(FILENUM),"PTR OUT",ONEREF,ENTRY)="" + . . SET ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF,ENTRY)="" ;"Not sure which is used throughout, so store both ways. + SET RESULT=1 +SPODN QUIT RESULT + ; +SETALLPTO ;" Set All Pointers Out + ;"Purpose: To cycle through ALL files and call SETPTOUT for each file. + ;"Input: None + ;"Output: Data will be stored... + ;"Results: None + NEW FILENUM SET FILENUM=0 + NEW STIME SET STIME=$H + NEW FILEMAXCT SET FILEMAXCT=0 + FOR SET FILENUM=$ORDER(^DD(FILENUM)) QUIT:(+FILENUM'>0) SET FILEMAXCT=FILEMAXCT+1 + NEW FILECT SET FILECT=0 + SET FILENUM=0 + FOR SET FILENUM=$ORDER(^DIC(FILENUM)) QUIT:(+FILENUM'>0) DO + . SET FILECT=FILECT+1 + . NEW FILENAME SET FILENAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) + . DO ProgressBar^TMGUSRIF(FILECT,"Progress: "_FILENAME,0,FILEMAXCT,70,STIME) + . IF $DATA(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT")) QUIT + . IF $$SETPTOUT(FILENUM) ;"ignore result + ;"Now handle subfiles. + SET FILENUM=0 + FOR SET FILENUM=$ORDER(^DD(FILENUM)) QUIT:(+FILENUM'>0) DO + . SET FILECT=FILECT+1 + . DO ProgressBar^TMGUSRIF(FILECT,"Progress: "_FILENUM,0,FILEMAXCT,70,STIME) + . IF $DATA(^DIC(FILENUM)) QUIT + . IF $$SETPTOUT(FILENUM) ;"ignore result + WRITE !,FILECT," Files processed.",! + DO PressToCont^TMGUSRIF + QUIT + ; +REAL1PTOUT(FILENUM,IEN,TALLY) ; + ;"Purpose: to compare 1 record in the specified file that has been downloaded from the + ;" server, but not yet processed, and look for actual pointers out. + ;" If pointers out refer to records already gotten from server, then pointer is + ;" fixed immediately. Otherwise pointer is added to list of fixes needed. + ;"Input: FILENUM -- the Fileman file (or subfile) number to look at + ;" IEN -- The record number to look at. + ;" If FILENUM is a subfile, pass IENS info in IEN (e.g. '3,2345,') + ;" TALLY -- OPTIONAL. PASS BY REFERENCE. An array to keep progress stats. Format: + ;" TALLY("ALREADY LOCAL FOUND")=# + ;" TALLY("FIXED LINK TO ALREADY-DOWNLOADED RECORD")=# + ;" TALLY(FILENUM,"NEW REC NEEDED")=# + ;"Output: Sets global records to show unresolved pointers: + ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,ReferToNodeToBeCorrected,INFO)="" + ;" INFO=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;"Result: 1 = OK, -1 = error + ;"NOTE: + ;" Uses data from ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",ONEREF,ENTRY) + ;" ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;" ONEREF will have multipe 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. + ; + NEW RESULT SET RESULT=-1 + SET FILENUM=+$GET(FILENUM) + IF FILENUM'>0 GOTO RP1ODN + IF $DATA(^TMG("TMGSIPH","DOWNLOADED",FILENUM,IEN)) DO GOTO RP1ODN ;"Already processed + . SET RESULT=1 + . SET TALLY("ALREADY LOCAL FOUND")=+$GET(TALLY("ALREADY LOCAL FOUND"))+1 + IF +$GET(^TMG("TMGSIPH","DD",FILENUM))=0 DO + . IF $$SETPTOUT(FILENUM) SET ^TMG("TMGSIPH","DD",FILENUM)=1 + NEW SAVIENS SET SAVIENS=IEN + NEW REF SET REF="" + FOR SET REF=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF)) QUIT:(REF="") DO + . NEW INFO SET INFO="" + . FOR SET INFO=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO)) QUIT:(INFO="") DO + . . NEW PCE SET PCE=+INFO + . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2) + . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3) + . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4) + . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V") + . . NEW TEMP SET TEMP=+IEN KILL IEN SET IEN=TEMP ;"kill subnodes. Prob won't work with sub-sub files. + . . NEW OKCOMBO + . . FOR DO QUIT:(OKCOMBO=0) + . . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(REF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @REF + . . . QUIT:(OKCOMBO=0) + . . . NEW RPTR SET RPTR=$PIECE($GET(@REF),"^",PCE) + . . . IF ISVIRT,$PIECE(RPTR,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF) + . . . SET RPTR=+RPTR QUIT:(RPTR'>0) + . . . NEW LPTR SET LPTR=+$GET(^TMG("TMGSIPH","PT XLAT",P2FILE,RPTR)) + . . . IF (LPTR>0) DO QUIT + . . . . IF LPTR'=RPTR SET $PIECE(@REF,"^",PCE)=LPTR + . . . . SET TALLY("FIXED LINK TO ALREADY-DOWNLOADED RECORD")=1+$GET(TALLY("FIXED LINK TO ALREADY-DOWNLOADED RECORD")) + . . . ;"SET ^TMG("TMGSIPH","UNRESOLVED",FILENUM,$NAME(@REF),INFO)=RPTR + . . . SET ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",P2FILE,RPTR,$NAME(@REF),INFO)="" + . . . SET TALLY(FILENUM,"NEW REC NEEDED")=+$GET(TALLY(FILENUM,"NEW REC NEEDED"))+1 + . . KILL IEN("DONE"),IEN("INIT") + SET RESULT=1 +RP1ODN QUIT RESULT + ; + ; +REALPTOUT(FILENUM) ;" DEPRECIATED + ;"Purpose: to compare all records in the specified file and look for actual pointers out. + ;"Input: FILENUM -- the Fileman file number to look at + ;"Result: 1 = OK, -1 = error + ; + NEW RESULT SET RESULT=-1 + IF +$GET(FILENUM)'=FILENUM GOTO RPODN + NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL")) + NEW CREF SET CREF=$$CREF^DILF(REF) + IF REF="" GOTO RPODN + ;"KILL ^TMG("TMGSIPH","UNRESOLVED",FILENUM) + NEW STARTTIME SET STARTTIME=$H + NEW MAXNUM SET MAXNUM=$ORDER(@(REF_"""A"")"),-1) + WRITE MAXNUM," records to check for unresolved pointers in file #",FILENUM,! + WRITE "Press ESC to abort...",! + NEW IEN SET IEN=0 + NEW TMGABORT SET TMGABORT=0 + FOR SET IEN=$ORDER(@CREF@(IEN)) QUIT:(+IEN'>0)!(TMGABORT=1) DO + . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) + . NEW TEMP SET TEMP=$$REAL1PTOUT(FILENUM,IEN) + . IF (IEN#10)=0 DO + . . DO ProgressBar^TMGUSRIF(IEN,"Progress: "_IEN,0,MAXNUM,70,STARTTIME) + SET RESULT=1 +RPODN QUIT RESULT + ; + ; +PREPXREF(JNUM,FILENUM) ; + ;"Purpose: To ask the server to pepair organized cross references. + ;"Input: JNUM -- The job number of the background client process + ;" FILENUM -- The Fileman file to transfer + ;"Results: 1 if OK, 0 if error. + NEW REPLY,ERROR,RESULT + SET RESULT=1 + SET QUERY="PREP XREFS|"_FILENUM_"^1" + DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,15) ;"ignore REPLY + IF $DATA(ERROR) DO + . WRITE ERROR,! + . SET RESULT=0 + QUIT RESULT Index: cprs/branches/tmg-cprs/m_files/TMGSIPH2.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH2.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH2.m (revision 896) @@ -0,0 +1,177 @@ +TMGSIPH2 ;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 + ;"----===== SERVER-SIDE CODE ====------ + ;"Especially functions for working with the data dictionaries, POINTERS IN. + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"HNDLPTIX(FILENUM) --prepair PT XREF for all records pointing INTO specified file. + ;"GETPTIN(PARAMS) --get a listing of all pointers INTO requested record + ;"BAKXREF(PARAMS) --Make a xref of cross-references (a backward xref) + ;"GETXRAGE --Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification + ;"FLD01(PARAMS) -- return .01 field of a record. Gets INTERNAL value, and doesn't support subfiles. + ;"GET01FLD(PARAMS) --To SEND .01 field of a record. Gets INTERNAL value, and doesn't support subfiles. + + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGKERN2, TMGUSRIF, TMGFMUT2 + ;"======================================================================= + ; +HNDLPTIX(FILENUM,CLSIDE) ; + ;"Purpose: To prepair PT XREF for all records pointing INTO specified file. + ;"Input: FILENUM -- The fileman file number to get pointers INTO. + ;" CLSIDE -- OPTIONAL. If =1, then will be running on client side, and will work differently + ;"Result: None + SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 QUIT + SET CLSIDE=+$GET(CLSIDE,0) + NEW TMGSTIME SET TMGSTIME=$H + NEW PGFN,LIMITS + IF 'CLSIDE SET PGFN="DO SEND^TMGKERN2(""#THINKING#|Organizing pointers for ""_TMGFNAME_"": ""_TMGIEN_"" of ""_TMGMAX)" + ELSE DO + . SET PGFN="WRITE ""Organizing pointers for ""_TMGFNAME_"": ""_TMGIEN_"" of ""_TMGMAX" + . SET LIMITS("REF")=$NAME(^TMG("TMGSIPH","DOWNLOADED")) + DO SETPTOUT^TMGFMUT2(FILENUM,$NAME(^TMG("PTXREF")),PGFN,3000,.LIMITS) + SET ^TMG("PTXREF","IN",FILENUM)=$H + SET ^TMG("PTXREF")=$H + QUIT + ; + ; +GETPTIN(PARAMS,CLSIDE) + ;"Purpose: To get a listing of all pointers INTO requested record + ;"Input: PARAMS -- this is FILENUM^IEN + ;" CLSIDE -- PASS BY REFERNCE. OPTIONAL. If =1, then will be running on client side, and will work differently + ;" Will also be used as an OUT PARAMETER when CLSIDE=1. Format: + ;" CLSIDE(1)=FROMFILE^FROMIENS^FROMFLD + ;" CLSIDE(2)=FROMFILE^FROMIENS^FROMFLD + ;" ... + ;"Output: Will return data to client. Format: + ;" FROMFILE^FROMIENS^FROMFLD + ;" FROMFILE^FROMIENS^FROMFLD + ;" FROMFILE^FROMIENS^FROMFLD (e.g. one line for every pointer in) + ;"Result: None. + NEW FILENUM SET FILENUM=+$PIECE(PARAMS,"^",1) + IF $DATA(^TMG("PTXREF","IN",FILENUM))'>0 DO HNDLPTIX(FILENUM,.CLSIDE) + DO GETPTIN^TMGFMUT2(PARAMS,.CLSIDE) ; + SET CLSIDE=+$GET(CLSIDE,0) IF CLSIDE QUIT + NEW TMGCT SET TMGCT=0 + FOR SET TMGCT=$ORDER(CLSIDE(TMGCT)) QUIT:(TMGCT="") DO + . NEW TEMP SET TEMP=$GET(CLSIDE(TMGCT)) QUIT:(TEMP="") + . DO SEND^TMGKERN2(TEMP) + QUIT + ; + ; +BAKXREF(PARAMS) ; + ;"Purpose: Make a xref of cross-references (a backward xref) + ;"Input: PARAMS -- This is FILENUM^[KEEP] + ;" FILENUM -- The fileman file to work with + ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists. + ;"Output: ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)= + ;" e.g. ^TMG("PTXREF","XREFS",FILENUM,113,"^VA(200,""A"",8870804679,113)")=6188 + ;"Result: none. + ;"DO SEND^TMGKERN2("#THINKING#|Organizing server cross-reference enteries...") + NEW PGFN + SET PGFN="DO SEND^TMGKERN2(""#THINKING#|Processing index: ""_INDEX_"" for file #""_FILENUM)" + DO BAKXREF^TMGFMUT2(PARAMS,PGFN) + ;"DO SEND^TMGKERN2("#THINKING#|Completed.") +BXDN QUIT + ; + ; +GETXRAGE ; + ;"Purpose: Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification + ;"OUTPUT: Sends 0 if not currently defined, otherwise number of HOURS since setup. + ;"Results: None + DO SEND^TMGKERN2($$GETXRAGE^TMGFMUT2) + QUIT + ; + ; +FLD01(PARAMS) ; + ;"Purpose: To return .01 field of a record. + ;"Input: PARAMS -- this is FILENUM^IEN + ;" Note: FILENUM can be in format of subfilenum{parentfilenum{grandparentnum + ;" In this case, IEN must be an IENS to be passed to $$GET1^DIQ + ;"Result: returns .01 value. Internal format (for speed), or External format if subfile. + NEW FILENUM SET FILENUM=$PIECE(PARAMS,"^",1) + NEW RESULT SET RESULT="" + IF FILENUM["{" DO + . SET FILENUM=+FILENUM + . NEW IENS SET IENS=$PIECE(PARAMS,"^",2) + . SET RESULT=$$GET1^DIQ(FILENUM,IENS,.01,"E") + ELSE DO + . SET FILENUM=+FILENUM + . NEW IEN SET IEN=+$PIECE(PARAMS,"^",2) + . NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + . IF GREF="" SET RESULT="" GOTO F1DN + . NEW CGREF SET CGREF=$$CREF^DILF(GREF) + . NEW VALUE SET VALUE=$GET(@CGREF@(IEN,0)) + . SET RESULT=$PIECE(VALUE,"^",1) + . IF RESULT="" SET RESULT="" +F1DN QUIT RESULT + ; + ; +GET01FLD(PARAMS) ; + ;"Purpose: To get .01 field of a record. + ;"Input: PARAMS -- this is FILENUM^IEN + ;" FILENUM can be File number, or SubFileNum{ParentFileNum{Grandparent... + ;" IEN can be a record number, or IENS (e.g. '1,2456,') + ;"Output: Will return data to client. Format: + ;" <.01 value> + ;"Result: None. + NEW VALUE + DO DEBUGMSG^TMGKERN2("In GET01FLD. PARAMS="_PARAMS) + SET VALUE=$$FLD01(.PARAMS) + DO DEBUGMSG^TMGKERN2("In GET01FLD. VALUE="_VALUE) + DO SEND^TMGKERN2(VALUE) + DO DEBUGMSG^TMGKERN2("Leaving GET01FLD.") + QUIT + ; + ; +HANDIENL(PARAMS) ; + ;"Purpose: To return a listing of all records (IEN's) in specified file. + ;"Input : PARAMS -- this is FILENUM (Subfiles not supported) + ;"Output: Will return data to client. Format: + ;" ^.01 Value (internal format) + ;" ^.01 Value (internal format) + ;" ^.01 Value (internal format) ... + ;"Results: None + SET PARAMS=$GET(PARAMS) + NEW FILENUM SET FILENUM=$PIECE(PARAMS,"^",1) + IF +FILENUM'>0 QUIT + NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + IF GREF="" QUIT + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + NEW TMGCT SET TMGCT=1 + NEW IEN SET IEN=0 + FOR SET IEN=$ORDER(@CGREF@(IEN)) QUIT:(+IEN'>0) DO + . NEW VALUE SET VALUE=$PIECE($GET(@CGREF@(IEN,0)),"^",1) + . DO SEND^TMGKERN2(IEN_"^"_VALUE) + . SET TMGCT=TMGCT+1 + . IF TMGCT>5000 DO + . . DO SEND^TMGKERN2("#THINKING#|Processing IEN: "_IEN_" for file #"_FILENUM) + . . SET TMGCT=0 + QUIT + ; +HANDLIENHDR(PARAMS) ; + ;"Purpose: Return the Fileman records of the last record added, and highest IEN number from File + ;"Input : PARAMS -- this is FILENUM (Subfiles not supported) + ;"Output: Will return data to client. Format: + ;" LastIEN^NumIENs + ;"Results: None + SET PARAMS=$GET(PARAMS) + NEW FILENUM SET FILENUM=$PIECE(PARAMS,"^",1) + IF +FILENUM'>0 QUIT + NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + IF GREF="" QUIT + NEW NODE SET NODE=$GET(@(GREF_"0)")) + NEW LASTIEN SET LASTIEN=$PIECE(NODE,"^",3) + NEW TOTIENS SET TOTIENS=$PIECE(NODE,"^",4) + DO SEND^TMGKERN2(LASTIEN_"^"_TOTIENS) + QUIT + ; + ; Index: cprs/branches/tmg-cprs/m_files/TMGSIPH3.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH3.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH3.m (revision 896) @@ -0,0 +1,755 @@ +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 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH4.m (revision 896) @@ -0,0 +1,363 @@ +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/TMGSIPH5.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH5.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH5.m (revision 896) @@ -0,0 +1,372 @@ +TMGSIPH5 ;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 + ;"Utility functions for working with transfers on client + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"EXAMNEED(JNUM,INOUT) -- User selects records, and then this displays who needs records. + ;"SHOWNEED(JNUM,GETARRAY) -- show selected records + ;"CHCK1NEED(FILENUM,RPTR,INOUT) --show who is needing one requested record + ;"GL2FILE(CREF,FNAME) -- Return filenumber based on global reference. + ;"KILLNEED(JNUM,INOUT) --allow user to kill needed needed pointers. + ;"PREVIEW(JNUM,INOUT) --allow user view server record before downloading and installing + ;"DELREC -- Allow user to del record and remove record that it has been previously downloaded. + ;"DEL1REC(FILENUM,LPTR) -- allow deletion of given record and that it has been downloaded. + ;" + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ; + ;"======================================================================= + ; +EXAMNEED(JNUM,INOUT) ; + ;"Purpose:User selects records, and then this displays who needs 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 + SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" + NEW OPTIONS + SET OPTIONS("HEADER")="Select File(s) to EXAMINE. Press when Done." + DO ASKNEEDED^TMGSIPH3(JNUM,.GETARRAY,INOUT,.OPTIONS) + IF $DATA(GETARRAY)=0 GOTO WNDN + IF $$SHOWNEED(JNUM,.GETARRAY) ;"Ignore aborts +WNDN QUIT + ; + ; +SHOWNEED(JNUM,GETARRAY) + ;"Purpose: To show selected records + ;"Input: JNUM + ;" GETARRAY -- PASS BY REFERENCE. Array as created by ASKNEEDED^TMGSIPH4 + ;" GETARRAY(FileNum,RecordNum)="" + ;"Results: 1 if OK, -1 if abort + NEW RESULT SET RESULT=1 + NEW TMGABORT SET TMGABORT=0 + NEW FILENUM SET FILENUM=0 + NEW STIME SET STIME=$H + NEW TALLY + NEW TMGCT SET TMGCT=1 + NEW SHOWPROG SET 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) + . NEW TMGMAX SET TMGMAX=-1 + . 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 $$CHCK1NEED(FILENUM,IEN,INOUT)=-1 DO QUIT + . . . NEW % SET %=1 + . . . WRITE "ABORT" DO YN^DICN WRITE ! + . . . IF %'=2 SET TMGABORT=1 + . . IF (SHOWPROG=0),(($PIECE($H,",",2)-$PIECE(STIME,",",2))>15) 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 + DO PRESSTOCONT^TMGUSRIF + IF ($GET(TMGPTCABORT)=1)!(TMGABORT) SET RESULT=-1 + QUIT RESULT + ; + ; +CHCK1NEED(FILENUM,RPTR,INOUT) ; + ;"Purpose: To show who is needing one requested record + ;"Input: FILENUM -- The file number to compare. + ;" RPTR -- The IEN of the record that was wanted from the server. + ;" 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,INFO)="" + ;" INFO=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;" As pointers are resolved, the entries will be KILLED from the above global + ;" + ;"Results: 1 for OK, -1 for abort + ;" + NEW RESULT SET RESULT=1 + SET FILENUM=+$GET(FILENUM) QUIT:(FILENUM'>0) + NEW FNAME SET FNAME=$PIECE($GET(^DIC(FILENUM,0)),"^",1) + SET RPTR=+$GET(RPTR) + SET LPTR=+$GET(LPTR) + NEW REF SET REF="" + FOR SET REF=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,REF)) QUIT:(REF="")!(RESULT=-1) DO + . NEW INFO SET INFO="" + . FOR SET INFO=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,REF,INFO)) QUIT:(INFO="")!(RESULT=-1) DO + . . NEW PCE SET PCE=+INFO + . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4) + . . NEW QNUM SET QNUM=$QLENGTH(REF)-(IENDEPTH*2) ;"e.g. ^TIU(8925,IEN,0), or e.g. ^PS(52.11,IEN,2,IEN2,0), ^PS(52.11,IEN,2,IEN2,0,IEN3,3) + . . NEW GL SET GL=$$QSUBS^TMGSIPHU(REF,QNUM) + . . NEW FRFNAME SET FRFNAME="??" + . . NEW PFROMFIL SET PFROMFIL=$$GL2FILE(GL,.FRFNAME) + . . NEW PFROMREC SET PFROMREC=$QSUBSCRIPT(REF,QNUM+1) + . . NEW LOC SET LOC=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . . NEW FLD SET FLD=$$GETFLD^TMGSIPHU(PFROMFIL,LOC,PCE) + . . WRITE !,"Needed Record: FILE ",FILENUM," [",FNAME,"]; #",RPTR," [",$$GET01FLD^TMGSIPH3(JNUM,FILENUM,RPTR),"] ",! + . . WRITE "Needed by: FILE: ",PFROMFIL," [",FRFNAME,"]; #",PFROMREC,"; FLD: ",+FLD," [",$PIECE(FLD,"^",2),"]",! + . . NEW TOSHOW,FLD SET FLD=0 + . . FOR SET FLD=$ORDER(^DD(PFROMFIL,FLD)) QUIT:(+FLD'>0) DO + . . . NEW INFO SET INFO=$PIECE($GET(^DD(PFROMFIL,FLD,0)),"^",2) + . . . QUIT:(INFO'["P") + . . . NEW AFILE SET AFILE=+$PIECE(INFO,"P",2) QUIT:(AFILE'=2) ;"2 = PATIENT file + . . . SET TOSHOW(FLD)="" + . . IF $DATA(TOSHOW) DO + . . . WRITE "Name of patient in this record as follows:",! + . . . DO DumpRec2^TMGDEBUG(PFROMFIL,PFROMREC,0,.TOSHOW) + . . NEW % SET %=2 + . . WRITE "View current local record needing record" DO YN^DICN WRITE ! + . . IF %=-1 SET RESULT=-1 QUIT + . . IF %=1 DO + . . . DO DumpRec2^TMGDEBUG(PFROMFIL,PFROMREC) + . . . WRITE ! + . . . DO PRESSTOCONT^TMGUSRIF + . . . IF $GET(TMGPTCABORT)=1 SET RESULT=-1 + ; + QUIT RESULT + ; + ; +GL2FILE(CREF,FNAME) ; + ;"Purpose: Return filenumber based on global reference. + ;"Input: CREF -- closed reference of root of file. + ;" FNAME -- OPTIONAL. PASS BY REFERENCE. Filled with filename, if found. + ;"Results: Filenumber, or 0 if problem + NEW RESULT SET RESULT=0 + NEW NODE0 SET NODE0=$GET(@CREF@(0)) GOTO:(NODE0="") G2FDN + SET FNAME=$PIECE(NODE0,"^",1) + SET RESULT=+$PIECE(NODE0,"^",2) +G2FDN QUIT RESULT + ; + ; +KILLNEED(JNUM,INOUT) ; + ;"Purpose: To allow user to kill needed needed pointers. + ;"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 + SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" + NEW TMGABORT SET TMGABORT=0 + NEW OPTIONS + SET OPTIONS("HEADER")="Select File(s) to REMOVE NEEDED FROM. Press when Done." + DO ASKNEEDED^TMGSIPH3(JNUM,.GETARRAY,INOUT,.OPTIONS) + IF $DATA(GETARRAY)=0 GOTO WNDN + WRITE !,"NOTE: If the selected records are removed from the needed list,",! + WRITE "then all the records pointing to this needed record will be left",! + WRITE "with NULL pointers. THIS CAN NOT BE UNDONE.",! + WRITE "It is recommended that the individual records be EXAMINED",! + WRITE "to better understand the linkages before deletion.",! + WRITE "If you don't know what you are doing,then don't proceed.",!,! + NEW % SET %=1 + WRITE "EXAMINE records first" DO YN^DICN WRITE ! + IF %=-1 GOTO KNDN + IF %=1 IF $$SHOWNEED(JNUM,.GETARRAY)=-1 GOTO KNDN + SET %=2 + WRITE "PROCEED WITH DELETION FROM NEEDED LIST" DO YN^DICN WRITE ! + IF %'=1 GOTO KNDN + SET FILENUM=0 + SET STIME=$H + SET TMGCT=1,SHOWPROG=0 + FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="")!(TMGABORT=1) DO + . NEW TMGMAX SET TMGMAX=-1 + . 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 + . . DO UNNEEDPTR^TMGSIPHU(FILENUM,IEN,0,.TALLY) + . . IF (SHOWPROG=0),(($PIECE($H,",",2)-$PIECE(STIME,",",2))>15) 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 + DO PRESSTOCONT^TMGUSRIF +KNDN QUIT + ; + ; +PREVIEW(JNUM,INOUT) ; + ;"Purpose: To allow user view server record before downloading and installing + ;"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 + SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" + NEW TMGABORT SET TMGABORT=0 + NEW OPTIONS + SET OPTIONS("HEADER")="Select File(s) to PREVIEW. Press when Done." + DO ASKNEEDED^TMGSIPH3(JNUM,.GETARRAY,INOUT,.OPTIONS) + IF $DATA(GETARRAY)=0 GOTO PVDN + NEW SHOWEMPTY + NEW % SET %=2 + WRITE "Display Empty Fields" DO YN^DICN WRITE ! + IF %=-1 GOTO PVDN + SET SHOWEMPTY=(%=1) + SET FILENUM=0 + SET STIME=$H + SET TMGCT=1,SHOWPROG=0 + FOR SET FILENUM=$ORDER(GETARRAY(FILENUM)) QUIT:(FILENUM="")!(TMGABORT=1) DO + . NEW TMGMAX SET TMGMAX=-1 + . 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 + . . SET QUERY="DUMP REC|"_FILENUM_"^"_IEN_"^"_SHOWEMPTY + . . DO MSGCLIENT^TMGKERN2(JNUM,QUERY,.REPLY,.ERROR,30) + . . IF $DATA(ERROR) DO QUIT + . . . WRITE ERROR,! + . . . SET TMGABORT=1 + . . NEW TMGI SET TMGI="" + . . FOR SET TMGI=$ORDER(REPLY(TMGI)) QUIT:(TMGI="") DO + . . . WRITE REPLY(TMGI),! + . . IF (SHOWPROG=0),(($PIECE($H,",",2)-$PIECE(STIME,",",2))>15) 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 + DO PRESSTOCONT^TMGUSRIF +PVDN QUIT + ; + ; +CHKPTIN(JNUM) ; + ;"Purpose: to check for pointers in to files/records already downloaded. + ;"Input: JNUM -- The job number of the background client process + ;"Results: None + NEW TMGARRAY,TMGSEL + NEW FILENUM SET FILENUM=0 + FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM)) QUIT:(FILENUM'>0) DO + . NEW DISPSTR SET DISPSTR="Check for pointers IN to file #"_FILENUM_" (" + . SET DISPSTR=DISPSTR_$PIECE($GET(^DIC(FILENUM,0)),"^",1)_")" + . SET TMGARRAY(DISPSTR)=FILENUM + NEW HEADER SET HEADER="Select File(s) to Check for POINTERS IN. Press when Done." + DO Selector^TMGUSRIF("TMGARRAY","TMGSEL",HEADER) + ; + NEW TMGABORT SET TMGABORT=0 + NEW IDX SET IDX="" + FOR SET IDX=$ORDER(TMGSEL(IDX)) QUIT:(IDX="")!TMGABORT DO + . SET FILENUM=$GET(TMGSEL(IDX)) QUIT:FILENUM="" + . SET TMGABORT=($$CHK1PTIN(JNUM,FILENUM)'=1) + ; + WRITE ! + DO PRESSTOCONT^TMGUSRIF; + QUIT + ; + ; +CHK1PTIN(JNUM,FILENUM) ; + ;"Purpose: To cycle through all local records that have been downloaded and manuall + ;" check on server for pointers in, and que checks if needed. + ;"Input: JNUM -- The job number of the background client process + ;" FILENUM -- The file to process. + ;"Results: 1 if OK -1 if error/abort + NEW RESULT SET RESULT=1 + NEW TMGABORT SET TMGABORT=0 + NEW TMGCT SET TMGCT=999 + NEW STIME SET STIME=$H + NEW TMGMIN SET TMGMIN=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM,0)) + NEW TMGMAX SET TMGMAX=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM,""),-1) + NEW LPTR SET LPTR=0 + FOR SET LPTR=$ORDER(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)) QUIT:(+LPTR'>0)!TMGABORT DO + . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) + . NEW RPTR SET RPTR=+$GET(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)) + . QUIT:(RPTR'>0) + . DO GETPTIN^TMGSIPH4(JNUM,FILENUM,RPTR) + . SET TMGCT=TMGCT+1 + . IF TMGCT>25 DO + . . DO ProgressBar^TMGUSRIF(LPTR,"Checking pointers IN to file #"_FILENUM,TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + IF TMGABORT SET RESULT=-1 + QUIT RESULT + ; + ; +DELREC; + ;"Purpose: To allow a user to delete a record on the client, and remove record that it has + ;" been previously downloaded. This will allow it to be downloaded again. + WRITE !,"Select a downloaded record to delete from this client.",! + WRITE "NOTE: All pointer to this record will be deleted.",! + NEW X,Y,DIC,FILENUM,RESULT + SET DIC=1,DIC(0)="MAEQ" + DO ^DIC WRITE ! + IF +Y>0 DO + . SET FILENUM=+Y + . NEW % SET %=2 + . WRITE "DELETE *ALL* RECORDS IN FILE" + . DO YN^DICN WRITE ! + . IF %=1 IF $$DELALL(FILENUM) QUIT + . IF %=-1 QUIT + . SET DIC=FILENUM + . DO ^DIC WRITE ! + . IF +Y'>0 QUIT + . SET RESULT=$$DEL1REC(FILENUM,+Y) + . IF +RESULT=-1 DO + . . WRITE $PIECE(RESULT,"^",2),! + . ELSE DO + . . WRITE "Record deleted, and all pointers to record have been removed.",! + . DO PRESSTOCONT^TMGUSRIF + QUIT + ; + ; +DELALL(FILENUM) + ;"Purpose: To allow deletion of all records in file on the client, and remove the + ;" notation that it has been downloaded. + ;"Input: FILENUM -- Filenumber to delete + ;"Result: 1 = OK, -1^Message if error + SET FILENUM=$GET(FILENUM) + NEW RESULT SET RESULT=1 + NEW % SET %=2 + WRITE "Are you CERTAIN you want to delete ALL records in file ",FILENUM + DO YN^DICN WRITE ! + IF %'=1 SET RESULT="-1^USER ABORTED" GOTO DADN + NEW TMGCT SET TMGCT=0 + NEW TMGABORT SET TMGABORT=0 + NEW STIME SET STIME=$H + NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL")) + IF REF="" DO GOTO DADN + . SET RESULT="-1^INVALID FILENUM: "_FILENUM + SET REF=$$CREF^DILF(REF) + SET TMGMIN=$ORDER(@REF@(0)) + SET TMGMAX=$ORDER(@REF@("@"),-1) + NEW TMGIEN SET TMGIEN=0 + FOR SET TMGIEN=$ORDER(@REF@(TMGIEN)) QUIT:(+TMGIEN'>0)!TMGABORT DO + . SET TMGABORT=$$UserAborted^TMGUSRIF() QUIT:(TMGABORT=1) + . IF TMGCT>100 DO + . . DO ProgressBar^TMGUSRIF(TMGIEN,"Deleting local records in file "_FILENUM,TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + . SET TMGCT=TMGCT+1 + . SET RESULT=$$DEL1REC(FILENUM,TMGIEN,1) + . IF +RESULT=-1 SET TMGABORT=1 + IF 'TMGABORT DO + . KILL ^TMG("TMGSIPH","PT XLAT",FILENUM) + . KILL ^TMG("TMGSIPH","RECORDS SYNC",FILENUM) +DADN QUIT RESULT + ; + ; +DEL1REC(FILENUM,LPTR,FORCE); + ;"Purpose: To allow deletion of a record on the client, and record that it has been downloaded. + ;"Input: FILENUM -- Filenumber to delete + ;" LPTR -- Record number (IEN) on client to delete + ;" FORCE -- OPTIONAL. If 1, then will delete even if not prev downloaded + ;"Result: 1 = OK, -1^Message if error + NEW RESULT SET RESULT=1 + IF $GET(FORCE)=1 GOTO D1L1 + NEW ISDNLOAD SET ISDNLOAD=($DATA(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR))'=0) + IF 'ISDNLOAD DO GOTO D1RDONE + . SET RESULT="-1^Record doesn't seem to have been downloaded. A local record was probably used instead." +D1L1 NEW OPTION + SET OPTION(FILENUM,LPTR)=0 + DO QTMVPTR^TMGFMUT(.OPTION) + NEW DIE,DR,DA + SET DIE=FILENUM + SET DR=".01///@" + SET DA=LPTR + DO ^DIE + NEW RPTR SET RPTR=+$GET(^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR)) + KILL ^TMG("TMGSIPH","DOWNLOADED",FILENUM,LPTR) + KILL ^TMG("TMGSIPH","PT XLAT",FILENUM,RPTR) +D1RDONE QUIT RESULT + ; + ; Index: cprs/branches/tmg-cprs/m_files/TMGSIPH6.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH6.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH6.m (revision 896) @@ -0,0 +1,93 @@ +TMGSIPH6 ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;2/15/10 + ;;1.0;TMG-LIB;**1**;2/15/10 + ; + ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE + ;"Utility functions for working with transfers on client + ;"Especially working with XRefs of transferred records. + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"2/15/10 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"XRFILES -- allow user to select files to be re-cross referenced + ; + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGUSRIF,DIK + ;"======================================================================= + ; +XRFILES ; + ;"Purpose: To allow user to select files to be re-cross referenced + ;"Input: None + ;"Result: None + ;"Output: Cross-references will be KILL'ed then SET, at user's choice + NEW TMGARRAY,TMGSEL + NEW FILENUM SET FILENUM=0 + FOR SET FILENUM=$ORDER(^TMG("TMGSIPH","NEED RE-XREF",FILENUM)) QUIT:(FILENUM'>0) DO + . NEW DISPSTR SET DISPSTR="Re-index records in file #"_FILENUM_" (" + . SET DISPSTR=DISPSTR_$PIECE($GET(^DIC(FILENUM,0)),"^",1)_")" + . SET TMGARRAY(DISPSTR)=FILENUM + NEW HEADER SET HEADER="Select File(s) to REINDEX. Press when Done." + DO Selector^TMGUSRIF("TMGARRAY","TMGSEL",HEADER) + ; + NEW TMGABORT SET TMGABORT=0 + NEW IDX SET IDX="" + FOR SET IDX=$ORDER(TMGSEL(IDX)) QUIT:(IDX="")!TMGABORT DO + . SET FILENUM=$GET(TMGSEL(IDX)) QUIT:FILENUM="" + . SET TMGABORT=($$REIX1FLE(FILENUM)'=1) + ; + DO PRESSTOCONT^TMGUSRIF; + QUIT + ; + ; +REIX1FLE(FILENUM) ; + ;"Purpose: to re-index all the cross references in 1 file + ;"Input: FILENUM -- the file to reindex. + ;"Results: 1=OK, 0 if error. + ;" + ;"NOTE: There should not be a need to re-index subfiles, becaUse those + ;" IEN's are not moved / translated + NEW RESULT SET RESULT=1 ;"default success + NEW TMGCT SET TMGCT=50 + NEW STIME SET STIME=$H + NEW VAFCA08 SET VAFCA08=1 ;"Prevent execution of XRef AVAFC01 (--> endless loop) + NEW DIK,DA,CGREF + SET DIK=$GET(^DIC(FILENUM,0,"GL")) + IF DIK="" SET RESULT=0 GOTO RXF1 + NEW CGREF SET CGREF=$$CREF^DILF(DIK) + SET TMGMIN=$ORDER(@CGREF@(0)) + SET TMGMAX=$ORDER(@CGREF@("#"),-1) + NEW TMGABORT SET TMGABORT=0 + NEW TMGERR,TMGLASTE SET TMGERR=0,TMGLASTE=0 + SET DA=0 + FOR SET DA=$ORDER(@CGREF@(DA)) QUIT:(+DA'>0)!TMGABORT DO + . IF $DATA(^TMG("TMGSIPH","RE-XREF DONE",FILENUM,DA)) QUIT + . DO + . . ;"NEW $ETRAP SET $ETRAP="SET $ZTRAP=""B"" write ""$ZTRAP="",$ZTRAP,!,""Error during XRef of FILE #"",$GET(FILENUM),""; IEN="",$GET(DA),! WRITE $ZSTATUS,! SET $ETRAP="""",$ECODE="""",TMGERR=1" + . . NEW $ETRAP SET $ETRAP="DO HANDLERR^TMGSIPH6" + . . DO IX^DIK ;"Uses DIK and DA as inputs + . . SET ^TMG("TMGSIPH","RE-XREF DONE",FILENUM,DA)="" ;"<-- not done if error during IX^DIK + . SET TMGABORT=$$UserAborted^TMGUSRIF() + . SET TMGCT=TMGCT+1 + . IF TMGCT>10 DO + . . DO ProgressBar^TMGUSRIF(DA,"Re-indexing file: "_FILENUM,TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + IF (TMGABORT=0)&(TMGERR=0) KILL ^TMG("TMGSIPH","NEED RE-XREF",FILENUM) + ELSE SET RESULT=0 + WRITE ! +RXF1 QUIT RESULT + ; + ; +HANDLERR ; + SET $ZTRAP="B" + IF $GET(DA)'=$GET(TMGLASTE) DO + . WRITE !,"Error during XRef of FILE #",$GET(FILENUM),"; IEN=",$GET(DA),! + . WRITE $ZSTATUS,! + . SET TMGERR=1 + . SET TMGLASTE=DA + SET $ETRAP="",$ECODE="" + QUIT + Index: cprs/branches/tmg-cprs/m_files/TMGSIPH7.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPH7.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPH7.m (revision 896) @@ -0,0 +1,18 @@ +TMGSIPH67 ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;2/15/10 + ;;1.0;TMG-LIB;**1**;2/15/10 + ; + ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE + ;"Utility functions for working with transfers on client + ;" + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"2/15/10 + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ; + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;" + ;"======================================================================= Index: cprs/branches/tmg-cprs/m_files/TMGSIPHU.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSIPHU.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSIPHU.m (revision 896) @@ -0,0 +1,652 @@ +TMGSIPH ;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 + ;"UTILITY FUNCTIONS + ;"Kevin Toppenberg MD + ;"GNU General Public License (GPL) applies + ;"11/27/09 + ; + ;"======================================================================= + ;" API -- Public Functions. + ;"======================================================================= + ;"ORDREF(REF) -- return a $ORDER on a reference + ;"QLASTSUB(REF) -- Returns the LAST subscript of reference + ;"QSUBS(REF,ENDNUM,STARTNUM) -- Return subscripts from START to END ***NOTE ORDER OF PARAMETERS. + ;"QSETSUB(REF,POS,VALUE) -- Set the subscript in REF as position POS to be VALUE + ;"GETREF0(FILENUM) -- Returns reference to 0 node for file. + ;"GETNUMREC(FILENUM) -- Return the highest record number in given file. + ;"STOREDATA(ARRAY) -- store data from array into local globals, making backup of overwritten records + ;"IENOFARRAY(FILENUM,ARRAY,IENS) --return the IEN record number of the array. + ;"APPENDIEN(FILENUM,IENS) --return an IEN number that is +1 from the last one in the file. + ;"RLOCARRAY(FILENUM,NEWIEN,ARRAY,NARRAY) --Relocate array (change IEN) + ;"STOREDAS(FILENUM,IEN,ARRAY) -- Store data from array into local globals, making backup of + ;" overwritten records. AND ALSO translate record number to input-specified IEN + ;"GETFLD(FILENUM,LOC,PCE) -Return field number cooresponding to File number, node, and piece. + ;" + ;"======================================================================= + ;" API -- Private Functions. + ;"======================================================================= + ;"UNNEEDPTR(FILENUM,RPTR,LPTR,INOUT,TALLY) -- satisfy all the places that were wanting a remote record to be downloaded + ;"ISDIFF(ARRAY) -- determine if record stored in ARRAY is different from that stored in local ^Global + ;"RECSHOW(FILENUM,RPTR,ARRAY) -- Show remote and local data, to allow user to see differences + ;"GET01FIELD(FILENUM,ARRAY,RVALUE,LVALUE,IENS) -- Extract .01 field name from data array + ;"GETTARGETIEN(FILENUM,ARRAY,TARGETIEN) --determine if a local record should be overwritten with record from server. + ;" Ask user directly if not able to automically determine. + ;"======================================================================= + ;"Dependancies + ;"======================================================================= + ;"TMGUSRIF + ;"======================================================================= + ; +ORDREF(REF) + ;"Purpose: to return a $ORDER on a reference + ;" e.g. ^TIU(8925,"") --> returns ^TIU(8925,0) + ;" ^TIU(8925) --> returns ^TIU(8925.1) + ;"NOTE: If there is no further nodes AT THE LEVEL OF THE LAST PARAMETER, then "" is returned. + ;" e.g. A("Fruits","Citrus","Orange") + ;" A("Fruits","Citrus","Green") + ;" A("Fruits","Non-Citrus","Red","Hard") + ;" A("Fruits","Non-Citrus","Red","Soft") + ;" A("Fruits","Tropic","Yellow") + ;" A("Fruits","Tropic","Blue") + ;" In this example, $ORDREF(A("Fruits","Non-Citrus","Red","Soft")), would return "" + ;" This is difference from $QUERY, which would return A("Fruits","Tropic","Yellow") + ;"Input --REF -- reference to a global. Must be in Closed format + ;"Results: Returns new reference. + NEW RESULT,SUB + SET SUB=$ORDER(@REF) + IF SUB'="" DO + . SET RESULT=REF + . DO QSETSUB(.RESULT,$QLENGTH(REF),SUB) + ELSE SET RESULT="" + QUIT RESULT + ; + ; +QLASTSUB(REF) ; + ;"Returns the LAST subscript of reference + ;"Input: REF -- The reference to work on, e.g. ^TIU(8925,3,0) MUST be in closed form + QUIT $QSUBSCRIPT(REF,$QLENGTH(REF)) + ; + ; +QSUBS(REF,ENDNUM,STARTNUM) ;"***NOTE ORDER OF PARAMETERS. IT IS 'BACKWARDS', so STARTNUM can be optional + ;"Purpose: Return subscripts from START to END + ;"Input: REF -- The reference to work on, e.g. ^TIU(8925,3,0) MUST be in closed form + ;" ENDNUM -- The ending subscript to return. + ;" STARTNUM -- The starting subscript to return. OPTIONAL. Default is 0 + ;"Returns the reference, in closed for. + NEW I,RESULT SET RESULT="" + SET STARTNUM=+$GET(STARTNUM) + SET ENDNUM=+$GET(ENDNUM) + IF ENDNUM>$QLENGTH(REF) SET ENDNUM=$QLENGTH(REF) + FOR I=STARTNUM:1:ENDNUM DO + . NEW ONENODE SET ONENODE=$QSUBSCRIPT(REF,I) + . IF (+ONENODE'=ONENODE),(I>0) SET ONENODE=""""_ONENODE_"""" + . SET RESULT=RESULT_ONENODE + . IF I=0 SET RESULT=RESULT_"(" + . ELSE SET RESULT=RESULT_"," + SET RESULT=$$CREF^DILF(RESULT) + IF (RESULT'["("),($EXTRACT(RESULT,$LENGTH(RESULT))=",") DO + . SET RESULT=$EXTRACT(RESULT,1,$LENGTH(RESULT)-1)_")" + QUIT RESULT + ; + ; +QSETSUB(REF,POS,VALUE) ; + ;"Purpose: Set the subscript in REF as position POS to be VALUE + ;"Input: REF -- The reference to modify. PASS BY REFERENCE + ;" POS -- The position of the subscript to change. POS=1 means first subscript + ;" VALUE -- The new subscript number or name + ;"Output: REF is modified + ;"Results: none + IF (POS>$QLENGTH(REF))!(POS<1) QUIT + NEW REFA SET REFA=$$QSUBS(REF,POS-1) + SET REFA=$$OREF^DILF(REFA) + NEW REFB SET REFB=$$QSUBS(REF,999,POS+1) + IF REFB="" SET REFB=")" + ELSE SET REFB=","_REFB + IF (+VALUE'=VALUE),($EXTRACT(VALUE,1)'="""") SET VALUE=""""_VALUE_"""" + SET REF=REFA_VALUE_REFB + QUIT + ; + ; +GETREF0(FILENUM) + ;"Purpose: Returns reference to 0 node for file. + ;"Input: FILENUM -- The fileman number of the file to return info for. + ;"Result: RETURNS REF, OR "" if problem. + NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL")) + IF REF'="" SET REF=REF_"0)" + QUIT REF + ; + ; +GETNUMREC(FILENUM) + ;"Purpose: Return the highest record number in given file. + ;"Input: FILENUM -- The fileman number of the file to return info for. + ;"Results: returns number, or -1 if problem. + ;"write "Here in GETNUMRECS",! + NEW RESULT,REF,NODE + SET RESULT=-1 + SET REF=$$GETREF0(FILENUM) + IF REF'="" SET RESULT=$PIECE($GET(@REF),"^",4) + IF RESULT="" SET RESULT=-1 + QUIT RESULT + ; + ; +STOREDATA(ARRAY) + ;"Purpose: To store data from array into local globals, making backup of + ;" overwritten records + ;"Input: ARRAY -- Pass by REFERENCE. Format + ;" ARRAY(1)=ARef_"=" + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;" ... + ;"Results: none + NEW STIME SET STIME=$H + NEW TMGI SET TMGI=1 + NEW TMGCT SET TMGCT=0 + NEW SHOWPROG SET SHOWPROG=0 + NEW SHOWREF SET SHOWREF=0 + NEW REF,VALUE + FOR DO QUIT:(TMGI="") + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . IF REF="" SET TMGI="" QUIT + . SET TMGI=TMGI+1 + . SET VALUE=$GET(ARRAY(TMGI)) + . SET VALUE=$EXTRACT(VALUE,2,10000) + . IF $DATA(@REF) DO + . . MERGE ^TMG("TMGSIPH","OVERWRITTEN",REF)=@REF + . . KILL @REF + . SET @REF=VALUE + . SET TMGI=$ORDER(ARRAY(TMGI)) + . SET TMGCT=TMGCT+1 + . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds. + . . SET SHOWPROG=1 + . . SET TMGMIN=$ORDER(ARRAY(0)) + . . SET TMGMAX=$ORDER(ARRAY(""),-1) + . IF (SHOWPROG=1),(TMGCT>500) DO + . . IF (SHOWREF=0),($$HDIFF^XLFDT($H,STIME,2)>120) DO ;"Turn on showing referecences after 2 min. + . . NEW SREF SET SREF="" + . . IF SHOWREF DO + . . . SET SREF=REF QUIT:($LENGTH(REF)'>20) + . . . SET SREF=$EXTRACT(REF,1,17)_"..." + . . DO ProgressBar^TMGUSRIF(TMGI,"Storing Data: "_SREF,TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + ; + QUIT + ; + ; +IENOFARRAY(FILENUM,ARRAY,IENS) ;" + ;"Purpose: return the IEN record number of the array. + ;"Input: FILENUM -- The file number of the data passed in array. MUST MATCH + ;" ARRAY -- Pass by REFERENCE. Format + ;" ARRAY(1)=ARef_"=" <---- Expected to hold the .01 field. + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;" IENS -- OPTIONAL (needed If FILENUM is a subfile) -- A standard IENS for subfile. + ;"Result: IEN if found, or 0 if error. + ;" NOTE: Even if FILENUM is a subfile, IEN is a single number, i.e. IEN of subrecord + ;" e.g. '3' not '3,23456,' + ;" + NEW RESULT SET RESULT=0 + SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 GOTO IOADN + ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) ;"IENS not used if not subfile. + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + IF GREF="" GOTO IOADN + NEW GREFLEN SET GREFLEN=$QLENGTH(CGREF) + NEW REF SET REF=$GET(ARRAY(1)) IF (REF="") GOTO IOADN + SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) IF (REF="") GOTO IOADN + IF $$QSUBS(REF,GREFLEN)'=CGREF GOTO IOADN + SET RESULT=$QSUBSCRIPT(REF,GREFLEN+1) +IOADN QUIT RESULT + ; + ; +APPENDIEN(FILENUM,IENS) ; + ;"Purpose: to return an IEN number that is +1 from the last one in the file. + ;"Return : the new IEN, or 0 if problem + NEW RESULT SET RESULT=0 + ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) IF GREF="" GOTO AIEDN + NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) ;"IENS not used if not subfile. + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + NEW LASTIEN SET LASTIEN="%" + FOR SET LASTIEN=$ORDER(@CGREF@(LASTIEN),-1) QUIT:(LASTIEN="")!(+LASTIEN=LASTIEN) + SET RESULT=LASTIEN+1 + IF $GET(IENS)["," DO + . SET $PIECE(IENS,",",1)=RESULT + . SET RESULT=IENS +AIEDN QUIT RESULT + ; + ; +RLOCARRAY(FILENUM,NEWIEN,ARRAY,NARRAY) ;"Relocate array (change IEN) + ;"Purpose: To take array, and change IEN values to NEWIEN + ;"NOTE: It is assumed that ALL data in ARRAY represents ONE record (not multiple!) + ;" The array MAY contain cross-references data + ;"Input: FILENUM -- The file (or subfile) number of the data passed in array. MUST MATCH + ;" NEWIEN -- The IEN that the data in ARRAY should be changed to. + ;" If FILENUM is a subfile, then NEWIEN should be in standard IENS format (e.g. '7,345,') + ;" ARRAY -- Pass by REFERENCE. Format + ;" ARRAY(1)=ARef_"=" + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;" ... + ;" NARRAY -- PASS BY REFERENCE, an OUT PARAMETER. Format same as ARRAY + ;" NARRAY(1)=ARef_"=" + ;" NARRAY(2)="="_AValue + ;" ... + ;"Results: 1 if OK, -1 if error + ; + KILL NARRAY + NEW RESULT SET RESULT=-1 + NEW SHOWPROG SET SHOWPROG=0 + NEW STIME SET STIME=$H + SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 GOTO RLAD + SET NEWIEN=$GET(NEWIEN) IF +NEWIEN'>0 GOTO RLAD + NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,NEWIEN) + ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) + NEW CGREF SET CGREF=$$CREF^DILF(GREF) + IF GREF="" GOTO SDAD + ;"Check to see that the ARRAY data is referenced to same place as FILENUM + NEW GREFLEN SET GREFLEN=$QL(CGREF) + NEW REF SET REF=$GET(ARRAY(1)) IF (REF="") GOTO RLAD + SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) IF (REF="") GOTO RLAD + IF $$QSUBS(REF,GREFLEN)'=CGREF GOTO RLAD + NEW VALUE,RECNUM + NEW OLDIEN SET OLDIEN="" + NEW DONE SET DONE=0 + NEW TMGCT SET TMGCT=0 + NEW TMGI SET TMGI=0 + FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!DONE DO + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . SET TMGI=TMGI+1 + . IF REF="" SET DONE=1 QUIT + . SET REC=$QSUBSCRIPT(REF,GREFLEN+1) ;"Get IEN of ARRAY data + . IF OLDIEN="",(+REC=REC) SET OLDIEN=REC + . IF REC'=+NEWIEN DO + . . IF (+REC=REC) DO ;"Change record number in reference + . . . SET REF=GREF_+NEWIEN_","_$$QSUBS(REF,99,GREFLEN+2) + . . ELSE DO ;"Redirect XREF value. + . . . NEW PT2 SET PT2=$QSUBSCRIPT(REF,$QLENGTH(REF)) + . . . IF PT2'=OLDIEN QUIT ;"Unexpected format of xref + . . . DO QSETSUB(.REF,$QLENGTH(REF),+NEWIEN) ;"Change pointer in last position. + . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) + . SET NARRAY(TMGI-1)=REF_"=" + . SET NARRAY(TMGI)="="_VALUE + . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds. + . . SET SHOWPROG=1 + . . SET TMGMIN=$ORDER(ARRAY(0)) + . . SET TMGMAX=$ORDER(ARRAY(""),-1) + . SET TMGCT=TMGCT+1 + . IF (SHOWPROG=1),(TMGCT>500) DO + . . DO ProgressBar^TMGUSRIF(TMGI,"Shifting Data: ",TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + SET RESULT=1 +RLAD QUIT RESULT + ; + ; +STOREDAS(FILENUM,IEN,ARRAY) ;"'STORE DATA AS' + ;"Purpose: To store data from array into local globals, making backup of + ;" overwritten records. AND ALSO translate record number to input-specified IEN + ;"NOTE: It is assumed that ALL data in ARRAY represents ONE record (not multiple!) + ;" The array MAY contain cross-references data + ;"Input: FILENUM -- The file number of the data passed in array. MUST MATCH + ;" IEN -- The IEN that the data in ARRAY should be changed to. + ;" If FILENUM is a subfile, then pass a standard IENS string in IEN + ;" ARRAY -- Pass by REFERENCE. Format + ;" ARRAY(1)=ARef_"=" + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;" ... + ;"Also -- Makes use of Globally-scoped variable TMGOWSAVE. If =0, overwritten records are NOT saved + ;"Results: 1 if OK, -1 if error + ;"NOTE: Subfile support not completed yet... + NEW RESULT SET RESULT=-1 + NEW NARRAY + NEW SHOWPROG SET SHOWPROG=0 + NEW SHOWREF SET SHOWREF=0 + NEW TMGCT SET TMGCT=0 + NEW STIME SET STIME=$H + IF $$IENOFARRAY(FILENUM,.ARRAY,IEN)=+NEWIEN GOTO SDA2 + IF $$RLOCARRAY(FILENUM,NEWIEN,.ARRAY,.NARRAY)'=1 GOTO SDAD ;"Relocate array (change IEN) + KILL ARRAY MERGE ARRAY=NARRAY +SDA2 NEW TMGI SET TMGI=0 + NEW DONE SET DONE=0 + FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!DONE DO + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . SET TMGI=TMGI+1 + . IF REF="" SET DONE=1 QUIT + . NEW VALUE SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) + . ;"write REF,! + . IF $DATA(@REF) DO + . . IF +$GET(TMGOWSAVE)=0 QUIT + . . MERGE ^TMG("TMGSIPH","OVERWRITTEN",REF)=@REF + . . KILL @REF + . SET @REF=VALUE + . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds. + . . SET SHOWPROG=1 + . . SET TMGMIN=$ORDER(ARRAY(0)) + . . SET TMGMAX=$ORDER(ARRAY(""),-1) + . SET TMGCT=TMGCT+1 + . IF (SHOWPROG=1),(TMGCT>500) DO + . . IF (SHOWREF=0),($$HDIFF^XLFDT($H,STIME,2)>120) DO ;"Turn on showing referecences after 2 min. + . . NEW SREF SET SREF="" + . . IF SHOWREF DO + . . . SET SREF=REF QUIT:($LENGTH(REF)'>20) + . . . SET SREF=$EXTRACT(REF,1,17)_"..." + . . DO ProgressBar^TMGUSRIF(TMGI,"Storing Data: "_SREF,TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + SET RESULT=1 +SDAD QUIT RESULT + ; + ; +UNNEEDPTR(FILENUM,RPTR,LPTR,INOUT,TALLY) ; + ;"Purpose: To satisfy all the places that were wanting a remote record to be downloaded + ;"Input: FILENUM -- the fileman number of file (or subfile) to get from remote server + ;" If FILENUM is a subfile, then can be passed as just subfilenumber, OR + ;" in format: SubFileNum{ParentFileNum... + ;" RPTR -- The IEN of the record that was wanted from the server. + ;" If dealing with subfiles, pass in standard IENS format (e.g. '7,2345,') + ;" LPTR -- OPTIONAL. This can specify if the desired REMOTE record has been + ;" stored at a different IEN locally. + ;" If dealing with subfiles, pass in standard IENS format (e.g. '7,2345,') + ;" INOUT -- OPTIONAL -- Default is "PTOUT". Should be "PTIN" or "PTOUT" + ;" TALLY -- OPTIONAL. PASS BY REFERENCE. An array to keep progress stats. Format: + ;" TALLY("UNNEEDED RECORDS")=# + ;"NOTE: Gobal ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT") used, with format as below: + ;" ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RemotePointer,RefToNodeToBeCorrected,INFO)="" + ;" INFO=DataPiece^PointedToFile^PointedToReference^IENDepth^[V] + ;" As pointers are resolved, the entries will be KILLED from the above global + ;"Results: none + ;" + SET FILENUM=$GET(FILENUM) QUIT:(+FILENUM'>0) + IF $$ISSUBFIL^TMGFMUT2(FILENUM),FILENUM'["{" DO + . SET FILENUM=$$GETSPFN^TMGFMUT2(FILENUM) ;"convert 123.02 --> '123.02{123' + SET RPTR=$GET(RPTR) + SET LPTR=$GET(LPTR) + SET INOUT=$GET(INOUT) IF INOUT'="PTIN" SET INOUT="PTOUT" + IF INOUT="PTIN" GOTO UN2 + NEW NODE SET NODE="" + FOR SET NODE=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE)) QUIT:(NODE="") DO + . NEW INFO SET INFO="" + . FOR SET INFO=$ORDER(^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE,INFO)) QUIT:(INFO="") DO + . . NEW PCE SET PCE=+INFO + . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2) + . . IF LPTR'=RPTR DO + . . . IF $PIECE(INFO,"^",5)="V" SET LPTR=LPTR_";"_$PIECE(INFO,"^",3) ;"VPTR stored as 'IEN;OREF' + . . . SET $PIECE(@NODE,"^",PCE)=LPTR + . . IF 0=1 DO ;"Build up map array to store history of connections. DON'T USE..... + . . . IF P2FILE=2 DO ;"2=PATIENT file. + . . . . SET ^TMG("TMGSIPH","MAP IN","F"_2,"F"_FILENUM,LPTR)="" + . . . . SET ^TMG("TMGSIPH","MAP IN","XREF",FILENUM)=$NAME(^TMG("TMGSIPH","MAP IN","F"_2,"F"_FILENUM)) + . . . IF $DATA(^TMG("TMGSIPH","MAP IN","XREF","F"_P2FILE)) DO + . . . . NEW REF SET REF=$GET(^TMG("TMGSIPH","MAP IN","XREF","F"_P2FILE)) + . . . . QUIT:(REF="")!($QLENGTH(REF)>15) + . . . . SET @REF@("F"_FILENUM,LPTR)="" + . . . . SET ^TMG("TMGSIPH","MAP IN","XREF","F"_FILENUM)=$NAME(@REF@("F"_FILENUM)) + . . KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM,RPTR,NODE,INFO) + . . SET TALLY("UNNEEDED RECORDS")=+$GET(TALLY("UNNEEDED RECORDS"))+1 +UN2 KILL ^TMG("TMGSIPH","NEEDED RECORDS",INOUT,FILENUM,RPTR) ;"TEMP + ; + QUIT + ; + ; +ISDIFF(ARRAY) ; + ;"Purpose:to determine if record stored in ARRAY is different from that stored in local ^Global + ;"Input: ARRAY -- Pass by REFERENCE. This is actual remote record from server. Format: + ;" ARRAY(1)=ARef_"=" + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;"Result: 0 -- no difference + ;" 1 -- ARRAY has extra information + ;" 2 -- ARRAY has conflicting information + ; + NEW RESULT SET RESULT=0 + NEW TMGI SET TMGI=0 + NEW STIME SET STIME=$H + NEW SHOWPROG SET SHOWPROG=0 + NEW TMGMAX,TMGMIN + NEW TMGCT SET TMGCT=0 + NEW REF,VALUE + FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(RESULT=2) DO + . IF (SHOWPROG=0),($$HDIFF^XLFDT($H,STIME,2)>15) DO ;"Turn on progress bar after 15 seconds. + . . SET SHOWPROG=1 + . . SET TMGMIN=$ORDER(ARRAY(0)) + . . SET TMGMAX=$ORDER(ARRAY(""),-1) + . IF (SHOWPROG=1),(TMGCT>500) DO + . . DO ProgressBar^TMGUSRIF(TMGI,"Comparing server data to local ",TMGMIN,TMGMAX,70,STIME) + . . SET TMGCT=0 + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . SET TMGI=TMGI+1 + . SET TMGCT=TMGCT+1 + . IF REF="" SET RESULT=2 QUIT + . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) + . IF $DATA(@REF)=0 SET RESULT=1 ;"ARRAY has extra info + . IF $GET(@REF)=VALUE QUIT + . SET RESULT=2 ;"ARRAY conflicts with local value. + QUIT RESULT + ; + ; +GETFLD(FILENUM,LOC,PCE) + ;"Purpose: Return field number cooresponding to File number, node, and piece. + ;"Input: FILENUM -- Fileman file number to work with. + ;" LOC -- the subscript location + ;" PCE -- the piece for the field in question + ;"Results: field number^field name, or 0 if not found + NEW RESULT SET RESULT=0 + NEW FOUND SET FOUND=0 + NEW FLD SET FLD=0 + FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(FOUND=1) DO + . NEW INFO SET INFO=$PIECE($GET(^DD(FILENUM,FLD,0)),"^",4) + . IF $PIECE(INFO,";",1)'=LOC QUIT + . IF $PIECE(INFO,";",2)'=PCE QUIT + . SET FOUND=1 + . SET RESULT=FLD_"^"_$PIECE($GET(^DD(FILENUM,FLD,0)),"^",1) + QUIT RESULT + ; + ; +RECSHOW(FILENUM,RPTR,ARRAY) ; + ;"Purpose: to show remote and local data, to allow user to see differences + ;"Input: FILENUM -- Fileman file (or subfile) number to work with. + ;" RPTR -- The record number (IEN) on the server of the record downloaded. + ;" If FILENUM is a subfile, then pass RPTR in standard IENS format (e.g. '4,6787,') + ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server. + ;" Format as per OVERWRITE + ;" + WRITE "NOTE: ONLY DIFFERENCE WILL BE SHOWN",!,! + WRITE "LEGEND: REFERENCE",! + WRITE " L -- Local data value",! + WRITE " R -- Remote data value",!! + NEW LINECT SET LINECT=6 + NEW TMGI SET TMGI=0 + SET IOSL=$GET(IOSL,24) + ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) QUIT:(GREF="") + NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,RPTR) QUIT:(GREF="") + NEW SL SET SL=$QLENGTH($$CREF^DILF(GREF)) + NEW REF,VALUE,LVALUE + NEW DONE SET DONE=0 + FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(DONE=1) DO + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . SET TMGI=TMGI+1 + . IF REF="" SET DONE=1 QUIT + . SET VALUE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) + . SET LVALUE=$GET(@REF) + . IF LVALUE=VALUE QUIT + . ;"Later, I will format raw nodes into readable fileman fields and values... + . IF $QLENGTH(REF)=(SL+2) DO + . . NEW LOC SET LOC=$QSUBSCRIPT(REF,SL+2) + . . NEW PCE,FLD + . . FOR PCE=1:1:$LENGTH(VALUE,"^") DO + . . . NEW V1,LV1,EV1,ELV1,INFO + . . . SET (EV1,V1)=$PIECE(VALUE,"^",PCE) + . . . SET (ELV1,LV1)=$PIECE(LVALUE,"^",PCE) + . . . IF V1=LV1 QUIT + . . . SET FLD=$$GETFLD(FILENUM,LOC,PCE) + . . . IF +FLD=0 WRITE "?? FIELD",! QUIT + . . . IF $DATA(^DD(FILENUM,+FLD,2))#10=1 DO + . . . . NEW XFRM SET XFRM=$GET(^DD(FILENUM,+FLD,2)) + . . . . IF XFRM="" QUIT + . . . . NEW Y + . . . . SET Y=V1 XECUTE XFRM SET EV1=Y + . . . . SET Y=LV1 XECUTE XFRM SET ELV1=Y + . . . WRITE "Field -- ",$PIECE(FLD,"^",2)," (",+FLD,"):",! + . . . WRITE " L = ",ELV1,! + . . . WRITE " R = ",EV1,! + . . . SET LINECT=LINECT+3 + . . . IF LINECT>(IOSL-5) DO + . . . . DO PressToCont^TMGUSRIF + . . . . SET LINECT=0 + . ELSE DO + . . WRITE REF,! + . . WRITE " L = ",$GET(@REF),! + . . WRITE " R = ",VALUE,! + . . SET LINECT=LINECT+3 + . . IF LINECT>(IOSL-5) DO + . . . DO PressToCont^TMGUSRIF + . . . SET LINECT=0 + ; + IF LINECT>0 DO PressToCont^TMGUSRIF + QUIT + ; + ; +GET01FIELD(FILENUM,ARRAY,RVALUE,LVALUE,IENS) ; + ;"Purpose: Extract .01 field name from data array + ;"Input: FILENUM -- Fileman file (of subfile) number to work with. + ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server. + ;" Format as per OVERWRITE + ;" RVALUE -- Pass by REFERENCE. An OUT PARAMETER. Filled with .01 field from server + ;" LVALUE -- Pass by REFERENCE. An OUT PARAMETER Filled with .01 field from local database + ;" IENS -- OPTIONAL. Only needed if FILENUM is a subfile. + ;"Results: none + ;"Output: RVALUE and LVALUE are filled with the INTERNAL values of the .01 field, or "" if null + ;" + SET (RVALUE,LVALUE)="" + ;"NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL")) QUIT:(GREF="") + NEW GREF SET GREF=$$GETGREF^TMGFMUT2(FILENUM,.IENS) QUIT:(GREF="") + NEW SL SET SL=$QLENGTH($$CREF^DILF(GREF)) + NEW REF,RNODE,LNODE + NEW DONE SET DONE=0 + NEW TMGI SET TMGI=0 + FOR SET TMGI=$ORDER(ARRAY(TMGI)) QUIT:(TMGI="")!(DONE=1) DO + . SET REF=$GET(ARRAY(TMGI)) + . SET REF=$EXTRACT(REF,1,$LENGTH(REF)-1) + . SET TMGI=TMGI+1 + . IF REF="" SET DONE=1 QUIT + . SET RNODE=$EXTRACT($GET(ARRAY(TMGI)),2,10000) + . SET LNODE=$GET(@REF) + . ;"Later, I will format raw nodes into readable fileman fields and values... + . IF $QLENGTH(REF)=(SL+2) DO + . . NEW LOC SET LOC=$QSUBSCRIPT(REF,SL+2) + . . IF LOC'=0 QUIT + . . SET RVALUE=$PIECE(RNODE,"^",1) + . . SET LVALUE=$PIECE(LNODE,"^",1) + . . SET DONE=1 + ; + QUIT + ; + ; +GETTARGETIEN(FILENUM,ARRAY,TARGETIEN) ; + ;"Purpose: To determine if a local record should be overwritten with record from server. + ;" Ask user directly if not able to automically determine. + ;"Input: FILENUM -- Fileman file (or subfile) number to work with. + ;" ARRAY -- Pass by REFERENCE. This is actual remote record from server. Format: + ;" ARRAY(1)=ARef_"=" + ;" ARRAY(2)="="_AValue + ;" ARRAY(3)=ARef_"=" + ;" ARRAY(4)="="_AValue + ;" NOTE: IEN of array doesn't match input TARGETIEN, then IEN of array will be changed to it. + ;" TARGETIEN -- Required. PASS BY REFERENCE. an IN & OUT PARAMETER. + ;" If FILENUM is a subfile, then pass TARGETIEN in standard IENS format. + ;" INPUT: The initially planned location for storing the array + ;" OUTPUT: This is the pointer of where the record should be stored locally + ;"Result: "OVERWRITE" = OVERWRITE record currently stored at TARGETIEN + ;" "ABORT" = User abort or error occurred. + ;" "USELOCAL" = Dump server data, and just use record already at TARGETIEN + ;"TARGETIEN pointer may be changed to new target record location. + NEW Y,NARRAY,% + NEW R01VALUE,L01VALUE + NEW RESULT SET RESULT="OVERWRITE" ;"default to overwriting + SET TARGETIEN=$GET(TARGETIEN) + IF +TARGETIEN'>0 DO GOTO OVWDN + . SET RESULT="ABORT" + SET FILENUM=+$GET(FILENUM) + NEW RPTR SET RPTR=+$$IENOFARRAY(FILENUM,.ARRAY,TARGETIEN) + IF TARGETIEN["," DO ;"i.e. is an IENS + . NEW TEMP SET TEMP=TARGETIEN + . SET $PIECE(TEMP,",",1)=RPTR + . SET RPTR=TEMP ;"convert RPTR into an IENS + IF +RPTR'>0 DO GOTO OVWDN + . SET RESULT="ABORT" + IF $GET(^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR))="" DO + . DO GET01FIELD(FILENUM,.ARRAY,.R01VALUE,,RPTR) ;"Extract .01 field name from data array, before relocated + . SET ^TMG("TMGSIPH",".01 VALUE",FILENUM,RPTR)=R01VALUE ;"Needed elsewhere for faster processing of future records. + IF TARGETIEN'=RPTR DO GOTO:(RESULT="ABORT") OVWDN + . NEW TEMP SET TEMP=$$RLOCARRAY(FILENUM,TARGETIEN,.ARRAY,.NARRAY) ;"Relocate array (change IEN) + . IF TEMP=-1 SET RESULT="ABORT" QUIT + . KILL ARRAY + . MERGE ARRAY=NARRAY + NEW DIFF SET DIFF=$$ISDIFF(.ARRAY) ;" 0=no diff, 1=ARRAY has extra info, 2=ARRAY has conflicting info + IF DIFF=0 SET RESULT="USELOCAL" GOTO OVWDN + IF DIFF=1 SET RESULT="OVERWRITE" GOTO OVWDN + ; + DO GET01FIELD(FILENUM,.ARRAY,.R01VALUE,.L01VALUE,RPTR) ; + IF R01VALUE'=L01VALUE DO GOTO OVWDN ;"If .01 values are different, so move TARGETIEN to new location + . SET TARGETIEN=$$APPENDIEN(FILENUM,RPTR) ;"RPTR not used unless dealing with subfile. + . SET RESULT=$SELECT((TARGETIEN>0):"OVERWRITE",1:"ABORT") + ; + IF $GET(^DD(FILENUM,.01,0))["DINUM" SET RESULT="OVERWRITE" GOTO OVWDN ;"translation of pointer not allowed + NEW MENU,USRSLCT + SET USRSLCT=$GET(^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)) + IF USRSLCT'="" GOTO OW3 + ; +OW2 WRITE # + NEW FNAME SET FNAME=$$FILENAME^TMGFMUT2(FILENUM) + KILL MENU + set MENU(0)="<> OVERWRITE LOCAL DATA IN FILE ["_FNAME_"] ?" + set MENU(1)="VIEW local and remote raw data"_$char(9)_"View" + set MENU(2)="OVERWRITE local data."_$char(9)_"Overwrite1" + set MENU(3)="Store record in NEW location."_$char(9)_"ChangeIEN" + set MENU(4)="Use LOCAL data, not remote data from server."_$char(9)_"UseLocal" + set MENU(5)="FIND a local record to use instead."_$char(9)_"FindLocal" + set MENU(6)="Abort"_$char(9)_"Abort" + ; + WRITE "File = ",FNAME,"; Record .01 field = "_R01VALUE,! + SET USRSLCT=$$Menu^TMGUSRIF(.MENU,"") + IF USRSLCT="^" SET USRSLCT="Abort" + IF USRSLCT=0 set USRSLCT="" + IF USRSLCT="FindLocal" DO GOTO:(+Y>0) OVWDN + . NEW X,DIC + . IF $$ISSUBFIL^TMGFMUT2(FILENUM) DO + . . SET DIC=$$GETGREF^TMGFMUT2(FILENUM,TARGETIEN) + . ELSE SET DIC=FILENUM + . SET DIC(0)="MAEQ" + . DO ^DIC WRITE ! + . IF +Y'>0 QUIT + . SET RESULT="OVERWRITE" + . SET $PIECE(TARGETIEN,",",1)=+Y + IF USRSLCT="Abort" SET RESULT="ABORT" GOTO OVWDN + IF USRSLCT="View" DO RECSHOW(FILENUM,RPTR,.ARRAY) GOTO OW2 + SET %=2 + WRITE "ALWAYS do this for file ["_FNAME_"]" + DO YN^DICN WRITE ! + IF %=-1 SET RESULT="ABORT" GOTO OVWDN + IF %=2 SET ^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)="" + ELSE SET ^TMG("TMGSIPH","CONFLICT HANDL",FILENUM)=USRSLCT +OW3 IF USRSLCT="Overwrite1" DO GOTO OVWDN + . SET RESULT="OVERWRITE" + IF USRSLCT="ChangeIEN" DO GOTO OVWDN + . SET TARGETIEN=$$APPENDIEN(FILENUM,RPTR) ;"RPTR not used unless dealing with subfile. + . SET RESULT=$SELECT((TARGETIEN>0):"OVERWRITE",1:"ABORT") + IF USRSLCT="UseLocal" DO GOTO OVWDN + . SET RESULT="USELOCAL" + GOTO OW2 + ; +OVWDN QUIT RESULT + ; Index: cprs/branches/tmg-cprs/m_files/TMGSTUTL.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGSTUTL.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGSTUTL.m (revision 896) @@ -0,0 +1,1737 @@ +TMGSTUTL ;TMG/kst/String Utilities and Library ;03/25/06,5/10/10 ; 5/19/10 5:01pm + ;;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 to double quotes (" --> "") + ;"$$QTPROTECT(S) -- Same as $$QtProtect(s) + ;"$$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) ;"SAAC compliant entry point + quit $$QtProtect(.S) +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,Restrict) + ;"Purpose: Provide a SAAC compliant (all upper case) entry point) for MatchXtract + quit $$MatchXtract(.s,.DivCh,.Group,.Map,.Restrict) + ; +MatchXtract(s,DivCh,Group,Map,Restrict) + ;"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. + ;" Restrict -- OPTIONAL. A string of allowed opening encapsulators (allows others to be ignored) + ;" e.g. "{(|" <-- will cause "<>#[]" to be ignored + ;"Results: Returns extracted string. + if $data(Map)=0 do MapMatch(s,.Map,.Restrict) + 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,Restrict) + ;"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 + ;" Restrict -- OPTIONAL. A string of allowed opening encapsulators (allows others to be ignored) + ;" e.g. "{(|" <-- will cause "<>#[]" to be ignored + ;"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 + set Restrict=$get(Restrict,"({|<#""") + new Match,Depth,i,Group + if Restrict["(" set Match("(")=")" + if Restrict["{" set Match("{")="}" + if Restrict["|" set Match("|")="|" + if Restrict["<" set Match("<")=">" + if Restrict["#" set Match("#")="#" + if Restrict["""" 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/TMGTICK2.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTICK2.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGTICK2.m (revision 896) @@ -0,0 +1,358 @@ +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 + if $data(SelArray)=0 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 =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGTICKL.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGTICKL.m (revision 896) @@ -0,0 +1,581 @@ +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) + ;"RescheduleTask -- 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 RescheduleTask + + 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 + set ZTREQ="@" ;"delete completed task. + 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 isHTML set isHTML=$$IsHTML^TMGSTUTL(DocIEN) + 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) + . . if isHTML set DateStr=$$TrimTags^TMGSTUTL(DateStr) + . . set DateStr=$$TRIM^XLFSTR(DateStr) + . . ;"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) + . . new %DT,X,Y + . . set X=DateStr,%DT="TF" ;"assume future dates, and time is allowed. + . . do ^%DT ;"returns Y=-1, or Y=fileman date format. + . . if Y>-1 do + . . . do DD^%DT + . . . set DateStr=Y ;"This should be a standardized date. + + 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 + + +RescheduleTask + ;"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 + + +CHECKRUN + ;"Purpose: To check that the background processor for the Tickler is running. + ;" If not running, give user a chance to start it. + ;"Input: None + ;"Results: None. + + do KillOldTasks + new Status +CR1 set Status=$$TaskStatus(0) + if +Status=1 do goto CRDN + . write !,"SUCCESS! The TICKLER MESSAGES task is running.",! + . write "Details:",! + . write " Task#: ",$piece(Status,"^",3),! + . write " Scheduled to run next: ",$$HTE^XLFDT($piece(Status,"^",4)),! + . do PressToCont^TMGUSRIF + write "There is a problem. Task is NOT running.",! + new prob set prob=$piece(Status,"^",2) + if prob'="" write "Problem: ",prob,! + new % set %=1 + write "Try to launch task now" DO YN^DICN write ! + if %=1 do goto CR1 + . do RescheduleTask + +CRDN quit + +TaskStatus(Verbose) + ;"Purpose: To determine the status of the Tickler background task. + ;"Input: Verbose : OPTIONAL. If 1 then output shown. 0 (default) is quiet. + ;"Output: 1^Active^TaskNumber^NextRun($H), or -1^Message + + new ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU + new ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK + + set ZTDESC="TMG TICKLER MESSAGES HANDLER" + set ZTIO="" + + set Verbose=+$get(Verbose) + new Result set Result="-1^No Task Found" ;"default to error + new NextRun set NextRun="" + + if $$TM^%ZTLOAD=0 do goto TSDone + . set Result="-1^Taskman not running on current volume set" + + new TMGLIST,TSK + do DESC^%ZTLOAD(ZTDESC,"TMGLIST") + new done set done=0 + set TSK=0 + for set TSK=$ORDER(TMGLIST(TSK)) quit:(TSK="")!done do + . new ZTSK set ZTSK=TSK + . do ISQED^%ZTLOAD + . if Verbose write "Task ",ZTSK,": " + . set ZTSK(0)=$GET(ZTSK(0)) + . if ZTSK(0)=1 if Verbose write "Pending/Waiting",! + . else if ZTSK(0)=0 do + . . if Verbose write "Done",! ;"Not Pending/Waiting",! + . else if ZTSK(0)="" do + . . if Verbose write "Lookup error.",! + . if $data(ZTSK("E")) do + . . if 'Verbose quit + . . if $GET(ZTSK("E"))="IT" write " The task number was not valid (0, negative, or non numeric).",! quit + . . if $GET(ZTSK("E"))="I" write " The task does not exist on the specified volume set.",! quit + . . if $GET(ZTSK("E"))="IS" write " The task set is not listed in the VOLUME SET file (#14.5).",! quit + . . if $GET(ZTSK("E"))="LS" write " The link to that volume set is not available.",! quit + . . if $GET(ZTSK("E"))="U" write " An unexpected error arose (e.g., disk full, protection, etc.).",! + . if $data(ZTSK("D")) do + . . set NextRun=$get(ZTSK("D")) + . . if 'Verbose quit + . . write " Task scheduled to start: ",$$HTE^XLFDT($GET(ZTSK("D"))),! + . kill ZTSK set ZTSK=TSK + . do STAT^%ZTLOAD + . if ZTSK(0)=0 do quit + . . if 'Verbose quit + . . write "?? task undefined??" + . set ZTSK(1)=$get(ZTSK(1)) + . if Verbose write " Status: ",ZTSK(1)," ",ZTSK(2),! + . if (ZTSK(1)=1)&(ZTSK(2)="Active: Pending") do quit + . . set done=1 + . . set Result="1^Active^"_TSK_"^"_NextRun + . +TSDone quit Result + + +KillOldTasks + ;"Purpose: To clear out old, completed tasks + ;"Input: none + ;"Output: + + new ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU + new ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK + new TMGLIST,TSK + set ZTDESC="TMG TICKLER MESSAGES HANDLER" + do DESC^%ZTLOAD(ZTDESC,"TMGLIST") + set TSK=0 + for set TSK=$ORDER(TMGLIST(TSK)) quit:(TSK="") do + . new ZTSK set ZTSK=TSK + . do ISQED^%ZTLOAD + . set ZTSK(0)=$GET(ZTSK(0)) + . if $data(ZTSK("E")) do quit + . . write "Task ",ZTSK,": ",$GET(ZTSK("E")),! + . if ZTSK(0)="" write "Lookup error for task: ",TSK,! quit + . if ZTSK(0)'=0 quit + . kill ZTSK set ZTSK=TSK + . do STAT^%ZTLOAD + . if ZTSK(0)=0 write "Task ",ZTSK,": ?? task undefined??" quit + . if ($GET(ZTSK(1))=3)&($GET(ZTSK(2))="Inactive: Finished") do + . . do KILL^%ZTLOAD + 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/TMGUSRIF.m =================================================================== --- cprs/branches/tmg-cprs/m_files/TMGUSRIF.m (revision 896) +++ cprs/branches/tmg-cprs/m_files/TMGUSRIF.m (revision 896) @@ -0,0 +1,1387 @@ +TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06, 5/28/10 + ;;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 + ;"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) + ;"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 + ;" 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) + new tmgZB + 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') + set tmgZB=$ZB + ;"write " $l(tmgZB)=",$l(tmgZB)," tmgZB=" f i=1:1:$l(tmgZB) w $ascii($E(tmgZB,i)),"," + 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",tmgZB)) + . if EscKey="" do + . . do FixEscTable + . . set EscKey=$get(^XUTL("XGKB",tmgZB)) + . 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 + +FixEscTable + ;"Purpose: There is a difference between my old system and the new. I + ;" don't know why, but this will fix it for me, and anyone else. +T1 ;;$C(1))="^A" + ;;$C(2))="^B" + ;;$C(3))="^C" + ;;$C(4))="^D" + ;;$C(5))="^E" + ;;$C(6))="^F" + ;;$C(7))="^G" + ;;$C(8))="^H" + ;;$C(9))="TAB" + ;;$C(10))="^J" + ;;$C(11))="^K" + ;;$C(12))="^L" + ;;$C(13))="CR" + ;;$C(14))="^N" + ;;$C(15))="^O" + ;;$C(16))="^P" + ;;$C(17))="^Q" + ;;$C(18))="^R" + ;;$C(19))="^S" + ;;$C(20))="^T" + ;;$C(21))="^U" + ;;$C(22))="^V" + ;;$C(23))="^W" + ;;$C(24))="^X" + ;;$C(25))="^Y" + ;;$C(26))="^Z" + ;;$C(27)_"OM")="KPENTER" + ;;$C(27)_"OP")="PF1" + ;;$C(27)_"OQ")="PF2" + ;;$C(27)_"OR")="PF3" + ;;$C(27)_"OS")="PF4" + ;;$C(27)_"Ol")="KP+" + ;;$C(27)_"Om")="KP-" + ;;$C(27)_"On")="KP." + ;;$C(27)_"Op")="KP0" + ;;$C(27)_"Oq")="KP1" + ;;$C(27)_"Or")="KP2" + ;;$C(27)_"Os")="KP3" + ;;$C(27)_"Ot")="KP4" + ;;$C(27)_"Ou")="KP5" + ;;$C(27)_"Ov")="KP6" + ;;$C(27)_"Ow")="KP7" + ;;$C(27)_"Ox")="KP8" + ;;$C(27)_"Oy")="KP9" + ;;$C(27)_"[15~")="F5" + ;;$C(27)_"[17~")="F6" + ;;$C(27)_"[18~")="F7" + ;;$C(27)_"[19~")="F8" + ;;$C(27)_"[1~")="FIND" + ;;$C(27)_"[20~")="F9" + ;;$C(27)_"[21~")="F10" + ;;$C(27)_"[23~")="F11" + ;;$C(27)_"[24~")="F12" + ;;$C(27)_"[25~")="F13" + ;;$C(27)_"[26~")="F14" + ;;$C(27)_"[28~")="HELP" + ;;$C(27)_"[29~")="DO" + ;;$C(27)_"[2~")="INSERT" + ;;$C(27)_"[31~")="F17" + ;;$C(27)_"[32~")="F18" + ;;$C(27)_"[33~")="F19" + ;;$C(27)_"[34~")="F20" + ;;$C(27)_"[3~")="REMOVE" + ;;$C(27)_"[4~")="SELECT" + ;;$C(27)_"[5~")="PREV" + ;;$C(27)_"[6~")="NEXT" + ;;$C(27)_"[A")="UP" + ;;$C(27)_"[B")="DOWN" + ;;$C(27)_"[C")="RIGHT" + ;;$C(27)_"[D")="LEFT" + ;;$C(28))="^\" + ;;$C(29))="^]" + ;;$C(30))="^6" + ;;$C(31))="^_" + ;;#DONE# + ; + new i,s + for i=0:1 do quit:(s["#DONE#") + . set s=$TEXT(T1+i^TMGUSRIF) + . quit:(s["#DONE#") + . set s=$piece(s,";;",2) + . new x set x="s ^XUTL(""XGKB"","_s + . write x,! + . xecute x + quit + +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 $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)