LEX10CX4 ;ISL/KER - ICD-10 Cross-Over - Ask ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; None
;
; External References
; ^DIC ICR 10006
; ^DIR ICR 10026
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEX0FND,LEX0REV,LEX0SEL NEWed in LEX10CX
;
ASK(LEXA,LEXB) ; Ask for Selection
N LEXSRCO,LEXSRTX,LEXSRNM,LEXANS,LEXFND,LEXI,LEXIND,LEXLEN,LEXT
S Y=-1,LEXFND=+($G(LEXB(0))) Q:LEXFND'>0 S LEX0FND=1
S LEXSRCO=$G(LEXA("SOURCE","SOE"))
S LEXSRTX=$$UP^XLFSTR($G(LEXA("SOURCE","EXP")))
S LEXSRNM=$G(LEXA("SOURCE","SRC"))
W ! I $L($G(LEXSRTX)),$L($G(LEXSRCO)) D
. W !," ",LEXSRNM," ",LEXSRCO
. N LEXIND,LEXLEN,LEXT,LEXI S LEXIND=18,LEXT(1)=LEXSRTX
. D PR^LEXU(.LEXT,50) W ?22," ",$G(LEXT(1))
. S LEXI=1 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 D
. . N LEXTX2 S LEXTX2=$$TM($G(LEXT(LEXI))) Q:'$L(LEXTX2)
. . W !,?23,LEXTX2
S:+LEXFND=1 LEXANS=$$ONE S:+LEXFND>1 LEXANS=$$MUL
I LEXANS>0 D S:+($G(X))'>0 X="" S:+($G(Y))'>0 Y=-1 Q
. S X="",Y=-1 D X(.LEXA),Y(LEXANS,.LEXB)
. Q:+($G(X))>0&(+($G(Y))>0) S X="",Y=-1
I LEXANS'>0 K X,Y,LEXB S X="",Y=-1
Q
ONE(X) ; One Entry Found - Needs LEXB
N LEXIEN,LEXLN,LEXSO,LEXTEXT N DIR
N LEXTXT,Y S LEXTEXT=$G(LEXB(1)),LEXIEN=+LEXTEXT
S LEXSO=$P(LEXTEXT,U,2),LEXTEXT=$P(LEXTEXT,U,3)
S LEXTXT(1)=LEXSO_" "_LEXTEXT D PR^LEXU(.LEXTXT,64)
S DIR("A",1)=" One ICD-10 suggestion found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(LEXTXT(1)),LEXLN=3
I $L($G(LEXTXT(2))) S LEXLN=LEXLN+1 D
. S DIR("A",LEXLN)=" "_$G(LEXTXT(2))
S LEXLN=LEXLN+1,DIR("A",LEXLN)=" ",LEXLN=LEXLN+1
S DIR("A")=" OK? ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR S LEX0REV=1 S:+Y>0 LEX0SEL=1 Q:+Y>0 1
Q:X["^^"!($D(DTOUT)) "^^" Q:X["^" "^"
Q -1
MUL(X) ; Multiple Entries Found - Needs LEXB
N LEXENT,LEXIEN,LEXIT,LEXITEM,LEXLEN,LEXMAX,LEXMAT,LEXN,LEXSEL
N LEXSO,LEXTEXT,LEXTOT,Y S LEXLEN=+($G(LEXN))
S:+LEXLEN'>4 LEXLEN=5 N LEXN
S (LEXMAX,LEXENT,LEXSEL,LEXIT)=0
S U="^",LEXTOT=$G(LEXB(0))
S LEXSEL=0 G:+LEXTOT=0 MULQ
S LEXMAT=LEXTOT_" ICD-10 suggestion"_$S(+LEXTOT>1:"s",1:"")_" found"
W:+LEXTOT>0 !!," ",LEXMAT
F LEXENT=1:1:LEXTOT Q:LEXIT D Q:LEXIT
. I ((LEXSEL>0)&(LEXSEL<LEXENT+1)) S LEXIT=1 Q
. N LEXITEM,LEXIEN,LEXTEXT,LEXSO
. S LEXITEM=$G(LEXB(LEXENT))
. S LEXIEN=+LEXITEM,LEXSO=$P(LEXITEM,U,3)
. S LEXTEXT=$P(LEXITEM,U,2) Q:+LEXIEN'>0
. Q:'$L(LEXSO) Q:'$L(LEXTEXT)
. S LEXMAX=LEXENT W:LEXENT#LEXLEN=1 ! D MULW
. S:LEXMAX=LEXTOT LEX0REV=1
. W:LEXENT#LEXLEN=0 !
. S:LEXENT#LEXLEN=0 LEXSEL=$$MULS(LEXMAX,LEXENT)
. S:LEXSEL["^" LEXIT=1
I LEXENT#LEXLEN'=0,+LEXSEL=0 D
. W ! S LEXSEL=$$MULS(LEXMAX,LEXENT)
. S:LEXSEL["^" LEXIT=1
G MULQ
Q X
MULW ; Write Multiple - Needs LEXENT,LEXIEN,LEXSO,LEXTXT
Q:+($G(LEXENT))'>0 Q:+($G(LEXIEN))'>0
Q:'$L($G(LEXTEXT)) Q:'$L($G(LEXSO))
N LEXI,LEXIND,LEXTAB,LEXTXT,LEXTX2
S LEXTAB=8,LEXIND=18
W !,$J(LEXENT,5),".",?LEXTAB,LEXSO
S LEXTXT(1)=LEXTEXT D PR^LEXU(.LEXTXT,54)
W ?LEXIND,$G(LEXTXT(1))
S LEXI=1 F S LEXI=$O(LEXTXT(LEXI)) Q:+LEXI'>0 D
. N LEXTX2 S LEXTX2=$$TM($G(LEXTXT(LEXI))) Q:'$L(LEXTX2)
. W !,?LEXIND,LEXTX2
Q
MULS(X,Y) ; Select Multiple - Needs LEXB, Uses LEXIT,LEXTOT
N DIR,DIRB,LEXHLP,LEXLAST,LEXMAX
N LEXNEXT,LEXRAN,LEXS,LEXENT,Y Q:+($G(LEXIT))>0 "^^"
S LEXS=$G(X),LEXENT=$G(Y) N X
S LEXMAX=+($G(LEXS)),LEXLAST=+($G(LEXENT))
Q:LEXMAX=0 -1 S LEXRAN=" Select 1-"_LEXMAX_": "
S LEXNEXT=$O(LEXB(+LEXLAST)) I +LEXNEXT>0 D
. S DIR("A")=" Press <RETURN> for more, "
. S DIR("A")=DIR("A")_"'^' to exit, or"_LEXRAN
S:+LEXNEXT'>0 DIR("A")=LEXRAN
S LEXHLP=" Answer must be from 1 to "_LEXMAX
S LEXHLP=LEXHLP_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^ICDEXLK2"
S DIR(0)="NAO^1:"_LEXMAX_":0" D ^DIR
S:X["^"&(LEXENT=+($G(LEXTOT))) (X,Y)="^^^"
S:X["^^"!($D(DTOUT)) LEXIT=1,X="^^"
I X["^^"!(+($G(LEXIT))>0) Q "^^"
S LEXS=+Y S:$D(DTOUT)!(X[U) LEXS=U
K DIR N LEXIT,LEXTOT
S:+LEXS>0&($D(LEXB(+LEXS))) LEX0SEL=1
Q LEXS
MULSH ; Select Multiple Help
I $L($G(LEXHLP)) W !,$G(LEXHLP) Q
Q
MULQ ; Quit Multiple
Q:+LEXSEL'>0 -1 S X=+LEXSEL
Q X
;
; Miscellaneous
TM(X,Y) ; Trim Y
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
X(LEXA) ; Set X
N LEXEXP,LEXCOD,LEXNOM,LEXIEN K X S X=""
S LEXEXP=$G(LEXA("SOURCE","EXP")) Q:'$L(LEXEXP)
S LEXCOD=$G(LEXA("SOURCE","SOE")) Q:'$L(LEXCOD)
S LEXNOM=$G(LEXA("SOURCE","SRC")) Q:'$L(LEXNOM)
S LEXIEN=+($G(LEXA("SOURCE","Y"))) Q:'$L(LEXIEN)
Q:+LEXIEN'>0 S X=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM
Q
Y(LEX,LEXB) ; Set Y
N LEXEXP,LEXCOD,LEXNOM,LEXIEN,LEXDAT
N LEXDAT,LEXEIEN,LEXEX,LEXICDD,LEXSO,LEXSTA,LEXTD
K Y S Y=-1 S LEX=+($G(LEX)),LEXDAT=$G(LEXB(+LEX))
S LEXEXP=$P(LEXDAT,"^",2) Q:'$L(LEXEXP)
S LEXCOD=$P(LEXDAT,"^",3) Q:'$L(LEXCOD)
S LEXNOM="ICD-10-CM"
S LEXIEN=+($P(LEXDAT,"^",1)) Q:'$L(LEXIEN)
Q:+LEXIEN'>0 S Y=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM
Q
SAB(X) ; Select Coding System
N DIC,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,Y
S DIC="^LEX(757.03,",DIC(0)="AEQM"
S DIC("A")=" Select a Coding System: "
S LEXB=$P($G(^LEX(757.03,1,0)),"^",2) S:$L(LEXB) DIC("B")=LEXB
S DIC("W")="N LEX1,LEX2 S LEX1=$P($G(^LEX(757.03,+Y,0)),U,2),"
S DIC("W")=DIC("W")_"LEX2=$P($G(^LEX(757.03,+Y,0)),U,3) "
S DIC("W")=DIC("W")_"S:$L(LEX2,"","")>2 LEX2=$P(LEX2,"","",1,"
S DIC("W")=DIC("W")_"($L(LEX2,"","")-1)) W "" "",LEX1"
S DIC("W")=DIC("W")_"_$J("" "",(12-$L(LEX1)))_"" ""_LEX2"
S DIC("S")="I $E($P($G(^LEX(757.03,+Y,0)),""^"",1),1,3)'=""10D"""
S DIC("W")="W "" "",$P($G(^LEX(757.03,+Y,0)),U,2)"
K X D ^DIC Q:X["^"!($D(DTOUT))!($D(DUOUT)) "^"
S LEXB=$E($P($G(^LEX(757.03,+Y,0)),"^",1),1,3) Q:$L(LEXB)'=3 "^"
Q:'$D(^LEX(757.03,"ASAB",LEXB)) "^" S X=LEXB
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10CX4 6056 printed Apr 09, 2024@21:14:44 Page 2
LEX10CX4 ;ISL/KER - ICD-10 Cross-Over - Ask ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; ^DIC ICR 10006
+8 ; ^DIR ICR 10026
+9 ; $$UP^XLFSTR ICR 10104
+10 ;
+11 ; Local Variables NEWed or KILLed Elsewhere
+12 ; LEX0FND,LEX0REV,LEX0SEL NEWed in LEX10CX
+13 ;
ASK(LEXA,LEXB) ; Ask for Selection
+1 NEW LEXSRCO,LEXSRTX,LEXSRNM,LEXANS,LEXFND,LEXI,LEXIND,LEXLEN,LEXT
+2 SET Y=-1
SET LEXFND=+($GET(LEXB(0)))
if LEXFND'>0
QUIT
SET LEX0FND=1
+3 SET LEXSRCO=$GET(LEXA("SOURCE","SOE"))
+4 SET LEXSRTX=$$UP^XLFSTR($GET(LEXA("SOURCE","EXP")))
+5 SET LEXSRNM=$GET(LEXA("SOURCE","SRC"))
+6 WRITE !
IF $LENGTH($GET(LEXSRTX))
IF $LENGTH($GET(LEXSRCO))
Begin DoDot:1
+7 WRITE !," ",LEXSRNM," ",LEXSRCO
+8 NEW LEXIND,LEXLEN,LEXT,LEXI
SET LEXIND=18
SET LEXT(1)=LEXSRTX
+9 DO PR^LEXU(.LEXT,50)
WRITE ?22," ",$GET(LEXT(1))
+10 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+11 NEW LEXTX2
SET LEXTX2=$$TM($GET(LEXT(LEXI)))
if '$LENGTH(LEXTX2)
QUIT
+12 WRITE !,?23,LEXTX2
End DoDot:2
End DoDot:1
+13 if +LEXFND=1
SET LEXANS=$$ONE
if +LEXFND>1
SET LEXANS=$$MUL
+14 IF LEXANS>0
Begin DoDot:1
+15 SET X=""
SET Y=-1
DO X(.LEXA)
DO Y(LEXANS,.LEXB)
+16 if +($GET(X))>0&(+($GET(Y))>0)
QUIT
SET X=""
SET Y=-1
End DoDot:1
if +($GET(X))'>0
SET X=""
if +($GET(Y))'>0
SET Y=-1
QUIT
+17 IF LEXANS'>0
KILL X,Y,LEXB
SET X=""
SET Y=-1
+18 QUIT
ONE(X) ; One Entry Found - Needs LEXB
+1 NEW LEXIEN,LEXLN,LEXSO,LEXTEXT
NEW DIR
+2 NEW LEXTXT,Y
SET LEXTEXT=$GET(LEXB(1))
SET LEXIEN=+LEXTEXT
+3 SET LEXSO=$PIECE(LEXTEXT,U,2)
SET LEXTEXT=$PIECE(LEXTEXT,U,3)
+4 SET LEXTXT(1)=LEXSO_" "_LEXTEXT
DO PR^LEXU(.LEXTXT,64)
+5 SET DIR("A",1)=" One ICD-10 suggestion found"
SET DIR("A",2)=" "
+6 SET DIR("A",3)=" "_$GET(LEXTXT(1))
SET LEXLN=3
+7 IF $LENGTH($GET(LEXTXT(2)))
SET LEXLN=LEXLN+1
Begin DoDot:1
+8 SET DIR("A",LEXLN)=" "_$GET(LEXTXT(2))
End DoDot:1
+9 SET LEXLN=LEXLN+1
SET DIR("A",LEXLN)=" "
SET LEXLN=LEXLN+1
+10 SET DIR("A")=" OK? "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+11 DO ^DIR
SET LEX0REV=1
if +Y>0
SET LEX0SEL=1
if +Y>0
QUIT 1
+12 if X["^^"!($DATA(DTOUT))
QUIT "^^"
if X["^"
QUIT "^"
+13 QUIT -1
MUL(X) ; Multiple Entries Found - Needs LEXB
+1 NEW LEXENT,LEXIEN,LEXIT,LEXITEM,LEXLEN,LEXMAX,LEXMAT,LEXN,LEXSEL
+2 NEW LEXSO,LEXTEXT,LEXTOT,Y
SET LEXLEN=+($GET(LEXN))
+3 if +LEXLEN'>4
SET LEXLEN=5
NEW LEXN
+4 SET (LEXMAX,LEXENT,LEXSEL,LEXIT)=0
+5 SET U="^"
SET LEXTOT=$GET(LEXB(0))
+6 SET LEXSEL=0
if +LEXTOT=0
GOTO MULQ
+7 SET LEXMAT=LEXTOT_" ICD-10 suggestion"_$SELECT(+LEXTOT>1:"s",1:"")_" found"
+8 if +LEXTOT>0
WRITE !!," ",LEXMAT
+9 FOR LEXENT=1:1:LEXTOT
if LEXIT
QUIT
Begin DoDot:1
+10 IF ((LEXSEL>0)&(LEXSEL<LEXENT+1))
SET LEXIT=1
QUIT
+11 NEW LEXITEM,LEXIEN,LEXTEXT,LEXSO
+12 SET LEXITEM=$GET(LEXB(LEXENT))
+13 SET LEXIEN=+LEXITEM
SET LEXSO=$PIECE(LEXITEM,U,3)
+14 SET LEXTEXT=$PIECE(LEXITEM,U,2)
if +LEXIEN'>0
QUIT
+15 if '$LENGTH(LEXSO)
QUIT
if '$LENGTH(LEXTEXT)
QUIT
+16 SET LEXMAX=LEXENT
if LEXENT#LEXLEN=1
WRITE !
DO MULW
+17 if LEXMAX=LEXTOT
SET LEX0REV=1
+18 if LEXENT#LEXLEN=0
WRITE !
+19 if LEXENT#LEXLEN=0
SET LEXSEL=$$MULS(LEXMAX,LEXENT)
+20 if LEXSEL["^"
SET LEXIT=1
End DoDot:1
if LEXIT
QUIT
+21 IF LEXENT#LEXLEN'=0
IF +LEXSEL=0
Begin DoDot:1
+22 WRITE !
SET LEXSEL=$$MULS(LEXMAX,LEXENT)
+23 if LEXSEL["^"
SET LEXIT=1
End DoDot:1
+24 GOTO MULQ
+25 QUIT X
MULW ; Write Multiple - Needs LEXENT,LEXIEN,LEXSO,LEXTXT
+1 if +($GET(LEXENT))'>0
QUIT
if +($GET(LEXIEN))'>0
QUIT
+2 if '$LENGTH($GET(LEXTEXT))
QUIT
if '$LENGTH($GET(LEXSO))
QUIT
+3 NEW LEXI,LEXIND,LEXTAB,LEXTXT,LEXTX2
+4 SET LEXTAB=8
SET LEXIND=18
+5 WRITE !,$JUSTIFY(LEXENT,5),".",?LEXTAB,LEXSO
+6 SET LEXTXT(1)=LEXTEXT
DO PR^LEXU(.LEXTXT,54)
+7 WRITE ?LEXIND,$GET(LEXTXT(1))
+8 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXTXT(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+9 NEW LEXTX2
SET LEXTX2=$$TM($GET(LEXTXT(LEXI)))
if '$LENGTH(LEXTX2)
QUIT
+10 WRITE !,?LEXIND,LEXTX2
End DoDot:1
+11 QUIT
MULS(X,Y) ; Select Multiple - Needs LEXB, Uses LEXIT,LEXTOT
+1 NEW DIR,DIRB,LEXHLP,LEXLAST,LEXMAX
+2 NEW LEXNEXT,LEXRAN,LEXS,LEXENT,Y
if +($GET(LEXIT))>0
QUIT "^^"
+3 SET LEXS=$GET(X)
SET LEXENT=$GET(Y)
NEW X
+4 SET LEXMAX=+($GET(LEXS))
SET LEXLAST=+($GET(LEXENT))
+5 if LEXMAX=0
QUIT -1
SET LEXRAN=" Select 1-"_LEXMAX_": "
+6 SET LEXNEXT=$ORDER(LEXB(+LEXLAST))
IF +LEXNEXT>0
Begin DoDot:1
+7 SET DIR("A")=" Press <RETURN> for more, "
+8 SET DIR("A")=DIR("A")_"'^' to exit, or"_LEXRAN
End DoDot:1
+9 if +LEXNEXT'>0
SET DIR("A")=LEXRAN
+10 SET LEXHLP=" Answer must be from 1 to "_LEXMAX
+11 SET LEXHLP=LEXHLP_", or <Return> to continue"
+12 SET DIR("PRE")="S:X[""?"" X=""??"""
+13 SET (DIR("?"),DIR("??"))="^D MULSH^ICDEXLK2"
+14 SET DIR(0)="NAO^1:"_LEXMAX_":0"
DO ^DIR
+15 if X["^"&(LEXENT=+($GET(LEXTOT)))
SET (X,Y)="^^^"
+16 if X["^^"!($DATA(DTOUT))
SET LEXIT=1
SET X="^^"
+17 IF X["^^"!(+($GET(LEXIT))>0)
QUIT "^^"
+18 SET LEXS=+Y
if $DATA(DTOUT)!(X[U)
SET LEXS=U
+19 KILL DIR
NEW LEXIT,LEXTOT
+20 if +LEXS>0&($DATA(LEXB(+LEXS)))
SET LEX0SEL=1
+21 QUIT LEXS
MULSH ; Select Multiple Help
+1 IF $LENGTH($GET(LEXHLP))
WRITE !,$GET(LEXHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 if +LEXSEL'>0
QUIT -1
SET X=+LEXSEL
+2 QUIT X
+3 ;
+4 ; Miscellaneous
TM(X,Y) ; Trim Y
+1 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
X(LEXA) ; Set X
+1 NEW LEXEXP,LEXCOD,LEXNOM,LEXIEN
KILL X
SET X=""
+2 SET LEXEXP=$GET(LEXA("SOURCE","EXP"))
if '$LENGTH(LEXEXP)
QUIT
+3 SET LEXCOD=$GET(LEXA("SOURCE","SOE"))
if '$LENGTH(LEXCOD)
QUIT
+4 SET LEXNOM=$GET(LEXA("SOURCE","SRC"))
if '$LENGTH(LEXNOM)
QUIT
+5 SET LEXIEN=+($GET(LEXA("SOURCE","Y")))
if '$LENGTH(LEXIEN)
QUIT
+6 if +LEXIEN'>0
QUIT
SET X=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM
+7 QUIT
Y(LEX,LEXB) ; Set Y
+1 NEW LEXEXP,LEXCOD,LEXNOM,LEXIEN,LEXDAT
+2 NEW LEXDAT,LEXEIEN,LEXEX,LEXICDD,LEXSO,LEXSTA,LEXTD
+3 KILL Y
SET Y=-1
SET LEX=+($GET(LEX))
SET LEXDAT=$GET(LEXB(+LEX))
+4 SET LEXEXP=$PIECE(LEXDAT,"^",2)
if '$LENGTH(LEXEXP)
QUIT
+5 SET LEXCOD=$PIECE(LEXDAT,"^",3)
if '$LENGTH(LEXCOD)
QUIT
+6 SET LEXNOM="ICD-10-CM"
+7 SET LEXIEN=+($PIECE(LEXDAT,"^",1))
if '$LENGTH(LEXIEN)
QUIT
+8 if +LEXIEN'>0
QUIT
SET Y=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM
+9 QUIT
SAB(X) ; Select Coding System
+1 NEW DIC,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,Y
+2 SET DIC="^LEX(757.03,"
SET DIC(0)="AEQM"
+3 SET DIC("A")=" Select a Coding System: "
+4 SET LEXB=$PIECE($GET(^LEX(757.03,1,0)),"^",2)
if $LENGTH(LEXB)
SET DIC("B")=LEXB
+5 SET DIC("W")="N LEX1,LEX2 S LEX1=$P($G(^LEX(757.03,+Y,0)),U,2),"
+6 SET DIC("W")=DIC("W")_"LEX2=$P($G(^LEX(757.03,+Y,0)),U,3) "
+7 SET DIC("W")=DIC("W")_"S:$L(LEX2,"","")>2 LEX2=$P(LEX2,"","",1,"
+8 SET DIC("W")=DIC("W")_"($L(LEX2,"","")-1)) W "" "",LEX1"
+9 SET DIC("W")=DIC("W")_"_$J("" "",(12-$L(LEX1)))_"" ""_LEX2"
+10 SET DIC("S")="I $E($P($G(^LEX(757.03,+Y,0)),""^"",1),1,3)'=""10D"""
+11 SET DIC("W")="W "" "",$P($G(^LEX(757.03,+Y,0)),U,2)"
+12 KILL X
DO ^DIC
if X["^"!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
+13 SET LEXB=$EXTRACT($PIECE($GET(^LEX(757.03,+Y,0)),"^",1),1,3)
if $LENGTH(LEXB)'=3
QUIT "^"
+14 if '$DATA(^LEX(757.03,"ASAB",LEXB))
QUIT "^"
SET X=LEXB
+15 QUIT X
