XPARTPV1 ;SLC/KCM - Transport, supporting calls
;;7.3;TOOLKIT;**26**;Apr 25, 1995
;
ZPKG(IEN,NAME) ; get package IEN & Name
N DIC,X,Y
S IEN=0,NAME=""
S DIC=9.4,DIC(0)="AEMQ" D ^DIC Q:Y<1
S IEN=+Y_";DIC(9.4,",NAME=$P(Y,U,2)
Q
PKG(IEN,NAME,NMSP) ; get namespace and associated package
N DIR,DIRUT,DTOUT,DUOUT,PKG
S IEN=0,NAME="",NMSP=""
S DIR("A")="Parameter Namespace",DIR(0)="F^2:30"
D ^DIR Q:$D(DIRUT) S NMSP=$P(Y,"*")
I $D(^DIC(9.4,"C",NMSP)) S IEN=$O(^DIC(9.4,"C",NMSP,0))
E S PKG=NMSP D
. F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(NMSP,1,$L(PKG))=PKG
. I $L(PKG) S IEN=$O(^DIC(9.4,"C",PKG,0))
I IEN S NAME=$P(^DIC(9.4,IEN,0),U),IEN=IEN_";DIC(9.4,"
Q
ROU(NAME) ; get routine name
N DIR,DIRUT,DTOUT,DUOUT
S NAME=""
S DIR("A")="Routine Name",DIR(0)="F^2:6"
D ^DIR Q:$D(DIRUT) S NAME=Y
W !!,"This will create a series of ",NAME," routines."
I $T(@(U_NAME))'="" W !,"But "_NAME_" already exists!"
S DIR("A")="Is that ok",DIR(0)="Y"
D ^DIR I $D(DIRUT)!(Y=0) S NAME=""
Q
MAX(SIZ) ; get maximum routine size
N DIR,DIRUT,DTOUT,DUOUT
S SIZ=0
S DIR("A")="Maximum Routine Size",DIR(0)="N^2000:8000"
D ^DIR Q:$D(DIRUT) S SIZ=Y
Q
VALTOTMP(PKG,NMSP) ; gather package level parameter values & put in ^TMP
N I,CNT K ^TMP($J,"XPARSAVE")
S (I,CNT)=0 F S I=$O(^XTV(8989.5,"B",PKG,I)) Q:'I D
. N PAR,PARNAME,INST,VAL,X
. S X=^XTV(8989.5,I,0),PAR=$P(X,U,2),INST=$P(X,U,3),VAL=^(1)
. S PARNAME=$P(^XTV(8989.51,PAR,0),U,1)
. I $E(PARNAME,1,$L(NMSP))'=NMSP Q ; skip if outside namespace
. S INST=$$EXT^XPARDD(INST,PAR,"I"),VAL=$$EXT^XPARDD(VAL,PAR,"V")
. I $D(^XTV(8989.5,I,2))>9 M VAL=^(2) K VAL(0)
. S ^TMP($J,"XPARSAVE",I,"KEY")=PARNAME_U_INST
. M ^TMP($J,"XPARSAVE",I,"VAL")=VAL
. S CNT=CNT+1 I CNT#100=0 W "."
Q
SAVEROU ; loop thru ^TMP($J,"ROU") and save routines
N DIE,X,XCM,XCN
S X="" F S X=$O(^TMP($J,"ROU",X)) Q:X="" D
. W !,"Saving ",X
. S DIE="^TMP($J,""ROU"","""_X_""",",XCN=0
. X ^%ZOSF("SAVE")
Q
MAKEID(I) ; return two char ID based on integer, (0..9,A..Z)=base 36
Q $TR($C(I\36+55)_$C(I#36+55),"789:;<=>?@","0123456789")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPARTPV1 2130 printed Dec 13, 2024@02:40:24 Page 2
XPARTPV1 ;SLC/KCM - Transport, supporting calls
+1 ;;7.3;TOOLKIT;**26**;Apr 25, 1995
+2 ;
ZPKG(IEN,NAME) ; get package IEN & Name
+1 NEW DIC,X,Y
+2 SET IEN=0
SET NAME=""
+3 SET DIC=9.4
SET DIC(0)="AEMQ"
DO ^DIC
if Y<1
QUIT
+4 SET IEN=+Y_";DIC(9.4,"
SET NAME=$PIECE(Y,U,2)
+5 QUIT
PKG(IEN,NAME,NMSP) ; get namespace and associated package
+1 NEW DIR,DIRUT,DTOUT,DUOUT,PKG
+2 SET IEN=0
SET NAME=""
SET NMSP=""
+3 SET DIR("A")="Parameter Namespace"
SET DIR(0)="F^2:30"
+4 DO ^DIR
if $DATA(DIRUT)
QUIT
SET NMSP=$PIECE(Y,"*")
+5 IF $DATA(^DIC(9.4,"C",NMSP))
SET IEN=$ORDER(^DIC(9.4,"C",NMSP,0))
+6 IF '$TEST
SET PKG=NMSP
Begin DoDot:1
+7 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
if $EXTRACT(NMSP,1,$LENGTH(PKG))=PKG
QUIT
+8 IF $LENGTH(PKG)
SET IEN=$ORDER(^DIC(9.4,"C",PKG,0))
End DoDot:1
+9 IF IEN
SET NAME=$PIECE(^DIC(9.4,IEN,0),U)
SET IEN=IEN_";DIC(9.4,"
+10 QUIT
ROU(NAME) ; get routine name
+1 NEW DIR,DIRUT,DTOUT,DUOUT
+2 SET NAME=""
+3 SET DIR("A")="Routine Name"
SET DIR(0)="F^2:6"
+4 DO ^DIR
if $DATA(DIRUT)
QUIT
SET NAME=Y
+5 WRITE !!,"This will create a series of ",NAME," routines."
+6 IF $TEXT(@(U_NAME))'=""
WRITE !,"But "_NAME_" already exists!"
+7 SET DIR("A")="Is that ok"
SET DIR(0)="Y"
+8 DO ^DIR
IF $DATA(DIRUT)!(Y=0)
SET NAME=""
+9 QUIT
MAX(SIZ) ; get maximum routine size
+1 NEW DIR,DIRUT,DTOUT,DUOUT
+2 SET SIZ=0
+3 SET DIR("A")="Maximum Routine Size"
SET DIR(0)="N^2000:8000"
+4 DO ^DIR
if $DATA(DIRUT)
QUIT
SET SIZ=Y
+5 QUIT
VALTOTMP(PKG,NMSP) ; gather package level parameter values & put in ^TMP
+1 NEW I,CNT
KILL ^TMP($JOB,"XPARSAVE")
+2 SET (I,CNT)=0
FOR
SET I=$ORDER(^XTV(8989.5,"B",PKG,I))
if 'I
QUIT
Begin DoDot:1
+3 NEW PAR,PARNAME,INST,VAL,X
+4 SET X=^XTV(8989.5,I,0)
SET PAR=$PIECE(X,U,2)
SET INST=$PIECE(X,U,3)
SET VAL=^(1)
+5 SET PARNAME=$PIECE(^XTV(8989.51,PAR,0),U,1)
+6 ; skip if outside namespace
IF $EXTRACT(PARNAME,1,$LENGTH(NMSP))'=NMSP
QUIT
+7 SET INST=$$EXT^XPARDD(INST,PAR,"I")
SET VAL=$$EXT^XPARDD(VAL,PAR,"V")
+8 IF $DATA(^XTV(8989.5,I,2))>9
MERGE VAL=^(2)
KILL VAL(0)
+9 SET ^TMP($JOB,"XPARSAVE",I,"KEY")=PARNAME_U_INST
+10 MERGE ^TMP($JOB,"XPARSAVE",I,"VAL")=VAL
+11 SET CNT=CNT+1
IF CNT#100=0
WRITE "."
End DoDot:1
+12 QUIT
SAVEROU ; loop thru ^TMP($J,"ROU") and save routines
+1 NEW DIE,X,XCM,XCN
+2 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"ROU",X))
if X=""
QUIT
Begin DoDot:1
+3 WRITE !,"Saving ",X
+4 SET DIE="^TMP($J,""ROU"","""_X_""","
SET XCN=0
+5 XECUTE ^%ZOSF("SAVE")
End DoDot:1
+6 QUIT
MAKEID(I) ; return two char ID based on integer, (0..9,A..Z)=base 36
+1 QUIT $TRANSLATE($CHAR(I\36+55)_$CHAR(I#36+55),"789:;<=>?@","0123456789")
