XTLKEFOP ; ALB/JLU ISC,IHS/OHPRD/ACC,SFISC/JC - EDIT FREQUENTLY USED OP NARR, SHORTCUT ;03/01/95 15:31
;;7.3;TOOLKIT;;Apr 25, 1995
;
C ;GETS THE CODE FROM THE NECESSARY FILE.
W ! S DIC("A")="Which code in the "_$P(^DIC(+XTLKY,0),U)_" file?: ",DIC(0)="AEMQ",DIC=^DIC(+XTLKY,0,"GL") D ^DIC I Y<1 K DIC Q
C1 S XTLKCOD=+Y_";"_$P(DIC,U,2),XTLKCOD1=$P(Y,U,2)
K DIC Q
;
QU(XTLKF) ;Deciding on which file proc/diag Etc.
;XTLKF=filename (optional)
W !!
I $G(XTLKF)="" S DIC("A")=$S($D(XTLKOPP):"Print "_XTLKOPP_" for ",$D(XTLKOP):"Additions/Modifications to ",1:"Lookup on ")_$S($D(XTLKOP):XTLKOP_" in ",1:"")_"which file?: ",DIC(0)="AEMQ",DIC="^XT(8984.4," D ^DIC K DIC Q:Y<1
I $G(XTLKF)'="" S X=XTLKF,DIC=8984.4,DIC(0)="MQZ" D ^DIC K DIC I Y<1 W "...",XTLKF," not found in local lookup file." Q
S XTLKY=Y,XTLKPF=+$O(^DD(8984.2,.02,"V","B",+Y,"")) G:'XTLKPF KL
S XTLKPF=$P(^DD(8984.2,.02,"V",XTLKPF,0),U,4),XTLKUT=1
Q
;
KL ;Exit line.
K XTLKY,XTLKPF,XTLKGL,XTLKUT,DIC,DIE,DR,JL,DA,DIR,X,Y,XTLKCOD,XTLKCOD1,XTLKOP Q
;
;Editing synonym file.
SY D QU() I Y<1 D KL Q
SY1 ;
W ! S (DIC,DIE)="^XT(8984.3,",DIC(0)="AELMQ",DIC("DR")="[XTLK EDIT SYN]",DIC("S")="I $P(^(0),U,2)="_+XTLKY,DLAYGO="8984.3" D ^DIC K DLAYGO,DIC("S") I Y<1 G SY
I '$P(Y,U,3) S DA=+Y,DR="[XTLK EDIT SYN]" D ^DIE
K DIC,DIE,DA,DR,Y
G SY1
;
;Editing keyword file.
KE D QU() I Y<1 D KL Q
D C I Y<1 D KL Q
KE1 R !,"Select LOCAL KEYWORD NAME: ",X:DTIME I '$T!(X[U)!(X="") D KL G KE Q
I X["?" D HL G KE1
W ! S (DIE,DIC)="^XT(8984.1,",DIC(0)="EILMQ",DIC("DR")="[XTLK EDIT KEY]",DIC("S")="I $P(^(0),U,2)[JL&($P(^(0),U,3)[XTLKCOD1)",JL=$P(^DIC(+XTLKY,0,"GL"),U,2),DLAYGO="8984.1" D ^DIC K DLAYGO,DIC("S") G:Y<1 KE1
I '$P(Y,U,3) S DA=+Y,DR="[XTLK EDIT KEY]" D ^DIE
K DIE,DIC
G KE1
;
;Editing shortcut file.
SH D QU() I Y<1 D KL Q
SH1 ;
W ! S (DIE,DIC)="^XT(8984.2,",DIC(0)="AELMQ",DIC("DR")="[XTLK EDIT SHORT]",DIC("S")="I $P(^(0),U,2)[JL",JL=$P(^DIC(+XTLKY,0,"GL"),U,2),DLAYGO="8984.2" D ^DIC K DLAYGO,DIC("S") G:Y<1 SH
I '$P(Y,U,3) S DA=+Y,DR="[XTLK EDIT SHORT]" D ^DIE
K DIE,DIC
G SH1
;
LL ;Interactive Entry point to edit Local Lookup File.
D LL1 Q:$G(Y)=-1!($D(DTOUT))!($D(DUOUT))
D LL2
D LL3
K XTLKPRE,DIC,DIE,DA,Y,DR,JL0,JLY,XTLKLP
Q
;
LL1 ;
S (DIE,DIC)="^XT(8984.4,",DIC(0)="EALMQZ" D ^DIC K DIC
Q:Y=-1!($D(DTOUT))!($D(DUOUT))
;S X=$P(Y,U,2),(DIE,DIC)="^XT(8984.4,",DIC(0)="ELMQZ",DIC("DR")="[XTLK EDIT LOOKUP]" D ^DIC
S JL0=Y(0,0),JLY=+Y
S DIE("NO^")="",DA=+Y,DR="[XTLK EDIT LOOKUP]" D ^DIE
Q:$D(DTOUT)
;I '$P(Y,U,3) S DA=+Y,DR="[XTLK EDIT LOOKUP]" D ^DIE Q
W !!,"...Ok, will now setup KEYWORD and SHORTCUT file DD's"
W !," to allow terms for '",JL0,"' entries..."
Q
LL2 ;
S XTLKPRE=$G(XTLKPRE)
F XTLKLP=8984.1,8984.2 D
.S (DIE,DIC)="^DD("_XTLKLP_",.02,""V"",",DIC(0)="L",X=+JLY,DA(1)=.02,DA(2)=XTLKLP D ^DIC K DIC Q:Y=-1 D S,^DIE
Q
LL3 ;
;S ^DD(JLY,0,"DIC")="XTLKDICL"
W !,"<REMINDER> Using 'Edit File', set the lookup routine, XTLKDICL, in ",JL0," DD."
K XTLKPRE,DIC,DIE,DA,Y G LL1
Q
;
S S DA=+Y,DR=".02////"_JL0_";.03////"_DA_";.05////n;.06////n;.04"_$S(XTLKPRE="":"",1:"////"_XTLKPRE)_";S XTLKPRE=X"
Q
;Entry point to delete from 8984.4 and the variable pts in 8984.1,8984.2
DD D DD1
K DIC,DIE,DR,DIR,XTLKY,XTLKLP,DIK,DA,JL0
Q
;
DD1 S DIC="^XT(8984.4,",DIC(0)="AEMQZ" D ^DIC Q:Y<1 W !,$C(7)
S (XTLKY,DA)=+Y,JL0=Y(0,0),DIR(0)="Y",DIR("A")="Are you sure you want to delete "_Y(0,0) D ^DIR Q:Y<1
S XTLKJG=$P(^DIC(+XTLKY,0,"GL"),U,2)
I $D(^XT(8984.2,"AC",XTLKJG))!($D(^XT(8984.3,"AC",XTLKJG)))!($D(^XT(8984.1,"AD",+XTLKY))) W $C(7),!!,"There are still Keywords, Shortcuts and/or Synonyms for this entry.",!," <<Nothing Deleted!>>" Q
W !!,"Deleting from Local Lookup file....."
S DIK="^XT(8984.4," D ^DIK
W !,"Deleting variable pointers from Local Keyword and Shortcut files."
F XTLKLP=8984.1,8984.2 S DIK="^DD("_XTLKLP_",.02,""V"",",DA(1)=.02,DA(2)=XTLKLP,DA=$O(@($NA(^DD(XTLKLP,.02,"V","B",+XTLKY,0)))) D ^DIK
W !,"<REMINDER> Delete the lookup routine, XTLKDICL, from ",JL0," DD."
;K ^DD(XTLKY,0,"DIC")
Q
;HELP ENTRY POINT
HL W !,"ANSWER WITH LOCAL KEYWORD NAME, OR CODE",!,"CHOOSE FROM:"
S (XTLKC,XTLKF)=0
F LP=0:0 S LP=$O(^XT(8984.1,"C",XTLKCOD1_" ",LP)) Q:'LP D WR Q:XTLKF
K LP,XTLKC,XTLKF Q
WR I XTLKC>(IOSL-4) S DIR(0)="E" D ^DIR I 'Y S XTLKF=1 Q
Q:'$D(^XT(8984.1,LP,0)) W !,$P(^(0),U)," ",$P(^(0),U,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTLKEFOP 4462 printed Dec 13, 2024@02:41:20 Page 2
XTLKEFOP ; ALB/JLU ISC,IHS/OHPRD/ACC,SFISC/JC - EDIT FREQUENTLY USED OP NARR, SHORTCUT ;03/01/95 15:31
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 ;
C ;GETS THE CODE FROM THE NECESSARY FILE.
+1 WRITE !
SET DIC("A")="Which code in the "_$PIECE(^DIC(+XTLKY,0),U)_" file?: "
SET DIC(0)="AEMQ"
SET DIC=^DIC(+XTLKY,0,"GL")
DO ^DIC
IF Y<1
KILL DIC
QUIT
C1 SET XTLKCOD=+Y_";"_$PIECE(DIC,U,2)
SET XTLKCOD1=$PIECE(Y,U,2)
+1 KILL DIC
QUIT
+2 ;
QU(XTLKF) ;Deciding on which file proc/diag Etc.
+1 ;XTLKF=filename (optional)
+2 WRITE !!
+3 IF $GET(XTLKF)=""
SET DIC("A")=$SELECT($DATA(XTLKOPP):"Print "_XTLKOPP_" for ",$DATA(XTLKOP):"Additions/Modifications to ",1:"Lookup on ")_$SELECT($DATA(XTLKOP):XTLKOP_" in ",1:"")_"which file?: "
SET DIC(0)="AEMQ"
SET DIC="^XT(8984.4,"
DO ^DIC
KILL DIC
if Y<1
QUIT
+4 IF $GET(XTLKF)'=""
SET X=XTLKF
SET DIC=8984.4
SET DIC(0)="MQZ"
DO ^DIC
KILL DIC
IF Y<1
WRITE "...",XTLKF," not found in local lookup file."
QUIT
+5 SET XTLKY=Y
SET XTLKPF=+$ORDER(^DD(8984.2,.02,"V","B",+Y,""))
if 'XTLKPF
GOTO KL
+6 SET XTLKPF=$PIECE(^DD(8984.2,.02,"V",XTLKPF,0),U,4)
SET XTLKUT=1
+7 QUIT
+8 ;
KL ;Exit line.
+1 KILL XTLKY,XTLKPF,XTLKGL,XTLKUT,DIC,DIE,DR,JL,DA,DIR,X,Y,XTLKCOD,XTLKCOD1,XTLKOP
QUIT
+2 ;
+3 ;Editing synonym file.
SY DO QU()
IF Y<1
DO KL
QUIT
SY1 ;
+1 WRITE !
SET (DIC,DIE)="^XT(8984.3,"
SET DIC(0)="AELMQ"
SET DIC("DR")="[XTLK EDIT SYN]"
SET DIC("S")="I $P(^(0),U,2)="_+XTLKY
SET DLAYGO="8984.3"
DO ^DIC
KILL DLAYGO,DIC("S")
IF Y<1
GOTO SY
+2 IF '$PIECE(Y,U,3)
SET DA=+Y
SET DR="[XTLK EDIT SYN]"
DO ^DIE
+3 KILL DIC,DIE,DA,DR,Y
+4 GOTO SY1
+5 ;
+6 ;Editing keyword file.
KE DO QU()
IF Y<1
DO KL
QUIT
+1 DO C
IF Y<1
DO KL
QUIT
KE1 READ !,"Select LOCAL KEYWORD NAME: ",X:DTIME
IF '$TEST!(X[U)!(X="")
DO KL
GOTO KE
QUIT
+1 IF X["?"
DO HL
GOTO KE1
+2 WRITE !
SET (DIE,DIC)="^XT(8984.1,"
SET DIC(0)="EILMQ"
SET DIC("DR")="[XTLK EDIT KEY]"
SET DIC("S")="I $P(^(0),U,2)[JL&($P(^(0),U,3)[XTLKCOD1)"
SET JL=$PIECE(^DIC(+XTLKY,0,"GL"),U,2)
SET DLAYGO="8984.1"
DO ^DIC
KILL DLAYGO,DIC("S")
if Y<1
GOTO KE1
+3 IF '$PIECE(Y,U,3)
SET DA=+Y
SET DR="[XTLK EDIT KEY]"
DO ^DIE
+4 KILL DIE,DIC
+5 GOTO KE1
+6 ;
+7 ;Editing shortcut file.
SH DO QU()
IF Y<1
DO KL
QUIT
SH1 ;
+1 WRITE !
SET (DIE,DIC)="^XT(8984.2,"
SET DIC(0)="AELMQ"
SET DIC("DR")="[XTLK EDIT SHORT]"
SET DIC("S")="I $P(^(0),U,2)[JL"
SET JL=$PIECE(^DIC(+XTLKY,0,"GL"),U,2)
SET DLAYGO="8984.2"
DO ^DIC
KILL DLAYGO,DIC("S")
if Y<1
GOTO SH
+2 IF '$PIECE(Y,U,3)
SET DA=+Y
SET DR="[XTLK EDIT SHORT]"
DO ^DIE
+3 KILL DIE,DIC
+4 GOTO SH1
+5 ;
LL ;Interactive Entry point to edit Local Lookup File.
+1 DO LL1
if $GET(Y)=-1!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+2 DO LL2
+3 DO LL3
+4 KILL XTLKPRE,DIC,DIE,DA,Y,DR,JL0,JLY,XTLKLP
+5 QUIT
+6 ;
LL1 ;
+1 SET (DIE,DIC)="^XT(8984.4,"
SET DIC(0)="EALMQZ"
DO ^DIC
KILL DIC
+2 if Y=-1!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+3 ;S X=$P(Y,U,2),(DIE,DIC)="^XT(8984.4,",DIC(0)="ELMQZ",DIC("DR")="[XTLK EDIT LOOKUP]" D ^DIC
+4 SET JL0=Y(0,0)
SET JLY=+Y
+5 SET DIE("NO^")=""
SET DA=+Y
SET DR="[XTLK EDIT LOOKUP]"
DO ^DIE
+6 if $DATA(DTOUT)
QUIT
+7 ;I '$P(Y,U,3) S DA=+Y,DR="[XTLK EDIT LOOKUP]" D ^DIE Q
+8 WRITE !!,"...Ok, will now setup KEYWORD and SHORTCUT file DD's"
+9 WRITE !," to allow terms for '",JL0,"' entries..."
+10 QUIT
LL2 ;
+1 SET XTLKPRE=$GET(XTLKPRE)
+2 FOR XTLKLP=8984.1,8984.2
Begin DoDot:1
+3 SET (DIE,DIC)="^DD("_XTLKLP_",.02,""V"","
SET DIC(0)="L"
SET X=+JLY
SET DA(1)=.02
SET DA(2)=XTLKLP
DO ^DIC
KILL DIC
if Y=-1
QUIT
DO S
DO ^DIE
End DoDot:1
+4 QUIT
LL3 ;
+1 ;S ^DD(JLY,0,"DIC")="XTLKDICL"
+2 WRITE !,"<REMINDER> Using 'Edit File', set the lookup routine, XTLKDICL, in ",JL0," DD."
+3 KILL XTLKPRE,DIC,DIE,DA,Y
GOTO LL1
+4 QUIT
+5 ;
S SET DA=+Y
SET DR=".02////"_JL0_";.03////"_DA_";.05////n;.06////n;.04"_$SELECT(XTLKPRE="":"",1:"////"_XTLKPRE)_";S XTLKPRE=X"
+1 QUIT
+2 ;Entry point to delete from 8984.4 and the variable pts in 8984.1,8984.2
DD DO DD1
+1 KILL DIC,DIE,DR,DIR,XTLKY,XTLKLP,DIK,DA,JL0
+2 QUIT
+3 ;
DD1 SET DIC="^XT(8984.4,"
SET DIC(0)="AEMQZ"
DO ^DIC
if Y<1
QUIT
WRITE !,$CHAR(7)
+1 SET (XTLKY,DA)=+Y
SET JL0=Y(0,0)
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete "_Y(0,0)
DO ^DIR
if Y<1
QUIT
+2 SET XTLKJG=$PIECE(^DIC(+XTLKY,0,"GL"),U,2)
+3 IF $DATA(^XT(8984.2,"AC",XTLKJG))!($DATA(^XT(8984.3,"AC",XTLKJG)))!($DATA(^XT(8984.1,"AD",+XTLKY)))
WRITE $CHAR(7),!!,"There are still Keywords, Shortcuts and/or Synonyms for this entry.",!," <<Nothing Deleted!>>"
QUIT
+4 WRITE !!,"Deleting from Local Lookup file....."
+5 SET DIK="^XT(8984.4,"
DO ^DIK
+6 WRITE !,"Deleting variable pointers from Local Keyword and Shortcut files."
+7 FOR XTLKLP=8984.1,8984.2
SET DIK="^DD("_XTLKLP_",.02,""V"","
SET DA(1)=.02
SET DA(2)=XTLKLP
SET DA=$ORDER(@($NAME(^DD(XTLKLP,.02,"V","B",+XTLKY,0))))
DO ^DIK
+8 WRITE !,"<REMINDER> Delete the lookup routine, XTLKDICL, from ",JL0," DD."
+9 ;K ^DD(XTLKY,0,"DIC")
+10 QUIT
+11 ;HELP ENTRY POINT
HL WRITE !,"ANSWER WITH LOCAL KEYWORD NAME, OR CODE",!,"CHOOSE FROM:"
+1 SET (XTLKC,XTLKF)=0
+2 FOR LP=0:0
SET LP=$ORDER(^XT(8984.1,"C",XTLKCOD1_" ",LP))
if 'LP
QUIT
DO WR
if XTLKF
QUIT
+3 KILL LP,XTLKC,XTLKF
QUIT
WR IF XTLKC>(IOSL-4)
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET XTLKF=1
QUIT
+1 if '$DATA(^XT(8984.1,LP,0))
QUIT
WRITE !,$PIECE(^(0),U)," ",$PIECE(^(0),U,3)
+2 QUIT
