LEXNDX6 ;ISL/KER - Set/kill indexes (Misc) ;05/23/2017
;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.4) N/A
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
;
; NEWed/KILLed by FileMan
; DA
;
SRA ; Set Shortcut index
Q:'$D(X)!('$D(DA))!('$D(DA(1))) N LEXKW S LEXKW=$P($G(^LEX(757.4,DA(1),1,DA,0)),U,1) S:$L(LEXKW) ^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXKW),1,63),X,DA(1),DA)="" Q
KRA ; Kill Shortcut index
Q:'$D(X)!('$D(DA))!('$D(DA(1))) N LEXKW S LEXKW=$P($G(^LEX(757.4,DA(1),1,DA,0)),U,1) K:$L(LEXKW) ^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXKW),1,63),X,DA(1),DA) Q
;
SSF ; Set String Frequency
Q:'$L($G(X)) N LEXIDX,LEXE
S LEXIDX="",LEXE=X,X=$$UP^XLFSTR(X) D PTX^LEXTOKN
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
. N LEXNT,LEXT,LEXW,LEXI,LEXP,LEXS S LEXI=""
. S LEXI=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
. . S LEXW=$O(^TMP("LEXTKN",$J,LEXI,"")) Q:'$L(LEXW)
. . F LEXP=1:1:$L(LEXW) D
. . . S LEXS=$E(LEXW,1,LEXP)
. . . ; Re-indexing All Entries of the file
. . . S LEXT=0 I $D(^LEX(757.01,"ASL",LEXS)) D
. . . . S LEXT=$O(^LEX(757.01,"ASL",LEXS,0))
. . . S LEXNT=LEXT+1 Q:LEXNT'>0
. . . K ^LEX(757.01,"ASL",LEXS)
. . . S ^LEX(757.01,"ASL",LEXS,LEXNT)=""
S X=LEXE K ^TMP("LEXTKN",$J) N DICNT,DIKDASV,DIKSAVE K LEXRECAL
Q
KSF ; Kill String Frequency
Q:'$L($G(X)) N LEXIDX,LEXE
S LEXIDX="",LEXE=X,X=$$UP^XLFSTR(X) D PTX^LEXTOKN
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
. N LEXNT,LEXT,LEXW,LEXI,LEXP,LEXS S LEXI=""
. S LEXI=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
. . S LEXW=$O(^TMP("LEXTKN",$J,LEXI,""))
. . I $L(LEXW) F LEXP=1:1:$L(LEXW) D
. . . S LEXS=$E(LEXW,1,LEXP),LEXT=0
. . . I $D(^LEX(757.01,"ASL",LEXS)) D
. . . . S LEXT=$O(^LEX(757.01,"ASL",LEXS,0))
. . . S LEXNT=LEXT-1
. . . I LEXNT'>0 K ^LEX(757.01,"ASL",LEXS) Q
. . . K ^LEX(757.01,"ASL",LEXS)
. . . S ^LEX(757.01,"ASL",LEXS,LEXNT)=""
. . .
S X=LEXE K ^TMP("LEXTKN",$J)
Q
FRE(X) ; Frequency Counter of String
N LEX,LEXA,LEXE,LEXIT,LEXM,LEXN,LEXO,LEXOUT,LEXP,LEXRT,LEXRT2,LEXS,LEXT,LEXTKN
S LEXS=$$UP^XLFSTR($G(X)) Q:'$L(LEXS) 0 S LEXRT="" S:$D(^LEX(757.01,"AWRD")) LEXRT="^LEX(757.01,""AWRD"","
Q:'$L(LEXRT) 0 S (LEXA,LEXN,LEXT)=0
S:$L(LEXS)>1 LEXO=$E(LEXS,1,($L(LEXS)-1))_$C(($A($E(LEXS,$L(LEXS)))-1))_"~"
S:$L(LEXS)=1 LEXO=$C(($A(LEXS)-1))_"~" S LEXIT=0
F S LEXO=$O(@(LEXRT_""""_LEXO_""")")) D Q:LEXIT>0
. S:'$L(LEXO) LEXIT=1 S:$E(LEXO,1,$L(LEXS))'=LEXS LEXIT=1
. Q:LEXIT>0 N LEXM S LEXM=0 F S LEXM=$O(@(LEXRT_""""_LEXO_""","_LEXM_")")) Q:+LEXM'>0 D
. . N LEXE,LEXRT2 S LEXE=0,LEXRT2=LEXRT_""""_LEXO_""","_LEXM_","
. . F S LEXE=$O(@(LEXRT2_LEXE_")")) Q:+LEXE'>0 S LEXT=LEXT+1,LEXA=LEXA+1
I $TR(LEXS,".","")?1N.N,$L(LEXS,".")'>2 I +LEXS=LEXS D
. N LEXFC S LEXFC=$E(LEXS,1) S:$E(LEXS,1)?1N LEXO=LEXS-.000000001
. S:$E(LEXS,1)="." LEXO=.000000001 S LEXIT=0
. F S LEXO=$O(@(LEXRT_+LEXO_")")) D Q:LEXIT>0 Q:'$L(LEXO)
. . S:LEXFC?1N&($E(LEXO,1)'?1N) LEXIT=1
. . S:LEXFC?1P&($E(LEXO,1)'?1P) LEXIT=1 Q:LEXIT>0
. . Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXS))'=LEXS N LEXM S LEXM=0
. . F S LEXM=$O(@(LEXRT_+LEXO_","_LEXM_")")) Q:+LEXM'>0 D
. . . N LEXE,LEXRT2 S LEXE=0,LEXRT2=LEXRT_+LEXO_","_LEXM_","
. . . F S LEXE=$O(@(LEXRT2_LEXE_")")) Q:+LEXE'>0 S LEXT=LEXT+1,LEXN=LEXN+1
S X=LEXT
Q X
;
SSUP ; Set Supplemental Words
N LEXX,LEXDA1,LEXDA,LEXMC,LEXDEA,LEXTTYP
S LEXX=$G(X) Q:'$L(LEXX) S LEXDA1=+($G(DA(1)))
S LEXDEA=$$DEA(LEXDA1),LEXTTYP=$P($G(^LEX(757.01,+LEXDA1,1)),"^",2)
Q:+LEXDEA>0 Q:+LEXTTYP=8
Q:LEXDA1=0 S LEXDA=+($G(DA)) Q:LEXDA=0
S LEXMC=$$MC(LEXDA1) Q:LEXMC=0
S ^LEX(757.01,"AWRD",$$UP^XLFSTR(LEXX),LEXDA1,LEXMC,LEXDA)=""
Q
KSUP ; Kill Supplemental Words
N LEXX,LEXDA1,LEXDA,LEXMC,LEXDEA,LEXTTYP
S LEXX=$G(X) Q:'$L(LEXX) S LEXDA1=+($G(DA(1))) Q:LEXDA1=0 S LEXDA=+($G(DA)) Q:LEXDA=0
S LEXMC=$$MC(LEXDA1) Q:LEXMC=0
K ^LEX(757.01,"AWRD",LEXX,LEXDA1,LEXMC,LEXDA)
K ^LEX(757.01,"AWRD",$$UP^XLFSTR(LEXX),LEXDA1,LEXMC,LEXDA)
Q
;
; Miscellaneous
MC(X) ; Major Concept IEN
N LEXX S LEXX=+($G(X)) Q:LEXX=0 0
S LEXX=+($G(^LEX(757.01,LEXX,1))) Q:LEXX=0 0
S LEXX=+($G(^LEX(757,LEXX,0))) Q:LEXX=0 0
S X=LEXX Q X
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[HLEXNDX6 4723 printed Dec 13, 2024@02:08:18 Page 2
LEXNDX6 ;ISL/KER - Set/kill indexes (Misc) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.4) N/A
+5 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10103
+9 ;
+10 ; NEWed/KILLed by FileMan
+11 ; DA
+12 ;
SRA ; Set Shortcut index
+1 if '$DATA(X)!('$DATA(DA))!('$DATA(DA(1)))
QUIT
NEW LEXKW
SET LEXKW=$PIECE($GET(^LEX(757.4,DA(1),1,DA,0)),U,1)
if $LENGTH(LEXKW)
SET ^LEX(757.4,"ARA",$EXTRACT($$UP^XLFSTR(LEXKW),1,63),X,DA(1),DA)=""
QUIT
KRA ; Kill Shortcut index
+1 if '$DATA(X)!('$DATA(DA))!('$DATA(DA(1)))
QUIT
NEW LEXKW
SET LEXKW=$PIECE($GET(^LEX(757.4,DA(1),1,DA,0)),U,1)
if $LENGTH(LEXKW)
KILL ^LEX(757.4,"ARA",$EXTRACT($$UP^XLFSTR(LEXKW),1,63),X,DA(1),DA)
QUIT
+2 ;
SSF ; Set String Frequency
+1 if '$LENGTH($GET(X))
QUIT
NEW LEXIDX,LEXE
+2 SET LEXIDX=""
SET LEXE=X
SET X=$$UP^XLFSTR(X)
DO PTX^LEXTOKN
+3 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:1
+4 NEW LEXNT,LEXT,LEXW,LEXI,LEXP,LEXS
SET LEXI=""
+5 SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+6 SET LEXW=$ORDER(^TMP("LEXTKN",$JOB,LEXI,""))
if '$LENGTH(LEXW)
QUIT
+7 FOR LEXP=1:1:$LENGTH(LEXW)
Begin DoDot:3
+8 SET LEXS=$EXTRACT(LEXW,1,LEXP)
+9 ; Re-indexing All Entries of the file
+10 SET LEXT=0
IF $DATA(^LEX(757.01,"ASL",LEXS))
Begin DoDot:4
+11 SET LEXT=$ORDER(^LEX(757.01,"ASL",LEXS,0))
End DoDot:4
+12 SET LEXNT=LEXT+1
if LEXNT'>0
QUIT
+13 KILL ^LEX(757.01,"ASL",LEXS)
+14 SET ^LEX(757.01,"ASL",LEXS,LEXNT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET X=LEXE
KILL ^TMP("LEXTKN",$JOB)
NEW DICNT,DIKDASV,DIKSAVE
KILL LEXRECAL
+16 QUIT
KSF ; Kill String Frequency
+1 if '$LENGTH($GET(X))
QUIT
NEW LEXIDX,LEXE
+2 SET LEXIDX=""
SET LEXE=X
SET X=$$UP^XLFSTR(X)
DO PTX^LEXTOKN
+3 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:1
+4 NEW LEXNT,LEXT,LEXW,LEXI,LEXP,LEXS
SET LEXI=""
+5 SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+6 SET LEXW=$ORDER(^TMP("LEXTKN",$JOB,LEXI,""))
+7 IF $LENGTH(LEXW)
FOR LEXP=1:1:$LENGTH(LEXW)
Begin DoDot:3
+8 SET LEXS=$EXTRACT(LEXW,1,LEXP)
SET LEXT=0
+9 IF $DATA(^LEX(757.01,"ASL",LEXS))
Begin DoDot:4
+10 SET LEXT=$ORDER(^LEX(757.01,"ASL",LEXS,0))
End DoDot:4
+11 SET LEXNT=LEXT-1
+12 IF LEXNT'>0
KILL ^LEX(757.01,"ASL",LEXS)
QUIT
+13 KILL ^LEX(757.01,"ASL",LEXS)
+14 SET ^LEX(757.01,"ASL",LEXS,LEXNT)=""
+15 End DoDot:3
End DoDot:2
End DoDot:1
+16 SET X=LEXE
KILL ^TMP("LEXTKN",$JOB)
+17 QUIT
FRE(X) ; Frequency Counter of String
+1 NEW LEX,LEXA,LEXE,LEXIT,LEXM,LEXN,LEXO,LEXOUT,LEXP,LEXRT,LEXRT2,LEXS,LEXT,LEXTKN
+2 SET LEXS=$$UP^XLFSTR($GET(X))
if '$LENGTH(LEXS)
QUIT 0
SET LEXRT=""
if $DATA(^LEX(757.01,"AWRD"))
SET LEXRT="^LEX(757.01,""AWRD"","
+3 if '$LENGTH(LEXRT)
QUIT 0
SET (LEXA,LEXN,LEXT)=0
+4 if $LENGTH(LEXS)>1
SET LEXO=$EXTRACT(LEXS,1,($LENGTH(LEXS)-1))_$CHAR(($ASCII($EXTRACT(LEXS,$LENGTH(LEXS)))-1))_"~"
+5 if $LENGTH(LEXS)=1
SET LEXO=$CHAR(($ASCII(LEXS)-1))_"~"
SET LEXIT=0
+6 FOR
SET LEXO=$ORDER(@(LEXRT_""""_LEXO_""")"))
Begin DoDot:1
+7 if '$LENGTH(LEXO)
SET LEXIT=1
if $EXTRACT(LEXO,1,$LENGTH(LEXS))'=LEXS
SET LEXIT=1
+8 if LEXIT>0
QUIT
NEW LEXM
SET LEXM=0
FOR
SET LEXM=$ORDER(@(LEXRT_""""_LEXO_""","_LEXM_")"))
if +LEXM'>0
QUIT
Begin DoDot:2
+9 NEW LEXE,LEXRT2
SET LEXE=0
SET LEXRT2=LEXRT_""""_LEXO_""","_LEXM_","
+10 FOR
SET LEXE=$ORDER(@(LEXRT2_LEXE_")"))
if +LEXE'>0
QUIT
SET LEXT=LEXT+1
SET LEXA=LEXA+1
End DoDot:2
End DoDot:1
if LEXIT>0
QUIT
+11 IF $TRANSLATE(LEXS,".","")?1N.N
IF $LENGTH(LEXS,".")'>2
IF +LEXS=LEXS
Begin DoDot:1
+12 NEW LEXFC
SET LEXFC=$EXTRACT(LEXS,1)
if $EXTRACT(LEXS,1)?1N
SET LEXO=LEXS-.000000001
+13 if $EXTRACT(LEXS,1)="."
SET LEXO=.000000001
SET LEXIT=0
+14 FOR
SET LEXO=$ORDER(@(LEXRT_+LEXO_")"))
Begin DoDot:2
+15 if LEXFC?1N&($EXTRACT(LEXO,1)'?1N)
SET LEXIT=1
+16 if LEXFC?1P&($EXTRACT(LEXO,1)'?1P)
SET LEXIT=1
if LEXIT>0
QUIT
+17 if '$LENGTH(LEXO)
QUIT
if $EXTRACT(LEXO,1,$LENGTH(LEXS))'=LEXS
QUIT
NEW LEXM
SET LEXM=0
+18 FOR
SET LEXM=$ORDER(@(LEXRT_+LEXO_","_LEXM_")"))
if +LEXM'>0
QUIT
Begin DoDot:3
+19 NEW LEXE,LEXRT2
SET LEXE=0
SET LEXRT2=LEXRT_+LEXO_","_LEXM_","
+20 FOR
SET LEXE=$ORDER(@(LEXRT2_LEXE_")"))
if +LEXE'>0
QUIT
SET LEXT=LEXT+1
SET LEXN=LEXN+1
End DoDot:3
End DoDot:2
if LEXIT>0
QUIT
if '$LENGTH(LEXO)
QUIT
End DoDot:1
+21 SET X=LEXT
+22 QUIT X
+23 ;
SSUP ; Set Supplemental Words
+1 NEW LEXX,LEXDA1,LEXDA,LEXMC,LEXDEA,LEXTTYP
+2 SET LEXX=$GET(X)
if '$LENGTH(LEXX)
QUIT
SET LEXDA1=+($GET(DA(1)))
+3 SET LEXDEA=$$DEA(LEXDA1)
SET LEXTTYP=$PIECE($GET(^LEX(757.01,+LEXDA1,1)),"^",2)
+4 if +LEXDEA>0
QUIT
if +LEXTTYP=8
QUIT
+5 if LEXDA1=0
QUIT
SET LEXDA=+($GET(DA))
if LEXDA=0
QUIT
+6 SET LEXMC=$$MC(LEXDA1)
if LEXMC=0
QUIT
+7 SET ^LEX(757.01,"AWRD",$$UP^XLFSTR(LEXX),LEXDA1,LEXMC,LEXDA)=""
+8 QUIT
KSUP ; Kill Supplemental Words
+1 NEW LEXX,LEXDA1,LEXDA,LEXMC,LEXDEA,LEXTTYP
+2 SET LEXX=$GET(X)
if '$LENGTH(LEXX)
QUIT
SET LEXDA1=+($GET(DA(1)))
if LEXDA1=0
QUIT
SET LEXDA=+($GET(DA))
if LEXDA=0
QUIT
+3 SET LEXMC=$$MC(LEXDA1)
if LEXMC=0
QUIT
+4 KILL ^LEX(757.01,"AWRD",LEXX,LEXDA1,LEXMC,LEXDA)
+5 KILL ^LEX(757.01,"AWRD",$$UP^XLFSTR(LEXX),LEXDA1,LEXMC,LEXDA)
+6 QUIT
+7 ;
+8 ; Miscellaneous
MC(X) ; Major Concept IEN
+1 NEW LEXX
SET LEXX=+($GET(X))
if LEXX=0
QUIT 0
+2 SET LEXX=+($GET(^LEX(757.01,LEXX,1)))
if LEXX=0
QUIT 0
+3 SET LEXX=+($GET(^LEX(757,LEXX,0)))
if LEXX=0
QUIT 0
+4 SET X=LEXX
QUIT X
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
