XPAREDT3 ;SLC/KCM - Parameter Templates
;;7.3;TOOLKIT;**26**;Apr 25, 1995
;
SELTED ; select template then edit
N DIC,Y
S DIC=8989.52,DIC(0)="AEMQ" D ^DIC Q:Y<0
D TED^XPAREDIT(+Y,"BA")
Q
TED ; come here from TED^XPAREDIT(TLT,SHWFLG,ALLENT)
; edit templates - suppress display of dashed header for each value
N NOHDR S NOHDR=""
TEDH ; come here from TEDH^XPAREDIT(TLT,SHWFLG,ALLENT)
; Edits parameters using a template
; TLT: name of a template in (or pointer to) PARAMETER TEMPLATE file
N ALLINST,ENT,SEQ,IEN,PAR,TLTJMP,DIRUT,DTOUT,DUOUT
I 'TLT S TLT=$O(^XTV(8989.52,"B",TLT,0))
I 'TLT W !!,$C(7),"Parameter template not found.",! Q
I '$L($G(ALLENT)) D SELENT(.ALLENT,TLT) Q:$D(DTOUT)!$D(DUOUT)
D SELINST(.ALLINST,ALLENT,TLT) Q:$D(DTOUT)!$D(DUOUT)
I $G(SHWFLG)["B" D SHWTLT(ALLENT,ALLINST,TLT)
; set up ref array for ^jumping
S (SEQ,CNT)=0 F S SEQ=$O(^XTV(8989.52,TLT,10,"B",SEQ)) Q:'SEQ D
. S IEN=0 F S IEN=$O(^XTV(8989.52,TLT,10,"B",SEQ,IEN)) Q:'IEN D
. . S PAR=$P(^XTV(8989.52,TLT,10,IEN,0),U,2),X=^XTV(8989.51,PAR,0)
. . S CNT=CNT+1,TLTJMP(CNT)=PAR_U_$P(X,U,2)_U_$P(X,U,5)
. . I $L($P(X,U,5)) S TLTJMP("B",$$UP^XLFSTR($P(X,U,5)),CNT)="" I 1
. . E I $L($P(X,U,2)) S TLTJMP("B",$$UP^XLFSTR($P(X,U,2)),CNT)=""
S SEQ=0 F S SEQ=$O(TLTJMP(SEQ)) Q:'SEQ D Q:$D(DTOUT)!$D(DUOUT)
. S PAR=$P(TLTJMP(SEQ),U,1,2)
. S ENT=ALLENT
. I 'ENT D GETENT^XPAREDIT(.ENT,PAR) I 'ENT S DUOUT="" Q
. I ENT D TEDIT^XPAREDIT(ENT,PAR,ALLINST,.VAL)
. I $E(VAL)=U D
. . S X=$$UP^XLFSTR($E(VAL,2,$L(VAL)-1)_$C($A($E(VAL,$L(VAL))-1)))
. . S X=$O(TLTJMP("B",X)) I $L(X) S SEQ=$O(TLTJMP("B",X,0))-.1
I $G(SHWFLG)["A" D SHWTLT(ALLENT,ALLINST,TLT,1) S DIR(0)="E" D ^DIR
Q
SELENT(ENT,TLT) ; Select an entity for use with the template
; .ENT: Returns the selected entity or null
; TLT: passed in pointer to the parameter template file
N FN S FN=$P(^XTV(8989.52,TLT,0),U,3),ENT="" Q:'FN
; begin case FN
I FN=9.4 D G XC1 ; get package pointer for this template
. N PKG,NAM
. S NAM=$P(^XTV(8989.52,TLT,0),U),PKG=NAM
. F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(NAM,1,$L(PKG))=PKG
. S PKG=$O(^DIC(9.4,"C",PKG,0))
. I PKG S ENT=PKG_";DIC(9.4,"
I FN=4.2 D G XC1 ; get domain pointer
. I '$D(XPARSYS) S XPARSYS=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
. S ENT=XPARSYS
I FN=4 D G:ENT XC1 ; get division pointer
. N DIV S DIV=$$KSP^XUPARAM("INST")
. I $$GET1^DIQ(4,DIV_",",5,"I")'="Y" S ENT=DIV_";DIC(4,"
D LOOKUP^XPAREDIT(.ENT,FN) ; otherwise, lookup entity
XC1 ; end case FN
I 'ENT S DUOUT="" ; no entity selected, treat as "^"
Q
SELINST(INST,ENT,TLT) ; Display instances & select from list, or add new
S INST="" N PAR,INSTLST Q:'ENT
S PAR=$P(^XTV(8989.52,TLT,0),U,4) Q:'PAR
D GETLST^XPAR(.INSTLST,ENT,PAR,"E")
;D SHWINST^XPAREDT2(ENT,PAR,20,0,.INSTLST)
D SELINST^XPAREDT2(.INST,ENT,PAR)
I INST="" S DUOUT=""
Q
SHWTLT(ENT,INST,TLT,AFT) ; Display all values for a template
Q:'ENT
N X,SEQ,CNT,IEN,PAR,LST,LF,I
S X=$P(^XTV(8989.52,TLT,0),U,2)_$$ENTDISP^XPAREDIT(ENT)
I $L(INST) S X=X_", "_$P(INST,U,2)
I $G(AFT) S X=X_" is now:"
W !!,X,!,$$DASH^XPAREDIT(78),!
I $E(INST)="`" S INST=$E(INST,2,999)
S (SEQ,CNT)=0 F S SEQ=$O(^XTV(8989.52,TLT,10,"B",SEQ)) Q:'SEQ D
. S IEN=0 F S IEN=$O(^XTV(8989.52,TLT,10,"B",SEQ,IEN)) Q:'IEN D
. . S PAR=$P(^XTV(8989.52,TLT,10,IEN,0),U,2),X=^XTV(8989.51,PAR,0)
. . W $P(X,U,2)
. . I $P(X,U,3) D ; multi-valued
. . . D GETLST^XPAR(.LST,ENT,PAR,"B") S LF=0
. . . S I=0 F S I=$O(LST(I)) Q:'I I (LST(I,"N")=INST)!('$L(INST)) D
. . . . W ?29," ",$P(LST(I,"N"),U,2),?49," ",$P(LST(I,"V"),U,2),!
. . . . S LF=1
. . . I 'LF W !
. . E D ; single-valued
. . . W ?49," ",$$GET^XPAR(ENT,PAR,1,"E"),!
W $$DASH^XPAREDIT(78)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPAREDT3 3864 printed Apr 09, 2024@21:44:37 Page 2
XPAREDT3 ;SLC/KCM - Parameter Templates
+1 ;;7.3;TOOLKIT;**26**;Apr 25, 1995
+2 ;
SELTED ; select template then edit
+1 NEW DIC,Y
+2 SET DIC=8989.52
SET DIC(0)="AEMQ"
DO ^DIC
if Y<0
QUIT
+3 DO TED^XPAREDIT(+Y,"BA")
+4 QUIT
TED ; come here from TED^XPAREDIT(TLT,SHWFLG,ALLENT)
+1 ; edit templates - suppress display of dashed header for each value
+2 NEW NOHDR
SET NOHDR=""
TEDH ; come here from TEDH^XPAREDIT(TLT,SHWFLG,ALLENT)
+1 ; Edits parameters using a template
+2 ; TLT: name of a template in (or pointer to) PARAMETER TEMPLATE file
+3 NEW ALLINST,ENT,SEQ,IEN,PAR,TLTJMP,DIRUT,DTOUT,DUOUT
+4 IF 'TLT
SET TLT=$ORDER(^XTV(8989.52,"B",TLT,0))
+5 IF 'TLT
WRITE !!,$CHAR(7),"Parameter template not found.",!
QUIT
+6 IF '$LENGTH($GET(ALLENT))
DO SELENT(.ALLENT,TLT)
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+7 DO SELINST(.ALLINST,ALLENT,TLT)
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 IF $GET(SHWFLG)["B"
DO SHWTLT(ALLENT,ALLINST,TLT)
+9 ; set up ref array for ^jumping
+10 SET (SEQ,CNT)=0
FOR
SET SEQ=$ORDER(^XTV(8989.52,TLT,10,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+11 SET IEN=0
FOR
SET IEN=$ORDER(^XTV(8989.52,TLT,10,"B",SEQ,IEN))
if 'IEN
QUIT
Begin DoDot:2
+12 SET PAR=$PIECE(^XTV(8989.52,TLT,10,IEN,0),U,2)
SET X=^XTV(8989.51,PAR,0)
+13 SET CNT=CNT+1
SET TLTJMP(CNT)=PAR_U_$PIECE(X,U,2)_U_$PIECE(X,U,5)
+14 IF $LENGTH($PIECE(X,U,5))
SET TLTJMP("B",$$UP^XLFSTR($PIECE(X,U,5)),CNT)=""
IF 1
+15 IF '$TEST
IF $LENGTH($PIECE(X,U,2))
SET TLTJMP("B",$$UP^XLFSTR($PIECE(X,U,2)),CNT)=""
End DoDot:2
End DoDot:1
+16 SET SEQ=0
FOR
SET SEQ=$ORDER(TLTJMP(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+17 SET PAR=$PIECE(TLTJMP(SEQ),U,1,2)
+18 SET ENT=ALLENT
+19 IF 'ENT
DO GETENT^XPAREDIT(.ENT,PAR)
IF 'ENT
SET DUOUT=""
QUIT
+20 IF ENT
DO TEDIT^XPAREDIT(ENT,PAR,ALLINST,.VAL)
+21 IF $EXTRACT(VAL)=U
Begin DoDot:2
+22 SET X=$$UP^XLFSTR($EXTRACT(VAL,2,$LENGTH(VAL)-1)_$CHAR($ASCII($EXTRACT(VAL,$LENGTH(VAL))-1)))
+23 SET X=$ORDER(TLTJMP("B",X))
IF $LENGTH(X)
SET SEQ=$ORDER(TLTJMP("B",X,0))-.1
End DoDot:2
End DoDot:1
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+24 IF $GET(SHWFLG)["A"
DO SHWTLT(ALLENT,ALLINST,TLT,1)
SET DIR(0)="E"
DO ^DIR
+25 QUIT
SELENT(ENT,TLT) ; Select an entity for use with the template
+1 ; .ENT: Returns the selected entity or null
+2 ; TLT: passed in pointer to the parameter template file
+3 NEW FN
SET FN=$PIECE(^XTV(8989.52,TLT,0),U,3)
SET ENT=""
if 'FN
QUIT
+4 ; begin case FN
+5 ; get package pointer for this template
IF FN=9.4
Begin DoDot:1
+6 NEW PKG,NAM
+7 SET NAM=$PIECE(^XTV(8989.52,TLT,0),U)
SET PKG=NAM
+8 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
if $EXTRACT(NAM,1,$LENGTH(PKG))=PKG
QUIT
+9 SET PKG=$ORDER(^DIC(9.4,"C",PKG,0))
+10 IF PKG
SET ENT=PKG_";DIC(9.4,"
End DoDot:1
GOTO XC1
+11 ; get domain pointer
IF FN=4.2
Begin DoDot:1
+12 IF '$DATA(XPARSYS)
SET XPARSYS=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
+13 SET ENT=XPARSYS
End DoDot:1
GOTO XC1
+14 ; get division pointer
IF FN=4
Begin DoDot:1
+15 NEW DIV
SET DIV=$$KSP^XUPARAM("INST")
+16 IF $$GET1^DIQ(4,DIV_",",5,"I")'="Y"
SET ENT=DIV_";DIC(4,"
End DoDot:1
if ENT
GOTO XC1
+17 ; otherwise, lookup entity
DO LOOKUP^XPAREDIT(.ENT,FN)
XC1 ; end case FN
+1 ; no entity selected, treat as "^"
IF 'ENT
SET DUOUT=""
+2 QUIT
SELINST(INST,ENT,TLT) ; Display instances & select from list, or add new
+1 SET INST=""
NEW PAR,INSTLST
if 'ENT
QUIT
+2 SET PAR=$PIECE(^XTV(8989.52,TLT,0),U,4)
if 'PAR
QUIT
+3 DO GETLST^XPAR(.INSTLST,ENT,PAR,"E")
+4 ;D SHWINST^XPAREDT2(ENT,PAR,20,0,.INSTLST)
+5 DO SELINST^XPAREDT2(.INST,ENT,PAR)
+6 IF INST=""
SET DUOUT=""
+7 QUIT
SHWTLT(ENT,INST,TLT,AFT) ; Display all values for a template
+1 if 'ENT
QUIT
+2 NEW X,SEQ,CNT,IEN,PAR,LST,LF,I
+3 SET X=$PIECE(^XTV(8989.52,TLT,0),U,2)_$$ENTDISP^XPAREDIT(ENT)
+4 IF $LENGTH(INST)
SET X=X_", "_$PIECE(INST,U,2)
+5 IF $GET(AFT)
SET X=X_" is now:"
+6 WRITE !!,X,!,$$DASH^XPAREDIT(78),!
+7 IF $EXTRACT(INST)="`"
SET INST=$EXTRACT(INST,2,999)
+8 SET (SEQ,CNT)=0
FOR
SET SEQ=$ORDER(^XTV(8989.52,TLT,10,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+9 SET IEN=0
FOR
SET IEN=$ORDER(^XTV(8989.52,TLT,10,"B",SEQ,IEN))
if 'IEN
QUIT
Begin DoDot:2
+10 SET PAR=$PIECE(^XTV(8989.52,TLT,10,IEN,0),U,2)
SET X=^XTV(8989.51,PAR,0)
+11 WRITE $PIECE(X,U,2)
+12 ; multi-valued
IF $PIECE(X,U,3)
Begin DoDot:3
+13 DO GETLST^XPAR(.LST,ENT,PAR,"B")
SET LF=0
+14 SET I=0
FOR
SET I=$ORDER(LST(I))
if 'I
QUIT
IF (LST(I,"N")=INST)!('$LENGTH(INST))
Begin DoDot:4
+15 WRITE ?29," ",$PIECE(LST(I,"N"),U,2),?49," ",$PIECE(LST(I,"V"),U,2),!
+16 SET LF=1
End DoDot:4
+17 IF 'LF
WRITE !
End DoDot:3
+18 ; single-valued
IF '$TEST
Begin DoDot:3
+19 WRITE ?49," ",$$GET^XPAR(ENT,PAR,1,"E"),!
End DoDot:3
End DoDot:2
End DoDot:1
+20 WRITE $$DASH^XPAREDIT(78)
+21 QUIT
