- 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
