LEXAMD ;ISL/KER - Look-up Modifiers ;04/21/2014
;;2.0;LEXICON UTILITY;**6,25,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^TMP("LEXFND" SACC 2.3.2.5.1
; ^TMP("LEXHIT" SACC 2.3.2.5.1
; ^TMP("LEXSCH" SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10104
;
; LEXX IEN file 757.01 of an expression w/Modifiers
; LEXVDT Date to screen against
;
EN(LEXX,LEXVDT) ; Look-up Modifiers
S LEXX=+($G(LEXX)) Q:+($G(^TMP("LEXSCH",$J,"MOD",0)))=0
Q:+($G(LEXX))'>2 Q:'$D(^LEX(757.01,+($G(LEXX)),0))
Q:+($P($G(^LEX(757.01,+LEXX,1)),"^",6))=0
Q:'$D(^LEX(757.01,"APAR",LEXX)) N LEXXN D ARY
Q
ARY ; Build Array of Modified Terms
N LEXLVL,LEXO,LEXI,LEXN,LEXA,LEXT,LEXDSP,LEXDES,LEXL
S LEXI=0,LEXXN=$G(^LEX(757.01,LEXX,0)),LEXA(0)=1
S LEXA(1,LEXX)=LEXXN,LEXLVL=+($G(LEX("LVL"))) S:LEXLVL=0 LEXLVL=1
F S LEXI=$O(^LEX(757.01,"APAR",LEXX,LEXI)) Q:+LEXI=0 D
. S LEXN=$G(^LEX(757.01,LEXI,1)) Q:LEXN="" S LEXT=+($P(LEXN,"^",2)) Q:LEXT'=7
. S LEXO=+($P(LEXN,"^",10)) S:LEXO'=0 LEXO=LEXO+1 S:LEXO=0 LEXO=99999 I $D(LEXA(LEXO)) F Q:'$D(LEXA(LEXO)) S LEXO=LEXO+1
. S LEXA(LEXO,LEXI)=$G(^LEX(757.01,LEXI,0)),LEXA(0)=+($G(LEXA(0)))+1
; Quit if no Modified Terms Found
Q:+($G(LEXA(0)))'>1 S (LEXO,LEXI)=0 D FND
Q
FND ; Build List of Modifiers Found (LEXFND)
K ^TMP("LEXSCH",$J,"EXM"),^TMP("LEXSCH",$J,"NAR"),^TMP("LEXSCH",$J,"SCH"),^TMP("LEXSCH",$J,"TOL"),^TMP("LEXSCH",$J,"NUM"),^TMP("LEXFND",$J)
F S LEXO=$O(LEXA(LEXO)) Q:+LEXO=0 D
. S LEXI=0 F S LEXI=$O(LEXA(LEXO,LEXI)) Q:+LEXI=0 D
. . I LEXO=1 S LEXDES=$$DES(LEXI),LEXDSP=$$SO^LEXASO(LEXI,$G(LEXSHOW),1,$G(LEXVDT))
. . I LEXO>1 S (LEXDES,LEXDSP)=""
. . S LEXT=$G(LEXA(LEXO,LEXI)) Q:'$L(LEXT)
. . S:$L(LEXDES) LEXT=LEXT_" "_LEXDES
. . S:$L(LEXDSP) LEXT=LEXT_" "_LEXDSP
. . S LEXN=-999999999+($G(LEXO))
. . S ^TMP("LEXFND",$J,LEXN,LEXI)=LEXT
. . S ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
HIT ; Build HIT list
I $D(^TMP("LEXFND",$J)) D Q
. K LEX,^TMP("LEXHIT",$J)
. S LEX=+($G(LEXA(0)))
. S LEX("LVL")=+($G(LEXLVL))+1
. I +LEX>0 D
. . N LEXMAT S LEXMAT=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found for """_LEXXN_""""
. . S:$$UP^XLFSTR($G(LEXSUG))["SUGGEST" LEXMAT=+LEX_" suggestion"_$S(+LEX>1:"s",1:"")_" found for """_LEXXN_""""
. . S (^TMP("LEXSCH",$J,"MAT",0),LEX("MAT"))=LEXMAT D SCH,BEG,NAR N LEXSUG
I '$D(^TMP("LEXFND",$J)) D NOM
Q
SCH ; Search Conditions/Results
K ^TMP("LEXSCH",$J,"EXM")
S ^TMP("LEXSCH",$J,"NAR",0)=$$UP(LEXXN)
S ^TMP("LEXSCH",$J,"SCH",0)=$$UP(LEXXN)
S ^TMP("LEXSCH",$J,"TOL",0)=1
S ^TMP("LEXSCH",$J,"NUM",0)=+($G(^TMP("LEXSCH",$J,"NUM",0)))
Q
NOM ; No Modifiers
K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J,"EXM"),^TMP("LEXSCH",$J,"NAR"),^TMP("LEXSCH",$J,"SCH"),^TMP("LEXSCH",$J,"TOL")
S ^TMP("LEXSCH",$J,"NUM",0)=0 S:$L($G(LEXXN)) ^TMP("LEXSCH",$J,"NAR",0)=$$UP(LEXXN) S:$L($G(LEXXN)) ^TMP("LEXSCH",$J,"SCH",0)=$$UP(LEXXN)
Q
NAR ; Narrative
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q
DES(LEXX) ; Get description flag
N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1),LEXM=+($G(^LEX(757,+($G(LEXM)),0))) S:$D(^LEX(757.01,LEXM,3)) LEXDES="*" S LEXX=$G(LEXDES) Q LEXX
BEG ; Begin List
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q:'$D(^TMP("LEXFND",$J))
N LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP,LEXLL
S LEXRL=0,LEXLL=+($G(^TMP("LEXSCH",$J,"LEN",0)))
S:+LEXLL=0 (LEXRL,LEXLL)=5 S LEXJ=0,LEXI=-9999999999
; Hit List ^TMP("LEXHIT",$J,#)
F S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:+LEXI=0 D
. S LEXA=0
. F S LEXA=$O(^TMP("LEXFND",$J,LEXI,LEXA)) Q:+LEXA=0!(LEXJ=LEXLL) D Q:+LEXA=0!(LEXJ=LEXLL)
. . S LEXJ=LEXJ+1,LEXDP=^TMP("LEXFND",$J,LEXI,LEXA)
. . S ^TMP("LEXHIT",$J,0)=LEXJ
. . S ^TMP("LEXHIT",$J,LEXJ)=LEXA_"^"_LEXDP
. . S:+($G(^TMP("LEXSCH",$J,"EXM",0)))=+LEXA ^TMP("LEXSCH",$J,"EXM",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
. . S:+($G(^TMP("LEXSCH",$J,"EXC",0)))=+LEXA ^TMP("LEXSCH",$J,"EXC",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
. . K ^TMP("LEXFND",$J,LEXI,LEXA)
; List LEX("LIST")
I $D(^TMP("LEXSCH",$J,"NUM",0)) S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
I LEXLL>0 D
. N LEXI,LEXJ S (LEXJ,LEXI)=0
. F S LEXJ=$O(^TMP("LEXHIT",$J,LEXJ)) Q:+LEXJ=0!(+LEXI=LEXLL) D Q:+LEXI=LEXLL
. . S LEXI=LEXI+1,LEX("LIST",LEXI)=^TMP("LEXHIT",$J,LEXJ)
. . S LEX("LIST",0)=LEXI_"^"_LEXI
. . S (LEX("MAX"),^TMP("LEXSCH",$J,"LST",0))=LEXI
S ^TMP("LEXSCH",$J,"TOL",0)=0 S:$D(LEX("LIST",1)) ^TMP("LEXSCH",$J,"TOL",0)=1
S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
S:^TMP("LEXSCH",$J,"TOL",0)=1&(+($G(LEX))>0) LEX("MAT")=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found"
S:+($G(LEX("MAX")))>0 LEX("MIN")=1
I $L($G(^TMP("LEXSCH",$J,"EXM",2))) S LEX("EXM")=^TMP("LEXSCH",$J,"EXM",2)
I $L($G(^TMP("LEXSCH",$J,"EXC",2))) S LEX("EXC")=^TMP("LEXSCH",$J,"EXC",2)
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q:'$D(^TMP("LEXFND",$J)) K:+($G(LEXRL))>0 LEXLL
Q
UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CLR K X,Y,LEXLL,LEXSHOW,LEX,^TMP("LEXSCH"),^TMP("LEXHIT"),^TMP("LEXFND") Q
LEXAMD ;ISL/KER - Look-up Modifiers ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**6,25,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+5 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
+6 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$UP^XLFSTR ICR 10104
+10 ;
+11 ; LEXX IEN file 757.01 of an expression w/Modifiers
+12 ; LEXVDT Date to screen against
+13 ;
EN(LEXX,LEXVDT) ; Look-up Modifiers
+1 SET LEXX=+($GET(LEXX))
IF +($GET(^TMP("LEXSCH",$JOB,"MOD",0)))=0
QUIT
+2 IF +($GET(LEXX))'>2
QUIT
IF '$DATA(^LEX(757.01,+($GET(LEXX)),0))
QUIT
+3 IF +($PIECE($GET(^LEX(757.01,+LEXX,1)),"^",6))=0
QUIT
+4 IF '$DATA(^LEX(757.01,"APAR",LEXX))
QUIT
NEW LEXXN
DO ARY
+5 QUIT
ARY ; Build Array of Modified Terms
+1 NEW LEXLVL,LEXO,LEXI,LEXN,LEXA,LEXT,LEXDSP,LEXDES,LEXL
+2 SET LEXI=0
SET LEXXN=$GET(^LEX(757.01,LEXX,0))
SET LEXA(0)=1
+3 SET LEXA(1,LEXX)=LEXXN
SET LEXLVL=+($GET(LEX("LVL")))
IF LEXLVL=0
SET LEXLVL=1
+4 FOR
SET LEXI=$ORDER(^LEX(757.01,"APAR",LEXX,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+5 SET LEXN=$GET(^LEX(757.01,LEXI,1))
IF LEXN=""
QUIT
SET LEXT=+($PIECE(LEXN,"^",2))
IF LEXT'=7
QUIT
+6 SET LEXO=+($PIECE(LEXN,"^",10))
IF LEXO'=0
SET LEXO=LEXO+1
IF LEXO=0
SET LEXO=99999
IF $DATA(LEXA(LEXO))
FOR
IF '$DATA(LEXA(LEXO))
QUIT
SET LEXO=LEXO+1
+7 SET LEXA(LEXO,LEXI)=$GET(^LEX(757.01,LEXI,0))
SET LEXA(0)=+($GET(LEXA(0)))+1
End DoDot:1
+8 ; Quit if no Modified Terms Found
+9 IF +($GET(LEXA(0)))'>1
QUIT
SET (LEXO,LEXI)=0
DO FND
+10 QUIT
FND ; Build List of Modifiers Found (LEXFND)
+1 KILL ^TMP("LEXSCH",$JOB,"EXM"),^TMP("LEXSCH",$JOB,"NAR"),^TMP("LEXSCH",$JOB,"SCH"),^TMP("LEXSCH",$JOB,"TOL"),^TMP("LEXSCH",$JOB,"NUM"),^TMP("LEXFND",$JOB)
+2 FOR
SET LEXO=$ORDER(LEXA(LEXO))
IF +LEXO=0
QUIT
Begin DoDot:1
+3 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXO,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:2
+4 IF LEXO=1
SET LEXDES=$$DES(LEXI)
SET LEXDSP=$$SO^LEXASO(LEXI,$GET(LEXSHOW),1,$GET(LEXVDT))
+5 IF LEXO>1
SET (LEXDES,LEXDSP)=""
+6 SET LEXT=$GET(LEXA(LEXO,LEXI))
IF '$LENGTH(LEXT)
QUIT
+7 IF $LENGTH(LEXDES)
SET LEXT=LEXT_" "_LEXDES
+8 IF $LENGTH(LEXDSP)
SET LEXT=LEXT_" "_LEXDSP
+9 SET LEXN=-999999999+($GET(LEXO))
+10 SET ^TMP("LEXFND",$JOB,LEXN,LEXI)=LEXT
+11 SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
End DoDot:2
End DoDot:1
HIT ; Build HIT list
+1 IF $DATA(^TMP("LEXFND",$JOB))
Begin DoDot:1
+2 KILL LEX,^TMP("LEXHIT",$JOB)
+3 SET LEX=+($GET(LEXA(0)))
+4 SET LEX("LVL")=+($GET(LEXLVL))+1
+5 IF +LEX>0
Begin DoDot:2
+6 NEW LEXMAT
SET LEXMAT=+LEX_" match"_$SELECT(+LEX>1:"es",1:"")_" found for """_LEXXN_""""
+7 IF $$UP^XLFSTR($GET(LEXSUG))["SUGGEST"
SET LEXMAT=+LEX_" suggestion"_$SELECT(+LEX>1:"s",1:"")_" found for """_LEXXN_""""
+8 SET (^TMP("LEXSCH",$JOB,"MAT",0),LEX("MAT"))=LEXMAT
DO SCH
DO BEG
DO NAR
NEW LEXSUG
End DoDot:2
End DoDot:1
QUIT
+9 IF '$DATA(^TMP("LEXFND",$JOB))
DO NOM
+10 QUIT
SCH ; Search Conditions/Results
+1 KILL ^TMP("LEXSCH",$JOB,"EXM")
+2 SET ^TMP("LEXSCH",$JOB,"NAR",0)=$$UP(LEXXN)
+3 SET ^TMP("LEXSCH",$JOB,"SCH",0)=$$UP(LEXXN)
+4 SET ^TMP("LEXSCH",$JOB,"TOL",0)=1
+5 SET ^TMP("LEXSCH",$JOB,"NUM",0)=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+6 QUIT
NOM ; No Modifiers
+1 KILL LEX,^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB,"EXM"),^TMP("LEXSCH",$JOB,"NAR"),^TMP("LEXSCH",$JOB,"SCH"),^TMP("LEXSCH",$JOB,"TOL")
+2 SET ^TMP("LEXSCH",$JOB,"NUM",0)=0
IF $LENGTH($GET(LEXXN))
SET ^TMP("LEXSCH",$JOB,"NAR",0)=$$UP(LEXXN)
IF $LENGTH($GET(LEXXN))
SET ^TMP("LEXSCH",$JOB,"SCH",0)=$$UP(LEXXN)
+3 QUIT
NAR ; Narrative
+1 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+2 QUIT
DES(LEXX) ; Get description flag
+1 NEW LEXDES,LEXE,LEXM
SET LEXDES=""
SET LEXE=+LEXX
+2 SET LEXM=$PIECE($GET(^LEX(757.01,+($GET(LEXX)),1)),"^",1)
SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
IF $DATA(^LEX(757.01,LEXM,3))
SET LEXDES="*"
SET LEXX=$GET(LEXDES)
QUIT LEXX
BEG ; Begin List
+1 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+2 IF '$DATA(^TMP("LEXFND",$JOB))
QUIT
+3 NEW LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP,LEXLL
+4 SET LEXRL=0
SET LEXLL=+($GET(^TMP("LEXSCH",$JOB,"LEN",0)))
+5 IF +LEXLL=0
SET (LEXRL,LEXLL)=5
SET LEXJ=0
SET LEXI=-9999999999
+6 ; Hit List ^TMP("LEXHIT",$J,#)
+7 FOR
SET LEXI=$ORDER(^TMP("LEXFND",$JOB,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+8 SET LEXA=0
+9 FOR
SET LEXA=$ORDER(^TMP("LEXFND",$JOB,LEXI,LEXA))
IF +LEXA=0!(LEXJ=LEXLL)
QUIT
Begin DoDot:2
+10 SET LEXJ=LEXJ+1
SET LEXDP=^TMP("LEXFND",$JOB,LEXI,LEXA)
+11 SET ^TMP("LEXHIT",$JOB,0)=LEXJ
+12 SET ^TMP("LEXHIT",$JOB,LEXJ)=LEXA_"^"_LEXDP
+13 IF +($GET(^TMP("LEXSCH",$JOB,"EXM",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXM",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+14 IF +($GET(^TMP("LEXSCH",$JOB,"EXC",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXC",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+15 KILL ^TMP("LEXFND",$JOB,LEXI,LEXA)
End DoDot:2
IF +LEXA=0!(LEXJ=LEXLL)
QUIT
End DoDot:1
+16 ; List LEX("LIST")
+17 IF $DATA(^TMP("LEXSCH",$JOB,"NUM",0))
SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+18 IF LEXLL>0
Begin DoDot:1
+19 NEW LEXI,LEXJ
SET (LEXJ,LEXI)=0
+20 FOR
SET LEXJ=$ORDER(^TMP("LEXHIT",$JOB,LEXJ))
IF +LEXJ=0!(+LEXI=LEXLL)
QUIT
Begin DoDot:2
+21 SET LEXI=LEXI+1
SET LEX("LIST",LEXI)=^TMP("LEXHIT",$JOB,LEXJ)
+22 SET LEX("LIST",0)=LEXI_"^"_LEXI
+23 SET (LEX("MAX"),^TMP("LEXSCH",$JOB,"LST",0))=LEXI
End DoDot:2
IF +LEXI=LEXLL
QUIT
End DoDot:1
+24 SET ^TMP("LEXSCH",$JOB,"TOL",0)=0
IF $DATA(LEX("LIST",1))
SET ^TMP("LEXSCH",$JOB,"TOL",0)=1
+25 SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+26 IF ^TMP("LEXSCH",$JOB,"TOL",0)=1&(+($GET(LEX))>0)
SET LEX("MAT")=+LEX_" match"_$SELECT(+LEX>1:"es",1:"")_" found"
+27 IF +($GET(LEX("MAX")))>0
SET LEX("MIN")=1
+28 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXM",2)))
SET LEX("EXM")=^TMP("LEXSCH",$JOB,"EXM",2)
+29 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXC",2)))
SET LEX("EXC")=^TMP("LEXSCH",$JOB,"EXC",2)
+30 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+31 IF '$DATA(^TMP("LEXFND",$JOB))
QUIT
IF +($GET(LEXRL))>0
KILL LEXLL
+32 QUIT
UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CLR KILL X,Y,LEXLL,LEXSHOW,LEX,^TMP("LEXSCH"),^TMP("LEXHIT"),^TMP("LEXFND")
QUIT
