LEXAB ;ISL/KER - Look-up Exact Match "B" index ;05/23/2017
;;2.0;LEXICON UTILITY;**25,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10104
;
; Killed in LEXA
; LEXFIL
;
; Exact match S X=$$EN^LEXAB("LEXSCH",LEXVDT)
;
; INPUT
; LEXSCH User input string to search for
; LEXVDT Date used to screen out inactive codes
;
; Notes:
;
; 1. If an exact match is found, it is placed at
; the top of the selection list at
; ^TMP("LEXFND",$J)
;
; 2. Returns
;
; 0 - Exact match not found
; 1 - Exact match found
;
EN(LEXSCH,LEXVDT) ; Check "B" index for exact match
Q:'$L(LEXSCH) 0
N LEXLKGL,LEXEM,LEXEMC,LEXLKT S LEXLKT="AB",LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)),LEXEMC=0
I $D(^TMP("LEXSCH",$J,"FMT",0)) S:'$D(LEXAFMT)!($G(LEXAFMT)'?1N) LEXAFMT=$G(^TMP("LEXSCH",$J,"FMT",0))
Q:$G(LEXLKGL)'["757.01" 0
D VDT^LEXU N LEXSHOW S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
N LEXO,LEXE,LEXOK,LEXDES,LEXDSP
S (LEXE,LEXOK)=0,LEXO=$$SCH(LEXSCH)
F S LEXO=$O(^LEX(757.01,"B",LEXO)) Q:LEXO=""!(LEXSCH'[LEXO) D
. S (LEXE,LEXOK)=0
. F S LEXE=$O(^LEX(757.01,"B",LEXO,LEXE)) Q:+LEXE=0 D
. . Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
. . I $$UP^XLFSTR(LEXSCH)=$$UP^XLFSTR($G(^LEX(757.01,LEXE,0))) D
. . . S LEXEMC=+($G(LEXEMC)),LEXEMC=LEXEMC+1,LEXEM=LEXE
S:+($G(LEXEMC))=1 LEXOK=$G(LEXEM) S:+($G(LEXEMC))'=1 LEXOK=0
; Exact Match Found
I +LEXOK>0 D
. N LEXFILR S LEXE=LEXOK
. ; Filter
. I $L($G(LEXFIL)),LEXE>0 S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
. ; Deactivated
. Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
. S LEXDES=$$DES(LEXE)
. S LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
. D ADDE^LEXAL(LEXE,LEXDES,LEXDSP)
. S ^TMP("LEXSCH",$J,"EXM",0)=LEXE
. S ^TMP("LEXSCH",$J,"EXM",1)=$G(^LEX(757.01,+LEXE,0))
. I '$D(^LEX(757,"B",LEXE)) D
. . N LEXME,LEXM S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
. . S LEXME=+($G(^LEX(757,LEXM,0))) Q:LEXM=0 Q:LEXE=LEXME
. . I +($G(^LEX(757.01,LEXME,1)))=LEXM D
. . . S LEXDES=$$DES(LEXME),LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
. . . D ADDEM^LEXAL(LEXME,LEXDES,LEXDSP)
. . . S ^TMP("LEXSCH",$J,"EXC",0)=LEXME
. . . S ^TMP("LEXSCH",$J,"EXC",1)=$G(^LEX(757.01,+LEXME,0))
I $D(^TMP("LEXFND",$J)),'$D(^TMP("LEXSCH",$J,"SCH",0)) D BEG^LEXAL
Q:$D(^TMP("LEXFND",$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(X,Y,LEXVDT) ; Return displayable text
N LEXX,LEXDSP,LEXMCE S LEXX=+($G(X)),LEXDSP=$G(Y),LEXMCE=+($G(^LEX(757,+($G(^LEX(757.01,LEXX,1))),0)))
I +LEXMCE>0,$D(^LEX(757.01,+LEXMCE,0)) D Q X
. I +($G(LEXAFMT))'>0 S X=$$SO^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT)) Q
. S X="" I +($G(LEXAFMT))>0 S X=$$SOA^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT),.LEXSOA)
S LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT))
Q LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
S LEXX=$$UP^XLFSTR($E(LEXX,1,63)) N LEXIGN
S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAB 3699 printed Jan 18, 2025@03:07:47 Page 2
LEXAB ;ISL/KER - Look-up Exact Match "B" index ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**25,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757 SACC 1.3
+5 ; ^LEX(757.01 SACC 1.3
+6 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+7 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 ; Killed in LEXA
+13 ; LEXFIL
+14 ;
+15 ; Exact match S X=$$EN^LEXAB("LEXSCH",LEXVDT)
+16 ;
+17 ; INPUT
+18 ; LEXSCH User input string to search for
+19 ; LEXVDT Date used to screen out inactive codes
+20 ;
+21 ; Notes:
+22 ;
+23 ; 1. If an exact match is found, it is placed at
+24 ; the top of the selection list at
+25 ; ^TMP("LEXFND",$J)
+26 ;
+27 ; 2. Returns
+28 ;
+29 ; 0 - Exact match not found
+30 ; 1 - Exact match found
+31 ;
EN(LEXSCH,LEXVDT) ; Check "B" index for exact match
+1 if '$LENGTH(LEXSCH)
QUIT 0
+2 NEW LEXLKGL,LEXEM,LEXEMC,LEXLKT
SET LEXLKT="AB"
SET LEXLKGL=$GET(^TMP("LEXSCH",$JOB,"GBL",0))
SET LEXEMC=0
+3 IF $DATA(^TMP("LEXSCH",$JOB,"FMT",0))
if '$DATA(LEXAFMT)!($GET(LEXAFMT)'?1N)
SET LEXAFMT=$GET(^TMP("LEXSCH",$JOB,"FMT",0))
+4 if $GET(LEXLKGL)'["757.01"
QUIT 0
+5 DO VDT^LEXU
NEW LEXSHOW
SET LEXSHOW=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
+6 NEW LEXO,LEXE,LEXOK,LEXDES,LEXDSP
+7 SET (LEXE,LEXOK)=0
SET LEXO=$$SCH(LEXSCH)
+8 FOR
SET LEXO=$ORDER(^LEX(757.01,"B",LEXO))
if LEXO=""!(LEXSCH'[LEXO)
QUIT
Begin DoDot:1
+9 SET (LEXE,LEXOK)=0
+10 FOR
SET LEXE=$ORDER(^LEX(757.01,"B",LEXO,LEXE))
if +LEXE=0
QUIT
Begin DoDot:2
+11 if '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+12 IF $$UP^XLFSTR(LEXSCH)=$$UP^XLFSTR($GET(^LEX(757.01,LEXE,0)))
Begin DoDot:3
+13 SET LEXEMC=+($GET(LEXEMC))
SET LEXEMC=LEXEMC+1
SET LEXEM=LEXE
End DoDot:3
End DoDot:2
End DoDot:1
+14 if +($GET(LEXEMC))=1
SET LEXOK=$GET(LEXEM)
if +($GET(LEXEMC))'=1
SET LEXOK=0
+15 ; Exact Match Found
+16 IF +LEXOK>0
Begin DoDot:1
+17 NEW LEXFILR
SET LEXE=LEXOK
+18 ; Filter
+19 IF $LENGTH($GET(LEXFIL))
IF LEXE>0
SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),LEXE)
if LEXFILR=0
QUIT
+20 ; Deactivated
+21 if '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+22 SET LEXDES=$$DES(LEXE)
+23 SET LEXDSP=""
if $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+24 DO ADDE^LEXAL(LEXE,LEXDES,LEXDSP)
+25 SET ^TMP("LEXSCH",$JOB,"EXM",0)=LEXE
+26 SET ^TMP("LEXSCH",$JOB,"EXM",1)=$GET(^LEX(757.01,+LEXE,0))
+27 IF '$DATA(^LEX(757,"B",LEXE))
Begin DoDot:2
+28 NEW LEXME,LEXM
SET LEXM=+($GET(^LEX(757.01,LEXE,1)))
if LEXM=0
QUIT
+29 SET LEXME=+($GET(^LEX(757,LEXM,0)))
if LEXM=0
QUIT
if LEXE=LEXME
QUIT
+30 IF +($GET(^LEX(757.01,LEXME,1)))=LEXM
Begin DoDot:3
+31 SET LEXDES=$$DES(LEXME)
SET LEXDSP=""
if $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+32 DO ADDEM^LEXAL(LEXME,LEXDES,LEXDSP)
+33 SET ^TMP("LEXSCH",$JOB,"EXC",0)=LEXME
+34 SET ^TMP("LEXSCH",$JOB,"EXC",1)=$GET(^LEX(757.01,+LEXME,0))
End DoDot:3
End DoDot:2
End DoDot:1
+35 IF $DATA(^TMP("LEXFND",$JOB))
IF '$DATA(^TMP("LEXSCH",$JOB,"SCH",0))
DO BEG^LEXAL
+36 if $DATA(^TMP("LEXFND",$JOB))
QUIT 1
+37 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(X,Y,LEXVDT) ; Return displayable text
+1 NEW LEXX,LEXDSP,LEXMCE
SET LEXX=+($GET(X))
SET LEXDSP=$GET(Y)
SET LEXMCE=+($GET(^LEX(757,+($GET(^LEX(757.01,LEXX,1))),0)))
+2 IF +LEXMCE>0
IF $DATA(^LEX(757.01,+LEXMCE,0))
Begin DoDot:1
+3 IF +($GET(LEXAFMT))'>0
SET X=$$SO^LEXASO(LEXX,LEXDSP,1,$GET(LEXVDT))
QUIT
+4 SET X=""
IF +($GET(LEXAFMT))>0
SET X=$$SOA^LEXASO(LEXX,LEXDSP,1,$GET(LEXVDT),.LEXSOA)
End DoDot:1
QUIT X
+5 SET LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$GET(LEXVDT))
+6 QUIT LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
+1 SET LEXX=$$UP^XLFSTR($EXTRACT(LEXX,1,63))
NEW LEXIGN
+2 SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~"
QUIT LEXX
