LEXASC ;ISL/KER - Look-up by Shortcuts ;04/21/2014
;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.4) N/A
; ^LEX(757.41) N/A
; ^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
;
; ^TMP("LEXFND",$J) Entries found
; ^TMP("LEXHIT",$J) Entries returned
;
; LEXSCH User input string to search for
; LEXVDT Date is used to screen out inactive codes
;
; LEXC Pointer to Shortcut Context in file 757.41
; LEXS Pointer to Shortcut in file 757.4
; LEXE Pointer to expression in 757.01
; LEXM Pointer to Major Concept in 757.01
;
; LEXDSP Source Display string
; LEXDES Flag - has (*) or doesn't have () a description
; LEXSHOW Display string from Application/User defaults
; LEXX Returned variable from functions
;
EN(LEXSCH,LEXC,LEXVDT) ; Check Shortcuts file 757.4 for LEXSCH
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 S LEXS=0
F S LEXS=$O(^LEX(757.4,"ARA",LEXSCH,LEXC,LEXS)) Q:+LEXS=0 D
. N LEXE,LEXDES,LEXDSP,LEXLKT S LEXLKT="ASC"
. S LEXE=+($G(^LEX(757.4,LEXS,0))) Q:LEXE'>0
. ; Filter
. S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
. ; Deactivated Term
. 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)
I $D(^TMP("LEXFND",$J)) D 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
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(LEXX,LEXDSP,LEXVDT) ; Return displayable text
S LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT)) Q LEXX
SUB(LEXX) ;
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
LEXASC ;ISL/KER - Look-up by Shortcuts ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.4) N/A
+5 ; ^LEX(757.41) N/A
+6 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+7 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+8 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; None
+12 ;
+13 ; ^TMP("LEXFND",$J) Entries found
+14 ; ^TMP("LEXHIT",$J) Entries returned
+15 ;
+16 ; LEXSCH User input string to search for
+17 ; LEXVDT Date is used to screen out inactive codes
+18 ;
+19 ; LEXC Pointer to Shortcut Context in file 757.41
+20 ; LEXS Pointer to Shortcut in file 757.4
+21 ; LEXE Pointer to expression in 757.01
+22 ; LEXM Pointer to Major Concept in 757.01
+23 ;
+24 ; LEXDSP Source Display string
+25 ; LEXDES Flag - has (*) or doesn't have () a description
+26 ; LEXSHOW Display string from Application/User defaults
+27 ; LEXX Returned variable from functions
+28 ;
EN(LEXSCH,LEXC,LEXVDT) ; Check Shortcuts file 757.4 for LEXSCH
+1 SET LEXC=+($GET(LEXC))
+2 IF '$LENGTH(LEXSCH)!(LEXC=0)
QUIT 0
+3 IF '$DATA(^LEX(757.41,LEXC))
QUIT 0
+4 IF $LENGTH(LEXSCH)<2!($LENGTH(LEXSCH)>63)
QUIT 0
+5 IF '$DATA(^LEX(757.4,"ARA",LEXSCH,LEXC))
QUIT 0
+6 DO VDT^LEXU
NEW LEXS
SET LEXS=0
+7 FOR
SET LEXS=$ORDER(^LEX(757.4,"ARA",LEXSCH,LEXC,LEXS))
IF +LEXS=0
QUIT
Begin DoDot:1
+8 NEW LEXE,LEXDES,LEXDSP,LEXLKT
SET LEXLKT="ASC"
+9 SET LEXE=+($GET(^LEX(757.4,LEXS,0)))
IF LEXE'>0
QUIT
+10 ; Filter
+11 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),LEXE)
IF LEXFILR=0
QUIT
+12 ; Deactivated Term
+13 IF '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+14 IF +($$SUB(LEXE))=0
QUIT
+15 SET LEXDES=$$DES(LEXE)
+16 SET LEXDSP=""
SET LEXSHOW=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
IF $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+17 DO ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
End DoDot:1
+18 IF $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
+19 IF '$DATA(^TMP("LEXFND",$JOB))
Begin DoDot:1
+20 KILL LEX,^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
SET LEX=0
+21 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
+22 IF $DATA(^TMP("LEXHIT",$JOB))
QUIT 1
+23 QUIT 0
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(LEXX,LEXDSP,LEXVDT) ; Return displayable text
+1 SET LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$GET(LEXVDT))
QUIT LEXX
SUB(LEXX) ;
+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
