LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;05/23/2017
;;2.0;LEXICON UTILITY;**51,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DD( ICR 345
; ^LEX(757.011) N/A
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
;
SS ; Get (unique) text for an expression in the Subset file
Q:'$D(X)!('$D(DA))
N LEXEXP,LEXMC,LEXTEXP,LEXOLDX S LEXOLDX=X
S LEXEXP=+(^LEX(757.21,DA,0)) Q:$P($G(^LEX(757.01,+LEXEXP,1)),U,5)>0
S LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
. Q:$P($G(^LEX(757.01,+LEXTEXP,1)),U,5)>0 N LEXTTYP,LEXDEA
. S LEXTTYP=+($P($G(^LEX(757.01,+LEXTEXP,1)),U,2)) Q:LEXTTYP=8
. S LEXDEA=$$DEA(+LEXTEXP) Q:LEXDEA>0
. S X=^LEX(757.01,LEXTEXP,0) D SS2
S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP
Q
SS2 ; Parse text and set node for each word
N LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
S LEXYPE=+($P($G(^LEX(757.01,LEXTEXP,1)),U,2)) Q:LEXYPE'>0
S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),"^",2)) Q:LEXT=0
S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
D PTX^LEXTOKN,KNR
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="",LEXJ=0 D
. F S LEXJ=$O(^TMP("LEXTKN",$J,LEXJ)) Q:+LEXJ'>0 D
. . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,"")) Q:'$L(LEXI)
. . S:'$D(^LEX(757.21,LEXSIDX,LEXI,DA)) ^LEX(757.21,LEXSIDX,LEXI,DA)=""
K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
SK ; Get (all) text for an expression in the Subset file
Q:'$D(X)!('$D(DA))
N LEXEXP,LEXMC,LEXTEXP,LEXOLDX,LEXDEA,LEXTTYP S LEXOLDX=X
S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
. S X=^LEX(757.01,LEXTEXP,0) D SK2
S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP Q
SK2 ; Parse text and kill node for each word
N LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
D PTX^LEXTOKN,KNR
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="",LEXJ=0 D
. F S LEXJ=$O(^TMP("LEXTKN",$J,LEXJ)) Q:+LEXJ'>0 D
. . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,"")) Q:'$L(LEXI)
. . K ^LEX(757.21,LEXSIDX,LEXI,DA)
K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
SET ; Given DIC and DA set indexes
Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
. S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
. S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
. F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
. . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
. . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
. . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
. . I DA>$P($G(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3) S $P(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
Q
KILL ; Given DIC and DA kill indexes
Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
. S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
. S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
. F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
. . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
. . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
. . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
Q
SAPP ; Set application subset definition index
I X'="" D
. N LEXIDX S LEXIDX=$P(^LEXT(757.2,DA,0),U,2) I LEXIDX'="" D
. . K ^LEXT(757.2,"AA",LEXIDX) S $P(^LEXT(757.2,DA,0),U,2)="" K LEXIDX
. S ^LEXT(757.2,"AB",X,DA)=""
Q
KAPP ; Kill application subset definition index
K ^LEXT(757.2,"AB",X,DA) Q
SSM ; Set index for Subset Mnemonic
S ^LEXT(757.2,"AA",X,DA)="" N LEXX,LEXLOW
S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
S:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA)="",^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
I $L(LEXX) D
. N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
. I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
. . S ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)=""
. . S ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)=""
Q
KSM ; Kill index for Subset Mnemonic
K ^LEXT(757.2,"AA",X,DA) N LEXX,LEXLOW
S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
K:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
I $L(LEXX) D
. N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
. I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
. . K ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)
. . K ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)
Q
KNR ; keywords and replacement words
Q:+($G(LEXDEA))>0 Q:+($G(LEXTTYP))=8
N LEXV,LEXN
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
.I $D(^LEX(757.01,LEXTEXP,5)) D
..S LEXV=""
..F S LEXV=$O(^LEX(757.01,LEXTEXP,5,"B",LEXV)) Q:LEXV="" D
...D ADDTKN(LEXV)
.I $D(^LEX(757.05,"AEXP",LEXTEXP)) D
..S LEXN=""
..F S LEXN=$O(^LEX(757.05,"AEXP",LEXTEXP,LEXN)) Q:LEXN="" D
...S LEXV=$P(^LEX(757.05,LEXN,0),U)
...D ADDTKN(LEXV)
Q
ADDTKN(LEXV) ; add to LEXTKN
N LEXC
S LEXC=^TMP("LEXTKN",$J,0)+1
S ^TMP("LEXTKN",$J,LEXC,LEXV)=""
S ^TMP("LEXTKN",$J,0)=LEXC
Q
DEA(X) ; Expression/Concept Deactive
N LEXA,LEXEA,LEXEIEN,LEXMA,LEXMIEN,LEXN S LEXEIEN=+($G(X)),LEXN=$G(^LEX(757.01,+LEXEIEN,1))
S LEXEA=+($P(LEXN,"^",5)),LEXMIEN=+LEXN,LEXN=+($P(LEXN,"^",2)) Q:LEXN=1&(LEXEA>0) 1 Q:LEXN=1&(LEXEA'>0) 0
S LEXMIEN=+($G(^LEX(757,+LEXMIEN,0))),LEXMA=+($P($G(^LEX(757.01,+LEXMIEN,1)),"^",5)) Q:(LEXEA+LEXMA)>0 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXNDX2 5973 printed Nov 22, 2024@17:18:21 Page 2
LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**51,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DD( ICR 345
+5 ; ^LEX(757.011) N/A
+6 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$UP^XLFSTR ICR 10103
+10 ;
SS ; Get (unique) text for an expression in the Subset file
+1 if '$DATA(X)!('$DATA(DA))
QUIT
+2 NEW LEXEXP,LEXMC,LEXTEXP,LEXOLDX
SET LEXOLDX=X
+3 SET LEXEXP=+(^LEX(757.21,DA,0))
if $PIECE($GET(^LEX(757.01,+LEXEXP,1)),U,5)>0
QUIT
+4 SET LEXMC=$PIECE(^LEX(757.01,LEXEXP,1),U,1)
+5 SET LEXTEXP=0
FOR
SET LEXTEXP=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXTEXP))
if +LEXTEXP=0
QUIT
Begin DoDot:1
+6 if $PIECE($GET(^LEX(757.01,+LEXTEXP,1)),U,5)>0
QUIT
NEW LEXTTYP,LEXDEA
+7 SET LEXTTYP=+($PIECE($GET(^LEX(757.01,+LEXTEXP,1)),U,2))
if LEXTTYP=8
QUIT
+8 SET LEXDEA=$$DEA(+LEXTEXP)
if LEXDEA>0
QUIT
+9 SET X=^LEX(757.01,LEXTEXP,0)
DO SS2
End DoDot:1
+10 SET X=LEXOLDX
KILL LEXOLDX,LEXEXP,LEXMC,LEXTEXP
+11 QUIT
SS2 ; Parse text and set node for each word
+1 NEW LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI
SET LEXIDX=""
+2 SET LEXYPE=+($PIECE($GET(^LEX(757.01,LEXTEXP,1)),U,2))
if LEXYPE'>0
QUIT
+3 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXYPE,0)),"^",2))
if LEXT=0
QUIT
+4 SET LEXSIDX="A"_$PIECE(^LEXT(757.2,LEXOLDX,0),U,2)
+5 DO PTX^LEXTOKN
DO KNR
+6 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI=""
SET LEXJ=0
Begin DoDot:1
+7 FOR
SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
if +LEXJ'>0
QUIT
Begin DoDot:2
+8 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
if '$LENGTH(LEXI)
QUIT
+9 if '$DATA(^LEX(757.21,LEXSIDX,LEXI,DA))
SET ^LEX(757.21,LEXSIDX,LEXI,DA)=""
End DoDot:2
End DoDot:1
+10 KILL LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
QUIT
SK ; Get (all) text for an expression in the Subset file
+1 if '$DATA(X)!('$DATA(DA))
QUIT
+2 NEW LEXEXP,LEXMC,LEXTEXP,LEXOLDX,LEXDEA,LEXTTYP
SET LEXOLDX=X
+3 SET LEXEXP=+(^LEX(757.21,DA,0))
SET LEXMC=$PIECE(^LEX(757.01,LEXEXP,1),U,1)
+4 SET LEXTEXP=0
FOR
SET LEXTEXP=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXTEXP))
if +LEXTEXP=0
QUIT
Begin DoDot:1
+5 SET X=^LEX(757.01,LEXTEXP,0)
DO SK2
End DoDot:1
+6 SET X=LEXOLDX
KILL LEXOLDX,LEXEXP,LEXMC,LEXTEXP
QUIT
SK2 ; Parse text and kill node for each word
+1 NEW LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI
SET LEXIDX=""
+2 SET LEXSIDX="A"_$PIECE(^LEXT(757.2,LEXOLDX,0),U,2)
+3 DO PTX^LEXTOKN
DO KNR
+4 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI=""
SET LEXJ=0
Begin DoDot:1
+5 FOR
SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
if +LEXJ'>0
QUIT
Begin DoDot:2
+6 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
if '$LENGTH(LEXI)
QUIT
+7 KILL ^LEX(757.21,LEXSIDX,LEXI,DA)
End DoDot:2
End DoDot:1
+8 KILL LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
QUIT
SET ; Given DIC and DA set indexes
+1 if $DATA(DIC)#2=0!('$DATA(DA))
QUIT
if DIC'["LEX("&(DIC'["LEX(")
QUIT
+2 NEW LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
+3 SET LEXFN=+($PIECE(DIC,"(",2))
SET LEXRT=$TRANSLATE($PIECE(DIC,"(",1),"^","")
+4 SET LEXFL=0
FOR
SET LEXFL=$ORDER(^DD(LEXFN,LEXFL))
if +LEXFL=0
QUIT
Begin DoDot:1
+5 SET LEXN=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",1)
+6 SET LEXP=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",2)
SET LEXRIDX=0
+7 FOR
SET LEXRIDX=$ORDER(^DD(LEXFN,LEXFL,1,LEXRIDX))
if +LEXRIDX=0
QUIT
Begin DoDot:2
+8 IF $LENGTH($PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP))
Begin DoDot:3
+9 SET X=$PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
+10 if X'=""
XECUTE ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
End DoDot:3
+11 IF DA>$PIECE($GET(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3)
SET $PIECE(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
End DoDot:2
End DoDot:1
+12 KILL LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
+13 QUIT
KILL ; Given DIC and DA kill indexes
+1 if $DATA(DIC)#2=0!('$DATA(DA))
QUIT
if DIC'["LEX("&(DIC'["LEX(")
QUIT
+2 NEW LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
+3 SET LEXFN=+($PIECE(DIC,"(",2))
SET LEXRT=$TRANSLATE($PIECE(DIC,"(",1),"^","")
+4 SET LEXFL=0
FOR
SET LEXFL=$ORDER(^DD(LEXFN,LEXFL))
if +LEXFL=0
QUIT
Begin DoDot:1
+5 SET LEXN=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",1)
+6 SET LEXP=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",2)
SET LEXRIDX=0
+7 FOR
SET LEXRIDX=$ORDER(^DD(LEXFN,LEXFL,1,LEXRIDX))
if +LEXRIDX=0
QUIT
Begin DoDot:2
+8 IF $LENGTH($PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP))
Begin DoDot:3
+9 SET X=$PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
+10 if X'=""
XECUTE ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
End DoDot:3
End DoDot:2
End DoDot:1
+11 KILL LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
+12 QUIT
SAPP ; Set application subset definition index
+1 IF X'=""
Begin DoDot:1
+2 NEW LEXIDX
SET LEXIDX=$PIECE(^LEXT(757.2,DA,0),U,2)
IF LEXIDX'=""
Begin DoDot:2
+3 KILL ^LEXT(757.2,"AA",LEXIDX)
SET $PIECE(^LEXT(757.2,DA,0),U,2)=""
KILL LEXIDX
End DoDot:2
+4 SET ^LEXT(757.2,"AB",X,DA)=""
End DoDot:1
+5 QUIT
KAPP ; Kill application subset definition index
+1 KILL ^LEXT(757.2,"AB",X,DA)
QUIT
SSM ; Set index for Subset Mnemonic
+1 SET ^LEXT(757.2,"AA",X,DA)=""
NEW LEXX,LEXLOW
+2 SET LEXX=$PIECE($GET(^LEXT(757.2,DA,0)),U,1)
+3 if $LENGTH(LEXX)
SET ^LEXT(757.2,"AA",LEXX,DA)=""
SET ^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
+4 IF $LENGTH(LEXX)
Begin DoDot:1
+5 NEW X,LEXI
SET X=LEXX
SET LEXLOW=""
DO PTX^LEXTOKN
+6 IF +($GET(^TMP("LEXTKN",$JOB,0)))>0
FOR LEXI=1:1:+($GET(^TMP("LEXTKN",$JOB,0)))
Begin DoDot:2
+7 SET ^LEXT(757.2,"AA",$ORDER(^TMP("LEXTKN",$JOB,LEXI,"")),DA)=""
+8 SET ^LEXT(757.2,"AA",$$UP^XLFSTR($ORDER(^TMP("LEXTKN",$JOB,LEXI,""))),DA)=""
End DoDot:2
End DoDot:1
+9 QUIT
KSM ; Kill index for Subset Mnemonic
+1 KILL ^LEXT(757.2,"AA",X,DA)
NEW LEXX,LEXLOW
+2 SET LEXX=$PIECE($GET(^LEXT(757.2,DA,0)),U,1)
+3 if $LENGTH(LEXX)
KILL ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
+4 IF $LENGTH(LEXX)
Begin DoDot:1
+5 NEW X,LEXI
SET X=LEXX
SET LEXLOW=""
DO PTX^LEXTOKN
+6 IF +($GET(^TMP("LEXTKN",$JOB,0)))>0
FOR LEXI=1:1:+($GET(^TMP("LEXTKN",$JOB,0)))
Begin DoDot:2
+7 KILL ^LEXT(757.2,"AA",$ORDER(^TMP("LEXTKN",$JOB,LEXI,"")),DA)
+8 KILL ^LEXT(757.2,"AA",$$UP^XLFSTR($ORDER(^TMP("LEXTKN",$JOB,LEXI,""))),DA)
End DoDot:2
End DoDot:1
+9 QUIT
KNR ; keywords and replacement words
+1 if +($GET(LEXDEA))>0
QUIT
if +($GET(LEXTTYP))=8
QUIT
+2 NEW LEXV,LEXN
+3 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:1
+4 IF $DATA(^LEX(757.01,LEXTEXP,5))
Begin DoDot:2
+5 SET LEXV=""
+6 FOR
SET LEXV=$ORDER(^LEX(757.01,LEXTEXP,5,"B",LEXV))
if LEXV=""
QUIT
Begin DoDot:3
+7 DO ADDTKN(LEXV)
End DoDot:3
End DoDot:2
+8 IF $DATA(^LEX(757.05,"AEXP",LEXTEXP))
Begin DoDot:2
+9 SET LEXN=""
+10 FOR
SET LEXN=$ORDER(^LEX(757.05,"AEXP",LEXTEXP,LEXN))
if LEXN=""
QUIT
Begin DoDot:3
+11 SET LEXV=$PIECE(^LEX(757.05,LEXN,0),U)
+12 DO ADDTKN(LEXV)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
ADDTKN(LEXV) ; add to LEXTKN
+1 NEW LEXC
+2 SET LEXC=^TMP("LEXTKN",$JOB,0)+1
+3 SET ^TMP("LEXTKN",$JOB,LEXC,LEXV)=""
+4 SET ^TMP("LEXTKN",$JOB,0)=LEXC
+5 QUIT
DEA(X) ; Expression/Concept Deactive
+1 NEW LEXA,LEXEA,LEXEIEN,LEXMA,LEXMIEN,LEXN
SET LEXEIEN=+($GET(X))
SET LEXN=$GET(^LEX(757.01,+LEXEIEN,1))
+2 SET LEXEA=+($PIECE(LEXN,"^",5))
SET LEXMIEN=+LEXN
SET LEXN=+($PIECE(LEXN,"^",2))
if LEXN=1&(LEXEA>0)
QUIT 1
if LEXN=1&(LEXEA'>0)
QUIT 0
+3 SET LEXMIEN=+($GET(^LEX(757,+LEXMIEN,0)))
SET LEXMA=+($PIECE($GET(^LEX(757.01,+LEXMIEN,1)),"^",5))
if (LEXEA+LEXMA)>0
QUIT 1
+4 QUIT 0
