- 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 Feb 19, 2025@00:06:52 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")
