LEX10CS2 ;ISL/KER - ICD-10 Code Set (cont) ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP(LEXSUB,$J, SACC 2.3.2.5.1
; ^YSD(627.7, ICR 1612
; ^ICPT( ICR 4489
;
; External References
; $$CODEABA^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$CODEN^ICPTCOD ICR 1995
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
CODELIST(X,LEXSPEC,LEXSUB,LEXD,LEXL,LEXF) ; Wild Card Search for Codes
;
; Input
;
; X Coding System (Required)
; LEXSPEC Search Specification (Required)
; First 2 characters alpha-numeric
; May contain a "?" wildcard in any position
; May contain a "*" wildcard in last position
;
; LEXSUB Global Subscript in the calling applications
; namespace to be used in the output ^TMP
; global array (Optional, default "CODELIST")
;
; ^TMP(LEXSUB,$J, ...
;
; LEXD Search Date (Optional)
; LEXL List Length (Optional, Default 30)
; LEXF Output Flag (Optional)
; 0 or Null brief output
; 1 detailed output
;
; Output
;
; ^TMP(LEXSUB,$J) Output Array containing the codes found
;
; LEXF = 0 or not passed
;
; ^TMP(LEXSUB,$J,0)=Total n
; ^TMP(LEXSUB,$J,1)=Code 1
; ^TMP(LEXSUB,$J,2)=Code 2
; ^TMP(LEXSUB,$J,n)=Code n
;
; LEXF > 0
;
; ^TMP(LEXSUB,$J,0)=Total n
; ^TMP(LEXSUB,$J,1)=Code 1
; ^TMP(LEXSUB,$J,1,1)=Code 1 ^ date
; ^TMP(LEXSUB,$J,1,2)=Expression 1 IEN ^ Expression 1
; ^TMP(LEXSUB,$J,1,"MSG")=Message (unversioned only)
; ^TMP(LEXSUB,$J,2)=Code 1
; ^TMP(LEXSUB,$J,2,1)=Code 2 ^ date
; ^TMP(LEXSUB,$J,2,2)=Expression 2 IEN ^ Expression 2
; ^TMP(LEXSUB,$J,2,"MSG")=Message (unversioned only)
; ^TMP(LEXSUB,$J,n)=Code n
; ^TMP(LEXSUB,$J,n,1)=Code n ^ date
; ^TMP(LEXSUB,$J,n,2)=Expression n IEN ^ Expression n
; ^TMP(LEXSUB,$J,n,"MSG")=Message (unversioned only)
;
; $$CODELIST
;
; A variable defining success/error conditions
;
; Positive number for success
; Negative number for error or condition
;
; "-1^Coding system not specified"
; "-2^Invalid coding system/source abbreviation"
; "-3^No search specification"
; "-4^Insufficient search specification"
; "-5^Invalid search specification"
; "-6^Number of matches exceeds specified limit"
;
N LEX,LEXAI,LEXC,LEXCLIS,LEXCODE,LEXEFF,LEXEI,LEXEX,LEXEXC,LEXEXIT
N LEXEXP,LEXFLG,LEXHIS,LEXI,LEXLEN,LEXND,LEXO,LEXOK,LEXR,LEXSI,LEXUN
N LEXSP,LEXSRC,LEXSS,LEXTOT,LEXVDT S LEXTOT=0
Q:'$L($G(X)) "-1^Coding system not specified"
S LEXEXC=0,LEXSRC=$$SRC($G(X))
Q:LEXSRC'>0 "-2^Invalid coding system/source abbreviation"
S LEXSPEC=$$UP^XLFSTR($G(LEXSPEC))
I LEXSRC=30 D
. I $L(LEXSPEC)=4,$E(LEXSPEC,3)="*",$E(LEXSPEC,4)="." S LEXSPEC=$E(LEXSPEC,1,3)
. I $L(LEXSPEC)=3,$E(LEXSPEC,3)'="*" S LEXSPEC=LEXSPEC_"."
. I $L(LEXSPEC)>3,LEXSPEC'["." S LEXSPEC=$E(LEXSPEC,1,3)_"."_$E(LEXSPEC,4,$L(LEXSPEC))
Q:'$L(LEXSPEC) "-3^No search specification"
S LEXR=$P(LEXSPEC,"*",1),LEXR=$P(LEXR,"?",1)
Q:$L(LEXR)'>1 "-4^Insufficient search specification"
S LEXEXIT=0,LEXOK=1 F LEXI=1,2 D
. S:$E(LEXSPEC,LEXI)'?1A&($E(LEXSPEC,LEXI)'?1N) LEXOK=0
Q:'LEXOK "-5^Invalid search specification, first two characters must be alpha numeric"
I LEXSPEC["*",$L($TR($P(LEXSPEC,"*",2,4000),".","")) S LEXOK=0
Q:'LEXOK "-5^Invalid search specification, trailing wildcard character ""*"""
S LEXSS=$G(LEXSUB) S:'$L(LEXSS) LEXSS="CODELIST" S LEXVDT=$G(LEXD)
S LEXUN=$S(LEXVDT?7N:0,1:1)
S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=5000000
S LEXFLG=+($G(LEXF))
S LEXO=$E(LEXR,1,($L(LEXR)-1))_$C($A($E(LEXR,$L(LEXR)))-1)_"~"
S LEXEX=$S($E(LEXSPEC,$L(LEXSPEC))="*":0,1:1),LEXSP=$TR(LEXSPEC,"*","")
S LEXEXIT=0 F S LEXO=$O(^LEX(757.02,"CODE",LEXO)) D Q:LEXEXIT
. S:'$L(LEXO)!($E(LEXO,1,$L(LEXR))'=LEXR) LEXEXIT=1 Q:LEXEXIT
. S LEXC=$TR(LEXO," ","") Q:LEXEX&($L(LEXSP)'=$L(LEXC))
. S LEXOK=1 F LEXI=1:1:$L(LEXSP) D
. . Q:$E(LEXSPEC,LEXI)="?" Q:$E(LEXSPEC,LEXI)="*"
. . S:$E(LEXC,LEXI)'=$E(LEXSPEC,LEXI) LEXOK=0
. Q:'LEXOK S LEXSI=0
. F S LEXSI=$O(^LEX(757.02,"CODE",LEXO,LEXSI)) Q:+LEXSI'>0 D
. . N LEXAI,LEXCODE,LEXEFF,LEXEI,LEXEXP,LEXHIS,LEXND,LEXVAR,LEXMSG
. . S LEXND=$G(^LEX(757.02,+LEXSI,0))
. . Q:$P(LEXND,"^",3)'=LEXSRC Q:$P(LEXND,"^",5)'=1
. . I LEXVDT?7N S LEXEFF=$O(^LEX(757.02,+LEXSI,4,"B",(LEXVDT+.001)),-1) Q:LEXEFF'?7N
. . I LEXVDT?7N S LEXHIS=$O(^LEX(757.02,+LEXSI,4,"B",LEXEFF," "),-1) Q:LEXHIS'?1N.N
. . I LEXVDT'?7N S LEXEFF=$O(^LEX(757.02,+LEXSI,4,"B",(9999999+.001)),-1) Q:LEXEFF'?7N
. . I LEXVDT'?7N S LEXHIS=$O(^LEX(757.02,+LEXSI,4,"B",LEXEFF," "),-1) Q:LEXHIS'?1N.N
. . I LEXVDT?7N Q:$P($G(^LEX(757.02,+LEXSI,4,+LEXHIS,0)),"^",2)'=1
. . S LEXEI=+LEXND,LEXEXP=$P($G(^LEX(757.01,+LEXEI,0)),"^",1)
. . S LEXCODE=$P(LEXND,"^",2) Q:'$L(LEXCODE) Q:+LEXEI'>0 Q:'$L(LEXEXP)
. . S LEXMSG="" S:LEXUN>0 LEXMSG=$$MSG(LEXCODE)
. . S LEXAI=$O(^TMP(LEXSS,$J," "),-1)+1
. . S LEXTOT=LEXTOT+1 I LEXAI>LEXLEN S LEXEXC=1 Q
. . S LEXVAR="" S:$L(LEXCODE)&(+LEXSRC>0) LEXVAR=$$VAR(LEXCODE,LEXSRC)
. . S ^TMP(LEXSS,$J,0)=LEXAI
. . S ^TMP(LEXSS,$J,LEXAI)=LEXCODE
. . S:+LEXFLG>0 ^TMP(LEXSS,$J,LEXAI,1)=LEXVAR_"^"_LEXCODE_"^"_LEXEFF
. . S:+LEXFLG>0 ^TMP(LEXSS,$J,LEXAI,2)=LEXEI_"^"_LEXEXP
. . S:$L($G(LEXMSG)) ^TMP(LEXSS,$J,LEXAI,"MSG")=$G(LEXMSG)
N LEXICON S X="1^"_+($G(^TMP(LEXSS,$J,0))) I +LEXEXC>0 D
. I +($G(LEXTOT))>+($G(LEXLEN)) D
. . S LEXTOT=$S(+($G(LEXTOT))>0:("("_+($G(LEXTOT))_") "),1:"")
. . S LEXLEN=$S(+($G(LEXLEN))>0:(" ("_+($G(LEXLEN))_")"),1:"")
. E S (LEXTOT,LEXLEN)=""
. S X="-6^Number "_$G(LEXTOT)_"of matches "
. S X=X_"exceeds specified limit"_$G(LEXLEN)
Q X
SRC(X) ; Source
N LEXS S LEXS=$G(X) Q:'$L(LEXS) -1
Q:LEXS?1N.N&($D(^LEX(757.03,+LEXS,0))) +LEXS
Q:$D(^LEX(757.03,"B",LEXS)) $O(^LEX(757.03,"B",LEXS,0))
Q:$D(^LEX(757.03,"ASAB",$E(LEXS,1,3))) $O(^LEX(757.03,"ASAB",$E(LEXS,1,3),0))
Q -1
VAR(X,Y) ; Variable Pointer for code X and system Y
N LEXCODE,LEXI,LEXIEN,LEXO,LEXRT,LEXSYS,LEXT,LEXVAR S LEXCODE=$G(X),LEXSYS=$G(Y) S LEXVAR=""
I "^1^30^"[("^"_LEXSYS_"^") D S X=LEXVAR Q X
. S LEXRT=$$ROOT^ICDEX(80),LEXIEN=$$CODEABA^ICDEX(LEXCODE,80,LEXSYS)
. S:+($G(LEXIEN))>0&(LEXRT["^") LEXVAR=+($G(LEXIEN))_";"_$TR(LEXRT,"^","")
I "^2^31^"[("^"_LEXSYS_"^") D S X=LEXVAR Q X
. S LEXRT=$$ROOT^ICDEX(80.1),LEXIEN=$$CODEABA^ICDEX(LEXCODE,80.1,LEXSYS)
. S:+($G(LEXIEN))>0&(LEXRT["^") LEXVAR=+($G(LEXIEN))_";"_$TR(LEXRT,"^","")
I "^3^4^"[("^"_LEXSYS_"^") D S X=LEXVAR Q X
. S LEXRT="^ICPT(",LEXIEN=$$CODEN^ICPTCOD(LEXCODE)
. S:+($G(LEXIEN))>0 LEXVAR=+($G(LEXIEN))_";"_$TR(LEXRT,"^","")
I "^5^6^"[("^"_LEXSYS_"^") D S X=LEXVAR Q X
. N LEXT,LEXI,LEXIEN,LEXRT S LEXVAR=""
. S LEXRT=" ^YSD(627.7,",LEXT=$S(LEXSYS=5:"3R",LEXSYS=6:4,1:"") Q:+LEXT'>0
. S LEXI=0 F S LEXI=$O(^YSD(627.7,"B",LEXCODE,LEXI)) Q:+LEXI=0 D
. . Q:$P($G(^YSD(627.7,LEXI,0)),"^",2)'=LEXT S LEXIEN=LEXI
. S:+($G(LEXIEN))>0 LEXVAR=+($G(LEXIEN))_";"_$TR(LEXRT,"^","")
S X=LEXVAR
Q X
MSG(X) ; Message for Unversioned Search
N LEXCODE,LEXIA,LEXAC,LEXPD,LEXTD S LEXTD=$$DT^XLFDT,LEXCODE=$TR(X," ","")
S:$G(LEXCDT)?7N&($G(LEXCDT)'=LEXTD) LEXTD=$G(LEXCDT)
I $G(LEXCDT)="" S:$G(LEXVDT)?7N&($G(LEXVDT)'=LEXTD) LEXTD=$G(LEXVDT)
Q:'$L(LEXCODE) "" Q:'$D(^LEX(757.02,"ACT",(LEXCODE_" "))) ""
S LEXIA=$O(^LEX(757.02,"ACT",(LEXCODE_" "),2,(LEXTD+.0001)),-1)
S LEXAC=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD-.0001)),-1)
S LEXPD=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD)))
I LEXIA?7N,LEXAC?7N,LEXIA>LEXAC D Q X
. S X="Inactive "_$$FMTE^XLFDT(LEXIA,"5Z")
I LEXAC'=LEXTD,LEXPD?7N,LEXPD>LEXTD D Q X
. S X="Pending "_$$FMTE^XLFDT(LEXPD,"5Z")
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10CS2 8180 printed Sep 23, 2025@19:39:08 Page 2
LEX10CS2 ;ISL/KER - ICD-10 Code Set (cont) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP(LEXSUB,$J, SACC 2.3.2.5.1
+5 ; ^YSD(627.7, ICR 1612
+6 ; ^ICPT( ICR 4489
+7 ;
+8 ; External References
+9 ; $$CODEABA^ICDEX ICR 5747
+10 ; $$ROOT^ICDEX ICR 5747
+11 ; $$CODEN^ICPTCOD ICR 1995
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
CODELIST(X,LEXSPEC,LEXSUB,LEXD,LEXL,LEXF) ; Wild Card Search for Codes
+1 ;
+2 ; Input
+3 ;
+4 ; X Coding System (Required)
+5 ; LEXSPEC Search Specification (Required)
+6 ; First 2 characters alpha-numeric
+7 ; May contain a "?" wildcard in any position
+8 ; May contain a "*" wildcard in last position
+9 ;
+10 ; LEXSUB Global Subscript in the calling applications
+11 ; namespace to be used in the output ^TMP
+12 ; global array (Optional, default "CODELIST")
+13 ;
+14 ; ^TMP(LEXSUB,$J, ...
+15 ;
+16 ; LEXD Search Date (Optional)
+17 ; LEXL List Length (Optional, Default 30)
+18 ; LEXF Output Flag (Optional)
+19 ; 0 or Null brief output
+20 ; 1 detailed output
+21 ;
+22 ; Output
+23 ;
+24 ; ^TMP(LEXSUB,$J) Output Array containing the codes found
+25 ;
+26 ; LEXF = 0 or not passed
+27 ;
+28 ; ^TMP(LEXSUB,$J,0)=Total n
+29 ; ^TMP(LEXSUB,$J,1)=Code 1
+30 ; ^TMP(LEXSUB,$J,2)=Code 2
+31 ; ^TMP(LEXSUB,$J,n)=Code n
+32 ;
+33 ; LEXF > 0
+34 ;
+35 ; ^TMP(LEXSUB,$J,0)=Total n
+36 ; ^TMP(LEXSUB,$J,1)=Code 1
+37 ; ^TMP(LEXSUB,$J,1,1)=Code 1 ^ date
+38 ; ^TMP(LEXSUB,$J,1,2)=Expression 1 IEN ^ Expression 1
+39 ; ^TMP(LEXSUB,$J,1,"MSG")=Message (unversioned only)
+40 ; ^TMP(LEXSUB,$J,2)=Code 1
+41 ; ^TMP(LEXSUB,$J,2,1)=Code 2 ^ date
+42 ; ^TMP(LEXSUB,$J,2,2)=Expression 2 IEN ^ Expression 2
+43 ; ^TMP(LEXSUB,$J,2,"MSG")=Message (unversioned only)
+44 ; ^TMP(LEXSUB,$J,n)=Code n
+45 ; ^TMP(LEXSUB,$J,n,1)=Code n ^ date
+46 ; ^TMP(LEXSUB,$J,n,2)=Expression n IEN ^ Expression n
+47 ; ^TMP(LEXSUB,$J,n,"MSG")=Message (unversioned only)
+48 ;
+49 ; $$CODELIST
+50 ;
+51 ; A variable defining success/error conditions
+52 ;
+53 ; Positive number for success
+54 ; Negative number for error or condition
+55 ;
+56 ; "-1^Coding system not specified"
+57 ; "-2^Invalid coding system/source abbreviation"
+58 ; "-3^No search specification"
+59 ; "-4^Insufficient search specification"
+60 ; "-5^Invalid search specification"
+61 ; "-6^Number of matches exceeds specified limit"
+62 ;
+63 NEW LEX,LEXAI,LEXC,LEXCLIS,LEXCODE,LEXEFF,LEXEI,LEXEX,LEXEXC,LEXEXIT
+64 NEW LEXEXP,LEXFLG,LEXHIS,LEXI,LEXLEN,LEXND,LEXO,LEXOK,LEXR,LEXSI,LEXUN
+65 NEW LEXSP,LEXSRC,LEXSS,LEXTOT,LEXVDT
SET LEXTOT=0
+66 if '$LENGTH($GET(X))
QUIT "-1^Coding system not specified"
+67 SET LEXEXC=0
SET LEXSRC=$$SRC($GET(X))
+68 if LEXSRC'>0
QUIT "-2^Invalid coding system/source abbreviation"
+69 SET LEXSPEC=$$UP^XLFSTR($GET(LEXSPEC))
+70 IF LEXSRC=30
Begin DoDot:1
+71 IF $LENGTH(LEXSPEC)=4
IF $EXTRACT(LEXSPEC,3)="*"
IF $EXTRACT(LEXSPEC,4)="."
SET LEXSPEC=$EXTRACT(LEXSPEC,1,3)
+72 IF $LENGTH(LEXSPEC)=3
IF $EXTRACT(LEXSPEC,3)'="*"
SET LEXSPEC=LEXSPEC_"."
+73 IF $LENGTH(LEXSPEC)>3
IF LEXSPEC'["."
SET LEXSPEC=$EXTRACT(LEXSPEC,1,3)_"."_$EXTRACT(LEXSPEC,4,$LENGTH(LEXSPEC))
End DoDot:1
+74 if '$LENGTH(LEXSPEC)
QUIT "-3^No search specification"
+75 SET LEXR=$PIECE(LEXSPEC,"*",1)
SET LEXR=$PIECE(LEXR,"?",1)
+76 if $LENGTH(LEXR)'>1
QUIT "-4^Insufficient search specification"
+77 SET LEXEXIT=0
SET LEXOK=1
FOR LEXI=1,2
Begin DoDot:1
+78 if $EXTRACT(LEXSPEC,LEXI)'?1A&($EXTRACT(LEXSPEC,LEXI)'?1N)
SET LEXOK=0
End DoDot:1
+79 if 'LEXOK
QUIT "-5^Invalid search specification, first two characters must be alpha numeric"
+80 IF LEXSPEC["*"
IF $LENGTH($TRANSLATE($PIECE(LEXSPEC,"*",2,4000),".",""))
SET LEXOK=0
+81 if 'LEXOK
QUIT "-5^Invalid search specification, trailing wildcard character ""*"""
+82 SET LEXSS=$GET(LEXSUB)
if '$LENGTH(LEXSS)
SET LEXSS="CODELIST"
SET LEXVDT=$GET(LEXD)
+83 SET LEXUN=$SELECT(LEXVDT?7N:0,1:1)
+84 SET LEXLEN=$GET(LEXL)
if +LEXLEN'>0
SET LEXLEN=5000000
+85 SET LEXFLG=+($GET(LEXF))
+86 SET LEXO=$EXTRACT(LEXR,1,($LENGTH(LEXR)-1))_$CHAR($ASCII($EXTRACT(LEXR,$LENGTH(LEXR)))-1)_"~"
+87 SET LEXEX=$SELECT($EXTRACT(LEXSPEC,$LENGTH(LEXSPEC))="*":0,1:1)
SET LEXSP=$TRANSLATE(LEXSPEC,"*","")
+88 SET LEXEXIT=0
FOR
SET LEXO=$ORDER(^LEX(757.02,"CODE",LEXO))
Begin DoDot:1
+89 if '$LENGTH(LEXO)!($EXTRACT(LEXO,1,$LENGTH(LEXR))'=LEXR)
SET LEXEXIT=1
if LEXEXIT
QUIT
+90 SET LEXC=$TRANSLATE(LEXO," ","")
if LEXEX&($LENGTH(LEXSP)'=$LENGTH(LEXC))
QUIT
+91 SET LEXOK=1
FOR LEXI=1:1:$LENGTH(LEXSP)
Begin DoDot:2
+92 if $EXTRACT(LEXSPEC,LEXI)="?"
QUIT
if $EXTRACT(LEXSPEC,LEXI)="*"
QUIT
+93 if $EXTRACT(LEXC,LEXI)'=$EXTRACT(LEXSPEC,LEXI)
SET LEXOK=0
End DoDot:2
+94 if 'LEXOK
QUIT
SET LEXSI=0
+95 FOR
SET LEXSI=$ORDER(^LEX(757.02,"CODE",LEXO,LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:2
+96 NEW LEXAI,LEXCODE,LEXEFF,LEXEI,LEXEXP,LEXHIS,LEXND,LEXVAR,LEXMSG
+97 SET LEXND=$GET(^LEX(757.02,+LEXSI,0))
+98 if $PIECE(LEXND,"^",3)'=LEXSRC
QUIT
if $PIECE(LEXND,"^",5)'=1
QUIT
+99 IF LEXVDT?7N
SET LEXEFF=$ORDER(^LEX(757.02,+LEXSI,4,"B",(LEXVDT+.001)),-1)
if LEXEFF'?7N
QUIT
+100 IF LEXVDT?7N
SET LEXHIS=$ORDER(^LEX(757.02,+LEXSI,4,"B",LEXEFF," "),-1)
if LEXHIS'?1N.N
QUIT
+101 IF LEXVDT'?7N
SET LEXEFF=$ORDER(^LEX(757.02,+LEXSI,4,"B",(9999999+.001)),-1)
if LEXEFF'?7N
QUIT
+102 IF LEXVDT'?7N
SET LEXHIS=$ORDER(^LEX(757.02,+LEXSI,4,"B",LEXEFF," "),-1)
if LEXHIS'?1N.N
QUIT
+103 IF LEXVDT?7N
if $PIECE($GET(^LEX(757.02,+LEXSI,4,+LEXHIS,0)),"^",2)'=1
QUIT
+104 SET LEXEI=+LEXND
SET LEXEXP=$PIECE($GET(^LEX(757.01,+LEXEI,0)),"^",1)
+105 SET LEXCODE=$PIECE(LEXND,"^",2)
if '$LENGTH(LEXCODE)
QUIT
if +LEXEI'>0
QUIT
if '$LENGTH(LEXEXP)
QUIT
+106 SET LEXMSG=""
if LEXUN>0
SET LEXMSG=$$MSG(LEXCODE)
+107 SET LEXAI=$ORDER(^TMP(LEXSS,$JOB," "),-1)+1
+108 SET LEXTOT=LEXTOT+1
IF LEXAI>LEXLEN
SET LEXEXC=1
QUIT
+109 SET LEXVAR=""
if $LENGTH(LEXCODE)&(+LEXSRC>0)
SET LEXVAR=$$VAR(LEXCODE,LEXSRC)
+110 SET ^TMP(LEXSS,$JOB,0)=LEXAI
+111 SET ^TMP(LEXSS,$JOB,LEXAI)=LEXCODE
+112 if +LEXFLG>0
SET ^TMP(LEXSS,$JOB,LEXAI,1)=LEXVAR_"^"_LEXCODE_"^"_LEXEFF
+113 if +LEXFLG>0
SET ^TMP(LEXSS,$JOB,LEXAI,2)=LEXEI_"^"_LEXEXP
+114 if $LENGTH($GET(LEXMSG))
SET ^TMP(LEXSS,$JOB,LEXAI,"MSG")=$GET(LEXMSG)
End DoDot:2
End DoDot:1
if LEXEXIT
QUIT
+115 NEW LEXICON
SET X="1^"_+($GET(^TMP(LEXSS,$JOB,0)))
IF +LEXEXC>0
Begin DoDot:1
+116 IF +($GET(LEXTOT))>+($GET(LEXLEN))
Begin DoDot:2
+117 SET LEXTOT=$SELECT(+($GET(LEXTOT))>0:("("_+($GET(LEXTOT))_") "),1:"")
+118 SET LEXLEN=$SELECT(+($GET(LEXLEN))>0:(" ("_+($GET(LEXLEN))_")"),1:"")
End DoDot:2
+119 IF '$TEST
SET (LEXTOT,LEXLEN)=""
+120 SET X="-6^Number "_$GET(LEXTOT)_"of matches "
+121 SET X=X_"exceeds specified limit"_$GET(LEXLEN)
End DoDot:1
+122 QUIT X
SRC(X) ; Source
+1 NEW LEXS
SET LEXS=$GET(X)
if '$LENGTH(LEXS)
QUIT -1
+2 if LEXS?1N.N&($DATA(^LEX(757.03,+LEXS,0)))
QUIT +LEXS
+3 if $DATA(^LEX(757.03,"B",LEXS))
QUIT $ORDER(^LEX(757.03,"B",LEXS,0))
+4 if $DATA(^LEX(757.03,"ASAB",$EXTRACT(LEXS,1,3)))
QUIT $ORDER(^LEX(757.03,"ASAB",$EXTRACT(LEXS,1,3),0))
+5 QUIT -1
VAR(X,Y) ; Variable Pointer for code X and system Y
+1 NEW LEXCODE,LEXI,LEXIEN,LEXO,LEXRT,LEXSYS,LEXT,LEXVAR
SET LEXCODE=$GET(X)
SET LEXSYS=$GET(Y)
SET LEXVAR=""
+2 IF "^1^30^"[("^"_LEXSYS_"^")
Begin DoDot:1
+3 SET LEXRT=$$ROOT^ICDEX(80)
SET LEXIEN=$$CODEABA^ICDEX(LEXCODE,80,LEXSYS)
+4 if +($GET(LEXIEN))>0&(LEXRT["^")
SET LEXVAR=+($GET(LEXIEN))_";"_$TRANSLATE(LEXRT,"^","")
End DoDot:1
SET X=LEXVAR
QUIT X
+5 IF "^2^31^"[("^"_LEXSYS_"^")
Begin DoDot:1
+6 SET LEXRT=$$ROOT^ICDEX(80.1)
SET LEXIEN=$$CODEABA^ICDEX(LEXCODE,80.1,LEXSYS)
+7 if +($GET(LEXIEN))>0&(LEXRT["^")
SET LEXVAR=+($GET(LEXIEN))_";"_$TRANSLATE(LEXRT,"^","")
End DoDot:1
SET X=LEXVAR
QUIT X
+8 IF "^3^4^"[("^"_LEXSYS_"^")
Begin DoDot:1
+9 SET LEXRT="^ICPT("
SET LEXIEN=$$CODEN^ICPTCOD(LEXCODE)
+10 if +($GET(LEXIEN))>0
SET LEXVAR=+($GET(LEXIEN))_";"_$TRANSLATE(LEXRT,"^","")
End DoDot:1
SET X=LEXVAR
QUIT X
+11 IF "^5^6^"[("^"_LEXSYS_"^")
Begin DoDot:1
+12 NEW LEXT,LEXI,LEXIEN,LEXRT
SET LEXVAR=""
+13 SET LEXRT=" ^YSD(627.7,"
SET LEXT=$SELECT(LEXSYS=5:"3R",LEXSYS=6:4,1:"")
if +LEXT'>0
QUIT
+14 SET LEXI=0
FOR
SET LEXI=$ORDER(^YSD(627.7,"B",LEXCODE,LEXI))
if +LEXI=0
QUIT
Begin DoDot:2
+15 if $PIECE($GET(^YSD(627.7,LEXI,0)),"^",2)'=LEXT
QUIT
SET LEXIEN=LEXI
End DoDot:2
+16 if +($GET(LEXIEN))>0
SET LEXVAR=+($GET(LEXIEN))_";"_$TRANSLATE(LEXRT,"^","")
End DoDot:1
SET X=LEXVAR
QUIT X
+17 SET X=LEXVAR
+18 QUIT X
MSG(X) ; Message for Unversioned Search
+1 NEW LEXCODE,LEXIA,LEXAC,LEXPD,LEXTD
SET LEXTD=$$DT^XLFDT
SET LEXCODE=$TRANSLATE(X," ","")
+2 if $GET(LEXCDT)?7N&($GET(LEXCDT)'=LEXTD)
SET LEXTD=$GET(LEXCDT)
+3 IF $GET(LEXCDT)=""
if $GET(LEXVDT)?7N&($GET(LEXVDT)'=LEXTD)
SET LEXTD=$GET(LEXVDT)
+4 if '$LENGTH(LEXCODE)
QUIT ""
if '$DATA(^LEX(757.02,"ACT",(LEXCODE_" ")))
QUIT ""
+5 SET LEXIA=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),2,(LEXTD+.0001)),-1)
+6 SET LEXAC=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD-.0001)),-1)
+7 SET LEXPD=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD)))
+8 IF LEXIA?7N
IF LEXAC?7N
IF LEXIA>LEXAC
Begin DoDot:1
+9 SET X="Inactive "_$$FMTE^XLFDT(LEXIA,"5Z")
End DoDot:1
QUIT X
+10 IF LEXAC'=LEXTD
IF LEXPD?7N
IF LEXPD>LEXTD
Begin DoDot:1
+11 SET X="Pending "_$$FMTE^XLFDT(LEXPD,"5Z")
End DoDot:1
QUIT X
+12 QUIT ""
