LEXASO ;ISL/KER - Look-up Display String (Sources) ;05/23/2017
;;2.0;LEXICON UTILITY;**25,32,73,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.01, SACC 1.3
; ^LEX(757.02, SACC 1.3
; ^LEX(757.03, SACC 1.3
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$CODEN^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$CODEN^ICPTCOD ICR 1995
;
; Local Variables NEWed or KILLed Elsewhere
; LEXSOA Array of Codes
;
SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
;
; Input
;
; LEXX IEN of Expression file 757.01
; LEXSA Source abbreviation string
; LEXA ALL is a flag
; 0 - Expression codes only
; 1 - Concept codes
; LEXVDT Versioning Date
;
; Output
;
; $$SO String of Source Codes i.e.,
; (ICD-9-CM 799.9)
;
I +($G(LEXAFMT))>0 D SOA^LEXASO(LEXX,$G(^TMP("LEXSCH",$J,"DIS",0)),1,$G(LEXVDT),.LEXSOA) Q ""
Q:+($G(LEXX))=0!('$L($G(LEXSA))) "" Q:'$L($G(^LEX(757.01,LEXX,0))) ""
N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST D VDT^LEXU
S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0
S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
; Codes for an expression D EXP
I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
; Codes for a major concept D MAJ
I LEXM=1 S LEXMC=LEXEX D MAJ
EXIT ; Clean up and quit
Q LEXX
SOA(LEXX,LEXSA,LEXA,LEXVDT,LEXARY) ; Return array of source codes for LEXX SAB
;
; Input
;
; LEXX IEN of Expression file 757.01
; LEXSA Source abbreviation string
; LEXA ALL is a flag
; 0 - Expression codes only
; 1 - Concept codes
; LEXVDT Versioning Date
; LEXARY Array passed by Reference
;
; Output
;
; $$SO Success
; 0 - No codes found
; 1 - Codes found
;
; LEXARY(X) Array of Sources passed by Reference
;
; X = Coding System (pointer to 757.03)
;
; LEXARY(X,"P") = 3 Piece "^" delimited string
; 1 Code
; 2 Coding System the
; Preferred Term of
; the code
; 3 Variable Pointer to
; a National file if
; one exist
;
; LEXARY(X,###) = 3 Piece "^" delimited string
; 1 Code
; 2 Coding System the
; an expression that is
; not the Preferred
; Term for the code
; 3 Variable Pointer to
; a National file if
; one exist
;
Q:+($G(LEXX))=0!('$L($G(LEXSA))) "" Q:'$L($G(^LEX(757.01,LEXX,0))) ""
N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST,LEXAFMT D VDT^LEXU
S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0,LEXAFMT=1 K LEXARY
S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
; Codes for an expression D EXP
I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
; Codes for a major concept D MAJ
I LEXM=1 S LEXMC=LEXEX D MAJ
Q:$O(LEXARY(0))>0 1
Q 0
EXP ; Source string for an expression
I LEXSA'["/" D CODES(LEXEX,LEXSA,$G(LEXVDT)) S:+($G(LEXAFMT))'>0 LEXX=$$ASSEM Q
I LEXSA["/" D S:+($G(LEXAFMT))'>0 LEXX=$$ASSEM
. N LEXC F LEXC=1:1:$L(LEXSA,"/") D
. . D CODES(LEXEX,$P(LEXSA,"/",LEXC),$G(LEXVDT))
Q
MAJ ; Source string for a major concept
S LEXMC=$P($G(^LEX(757.01,LEXEX,1)),"^",1),LEXEX=0
S LEXEX=0 F S LEXEX=$O(^LEX(757.02,"AMC",LEXMC,LEXEX)) Q:+LEXEX=0 D
. N LEXME S LEXME=+($G(^LEX(757.02,LEXEX,0)))
. I LEXSA'["/" D CODES(LEXME,LEXSA,$G(LEXVDT)) Q
. I LEXSA["/" D Q
. . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
. . . D CODES(LEXME,$P(LEXSA,"/",LEXC),$G(LEXVDT))
S:+($G(LEXAFMT))'>0 LEXX=$$ASSEM
Q
CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
Q:$L($G(LEXSA))'=3 N LEXCD,LEXCN,LEXCP,LEXCS,LEXHE,LEXHI,LEXHN,LEXHS,LEXSAI,LEXSAN,LEXSO,LEXSR,LEXST,LEXSTA
S LEXST="",LEXSAI=+($O(^LEX(757.03,"ASAB",LEXSA,0))) Q:+LEXSAI'>0 S LEXSAN=$P($G(^LEX(757.03,+LEXSAI,0)),"^",2) Q:'$L(LEXSAN)
S LEXSO=0 F S LEXSO=$O(^LEX(757.02,"B",LEXEX,LEXSO)) Q:+LEXSO=0 D
. S LEXCN=$G(^LEX(757.02,LEXSO,0)),LEXCD=$P(LEXCN,"^",2) Q:'$L(LEXCD) S LEXCS=$P(LEXCN,"^",3) Q:+LEXCS'=+LEXSAI
. S LEXCP=$P(LEXCN,"^",5),LEXHE=$S(+LEXVDT>0:(LEXVDT_".99999"),1:" "),LEXHE=$O(^LEX(757.02,+LEXSO,4,"B",LEXHE),-1) Q:+LEXHE'>0
. S LEXHI=$O(^LEX(757.02,+LEXSO,4,"B",+LEXHE," "),-1)
. S LEXHN=$G(^LEX(757.02,+LEXSO,4,+LEXHI,0)),LEXHS=$P(LEXHN,"^",2) Q:+($G(LEXHS))'>0
. I +($G(LEXAFMT))=1 D Q
. . N LEXI,LEXO,LEXVP S LEXVP=""
. . I +LEXCS=1!(+LEXCS=30) D
. . . N LEXP,LEXS S LEXP=$$CODEN^ICDEX(LEXCD,80),LEXS=$$CSI^ICDEX(80,+LEXP) S:+LEXP>0&(LEXS=LEXCS) LEXVP=+LEXP_";ICD9("
. . I +LEXCS=2!(+LEXCS=31) D
. . . N LEXP,LEXS S LEXP=$$CODEN^ICDEX(LEXCD,80.1),LEXS=$$CSI^ICDEX(80.1,+LEXP) S:+LEXP>0&(LEXS=LEXCS) LEXVP=+LEXP_";ICD0("
. . I +LEXCS=3!(+LEXCS=4) D
. . . N LEXP S LEXP=$$CODEN^ICPTCOD(LEXCD) S:+LEXP>0 LEXVP=+LEXP_";ICPT("
. . S LEXO=LEXCD_"^"_LEXSAN S:$L(LEXVP) LEXO=LEXO_"^"_LEXVP
. . N LEXI I LEXCP>0 S LEXARY(+LEXCS,"P")=LEXO Q
. . S LEXI=$O(LEXARY(+LEXCS," "),-1)+1,LEXARY(+LEXCS,+LEXI)=LEXO
. S LEXSR=$P($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
. S LEXCC(LEXSR,(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
. ; Primary Code Saved - p32
. S:$P($G(^LEX(757.02,LEXSO,0)),"^",7)=1 LEXCC(LEXSR,"P",(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
Q
ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
Q:'$D(LEXCC) "" Q:$O(LEXCC(""))="" "" N LEXSR,LEXST S LEXSR=""
D SHELLY F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
. N LEXSC S LEXSC="",LEXST="("_LEXSR_" "
. ; Primary Code listed first - p32
. I $D(LEXCC(LEXSR,"P")) D
. . N LEXSC S LEXSC=$O(LEXCC(LEXSR,"P",""))
. . S:$L(LEXSC) LEXST=LEXST_$$TRIM(LEXSC)_"/"
. . K LEXCC(LEXSR,"P") K:$L(LEXSC) LEXCC(LEXSR,LEXSC)
. S LEXSC="" F S LEXSC=$O(LEXCC(LEXSR,LEXSC)) Q:LEXSC="" D
. . S LEXST=LEXST_$$TRIM(LEXSC)_"/"
. . K LEXCC(LEXSR,LEXSC)
. S LEXCC(LEXSR)=$E(LEXST,1,($L(LEXST)-1))_")"
S (LEXST,LEXSR)=""
F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
. S LEXST=LEXST_" "_LEXCC(LEXSR)
F Q:$E(LEXST,1)'=" " S LEXST=$E(LEXST,2,$L(LEXST))
S LEXX=LEXST Q LEXX
SHELLY ; Suppress other (non-primary) codes
N LEXSY,LEXCD S LEXSY="" F S LEXSY=$O(LEXCC(LEXSY)) Q:'$L(LEXSY) D
. N LEXPF S LEXPF=$O(LEXCC(LEXSY,"P","")) Q:'$L(LEXPF)
. S LEXCD="" F S LEXCD=$O(LEXCC(LEXSY,LEXCD)) Q:'$L(LEXCD) D
. . Q:LEXCD="P" K:LEXCD'=LEXPF LEXCC(LEXSY,LEXCD)
Q
TRIM(LEXX) ; Trim spaces
F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXASO 7340 printed Dec 13, 2024@02:07:16 Page 2
LEXASO ;ISL/KER - Look-up Display String (Sources) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**25,32,73,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01, SACC 1.3
+5 ; ^LEX(757.02, SACC 1.3
+6 ; ^LEX(757.03, SACC 1.3
+7 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$CODEN^ICDEX ICR 5747
+11 ; $$CSI^ICDEX ICR 5747
+12 ; $$CODEN^ICPTCOD ICR 1995
+13 ;
+14 ; Local Variables NEWed or KILLed Elsewhere
+15 ; LEXSOA Array of Codes
+16 ;
SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
+1 ;
+2 ; Input
+3 ;
+4 ; LEXX IEN of Expression file 757.01
+5 ; LEXSA Source abbreviation string
+6 ; LEXA ALL is a flag
+7 ; 0 - Expression codes only
+8 ; 1 - Concept codes
+9 ; LEXVDT Versioning Date
+10 ;
+11 ; Output
+12 ;
+13 ; $$SO String of Source Codes i.e.,
+14 ; (ICD-9-CM 799.9)
+15 ;
+16 IF +($GET(LEXAFMT))>0
DO SOA^LEXASO(LEXX,$GET(^TMP("LEXSCH",$JOB,"DIS",0)),1,$GET(LEXVDT),.LEXSOA)
QUIT ""
+17 if +($GET(LEXX))=0!('$LENGTH($GET(LEXSA)))
QUIT ""
if '$LENGTH($GET(^LEX(757.01,LEXX,0)))
QUIT ""
+18 NEW LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST
DO VDT^LEXU
+19 SET LEXEX=+LEXX
SET LEXX=""
SET LEXA=+($GET(LEXA))
SET LEXMC=0
+20 SET LEXM=$PIECE($GET(^LEX(757.01,LEXEX,1)),"^",2)
SET LEXST=""
+21 ; Codes for an expression D EXP
+22 IF LEXM'=1!(+($GET(LEXA))=0)
DO EXP
GOTO EXIT
+23 ; Codes for a major concept D MAJ
+24 IF LEXM=1
SET LEXMC=LEXEX
DO MAJ
EXIT ; Clean up and quit
+1 QUIT LEXX
SOA(LEXX,LEXSA,LEXA,LEXVDT,LEXARY) ; Return array of source codes for LEXX SAB
+1 ;
+2 ; Input
+3 ;
+4 ; LEXX IEN of Expression file 757.01
+5 ; LEXSA Source abbreviation string
+6 ; LEXA ALL is a flag
+7 ; 0 - Expression codes only
+8 ; 1 - Concept codes
+9 ; LEXVDT Versioning Date
+10 ; LEXARY Array passed by Reference
+11 ;
+12 ; Output
+13 ;
+14 ; $$SO Success
+15 ; 0 - No codes found
+16 ; 1 - Codes found
+17 ;
+18 ; LEXARY(X) Array of Sources passed by Reference
+19 ;
+20 ; X = Coding System (pointer to 757.03)
+21 ;
+22 ; LEXARY(X,"P") = 3 Piece "^" delimited string
+23 ; 1 Code
+24 ; 2 Coding System the
+25 ; Preferred Term of
+26 ; the code
+27 ; 3 Variable Pointer to
+28 ; a National file if
+29 ; one exist
+30 ;
+31 ; LEXARY(X,###) = 3 Piece "^" delimited string
+32 ; 1 Code
+33 ; 2 Coding System the
+34 ; an expression that is
+35 ; not the Preferred
+36 ; Term for the code
+37 ; 3 Variable Pointer to
+38 ; a National file if
+39 ; one exist
+40 ;
+41 if +($GET(LEXX))=0!('$LENGTH($GET(LEXSA)))
QUIT ""
if '$LENGTH($GET(^LEX(757.01,LEXX,0)))
QUIT ""
+42 NEW LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST,LEXAFMT
DO VDT^LEXU
+43 SET LEXEX=+LEXX
SET LEXX=""
SET LEXA=+($GET(LEXA))
SET LEXMC=0
SET LEXAFMT=1
KILL LEXARY
+44 SET LEXM=$PIECE($GET(^LEX(757.01,LEXEX,1)),"^",2)
SET LEXST=""
+45 ; Codes for an expression D EXP
+46 IF LEXM'=1!(+($GET(LEXA))=0)
DO EXP
GOTO EXIT
+47 ; Codes for a major concept D MAJ
+48 IF LEXM=1
SET LEXMC=LEXEX
DO MAJ
+49 if $ORDER(LEXARY(0))>0
QUIT 1
+50 QUIT 0
EXP ; Source string for an expression
+1 IF LEXSA'["/"
DO CODES(LEXEX,LEXSA,$GET(LEXVDT))
if +($GET(LEXAFMT))'>0
SET LEXX=$$ASSEM
QUIT
+2 IF LEXSA["/"
Begin DoDot:1
+3 NEW LEXC
FOR LEXC=1:1:$LENGTH(LEXSA,"/")
Begin DoDot:2
+4 DO CODES(LEXEX,$PIECE(LEXSA,"/",LEXC),$GET(LEXVDT))
End DoDot:2
End DoDot:1
if +($GET(LEXAFMT))'>0
SET LEXX=$$ASSEM
+5 QUIT
MAJ ; Source string for a major concept
+1 SET LEXMC=$PIECE($GET(^LEX(757.01,LEXEX,1)),"^",1)
SET LEXEX=0
+2 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXEX))
if +LEXEX=0
QUIT
Begin DoDot:1
+3 NEW LEXME
SET LEXME=+($GET(^LEX(757.02,LEXEX,0)))
+4 IF LEXSA'["/"
DO CODES(LEXME,LEXSA,$GET(LEXVDT))
QUIT
+5 IF LEXSA["/"
Begin DoDot:2
+6 NEW LEXC
FOR LEXC=1:1:$LENGTH(LEXSA,"/")
Begin DoDot:3
+7 DO CODES(LEXME,$PIECE(LEXSA,"/",LEXC),$GET(LEXVDT))
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+8 if +($GET(LEXAFMT))'>0
SET LEXX=$$ASSEM
+9 QUIT
CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
+1 if $LENGTH($GET(LEXSA))'=3
QUIT
NEW LEXCD,LEXCN,LEXCP,LEXCS,LEXHE,LEXHI,LEXHN,LEXHS,LEXSAI,LEXSAN,LEXSO,LEXSR,LEXST,LEXSTA
+2 SET LEXST=""
SET LEXSAI=+($ORDER(^LEX(757.03,"ASAB",LEXSA,0)))
if +LEXSAI'>0
QUIT
SET LEXSAN=$PIECE($GET(^LEX(757.03,+LEXSAI,0)),"^",2)
if '$LENGTH(LEXSAN)
QUIT
+3 SET LEXSO=0
FOR
SET LEXSO=$ORDER(^LEX(757.02,"B",LEXEX,LEXSO))
if +LEXSO=0
QUIT
Begin DoDot:1
+4 SET LEXCN=$GET(^LEX(757.02,LEXSO,0))
SET LEXCD=$PIECE(LEXCN,"^",2)
if '$LENGTH(LEXCD)
QUIT
SET LEXCS=$PIECE(LEXCN,"^",3)
if +LEXCS'=+LEXSAI
QUIT
+5 SET LEXCP=$PIECE(LEXCN,"^",5)
SET LEXHE=$SELECT(+LEXVDT>0:(LEXVDT_".99999"),1:" ")
SET LEXHE=$ORDER(^LEX(757.02,+LEXSO,4,"B",LEXHE),-1)
if +LEXHE'>0
QUIT
+6 SET LEXHI=$ORDER(^LEX(757.02,+LEXSO,4,"B",+LEXHE," "),-1)
+7 SET LEXHN=$GET(^LEX(757.02,+LEXSO,4,+LEXHI,0))
SET LEXHS=$PIECE(LEXHN,"^",2)
if +($GET(LEXHS))'>0
QUIT
+8 IF +($GET(LEXAFMT))=1
Begin DoDot:2
+9 NEW LEXI,LEXO,LEXVP
SET LEXVP=""
+10 IF +LEXCS=1!(+LEXCS=30)
Begin DoDot:3
+11 NEW LEXP,LEXS
SET LEXP=$$CODEN^ICDEX(LEXCD,80)
SET LEXS=$$CSI^ICDEX(80,+LEXP)
if +LEXP>0&(LEXS=LEXCS)
SET LEXVP=+LEXP_";ICD9("
End DoDot:3
+12 IF +LEXCS=2!(+LEXCS=31)
Begin DoDot:3
+13 NEW LEXP,LEXS
SET LEXP=$$CODEN^ICDEX(LEXCD,80.1)
SET LEXS=$$CSI^ICDEX(80.1,+LEXP)
if +LEXP>0&(LEXS=LEXCS)
SET LEXVP=+LEXP_";ICD0("
End DoDot:3
+14 IF +LEXCS=3!(+LEXCS=4)
Begin DoDot:3
+15 NEW LEXP
SET LEXP=$$CODEN^ICPTCOD(LEXCD)
if +LEXP>0
SET LEXVP=+LEXP_";ICPT("
End DoDot:3
+16 SET LEXO=LEXCD_"^"_LEXSAN
if $LENGTH(LEXVP)
SET LEXO=LEXO_"^"_LEXVP
+17 NEW LEXI
IF LEXCP>0
SET LEXARY(+LEXCS,"P")=LEXO
QUIT
+18 SET LEXI=$ORDER(LEXARY(+LEXCS," "),-1)+1
SET LEXARY(+LEXCS,+LEXI)=LEXO
End DoDot:2
QUIT
+19 SET LEXSR=$PIECE($GET(^LEX(757.03,$PIECE($GET(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
+20 SET LEXCC(LEXSR,(($PIECE($GET(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
+21 ; Primary Code Saved - p32
+22 if $PIECE($GET(^LEX(757.02,LEXSO,0)),"^",7)=1
SET LEXCC(LEXSR,"P",(($PIECE($GET(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
End DoDot:1
+23 QUIT
ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
+1 if '$DATA(LEXCC)
QUIT ""
if $ORDER(LEXCC(""))=""
QUIT ""
NEW LEXSR,LEXST
SET LEXSR=""
+2 DO SHELLY
FOR
SET LEXSR=$ORDER(LEXCC(LEXSR))
if LEXSR=""
QUIT
Begin DoDot:1
+3 NEW LEXSC
SET LEXSC=""
SET LEXST="("_LEXSR_" "
+4 ; Primary Code listed first - p32
+5 IF $DATA(LEXCC(LEXSR,"P"))
Begin DoDot:2
+6 NEW LEXSC
SET LEXSC=$ORDER(LEXCC(LEXSR,"P",""))
+7 if $LENGTH(LEXSC)
SET LEXST=LEXST_$$TRIM(LEXSC)_"/"
+8 KILL LEXCC(LEXSR,"P")
if $LENGTH(LEXSC)
KILL LEXCC(LEXSR,LEXSC)
End DoDot:2
+9 SET LEXSC=""
FOR
SET LEXSC=$ORDER(LEXCC(LEXSR,LEXSC))
if LEXSC=""
QUIT
Begin DoDot:2
+10 SET LEXST=LEXST_$$TRIM(LEXSC)_"/"
+11 KILL LEXCC(LEXSR,LEXSC)
End DoDot:2
+12 SET LEXCC(LEXSR)=$EXTRACT(LEXST,1,($LENGTH(LEXST)-1))_")"
End DoDot:1
+13 SET (LEXST,LEXSR)=""
+14 FOR
SET LEXSR=$ORDER(LEXCC(LEXSR))
if LEXSR=""
QUIT
Begin DoDot:1
+15 SET LEXST=LEXST_" "_LEXCC(LEXSR)
End DoDot:1
+16 FOR
if $EXTRACT(LEXST,1)'=" "
QUIT
SET LEXST=$EXTRACT(LEXST,2,$LENGTH(LEXST))
+17 SET LEXX=LEXST
QUIT LEXX
SHELLY ; Suppress other (non-primary) codes
+1 NEW LEXSY,LEXCD
SET LEXSY=""
FOR
SET LEXSY=$ORDER(LEXCC(LEXSY))
if '$LENGTH(LEXSY)
QUIT
Begin DoDot:1
+2 NEW LEXPF
SET LEXPF=$ORDER(LEXCC(LEXSY,"P",""))
if '$LENGTH(LEXPF)
QUIT
+3 SET LEXCD=""
FOR
SET LEXCD=$ORDER(LEXCC(LEXSY,LEXCD))
if '$LENGTH(LEXCD)
QUIT
Begin DoDot:2
+4 if LEXCD="P"
QUIT
if LEXCD'=LEXPF
KILL LEXCC(LEXSY,LEXCD)
End DoDot:2
End DoDot:1
+5 QUIT
TRIM(LEXX) ; Trim spaces
+1 FOR
if $EXTRACT(LEXX,1)'=" "
QUIT
SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
+2 FOR
if $EXTRACT(LEXX,$LENGTH(LEXX))'=" "
QUIT
SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))
+3 QUIT LEXX
