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