LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;04/21/2014
;;2.0;LEXICON UTILITY;**51,80**;Sep 23, 1996;Build 10
; Per VHA Directive 2004-038, this routine should not be modified.
;
; 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)),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 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
D 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 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
D 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
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
LEXNDX2 ;ISL/KER - Set/kill indexes (Part 2) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**51,80**;Sep 23, 1996;Build 10
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Global Variables
+5 ; ^DD( ICR 345
+6 ; ^LEX(757.011) N/A
+7 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$UP^XLFSTR ICR 10103
+11 ;
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))
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 SS2
End DoDot:1
+6 SET X=LEXOLDX
KILL LEXOLDX,LEXEXP,LEXMC,LEXTEXP
+7 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
+6 DO KNR
+7 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI=""
SET LEXJ=0
Begin DoDot:1
+8 FOR
SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
IF +LEXJ'>0
QUIT
Begin DoDot:2
+9 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
IF '$LENGTH(LEXI)
QUIT
+10 IF '$DATA(^LEX(757.21,LEXSIDX,LEXI,DA))
SET ^LEX(757.21,LEXSIDX,LEXI,DA)=""
End DoDot:2
End DoDot:1
+11 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
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
+4 DO KNR
+5 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI=""
SET LEXJ=0
Begin DoDot:1
+6 FOR
SET LEXJ=$ORDER(^TMP("LEXTKN",$JOB,LEXJ))
IF +LEXJ'>0
QUIT
Begin DoDot:2
+7 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
IF '$LENGTH(LEXI)
QUIT
+8 KILL ^LEX(757.21,LEXSIDX,LEXI,DA)
End DoDot:2
End DoDot:1
+9 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 NEW LEXV,LEXN
+2 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:1
+3 IF $DATA(^LEX(757.01,LEXTEXP,5))
Begin DoDot:2
+4 SET LEXV=""
+5 FOR
SET LEXV=$ORDER(^LEX(757.01,LEXTEXP,5,"B",LEXV))
IF LEXV=""
QUIT
Begin DoDot:3
+6 DO ADDTKN(LEXV)
End DoDot:3
End DoDot:2
+7 IF $DATA(^LEX(757.05,"AEXP",LEXTEXP))
Begin DoDot:2
+8 SET LEXN=""
+9 FOR
SET LEXN=$ORDER(^LEX(757.05,"AEXP",LEXTEXP,LEXN))
IF LEXN=""
QUIT
Begin DoDot:3
+10 SET LEXV=$PIECE(^LEX(757.05,LEXN,0),U)
+11 DO ADDTKN(LEXV)
End DoDot:3
End DoDot:2
End DoDot:1
+12 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
