DGICDL ;ALB/SJA - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
;;5.3;Registration;**850**;Aug 13, 1993;Build 171
; Clone of SROICDL
SEL(DGL,X) ; Select from List
;
;
; Input
;
; X Length of list to display (default 5)
; .DGL Local array passed by reference
;
; DGL() Input Array from ICDSRCH^LEX10CS
;
; DGL(0)=# found ^ Pruning Indicator
; DGL(1,0)=Code ^ Code IEN ^ date
; DGL(1,"IDL")=ICD-9/10 Description, Long
; DGL(1,"IDL",1)=ICD-9/10 IEN ^ date
; DGL(1,"IDS")=ICD-9/10 Description, Short
; DGL(1,"IDS",1)=ICD-9/10 IEN ^ date
; DGL(1,"LEX")=Lexicon Description
; DGL(1,"LEX",1)=Expression IEN ^ date
; DGL(1,"SYN",1)=Synonym #1
; DGL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; DGL Local array passed by reference
;
; DGL(0)=Code ^ Code IEN ^ date
; DGL("IDL")=ICD-9/10 Description, Long
; DGL("IDL",1)=ICD-9/10 IEN ^ date
; DGL("IDS")=ICD-9/10 Description, Short
; DGL("IDS",1)=ICD-9/10 IEN ^ date
; DGL("LEX")=Lexicon Description
; DGL("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(.DGL,X)
Q X
ASK(DGL,X) ; Ask for Selection
N DGLIT,DGLL,DGLTOT S DGLL=+($G(X)) S:DGLL'>0 DGLL=5
S DGLIT=0,DGLTOT=$O(DGL(" "),-1) Q:+DGLTOT'>0 "^"
K X S:+DGLTOT=1 X=$$ONE(DGLL,.DGL) S:+DGLTOT>1 X=$$MUL(.DGL,DGLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,DGL) ; One Entry Found
Q:+($G(DGLIT))>0 "^^" N Z,DIR,DGLC,DGLEX,DGLFI,DGLIT,DGLSO,DGLNC
N DGLSP,DGLTX,DGLC,Y S DGLFI=$O(DGL(0)) Q:+DGLFI'>0 "^" S DGLSP=$J(" ",11)
S DGLSO=$P(DGL(1,0),"^",1),DGLNC=$P(DGL(1,0),"^",3)
S:+DGLNC>0 DGLNC=" ("_DGLNC_")" S DGLEX=$G(DGL(1,"MENU"))
S DGLC=$S($D(DGL(1,"CAT")):"-",1:"")
S DGLTX(1)=DGLSO_DGLC_$J(" ",(9-$L(DGLSO)))_" "_DGLEX_DGLNC
D PR(.DGLTX,64) S DIR("A",1)=" One code found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(DGLTX(1)),DGLC=3
F Z=2:1 Q:$G(DGLTX(Z))="" S DGLC=DGLC+1,DIR("A",DGLC)=DGLSP_$G(DGLTX(Z))
S DGLC=DGLC+1,DIR("A",DGLC)=" ",DGLC=DGLC+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)) DGLIT=1
I X["^^"!(+($G(DGLIT))>0) K DGL Q "^^"
S X=$S(+Y>0:$$X(1,.DGL),1:-1)
I X>0 S DGZZONE=1
Q X
MUL(DGL,Y) ; Multiple Entries Found
Q:+($G(DGLIT))>0 "^^" N DGLE,DGLL,DGLMAX,DGLSS,DGLX,X
S (DGLMAX,DGLSS,DGLIT)=0,DGLL=+($G(Y)),U="^" S:+($G(DGLL))'>0 DGLL=5
S DGLX=$O(DGL(" "),-1),DGLSS=0
G:+DGLX=0 MULQ W ! W:+DGLX>1 !," ",DGLX," matches found"
F DGLE=1:1:DGLX Q:((DGLSS>0)&(DGLSS<(DGLE+1))) Q:DGLIT D Q:DGLIT
. W:DGLE#DGLL=1 ! D MULW
. S DGLMAX=DGLE W:DGLE#DGLL=0 !
. S:DGLE#DGLL=0 DGLSS=$$MULS(DGLMAX,DGLE,.DGL) S:DGLSS["^" DGLIT=1
I DGLE#DGLL'=0,+DGLSS<=0 D
. W ! S DGLSS=$$MULS(DGLMAX,DGLE,.DGL) S:DGLSS["^" DGLIT=1
G MULQ
Q X
MULW ; Write Multiple
N DGLEX,DGLI,DGLSO,DGLNC,DGLT,DGLTX S DGLSO=$P(DGL(+DGLE,0),"^",1)
S DGLNC=$P(DGL(+DGLE,0),"^",3) S:+DGLNC>0 DGLNC=" ("_DGLNC_")"
S DGLEX=$G(DGL(+DGLE,"MENU")),DGLTX(1)=DGLSO
S DGLTX(1)=DGLTX(1)_$S($D(DGL(+DGLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(DGLSO)))_" "_DGLEX_DGLNC
D PR(.DGLTX,60) W !,$J(DGLE,5),". ",$G(DGLTX(1))
F DGLI=2:1:5 S DGLT=$G(DGLTX(DGLI)) W:$L(DGLT) !,$J(" ",19),DGLT
Q
MULS(X,Y,DGL) ; Select from Multiple Entries
N DIR,DIRB,DGLFI,DGLHLP,DGLLAST,DGLMAX,DGLS
Q:+($G(DGLIT))>0 "^^" S DGLMAX=+($G(X)),DGLLAST=+($G(Y))
Q:DGLMAX=0 -1 S DGLFI=$O(DGL(0)) Q:+DGLFI'>0 -1
I +($O(DGL(+DGLLAST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_DGLMAX_": "
I +($O(DGL(+DGLLAST)))'>0 D
. S DIR("A")=" Select 1-"_DGLMAX_": "
S DGLHLP=" Answer must be from 1 to "
S DGLHLP=DGLHLP_DGLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^DGICDL"
S DIR(0)="NAO^1:"_DGLMAX_":0" D ^DIR
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) DGLIT=1,X="^^" I X["^^"!(+($G(DGLIT))>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(DGLHLP)) W !,$G(DGLHLP) Q
Q
MULQ ; Quit Multiple
I +DGLSS'>0,$G(DGLSS)="^" Q "^"
S X=-1 S:+($G(DGLIT))'>0 X=$$X(+DGLSS,.DGL)
Q X
X(X,DGL) ; Set X and Output Array
N DGLEX,DGLIEN,DGLN,DGLNC,DGLNN,DGLRN,DGLS,DGLSO
S DGLS=+($G(X))
S DGLSO=$P($G(DGL(DGLS,0)),"^",1),DGLEX=$G(DGL(DGLS,"MENU"))
S DGLIEN=$S($D(DGL(DGLS,"CAT")):"99:CAT;"_$P($G(DGL(DGLS,0)),"^"),1:$P($G(DGL(DGLS,"IDS",1)),"^")_";"_$P($G(DGL(DGLS,0)),"^")_";"_$P($G(DGL(DGLS,"LEX",1)),"^")) Q:'$L(DGLSO) "^"
Q:'$L(DGLEX) "^" Q:+DGLIEN'>0 "^" S X=DGLIEN_"^"_DGLEX
S DGLNN="DGL("_+DGLS_")",DGLNC="DGL("_+DGLS_","
F S DGLNN=$Q(@DGLNN) Q:'$L(DGLNN)!(DGLNN'[DGLNC) D
. S DGLRN="DGLN("_$P(DGLNN,"(",2,299) S @DGLRN=@DGLNN
K DGL S DGLNN="DGLN("_+DGLS_")",DGLNC="DGLN("_+DGLS_","
F S DGLNN=$Q(@DGLNN) Q:'$L(DGLNN)!(DGLNN'[DGLNC) D
. S DGLRN="DGL("_$P(DGLNN,"(",2,299),@DGLRN=@DGLNN
Q X
;
; Miscellaneous
CL ; Clear
K DGLIT
Q
PR(DGL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,DGLC,DGLI,DGLL
K ^UTILITY($J,"W") Q:'$D(DGL) S DGLL=+($G(X)) S:+DGLL'>0 DGLL=79
S DGLC=+($G(DGL)) S:+($G(DGLC))'>0 DGLC=$O(DGL(" "),-1) Q:+DGLC'>0
S DIWL=1,DIWF="C"_+DGLL S DGLI=0
F S DGLI=$O(DGL(DGLI)) Q:+DGLI=0 S X=$G(DGL(DGLI)) D ^DIWP
K DGL S (DGLC,DGLI)=0
F S DGLI=$O(^UTILITY($J,"W",1,DGLI)) Q:+DGLI=0 D
. S DGL(DGLI)=$$TM($G(^UTILITY($J,"W",1,DGLI,0))," "),DGLC=DGLC+1
S:$L(DGLC) DGL=DGLC 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[HDGICDL 6333 printed Sep 23, 2025@20:19:45 Page 2
DGICDL ;ALB/SJA - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
+1 ;;5.3;Registration;**850**;Aug 13, 1993;Build 171
+2 ; Clone of SROICDL
SEL(DGL,X) ; Select from List
+1 ;
+2 ;
+3 ; Input
+4 ;
+5 ; X Length of list to display (default 5)
+6 ; .DGL Local array passed by reference
+7 ;
+8 ; DGL() Input Array from ICDSRCH^LEX10CS
+9 ;
+10 ; DGL(0)=# found ^ Pruning Indicator
+11 ; DGL(1,0)=Code ^ Code IEN ^ date
+12 ; DGL(1,"IDL")=ICD-9/10 Description, Long
+13 ; DGL(1,"IDL",1)=ICD-9/10 IEN ^ date
+14 ; DGL(1,"IDS")=ICD-9/10 Description, Short
+15 ; DGL(1,"IDS",1)=ICD-9/10 IEN ^ date
+16 ; DGL(1,"LEX")=Lexicon Description
+17 ; DGL(1,"LEX",1)=Expression IEN ^ date
+18 ; DGL(1,"SYN",1)=Synonym #1
+19 ; DGL(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 ; DGL Local array passed by reference
+31 ;
+32 ; DGL(0)=Code ^ Code IEN ^ date
+33 ; DGL("IDL")=ICD-9/10 Description, Long
+34 ; DGL("IDL",1)=ICD-9/10 IEN ^ date
+35 ; DGL("IDS")=ICD-9/10 Description, Short
+36 ; DGL("IDS",1)=ICD-9/10 IEN ^ date
+37 ; DGL("LEX")=Lexicon Description
+38 ; DGL("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(.DGL,X)
+44 QUIT X
ASK(DGL,X) ; Ask for Selection
+1 NEW DGLIT,DGLL,DGLTOT
SET DGLL=+($GET(X))
if DGLL'>0
SET DGLL=5
+2 SET DGLIT=0
SET DGLTOT=$ORDER(DGL(" "),-1)
if +DGLTOT'>0
QUIT "^"
+3 KILL X
if +DGLTOT=1
SET X=$$ONE(DGLL,.DGL)
if +DGLTOT>1
SET X=$$MUL(.DGL,DGLL)
+4 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+5 QUIT X
ONE(X,DGL) ; One Entry Found
+1 if +($GET(DGLIT))>0
QUIT "^^"
NEW Z,DIR,DGLC,DGLEX,DGLFI,DGLIT,DGLSO,DGLNC
+2 NEW DGLSP,DGLTX,DGLC,Y
SET DGLFI=$ORDER(DGL(0))
if +DGLFI'>0
QUIT "^"
SET DGLSP=$JUSTIFY(" ",11)
+3 SET DGLSO=$PIECE(DGL(1,0),"^",1)
SET DGLNC=$PIECE(DGL(1,0),"^",3)
+4 if +DGLNC>0
SET DGLNC=" ("_DGLNC_")"
SET DGLEX=$GET(DGL(1,"MENU"))
+5 SET DGLC=$SELECT($DATA(DGL(1,"CAT")):"-",1:"")
+6 SET DGLTX(1)=DGLSO_DGLC_$JUSTIFY(" ",(9-$LENGTH(DGLSO)))_" "_DGLEX_DGLNC
+7 DO PR(.DGLTX,64)
SET DIR("A",1)=" One code found"
SET DIR("A",2)=" "
+8 SET DIR("A",3)=" "_$GET(DGLTX(1))
SET DGLC=3
+9 FOR Z=2:1
if $GET(DGLTX(Z))=""
QUIT
SET DGLC=DGLC+1
SET DIR("A",DGLC)=DGLSP_$GET(DGLTX(Z))
+10 SET DGLC=DGLC+1
SET DIR("A",DGLC)=" "
SET DGLC=DGLC+1
+11 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+12 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+13 if X["^^"!($DATA(DTOUT))
SET DGLIT=1
+14 IF X["^^"!(+($GET(DGLIT))>0)
KILL DGL
QUIT "^^"
+15 SET X=$SELECT(+Y>0:$$X(1,.DGL),1:-1)
+16 IF X>0
SET DGZZONE=1
+17 QUIT X
MUL(DGL,Y) ; Multiple Entries Found
+1 if +($GET(DGLIT))>0
QUIT "^^"
NEW DGLE,DGLL,DGLMAX,DGLSS,DGLX,X
+2 SET (DGLMAX,DGLSS,DGLIT)=0
SET DGLL=+($GET(Y))
SET U="^"
if +($GET(DGLL))'>0
SET DGLL=5
+3 SET DGLX=$ORDER(DGL(" "),-1)
SET DGLSS=0
+4 if +DGLX=0
GOTO MULQ
WRITE !
if +DGLX>1
WRITE !," ",DGLX," matches found"
+5 FOR DGLE=1:1:DGLX
if ((DGLSS>0)&(DGLSS<(DGLE+1)))
QUIT
if DGLIT
QUIT
Begin DoDot:1
+6 if DGLE#DGLL=1
WRITE !
DO MULW
+7 SET DGLMAX=DGLE
if DGLE#DGLL=0
WRITE !
+8 if DGLE#DGLL=0
SET DGLSS=$$MULS(DGLMAX,DGLE,.DGL)
if DGLSS["^"
SET DGLIT=1
End DoDot:1
if DGLIT
QUIT
+9 IF DGLE#DGLL'=0
IF +DGLSS<=0
Begin DoDot:1
+10 WRITE !
SET DGLSS=$$MULS(DGLMAX,DGLE,.DGL)
if DGLSS["^"
SET DGLIT=1
End DoDot:1
+11 GOTO MULQ
+12 QUIT X
MULW ; Write Multiple
+1 NEW DGLEX,DGLI,DGLSO,DGLNC,DGLT,DGLTX
SET DGLSO=$PIECE(DGL(+DGLE,0),"^",1)
+2 SET DGLNC=$PIECE(DGL(+DGLE,0),"^",3)
if +DGLNC>0
SET DGLNC=" ("_DGLNC_")"
+3 SET DGLEX=$GET(DGL(+DGLE,"MENU"))
SET DGLTX(1)=DGLSO
+4 SET DGLTX(1)=DGLTX(1)_$SELECT($DATA(DGL(+DGLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(DGLSO)))_" "_DGLEX_DGLNC
+5 DO PR(.DGLTX,60)
WRITE !,$JUSTIFY(DGLE,5),". ",$GET(DGLTX(1))
+6 FOR DGLI=2:1:5
SET DGLT=$GET(DGLTX(DGLI))
if $LENGTH(DGLT)
WRITE !,$JUSTIFY(" ",19),DGLT
+7 QUIT
MULS(X,Y,DGL) ; Select from Multiple Entries
+1 NEW DIR,DIRB,DGLFI,DGLHLP,DGLLAST,DGLMAX,DGLS
+2 if +($GET(DGLIT))>0
QUIT "^^"
SET DGLMAX=+($GET(X))
SET DGLLAST=+($GET(Y))
+3 if DGLMAX=0
QUIT -1
SET DGLFI=$ORDER(DGL(0))
if +DGLFI'>0
QUIT -1
+4 IF +($ORDER(DGL(+DGLLAST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_DGLMAX_": "
End DoDot:1
+7 IF +($ORDER(DGL(+DGLLAST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_DGLMAX_": "
End DoDot:1
+9 SET DGLHLP=" Answer must be from 1 to "
+10 SET DGLHLP=DGLHLP_DGLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^DGICDL"
+13 SET DIR(0)="NAO^1:"_DGLMAX_":0"
DO ^DIR
+14 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 if X["^^"!($DATA(DTOUT))
SET DGLIT=1
SET X="^^"
IF X["^^"!(+($GET(DGLIT))>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(DGLHLP))
WRITE !,$GET(DGLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +DGLSS'>0
IF $GET(DGLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(DGLIT))'>0
SET X=$$X(+DGLSS,.DGL)
+3 QUIT X
X(X,DGL) ; Set X and Output Array
+1 NEW DGLEX,DGLIEN,DGLN,DGLNC,DGLNN,DGLRN,DGLS,DGLSO
+2 SET DGLS=+($GET(X))
+3 SET DGLSO=$PIECE($GET(DGL(DGLS,0)),"^",1)
SET DGLEX=$GET(DGL(DGLS,"MENU"))
+4 SET DGLIEN=$SELECT($DATA(DGL(DGLS,"CAT")):"99:CAT;"_$PIECE($GET(DGL(DGLS,0)),"^"),1:$PIECE($GET(DGL(DGLS,"IDS",1)),"^")_";"_$PIECE($GET(DGL(DGLS,0)),"^")_";"_$PIECE($GET(DGL(DGLS,"LEX",1)),"^"))
if '$LENGTH(DGLSO)
QUIT "^"
+5 if '$LENGTH(DGLEX)
QUIT "^"
if +DGLIEN'>0
QUIT "^"
SET X=DGLIEN_"^"_DGLEX
+6 SET DGLNN="DGL("_+DGLS_")"
SET DGLNC="DGL("_+DGLS_","
+7 FOR
SET DGLNN=$QUERY(@DGLNN)
if '$LENGTH(DGLNN)!(DGLNN'[DGLNC)
QUIT
Begin DoDot:1
+8 SET DGLRN="DGLN("_$PIECE(DGLNN,"(",2,299)
SET @DGLRN=@DGLNN
End DoDot:1
+9 KILL DGL
SET DGLNN="DGLN("_+DGLS_")"
SET DGLNC="DGLN("_+DGLS_","
+10 FOR
SET DGLNN=$QUERY(@DGLNN)
if '$LENGTH(DGLNN)!(DGLNN'[DGLNC)
QUIT
Begin DoDot:1
+11 SET DGLRN="DGL("_$PIECE(DGLNN,"(",2,299)
SET @DGLRN=@DGLNN
End DoDot:1
+12 QUIT X
+13 ;
+14 ; Miscellaneous
CL ; Clear
+1 KILL DGLIT
+2 QUIT
PR(DGL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,DGLC,DGLI,DGLL
+2 KILL ^UTILITY($JOB,"W")
if '$DATA(DGL)
QUIT
SET DGLL=+($GET(X))
if +DGLL'>0
SET DGLL=79
+3 SET DGLC=+($GET(DGL))
if +($GET(DGLC))'>0
SET DGLC=$ORDER(DGL(" "),-1)
if +DGLC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+DGLL
SET DGLI=0
+5 FOR
SET DGLI=$ORDER(DGL(DGLI))
if +DGLI=0
QUIT
SET X=$GET(DGL(DGLI))
DO ^DIWP
+6 KILL DGL
SET (DGLC,DGLI)=0
+7 FOR
SET DGLI=$ORDER(^UTILITY($JOB,"W",1,DGLI))
if +DGLI=0
QUIT
Begin DoDot:1
+8 SET DGL(DGLI)=$$TM($GET(^UTILITY($JOB,"W",1,DGLI,0))," ")
SET DGLC=DGLC+1
End DoDot:1
+9 if $LENGTH(DGLC)
SET DGL=DGLC
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
