Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXNDX2

LEXNDX2.m

Go to the documentation of this file.
  1. LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**51,80,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^DD( ICR 345
  1. ; ^LEX(757.011) N/A
  1. ; ^TMP("LEXTKN") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$UP^XLFSTR ICR 10103
  1. ;
  1. SS ; Get (unique) text for an expression in the Subset file
  1. Q:'$D(X)!('$D(DA))
  1. N LEXEXP,LEXMC,LEXTEXP,LEXOLDX S LEXOLDX=X
  1. S LEXEXP=+(^LEX(757.21,DA,0)) Q:$P($G(^LEX(757.01,+LEXEXP,1)),U,5)>0
  1. S LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
  1. S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
  1. . Q:$P($G(^LEX(757.01,+LEXTEXP,1)),U,5)>0 N LEXTTYP,LEXDEA
  1. . S LEXTTYP=+($P($G(^LEX(757.01,+LEXTEXP,1)),U,2)) Q:LEXTTYP=8
  1. . S LEXDEA=$$DEA(+LEXTEXP) Q:LEXDEA>0
  1. . S X=^LEX(757.01,LEXTEXP,0) D SS2
  1. S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP
  1. Q
  1. SS2 ; Parse text and set node for each word
  1. N LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
  1. S LEXYPE=+($P($G(^LEX(757.01,LEXTEXP,1)),U,2)) Q:LEXYPE'>0
  1. S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),"^",2)) Q:LEXT=0
  1. S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
  1. D PTX^LEXTOKN,KNR
  1. I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="",LEXJ=0 D
  1. . F S LEXJ=$O(^TMP("LEXTKN",$J,LEXJ)) Q:+LEXJ'>0 D
  1. . . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,"")) Q:'$L(LEXI)
  1. . . S:'$D(^LEX(757.21,LEXSIDX,LEXI,DA)) ^LEX(757.21,LEXSIDX,LEXI,DA)=""
  1. K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
  1. SK ; Get (all) text for an expression in the Subset file
  1. Q:'$D(X)!('$D(DA))
  1. N LEXEXP,LEXMC,LEXTEXP,LEXOLDX,LEXDEA,LEXTTYP S LEXOLDX=X
  1. S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
  1. S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
  1. . S X=^LEX(757.01,LEXTEXP,0) D SK2
  1. S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP Q
  1. SK2 ; Parse text and kill node for each word
  1. N LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
  1. S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
  1. D PTX^LEXTOKN,KNR
  1. I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="",LEXJ=0 D
  1. . F S LEXJ=$O(^TMP("LEXTKN",$J,LEXJ)) Q:+LEXJ'>0 D
  1. . . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,"")) Q:'$L(LEXI)
  1. . . K ^LEX(757.21,LEXSIDX,LEXI,DA)
  1. K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
  1. SET ; Given DIC and DA set indexes
  1. Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
  1. N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
  1. S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
  1. S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
  1. . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
  1. . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
  1. . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
  1. . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
  1. . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
  1. . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
  1. . . I DA>$P($G(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3) S $P(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
  1. K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
  1. Q
  1. KILL ; Given DIC and DA kill indexes
  1. Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
  1. N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
  1. S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
  1. S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
  1. . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
  1. . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
  1. . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
  1. . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
  1. . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
  1. . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
  1. K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
  1. Q
  1. SAPP ; Set application subset definition index
  1. I X'="" D
  1. . N LEXIDX S LEXIDX=$P(^LEXT(757.2,DA,0),U,2) I LEXIDX'="" D
  1. . . K ^LEXT(757.2,"AA",LEXIDX) S $P(^LEXT(757.2,DA,0),U,2)="" K LEXIDX
  1. . S ^LEXT(757.2,"AB",X,DA)=""
  1. Q
  1. KAPP ; Kill application subset definition index
  1. K ^LEXT(757.2,"AB",X,DA) Q
  1. SSM ; Set index for Subset Mnemonic
  1. S ^LEXT(757.2,"AA",X,DA)="" N LEXX,LEXLOW
  1. S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
  1. S:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA)="",^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
  1. I $L(LEXX) D
  1. . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
  1. . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
  1. . . S ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)=""
  1. . . S ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)=""
  1. Q
  1. KSM ; Kill index for Subset Mnemonic
  1. K ^LEXT(757.2,"AA",X,DA) N LEXX,LEXLOW
  1. S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
  1. K:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
  1. I $L(LEXX) D
  1. . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
  1. . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
  1. . . K ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)
  1. . . K ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)
  1. Q
  1. KNR ; keywords and replacement words
  1. Q:+($G(LEXDEA))>0 Q:+($G(LEXTTYP))=8
  1. N LEXV,LEXN
  1. I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
  1. .I $D(^LEX(757.01,LEXTEXP,5)) D
  1. ..S LEXV=""
  1. ..F S LEXV=$O(^LEX(757.01,LEXTEXP,5,"B",LEXV)) Q:LEXV="" D
  1. ...D ADDTKN(LEXV)
  1. .I $D(^LEX(757.05,"AEXP",LEXTEXP)) D
  1. ..S LEXN=""
  1. ..F S LEXN=$O(^LEX(757.05,"AEXP",LEXTEXP,LEXN)) Q:LEXN="" D
  1. ...S LEXV=$P(^LEX(757.05,LEXN,0),U)
  1. ...D ADDTKN(LEXV)
  1. Q
  1. ADDTKN(LEXV) ; add to LEXTKN
  1. N LEXC
  1. S LEXC=^TMP("LEXTKN",$J,0)+1
  1. S ^TMP("LEXTKN",$J,LEXC,LEXV)=""
  1. S ^TMP("LEXTKN",$J,0)=LEXC
  1. Q
  1. DEA(X) ; Expression/Concept Deactive
  1. N LEXA,LEXEA,LEXEIEN,LEXMA,LEXMIEN,LEXN S LEXEIEN=+($G(X)),LEXN=$G(^LEX(757.01,+LEXEIEN,1))
  1. S LEXEA=+($P(LEXN,"^",5)),LEXMIEN=+LEXN,LEXN=+($P(LEXN,"^",2)) Q:LEXN=1&(LEXEA>0) 1 Q:LEXN=1&(LEXEA'>0) 0
  1. S LEXMIEN=+($G(^LEX(757,+LEXMIEN,0))),LEXMA=+($P($G(^LEX(757.01,+LEXMIEN,1)),"^",5)) Q:(LEXEA+LEXMA)>0 1
  1. Q 0