LEXNDX4 ;ISL/KER - Set/kill indexes (Part 4) Link ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.011) N/A
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
; YN^DICN ICR 10009
;
LINK ; Link a Keyword to an expression
I $D(^LEX(757.05,DA,1,"B",1)) Q
W !,"LINK" S X=LEXBY D PTX^LEXTOKN N LEXTMP
S (LEXTMP,LEXLINK,LEXKEY)=""
I ^TMP("LEXTKN",$J,0)>0 D
. N LEXTMP S LEXTMP=$O(^TMP("LEXTKN",$J,0)) Q:LEXTMP'>0
. S LEXKEY=$O(^TMP("LEXTKN",$J,LEXTMP,LEXKEY))
Q:'$L(LEXKEY) S LEXREC=0 F S LEXREC=$O(^LEX(757.01,"AWRD",LEXKEY,LEXREC)) Q:+LEXREC=0!(LEXLINK[U) D
. I ^TMP("LEXTKN",$J,0)=1 S LEXASK=1
. I ^TMP("LEXTKN",$J,0)>1 S LEXASK=1 D
. . S LEXA=1 F S LEXA=$O(^TMP("LEXTKN",$J,LEXA)) Q:+LEXA'>0 D
. . . S LEXAKEY="",LEXAKEY=$O(^TMP("LEXTKN",$J,LEXA,LEXAKEY)) Q:'$L($G(LEXAKEY))
. . . S LEXSRC=$$UP^XLFSTR(^LEX(757.01,LEXREC,0))
. . . I LEXSRC'[$E(LEXAKEY,1,4) S LEXASK=0
. S LEXLINK="" I LEXASK D
. . I $D(^LEX(757.05,DA,1,"B",LEXREC)) Q
MOK . . ; Prompt to Map/Link a keyword to an expression
. . W !!,"Map ",^LEX(757.01,LEXREC,0),!,"To ",LEXREP,!,"OK" S %=1 D YN^DICN S LEXLINK=% I %=-1 W ! S LEXLINK=U Q
. . I '% W !!,"By answering ""Yes"", an index reference will be made to link the",!,"term to the key word ",LEXREP G MOK
. I +LEXLINK=1 D
. . N LEXYPE,LEXT S ^LEX(757.05,"ALINK",DA,LEXREC)=""
. . S LEXYPE=+($P($G(^LEX(757.01,LEXREC,1)),U,2))
. . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
. . S:+LEXT>0 ^LEX(757.01,"AWRD",LEXREP,LEXREC,"LINKED")="" W !
. . I $D(^LEX(757.05,DA,1,0)) D
. . . S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
. . . . S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
. . . I '$D(^LEX(757.05,DA,1,"B",LEXREC)) D
. . . . S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S LEXLNK=LEXSREC+1
. . . . K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=LEXREC
. . . . S ^LEX(757.05,DA,1,"B",LEXREC,LEXLNK)="",$P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
. . . . S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
. . I '$D(^LEX(757.05,DA,1,0)) S ^LEX(757.05,DA,1,1,0)=LEXREC,^LEX(757.05,DA,1,"B",LEXREC,1)="",^LEX(757.05,DA,1,0)="^757.53P^1^1"
D VERIFY K ^TMP("LEXTKN",$J),^TMP("LEXTKN",$J,0),LEXSRC,LEXKEY,LEXA,LEXAKEY,LEXREC,LEXASK,LEXLINK
Q
VERIFY ; Display linkages made for user verification
Q:'$D(DA)
I '$D(^LEX(757.05,DA,1,0)) W !,"No Word Linkages Created",! Q
W !!,$P(^LEX(757.05,DA,0),"^",1)," has been linked to: ",!
N LEXSREC S LEXSREC=0
F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
. W !,?4,$E(^LEX(757.01,^LEX(757.05,DA,1,LEXSREC,0),0),1,75)
W ! I +$$OK D K LEXSREC,LEXLNK Q
. S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S LEXLNK=LEXSREC+1
. K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=1,^LEX(757.05,DA,1,"B",1,LEXLNK)=""
. S $P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
. S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
D UNLINK
Q
OK(LEXOK) ; Get user response
OK1 ; Prompt "Is this correct"
W !,"Is this correct" S %=1 D YN^DICN
I %=-1!(%=2) K %,%Y Q 0
I %=1 K %,%Y Q 1
I '% D G OK1
. W !,"By confirming the word linkages displayed above, a look-up"
. W !,"conducted on ",$P(^LEX(757.05,DA,0),"^",1)
. W " will retrieve the linked terms."
Q 0
RELINK ; Relink Keywords to expressions
Q:'$D(DA) Q:'$D(^LEX(757.05,DA,1,1,0))
D SUB N LEXMC,LEXCTR,LEXSREC,LEXERM S (LEXCTR,LEXSREC)=0,LEXERM=$P(^LEX(757.05,DA,0),"^",1)
F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
. S LEXCTR=LEXCTR+1
. S ^LEX(757.05,DA,1,0)="^757.53P^"_LEXCTR_"^"_LEXCTR
. S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
. I ^LEX(757.05,DA,1,LEXSREC,0)'=1 D
. . S LEXMC=^LEX(757.05,DA,1,LEXSREC,0)
. . N LEXYPE,LEXT S LEXYPE=+($P($G(^LEX(757.01,LEXMC,1)),U,2))
. . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
. . I +LEXT>0 D
. . . S ^LEX(757.01,"AWRD",LEXERM,LEXMC,"LINKED")=""
. . . N X S X=LEXERM I $L(X) D
. . . . Q:$D(DCNT)&($G(DIKSAVE(1))["ASL")
. . . . Q:$D(DCNT)&($G(DIK(1))["ASL")
. . . . Q:$D(DCNT)&('$D(DIK(1)))
. . . . D SSF^LEXNDX6
. . S ^LEX(757.05,"ALINK",DA,LEXMC)=""
K LEXSREC,LEXERM N DCNT,DIKSAVE
Q
UNLINK ; Unlink a Keyword from an expression
Q:'$D(^LEX(757.05,DA,1,0)) N LEXMC,LEXLNK
S LEXMC=0 F S LEXMC=$O(^LEX(757.05,DA,1,"B",LEXMC)) Q:+LEXMC=0 D
. S LEXLNK=0 F S LEXLNK=$O(^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)) Q:+LEXLNK=0 D
. . S LEXWRD=$P(^LEX(757.05,DA,0),U,1)
. . K ^LEX(757.01,"AWRD",LEXWRD,LEXMC,"LINKED")
. . N X S X=LEXWRD
. . I $D(X),X=0 D
. . . K ^LEX(757.05,DA,1,LEXLNK,0)
. . . K ^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)
. . . K ^LEX(757.05,DA,1,0)
. . I $L(X) D
. . . Q:$D(DCNT)&($G(DIKSAVE(1))["ASL")
. . . Q:$D(DCNT)&($G(DIK(1))["ASL")
. . . Q:$D(DCNT)&('$D(DIK(1)))
. . . D KSF^LEXNDX6
. . K ^LEX(757.05,"ALINK",DA,LEXMC)
K LEXLNK,LEXMC N DCNT,DIKSAVE
Q
SUB ; Index linked words in sub-file before UNLINK and RELINK
Q:'$D(DA) I $D(^LEX(757.05,DA,1,1,0)) N LEXSREC,LEXMC S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXNDX4 5380 printed Oct 16, 2024@18:08:58 Page 2
LEXNDX4 ;ISL/KER - Set/kill indexes (Part 4) Link ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.011) N/A
+5 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10103
+9 ; YN^DICN ICR 10009
+10 ;
LINK ; Link a Keyword to an expression
+1 IF $DATA(^LEX(757.05,DA,1,"B",1))
QUIT
+2 WRITE !,"LINK"
SET X=LEXBY
DO PTX^LEXTOKN
NEW LEXTMP
+3 SET (LEXTMP,LEXLINK,LEXKEY)=""
+4 IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:1
+5 NEW LEXTMP
SET LEXTMP=$ORDER(^TMP("LEXTKN",$JOB,0))
if LEXTMP'>0
QUIT
+6 SET LEXKEY=$ORDER(^TMP("LEXTKN",$JOB,LEXTMP,LEXKEY))
End DoDot:1
+7 if '$LENGTH(LEXKEY)
QUIT
SET LEXREC=0
FOR
SET LEXREC=$ORDER(^LEX(757.01,"AWRD",LEXKEY,LEXREC))
if +LEXREC=0!(LEXLINK[U)
QUIT
Begin DoDot:1
+8 IF ^TMP("LEXTKN",$JOB,0)=1
SET LEXASK=1
+9 IF ^TMP("LEXTKN",$JOB,0)>1
SET LEXASK=1
Begin DoDot:2
+10 SET LEXA=1
FOR
SET LEXA=$ORDER(^TMP("LEXTKN",$JOB,LEXA))
if +LEXA'>0
QUIT
Begin DoDot:3
+11 SET LEXAKEY=""
SET LEXAKEY=$ORDER(^TMP("LEXTKN",$JOB,LEXA,LEXAKEY))
if '$LENGTH($GET(LEXAKEY))
QUIT
+12 SET LEXSRC=$$UP^XLFSTR(^LEX(757.01,LEXREC,0))
+13 IF LEXSRC'[$EXTRACT(LEXAKEY,1,4)
SET LEXASK=0
End DoDot:3
End DoDot:2
+14 SET LEXLINK=""
IF LEXASK
Begin DoDot:2
+15 IF $DATA(^LEX(757.05,DA,1,"B",LEXREC))
QUIT
MOK ; Prompt to Map/Link a keyword to an expression
+1 WRITE !!,"Map ",^LEX(757.01,LEXREC,0),!,"To ",LEXREP,!,"OK"
SET %=1
DO YN^DICN
SET LEXLINK=%
IF %=-1
WRITE !
SET LEXLINK=U
QUIT
+2 IF '%
WRITE !!,"By answering ""Yes"", an index reference will be made to link the",!,"term to the key word ",LEXREP
GOTO MOK
End DoDot:2
+3 IF +LEXLINK=1
Begin DoDot:2
+4 NEW LEXYPE,LEXT
SET ^LEX(757.05,"ALINK",DA,LEXREC)=""
+5 SET LEXYPE=+($PIECE($GET(^LEX(757.01,LEXREC,1)),U,2))
+6 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXYPE,0)),U,2))
+7 if +LEXT>0
SET ^LEX(757.01,"AWRD",LEXREP,LEXREC,"LINKED")=""
WRITE !
+8 IF $DATA(^LEX(757.05,DA,1,0))
Begin DoDot:3
+9 SET LEXSREC=0
FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
Begin DoDot:4
+10 SET ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
End DoDot:4
+11 IF '$DATA(^LEX(757.05,DA,1,"B",LEXREC))
Begin DoDot:4
+12 SET LEXSREC=0
FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
SET LEXLNK=LEXSREC+1
+13 KILL LEXSREC
SET ^LEX(757.05,DA,1,LEXLNK,0)=LEXREC
+14 SET ^LEX(757.05,DA,1,"B",LEXREC,LEXLNK)=""
SET $PIECE(^LEX(757.05,DA,1,0),U,4)=$PIECE(^LEX(757.05,DA,1,0),U,4)+1
+15 SET $PIECE(^LEX(757.05,DA,1,0),U,3)=LEXLNK
KILL LEXLNK
End DoDot:4
End DoDot:3
+16 IF '$DATA(^LEX(757.05,DA,1,0))
SET ^LEX(757.05,DA,1,1,0)=LEXREC
SET ^LEX(757.05,DA,1,"B",LEXREC,1)=""
SET ^LEX(757.05,DA,1,0)="^757.53P^1^1"
End DoDot:2
End DoDot:1
+17 DO VERIFY
KILL ^TMP("LEXTKN",$JOB),^TMP("LEXTKN",$JOB,0),LEXSRC,LEXKEY,LEXA,LEXAKEY,LEXREC,LEXASK,LEXLINK
+18 QUIT
VERIFY ; Display linkages made for user verification
+1 if '$DATA(DA)
QUIT
+2 IF '$DATA(^LEX(757.05,DA,1,0))
WRITE !,"No Word Linkages Created",!
QUIT
+3 WRITE !!,$PIECE(^LEX(757.05,DA,0),"^",1)," has been linked to: ",!
+4 NEW LEXSREC
SET LEXSREC=0
+5 FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
Begin DoDot:1
+6 WRITE !,?4,$EXTRACT(^LEX(757.01,^LEX(757.05,DA,1,LEXSREC,0),0),1,75)
End DoDot:1
+7 WRITE !
IF +$$OK
Begin DoDot:1
+8 SET LEXSREC=0
FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
SET LEXLNK=LEXSREC+1
+9 KILL LEXSREC
SET ^LEX(757.05,DA,1,LEXLNK,0)=1
SET ^LEX(757.05,DA,1,"B",1,LEXLNK)=""
+10 SET $PIECE(^LEX(757.05,DA,1,0),U,4)=$PIECE(^LEX(757.05,DA,1,0),U,4)+1
+11 SET $PIECE(^LEX(757.05,DA,1,0),U,3)=LEXLNK
KILL LEXLNK
End DoDot:1
KILL LEXSREC,LEXLNK
QUIT
+12 DO UNLINK
+13 QUIT
OK(LEXOK) ; Get user response
OK1 ; Prompt "Is this correct"
+1 WRITE !,"Is this correct"
SET %=1
DO YN^DICN
+2 IF %=-1!(%=2)
KILL %,%Y
QUIT 0
+3 IF %=1
KILL %,%Y
QUIT 1
+4 IF '%
Begin DoDot:1
+5 WRITE !,"By confirming the word linkages displayed above, a look-up"
+6 WRITE !,"conducted on ",$PIECE(^LEX(757.05,DA,0),"^",1)
+7 WRITE " will retrieve the linked terms."
End DoDot:1
GOTO OK1
+8 QUIT 0
RELINK ; Relink Keywords to expressions
+1 if '$DATA(DA)
QUIT
if '$DATA(^LEX(757.05,DA,1,1,0))
QUIT
+2 DO SUB
NEW LEXMC,LEXCTR,LEXSREC,LEXERM
SET (LEXCTR,LEXSREC)=0
SET LEXERM=$PIECE(^LEX(757.05,DA,0),"^",1)
+3 FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
Begin DoDot:1
+4 SET LEXCTR=LEXCTR+1
+5 SET ^LEX(757.05,DA,1,0)="^757.53P^"_LEXCTR_"^"_LEXCTR
+6 SET ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
+7 IF ^LEX(757.05,DA,1,LEXSREC,0)'=1
Begin DoDot:2
+8 SET LEXMC=^LEX(757.05,DA,1,LEXSREC,0)
+9 NEW LEXYPE,LEXT
SET LEXYPE=+($PIECE($GET(^LEX(757.01,LEXMC,1)),U,2))
+10 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXYPE,0)),U,2))
+11 IF +LEXT>0
Begin DoDot:3
+12 SET ^LEX(757.01,"AWRD",LEXERM,LEXMC,"LINKED")=""
+13 NEW X
SET X=LEXERM
IF $LENGTH(X)
Begin DoDot:4
+14 if $DATA(DCNT)&($GET(DIKSAVE(1))["ASL")
QUIT
+15 if $DATA(DCNT)&($GET(DIK(1))["ASL")
QUIT
+16 if $DATA(DCNT)&('$DATA(DIK(1)))
QUIT
+17 DO SSF^LEXNDX6
End DoDot:4
End DoDot:3
+18 SET ^LEX(757.05,"ALINK",DA,LEXMC)=""
End DoDot:2
End DoDot:1
+19 KILL LEXSREC,LEXERM
NEW DCNT,DIKSAVE
+20 QUIT
UNLINK ; Unlink a Keyword from an expression
+1 if '$DATA(^LEX(757.05,DA,1,0))
QUIT
NEW LEXMC,LEXLNK
+2 SET LEXMC=0
FOR
SET LEXMC=$ORDER(^LEX(757.05,DA,1,"B",LEXMC))
if +LEXMC=0
QUIT
Begin DoDot:1
+3 SET LEXLNK=0
FOR
SET LEXLNK=$ORDER(^LEX(757.05,DA,1,"B",LEXMC,LEXLNK))
if +LEXLNK=0
QUIT
Begin DoDot:2
+4 SET LEXWRD=$PIECE(^LEX(757.05,DA,0),U,1)
+5 KILL ^LEX(757.01,"AWRD",LEXWRD,LEXMC,"LINKED")
+6 NEW X
SET X=LEXWRD
+7 IF $DATA(X)
IF X=0
Begin DoDot:3
+8 KILL ^LEX(757.05,DA,1,LEXLNK,0)
+9 KILL ^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)
+10 KILL ^LEX(757.05,DA,1,0)
End DoDot:3
+11 IF $LENGTH(X)
Begin DoDot:3
+12 if $DATA(DCNT)&($GET(DIKSAVE(1))["ASL")
QUIT
+13 if $DATA(DCNT)&($GET(DIK(1))["ASL")
QUIT
+14 if $DATA(DCNT)&('$DATA(DIK(1)))
QUIT
+15 DO KSF^LEXNDX6
End DoDot:3
+16 KILL ^LEX(757.05,"ALINK",DA,LEXMC)
End DoDot:2
End DoDot:1
+17 KILL LEXLNK,LEXMC
NEW DCNT,DIKSAVE
+18 QUIT
SUB ; Index linked words in sub-file before UNLINK and RELINK
+1 if '$DATA(DA)
QUIT
IF $DATA(^LEX(757.05,DA,1,1,0))
NEW LEXSREC,LEXMC
SET LEXSREC=0
FOR
SET LEXSREC=$ORDER(^LEX(757.05,DA,1,LEXSREC))
if +LEXSREC=0
QUIT
SET ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
+2 QUIT
