LEXNDX1 ;ISL/KER - Set/kill indexes (Part 1) ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.011) N/A
; ^TMP("LEXSTOP") SACC 2.3.2.5.1
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
;
S ; Set Expression file (#757.01) word index node AWRD
Q:'$D(X)!('$D(DA)) Q:$D(DIC)#2=0 Q:'$D(@(DIC_DA_",0)")) Q:'$D(@(DIC_DA_",1)"))
Q:+($P(@(DIC_DA_",1)"),U,1))'>0 N LEXIDX,LEXDEA,LEXTTYP,LEXJ,LEXI,LEXTYPE,LEXT
S LEXTYPE=+X Q:LEXTYPE'>0 S LEXT=$P($G(^LEX(757.011,LEXTYPE,0)),"^",2) Q:+LEXT=0
S LEXTYPE=$P($G(^LEX(757.011,LEXTYPE,0)),"^",1) D:LEXTYPE["DELETED" U
S X=@(DIC_DA_",0)") S:X'="" ^LEX(757.01,"B",$$UP^XLFSTR($E(X,1,63)),DA)=""
S LEXDEA=$$DEA(DA),LEXTTYP=$P($G(^LEX(757.01,DA,1)),U,2) Q:+($G(LEXDEA))>0 Q:LEXTTYP=8
S LEXEX=$P(^LEX(757,$P(^LEX(757.01,DA,1),U,1),0),U,1),LEXIDX=""
D PTX^LEXTOKN 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)
. . I '$D(^LEX(757.01,"AWRD",LEXI,LEXEX)) D
. . . S:'$D(^LEX(757.01,DA,4,"B",LEXI)) ^LEX(757.01,"AWRD",LEXI,LEXEX,DA)=""
D L K LEXIDX,LEXEX,LEXI,LEXTYPE,LEXT,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
;
K ; Kill Expression file (#757.01) word index node AWRD
Q:'$D(X)!('$D(DA)) D U
Q:'$D(^LEX(757.01,DA,0)) Q:+($P(^LEX(757.01,DA,1),U,1))=0
N LEXTYPE,LEXT S LEXTYPE=+X Q:LEXTYPE'>0
S LEXT=$P($G(^LEX(757.011,LEXTYPE,0)),"^",2) Q:+LEXT=0
N LEXIDX,LEXJ,LEXI S X=^LEX(757.01,DA,0),LEXIDX=""
D PTX^LEXTOKN 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
. . N LEXI,LEXEX S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,"")) Q:'$L(LEXI)
. . S LEXEX=$P(^LEX(757,$P(^LEX(757.01,DA,1),U,1),0),U,1)
. . K ^LEX(757.01,"AWRD",LEXI,DA)
. . K ^LEX(757.01,"AWRD",LEXI,LEXEX,DA)
K LEXIDX,LEXTYPE,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
L ; Link words
N DIC,LEXDEXP D KILL^LEXNDX2 S LEXDEXP=DA
; For Subsets
I $D(^LEX(757.21,"B",LEXDEXP)) D
. S DA=0 F S DA=$O(^LEX(757.21,"B",LEXDEXP,DA)) Q:+DA=0 D
. . N X S X=$P(^LEX(757.21,DA,0),U,2) Q:+X<1 D SS^LEXNDX2
; For Replacement Words
I $D(^LEX(757.05,"AEXP",LEXDEXP)) D
. S DA=0 F S DA=$O(^LEX(757.05,"AEXP",LEXDEXP,DA)) Q:+DA=0 D
. . N X,LEXMC S X=$P(^LEX(757.05,DA,0),U,1) Q:X=""
. . S LEXMC=$P($G(^LEX(757.01,LEXDEXP,1)),U,1) Q:+LEXMC'>0
. . S ^LEX(757.01,"AWRD",X,LEXDEXP,"LINKED")=""
S DA=LEXDEXP
Q
U ; Unlink words
N DIC,LEXDEXP D KILL^LEXNDX2 S LEXDEXP=DA
; For Subsets
I $D(^LEX(757.21,"B",LEXDEXP)) D
. S DA=0 F S DA=$O(^LEX(757.21,"B",LEXDEXP,DA)) Q:+DA=0 D
. . N X S X=$P(^LEX(757.21,DA,0),U,2) Q:+X<1 D SK^LEXNDX2
; For Replacement Words
I $D(^LEX(757.05,"AEXP",LEXDEXP)) D
. S DA=0 F S DA=$O(^LEX(757.05,"AEXP",LEXDEXP,DA)) Q:+DA=0 D
. . N X,LEXMC S X=$P(^LEX(757.05,DA,0),U,1) Q:X=""
. . S LEXMC=$P($G(^LEX(757.01,LEXDEXP,1)),U,1) Q:+LEXMC'>0
. . K ^LEX(757.01,"AWRD",X,LEXDEXP,"LINKED")
S DA=LEXDEXP
Q
REIDXMC ; Re-Index Expression file word index AWRD
S:$D(ZTQUEUED) ZTREQ="@"
N LEXIDX,LEXREIX,DA,X S DA=0,X="",(LEXREIX,LEXIDX)="" K ^TMP("LEXSTOP","REIDXMC")
F S DA=$O(^LEX(757.01,DA)) Q:+DA=0!($D(^TMP("LEXSTOP","REIDXMC"))) D
. S X=$P(^LEX(757.01,DA,1),U,2) D S
K ^TMP("LEXSTOP","REIDXMC"),LEXIDX,DA,X
Q
RMC ; Re-Index Expression file word index AWRD (Task Manager)
S ZTRTN="REIDXMC^LEXNDX1"
S ZTDESC="Re-Indexing Major Concept Words in ""AWRD"" index"
S ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS W:$D(ZTSK) !!,"Re-Indexing Major Concept Words in ""AWRD"" index" W:'$D(ZTSK) !!,"Task to re-index Major Concept not created"
K ZTDTH,ZTDESC,ZTIO,ZTRTN
Q
RALL ; Re-Index entire file (needs DIC)
S DIK=$G(DIC) Q:DIK="" Q:'$D(@(DIK_"0)"))
S ZTREQ="@",(ZTSAVE("ZTREQ"),ZTSAVE("DIK"))="",ZTRTN="IXALL^DIK"
S ZTDESC="Re-Indexing "_DIK
S ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS
K ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTREQ,ZTSAVE
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[HLEXNDX1 4578 printed Nov 22, 2024@17:18:20 Page 2
LEXNDX1 ;ISL/KER - Set/kill indexes (Part 1) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.011) N/A
+5 ; ^TMP("LEXSTOP") SACC 2.3.2.5.1
+6 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$UP^XLFSTR ICR 10103
+10 ; HOME^%ZIS ICR 10086
+11 ; ^%ZTLOAD ICR 10063
+12 ;
S ; Set Expression file (#757.01) word index node AWRD
+1 if '$DATA(X)!('$DATA(DA))
QUIT
if $DATA(DIC)#2=0
QUIT
if '$DATA(@(DIC_DA_",0)"))
QUIT
if '$DATA(@(DIC_DA_",1)"))
QUIT
+2 if +($PIECE(@(DIC_DA_",1)"),U,1))'>0
QUIT
NEW LEXIDX,LEXDEA,LEXTTYP,LEXJ,LEXI,LEXTYPE,LEXT
+3 SET LEXTYPE=+X
if LEXTYPE'>0
QUIT
SET LEXT=$PIECE($GET(^LEX(757.011,LEXTYPE,0)),"^",2)
if +LEXT=0
QUIT
+4 SET LEXTYPE=$PIECE($GET(^LEX(757.011,LEXTYPE,0)),"^",1)
if LEXTYPE["DELETED"
DO U
+5 SET X=@(DIC_DA_",0)")
if X'=""
SET ^LEX(757.01,"B",$$UP^XLFSTR($EXTRACT(X,1,63)),DA)=""
+6 SET LEXDEA=$$DEA(DA)
SET LEXTTYP=$PIECE($GET(^LEX(757.01,DA,1)),U,2)
if +($GET(LEXDEA))>0
QUIT
if LEXTTYP=8
QUIT
+7 SET LEXEX=$PIECE(^LEX(757,$PIECE(^LEX(757.01,DA,1),U,1),0),U,1)
SET LEXIDX=""
+8 DO PTX^LEXTOKN
IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI=""
SET LEXJ=0
Begin DoDot:1
+9 FOR
SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
if +LEXJ'>0
QUIT
Begin DoDot:2
+10 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
if '$LENGTH(LEXI)
QUIT
+11 IF '$DATA(^LEX(757.01,"AWRD",LEXI,LEXEX))
Begin DoDot:3
+12 if '$DATA(^LEX(757.01,DA,4,"B",LEXI))
SET ^LEX(757.01,"AWRD",LEXI,LEXEX,DA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 DO L
KILL LEXIDX,LEXEX,LEXI,LEXTYPE,LEXT,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
QUIT
+14 ;
K ; Kill Expression file (#757.01) word index node AWRD
+1 if '$DATA(X)!('$DATA(DA))
QUIT
DO U
+2 if '$DATA(^LEX(757.01,DA,0))
QUIT
if +($PIECE(^LEX(757.01,DA,1),U,1))=0
QUIT
+3 NEW LEXTYPE,LEXT
SET LEXTYPE=+X
if LEXTYPE'>0
QUIT
+4 SET LEXT=$PIECE($GET(^LEX(757.011,LEXTYPE,0)),"^",2)
if +LEXT=0
QUIT
+5 NEW LEXIDX,LEXJ,LEXI
SET X=^LEX(757.01,DA,0)
SET LEXIDX=""
+6 DO PTX^LEXTOKN
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 NEW LEXI,LEXEX
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
if '$LENGTH(LEXI)
QUIT
+9 SET LEXEX=$PIECE(^LEX(757,$PIECE(^LEX(757.01,DA,1),U,1),0),U,1)
+10 KILL ^LEX(757.01,"AWRD",LEXI,DA)
+11 KILL ^LEX(757.01,"AWRD",LEXI,LEXEX,DA)
End DoDot:2
End DoDot:1
+12 KILL LEXIDX,LEXTYPE,LEXI,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
QUIT
L ; Link words
+1 NEW DIC,LEXDEXP
DO KILL^LEXNDX2
SET LEXDEXP=DA
+2 ; For Subsets
+3 IF $DATA(^LEX(757.21,"B",LEXDEXP))
Begin DoDot:1
+4 SET DA=0
FOR
SET DA=$ORDER(^LEX(757.21,"B",LEXDEXP,DA))
if +DA=0
QUIT
Begin DoDot:2
+5 NEW X
SET X=$PIECE(^LEX(757.21,DA,0),U,2)
if +X<1
QUIT
DO SS^LEXNDX2
End DoDot:2
End DoDot:1
+6 ; For Replacement Words
+7 IF $DATA(^LEX(757.05,"AEXP",LEXDEXP))
Begin DoDot:1
+8 SET DA=0
FOR
SET DA=$ORDER(^LEX(757.05,"AEXP",LEXDEXP,DA))
if +DA=0
QUIT
Begin DoDot:2
+9 NEW X,LEXMC
SET X=$PIECE(^LEX(757.05,DA,0),U,1)
if X=""
QUIT
+10 SET LEXMC=$PIECE($GET(^LEX(757.01,LEXDEXP,1)),U,1)
if +LEXMC'>0
QUIT
+11 SET ^LEX(757.01,"AWRD",X,LEXDEXP,"LINKED")=""
End DoDot:2
End DoDot:1
+12 SET DA=LEXDEXP
+13 QUIT
U ; Unlink words
+1 NEW DIC,LEXDEXP
DO KILL^LEXNDX2
SET LEXDEXP=DA
+2 ; For Subsets
+3 IF $DATA(^LEX(757.21,"B",LEXDEXP))
Begin DoDot:1
+4 SET DA=0
FOR
SET DA=$ORDER(^LEX(757.21,"B",LEXDEXP,DA))
if +DA=0
QUIT
Begin DoDot:2
+5 NEW X
SET X=$PIECE(^LEX(757.21,DA,0),U,2)
if +X<1
QUIT
DO SK^LEXNDX2
End DoDot:2
End DoDot:1
+6 ; For Replacement Words
+7 IF $DATA(^LEX(757.05,"AEXP",LEXDEXP))
Begin DoDot:1
+8 SET DA=0
FOR
SET DA=$ORDER(^LEX(757.05,"AEXP",LEXDEXP,DA))
if +DA=0
QUIT
Begin DoDot:2
+9 NEW X,LEXMC
SET X=$PIECE(^LEX(757.05,DA,0),U,1)
if X=""
QUIT
+10 SET LEXMC=$PIECE($GET(^LEX(757.01,LEXDEXP,1)),U,1)
if +LEXMC'>0
QUIT
+11 KILL ^LEX(757.01,"AWRD",X,LEXDEXP,"LINKED")
End DoDot:2
End DoDot:1
+12 SET DA=LEXDEXP
+13 QUIT
REIDXMC ; Re-Index Expression file word index AWRD
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW LEXIDX,LEXREIX,DA,X
SET DA=0
SET X=""
SET (LEXREIX,LEXIDX)=""
KILL ^TMP("LEXSTOP","REIDXMC")
+3 FOR
SET DA=$ORDER(^LEX(757.01,DA))
if +DA=0!($DATA(^TMP("LEXSTOP","REIDXMC")))
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^LEX(757.01,DA,1),U,2)
DO S
End DoDot:1
+5 KILL ^TMP("LEXSTOP","REIDXMC"),LEXIDX,DA,X
+6 QUIT
RMC ; Re-Index Expression file word index AWRD (Task Manager)
+1 SET ZTRTN="REIDXMC^LEXNDX1"
+2 SET ZTDESC="Re-Indexing Major Concept Words in ""AWRD"" index"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
if $DATA(ZTSK)
WRITE !!,"Re-Indexing Major Concept Words in ""AWRD"" index"
if '$DATA(ZTSK)
WRITE !!,"Task to re-index Major Concept not created"
+4 KILL ZTDTH,ZTDESC,ZTIO,ZTRTN
+5 QUIT
RALL ; Re-Index entire file (needs DIC)
+1 SET DIK=$GET(DIC)
if DIK=""
QUIT
if '$DATA(@(DIK_"0)"))
QUIT
+2 SET ZTREQ="@"
SET (ZTSAVE("ZTREQ"),ZTSAVE("DIK"))=""
SET ZTRTN="IXALL^DIK"
+3 SET ZTDESC="Re-Indexing "_DIK
+4 SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
+5 KILL ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTREQ,ZTSAVE
+6 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
