- XQ5 ;SF/GFT,MJM,KLD,TK - Menu edit utilities [XUEDITOPT] ;01/30/2008
- ;;8.0;KERNEL;**44,130,484,627**;Jul 10, 1995;Build 3
- ;Per VHA Directive 6402, this routine should not be modified.
- ; Option & Input Template: XUEDITOPT
- DIP ;
- K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1)
- S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- DIP1 ;
- D:$G(DUZ0) PRNT
- D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0
- BY ;
- D:$G(DUZ0) SORT
- K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1)
- S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- BY1 ;
- D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR
- TEM ;
- I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY
- S XQ(64)=X
- FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7," DELETED!" S:$D(X) XQ(65)=X
- TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7," DELETED!" S:$D(X) XQ(66)=X
- D PUT G Q1
- DIE ;
- S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
- K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1)
- G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
- DIE1 ;
- D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1
- PUT S X=0 F S X=$O(XQ(X)) Q:X'>0 S ^DIC(19,DA,X)=XQ(X)
- Q
- ;
- Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC"
- Q1 K XQDIC,XQ,Y S DIC=DIE Q
- ;
- DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2)
- S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
- I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q
- W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
- S %=$S(XQ(31)["L":0,1:2) D YN^DICN
- I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L"
- I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L")
- A Q
- ;
- DIQ ;
- S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0)
- K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: "
- I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2)
- G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- DIQ1 ;
- D ^DIC K DIC G:Y<0 Q S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2)
- S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
- D PUT G Q1
- ;
- NAME ;
- I $E(X,1)="Z" S %=1,%1="Local" Q
- F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
- I $E(X,1)="A" S %=1,%1="Local" Q
- I 0
- Q
- NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q
- ;
- CHKNAME ;Called from the input transform of the .01 field of the Option File
- Q:$D(DIFROM)!($D(ZTQUEUED)) K XQPK
- I $D(DIC(0))#2,DIC(0)'["E" Q
- D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q
- D EN^DDIOL(" Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q
- ;
- PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",!
- W !,"By selecting a new Print/Sort Template below, your defaults will"
- W !,"be changed. Your defaults are currently set as follows (see below)."
- W !,"Should you desire to keep the defaults as they are, or to revise"
- W !,"one or more, enter an '^' up-arrow, without selecting a new"
- W !,"template name."
- W !!,?23,"Default Values",!,?23,"==============",!
- W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
- W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
- W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
- W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
- W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
- W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
- Q
- ;
- SORT W !,?16,"*** IMPORTANT PLEASE READ ***",!
- W !,"By selecting a new Sort Template below, your defaults will be"
- W !,"changed. Your defaults are currently set as follows (see below)."
- W !,"Should you desire to keep the defaults as they are, or to revise"
- W !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
- W !,"Template."
- W !!,?23,"Default Values",!,?23,"==============",!
- W ?5,"BY: "_$$GET1^DIQ(19,DA,64)
- W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
- W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
- Q
- TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
- T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1
- CLEAR ;Clear fields not used by this option.
- I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
- I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
- I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%)
- Q
- CLEAR1 S XQI=0 F S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0 S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI)
- K XQI,XQJ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ5 5710 printed Jan 18, 2025@03:06 Page 2
- XQ5 ;SF/GFT,MJM,KLD,TK - Menu edit utilities [XUEDITOPT] ;01/30/2008
- +1 ;;8.0;KERNEL;**44,130,484,627**;Jul 10, 1995;Build 3
- +2 ;Per VHA Directive 6402, this routine should not be modified.
- +3 ; Option & Input Template: XUEDITOPT
- DIP ;
- +1 KILL DIC
- SET DIC=.4
- SET DIC(0)="AEQMZ"
- IF $DATA(^DIC(19,DA,63))
- IF ^(63)?1"[".E1"]"
- SET DIC("B")=$EXTRACT(^(63),2,$LENGTH(^(63))-1)
- +2 SET DUZ0=$SELECT(DUZ(0)="@"!$DATA(^XUSEC("XUMGR",DUZ)):1,1:0)
- if DUZ0
- GOTO DIP1
- SET DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- DIP1 ;
- +1 if $GET(DUZ0)
- DO PRNT
- +2 DO ^DIC
- KILL DIC
- if Y<0&(DUZ(0)'="@")
- GOTO Q
- if Y<0&(DUZ0)
- GOTO Q1
- SET XQDIC=+$PIECE(Y(0),U,4)
- if XQDIC'>1
- GOTO Q
- SET XQ=$PIECE(^DIC(XQDIC,0),U,1)_U_XQDIC
- SET XQ(63)="["_$PIECE(Y,U,2)_"]"
- SET XQ(60)=$PIECE(^(0,"GL"),U,2)
- SET XQ(62)=0
- BY ;
- +1 if $GET(DUZ0)
- DO SORT
- +2 KILL DIC
- SET DIC=.401
- SET DIC(0)="AEQMZ"
- IF $DATA(^DIC(19,DA,64))
- IF ^(64)?1"[".E1"]"
- SET DIC("B")=$EXTRACT(^(64),2,$LENGTH(^(64))-1)
- +3 SET DIC("S")="I $P(^(0),U,4)=XQDIC"
- if DUZ0
- GOTO BY1
- SET DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- BY1 ;
- +1 DO ^DIC
- KILL DIC
- if X=""
- GOTO TEM
- if Y<0
- GOTO Q
- SET XQDIC=+$PIECE(Y(0),U,4)
- SET XQ=$PIECE(^DIC(XQDIC,0),U,1)_U_XQDIC
- SET XQ(64)="["_$PIECE(Y,U,2)_"]"
- GOTO FR
- TEM ;
- +1 IF +X=X
- IF '$DATA(^DD(+$PIECE(XQ,U,2),X,0))
- WRITE *7,"NO SUCH FIELD NUMBER"
- KILL X
- GOTO BY
- +2 SET XQ(64)=X
- FR KILL X
- SET Y=$SELECT($DATA(^DIC(19,DA,65)):^(65),1:"")
- WRITE !,"START WITH: ",$SELECT(Y]"":Y,1:"FIRST")_"// "
- READ X:DTIME
- if X=U
- GOTO Q
- if X=""
- SET X=Y
- if X="?"
- WRITE !?4,"ENTER IN 'FR' FORMAT"
- if X="?"
- GOTO FR
- if X="@"
- KILL X,^DIC(19,DA,65)
- if '$DATA(X)
- WRITE *7," DELETED!"
- if $DATA(X)
- SET XQ(65)=X
- TO KILL X
- SET Y=$SELECT($DATA(^DIC(19,DA,66)):^(66),1:"")
- WRITE !,"GO TO: ",$SELECT(Y]"":Y,1:"LAST")_"// "
- READ X:DTIME
- if X=U
- GOTO Q
- if X=""
- SET X=Y
- if X="?"
- WRITE !?4,"ENTER IN 'TO' FORMAT"
- if X="?"
- GOTO TO
- if X="@"
- KILL X,^DIC(19,DA,66)
- if '$DATA(X)
- WRITE *7," DELETED!"
- if $DATA(X)
- SET XQ(66)=X
- +1 DO PUT
- GOTO Q1
- DIE ;
- +1 SET DUZ0=$SELECT(DUZ(0)="@"!$DATA(^XUSEC("XUMGR",DUZ)):1,1:0)
- +2 KILL DIC,XQ
- SET DIC=.402
- SET DIC(0)="AQEMZ"
- IF $DATA(^DIC(19,DA,51))
- IF ^(51)?1"[".E1"]"
- SET DIC("B")=$EXTRACT(^(51),2,$LENGTH(^(51))-1)
- +3 if DUZ0
- GOTO DIE1
- SET DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q"
- DIE1 ;
- +1 DO ^DIC
- KILL DIC
- if Y<0&(DUZ(0)'="@")
- GOTO Q
- if Y<0&(DUZ0)
- GOTO Q1
- SET XQDIC=""
- SET XQDIC=+$PIECE(Y(0),U,4)
- if 'XQDIC
- GOTO Q
- SET XQ(51)="["_$PIECE(Y,U,2)_"]"
- DO DIC
- SET XQ(50)=XQ(30)
- DO PUT
- GOTO Q1
- PUT SET X=0
- FOR
- SET X=$ORDER(XQ(X))
- if X'>0
- QUIT
- SET ^DIC(19,DA,X)=XQ(X)
- +1 QUIT
- +2 ;
- Q WRITE *7,!,"NO CHANGE MADE TO OPTION LOGIC"
- Q1 KILL XQDIC,XQ,Y
- SET DIC=DIE
- QUIT
- +1 ;
- DIC SET XQ=$PIECE(^DIC(XQDIC,0),U,1)
- SET XQ(30)=$PIECE(^(0,"GL"),U,2)
- +1 SET XQ(31)=$GET(^DIC(19,DA,31))
- if XQ(31)=""
- SET XQ(31)="AEMQ"
- +2 IF $DATA(^DIC(XQDIC,0,"LAYGO"))
- IF DUZ(0)'="@"
- SET Y=$LENGTH(^("LAYGO"))
- IF Y
- FOR %=1:1
- IF DUZ(0)[$EXTRACT(^("LAYGO"),%)
- if %>Y
- GOTO A
- QUIT
- +3 WRITE !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
- +4 SET %=$SELECT(XQ(31)["L":0,1:2)
- DO YN^DICN
- +5 IF %=1
- IF XQ(31)'["L"
- SET XQ(31)=XQ(31)_"L"
- +6 IF %=2
- IF XQ(31)["L"
- SET XQ(31)=$TRANSLATE(XQ(31),"L")
- A QUIT
- +1 ;
- DIQ ;
- +1 SET DUZ0=$SELECT(DUZ(0)="@"!$DATA(^XUSEC("XUMGR",DUZ)):1,1:0)
- +2 KILL DIC,XQ
- SET DIC=1
- SET DIC(0)="AEQMZ"
- SET DIC("A")="INQUIRE TO WHAT FILE: "
- +3 IF $DATA(^DIC(19,DA,30))
- IF ^(30)["("
- IF @("$D(^"_^(30)_"0))")
- SET DIC("B")=+$PIECE(^(0),U,2)
- +4 if DUZ0
- GOTO DIQ1
- SET DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
- DIQ1 ;
- +1 DO ^DIC
- KILL DIC
- if Y<0
- GOTO Q
- SET (XQ(80),XQ(30))=$PIECE(^(0,"GL"),U,2)
- +2 SET XQ(31)=$GET(^DIC(19,DA,31))
- if XQ(31)=""
- SET XQ(31)="AEMQ"
- +3 DO PUT
- GOTO Q1
- +4 ;
- NAME ;
- +1 IF $EXTRACT(X,1)="Z"
- SET %=1
- SET %1="Local"
- QUIT
- +2 FOR %=4:-1:2
- if $DATA(^DIC(9.4,"C",$EXTRACT(X,1,%)))
- GOTO NAMEOK
- +3 IF $EXTRACT(X,1)="A"
- SET %=1
- SET %1="Local"
- QUIT
- +4 IF 0
- +5 QUIT
- NAMEOK SET %1=$ORDER(^DIC(9.4,"C",$EXTRACT(X,1,%),0))
- if %1=""
- SET %1=-1
- if $DATA(^DIC(9.4,%1,0))
- SET %1=$PIECE(^(0),U,1)
- SET XQPK=%1
- IF 1
- QUIT
- +1 ;
- CHKNAME ;Called from the input transform of the .01 field of the Option File
- +1 if $DATA(DIFROM)!($DATA(ZTQUEUED))
- QUIT
- KILL XQPK
- +2 IF $DATA(DIC(0))#2
- IF DIC(0)'["E"
- QUIT
- +3 DO NAME
- IF '$TEST
- DO EN^DDIOL("Not a known package or a local namespace.")
- QUIT
- +4 DO EN^DDIOL(" Located in the "_$EXTRACT(X,1,%)_" ("_%1_") namespace.")
- QUIT
- +5 ;
- PRNT WRITE !,?16,"*** IMPORTANT PLEASE READ ***",!
- +1 WRITE !,"By selecting a new Print/Sort Template below, your defaults will"
- +2 WRITE !,"be changed. Your defaults are currently set as follows (see below)."
- +3 WRITE !,"Should you desire to keep the defaults as they are, or to revise"
- +4 WRITE !,"one or more, enter an '^' up-arrow, without selecting a new"
- +5 WRITE !,"template name."
- +6 WRITE !!,?23,"Default Values",!,?23,"==============",!
- +7 WRITE !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
- +8 WRITE ?40,"L.: "_$$GET1^DIQ(19,DA,62)
- +9 WRITE !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
- +10 WRITE ?40,"BY: "_$$GET1^DIQ(19,DA,64)
- +11 WRITE !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
- +12 WRITE ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
- +13 QUIT
- +14 ;
- SORT WRITE !,?16,"*** IMPORTANT PLEASE READ ***",!
- +1 WRITE !,"By selecting a new Sort Template below, your defaults will be"
- +2 WRITE !,"changed. Your defaults are currently set as follows (see below)."
- +3 WRITE !,"Should you desire to keep the defaults as they are, or to revise"
- +4 WRITE !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
- +5 WRITE !,"Template."
- +6 WRITE !!,?23,"Default Values",!,?23,"==============",!
- +7 WRITE ?5,"BY: "_$$GET1^DIQ(19,DA,64)
- +8 WRITE !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
- +9 WRITE ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
- +10 QUIT
- TEST WRITE !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
- T1 READ !,"NAME: ",X:DTIME," "
- if X=""
- QUIT
- DO CHKNAME
- GOTO T1
- CLEAR ;Clear fields not used by this option.
- +1 IF "EMPRSOQ"[X
- XECUTE "F %="_$SELECT("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
- +2 IF "AI"[X
- XECUTE "F %="_$SELECT("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)"
- +3 IF "OQ"'[X
- FOR %=100,100.1,100.2
- IF $DATA(^DIC(19,DA,%))
- KILL ^DIC(19,DA,%)
- +4 QUIT
- CLEAR1 SET XQI=0
- FOR
- SET XQI=$ORDER(^DIC(19,DA,%,XQI))
- if XQI'>0
- QUIT
- SET XQJ=$PIECE(^(XQI,0),U)
- KILL ^DIC(19,"AD",$EXTRACT(XQJ,1,30),DA,XQI)
- +1 KILL XQI,XQJ
- +2 QUIT