XPAREDIT ; SLC/KCM - Simple Parameter Editor ;11:15 PM 4 Feb 1998
;;7.3;TOOLKIT;**26,118**;Apr 25, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; Enter here to select parameter, then entity
; ENT: variable pointer to the entity selected
; PAR: IEN^NAME of the selected parameter
W !,?25,"--- Edit Parameter Values ---"
N ENT,PAR,LST,JUST1,DIRUT,DUOUT,DTOUT
F W ! D GETPAR(.PAR) Q:'PAR D W !,$$DASH($S($D(IOM):IOM-1,1:78))
. D BLDLST(.LST,PAR)
. F D GETENT(.ENT,PAR,.JUST1) Q:'ENT D EDIT(ENT,PAR) Q:JUST1
Q
TED(TLT,SHWFLG,ALLENT) ; Edit parameters using a template
G TED^XPAREDT3
;
TEDH(TLT,SHWFLG,ALLENT) ; Edit parameters using a template, show dash headers
G TEDH^XPAREDT3
;
TEDIT(ENT,PAR,INST,USRX) ; Edit an instance of a parameter
K Y
I $G(INST)="" D EDITA S USRX=$G(Y("X")) I 1
E D EDIT1^XPAREDT2 S USRX=$G(Y("X"))
I $E(USRX)=U,$E(USRX,2)'=U,$L(USRX)>1 K DTOUT,DUOUT,DIRUT
Q
EDITPAR(PAR) ; Edit a single parameter
; add second parameter to limit entity type? ENTTYP
; LOC,CLS,TEA,USR,DIV,SVC call LOOKUP with appropriate FN
; PKG,SYS figure out appropriate defaults (param nmsp, domain)
N ENT
I 'PAR S PAR=$O(^XTV(8989.51,"B",PAR,0))
S PAR=PAR_U_$P(^XTV(8989.51,PAR,0),U,2)
; W $P(PAR,U,2)
D GETENT(.ENT,PAR) Q:'ENT
D EDIT(ENT,PAR)
Q
GETPAR(Y) ; Select parameter to edit
N DIC,DTOUT,DUOUT,X
S DIC=8989.51,DIC(0)="AEMQ"
S DIC("W")="W "" "",$P(^(0),U,2)"
D ^DIC I Y<1 S Y=0
Q
GETENT(ENT,PAR,JUST1) ; Select entity to edit for a given parameter
; .ENT=entity, returned as variable pointer
; PAR=ien^name
N X,I,LST
S JUST1=0
D BLDLST(.LST,PAR) S ENT=""
I LST=1 D ; if only one class of entity
. S X=LST($O(LST(0))),ENT=$P(X,U,5) ; instance for entity
. I ENT S JUST1=1 Q ; is fixed entry
. I 'ENT D LOOKUP(.ENT,+X) ; not fixed - do lookup
E D ; otherwise
. D GETCLS(.X,PAR,.LST) ; choose class
. I 'X S ENT="" Q ; nothing selected
. I +X&(X[";") S ENT=X Q ; resolved VP returned
. I $L($P(LST(X),U,5)) S ENT=$P(LST(X),U,5) Q ; fixed instance
. S ENT="" D LOOKUP(.ENT,+LST(X)) ; lookup on selected file
Q
EDIT(ENT,PAR) ; Edit value(s) for entity/parameter
N INST,X,Y
EDITA ; come here from TEDIT
N ERR,INSTLST
I '$D(NOHDR) W !!,$$CENTER("Setting "_$P(PAR,U,2)_" "_$$ENTDISP(ENT))
I +$P(^XTV(8989.51,+PAR,0),U,3) F D Q:'$L(INST)!$D(DIRUT) ; multiple
. I $D(NOHDR) W !!,"For "_$P(PAR,U,2)_" -"
. ; D SHWINST^XPAREDT2(ENT,+PAR,$S($D(IOSL):IOSL-4,1:20),0,.INSTLST)
. D SELINST^XPAREDT2(.INST,ENT,+PAR) M Y=INST Q:'$L(INST)
. W ! S Y="" D EDITVAL^XPAREDT2(.Y,+PAR,"I",INST) Q:(Y="")!($E(Y)=U)
. I Y="@" D DEL^XPAR(ENT,+PAR,$P(INST,U),.ERR) D Q
. . I ERR W $$ERR^XPAREDT2 Q
. . W " ...deleted"
. I $P(Y,U)'=$P(INST,U) D I ERR W $$ERR^XPAREDT2 Q
. . D REP^XPAR(ENT,+PAR,$P(INST,U),$P(Y,U),.ERR) S INST=Y
. W " ",$P(INST,U,2) D EDIT1^XPAREDT2
E S INST="1^1" D EDIT1^XPAREDT2 ;W ! before ; single valued
K ^TMP($J,"XPARWP")
Q
BLDLST(LST,PAR) ; Build list of entities allowed for this parameter
G BLDLST^XPAREDT1
;
GETCLS(X,PAR,LST) ; Choose the class of entity
G GETCLS^XPAREDT1
;
LOOKUP(X,FN) ; Lookup entry in a file and return selection as varptr
; if X has data, pass that into lookup silently
N DIC,DTOUT,DUOUT
S DIC=FN
S:$L(X) DIC(0)="M" S:'$L(X) DIC(0)="AEMQ"
D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<1) S X="" Q
S X=+Y_";"_$E(^DIC(FN,0,"GL"),2,999)
Q
ENTDISP(ENT) ; function - returns text descriptor of an entity
Q:'ENT ""
N X,FN
S FN=+$P(@(U_$P(ENT,";",2)_"0)"),U,2),X=$P(^XTV(8989.518,FN,0),U,3)
S X=" for "_X_": "_$$EXTPTR^XPARDD(+ENT,FN)
Q X
CENTER(X) ; function - writes a centered title with dashes on either side
N I,MAR
S MAR=(($S($D(IOM):IOM,1:80)-$L(X))\2)-2
Q $$DASH(MAR)_" "_X_" "_$$DASH(MAR)
DASH(N) ; function - returns N dashes
N I,X
S X="" F I=1:1:N S X=X_"-"
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPAREDIT 4146 printed Jan 18, 2025@03:41:26 Page 2
XPAREDIT ; SLC/KCM - Simple Parameter Editor ;11:15 PM 4 Feb 1998
+1 ;;7.3;TOOLKIT;**26,118**;Apr 25, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; Enter here to select parameter, then entity
+1 ; ENT: variable pointer to the entity selected
+2 ; PAR: IEN^NAME of the selected parameter
+3 WRITE !,?25,"--- Edit Parameter Values ---"
+4 NEW ENT,PAR,LST,JUST1,DIRUT,DUOUT,DTOUT
+5 FOR
WRITE !
DO GETPAR(.PAR)
if 'PAR
QUIT
Begin DoDot:1
+6 DO BLDLST(.LST,PAR)
+7 FOR
DO GETENT(.ENT,PAR,.JUST1)
if 'ENT
QUIT
DO EDIT(ENT,PAR)
if JUST1
QUIT
End DoDot:1
WRITE !,$$DASH($SELECT($DATA(IOM):IOM-1,1:78))
+8 QUIT
TED(TLT,SHWFLG,ALLENT) ; Edit parameters using a template
+1 GOTO TED^XPAREDT3
+2 ;
TEDH(TLT,SHWFLG,ALLENT) ; Edit parameters using a template, show dash headers
+1 GOTO TEDH^XPAREDT3
+2 ;
TEDIT(ENT,PAR,INST,USRX) ; Edit an instance of a parameter
+1 KILL Y
+2 IF $GET(INST)=""
DO EDITA
SET USRX=$GET(Y("X"))
IF 1
+3 IF '$TEST
DO EDIT1^XPAREDT2
SET USRX=$GET(Y("X"))
+4 IF $EXTRACT(USRX)=U
IF $EXTRACT(USRX,2)'=U
IF $LENGTH(USRX)>1
KILL DTOUT,DUOUT,DIRUT
+5 QUIT
EDITPAR(PAR) ; Edit a single parameter
+1 ; add second parameter to limit entity type? ENTTYP
+2 ; LOC,CLS,TEA,USR,DIV,SVC call LOOKUP with appropriate FN
+3 ; PKG,SYS figure out appropriate defaults (param nmsp, domain)
+4 NEW ENT
+5 IF 'PAR
SET PAR=$ORDER(^XTV(8989.51,"B",PAR,0))
+6 SET PAR=PAR_U_$PIECE(^XTV(8989.51,PAR,0),U,2)
+7 ; W $P(PAR,U,2)
+8 DO GETENT(.ENT,PAR)
if 'ENT
QUIT
+9 DO EDIT(ENT,PAR)
+10 QUIT
GETPAR(Y) ; Select parameter to edit
+1 NEW DIC,DTOUT,DUOUT,X
+2 SET DIC=8989.51
SET DIC(0)="AEMQ"
+3 SET DIC("W")="W "" "",$P(^(0),U,2)"
+4 DO ^DIC
IF Y<1
SET Y=0
+5 QUIT
GETENT(ENT,PAR,JUST1) ; Select entity to edit for a given parameter
+1 ; .ENT=entity, returned as variable pointer
+2 ; PAR=ien^name
+3 NEW X,I,LST
+4 SET JUST1=0
+5 DO BLDLST(.LST,PAR)
SET ENT=""
+6 ; if only one class of entity
IF LST=1
Begin DoDot:1
+7 ; instance for entity
SET X=LST($ORDER(LST(0)))
SET ENT=$PIECE(X,U,5)
+8 ; is fixed entry
IF ENT
SET JUST1=1
QUIT
+9 ; not fixed - do lookup
IF 'ENT
DO LOOKUP(.ENT,+X)
End DoDot:1
+10 ; otherwise
IF '$TEST
Begin DoDot:1
+11 ; choose class
DO GETCLS(.X,PAR,.LST)
+12 ; nothing selected
IF 'X
SET ENT=""
QUIT
+13 ; resolved VP returned
IF +X&(X[";")
SET ENT=X
QUIT
+14 ; fixed instance
IF $LENGTH($PIECE(LST(X),U,5))
SET ENT=$PIECE(LST(X),U,5)
QUIT
+15 ; lookup on selected file
SET ENT=""
DO LOOKUP(.ENT,+LST(X))
End DoDot:1
+16 QUIT
EDIT(ENT,PAR) ; Edit value(s) for entity/parameter
+1 NEW INST,X,Y
EDITA ; come here from TEDIT
+1 NEW ERR,INSTLST
+2 IF '$DATA(NOHDR)
WRITE !!,$$CENTER("Setting "_$PIECE(PAR,U,2)_" "_$$ENTDISP(ENT))
+3 ; multiple
IF +$PIECE(^XTV(8989.51,+PAR,0),U,3)
FOR
Begin DoDot:1
+4 IF $DATA(NOHDR)
WRITE !!,"For "_$PIECE(PAR,U,2)_" -"
+5 ; D SHWINST^XPAREDT2(ENT,+PAR,$S($D(IOSL):IOSL-4,1:20),0,.INSTLST)
+6 DO SELINST^XPAREDT2(.INST,ENT,+PAR)
MERGE Y=INST
if '$LENGTH(INST)
QUIT
+7 WRITE !
SET Y=""
DO EDITVAL^XPAREDT2(.Y,+PAR,"I",INST)
if (Y="")!($EXTRACT(Y)=U)
QUIT
+8 IF Y="@"
DO DEL^XPAR(ENT,+PAR,$PIECE(INST,U),.ERR)
Begin DoDot:2
+9 IF ERR
WRITE $$ERR^XPAREDT2
QUIT
+10 WRITE " ...deleted"
End DoDot:2
QUIT
+11 IF $PIECE(Y,U)'=$PIECE(INST,U)
Begin DoDot:2
+12 DO REP^XPAR(ENT,+PAR,$PIECE(INST,U),$PIECE(Y,U),.ERR)
SET INST=Y
End DoDot:2
IF ERR
WRITE $$ERR^XPAREDT2
QUIT
+13 WRITE " ",$PIECE(INST,U,2)
DO EDIT1^XPAREDT2
End DoDot:1
if '$LENGTH(INST)!$DATA(DIRUT)
QUIT
+14 ;W ! before ; single valued
IF '$TEST
SET INST="1^1"
DO EDIT1^XPAREDT2
+15 KILL ^TMP($JOB,"XPARWP")
+16 QUIT
BLDLST(LST,PAR) ; Build list of entities allowed for this parameter
+1 GOTO BLDLST^XPAREDT1
+2 ;
GETCLS(X,PAR,LST) ; Choose the class of entity
+1 GOTO GETCLS^XPAREDT1
+2 ;
LOOKUP(X,FN) ; Lookup entry in a file and return selection as varptr
+1 ; if X has data, pass that into lookup silently
+2 NEW DIC,DTOUT,DUOUT
+3 SET DIC=FN
+4 if $LENGTH(X)
SET DIC(0)="M"
if '$LENGTH(X)
SET DIC(0)="AEMQ"
+5 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
SET X=""
QUIT
+6 SET X=+Y_";"_$EXTRACT(^DIC(FN,0,"GL"),2,999)
+7 QUIT
ENTDISP(ENT) ; function - returns text descriptor of an entity
+1 if 'ENT
QUIT ""
+2 NEW X,FN
+3 SET FN=+$PIECE(@(U_$PIECE(ENT,";",2)_"0)"),U,2)
SET X=$PIECE(^XTV(8989.518,FN,0),U,3)
+4 SET X=" for "_X_": "_$$EXTPTR^XPARDD(+ENT,FN)
+5 QUIT X
CENTER(X) ; function - writes a centered title with dashes on either side
+1 NEW I,MAR
+2 SET MAR=(($SELECT($DATA(IOM):IOM,1:80)-$LENGTH(X))\2)-2
+3 QUIT $$DASH(MAR)_" "_X_" "_$$DASH(MAR)
DASH(N) ; function - returns N dashes
+1 NEW I,X
+2 SET X=""
FOR I=1:1:N
SET X=X_"-"
+3 QUIT X
