LEXABC2 ;ISL/KER - Look-up by Code (part 2) ;05/23/2017
;;2.0;LEXICON UTILITY;**4,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.01 SACC 1.3
; ^LEX(757.03 SACC 1.3
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXL") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; None
;
; Local Variables NEWed or KILLed Elsewhere
; LEX Output Array
; LEXAFMT Output Format
; LEXSO2 Trailing Character of Code +
;
REO ; Reorder list
Q:'$D(^TMP("LEXL",$J)) N LEXS,LEXT,LEXP,LEXE,LEXEX,LEXFT,LEXM,LEXX S LEXS="" F S LEXS=$O(^TMP("LEXL",$J,LEXS)) Q:LEXS="" S LEXT=0 F S LEXT=$O(^TMP("LEXL",$J,LEXS,LEXT)) Q:+LEXT=0 D
. S LEXP=0 F S LEXP=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP)) Q:+LEXP=0 S LEXE=0 F S LEXE=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)) Q:+LEXE=0 D
. . Q:LEXP=3
. . I LEXP=1 D MC Q
. . I LEXP=4,$G(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE))["ICD" D SP Q
. . D OT
Q
MC ; Major concept
S LEXM=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1),LEXFT="A"
S ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
Q
SP ; Joint term/code
N LEXS2,LEXT2,LEXP2,LEXF2,LEXE2,LEXEX,LEXFT,LEXM,LEXF
N LEXX,LEXTM,LEXTE,LEXHM,LEXHE,LEXHD,LEXOK
S LEXOK=0,LEXS2="" F S LEXS2=$O(^TMP("LEXL",$J,LEXS2)) Q:LEXS2=""!(LEXOK) S LEXT2=0 F S LEXT2=$O(^TMP("LEXL",$J,LEXS2,LEXT2)) Q:+LEXT2=0!(LEXOK) D
. S LEXP2=0 F S LEXP2=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2)) Q:+LEXP2=0!(LEXOK) S LEXF=99999999999 F S LEXF=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF)) Q:LEXF=""!(LEXOK) D
. . S LEXE2=0 F S LEXE2=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2)) Q:+LEXE2=0!(LEXOK) D
. . . S LEXTM=$P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",1)
. . . S LEXTE=$P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",2)
. . . S LEXHM=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1)
. . . S LEXHE=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",2)
. . . S LEXHD=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",4)
. . . I LEXTM=LEXHM,LEXTE=LEXHE S $P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",4)=LEXHD K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE) S LEXOK=1 Q
I 'LEXOK D OT
Q
OT ; Other than Major Concept
S:LEXP>1 LEXX=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1)
S LEXFT=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",5)
; Primary --> <major concept>=<primary concept>
I +($G(LEXM))=+($G(LEXX)) D Q
. S:LEXFT="" LEXFT="B"
. S:$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Other: " $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Synonym: ",LEXFT="B"
. S ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE) K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
Q:+($G(LEXM))=+($G(LEXX))
; Other --> <major concept>'=<primary concept>
S LEXFT="F"
S $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",7)=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)
S $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Other: "
S ^TMP("LEXL",$J,LEXS,LEXT,3,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
Q
SCH(LEXX) ; $Orderable variable
S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
ADD ; Add codes expressions to the selection list
;
; Use local array LEXL
;
; S ^TMP("LEXL",$J,<Code>,<Type>,<Preference>,<Form>,<IEN>)=
; <IEN 757>^<IEN 757.01>^<Description>^<Display>^<Form Type>^<Form>
;
N LEXS,LEXT,LEXP,LEXFT,LEXSIEN,LEXPM,LEXEXA
S LEXS="" F S LEXS=$O(^TMP("LEXL",$J,LEXS)) Q:LEXS="" D
. S LEXT=0 F S LEXT=$O(^TMP("LEXL",$J,LEXS,LEXT)) Q:+LEXT=0 D
. . S (LEXP,LEXPM)=0 F S LEXP=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP)) Q:+LEXP=0 D
. . . S LEXFT="" F S LEXFT=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT)) Q:LEXFT="" D
. . . . S LEXSIEN=0 F S LEXSIEN=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN)) Q:+LEXSIEN=0 D SAVE
Q
SAVE ; Save in ^TMP
N LEXMI,LEXEI,LEXEX,LEXCD,LEXDF,LEXDS,LEXFM,LEXTP,LEXPX,LEXSR,LEXSX,LEXSY,LEXFQ,LEXSTR,LEXTMP
S LEXSTR="",LEXTMP=$G(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN))
S LEXCD=$$TM(LEXS),LEXSY=$P($G(^LEX(757.03,+LEXT,0)),"^",2)
S LEXSR=+($G(LEXT)),LEXMI=$P(LEXTMP,"^",1),LEXEI=$P(LEXTMP,"^",2),LEXDF=$P(LEXTMP,"^",3)
S LEXDS=$P(LEXTMP,"^",4),LEXFM=$P(LEXTMP,"^",4),LEXTP=$P(LEXTMP,"^",6),(LEXSX,LEXPX)="" S:LEXP=1 LEXPM=LEXMI
; Remove the following line of code if Mental Health either begins to use ICD-10 or DSM-V
Q:$D(LEXEXA(+LEXEI)) S LEXEXA(+LEXEI)=""
; Prefix
I LEXP>1 S LEXPX=LEXTP S:LEXPX["Concept" LEXPX="Synonym: " S:LEXPX="" LEXPX="Other: "
; Suffix
I LEXP>1 S LEXSX="" S:LEXPX["Other:" LEXSX="classified as" S:LEXPX="" LEXSX="classified as",LEXPX="Other: "
; Display
S:$L(LEXSX)&($G(LEXSO2)["+") LEXDS=LEXSX_" "_LEXDS S:$L(LEXDS) LEXDS="("_LEXDS_")"
; String
S (LEXEX,LEXSTR)=$$TERM(LEXEI) S:$L(LEXDF) LEXSTR=LEXSTR_" "_LEXDF S:$L(LEXDS) LEXSTR=LEXSTR_" "_LEXDS S:$L(LEXPX) LEXSTR=LEXPX_LEXSTR S:LEXP>1 LEXSTR=" "_LEXSTR
; Format = 0
; ^TMP("LEXFND",$J,FQ,IEN) = Display Text
; Format = 1
; ^TMP("LEXFND",$J,FQ,IEN) = Expression
; ^TMP("LEXFND",$J,FQ,IEN,SOURCE) = Code ^ System
I +($G(LEXAFMT))'>0 D
. S LEXFQ=$G(^TMP("LEXFND",$J,0)) S:+LEXFQ=0 LEXFQ=-999999 S LEXFQ=LEXFQ+1
. S:'$D(^TMP("LEXFND",$J,-LEXFQ,LEXEI)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
. S ^TMP("LEXFND",$J,0)=LEXFQ,LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
. S ^TMP("LEXFND",$J,LEXFQ,LEXEI)=LEXSTR
I +($G(LEXAFMT))>0 D
. N LEXVP,LEXO S LEXFQ=$G(^TMP("LEXFND",$J,0)) S:+LEXFQ=0 LEXFQ=-999999 S LEXFQ=LEXFQ+1,LEXVP=""
. S:'$D(^TMP("LEXFND",$J,-LEXFQ,LEXEI)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
. S ^TMP("LEXFND",$J,0)=LEXFQ,LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
. S ^TMP("LEXFND",$J,LEXFQ,LEXEI)=LEXEX
. I +($G(LEXSR))=1!(+($G(LEXSR))=30) D
. . N LEXP,LEXS S LEXP=$$CODEN^ICDEX(LEXCD,80),LEXS=$$CSI^ICDEX(80,+LEXP) S:+LEXP>0&(LEXS=LEXSR) LEXVP=+LEXP_";ICD9("
. I +($G(LEXSR))=2!(+($G(LEXSR))=31) D
. . N LEXP,LEXS S LEXP=$$CODEN^ICDEX(LEXCD,80.1),LEXS=$$CSI^ICDEX(80.1,+LEXP) S:+LEXP>0&(LEXS=LEXSR) LEXVP=+LEXP_";ICD0("
. I +LEXSR=3!(+LEXSR=4) D
. . N LEXP S LEXP=$$CODEN^ICPTCOD(LEXCD) S:+LEXP>0 LEXVP=+LEXP_";ICPT("
. S LEXO=(LEXCD_"^"_LEXSY) S:$L($G(LEXVP)) LEXO=LEXO_"^"_LEXVP
. S ^TMP("LEXFND",$J,LEXFQ,LEXEI,+LEXSR)=LEXO
Q
;
; Miscellaneous
TERM(LEXX) ; Get expression
Q $G(^LEX(757.01,+($G(LEXX)),0))
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[HLEXABC2 6740 printed Dec 13, 2024@02:06:54 Page 2
LEXABC2 ;ISL/KER - Look-up by Code (part 2) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**4,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01 SACC 1.3
+5 ; ^LEX(757.03 SACC 1.3
+6 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+7 ; ^TMP("LEXL") SACC 2.3.2.5.1
+8 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; None
+12 ;
+13 ; Local Variables NEWed or KILLed Elsewhere
+14 ; LEX Output Array
+15 ; LEXAFMT Output Format
+16 ; LEXSO2 Trailing Character of Code +
+17 ;
REO ; Reorder list
+1 if '$DATA(^TMP("LEXL",$JOB))
QUIT
NEW LEXS,LEXT,LEXP,LEXE,LEXEX,LEXFT,LEXM,LEXX
SET LEXS=""
FOR
SET LEXS=$ORDER(^TMP("LEXL",$JOB,LEXS))
if LEXS=""
QUIT
SET LEXT=0
FOR
SET LEXT=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT))
if +LEXT=0
QUIT
Begin DoDot:1
+2 SET LEXP=0
FOR
SET LEXP=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP))
if +LEXP=0
QUIT
SET LEXE=0
FOR
SET LEXE=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE))
if +LEXE=0
QUIT
Begin DoDot:2
+3 if LEXP=3
QUIT
+4 IF LEXP=1
DO MC
QUIT
+5 IF LEXP=4
IF $GET(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE))["ICD"
DO SP
QUIT
+6 DO OT
End DoDot:2
End DoDot:1
+7 QUIT
MC ; Major concept
+1 SET LEXM=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",1)
SET LEXFT="A"
+2 SET ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
+3 KILL ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
+4 QUIT
SP ; Joint term/code
+1 NEW LEXS2,LEXT2,LEXP2,LEXF2,LEXE2,LEXEX,LEXFT,LEXM,LEXF
+2 NEW LEXX,LEXTM,LEXTE,LEXHM,LEXHE,LEXHD,LEXOK
+3 SET LEXOK=0
SET LEXS2=""
FOR
SET LEXS2=$ORDER(^TMP("LEXL",$JOB,LEXS2))
if LEXS2=""!(LEXOK)
QUIT
SET LEXT2=0
FOR
SET LEXT2=$ORDER(^TMP("LEXL",$JOB,LEXS2,LEXT2))
if +LEXT2=0!(LEXOK)
QUIT
Begin DoDot:1
+4 SET LEXP2=0
FOR
SET LEXP2=$ORDER(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2))
if +LEXP2=0!(LEXOK)
QUIT
SET LEXF=99999999999
FOR
SET LEXF=$ORDER(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2,LEXF))
if LEXF=""!(LEXOK)
QUIT
Begin DoDot:2
+5 SET LEXE2=0
FOR
SET LEXE2=$ORDER(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2,LEXF,LEXE2))
if +LEXE2=0!(LEXOK)
QUIT
Begin DoDot:3
+6 SET LEXTM=$PIECE(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",1)
+7 SET LEXTE=$PIECE(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",2)
+8 SET LEXHM=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",1)
+9 SET LEXHE=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",2)
+10 SET LEXHD=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",4)
+11 IF LEXTM=LEXHM
IF LEXTE=LEXHE
SET $PIECE(^TMP("LEXL",$JOB,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",4)=LEXHD
KILL ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
SET LEXOK=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF 'LEXOK
DO OT
+13 QUIT
OT ; Other than Major Concept
+1 if LEXP>1
SET LEXX=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",1)
+2 SET LEXFT=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",5)
+3 ; Primary --> <major concept>=<primary concept>
+4 IF +($GET(LEXM))=+($GET(LEXX))
Begin DoDot:1
+5 if LEXFT=""
SET LEXFT="B"
+6 if $PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",6)="Other
SET $PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",6)="Synonym: "
SET LEXFT="B"
+7 SET ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
KILL ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
End DoDot:1
QUIT
+8 if +($GET(LEXM))=+($GET(LEXX))
QUIT
+9 ; Other --> <major concept>'=<primary concept>
+10 SET LEXFT="F"
+11 SET $PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",7)=$PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",6)
+12 SET $PIECE(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE),"^",6)="Other: "
+13 SET ^TMP("LEXL",$JOB,LEXS,LEXT,3,LEXFT,LEXE)=^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
+14 KILL ^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXE)
+15 QUIT
SCH(LEXX) ; $Orderable variable
+1 SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~"
QUIT LEXX
ADD ; Add codes expressions to the selection list
+1 ;
+2 ; Use local array LEXL
+3 ;
+4 ; S ^TMP("LEXL",$J,<Code>,<Type>,<Preference>,<Form>,<IEN>)=
+5 ; <IEN 757>^<IEN 757.01>^<Description>^<Display>^<Form Type>^<Form>
+6 ;
+7 NEW LEXS,LEXT,LEXP,LEXFT,LEXSIEN,LEXPM,LEXEXA
+8 SET LEXS=""
FOR
SET LEXS=$ORDER(^TMP("LEXL",$JOB,LEXS))
if LEXS=""
QUIT
Begin DoDot:1
+9 SET LEXT=0
FOR
SET LEXT=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT))
if +LEXT=0
QUIT
Begin DoDot:2
+10 SET (LEXP,LEXPM)=0
FOR
SET LEXP=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP))
if +LEXP=0
QUIT
Begin DoDot:3
+11 SET LEXFT=""
FOR
SET LEXFT=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXFT))
if LEXFT=""
QUIT
Begin DoDot:4
+12 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXFT,LEXSIEN))
if +LEXSIEN=0
QUIT
DO SAVE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
SAVE ; Save in ^TMP
+1 NEW LEXMI,LEXEI,LEXEX,LEXCD,LEXDF,LEXDS,LEXFM,LEXTP,LEXPX,LEXSR,LEXSX,LEXSY,LEXFQ,LEXSTR,LEXTMP
+2 SET LEXSTR=""
SET LEXTMP=$GET(^TMP("LEXL",$JOB,LEXS,LEXT,LEXP,LEXFT,LEXSIEN))
+3 SET LEXCD=$$TM(LEXS)
SET LEXSY=$PIECE($GET(^LEX(757.03,+LEXT,0)),"^",2)
+4 SET LEXSR=+($GET(LEXT))
SET LEXMI=$PIECE(LEXTMP,"^",1)
SET LEXEI=$PIECE(LEXTMP,"^",2)
SET LEXDF=$PIECE(LEXTMP,"^",3)
+5 SET LEXDS=$PIECE(LEXTMP,"^",4)
SET LEXFM=$PIECE(LEXTMP,"^",4)
SET LEXTP=$PIECE(LEXTMP,"^",6)
SET (LEXSX,LEXPX)=""
if LEXP=1
SET LEXPM=LEXMI
+6 ; Remove the following line of code if Mental Health either begins to use ICD-10 or DSM-V
+7 if $DATA(LEXEXA(+LEXEI))
QUIT
SET LEXEXA(+LEXEI)=""
+8 ; Prefix
+9 IF LEXP>1
SET LEXPX=LEXTP
if LEXPX["Concept"
SET LEXPX="Synonym: "
if LEXPX=""
SET LEXPX="Other: "
+10 ; Suffix
+11 IF LEXP>1
SET LEXSX=""
if LEXPX["Other
SET LEXSX="classified as"
if LEXPX=""
SET LEXSX="classified as"
SET LEXPX="Other: "
+12 ; Display
+13 if $LENGTH(LEXSX)&($GET(LEXSO2)["+")
SET LEXDS=LEXSX_" "_LEXDS
if $LENGTH(LEXDS)
SET LEXDS="("_LEXDS_")"
+14 ; String
+15 SET (LEXEX,LEXSTR)=$$TERM(LEXEI)
if $LENGTH(LEXDF)
SET LEXSTR=LEXSTR_" "_LEXDF
if $LENGTH(LEXDS)
SET LEXSTR=LEXSTR_" "_LEXDS
if $LENGTH(LEXPX)
SET LEXSTR=LEXPX_LEXSTR
if LEXP>1
SET LEXSTR=" "_LEXSTR
+16 ; Format = 0
+17 ; ^TMP("LEXFND",$J,FQ,IEN) = Display Text
+18 ; Format = 1
+19 ; ^TMP("LEXFND",$J,FQ,IEN) = Expression
+20 ; ^TMP("LEXFND",$J,FQ,IEN,SOURCE) = Code ^ System
+21 IF +($GET(LEXAFMT))'>0
Begin DoDot:1
+22 SET LEXFQ=$GET(^TMP("LEXFND",$JOB,0))
if +LEXFQ=0
SET LEXFQ=-999999
SET LEXFQ=LEXFQ+1
+23 if '$DATA(^TMP("LEXFND",$JOB,-LEXFQ,LEXEI))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+24 SET ^TMP("LEXFND",$JOB,0)=LEXFQ
SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+25 SET ^TMP("LEXFND",$JOB,LEXFQ,LEXEI)=LEXSTR
End DoDot:1
+26 IF +($GET(LEXAFMT))>0
Begin DoDot:1
+27 NEW LEXVP,LEXO
SET LEXFQ=$GET(^TMP("LEXFND",$JOB,0))
if +LEXFQ=0
SET LEXFQ=-999999
SET LEXFQ=LEXFQ+1
SET LEXVP=""
+28 if '$DATA(^TMP("LEXFND",$JOB,-LEXFQ,LEXEI))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+29 SET ^TMP("LEXFND",$JOB,0)=LEXFQ
SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+30 SET ^TMP("LEXFND",$JOB,LEXFQ,LEXEI)=LEXEX
+31 IF +($GET(LEXSR))=1!(+($GET(LEXSR))=30)
Begin DoDot:2
+32 NEW LEXP,LEXS
SET LEXP=$$CODEN^ICDEX(LEXCD,80)
SET LEXS=$$CSI^ICDEX(80,+LEXP)
if +LEXP>0&(LEXS=LEXSR)
SET LEXVP=+LEXP_";ICD9("
End DoDot:2
+33 IF +($GET(LEXSR))=2!(+($GET(LEXSR))=31)
Begin DoDot:2
+34 NEW LEXP,LEXS
SET LEXP=$$CODEN^ICDEX(LEXCD,80.1)
SET LEXS=$$CSI^ICDEX(80.1,+LEXP)
if +LEXP>0&(LEXS=LEXSR)
SET LEXVP=+LEXP_";ICD0("
End DoDot:2
+35 IF +LEXSR=3!(+LEXSR=4)
Begin DoDot:2
+36 NEW LEXP
SET LEXP=$$CODEN^ICPTCOD(LEXCD)
if +LEXP>0
SET LEXVP=+LEXP_";ICPT("
End DoDot:2
+37 SET LEXO=(LEXCD_"^"_LEXSY)
if $LENGTH($GET(LEXVP))
SET LEXO=LEXO_"^"_LEXVP
+38 SET ^TMP("LEXFND",$JOB,LEXFQ,LEXEI,+LEXSR)=LEXO
End DoDot:1
+39 QUIT
+40 ;
+41 ; Miscellaneous
TERM(LEXX) ; Get expression
+1 QUIT $GET(^LEX(757.01,+($GET(LEXX)),0))
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
