- 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 Jan 18, 2025@03:09:08 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