- LEXQVSE2 ;ISL/TJH - Query - VA Extension SNOMED CT - Save ;01/25/2021
- ;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
- ;
- ; Global Variables
- ; ^LEX(757.01, SACC 1.3
- ; ^LEX(757.02, SACC 1.3
- ; ^TMP("LEXQVSEO") 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("LEXQVSEO",$J) Q:'$L($G(LEXELDT))
- I +($G(LEXSEN))>0,+($G(LEXSTA))=0,$G(LEXEFF)'?7N D FUT I +($G(LEXNODP))'>0 D:$D(^TMP("LEXQVSEO",$J)) DSP^LEXQO("LEXQVSEO") Q
- D FUL I +($G(LEXNODP))'>0 D:$D(^TMP("LEXQVSEO",$J)) DSP^LEXQO("LEXQVSEO")
- 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^LEXQVSE(LEXMC,.LEXIENS)
- D EXP($G(LEXSO),$G(LEXCDT),.LEXIENS,$G(LEXL))
- K LEXSUBS D SUBS^LEXQVSE(LEXMC,.LEXSUBS)
- D:$D(LEXSUBS) SUBS(.LEXSUBS,$G(LEXL))
- K LEXMAPS D MAPS^LEXQVSE(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^LEXQVSE(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
- 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^LEXQVSE(+LEXEI)
- . . . D DS^LEXQVSE(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:"^58^"[("^"_LEXSR_"^") LEXTD=LEXEF S:$G(LEXTD)?7N LEXD=LEXTD
- S:LEXD'?7N LEXD=$$DT^XLFDT S LEXSAB="VSE",LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB),LEXLEX=$P(LEXLEX,"^",2)
- S LEXLEX=$S(+LEXLEX>0:("Lexicon VA Extension 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","VSE",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("LEXQVSEO",$J," "),-1))+1 S ^TMP("LEXQVSEO",$J,LEXI)=$G(X),^TMP("LEXQVSEO",$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),"VSE",$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",58,"")) Q:'$L(LEXDES)
- . S LEXHIS=$O(^LEX(757.01,+LEXIEN,7,"C",58,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),58,.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[HLEXQVSE2 10152 printed Apr 23, 2025@18:23:16 Page 2
- LEXQVSE2 ;ISL/TJH - Query - VA Extension SNOMED CT - Save ;01/25/2021
- +1 ;;2.0;LEXICON UTILITY;**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("LEXQVSEO") 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("LEXQVSEO",$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("LEXQVSEO",$JOB))
- DO DSP^LEXQO("LEXQVSEO")
- QUIT
- +3 DO FUL
- IF +($GET(LEXNODP))'>0
- if $DATA(^TMP("LEXQVSEO",$JOB))
- DO DSP^LEXQO("LEXQVSEO")
- +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^LEXQVSE(LEXMC,.LEXIENS)
- +7 DO EXP($GET(LEXSO),$GET(LEXCDT),.LEXIENS,$GET(LEXL))
- +8 KILL LEXSUBS
- DO SUBS^LEXQVSE(LEXMC,.LEXSUBS)
- +9 if $DATA(LEXSUBS)
- DO SUBS(.LEXSUBS,$GET(LEXL))
- +10 KILL LEXMAPS
- DO MAPS^LEXQVSE(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^LEXQVSE(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
- 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^LEXQVSE(+LEXEI)
- +20 DO DS^LEXQVSE(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 "^58^"[("^"_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="VSE"
- SET LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB)
- SET LEXLEX=$PIECE(LEXLEX,"^",2)
- +6 SET LEXLEX=$SELECT(+LEXLEX>0:("Lexicon VA Extension 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","VSE",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("LEXQVSEO",$JOB," "),-1))+1
- SET ^TMP("LEXQVSEO",$JOB,LEXI)=$GET(X)
- SET ^TMP("LEXQVSEO",$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),"VSE",$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",58,""))
- if '$LENGTH(LEXDES)
- QUIT
- +6 SET LEXHIS=$ORDER(^LEX(757.01,+LEXIEN,7,"C",58,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),58,.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
