- LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;05/23/2017
- ;;2.0;LEXICON UTILITY;**51,80,103**;Sep 23, 1996;Build 2
- ;
- ; Global Variables
- ; ^DD( ICR 345
- ; ^LEX(757.011) N/A
- ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- ;
- ; External References
- ; $$UP^XLFSTR ICR 10103
- ;
- SS ; Get (unique) text for an expression in the Subset file
- Q:'$D(X)!('$D(DA))
- N LEXEXP,LEXMC,LEXTEXP,LEXOLDX S LEXOLDX=X
- S LEXEXP=+(^LEX(757.21,DA,0)) Q:$P($G(^LEX(757.01,+LEXEXP,1)),U,5)>0
- S LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
- S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
- . Q:$P($G(^LEX(757.01,+LEXTEXP,1)),U,5)>0 N LEXTTYP,LEXDEA
- . S LEXTTYP=+($P($G(^LEX(757.01,+LEXTEXP,1)),U,2)) Q:LEXTTYP=8
- . S LEXDEA=$$DEA(+LEXTEXP) Q:LEXDEA>0
- . S X=^LEX(757.01,LEXTEXP,0) D SS2
- S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP
- Q
- SS2 ; Parse text and set node for each word
- N LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
- S LEXYPE=+($P($G(^LEX(757.01,LEXTEXP,1)),U,2)) Q:LEXYPE'>0
- S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),"^",2)) Q:LEXT=0
- S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
- D PTX^LEXTOKN,KNR
- 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)
- . . S:'$D(^LEX(757.21,LEXSIDX,LEXI,DA)) ^LEX(757.21,LEXSIDX,LEXI,DA)=""
- K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
- SK ; Get (all) text for an expression in the Subset file
- Q:'$D(X)!('$D(DA))
- N LEXEXP,LEXMC,LEXTEXP,LEXOLDX,LEXDEA,LEXTTYP S LEXOLDX=X
- S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
- S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
- . S X=^LEX(757.01,LEXTEXP,0) D SK2
- S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP Q
- SK2 ; Parse text and kill node for each word
- N LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
- S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
- D PTX^LEXTOKN,KNR
- 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)
- . . K ^LEX(757.21,LEXSIDX,LEXI,DA)
- K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
- SET ; Given DIC and DA set indexes
- Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
- N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
- S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
- . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
- . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
- . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
- . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
- . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
- . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
- . . I DA>$P($G(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3) S $P(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
- K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- Q
- KILL ; Given DIC and DA kill indexes
- Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
- N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
- S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
- . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
- . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
- . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
- . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
- . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
- . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
- K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- Q
- SAPP ; Set application subset definition index
- I X'="" D
- . N LEXIDX S LEXIDX=$P(^LEXT(757.2,DA,0),U,2) I LEXIDX'="" D
- . . K ^LEXT(757.2,"AA",LEXIDX) S $P(^LEXT(757.2,DA,0),U,2)="" K LEXIDX
- . S ^LEXT(757.2,"AB",X,DA)=""
- Q
- KAPP ; Kill application subset definition index
- K ^LEXT(757.2,"AB",X,DA) Q
- SSM ; Set index for Subset Mnemonic
- S ^LEXT(757.2,"AA",X,DA)="" N LEXX,LEXLOW
- S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
- S:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA)="",^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
- I $L(LEXX) D
- . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
- . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
- . . S ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)=""
- . . S ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)=""
- Q
- KSM ; Kill index for Subset Mnemonic
- K ^LEXT(757.2,"AA",X,DA) N LEXX,LEXLOW
- S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
- K:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
- I $L(LEXX) D
- . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOKN
- . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
- . . K ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)
- . . K ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)
- Q
- KNR ; keywords and replacement words
- Q:+($G(LEXDEA))>0 Q:+($G(LEXTTYP))=8
- N LEXV,LEXN
- I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
- .I $D(^LEX(757.01,LEXTEXP,5)) D
- ..S LEXV=""
- ..F S LEXV=$O(^LEX(757.01,LEXTEXP,5,"B",LEXV)) Q:LEXV="" D
- ...D ADDTKN(LEXV)
- .I $D(^LEX(757.05,"AEXP",LEXTEXP)) D
- ..S LEXN=""
- ..F S LEXN=$O(^LEX(757.05,"AEXP",LEXTEXP,LEXN)) Q:LEXN="" D
- ...S LEXV=$P(^LEX(757.05,LEXN,0),U)
- ...D ADDTKN(LEXV)
- Q
- ADDTKN(LEXV) ; add to LEXTKN
- N LEXC
- S LEXC=^TMP("LEXTKN",$J,0)+1
- S ^TMP("LEXTKN",$J,LEXC,LEXV)=""
- S ^TMP("LEXTKN",$J,0)=LEXC
- 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[HLEXNDX2 5973 printed Jan 18, 2025@03:09:09 Page 2
- LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**51,80,103**;Sep 23, 1996;Build 2
- +2 ;
- +3 ; Global Variables
- +4 ; ^DD( ICR 345
- +5 ; ^LEX(757.011) N/A
- +6 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- +7 ;
- +8 ; External References
- +9 ; $$UP^XLFSTR ICR 10103
- +10 ;
- SS ; Get (unique) text for an expression in the Subset file
- +1 if '$DATA(X)!('$DATA(DA))
- QUIT
- +2 NEW LEXEXP,LEXMC,LEXTEXP,LEXOLDX
- SET LEXOLDX=X
- +3 SET LEXEXP=+(^LEX(757.21,DA,0))
- if $PIECE($GET(^LEX(757.01,+LEXEXP,1)),U,5)>0
- QUIT
- +4 SET LEXMC=$PIECE(^LEX(757.01,LEXEXP,1),U,1)
- +5 SET LEXTEXP=0
- FOR
- SET LEXTEXP=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXTEXP))
- if +LEXTEXP=0
- QUIT
- Begin DoDot:1
- +6 if $PIECE($GET(^LEX(757.01,+LEXTEXP,1)),U,5)>0
- QUIT
- NEW LEXTTYP,LEXDEA
- +7 SET LEXTTYP=+($PIECE($GET(^LEX(757.01,+LEXTEXP,1)),U,2))
- if LEXTTYP=8
- QUIT
- +8 SET LEXDEA=$$DEA(+LEXTEXP)
- if LEXDEA>0
- QUIT
- +9 SET X=^LEX(757.01,LEXTEXP,0)
- DO SS2
- End DoDot:1
- +10 SET X=LEXOLDX
- KILL LEXOLDX,LEXEXP,LEXMC,LEXTEXP
- +11 QUIT
- SS2 ; Parse text and set node for each word
- +1 NEW LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI
- SET LEXIDX=""
- +2 SET LEXYPE=+($PIECE($GET(^LEX(757.01,LEXTEXP,1)),U,2))
- if LEXYPE'>0
- QUIT
- +3 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXYPE,0)),"^",2))
- if LEXT=0
- QUIT
- +4 SET LEXSIDX="A"_$PIECE(^LEXT(757.2,LEXOLDX,0),U,2)
- +5 DO PTX^LEXTOKN
- DO KNR
- +6 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 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
- if '$LENGTH(LEXI)
- QUIT
- +9 if '$DATA(^LEX(757.21,LEXSIDX,LEXI,DA))
- SET ^LEX(757.21,LEXSIDX,LEXI,DA)=""
- End DoDot:2
- End DoDot:1
- +10 KILL LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
- QUIT
- SK ; Get (all) text for an expression in the Subset file
- +1 if '$DATA(X)!('$DATA(DA))
- QUIT
- +2 NEW LEXEXP,LEXMC,LEXTEXP,LEXOLDX,LEXDEA,LEXTTYP
- SET LEXOLDX=X
- +3 SET LEXEXP=+(^LEX(757.21,DA,0))
- SET LEXMC=$PIECE(^LEX(757.01,LEXEXP,1),U,1)
- +4 SET LEXTEXP=0
- FOR
- SET LEXTEXP=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXTEXP))
- if +LEXTEXP=0
- QUIT
- Begin DoDot:1
- +5 SET X=^LEX(757.01,LEXTEXP,0)
- DO SK2
- End DoDot:1
- +6 SET X=LEXOLDX
- KILL LEXOLDX,LEXEXP,LEXMC,LEXTEXP
- QUIT
- SK2 ; Parse text and kill node for each word
- +1 NEW LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI
- SET LEXIDX=""
- +2 SET LEXSIDX="A"_$PIECE(^LEXT(757.2,LEXOLDX,0),U,2)
- +3 DO PTX^LEXTOKN
- DO KNR
- +4 IF $DATA(^TMP("LEXTKN",$JOB,0))
- IF ^TMP("LEXTKN",$JOB,0)>0
- SET LEXI=""
- SET LEXJ=0
- Begin DoDot:1
- +5 FOR
- SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
- if +LEXJ'>0
- QUIT
- Begin DoDot:2
- +6 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
- if '$LENGTH(LEXI)
- QUIT
- +7 KILL ^LEX(757.21,LEXSIDX,LEXI,DA)
- End DoDot:2
- End DoDot:1
- +8 KILL LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$JOB,0),^TMP("LEXTKN",$JOB)
- QUIT
- SET ; Given DIC and DA set indexes
- +1 if $DATA(DIC)#2=0!('$DATA(DA))
- QUIT
- if DIC'["LEX("&(DIC'["LEX(")
- QUIT
- +2 NEW LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- +3 SET LEXFN=+($PIECE(DIC,"(",2))
- SET LEXRT=$TRANSLATE($PIECE(DIC,"(",1),"^","")
- +4 SET LEXFL=0
- FOR
- SET LEXFL=$ORDER(^DD(LEXFN,LEXFL))
- if +LEXFL=0
- QUIT
- Begin DoDot:1
- +5 SET LEXN=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",1)
- +6 SET LEXP=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",2)
- SET LEXRIDX=0
- +7 FOR
- SET LEXRIDX=$ORDER(^DD(LEXFN,LEXFL,1,LEXRIDX))
- if +LEXRIDX=0
- QUIT
- Begin DoDot:2
- +8 IF $LENGTH($PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP))
- Begin DoDot:3
- +9 SET X=$PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
- +10 if X'=""
- XECUTE ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
- End DoDot:3
- +11 IF DA>$PIECE($GET(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3)
- SET $PIECE(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
- End DoDot:2
- End DoDot:1
- +12 KILL LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- +13 QUIT
- KILL ; Given DIC and DA kill indexes
- +1 if $DATA(DIC)#2=0!('$DATA(DA))
- QUIT
- if DIC'["LEX("&(DIC'["LEX(")
- QUIT
- +2 NEW LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- +3 SET LEXFN=+($PIECE(DIC,"(",2))
- SET LEXRT=$TRANSLATE($PIECE(DIC,"(",1),"^","")
- +4 SET LEXFL=0
- FOR
- SET LEXFL=$ORDER(^DD(LEXFN,LEXFL))
- if +LEXFL=0
- QUIT
- Begin DoDot:1
- +5 SET LEXN=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",1)
- +6 SET LEXP=$PIECE($PIECE(^DD(LEXFN,LEXFL,0),U,4),";",2)
- SET LEXRIDX=0
- +7 FOR
- SET LEXRIDX=$ORDER(^DD(LEXFN,LEXFL,1,LEXRIDX))
- if +LEXRIDX=0
- QUIT
- Begin DoDot:2
- +8 IF $LENGTH($PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP))
- Begin DoDot:3
- +9 SET X=$PIECE($GET(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
- +10 if X'=""
- XECUTE ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 KILL LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
- +12 QUIT
- SAPP ; Set application subset definition index
- +1 IF X'=""
- Begin DoDot:1
- +2 NEW LEXIDX
- SET LEXIDX=$PIECE(^LEXT(757.2,DA,0),U,2)
- IF LEXIDX'=""
- Begin DoDot:2
- +3 KILL ^LEXT(757.2,"AA",LEXIDX)
- SET $PIECE(^LEXT(757.2,DA,0),U,2)=""
- KILL LEXIDX
- End DoDot:2
- +4 SET ^LEXT(757.2,"AB",X,DA)=""
- End DoDot:1
- +5 QUIT
- KAPP ; Kill application subset definition index
- +1 KILL ^LEXT(757.2,"AB",X,DA)
- QUIT
- SSM ; Set index for Subset Mnemonic
- +1 SET ^LEXT(757.2,"AA",X,DA)=""
- NEW LEXX,LEXLOW
- +2 SET LEXX=$PIECE($GET(^LEXT(757.2,DA,0)),U,1)
- +3 if $LENGTH(LEXX)
- SET ^LEXT(757.2,"AA",LEXX,DA)=""
- SET ^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
- +4 IF $LENGTH(LEXX)
- Begin DoDot:1
- +5 NEW X,LEXI
- SET X=LEXX
- SET LEXLOW=""
- DO PTX^LEXTOKN
- +6 IF +($GET(^TMP("LEXTKN",$JOB,0)))>0
- FOR LEXI=1:1:+($GET(^TMP("LEXTKN",$JOB,0)))
- Begin DoDot:2
- +7 SET ^LEXT(757.2,"AA",$ORDER(^TMP("LEXTKN",$JOB,LEXI,"")),DA)=""
- +8 SET ^LEXT(757.2,"AA",$$UP^XLFSTR($ORDER(^TMP("LEXTKN",$JOB,LEXI,""))),DA)=""
- End DoDot:2
- End DoDot:1
- +9 QUIT
- KSM ; Kill index for Subset Mnemonic
- +1 KILL ^LEXT(757.2,"AA",X,DA)
- NEW LEXX,LEXLOW
- +2 SET LEXX=$PIECE($GET(^LEXT(757.2,DA,0)),U,1)
- +3 if $LENGTH(LEXX)
- KILL ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
- +4 IF $LENGTH(LEXX)
- Begin DoDot:1
- +5 NEW X,LEXI
- SET X=LEXX
- SET LEXLOW=""
- DO PTX^LEXTOKN
- +6 IF +($GET(^TMP("LEXTKN",$JOB,0)))>0
- FOR LEXI=1:1:+($GET(^TMP("LEXTKN",$JOB,0)))
- Begin DoDot:2
- +7 KILL ^LEXT(757.2,"AA",$ORDER(^TMP("LEXTKN",$JOB,LEXI,"")),DA)
- +8 KILL ^LEXT(757.2,"AA",$$UP^XLFSTR($ORDER(^TMP("LEXTKN",$JOB,LEXI,""))),DA)
- End DoDot:2
- End DoDot:1
- +9 QUIT
- KNR ; keywords and replacement words
- +1 if +($GET(LEXDEA))>0
- QUIT
- if +($GET(LEXTTYP))=8
- QUIT
- +2 NEW LEXV,LEXN
- +3 IF $DATA(^TMP("LEXTKN",$JOB,0))
- IF ^TMP("LEXTKN",$JOB,0)>0
- Begin DoDot:1
- +4 IF $DATA(^LEX(757.01,LEXTEXP,5))
- Begin DoDot:2
- +5 SET LEXV=""
- +6 FOR
- SET LEXV=$ORDER(^LEX(757.01,LEXTEXP,5,"B",LEXV))
- if LEXV=""
- QUIT
- Begin DoDot:3
- +7 DO ADDTKN(LEXV)
- End DoDot:3
- End DoDot:2
- +8 IF $DATA(^LEX(757.05,"AEXP",LEXTEXP))
- Begin DoDot:2
- +9 SET LEXN=""
- +10 FOR
- SET LEXN=$ORDER(^LEX(757.05,"AEXP",LEXTEXP,LEXN))
- if LEXN=""
- QUIT
- Begin DoDot:3
- +11 SET LEXV=$PIECE(^LEX(757.05,LEXN,0),U)
- +12 DO ADDTKN(LEXV)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- ADDTKN(LEXV) ; add to LEXTKN
- +1 NEW LEXC
- +2 SET LEXC=^TMP("LEXTKN",$JOB,0)+1
- +3 SET ^TMP("LEXTKN",$JOB,LEXC,LEXV)=""
- +4 SET ^TMP("LEXTKN",$JOB,0)=LEXC
- +5 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