- 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 Feb 18, 2025@23:33:19 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
