- 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