ZIBRNSPC.m

ZIBRNSPC ; IHS/ADC/GTH - NAMESPACE PREVIOUSLY WRITTEN ROUTINES ; [ 10/29/2002   7:42 AM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ; 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

 ;

ZIBRNSPC  ; IHS/ADC/GTH - NAMESPACE PREVIOUSLY WRITTEN ROUTINES ; [ 10/29/2002   7:42 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.

 +3       ;

INIT      ;

 +1        KILL (%)

 +2        DO ^XBKVAR

 +3        SET DTIME=300

 +4        KILL %,DISYS,%H,X,^UTILITY($JOB),^TMP("ZIBRNSPC",$JOB)

 +5        SET IOP=$IO

 +6        DO ^%ZIS

START     ;

 +1        WRITE "Routine Namespace Converter",!

 +2        SET ZIBRQUIT=0

 +3        DO SETUP

 +4        IF ZIBRQUIT

               GOTO EXIT

 +5       ;S ZIBRRTN="";IHS/SET/GTH XB*3*9 10/29/2002

 +6       ;IHS/SET/GTH XB*3*9 10/29/2002

           SET ZIBRRTN=0

 +7        FOR ZIBRQ=0:0

               SET ZIBRRTN=$ORDER(^UTILITY($JOB,ZIBRRTN))

               IF ZIBRRTN=""

                   QUIT 

               WRITE !!,"-- ",ZIBRRTN," --",!!

               DO RLOAD

               DO RFIX

               DO RSAVE

               DO RNDX

EXIT      ;

 +1        WRITE !!,"Done.",!

 +2        KILL ^UTILITY($JOB),^TMP("ZIBRNSPC",$JOB),DUOUT,DTOUT,IOP

 +3        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

 +4        QUIT 

 +5       ;

SETUP     ; INITIALIZE UTILITY

 +1        FOR ZIBRT="EXC","PEXC"

               FOR ZIBRI=0:1

                   SET ZIBRL=$TEXT(@ZIBRT+ZIBRI)

                   SET ZIBRL=$PIECE(ZIBRL,";;",2,255)

                   IF ZIBRL=""

                       QUIT 

                   FOR ZIBRJ=1:1

                       SET ZIBRW=$PIECE(ZIBRL,"^",ZIBRJ)

                       IF ZIBRW=""

                           QUIT 

                       SET ^TMP("ZIBRNSPC",$JOB,ZIBRT,ZIBRW)=""

PLOOP     ;

 +1        READ "Package prefix (1-5 characters): ",ZIBRPRFX:DTIME

 +2        IF '$TEST

               SET ZIBRPRFX="^"

 +3        IF "^"'[ZIBRPRFX

               IF $LENGTH(ZIBRPRFX)>5!(ZIBRPRFX'?1.5U)

                   WRITE *7," -- Invalid prefix",!

                   GOTO PLOOP

 +4        WRITE !

 +5        IF "^"[ZIBRPRFX

               SET ZIBRQUIT=1

               QUIT 

 +6        WRITE !,"Enter any variables to be treated as external references --",!,"not to be namespaced -- in the form  NAME1,NAME2,...",!

 +7        FOR ZIBRQ=0:0

               READ " Externals: ",ZIBRL:DTIME,!

               IF '$TEST

                   SET ZIBRL="^"

               IF "^"[ZIBRL

                   QUIT 

               IF ZIBRL["?"

                   DO SHEXT

               IF ZIBRL]""

                   FOR ZIBRI=1:1

                       SET ZIBRW=$PIECE(ZIBRL,",",ZIBRI)

                       IF ZIBRW=""

                           QUIT 

                       SET ^TMP("ZIBRNSPC",$JOB,"EXC",ZIBRW)=""

                       WRITE "  ",ZIBRW,!

 +8        IF ZIBRL["^"

               SET ZIBRQUIT=1

               QUIT 

 +9        XECUTE ^%ZOSF("RSEL")

 +10       IF $ORDER(^UTILITY($JOB,""))=""

               SET ZIBRQUIT=1

 +11       QUIT 

 +12      ;

SHEXT     ;

 +1        WRITE !?2,"Currently defined externals:",!

 +2        SET ZIBRW=""

 +3        FOR ZIBRQ=0:0

               SET W=$ORDER(^TMP("ZIBRNSPC",$JOB,"EXC",ZIBRW))

               IF ZIBRW=""

                   QUIT 

               WRITE ?3,ZIBRW,!

 +4        WRITE !

 +5        SET ZIBRL=""

 +6        QUIT 

 +7       ;

EXC       ;;X^Y^DIE^DIC^DT^U^DUZ^DTIME^ZTSK^ZTDESC^ZTSAVE^ZTLOAD^ZTRTN^ZTIO^ZTDTH

 +1       ;;

PEXC      ;;IO^D^XB^Z

 +1       ;;

 +2       ;

RLOAD     ; LOAD ROUTINE INTO GLOBAL

 +1        WRITE "Beginning routine load ... "

 +2        KILL ^TMP("ZIBRNSPC",$JOB,"T"),^("K")

 +3        SET ZIBRXC=$EXTRACT($TEXT(RLOADX),10,255)

 +4        XECUTE ZIBRXC

 +5        WRITE " completed.",!

 +6        QUIT 

 +7       ;

RLOADX    ;;S ^TMP("ZIBRNSPC",$J,"T",0)=ZIBRRTN ZL @ZIBRRTN F ZIBRI=1:1 S ZIBRL=$T(+ZIBRI) Q:ZIBRL=""  S ^(ZIBRI)=ZIBRL

 +1       ;

RSAVE     ; SAVE GLOBAL TEXT AS ROUTINE

 +1        WRITE "Beginning routine save ... "

 +2        SET ZIBRXC=$PIECE($TEXT(RSAVEX),"RSAVEX ",2)

 +3        XECUTE ZIBRXC

 +4        WRITE " completed.",!

 +5        QUIT 

 +6       ;

 +7       ; 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     SET ZIBRRTN=^TMP("ZIBRNSPC",$JOB,"T",0)