214 lines
6.5 KiB
Mathematica
214 lines
6.5 KiB
Mathematica
|
ZIBRNSPC ; IHS/ADC/GTH - NAMESPACE PREVIOUSLY WRITTEN ROUTINES ; [ 10/29/2002 7:42 AM ]
|
||
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
||
|
|
; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
|
||
|
|
;
|
||
|
|
INIT ;
|
||
|
|
KILL (%)
|
||
|
|
D ^XBKVAR
|
||
|
|
S DTIME=300
|
||
|
|
KILL %,DISYS,%H,X,^UTILITY($J),^TMP("ZIBRNSPC",$J)
|
||
|
|
S IOP=$I
|
||
|
|
D ^%ZIS
|
||
|
|
START ;
|
||
|
|
W "Routine Namespace Converter",!
|
||
|
|
S ZIBRQUIT=0
|
||
|
|
D SETUP
|
||
|
|
G:ZIBRQUIT EXIT
|
||
|
|
;S ZIBRRTN="";IHS/SET/GTH XB*3*9 10/29/2002
|
||
|
|
S ZIBRRTN=0 ;IHS/SET/GTH XB*3*9 10/29/2002
|
||
|
|
F ZIBRQ=0:0 S ZIBRRTN=$O(^UTILITY($J,ZIBRRTN)) Q:ZIBRRTN="" W !!,"-- ",ZIBRRTN," --",!! D RLOAD,RFIX,RSAVE,RNDX
|
||
|
|
EXIT ;
|
||
|
|
W !!,"Done.",!
|
||
|
|
KILL ^UTILITY($J),^TMP("ZIBRNSPC",$J),DUOUT,DTOUT,IOP
|
||
|
|
KILL ZIBRANS,ZIBRCAND,ZIBRCH,ZIBRCMDT,ZIBRCPOS,ZIBRDEV,ZIBRFLI,ZIBRI,ZIBRJ,ZIBRL,ZIBRLINE,ZIBROBJ,ZIBROUTP,ZIBRPART,ZIBRPLEV,ZIBRPN,ZIBRPRFX,ZIBRQ,ZIBRQUIT,ZIBRRTN,ZIBRT,ZIBRV,ZIBRW,ZIBRXC
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
SETUP ; INITIALIZE UTILITY
|
||
|
|
F ZIBRT="EXC","PEXC" F ZIBRI=0:1 S ZIBRL=$T(@ZIBRT+ZIBRI),ZIBRL=$P(ZIBRL,";;",2,255) Q:ZIBRL="" F ZIBRJ=1:1 S ZIBRW=$P(ZIBRL,"^",ZIBRJ) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,ZIBRT,ZIBRW)=""
|
||
|
|
PLOOP ;
|
||
|
|
R "Package prefix (1-5 characters): ",ZIBRPRFX:DTIME
|
||
|
|
S:'$T ZIBRPRFX="^"
|
||
|
|
I "^"'[ZIBRPRFX I $L(ZIBRPRFX)>5!(ZIBRPRFX'?1.5U) W *7," -- Invalid prefix",! G PLOOP
|
||
|
|
W !
|
||
|
|
I "^"[ZIBRPRFX S ZIBRQUIT=1 Q
|
||
|
|
W !,"Enter any variables to be treated as external references --",!,"not to be namespaced -- in the form NAME1,NAME2,...",!
|
||
|
|
F ZIBRQ=0:0 R " Externals: ",ZIBRL:DTIME,! S:'$T ZIBRL="^" Q:"^"[ZIBRL D:ZIBRL["?" SHEXT I ZIBRL]"" F ZIBRI=1:1 S ZIBRW=$P(ZIBRL,",",ZIBRI) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)="" W " ",ZIBRW,!
|
||
|
|
I ZIBRL["^" S ZIBRQUIT=1 Q
|
||
|
|
X ^%ZOSF("RSEL")
|
||
|
|
I $O(^UTILITY($J,""))="" S ZIBRQUIT=1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
SHEXT ;
|
||
|
|
W !?2,"Currently defined externals:",!
|
||
|
|
S ZIBRW=""
|
||
|
|
F ZIBRQ=0:0 S W=$O(^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)) Q:ZIBRW="" W ?3,ZIBRW,!
|
||
|
|
W !
|
||
|
|
S ZIBRL=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
EXC ;;X^Y^DIE^DIC^DT^U^DUZ^DTIME^ZTSK^ZTDESC^ZTSAVE^ZTLOAD^ZTRTN^ZTIO^ZTDTH
|
||
|
|
;;
|
||
|
|
PEXC ;;IO^D^XB^Z
|
||
|
|
;;
|
||
|
|
;
|
||
|
|
RLOAD ; LOAD ROUTINE INTO GLOBAL
|
||
|
|
W "Beginning routine load ... "
|
||
|
|
KILL ^TMP("ZIBRNSPC",$J,"T"),^("K")
|
||
|
|
S ZIBRXC=$E($T(RLOADX),10,255)
|
||
|
|
X ZIBRXC
|
||
|
|
W " completed.",!
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
RLOADX ;;S ^TMP("ZIBRNSPC",$J,"T",0)=ZIBRRTN ZL @ZIBRRTN F ZIBRI=1:1 S ZIBRL=$T(+ZIBRI) Q:ZIBRL="" S ^(ZIBRI)=ZIBRL
|
||
|
|
;
|
||
|
|
RSAVE ; SAVE GLOBAL TEXT AS ROUTINE
|
||
|
|
W "Beginning routine save ... "
|
||
|
|
S ZIBRXC=$P($T(RSAVEX),"RSAVEX ",2)
|
||
|
|
X ZIBRXC
|
||
|
|
W " completed.",!
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
; S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) X "ZR X ""F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)"" ZS @ZIBRRTN" ; IHS/SET/GTH XB*3*9 10/29/2002
|
||
|
|
RSAVEX S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) ZR X "F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)" ZS @ZIBRRTN
|
||
|
|
;
|
||
|
|
RNDX ; PRINT INDEX OF ROUTINE CONVERSION
|
||
|
|
KILL %ZIS,IOP
|
||
|
|
S %ZIS("A")="Enter device for auxiliary listing of variable changes",%ZIS("B")=""
|
||
|
|
D ^%ZIS
|
||
|
|
S ZIBRDEV=$S($D(DTOUT)!$D(DUOUT):"^",IO=IO(0):0,1:IO)
|
||
|
|
Q:ZIBRDEV["^"
|
||
|
|
D RNDXP
|
||
|
|
I ZIBRDEV U ZIBRDEV D RNDXP D ^%ZISC
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
RNDXP ;
|
||
|
|
S ZIBRV=" "
|
||
|
|
F ZIBRI=0:1 S:ZIBRI=4 ZIBRI=0 W:ZIBRI=0 ! S ZIBRV=$O(^TMP("ZIBRNSPC",$J,"V",ZIBRV)) Q:ZIBRV="" W ?(19*ZIBRI),$J(ZIBRV,8),">",^(ZIBRV)
|
||
|
|
W !
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
RFIX ; FIX ROUTINE LINES STORED IN GLOBAL
|
||
|
|
F ZIBRFLI=1:1 Q:'$D(^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)) S ZIBRLINE=^(ZIBRFLI) D LSCAN S ^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)=ZIBROUTP
|
||
|
|
W "Line modification completed.",!
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
LSCAN ; SCAN LINE AND REPLACE VARIABLES
|
||
|
|
S ZIBRCPOS=$F(ZIBRLINE," ")-1,ZIBRCH=" ",ZIBROUTP=$E(ZIBRLINE,1,ZIBRCPOS-1)
|
||
|
|
F ZIBRQ=0:0 Q:ZIBRCH="" D COPY1,CMD
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CMD ;
|
||
|
|
I ZIBRCH=";" S ZIBROUTP=ZIBROUTP_$E(ZIBRLINE,ZIBRCPOS,255),ZIBRCPOS=$L(ZIBRLINE)+1,ZIBRCH="" Q
|
||
|
|
S ZIBRCMDT=ZIBRCH
|
||
|
|
F ZIBRQ=0:0 Q:": "[ZIBRCH D COPY1
|
||
|
|
D:ZIBRCH=":" EXPR
|
||
|
|
Q:ZIBRCH=""
|
||
|
|
D COPY1
|
||
|
|
I ZIBRCH'=" " D ARGS
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
COPY1 ;
|
||
|
|
S ZIBROUTP=ZIBROUTP_ZIBRCH
|
||
|
|
D ADVPOS
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
ADDOBJ ;
|
||
|
|
S ZIBROBJ=ZIBROBJ_ZIBRCH
|
||
|
|
D ADVPOS
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
ADVPOS ;
|
||
|
|
S ZIBRCPOS=ZIBRCPOS+1,ZIBRCH=$E(ZIBRLINE,ZIBRCPOS)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
EXPR ;
|
||
|
|
F ZIBRQ=0:0 Q:" "[ZIBRCH D COPYOBJ
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
COPYOBJ ; COPY AN OBJECT, CHECKING FOR VARIABLES
|
||
|
|
I ZIBRCH="""" D QSTR Q
|
||
|
|
I ZIBRCH'?1AN,"%^$"'[ZIBRCH D COPY1 Q
|
||
|
|
S ZIBROBJ=""
|
||
|
|
F ZIBRQ=0:0 D ADDOBJ Q:ZIBRCH'?1AN
|
||
|
|
D:$E(ZIBROBJ)?1A TSTOBJ
|
||
|
|
S ZIBROUTP=ZIBROUTP_ZIBROBJ
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
QSTR ; COPY QUOTED STRING (INCLUDED DOUBLED QUOTES)
|
||
|
|
F ZIBRQ=0:0 D COPY1 Q:""""[ZIBRCH
|
||
|
|
D COPY1
|
||
|
|
G:ZIBRCH="""" QSTR
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
ARGS ; COPY ARGUMENTS -- 'DO' AND 'GO' SPECIAL CASES
|
||
|
|
I "GD"'[ZIBRCMDT D EXPR Q
|
||
|
|
F ZIBRQ=0:0 Q:" "[ZIBRCH D DGARG D:ZIBRCH=":" CPYTCOM
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
DGARG ; PROCESS DO/GO ARGUMENTS
|
||
|
|
I ZIBRCH="@" D CPYTCOM Q
|
||
|
|
F ZIBRQ=0:0 Q:",: "[ZIBRCH D COPY1
|
||
|
|
D:ZIBRCH="," COPY1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CPYTCOM ; COPIES OBJECTS THRU ZERO-LEVEL COMMA
|
||
|
|
S ZIBRPLEV=0
|
||
|
|
F ZIBRQ=0:0 D CPYTKN Q:" "[ZIBRCH Q:ZIBRCH=","&(ZIBRPLEV=0)
|
||
|
|
D:ZIBRCH="," COPY1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CPYTKN ; COPIES A TOKEN, MODIFYING PARENTHESIS LEVEL
|
||
|
|
I ZIBRCH="(" S ZIBRPLEV=ZIBRPLEV+1 D COPY1 Q
|
||
|
|
I ZIBRCH=")" S ZIBRPLEV=ZIBRPLEV-1 D COPY1 Q
|
||
|
|
D COPYOBJ
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
TSTOBJ ; CONDITIONALLY REPLACES A VARIABLE NAME
|
||
|
|
Q:$E(ZIBROBJ,1,$L(ZIBRPRFX))=ZIBRPRFX
|
||
|
|
Q:$D(^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ))
|
||
|
|
I $D(^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)) S ZIBROBJ=^(ZIBROBJ) Q
|
||
|
|
D CHKPART
|
||
|
|
I ZIBRPART D VERPART Q:'ZIBRPART
|
||
|
|
S ZIBRCAND=ZIBRPRFX_ZIBROBJ
|
||
|
|
D VERCAND
|
||
|
|
S:ZIBRCAND="^" ZIBRCAND=ZIBROBJ
|
||
|
|
S ^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)=ZIBRCAND
|
||
|
|
S ^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)=ZIBROBJ
|
||
|
|
S ZIBROBJ=ZIBRCAND
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CHKPART ; VERIFY MATCH WITH EXCLUSION PARTIAL NAME LIST
|
||
|
|
S ZIBRPART=0,ZIBRPN=""
|
||
|
|
F ZIBRQ=0:0 S ZIBRPN=$O(^TMP("ZIBRNSPC",$J,"PEXC",ZIBRPN)) Q:ZIBRPN="" I $E(ZIBROBJ,1,$L(ZIBRPN))=ZIBRPN S ZIBRPART=1 Q
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
VERPART ; MANAGE PARTIAL MATCH
|
||
|
|
W "'",ZIBROBJ,"' begins with '",ZIBRPN,"'",!
|
||
|
|
R "Do you wish to treat it as an external reference? YES// ",ZIBRANS:DTIME,!
|
||
|
|
S:'$T ZIBRANS="Y"
|
||
|
|
S ZIBRANS=$E(ZIBRANS_"Y")
|
||
|
|
I ZIBRANS="?" W " Usage: ",ZIBRLINE,! G VERPART
|
||
|
|
S:ZIBRANS?1L ZIBRANS=$C($A(ZIBRANS)-32)
|
||
|
|
S:ZIBRANS="Y" ZIBRPART=0,^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ)=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
VERCAND ; MANAGE AUTO CANDIDATE SELECTION
|
||
|
|
I $L(ZIBRCAND)>8 W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"' due to its length.",! D GETALT G VERCAND
|
||
|
|
I $D(^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)),^(ZIBRCAND)'=ZIBROBJ W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"'; used for '",^(ZIBRCAND),"'",! D GETALT G VERCAND
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
GETALT ; GET ALTERNATE FOR PROPOSED CANDIDATE REPLACEMENT NAME
|
||
|
|
R "Please supply an alternative: ",ZIBRCAND:DTIME
|
||
|
|
S:'$T ZIBRCAND="^"
|
||
|
|
Q:ZIBRCAND="^"
|
||
|
|
I ZIBRCAND="?" W " Usage: ",ZIBRLINE,! G GETALT
|
||
|
|
I $E(ZIBRCAND,1,$L(ZIBRPRFX))=ZIBRPRFX W ! Q
|
||
|
|
W *7," -- does not begin with '",ZIBRPRFX,"'",!
|
||
|
|
R "Are you sure you want a non-namespaced variable? N// ",ZIBRANS:DTIME,!
|
||
|
|
S:'$T ZIBRANS="N"
|
||
|
|
S ZIBRANS=$E(ZIBRANS_"N")
|
||
|
|
I ZIBRANS?1L S ZIBRANS=$C($A(ZIBRANS)-32)
|
||
|
|
I ZIBRANS="Y" W ! Q
|
||
|
|
G GETALT
|
||
|
|
;
|