SROICDL ;ALB/SJA - Select ICD DIAGNOSIS FROM LIXICON UTILITY LIST ;12/07/2011
;;3.0;Surgery;**177**;24 Jun 93;Build 89
;
SEL(SRL,X) ; Select from List
;
;
; Input
;
; X Length of list to display (default 5)
; .SRL Local array passed by reference
;
; SRL() Input Array from ICDSRCH^LEX10CS
;
; SRL(0)=# found ^ Pruning Indicator
; SRL(1,0)=Code ^ Code IEN ^ date
; SRL(1,"IDL")=ICD-9/10 Description, Long
; SRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; SRL(1,"IDS")=ICD-9/10 Description, Short
; SRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; SRL(1,"LEX")=Lexicon Description
; SRL(1,"LEX",1)=Expression IEN ^ date
; SRL(1,"SYN",1)=Synonym #1
; SRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; SRL Local array passed by reference
;
; SRL(0)=Code ^ Code IEN ^ date
; SRL("IDL")=ICD-9/10 Description, Long
; SRL("IDL",1)=ICD-9/10 IEN ^ date
; SRL("IDS")=ICD-9/10 Description, Short
; SRL("IDS",1)=ICD-9/10 IEN ^ date
; SRL("LEX")=Lexicon Description
; SRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
;
S X=+($G(X)) S:X'>0 X=5 S X=$$ASK(.SRL,X)
Q X
ASK(SRL,X) ; Ask for Selection
N SRLIT,SRLL,SRLTOT S SRLL=+($G(X)) S:SRLL'>0 SRLL=5
S SRLIT=0,SRLTOT=$O(SRL(" "),-1) Q:+SRLTOT'>0 "^"
K X S:+SRLTOT=1 X=$$ONE(SRLL,.SRL) S:+SRLTOT>1 X=$$MUL(.SRL,SRLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,SRL) ; One Entry Found
Q:+($G(SRLIT))>0 "^^" N Z,DIR,SRLC,SRLEX,SRLFI,SRLIT,SRLSO,SRLNC
N SRLSP,SRLTX,SRLC,Y S SRLFI=$O(SRL(0)) Q:+SRLFI'>0 "^"
S SRLSP=$J(" ",11)
S SRLSO=$P(SRL(1,0),"^",1),SRLNC=$P(SRL(1,0),"^",3)
S:+SRLNC>0 SRLNC=" ("_SRLNC_")" S SRLEX=$G(SRL(1,"MENU"))
S SRLC=$S($D(SRL(1,"CAT")):"-",1:"")
S SRLTX(1)=SRLSO_SRLC_$J(" ",(9-$L(SRLSO)))_" "_SRLEX_SRLNC
;
D PR(.SRLTX,64)
S DIR("A",1)=" One code found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(SRLTX(1))
S SRLC=3
F Z=2:1 Q:$G(SRLTX(Z))="" S SRLC=SRLC+1,DIR("A",SRLC)=SRLSP_$G(SRLTX(Z))
S SRLC=SRLC+1
S DIR("A",SRLC)=" "
S SRLC=SRLC+1
;
S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) SRLIT=1
I X["^^"!(+($G(SRLIT))>0) K SRL Q "^^"
S X=$S(+Y>0:$$X(1,.SRL),1:-1)
I X>0 S SRZZONE=1
Q X
MUL(SRL,Y) ; Multiple Entries Found
Q:+($G(SRLIT))>0 "^^" N SRLE,SRLL,SRLMAX,SRLSS,SRLX,X
S (SRLMAX,SRLSS,SRLIT)=0,SRLL=+($G(Y)),U="^" S:+($G(SRLL))'>0 SRLL=5
S SRLX=$O(SRL(" "),-1),SRLSS=0
G:+SRLX=0 MULQ W ! W:+SRLX>1 !," ",SRLX," matches found"
F SRLE=1:1:SRLX Q:((SRLSS>0)&(SRLSS<(SRLE+1))) Q:SRLIT D Q:SRLIT
. W:SRLE#SRLL=1 ! D MULW
. S SRLMAX=SRLE W:SRLE#SRLL=0 !
. S:SRLE#SRLL=0 SRLSS=$$MULS(SRLMAX,SRLE,.SRL) S:SRLSS["^" SRLIT=1
I SRLE#SRLL'=0,+SRLSS<=0 D
. W ! S SRLSS=$$MULS(SRLMAX,SRLE,.SRL) S:SRLSS["^" SRLIT=1
G MULQ
Q X
MULW ; Write Multiple
N SRLEX,SRLI,SRLSO,SRLNC,SRLT,SRLTX S SRLSO=$P(SRL(+SRLE,0),"^",1)
S SRLNC=$P(SRL(+SRLE,0),"^",3) S:+SRLNC>0 SRLNC=" ("_SRLNC_")"
S SRLEX=$G(SRL(+SRLE,"MENU")),SRLTX(1)=SRLSO
S SRLTX(1)=SRLTX(1)_$S($D(SRL(+SRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(SRLSO)))_" "_SRLEX_SRLNC
D PR(.SRLTX,60) W !,$J(SRLE,5),". ",$G(SRLTX(1))
F SRLI=2:1:5 S SRLT=$G(SRLTX(SRLI)) W:$L(SRLT) !,$J(" ",19),SRLT
Q
MULS(X,Y,SRL) ; Select from Multiple Entries
N DIR,DIRB,SRLFI,SRLHLP,SRLLAST,SRLMAX,SRLS
Q:+($G(SRLIT))>0 "^^" S SRLMAX=+($G(X)),SRLLAST=+($G(Y))
Q:SRLMAX=0 -1 S SRLFI=$O(SRL(0)) Q:+SRLFI'>0 -1
I +($O(SRL(+SRLLAST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_SRLMAX_": "
I +($O(SRL(+SRLLAST)))'>0 D
. S DIR("A")=" Select 1-"_SRLMAX_": "
S SRLHLP=" Answer must be from 1 to "
S SRLHLP=SRLHLP_SRLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^SROICDL"
S DIR(0)="NAO^1:"_SRLMAX_":0" D ^DIR
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) SRLIT=1,X="^^" I X["^^"!(+($G(SRLIT))>0) Q "^^"
K DIR Q:$D(DTOUT)!(X[U) "^^"
Q $S(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
I $L($G(SRLHLP)) W !,$G(SRLHLP) Q
Q
MULQ ; Quit Multiple
I +SRLSS'>0,$G(SRLSS)="^" Q "^"
S X=-1 S:+($G(SRLIT))'>0 X=$$X(+SRLSS,.SRL)
Q X
X(X,SRL) ; Set X and Outpot Array
N SRLEX,SRFI,SRLIEN,SRLN,SRLNC,SRLNN,SRLRN,SRLS,SRLSO
S SRLS=+($G(X)) S SRFI=$O(SRL(0))
S SRLSO=$P($G(SRL(SRLS,0)),"^",1),SRLEX=$G(SRL(SRLS,"MENU"))
;
S SRLIEN=$S($D(SRL(SRLS,"CAT")):"99:CAT;"_$P($G(SRL(SRLS,0)),"^"),1:$P($G(SRL(SRLS,"IDS",1)),"^")_";"_$P($G(SRL(SRLS,0)),"^")_";"_$P($G(SRL(SRLS,"LEX",1)),"^")) Q:'$L(SRLSO) "^"
;
Q:'$L(SRLEX) "^" Q:+SRLIEN'>0 "^" S X=SRLIEN_"^"_SRLEX
S SRLNN="SRL("_+SRLS_")",SRLNC="SRL("_+SRLS_","
F S SRLNN=$Q(@SRLNN) Q:'$L(SRLNN)!(SRLNN'[SRLNC) D
. S SRLRN="SRLN("_$P(SRLNN,"(",2,299) S @SRLRN=@SRLNN
K SRL S SRLNN="SRLN("_+SRLS_")",SRLNC="SRLN("_+SRLS_","
F S SRLNN=$Q(@SRLNN) Q:'$L(SRLNN)!(SRLNN'[SRLNC) D
. S SRLRN="SRL("_$P(SRLNN,"(",2,299),@SRLRN=@SRLNN
Q X
;
; Miscellaneous
CL ; Clear
K SRLIT
Q
PR(SRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,SRLC,SRLI,SRLL
K ^UTILITY($J,"W") Q:'$D(SRL) S SRLL=+($G(X)) S:+SRLL'>0 SRLL=79
S SRLC=+($G(SRL)) S:+($G(SRLC))'>0 SRLC=$O(SRL(" "),-1) Q:+SRLC'>0
S DIWL=1,DIWF="C"_+SRLL S SRLI=0
F S SRLI=$O(SRL(SRLI)) Q:+SRLI=0 S X=$G(SRL(SRLI)) D ^DIWP
K SRL S (SRLC,SRLI)=0
F S SRLI=$O(^UTILITY($J,"W",1,SRLI)) Q:+SRLI=0 D
. S SRL(SRLI)=$$TM($G(^UTILITY($J,"W",1,SRLI,0))," "),SRLC=SRLC+1
S:$L(SRLC) SRL=SRLC K ^UTILITY($J,"W")
Q
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[HSROICDL 6363 printed Dec 13, 2024@02:43:55 Page 2
SROICDL ;ALB/SJA - Select ICD DIAGNOSIS FROM LIXICON UTILITY LIST ;12/07/2011
+1 ;;3.0;Surgery;**177**;24 Jun 93;Build 89
+2 ;
SEL(SRL,X) ; Select from List
+1 ;
+2 ;
+3 ; Input
+4 ;
+5 ; X Length of list to display (default 5)
+6 ; .SRL Local array passed by reference
+7 ;
+8 ; SRL() Input Array from ICDSRCH^LEX10CS
+9 ;
+10 ; SRL(0)=# found ^ Pruning Indicator
+11 ; SRL(1,0)=Code ^ Code IEN ^ date
+12 ; SRL(1,"IDL")=ICD-9/10 Description, Long
+13 ; SRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+14 ; SRL(1,"IDS")=ICD-9/10 Description, Short
+15 ; SRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+16 ; SRL(1,"LEX")=Lexicon Description
+17 ; SRL(1,"LEX",1)=Expression IEN ^ date
+18 ; SRL(1,"SYN",1)=Synonym #1
+19 ; SRL(1,"SYN",m)=Synonym #m
+20 ; ...
+21 ;
+22 ; Output
+23 ;
+24 ; $$SEL Two Piece "^" delimited string same as
+25 ; Fileman's Y output variable
+26 ;
+27 ; 1 Lexicon IEN
+28 ; 2 Lexicon Term
+29 ;
+30 ; SRL Local array passed by reference
+31 ;
+32 ; SRL(0)=Code ^ Code IEN ^ date
+33 ; SRL("IDL")=ICD-9/10 Description, Long
+34 ; SRL("IDL",1)=ICD-9/10 IEN ^ date
+35 ; SRL("IDS")=ICD-9/10 Description, Short
+36 ; SRL("IDS",1)=ICD-9/10 IEN ^ date
+37 ; SRL("LEX")=Lexicon Description
+38 ; SRL("LEX",1)=Expression IEN ^ date
+39 ;
+40 ; or ^ on error
+41 ; or -1 for non-selection
+42 ;
+43 SET X=+($GET(X))
if X'>0
SET X=5
SET X=$$ASK(.SRL,X)
+44 QUIT X
ASK(SRL,X) ; Ask for Selection
+1 NEW SRLIT,SRLL,SRLTOT
SET SRLL=+($GET(X))
if SRLL'>0
SET SRLL=5
+2 SET SRLIT=0
SET SRLTOT=$ORDER(SRL(" "),-1)
if +SRLTOT'>0
QUIT "^"
+3 KILL X
if +SRLTOT=1
SET X=$$ONE(SRLL,.SRL)
if +SRLTOT>1
SET X=$$MUL(.SRL,SRLL)
+4 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+5 QUIT X
ONE(X,SRL) ; One Entry Found
+1 if +($GET(SRLIT))>0
QUIT "^^"
NEW Z,DIR,SRLC,SRLEX,SRLFI,SRLIT,SRLSO,SRLNC
+2 NEW SRLSP,SRLTX,SRLC,Y
SET SRLFI=$ORDER(SRL(0))
if +SRLFI'>0
QUIT "^"
+3 SET SRLSP=$JUSTIFY(" ",11)
+4 SET SRLSO=$PIECE(SRL(1,0),"^",1)
SET SRLNC=$PIECE(SRL(1,0),"^",3)
+5 if +SRLNC>0
SET SRLNC=" ("_SRLNC_")"
SET SRLEX=$GET(SRL(1,"MENU"))
+6 SET SRLC=$SELECT($DATA(SRL(1,"CAT")):"-",1:"")
+7 SET SRLTX(1)=SRLSO_SRLC_$JUSTIFY(" ",(9-$LENGTH(SRLSO)))_" "_SRLEX_SRLNC
+8 ;
+9 DO PR(.SRLTX,64)
+10 SET DIR("A",1)=" One code found"
SET DIR("A",2)=" "
+11 SET DIR("A",3)=" "_$GET(SRLTX(1))
+12 SET SRLC=3
+13 FOR Z=2:1
if $GET(SRLTX(Z))=""
QUIT
SET SRLC=SRLC+1
SET DIR("A",SRLC)=SRLSP_$GET(SRLTX(Z))
+14 SET SRLC=SRLC+1
+15 SET DIR("A",SRLC)=" "
+16 SET SRLC=SRLC+1
+17 ;
+18 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+19 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+20 if X["^^"!($DATA(DTOUT))
SET SRLIT=1
+21 IF X["^^"!(+($GET(SRLIT))>0)
KILL SRL
QUIT "^^"
+22 SET X=$SELECT(+Y>0:$$X(1,.SRL),1:-1)
+23 IF X>0
SET SRZZONE=1
+24 QUIT X
MUL(SRL,Y) ; Multiple Entries Found
+1 if +($GET(SRLIT))>0
QUIT "^^"
NEW SRLE,SRLL,SRLMAX,SRLSS,SRLX,X
+2 SET (SRLMAX,SRLSS,SRLIT)=0
SET SRLL=+($GET(Y))
SET U="^"
if +($GET(SRLL))'>0
SET SRLL=5
+3 SET SRLX=$ORDER(SRL(" "),-1)
SET SRLSS=0
+4 if +SRLX=0
GOTO MULQ
WRITE !
if +SRLX>1
WRITE !," ",SRLX," matches found"
+5 FOR SRLE=1:1:SRLX
if ((SRLSS>0)&(SRLSS<(SRLE+1)))
QUIT
if SRLIT
QUIT
Begin DoDot:1
+6 if SRLE#SRLL=1
WRITE !
DO MULW
+7 SET SRLMAX=SRLE
if SRLE#SRLL=0
WRITE !
+8 if SRLE#SRLL=0
SET SRLSS=$$MULS(SRLMAX,SRLE,.SRL)
if SRLSS["^"
SET SRLIT=1
End DoDot:1
if SRLIT
QUIT
+9 IF SRLE#SRLL'=0
IF +SRLSS<=0
Begin DoDot:1
+10 WRITE !
SET SRLSS=$$MULS(SRLMAX,SRLE,.SRL)
if SRLSS["^"
SET SRLIT=1
End DoDot:1
+11 GOTO MULQ
+12 QUIT X
MULW ; Write Multiple
+1 NEW SRLEX,SRLI,SRLSO,SRLNC,SRLT,SRLTX
SET SRLSO=$PIECE(SRL(+SRLE,0),"^",1)
+2 SET SRLNC=$PIECE(SRL(+SRLE,0),"^",3)
if +SRLNC>0
SET SRLNC=" ("_SRLNC_")"
+3 SET SRLEX=$GET(SRL(+SRLE,"MENU"))
SET SRLTX(1)=SRLSO
+4 SET SRLTX(1)=SRLTX(1)_$SELECT($DATA(SRL(+SRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(SRLSO)))_" "_SRLEX_SRLNC
+5 DO PR(.SRLTX,60)
WRITE !,$JUSTIFY(SRLE,5),". ",$GET(SRLTX(1))
+6 FOR SRLI=2:1:5
SET SRLT=$GET(SRLTX(SRLI))
if $LENGTH(SRLT)
WRITE !,$JUSTIFY(" ",19),SRLT
+7 QUIT
MULS(X,Y,SRL) ; Select from Multiple Entries
+1 NEW DIR,DIRB,SRLFI,SRLHLP,SRLLAST,SRLMAX,SRLS
+2 if +($GET(SRLIT))>0
QUIT "^^"
SET SRLMAX=+($GET(X))
SET SRLLAST=+($GET(Y))
+3 if SRLMAX=0
QUIT -1
SET SRLFI=$ORDER(SRL(0))
if +SRLFI'>0
QUIT -1
+4 IF +($ORDER(SRL(+SRLLAST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_SRLMAX_": "
End DoDot:1
+7 IF +($ORDER(SRL(+SRLLAST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_SRLMAX_": "
End DoDot:1
+9 SET SRLHLP=" Answer must be from 1 to "
+10 SET SRLHLP=SRLHLP_SRLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^SROICDL"
+13 SET DIR(0)="NAO^1:"_SRLMAX_":0"
DO ^DIR
+14 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 if X["^^"!($DATA(DTOUT))
SET SRLIT=1
SET X="^^"
IF X["^^"!(+($GET(SRLIT))>0)
QUIT "^^"
+16 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^^"
+17 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(SRLHLP))
WRITE !,$GET(SRLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +SRLSS'>0
IF $GET(SRLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(SRLIT))'>0
SET X=$$X(+SRLSS,.SRL)
+3 QUIT X
X(X,SRL) ; Set X and Outpot Array
+1 NEW SRLEX,SRFI,SRLIEN,SRLN,SRLNC,SRLNN,SRLRN,SRLS,SRLSO
+2 SET SRLS=+($GET(X))
SET SRFI=$ORDER(SRL(0))
+3 SET SRLSO=$PIECE($GET(SRL(SRLS,0)),"^",1)
SET SRLEX=$GET(SRL(SRLS,"MENU"))
+4 ;
+5 SET SRLIEN=$SELECT($DATA(SRL(SRLS,"CAT")):"99:CAT;"_$PIECE($GET(SRL(SRLS,0)),"^"),1:$PIECE($GET(SRL(SRLS,"IDS",1)),"^")_";"_$PIECE($GET(SRL(SRLS,0)),"^")_";"_$PIECE($GET(SRL(SRLS,"LEX",1)),"^"))
if '$LENGTH(SRLSO)
QUIT "^"
+6 ;
+7 if '$LENGTH(SRLEX)
QUIT "^"
if +SRLIEN'>0
QUIT "^"
SET X=SRLIEN_"^"_SRLEX
+8 SET SRLNN="SRL("_+SRLS_")"
SET SRLNC="SRL("_+SRLS_","
+9 FOR
SET SRLNN=$QUERY(@SRLNN)
if '$LENGTH(SRLNN)!(SRLNN'[SRLNC)
QUIT
Begin DoDot:1
+10 SET SRLRN="SRLN("_$PIECE(SRLNN,"(",2,299)
SET @SRLRN=@SRLNN
End DoDot:1
+11 KILL SRL
SET SRLNN="SRLN("_+SRLS_")"
SET SRLNC="SRLN("_+SRLS_","
+12 FOR
SET SRLNN=$QUERY(@SRLNN)
if '$LENGTH(SRLNN)!(SRLNN'[SRLNC)
QUIT
Begin DoDot:1
+13 SET SRLRN="SRL("_$PIECE(SRLNN,"(",2,299)
SET @SRLRN=@SRLNN
End DoDot:1
+14 QUIT X
+15 ;
+16 ; Miscellaneous
CL ; Clear
+1 KILL SRLIT
+2 QUIT
PR(SRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,SRLC,SRLI,SRLL
+2 KILL ^UTILITY($JOB,"W")
if '$DATA(SRL)
QUIT
SET SRLL=+($GET(X))
if +SRLL'>0
SET SRLL=79
+3 SET SRLC=+($GET(SRL))
if +($GET(SRLC))'>0
SET SRLC=$ORDER(SRL(" "),-1)
if +SRLC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+SRLL
SET SRLI=0
+5 FOR
SET SRLI=$ORDER(SRL(SRLI))
if +SRLI=0
QUIT
SET X=$GET(SRL(SRLI))
DO ^DIWP
+6 KILL SRL
SET (SRLC,SRLI)=0
+7 FOR
SET SRLI=$ORDER(^UTILITY($JOB,"W",1,SRLI))
if +SRLI=0
QUIT
Begin DoDot:1
+8 SET SRL(SRLI)=$$TM($GET(^UTILITY($JOB,"W",1,SRLI,0))," ")
SET SRLC=SRLC+1
End DoDot:1
+9 if $LENGTH(SRLC)
SET SRL=SRLC
KILL ^UTILITY($JOB,"W")
+10 QUIT
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
