- 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