LEXQSC2 ;ISL/KER - Query - SNOMED CT - Save ;03/23/2021
;;2.0;LEXICON UTILITY;**103,133**;Sep 23, 1996;Build 3
;
; Global Variables
; ^LEX(757.01, SACC 1.3
; ^LEX(757.02, SACC 1.3
; ^TMP("LEXQSCO") SACC 2.3.2.5.1
;
; External References
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXSEN Code IEN
; LEXCOD Code
; LEXSTA Status
; LEXEEN Expression IEN
; LEXIIEN Flag to Include IENs
;
EN ; Main Entry Point
K ^TMP("LEXQSCO",$J) Q:'$L($G(LEXELDT))
I +($G(LEXSEN))>0,+($G(LEXSTA))=0,$G(LEXEFF)'?7N D FUT I +($G(LEXNODP))'>0 D:$D(^TMP("LEXQSCO",$J)) DSP^LEXQO("LEXQSCO") Q
D FUL I +($G(LEXNODP))'>0 D:$D(^TMP("LEXQSCO",$J)) DSP^LEXQO("LEXQSCO")
Q
FUL ; Full Display
N LEXFUL,LEX,LEXL,LEXSO,LEXNAM,LEXIENS,LEXSUBS,LEXMAPS,LEXMC S LEXL=$G(LEXLEN) S:+LEXL'>0 LEXL="18^25^53" S LEXSO=$G(LEXCOD) Q:'$L(LEXSO)
S LEXNAM=$P($G(^LEX(757.02,+($G(LEXSEN)),0)),"^",1) Q:+LEXNAM'>0 S LEXNAM=$G(^LEX(757.01,+LEXNAM,0)) Q:'$L(LEXNAM)
S LEXFUL="" D BOD($G(LEXELDT)),COD(LEXSO,LEXNAM,$G(LEXCDT),$G(LEXL))
D STAL(LEXSO,$G(LEXL))
K LEXIENS S LEXMC=+($G(^LEX(757.01,+($G(LEXEEN)),1)))
D IENS^LEXQSC(LEXMC,.LEXIENS)
D EXP($G(LEXSO),$G(LEXCDT),.LEXIENS,$G(LEXL))
K LEXSUBS D SUBS^LEXQSC(LEXMC,.LEXSUBS)
D:$D(LEXSUBS) SUBS(.LEXSUBS,$G(LEXL))
K LEXMAPS D MAPS^LEXQSC(LEXSO,.LEXMAPS,$G(LEXCDT),LEXL)
D:$D(LEXMAPS) MAPS(.LEXMAPS,LEXL)
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXNAM,LEXSO,LEXNA,LEXNAM S LEXL=$G(LEXLEN) S:+LEXL'>0 LEXL="18^25^53"
S LEXSO=$G(LEXCOD) S LEXNA=$$NA^LEXQSC(LEXSO,$G(LEXCDT)) S LEXNAM=$P($G(^LEX(757.02,+($G(LEXSEN)),0)),"^",1) Q:+LEXNAM'>0
S LEXNAM=$G(^LEX(757.01,+LEXNAM,0)) Q:'$L(LEXNAM) D BOD(LEXELDT),COD(LEXSO,LEXNAM,$G(LEXL))
D STAF(LEXNA,$G(LEXL))
Q
BOD(X) ; Based on Date
N LEXBOD,LEXT S LEXBOD=$G(X),LEXT="Display based on date: "_LEXBOD D BL,TL(LEXT)
Q
COD(X,Y,LEXD,LEXLEN) ; Code Line
N LEXC,LEXN,LEXI,LEXN,LEXT,LEXCL,LEXLL,LEXTL,LEXIEN,LEXNAM S LEXC=$G(X),LEXNAM=$G(Y),LEXD=$G(LEXD),LEXIEN=$$CI(LEXC,LEXD)
S LEXCL=+($G(LEXLEN)),LEXLL=+($P($G(LEXLEN),"^",2)),LEXTL=+($P($G(LEXLEN),"^",3))
S:$D(LEXIIEN)&($L(LEXIEN)) LEXNAM=LEXIEN S LEXN(1)=LEXNAM,LEXT="Code: "_LEXC S LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))
D PR^LEXU(.LEXN,+($G(LEXTL)))
S LEXT=LEXT_LEXN(1) D BL,TL(LEXT)
S LEXI=1 F S LEXI=$O(LEXN(LEXI)) Q:+LEXI'>0 D
. N LEXT,LEX S LEX=$G(LEXN(LEXI)) Q:'$L(LEX)
. S LEXT=" ",LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_LEX D TL(LEXT)
Q
STAF(X,LEXLEN) ; Status Line (Future)
N LEXX,LEXT,LEXE,LEXCL,LEXLL,LEXTL
S LEXCL=+($G(LEXLEN)),LEXLL=+($P($G(LEXLEN),"^",2)),LEXTL=+($P($G(LEXLEN),"^",3))
S LEXX=$G(X)
S LEXT=" Status: "
S LEXT=LEXT_"Pending"
S LEXT=LEXT_$J(" ",(42-$L(LEXT)))
S LEXE=$S(LEXX?7N:$$FMTE^XLFDT(LEXX,"5Z"),1:"Unknown")
S LEXT=LEXT_" Effective: "_LEXE
D BL,TL((LEXT))
Q
STAL(X,LEXLEN) ; Status Line
N LEXSO,LEXL,LEXCL,LEXLL,LEXTL,LEXH,LEXHI,LEXLDR,LEXT
S LEXL=$G(LEXLEN) S LEXCL=+($G(LEXL)),LEXLL=+($P($G(LEXL),"^",2)),LEXTL=+($P($G(LEXL),"^",3))
S LEXSO=$G(X) Q:'$L(LEXSO) S LEXH=$$HIST(LEXSO,.LEXHI)
S LEXLDR=" Status: "
S LEXEFF=LEXCDT+1,LEXEFF=$O(LEXHI(LEXEFF),-1)
S LEXI="",LEXI=$O(LEXHI(LEXEFF,LEXI),-1) D
. N LEXST,LEXSE,LEXT S LEXST=$G(LEXHI(LEXEFF,LEXI)),LEXST=$$STUPD(LEXST)
. S LEXSE=$$FMTE^XLFDT(LEXEFF,"5Z")
. S LEXT=LEXLDR
. S LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_LEXST
. S LEXT=LEXT_$J(" ",(42-$L(LEXT)))_" Effective: "_LEXSE
. D:LEXLDR["Status" BL D TL(LEXT)
. S LEXLDR=" "
Q
;STAL;(X,LEXLEN) ; Status Line PATCH 103 VERSION ; bugged so doesn't display inactive codes
;N LEXSO,LEXL,LEXCL,LEXLL,LEXTL,LEXH,LEXHI,LEXLDR,LEXT
;S LEXL=$G(LEXLEN) S LEXCL=+($G(LEXL)),LEXLL=+($P($G(LEXL),"^",2)),LEXTL=+($P($G(LEXL),"^",3))
;S LEXSO=$G(X) Q:'$L(LEXSO) S LEXH=$$HIST(LEXSO,.LEXHI)
;S LEXLDR=" Status: "
;S LEXEFF="9999999" F S LEXEFF=$O(LEXHI(LEXEFF),-1) Q:LEXEFF'?7N D
;. N LEXI S LEXI="9999999" F S LEXI=$O(LEXHI(LEXEFF,LEXI),-1) Q:+LEXI'>0 D
;. . N LEXST,LEXSE,LEXT S LEXST=$G(LEXHI(LEXEFF,LEXI)),LEXST=$$STUPD(LEXST)
;. . S LEXSE=$$FMTE^XLFDT(LEXEFF,"5Z")
;. . S LEXT=LEXLDR
;. . S LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_LEXST
;. . S LEXT=LEXT_$J(" ",(42-$L(LEXT)))_" Effective: "_LEXSE
;. . D:LEXLDR["Status" BL D TL(LEXT)
;. . S LEXLDR=" "
;Q
EXP(LEXSO,LEXCDT,LEXEX,LEXLEN) ; Expressions
N LEXPREF,LEXFSC,LEXFSN,LEXCL,LEXLL,LEXTL,LEXDT,LEXP S LEXPREF=$$PREF(LEXSO,LEXCDT)
S LEXFSN=$$FSN(.LEXEX),LEXFSC=+LEXFSN,LEXFSN=$P(LEXFSN,"^",2)
S LEXCL=+($G(LEXLEN)),LEXLL=+($P($G(LEXLEN),"^",2)),LEXTL=+($P($G(LEXLEN),"^",3)) D:$O(LEXEX(0))>0 BL
N LEXTY S LEXTY=0 F S LEXTY=$O(LEXEX(LEXTY)) Q:+LEXTY'>0 D
. I LEXTY>0 D Q
. . N LEXS,LEXPL,LEXFN,LEXLN S LEXPL=0 S LEXFN=$O(LEXEX(LEXTY,0)),LEXLN=$O(LEXEX(LEXTY," "),-1)
. . S:LEXFN>0&(LEXLN>0)&(LEXFN'=LEXLN) LEXPL=1
. . S LEXS=0 F S LEXS=$O(LEXEX(LEXTY,LEXS)) Q:+LEXS'>0 D
. . . N LEXEI,LEXP,LEXDT,LEXT,LEXDA,LEXDS,LEXO,LEXD,LEXDF,LEXCOM
. . . S LEXEI=$G(LEXEX(LEXTY,LEXS)) Q:LEXEI'?1N.N
. . . S LEXCOM="" I LEXTY=2 D
. . . . Q:LEXFSN'>0 Q:$O(LEXEX(2,0))=$O(LEXEX(2," "),-1)
. . . . I +($G(LEXFSC))>1,LEXEI=LEXFSN S LEXCOM="Preferred FSN"
. . . S LEXDF=$P($G(^LEX(757.01,+LEXEI,1)),"^",5)
. . . S LEXCOM=LEXCOM_$S(LEXDF>0:", Deactivated",1:"")
. . . S:$D(LEXIIEN) LEXCOM=LEXCOM_", IEN "_+LEXEI
. . . S LEXCOM=$$TM($$TM(LEXCOM,",")) S:$L(LEXCOM) LEXCOM=" ("_LEXCOM_")"
. . . S LEXP="" I +LEXEI=+LEXPREF S LEXP="Preferred Term"
. . . S LEXD=$$DA^LEXQSC(+LEXEI)
. . . D DS^LEXQSC(LEXEI,.LEXDS)
. . . S LEXDT(1)=$G(^LEX(757.01,+LEXEI,0))_LEXCOM
. . . D PR^LEXU(.LEXDT,+($G(LEXTL)))
. . . S:LEXTY=1 LEXT=" Major Concept: "
. . . S:LEXTY=1&(+($G(LEXPL))>0) LEXT=" Major Concepts: "
. . . S:LEXTY=2 LEXT=" Fully Specified: "
. . . S:LEXTY=3 LEXT=" Synonymous Term: "
. . . S:LEXTY=3&(+($G(LEXPL))>0) LEXT=" Synonymous Terms:"
. . . S:LEXS>1 LEXT=" "
. . . S LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_$G(LEXDT(1)) D TL(LEXT)
. . . S LEXO=1 F S LEXO=$O(LEXDT(LEXO)) Q:+LEXO=0 D
. . . . N LEXT S LEXT="",LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_$G(LEXDT(LEXO)) D TL(LEXT)
. . . I $L(LEXP) S LEXT="",LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_" "_LEXP D TL(LEXT)
. . . I $L(LEXD) S LEXT="",LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_" "_LEXD D TL(LEXT)
. . . I $O(LEXDS(0))>0 D
. . . . N LEXT,LEXTT,LEXND,LEXCD,LEXHI,LEXI,LEXCT S LEXCT=0
. . . . S LEXTT="",LEXTT=LEXTT_$J(" ",(LEXLL-$L(LEXTT)))_" Designation Code"
. . . . S LEXI=0 F S LEXI=$O(LEXDS(LEXI)) Q:+LEXI'>0 D
. . . . . N LEXT,LEXND,LEXCD,LEXHI,LEXNL S LEXND=$G(LEXDS(LEXI)),LEXCD=$P(LEXND,"^",1),LEXHI=$P(LEXND,"^",2),LEXNL=43
. . . . . S LEXCT=LEXCT+1 S:$L(LEXHI) LEXTT=LEXTT_"/Hierarchy" D:LEXCT=1 TL(LEXTT)
. . . . . S LEXT="",LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_" "_LEXCD
. . . . . S:$L(LEXHI) LEXT=LEXT_$J(" ",(LEXNL-$L(LEXT)))_" "_LEXHI
. . . . .
. . . . . D TL(LEXT)
Q
SUBS(LEX,LEXLEN) ; Subsets
N LEXSA,LEXSN,LEXLDR,LEXPL,LEXCL,LEXLL,LEXTL Q:'$L($O(LEX(""))) S LEXPL=0 S:$O(LEX(""))'=$O(LEX(""),-1) LEXPL=1
S LEXCL=+($G(LEXLEN)),LEXLL=+($P($G(LEXLEN),"^",2)),LEXTL=+($P($G(LEXLEN),"^",3))
S LEXLDR=" Subset: " S:LEXPL>0 LEXLDR=" Subsets: " S LEXSA="" D BL
F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
. N LEXSN,LEXSI,LEXT,LEXIEN S LEXSN=$P($G(LEX(LEXSA)),"^",1)
. S LEXSN=$P($G(LEX(LEXSA)),"^",1),LEXIEN=+($P($G(LEX(LEXSA)),"^",3))
. S:$D(LEXIIEN)&($L(LEXSN))&(+($G(LEXIEN))>0) LEXSN=LEXSN_" (IEN "_+LEXIEN_")"
. S LEXT=$G(LEXLDR),LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_LEXSN D TL(LEXT) S LEXLDR=" "
Q
MAPS(LEX,LEXLEN) ; Mappings
N LEXSA,LEXSN,LEXLDR,LEXPL,LEXCL,LEXLL,LEXTL,LEXN Q:'$L($O(LEX("")))
S (LEXPL,LEXSA)=0 F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) S:$E($G(LEX(LEXSA)),1) LEXPL=+LEXPL+1
S LEXCL=+($G(LEXLEN)),LEXLL=+($P($G(LEXLEN),"^",2)),LEXTL=+($P($G(LEXLEN),"^",3))
S LEXLDR=" Mapping:" S:LEXPL>0 LEXLDR=" Mappings:" S LEXLDR=LEXLDR_$J(" ",(LEXLL-$L(LEXLDR)))
D BL S LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
. N LEXSN,LEXT S LEXSN=$G(LEX(LEXSA))
. S LEXT=LEXLDR_LEXSN D TL(LEXT) S LEXLDR=$J(" ",LEXLL)
Q
;
; Miscellaneous
CI(X,LEXD) ; Code IENs
N LEXSO,LEXSDO,LEXLEX,LEXSAB S LEXSO=$G(X) Q:'$L(LEXSO) S LEXD=$G(LEXD) I LEXD'?7N D
. N LEXEF,LEXTD S LEXTD="",LEXEF=9999999 F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1) Q:+LEXEF'>0 D Q:LEXTD?7N
. . N LEXIE S LEXIE=$O(^LEX(757.02," "),-1) F S LEXIE=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1) Q:+LEXIE'>0 D Q:LEXTD?7N
. . . N LEXSR S LEXSR=$P($G(^LEX(757.02,+LEXIE,0)),"^",3) S:"^56^"[("^"_LEXSR_"^") LEXTD=LEXEF S:$G(LEXTD)?7N LEXD=LEXTD
S:LEXD'?7N LEXD=$$DT^XLFDT S LEXSAB="SCT",LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB),LEXLEX=$P(LEXLEX,"^",2)
S LEXLEX=$S(+LEXLEX>0:("Lexicon SNOMED CT Code IEN "_+LEXLEX),1:"") S X="" S:$L(LEXLEX) X=LEXLEX
Q X
LEN(X) ; Length of Code
N LEXSIEN,LEXMAX S LEXMAX=0,LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"ASRC","SCT",LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXCD S LEXCD=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",2) S:$L(LEXCD)>LEXMAX LEXMAX=$L(LEXCD)
S X=LEXMAX
Q X
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI S LEXI=+($O(^TMP("LEXQSCO",$J," "),-1))+1 S ^TMP("LEXQSCO",$J,LEXI)=$G(X),^TMP("LEXQSCO",$J,0)=LEXI
Q
CLR ; Clear
N LEXIEN,LEXLEN,LEXGET,LEXSD,LEXLD,LEXMD,LEXLX,LEXINC,LEXELDT,LEXST,LEXTEST,LEXWN
Q
STUPD(X) ; Status Update
N LEXUP S LEXUP=$$UP^XLFSTR(X) S:LEXUP["ACTIVATED" X="Active" S:LEXUP["INACTIV" X="Inactive" S:LEXUP["REVISE" X="Active ("_X_")"
S:LEXUP["RE-ACT" X="Active ("_X_")" S:LEXUP["RE-USE" X="Active ("_X_")"
Q X
PREF(LEXSO,LEXCDT) ; Get Preferred Expression for an Active Code
Q $$PREF^LEXU($G(LEXSO),"SCT",$G(LEXCDT))
FSN(LEXEX) ; Get Count and Preferred Fully Specified Name
N LEXACT,LEXI,LEXPA K LEXPA S (LEXACT,LEXI)=0 F S LEXI=$O(LEXEX(2,LEXI)) Q:+LEXI'>0 D
. N LEXIEN,LEXDES,LEXHIS,LEXHAR S LEXIEN=$G(LEXEX(2,LEXI))
. Q:$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)>0
. S LEXACT=LEXACT+1
. S LEXDES=$O(^LEX(757.01,+LEXIEN,7,"C",56,"")) Q:'$L(LEXDES)
. S LEXHIS=$O(^LEX(757.01,+LEXIEN,7,"C",56,LEXDES,0)) Q:+LEXHIS'>0
. S LEXHAR=$P($G(^LEX(757.01,+LEXIEN,7,+LEXHIS,0)),"^",3) Q:+LEXHAR'>0
. Q:$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)>0
. S LEXPA(LEXIEN)=""
S X=$O(LEXPA(" "),-1) S:+X'>0 X="" S:X>0 X=+LEXACT_"^"_X
Q X
HIST(CODE,ARY) ; Activation History
N LEXCOD,LEXEEN,LEXIIEN,LEXNODP,LEXSEN,LEXSTA
Q $$HIST^LEXU($G(CODE),56,.ARY)
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQSC2 10926 printed Dec 13, 2024@02:09:02 Page 2
LEXQSC2 ;ISL/KER - Query - SNOMED CT - Save ;03/23/2021
+1 ;;2.0;LEXICON UTILITY;**103,133**;Sep 23, 1996;Build 3
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01, SACC 1.3
+5 ; ^LEX(757.02, SACC 1.3
+6 ; ^TMP("LEXQSCO") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$FMTE^XLFDT ICR 10103
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 ; Local Variables NEWed or KILLed Elsewhere
+13 ; LEXSEN Code IEN
+14 ; LEXCOD Code
+15 ; LEXSTA Status
+16 ; LEXEEN Expression IEN
+17 ; LEXIIEN Flag to Include IENs
+18 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQSCO",$JOB)
if '$LENGTH($GET(LEXELDT))
QUIT
+2 IF +($GET(LEXSEN))>0
IF +($GET(LEXSTA))=0
IF $GET(LEXEFF)'?7N
DO FUT
IF +($GET(LEXNODP))'>0
if $DATA(^TMP("LEXQSCO",$JOB))
DO DSP^LEXQO("LEXQSCO")
QUIT
+3 DO FUL
IF +($GET(LEXNODP))'>0
if $DATA(^TMP("LEXQSCO",$JOB))
DO DSP^LEXQO("LEXQSCO")
+4 QUIT
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL,LEXSO,LEXNAM,LEXIENS,LEXSUBS,LEXMAPS,LEXMC
SET LEXL=$GET(LEXLEN)
if +LEXL'>0
SET LEXL="18^25^53"
SET LEXSO=$GET(LEXCOD)
if '$LENGTH(LEXSO)
QUIT
+2 SET LEXNAM=$PIECE($GET(^LEX(757.02,+($GET(LEXSEN)),0)),"^",1)
if +LEXNAM'>0
QUIT
SET LEXNAM=$GET(^LEX(757.01,+LEXNAM,0))
if '$LENGTH(LEXNAM)
QUIT
+3 SET LEXFUL=""
DO BOD($GET(LEXELDT))
DO COD(LEXSO,LEXNAM,$GET(LEXCDT),$GET(LEXL))
+4 DO STAL(LEXSO,$GET(LEXL))
+5 KILL LEXIENS
SET LEXMC=+($GET(^LEX(757.01,+($GET(LEXEEN)),1)))
+6 DO IENS^LEXQSC(LEXMC,.LEXIENS)
+7 DO EXP($GET(LEXSO),$GET(LEXCDT),.LEXIENS,$GET(LEXL))
+8 KILL LEXSUBS
DO SUBS^LEXQSC(LEXMC,.LEXSUBS)
+9 if $DATA(LEXSUBS)
DO SUBS(.LEXSUBS,$GET(LEXL))
+10 KILL LEXMAPS
DO MAPS^LEXQSC(LEXSO,.LEXMAPS,$GET(LEXCDT),LEXL)
+11 if $DATA(LEXMAPS)
DO MAPS(.LEXMAPS,LEXL)
+12 QUIT
FUT ; Future Activation
+1 NEW LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXNAM,LEXSO,LEXNA,LEXNAM
SET LEXL=$GET(LEXLEN)
if +LEXL'>0
SET LEXL="18^25^53"
+2 SET LEXSO=$GET(LEXCOD)
SET LEXNA=$$NA^LEXQSC(LEXSO,$GET(LEXCDT))
SET LEXNAM=$PIECE($GET(^LEX(757.02,+($GET(LEXSEN)),0)),"^",1)
if +LEXNAM'>0
QUIT
+3 SET LEXNAM=$GET(^LEX(757.01,+LEXNAM,0))
if '$LENGTH(LEXNAM)
QUIT
DO BOD(LEXELDT)
DO COD(LEXSO,LEXNAM,$GET(LEXL))
+4 DO STAF(LEXNA,$GET(LEXL))
+5 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD,LEXT
SET LEXBOD=$GET(X)
SET LEXT="Display based on date: "_LEXBOD
DO BL
DO TL(LEXT)
+2 QUIT
COD(X,Y,LEXD,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXI,LEXN,LEXT,LEXCL,LEXLL,LEXTL,LEXIEN,LEXNAM
SET LEXC=$GET(X)
SET LEXNAM=$GET(Y)
SET LEXD=$GET(LEXD)
SET LEXIEN=$$CI(LEXC,LEXD)
+2 SET LEXCL=+($GET(LEXLEN))
SET LEXLL=+($PIECE($GET(LEXLEN),"^",2))
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
+3 if $DATA(LEXIIEN)&($LENGTH(LEXIEN))
SET LEXNAM=LEXIEN
SET LEXN(1)=LEXNAM
SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))
+4 DO PR^LEXU(.LEXN,+($GET(LEXTL)))
+5 SET LEXT=LEXT_LEXN(1)
DO BL
DO TL(LEXT)
+6 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXN(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+7 NEW LEXT,LEX
SET LEX=$GET(LEXN(LEXI))
if '$LENGTH(LEX)
QUIT
+8 SET LEXT=" "
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_LEX
DO TL(LEXT)
End DoDot:1
+9 QUIT
STAF(X,LEXLEN) ; Status Line (Future)
+1 NEW LEXX,LEXT,LEXE,LEXCL,LEXLL,LEXTL
+2 SET LEXCL=+($GET(LEXLEN))
SET LEXLL=+($PIECE($GET(LEXLEN),"^",2))
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
+3 SET LEXX=$GET(X)
+4 SET LEXT=" Status: "
+5 SET LEXT=LEXT_"Pending"
+6 SET LEXT=LEXT_$JUSTIFY(" ",(42-$LENGTH(LEXT)))
+7 SET LEXE=$SELECT(LEXX?7N:$$FMTE^XLFDT(LEXX,"5Z"),1:"Unknown")
+8 SET LEXT=LEXT_" Effective: "_LEXE
+9 DO BL
DO TL((LEXT))
+10 QUIT
STAL(X,LEXLEN) ; Status Line
+1 NEW LEXSO,LEXL,LEXCL,LEXLL,LEXTL,LEXH,LEXHI,LEXLDR,LEXT
+2 SET LEXL=$GET(LEXLEN)
SET LEXCL=+($GET(LEXL))
SET LEXLL=+($PIECE($GET(LEXL),"^",2))
SET LEXTL=+($PIECE($GET(LEXL),"^",3))
+3 SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXH=$$HIST(LEXSO,.LEXHI)
+4 SET LEXLDR=" Status: "
+5 SET LEXEFF=LEXCDT+1
SET LEXEFF=$ORDER(LEXHI(LEXEFF),-1)
+6 SET LEXI=""
SET LEXI=$ORDER(LEXHI(LEXEFF,LEXI),-1)
Begin DoDot:1
+7 NEW LEXST,LEXSE,LEXT
SET LEXST=$GET(LEXHI(LEXEFF,LEXI))
SET LEXST=$$STUPD(LEXST)
+8 SET LEXSE=$$FMTE^XLFDT(LEXEFF,"5Z")
+9 SET LEXT=LEXLDR
+10 SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_LEXST
+11 SET LEXT=LEXT_$JUSTIFY(" ",(42-$LENGTH(LEXT)))_" Effective: "_LEXSE
+12 if LEXLDR["Status"
DO BL
DO TL(LEXT)
+13 SET LEXLDR=" "
End DoDot:1
+14 QUIT
+15 ;STAL;(X,LEXLEN) ; Status Line PATCH 103 VERSION ; bugged so doesn't display inactive codes
+16 ;N LEXSO,LEXL,LEXCL,LEXLL,LEXTL,LEXH,LEXHI,LEXLDR,LEXT
+17 ;S LEXL=$G(LEXLEN) S LEXCL=+($G(LEXL)),LEXLL=+($P($G(LEXL),"^",2)),LEXTL=+($P($G(LEXL),"^",3))
+18 ;S LEXSO=$G(X) Q:'$L(LEXSO) S LEXH=$$HIST(LEXSO,.LEXHI)
+19 ;S LEXLDR=" Status: "
+20 ;S LEXEFF="9999999" F S LEXEFF=$O(LEXHI(LEXEFF),-1) Q:LEXEFF'?7N D
+21 ;. N LEXI S LEXI="9999999" F S LEXI=$O(LEXHI(LEXEFF,LEXI),-1) Q:+LEXI'>0 D
+22 ;. . N LEXST,LEXSE,LEXT S LEXST=$G(LEXHI(LEXEFF,LEXI)),LEXST=$$STUPD(LEXST)
+23 ;. . S LEXSE=$$FMTE^XLFDT(LEXEFF,"5Z")
+24 ;. . S LEXT=LEXLDR
+25 ;. . S LEXT=LEXT_$J(" ",(LEXLL-$L(LEXT)))_LEXST
+26 ;. . S LEXT=LEXT_$J(" ",(42-$L(LEXT)))_" Effective: "_LEXSE
+27 ;. . D:LEXLDR["Status" BL D TL(LEXT)
+28 ;. . S LEXLDR=" "
+29 ;Q
EXP(LEXSO,LEXCDT,LEXEX,LEXLEN) ; Expressions
+1 NEW LEXPREF,LEXFSC,LEXFSN,LEXCL,LEXLL,LEXTL,LEXDT,LEXP
SET LEXPREF=$$PREF(LEXSO,LEXCDT)
+2 SET LEXFSN=$$FSN(.LEXEX)
SET LEXFSC=+LEXFSN
SET LEXFSN=$PIECE(LEXFSN,"^",2)
+3 SET LEXCL=+($GET(LEXLEN))
SET LEXLL=+($PIECE($GET(LEXLEN),"^",2))
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
if $ORDER(LEXEX(0))>0
DO BL
+4 NEW LEXTY
SET LEXTY=0
FOR
SET LEXTY=$ORDER(LEXEX(LEXTY))
if +LEXTY'>0
QUIT
Begin DoDot:1
+5 IF LEXTY>0
Begin DoDot:2
+6 NEW LEXS,LEXPL,LEXFN,LEXLN
SET LEXPL=0
SET LEXFN=$ORDER(LEXEX(LEXTY,0))
SET LEXLN=$ORDER(LEXEX(LEXTY," "),-1)
+7 if LEXFN>0&(LEXLN>0)&(LEXFN'=LEXLN)
SET LEXPL=1
+8 SET LEXS=0
FOR
SET LEXS=$ORDER(LEXEX(LEXTY,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:3
+9 NEW LEXEI,LEXP,LEXDT,LEXT,LEXDA,LEXDS,LEXO,LEXD,LEXDF,LEXCOM
+10 SET LEXEI=$GET(LEXEX(LEXTY,LEXS))
if LEXEI'?1N.N
QUIT
+11 SET LEXCOM=""
IF LEXTY=2
Begin DoDot:4
+12 if LEXFSN'>0
QUIT
if $ORDER(LEXEX(2,0))=$ORDER(LEXEX(2," "),-1)
QUIT
+13 IF +($GET(LEXFSC))>1
IF LEXEI=LEXFSN
SET LEXCOM="Preferred FSN"
End DoDot:4
+14 SET LEXDF=$PIECE($GET(^LEX(757.01,+LEXEI,1)),"^",5)
+15 SET LEXCOM=LEXCOM_$SELECT(LEXDF>0:", Deactivated",1:"")
+16 if $DATA(LEXIIEN)
SET LEXCOM=LEXCOM_", IEN "_+LEXEI
+17 SET LEXCOM=$$TM($$TM(LEXCOM,","))
if $LENGTH(LEXCOM)
SET LEXCOM=" ("_LEXCOM_")"
+18 SET LEXP=""
IF +LEXEI=+LEXPREF
SET LEXP="Preferred Term"
+19 SET LEXD=$$DA^LEXQSC(+LEXEI)
+20 DO DS^LEXQSC(LEXEI,.LEXDS)
+21 SET LEXDT(1)=$GET(^LEX(757.01,+LEXEI,0))_LEXCOM
+22 DO PR^LEXU(.LEXDT,+($GET(LEXTL)))
+23 if LEXTY=1
SET LEXT=" Major Concept: "
+24 if LEXTY=1&(+($GET(LEXPL))>0)
SET LEXT=" Major Concepts: "
+25 if LEXTY=2
SET LEXT=" Fully Specified: "
+26 if LEXTY=3
SET LEXT=" Synonymous Term: "
+27 if LEXTY=3&(+($GET(LEXPL))>0)
SET LEXT=" Synonymous Terms:"
+28 if LEXS>1
SET LEXT=" "
+29 SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_$GET(LEXDT(1))
DO TL(LEXT)
+30 SET LEXO=1
FOR
SET LEXO=$ORDER(LEXDT(LEXO))
if +LEXO=0
QUIT
Begin DoDot:4
+31 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_$GET(LEXDT(LEXO))
DO TL(LEXT)
End DoDot:4
+32 IF $LENGTH(LEXP)
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_" "_LEXP
DO TL(LEXT)
+33 IF $LENGTH(LEXD)
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_" "_LEXD
DO TL(LEXT)
+34 IF $ORDER(LEXDS(0))>0
Begin DoDot:4
+35 NEW LEXT,LEXTT,LEXND,LEXCD,LEXHI,LEXI,LEXCT
SET LEXCT=0
+36 SET LEXTT=""
SET LEXTT=LEXTT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXTT)))_" Designation Code"
+37 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXDS(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:5
+38 NEW LEXT,LEXND,LEXCD,LEXHI,LEXNL
SET LEXND=$GET(LEXDS(LEXI))
SET LEXCD=$PIECE(LEXND,"^",1)
SET LEXHI=$PIECE(LEXND,"^",2)
SET LEXNL=43
+39 SET LEXCT=LEXCT+1
if $LENGTH(LEXHI)
SET LEXTT=LEXTT_"/Hierarchy"
if LEXCT=1
DO TL(LEXTT)
+40 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_" "_LEXCD
+41 if $LENGTH(LEXHI)
SET LEXT=LEXT_$JUSTIFY(" ",(LEXNL-$LENGTH(LEXT)))_" "_LEXHI
+42 +43 DO TL(LEXT)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+44 QUIT
SUBS(LEX,LEXLEN) ; Subsets
+1 NEW LEXSA,LEXSN,LEXLDR,LEXPL,LEXCL,LEXLL,LEXTL
if '$LENGTH($ORDER(LEX("")))
QUIT
SET LEXPL=0
if $ORDER(LEX(""))'=$ORDER(LEX(""),-1)
SET LEXPL=1
+2 SET LEXCL=+($GET(LEXLEN))
SET LEXLL=+($PIECE($GET(LEXLEN),"^",2))
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
+3 SET LEXLDR=" Subset: "
if LEXPL>0
SET LEXLDR=" Subsets: "
SET LEXSA=""
DO BL
+4 FOR
SET LEXSA=$ORDER(LEX(LEXSA))
if '$LENGTH(LEXSA)
QUIT
Begin DoDot:1
+5 NEW LEXSN,LEXSI,LEXT,LEXIEN
SET LEXSN=$PIECE($GET(LEX(LEXSA)),"^",1)
+6 SET LEXSN=$PIECE($GET(LEX(LEXSA)),"^",1)
SET LEXIEN=+($PIECE($GET(LEX(LEXSA)),"^",3))
+7 if $DATA(LEXIIEN)&($LENGTH(LEXSN))&(+($GET(LEXIEN))>0)
SET LEXSN=LEXSN_" (IEN "_+LEXIEN_")"
+8 SET LEXT=$GET(LEXLDR)
SET LEXT=LEXT_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXT)))_LEXSN
DO TL(LEXT)
SET LEXLDR=" "
End DoDot:1
+9 QUIT
MAPS(LEX,LEXLEN) ; Mappings
+1 NEW LEXSA,LEXSN,LEXLDR,LEXPL,LEXCL,LEXLL,LEXTL,LEXN
if '$LENGTH($ORDER(LEX("")))
QUIT
+2 SET (LEXPL,LEXSA)=0
FOR
SET LEXSA=$ORDER(LEX(LEXSA))
if '$LENGTH(LEXSA)
QUIT
if $EXTRACT($GET(LEX(LEXSA)),1)
SET LEXPL=+LEXPL+1
+3 SET LEXCL=+($GET(LEXLEN))
SET LEXLL=+($PIECE($GET(LEXLEN),"^",2))
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
+4 SET LEXLDR=" Mapping:"
if LEXPL>0
SET LEXLDR=" Mappings:"
SET LEXLDR=LEXLDR_$JUSTIFY(" ",(LEXLL-$LENGTH(LEXLDR)))
+5 DO BL
SET LEXSA=""
FOR
SET LEXSA=$ORDER(LEX(LEXSA))
if '$LENGTH(LEXSA)
QUIT
Begin DoDot:1
+6 NEW LEXSN,LEXT
SET LEXSN=$GET(LEX(LEXSA))
+7 SET LEXT=LEXLDR_LEXSN
DO TL(LEXT)
SET LEXLDR=$JUSTIFY(" ",LEXLL)
End DoDot:1
+8 QUIT
+9 ;
+10 ; Miscellaneous
CI(X,LEXD) ; Code IENs
+1 NEW LEXSO,LEXSDO,LEXLEX,LEXSAB
SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXD=$GET(LEXD)
IF LEXD'?7N
Begin DoDot:1
+2 NEW LEXEF,LEXTD
SET LEXTD=""
SET LEXEF=9999999
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1)
if +LEXEF'>0
QUIT
Begin DoDot:2
+3 NEW LEXIE
SET LEXIE=$ORDER(^LEX(757.02," "),-1)
FOR
SET LEXIE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1)
if +LEXIE'>0
QUIT
Begin DoDot:3
+4 NEW LEXSR
SET LEXSR=$PIECE($GET(^LEX(757.02,+LEXIE,0)),"^",3)
if "^56^"[("^"_LEXSR_"^")
SET LEXTD=LEXEF
if $GET(LEXTD)?7N
SET LEXD=LEXTD
End DoDot:3
if LEXTD?7N
QUIT
End DoDot:2
if LEXTD?7N
QUIT
End DoDot:1
+5 if LEXD'?7N
SET LEXD=$$DT^XLFDT
SET LEXSAB="SCT"
SET LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB)
SET LEXLEX=$PIECE(LEXLEX,"^",2)
+6 SET LEXLEX=$SELECT(+LEXLEX>0:("Lexicon SNOMED CT Code IEN "_+LEXLEX),1:"")
SET X=""
if $LENGTH(LEXLEX)
SET X=LEXLEX
+7 QUIT X
LEN(X) ; Length of Code
+1 NEW LEXSIEN,LEXMAX
SET LEXMAX=0
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"ASRC","SCT",LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+2 NEW LEXCD
SET LEXCD=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",2)
if $LENGTH(LEXCD)>LEXMAX
SET LEXMAX=$LENGTH(LEXCD)
End DoDot:1
+3 SET X=LEXMAX
+4 QUIT X
BL ; Blank Line
+1 DO TL(" ")
QUIT
TL(X) ; Text Line
+1 IF $DATA(LEXTEST)
WRITE !,$GET(X)
QUIT
+2 NEW LEXI
SET LEXI=+($ORDER(^TMP("LEXQSCO",$JOB," "),-1))+1
SET ^TMP("LEXQSCO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQSCO",$JOB,0)=LEXI
+3 QUIT
CLR ; Clear
+1 NEW LEXIEN,LEXLEN,LEXGET,LEXSD,LEXLD,LEXMD,LEXLX,LEXINC,LEXELDT,LEXST,LEXTEST,LEXWN
+2 QUIT
STUPD(X) ; Status Update
+1 NEW LEXUP
SET LEXUP=$$UP^XLFSTR(X)
if LEXUP["ACTIVATED"
SET X="Active"
if LEXUP["INACTIV"
SET X="Inactive"
if LEXUP["REVISE"
SET X="Active ("_X_")"
+2 if LEXUP["RE-ACT"
SET X="Active ("_X_")"
if LEXUP["RE-USE"
SET X="Active ("_X_")"
+3 QUIT X
PREF(LEXSO,LEXCDT) ; Get Preferred Expression for an Active Code
+1 QUIT $$PREF^LEXU($GET(LEXSO),"SCT",$GET(LEXCDT))
FSN(LEXEX) ; Get Count and Preferred Fully Specified Name
+1 NEW LEXACT,LEXI,LEXPA
KILL LEXPA
SET (LEXACT,LEXI)=0
FOR
SET LEXI=$ORDER(LEXEX(2,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+2 NEW LEXIEN,LEXDES,LEXHIS,LEXHAR
SET LEXIEN=$GET(LEXEX(2,LEXI))
+3 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
QUIT
+4 SET LEXACT=LEXACT+1
+5 SET LEXDES=$ORDER(^LEX(757.01,+LEXIEN,7,"C",56,""))
if '$LENGTH(LEXDES)
QUIT
+6 SET LEXHIS=$ORDER(^LEX(757.01,+LEXIEN,7,"C",56,LEXDES,0))
if +LEXHIS'>0
QUIT
+7 SET LEXHAR=$PIECE($GET(^LEX(757.01,+LEXIEN,7,+LEXHIS,0)),"^",3)
if +LEXHAR'>0
QUIT
+8 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
QUIT
+9 SET LEXPA(LEXIEN)=""
End DoDot:1
+10 SET X=$ORDER(LEXPA(" "),-1)
if +X'>0
SET X=""
if X>0
SET X=+LEXACT_"^"_X
+11 QUIT X
HIST(CODE,ARY) ; Activation History
+1 NEW LEXCOD,LEXEEN,LEXIIEN,LEXNODP,LEXSEN,LEXSTA
+2 QUIT $$HIST^LEXU($GET(CODE),56,.ARY)
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
