- 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 Feb 18, 2025@23:32:58 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
