LEXASC ;ISL/KER - Look-up by Shortcuts ;05/23/2017
;;2.0;LEXICON UTILITY;**25,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^LEX(757.21 SACC 1.3
; ^LEX(757.4 SACC 1.3
; ^LEX(757.41 SACC 1.3
; ^LEXT(757.2 SACC 1.3
; ^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
; None
;
; Local Variables NEWed or KILLed Elsewhere
; LEXAFMT Output Format
; LEXFIL Filter
; LEXSHOW Display string (SABs)
;
EN(LEXSCH,LEXC,LEXVDT) ; Check Shortcuts file 757.4 for LEXSCH
; LEXSCH User input string to search for
; LEXVDT Versioning Date
; LEXC Pointer to Shortcut file 757.41
;
; Disabled LEX*2.0*103
Q 0
;
S LEXC=+($G(LEXC)) Q:'$L(LEXSCH)!(LEXC=0) 0 Q:'$D(^LEX(757.41,LEXC)) 0 Q:$L(LEXSCH)<2!($L(LEXSCH)>63) 0
Q:'$D(^LEX(757.4,"ARA",LEXSCH,LEXC)) 0 D VDT^LEXU N LEXS,LEXSOA S LEXS=0
I $D(^TMP("LEXSCH",$J,"FMT",0)) S:'$D(LEXAFMT)!($G(LEXAFMT)'?1N) LEXAFMT=$G(^TMP("LEXSCH",$J,"FMT",0))
F S LEXS=$O(^LEX(757.4,"ARA",LEXSCH,LEXC,LEXS)) Q:+LEXS=0 D
. N LEXE,LEXDES,LEXDSP,LEXLKT,LEXFILR S LEXLKT="ASC" S LEXE=+($G(^LEX(757.4,LEXS,0))) Q:LEXE'>0
. S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
. Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1) Q:+($$SUB(LEXE))=0 S LEXDES=$$DES(LEXE)
. S LEXDSP="",LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0)) S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
. D ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
D:$D(^TMP("LEXFND",$J)) BEG^LEXAL I '$D(^TMP("LEXFND",$J)) D
. K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J) S LEX=0
. 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("LEXHIT",$J)) 1
Q 0
;
; Miscellaneous
DES(LEXX) ; Get description flag
N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
S LEXX=$G(LEXDES) Q LEXX
TERM(LEXX) ; Get expression
Q $G(^LEX(757.01,LEXX,0))
DSP(X,Y,LEXVDT) ; Return displayable text
I +($G(LEXAFMT))'>0 S X=$$SO^LEXASO($G(X),$G(Y),1,$G(LEXVDT)) Q X
I +($G(LEXAFMT))>0 S X=$$SOA^LEXASO($G(X),$G(Y),1,$G(LEXVDT),.LEXSOA) Q X
Q ""
SUB(LEXX) ; Subset
Q:$G(^TMP("LEXSCH",$J,"GBL",0))'="^LEX(757.21," 1
Q:'$L($G(^TMP("LEXSCH",$J,"IDX",0))) 1
N LEXIDX,LEXSS,LEXSN S LEXIDX=$G(^TMP("LEXSCH",$J,"IDX",0))
S LEXSS=$E(LEXIDX,2,$L(LEXIDX))
S LEXSN=$O(^LEXT(757.2,"AA",LEXSS,0))
Q:+($G(LEXSN))=0 1
N LEXOK,LEXR S (LEXR,LEXOK)=0
F S LEXR=$O(^LEX(757.21,"B",LEXX,LEXR)) Q:+LEXR=0 D
. I $P($G(^LEX(757.21,LEXR,0)),"^",2)=LEXSN S LEXOK=1
S LEXX=LEXOK Q LEXX
CLR ; Clear
N LEXIGN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXASC 3031 printed Apr 09, 2024@21:14:17 Page 2
LEXASC ;ISL/KER - Look-up by Shortcuts ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**25,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757 SACC 1.3
+5 ; ^LEX(757.01 SACC 1.3
+6 ; ^LEX(757.21 SACC 1.3
+7 ; ^LEX(757.4 SACC 1.3
+8 ; ^LEX(757.41 SACC 1.3
+9 ; ^LEXT(757.2 SACC 1.3
+10 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+11 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+12 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+13 ;
+14 ; External References
+15 ; None
+16 ;
+17 ; Local Variables NEWed or KILLed Elsewhere
+18 ; LEXAFMT Output Format
+19 ; LEXFIL Filter
+20 ; LEXSHOW Display string (SABs)
+21 ;
EN(LEXSCH,LEXC,LEXVDT) ; Check Shortcuts file 757.4 for LEXSCH
+1 ; LEXSCH User input string to search for
+2 ; LEXVDT Versioning Date
+3 ; LEXC Pointer to Shortcut file 757.41
+4 ;
+5 ; Disabled LEX*2.0*103
+6 QUIT 0
+7 ;
+8 SET LEXC=+($GET(LEXC))
if '$LENGTH(LEXSCH)!(LEXC=0)
QUIT 0
if '$DATA(^LEX(757.41,LEXC))
QUIT 0
if $LENGTH(LEXSCH)<2!($LENGTH(LEXSCH)>63)
QUIT 0
+9 if '$DATA(^LEX(757.4,"ARA",LEXSCH,LEXC))
QUIT 0
DO VDT^LEXU
NEW LEXS,LEXSOA
SET LEXS=0
+10 IF $DATA(^TMP("LEXSCH",$JOB,"FMT",0))
if '$DATA(LEXAFMT)!($GET(LEXAFMT)'?1N)
SET LEXAFMT=$GET(^TMP("LEXSCH",$JOB,"FMT",0))
+11 FOR
SET LEXS=$ORDER(^LEX(757.4,"ARA",LEXSCH,LEXC,LEXS))
if +LEXS=0
QUIT
Begin DoDot:1
+12 NEW LEXE,LEXDES,LEXDSP,LEXLKT,LEXFILR
SET LEXLKT="ASC"
SET LEXE=+($GET(^LEX(757.4,LEXS,0)))
if LEXE'>0
QUIT
+13 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),LEXE)
if LEXFILR=0
QUIT
+14 if '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
if +($$SUB(LEXE))=0
QUIT
SET LEXDES=$$DES(LEXE)
+15 SET LEXDSP=""
SET LEXSHOW=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
if $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+16 DO ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
End DoDot:1
+17 if $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
IF '$DATA(^TMP("LEXFND",$JOB))
Begin DoDot:1
+18 KILL LEX,^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
SET LEX=0
+19 if +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
End DoDot:1
+20 if $DATA(^TMP("LEXHIT",$JOB))
QUIT 1
+21 QUIT 0
+22 ;
+23 ; Miscellaneous
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)
+3 SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
+4 if $DATA(^LEX(757.01,LEXM,3))
SET LEXDES="*"
+5 SET LEXX=$GET(LEXDES)
QUIT LEXX
TERM(LEXX) ; Get expression
+1 QUIT $GET(^LEX(757.01,LEXX,0))
DSP(X,Y,LEXVDT) ; Return displayable text
+1 IF +($GET(LEXAFMT))'>0
SET X=$$SO^LEXASO($GET(X),$GET(Y),1,$GET(LEXVDT))
QUIT X
+2 IF +($GET(LEXAFMT))>0
SET X=$$SOA^LEXASO($GET(X),$GET(Y),1,$GET(LEXVDT),.LEXSOA)
QUIT X
+3 QUIT ""
SUB(LEXX) ; Subset
+1 if $GET(^TMP("LEXSCH",$JOB,"GBL",0))'="^LEX(757.21,"
QUIT 1
+2 if '$LENGTH($GET(^TMP("LEXSCH",$JOB,"IDX",0)))
QUIT 1
+3 NEW LEXIDX,LEXSS,LEXSN
SET LEXIDX=$GET(^TMP("LEXSCH",$JOB,"IDX",0))
+4 SET LEXSS=$EXTRACT(LEXIDX,2,$LENGTH(LEXIDX))
+5 SET LEXSN=$ORDER(^LEXT(757.2,"AA",LEXSS,0))
+6 if +($GET(LEXSN))=0
QUIT 1
+7 NEW LEXOK,LEXR
SET (LEXR,LEXOK)=0
+8 FOR
SET LEXR=$ORDER(^LEX(757.21,"B",LEXX,LEXR))
if +LEXR=0
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(^LEX(757.21,LEXR,0)),"^",2)=LEXSN
SET LEXOK=1
End DoDot:1
+10 SET LEXX=LEXOK
QUIT LEXX
CLR ; Clear
+1 NEW LEXIGN
+2 QUIT
