XPARTPV ;SLC/KCM - Transport package level values
;;7.3;TOOLKIT;**26**;Apr 25, 1995
;
EN ; create transport routines
W !,"Transport Package Level Parameter Values",!
N I,PKG,NMSP,ROUNAME,MAXSIZE,NMSP,TODAY,PKGNAME K ^TMP($J)
S TODAY=$$FMTE^XLFDT($$NOW^XLFDT)
D PKG^XPARTPV1(.PKG,.PKGNAME,.NMSP) Q:'PKG ; package & namespace
D ROU^XPARTPV1(.ROUNAME) Q:ROUNAME="" ; routine name
D MAX^XPARTPV1(.MAXSIZE) Q:MAXSIZE=0 ; maximum size
W !,"Gathering data..."
D VALTOTMP^XPARTPV1(PKG,NMSP) ; put values in ^TMP
I $O(^TMP($J,"XPARSAVE",0))="" W !,"No data found." Q
;
; create main transport routine
W !,"Creating ",ROUNAME
S I=0 F S X=$T(XX0+I) Q:$P(X," ")="XMAIN" D
. I $P(X," ")="XX0" S X=ROUNAME_" ; Export Package Level Parameters ; "_TODAY
. I $P(X," ")="XX1" S X=" D ^"_ROUNAME_$$MAKEID^XPARTPV1(1)
. I $P(X," ")="XX2" S $P(X,"_",2)=""""_PKGNAME_""""
. S I=I+1,^TMP($J,"ROU",ROUNAME,I,0)=X
;
; create data loading routines
N CURSIZE,ROOT,ROOTEND,ROUCNT,NROUNAM,REF,VAL,X
S ROUCNT=0,ROOT=$NAME(^TMP($J,"XPARSAVE")),ROOTEND=$L(ROOT)
D NEWROU S I=8 ; label DATA is at line 8
S X=ROOT F S X=$Q(@X) Q:$E(X,1,ROOTEND-1)_")"'=ROOT D
. I (CURSIZE+512)>MAXSIZE D NEWROU S I=8
. S REF=" ;;"_$E(X,ROOTEND+1,255),VAL=" ;;"_@X
. S I=I+1,^TMP($J,"ROU",NROUNAM,I,0)=REF
. S I=I+1,^TMP($J,"ROU",NROUNAM,I,0)=VAL
. S CURSIZE=CURSIZE+$L(REF)+$L(VAL)
S ^TMP($J,"ROU",NROUNAM,7,0)=" Q" ; last rtn: QUIT, not GO
;
; save routines stored in ^TMP
D SAVEROU^XPARTPV1
K ^TMP($J)
Q
NEWROU ; new data loading routine, changes ROUCNT,NROUNAM,CURSIZ
N I,X
S ROUCNT=ROUCNT+1,NROUNAM=ROUNAME_$$MAKEID^XPARTPV1(ROUCNT),CURSIZE=0
W !,"Creating ",NROUNAM
S I=0 F S X=$T(XX3+I) Q:$P(X," ")="XLOAD" D
. I $P(X," ")="XX3" S X=NROUNAM_" ; ; "_TODAY
. I $P(X," ")="XX4" S X=" G ^"_ROUNAME_$$MAKEID^XPARTPV1(ROUCNT+1)
. S I=I+1,^TMP($J,"ROU",NROUNAM,I,0)=X,CURSIZE=CURSIZE+$L(X)
Q
;
STUB Q
;
XX0 ; Export Package Level Parameters
;;
MAIN ; main (initial) parameter transport routine
K ^TMP($J,"XPARRSTR")
N ENT,IDX,ROOT,REF,VAL,I
S ROOT=$NAME(^TMP($J,"XPARRSTR")),ROOT=$E(ROOT,1,$L(ROOT)-1)_","
XX1 D STUB ; chains routines that load ^TMP
XX2 S IDX=0,ENT="PKG."_STUB
F S IDX=$O(^TMP($J,"XPARRSTR",IDX)) Q:'IDX D
. N PAR,INST,VAL,ERR
. S PAR=$P(^TMP($J,"XPARRSTR",IDX,"KEY"),U),INST=$P(^("KEY"),U,2)
. M VAL=^TMP($J,"XPARRSTR",IDX,"VAL")
. D EN^XPAR(ENT,PAR,INST,.VAL,.ERR)
K ^TMP($J,"XPARRSTR")
Q
XMAIN ;; end of MAIN
;
XX3 ; Export Package Level Parameters
;;
LOAD ; load data into ^TMP (expects ROOT to be defined)
S I=1 F S REF=$T(DATA+I) Q:REF="" S VAL=$T(DATA+I+1) D
. S I=I+2,REF=$P(REF,";",3,999),VAL=$P(VAL,";",3,999)
. S @(ROOT_REF)=VAL
XX4 G STUB
DATA ; parameter data
XLOAD ;; end of LOAD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPARTPV 2928 printed Dec 13, 2024@02:40:23 Page 2
XPARTPV ;SLC/KCM - Transport package level values
+1 ;;7.3;TOOLKIT;**26**;Apr 25, 1995
+2 ;
EN ; create transport routines
+1 WRITE !,"Transport Package Level Parameter Values",!
+2 NEW I,PKG,NMSP,ROUNAME,MAXSIZE,NMSP,TODAY,PKGNAME
KILL ^TMP($JOB)
+3 SET TODAY=$$FMTE^XLFDT($$NOW^XLFDT)
+4 ; package & namespace
DO PKG^XPARTPV1(.PKG,.PKGNAME,.NMSP)
if 'PKG
QUIT
+5 ; routine name
DO ROU^XPARTPV1(.ROUNAME)
if ROUNAME=""
QUIT
+6 ; maximum size
DO MAX^XPARTPV1(.MAXSIZE)
if MAXSIZE=0
QUIT
+7 WRITE !,"Gathering data..."
+8 ; put values in ^TMP
DO VALTOTMP^XPARTPV1(PKG,NMSP)
+9 IF $ORDER(^TMP($JOB,"XPARSAVE",0))=""
WRITE !,"No data found."
QUIT
+10 ;
+11 ; create main transport routine
+12 WRITE !,"Creating ",ROUNAME
+13 SET I=0
FOR
SET X=$TEXT(XX0+I)
if $PIECE(X," ")="XMAIN"
QUIT
Begin DoDot:1
+14 IF $PIECE(X," ")="XX0"
SET X=ROUNAME_" ; Export Package Level Parameters ; "_TODAY
+15 IF $PIECE(X," ")="XX1"
SET X=" D ^"_ROUNAME_$$MAKEID^XPARTPV1(1)
+16 IF $PIECE(X," ")="XX2"
SET $PIECE(X,"_",2)=""""_PKGNAME_""""
+17 SET I=I+1
SET ^TMP($JOB,"ROU",ROUNAME,I,0)=X
End DoDot:1
+18 ;
+19 ; create data loading routines
+20 NEW CURSIZE,ROOT,ROOTEND,ROUCNT,NROUNAM,REF,VAL,X
+21 SET ROUCNT=0
SET ROOT=$NAME(^TMP($JOB,"XPARSAVE"))
SET ROOTEND=$LENGTH(ROOT)
+22 ; label DATA is at line 8
DO NEWROU
SET I=8
+23 SET X=ROOT
FOR
SET X=$QUERY(@X)
if $EXTRACT(X,1,ROOTEND-1)_")"'=ROOT
QUIT
Begin DoDot:1
+24 IF (CURSIZE+512)>MAXSIZE
DO NEWROU
SET I=8
+25 SET REF=" ;;"_$EXTRACT(X,ROOTEND+1,255)
SET VAL=" ;;"_@X
+26 SET I=I+1
SET ^TMP($JOB,"ROU",NROUNAM,I,0)=REF
+27 SET I=I+1
SET ^TMP($JOB,"ROU",NROUNAM,I,0)=VAL
+28 SET CURSIZE=CURSIZE+$LENGTH(REF)+$LENGTH(VAL)
End DoDot:1
+29 ; last rtn: QUIT, not GO
SET ^TMP($JOB,"ROU",NROUNAM,7,0)=" Q"
+30 ;
+31 ; save routines stored in ^TMP
+32 DO SAVEROU^XPARTPV1
+33 KILL ^TMP($JOB)
+34 QUIT
NEWROU ; new data loading routine, changes ROUCNT,NROUNAM,CURSIZ
+1 NEW I,X
+2 SET ROUCNT=ROUCNT+1
SET NROUNAM=ROUNAME_$$MAKEID^XPARTPV1(ROUCNT)
SET CURSIZE=0
+3 WRITE !,"Creating ",NROUNAM
+4 SET I=0
FOR
SET X=$TEXT(XX3+I)
if $PIECE(X," ")="XLOAD"
QUIT
Begin DoDot:1
+5 IF $PIECE(X," ")="XX3"
SET X=NROUNAM_" ; ; "_TODAY
+6 IF $PIECE(X," ")="XX4"
SET X=" G ^"_ROUNAME_$$MAKEID^XPARTPV1(ROUCNT+1)
+7 SET I=I+1
SET ^TMP($JOB,"ROU",NROUNAM,I,0)=X
SET CURSIZE=CURSIZE+$LENGTH(X)
End DoDot:1
+8 QUIT
+9 ;
STUB QUIT
+1 ;
XX0 ; Export Package Level Parameters
+1 ;;
MAIN ; main (initial) parameter transport routine
+1 KILL ^TMP($JOB,"XPARRSTR")
+2 NEW ENT,IDX,ROOT,REF,VAL,I
+3 SET ROOT=$NAME(^TMP($JOB,"XPARRSTR"))
SET ROOT=$EXTRACT(ROOT,1,$LENGTH(ROOT)-1)_","
XX1 ; chains routines that load ^TMP
DO STUB
XX2 SET IDX=0
SET ENT="PKG."_STUB
+1 FOR
SET IDX=$ORDER(^TMP($JOB,"XPARRSTR",IDX))
if 'IDX
QUIT
Begin DoDot:1
+2 NEW PAR,INST,VAL,ERR
+3 SET PAR=$PIECE(^TMP($JOB,"XPARRSTR",IDX,"KEY"),U)
SET INST=$PIECE(^("KEY"),U,2)
+4 MERGE VAL=^TMP($JOB,"XPARRSTR",IDX,"VAL")
+5 DO EN^XPAR(ENT,PAR,INST,.VAL,.ERR)
End DoDot:1
+6 KILL ^TMP($JOB,"XPARRSTR")
+7 QUIT
XMAIN ;; end of MAIN
+1 ;
XX3 ; Export Package Level Parameters
+1 ;;
LOAD ; load data into ^TMP (expects ROOT to be defined)
+1 SET I=1
FOR
SET REF=$TEXT(DATA+I)
if REF=""
QUIT
SET VAL=$TEXT(DATA+I+1)
Begin DoDot:1
+2 SET I=I+2
SET REF=$PIECE(REF,";",3,999)
SET VAL=$PIECE(VAL,";",3,999)
+3 SET @(ROOT_REF)=VAL
End DoDot:1
XX4 GOTO STUB
DATA ; parameter data
XLOAD ;; end of LOAD
