LEXLK2 ;ISL/KER - Look Up - Expression Attributes ;04/21/2014
;;2.0;LEXICON UTILITY;**6,19,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.13) N/A
;
; External References
; ^DIR ICR 10026
;
GET(Y) ; Build list in array LEX
N LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP
S $E(LEXSPC,42)=" "
K LEX
; PCH 6 add MD and CLC
D MC,SY,LV,MD,DEF,STY,CLC,SRC
K LEXC,LEXCODE,LEXCT,LEXDEF,LEXDIS,LEXEXP,LEXF
K LEXFORM,LEXMC,LEXMCE,LEXNOM,LEXSCP,LEXSO,LEXSPC,LEXSPCR
K LEXSR,LEXSRC,LEXSTR
Q
MC ; Major Concept
N LEXMEX
S LEXMC=+^LEX(757.01,+Y,1)
S LEXMCE=+Y
S LEXMEX=+^LEX(757,LEXMC,0)
D BL,BL
S LEXSTR="TERMS:" D TL,BL
S LEXSTR=" Concept: "_$E(^LEX(757.01,LEXMEX,0),1,66) D TL
S LEXDIS=$$T(+Y) S LEXSTR=" "_LEXDIS D TL
Q
SY ; Synonyms
N LEXEXP
S LEXEXP=0
F S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0 D
.I $P(^LEX(757.01,LEXEXP,1),U,2)=2 D
..S LEXDIS=$$T(LEXEXP) D BL
..S LEXSTR=" Synonym: "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
..S LEXSTR=" "_LEXDIS D TL
Q
LV ; Lexical Variants
N LEXEXP
S LEXEXP=0
F S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0 D
.I $P(^LEX(757.01,LEXEXP,1),U,2)=3 D
..S LEXDIS=$$T(LEXEXP) D BL
..S LEXSTR=" Variant: "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
..S LEXSTR=" "_LEXDIS D TL
Q
MD ; Modifiers/Descendants PCH 6 added
Q:'$D(^LEX(757.01,"APAR",LEXMCE))
D BL
N LEXCHD,LEXORD,LEXSTR,LEXNO,LEXE,LEXCT,LEXTY,LEXL
S (LEXCHD,LEXCT)=0
S LEXSTR=" Modified/Descendant Terms" D TL,BL
F S LEXCHD=$O(^LEX(757.01,"APAR",LEXMCE,LEXCHD)) Q:+LEXCHD=0 D
.S LEXE=$P($G(^LEX(757.01,LEXCHD,0)),"^") Q:'$L(LEXE)
.S LEXTY=+$P($G(^LEX(757.01,LEXCHD,1)),"^",2) Q:LEXTY=0
.S LEXCT=LEXCT+1
.S LEXORD=+$P($G(^LEX(757.01,LEXCHD,1)),"^",10)
.S LEXNO=$S(LEXORD>0:LEXORD,1:(9999+LEXCT))
.S LEXL(LEXTY,LEXNO)=LEXE
S LEXTY=0 F S LEXTY=$O(LEXL(LEXTY)) Q:+LEXTY=0 D
.S LEXNO=0 F S LEXNO=$O(LEXL(LEXTY,LEXNO)) Q:+LEXNO=0 D
..S LEXSTR=" "_LEXL(LEXTY,LEXNO) D TL
Q
DEF ; Definition
D BL
I $D(^LEX(757.01,+Y,3)) D D BL
.S LEXSTR="DEFINITION:" D TL,BL
.N LEXDEF S LEXDEF=0
.F S LEXDEF=$O(^LEX(757.01,+Y,3,LEXDEF)) Q:+LEXDEF=0 D
..S LEXSTR=" "_^LEX(757.01,+Y,3,LEXDEF,0) D TL
Q
STY ; Semantic Classes/Types
S LEXSTR="SEMANTICS:" D TL,BL
S LEXSTR=" CLASS TYPE" D TL,BL
N LEXC,LEXT,LEXCT,LEXTT S LEXC="",LEXT=0
F S LEXC=$O(^LEX(757.1,"AMCC",LEXMC,LEXC)) Q:LEXC="" D
.S LEXCT=$E($P(^LEX(757.11,+$O(^LEX(757.11,"B",LEXC,0)),0),U,2),1,38)
.S LEXSTR=" "_LEXCT
.S LEXT=0
.F S LEXT=$O(^LEX(757.1,"AMCC",LEXMC,LEXC,LEXT)) Q:+LEXT=0 D
..S LEXTT=$E($P(^LEX(757.12,+$P(^LEX(757.1,LEXT,0),U,3),0),U,2),1,38)
..S LEXSPCR=$E(LEXSPC,1,(40-$L(LEXSTR)))
..S LEXSTR=LEXSTR_LEXSPCR_LEXTT D TL S LEXSTR=""
Q
CLC ; Clinical Class PCH 6 added
N LEXCL,LEXGP,LEXSTR,LEXFM,LEXIND,LEXP,LEXMEM,LEXT,LEXTC
S LEXCL=+$P($G(^LEX(757.01,+Y,1)),"^",11)
S:LEXCL=0 LEXCL=+$P($G(^LEX(757.01,LEXMCE,1)),"^",11)
Q:LEXCL=0 Q:'$D(^LEX(757.13,LEXCL,0))
S LEXGP=$G(^LEX(757.13,LEXCL,5)) Q:'$L(LEXGP)
D BL
S LEXSTR="SOURCE CATEGORY: "_LEXGP D TL,BL
S LEXFM=$P($G(^LEX(757.13,LEXCL,3)),"^") Q:'$L(LEXFM)
S LEXIND=" "
F LEXP=1:1:$L(LEXFM,"~") D
.S LEXMEM=+$P(LEXFM,"~",LEXP) Q:LEXMEM=0 Q:'$D(^LEX(757.13,LEXMEM,0))
.S LEXT=$P($G(^LEX(757.13,LEXMEM,0)),"^") Q:LEXT=""
.S LEXTC=$P($G(^LEX(757.13,LEXMEM,0)),"^",2)
.S LEXIND=LEXIND_" "
.S LEXSTR=LEXIND_LEXT D TL
Q
SRC ; Classification Systems/Codes
N LEXSR,LEXSO,LEXSPC
K LEXSRC
S LEXSO=0
F S LEXSO=$O(^LEX(757.02,"AMC",LEXMC,LEXSO)) Q:+LEXSO=0 D
.Q:$P(^LEX(757.02,LEXSO,0),"^",6)=1
.S LEXNOM=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,2)
.S LEXSR=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,3)
.S $E(LEXSPC,16)=" "
.S LEXSPC=$E(LEXSPC,1,$L(LEXSPC)-$L(LEXNOM))
.S LEXSR=LEXNOM_LEXSPC_LEXSR
.S LEXCODE=$P(^LEX(757.02,LEXSO,0),U,2)
.S LEXSRC(LEXSR,LEXCODE)=""
I $D(LEXSRC) D K LEXSRC
.D BL S LEXSTR="CLASSIFICATION SYSTEMS/CODES:" D TL,BL
.S LEXSR=""
.F S LEXSR=$O(LEXSRC(LEXSR)) Q:LEXSR="" D
..D BL S LEXSTR=" "_LEXSR D TL
..S (LEXSTR,LEXCODE)=""
..F S LEXCODE=$O(LEXSRC(LEXSR,LEXCODE)) Q:LEXCODE="" D
...S LEXSTR=LEXSTR_"/"_LEXCODE
..S:$E(LEXSTR)="/" LEXSTR=$E(LEXSTR,2,$L(LEXSTR))
..S LEXSTR=" "_LEXSTR
..D:$L(LEXSTR)>18 TL
Q
T(X) ; Get Term Type
N LEXSCP,LEXF
S LEXF="",LEXFORM="",LEXEXP=+X,X=""
S LEXSCP=$P(^LEX(757.01,LEXEXP,1),U,3)
S LEXSCP=$S(LEXSCP="D":"Directly Linked to Concept",LEXSCP="I":"Indirectly Linked (via Synonym)",LEXSCP="B":"Broader View of Concept",LEXSCP="N":"Narrower View of Concept",LEXSCP="O":"Other View of Concept",1:"")
S LEXF=$P(^LEX(757.01,LEXEXP,1),U,4) S:+LEXF=0 LEXF=""
S:+LEXF>0 LEXF=$P($G(^LEX(757.014,+LEXF,0)),U,2)
S X=LEXSCP_"/"_LEXF S:$P(X,"/",2)="" X=$P(X,"/",1)
S:$E(X)="/" X=$E(X,2,$L(X))
K LEXSCP,LEXF
Q X
TL ; Create a Text Line
Q:'$L($G(LEXSTR))
N LEXC
S LEXC=+$G(LEX(0)),LEXC=LEXC+1
S LEX(LEXC)=LEXSTR
S LEX(0)=LEXC
Q
BL ; Create a Blank Line
N LEXC
S LEXC=+$G(LEX(0)),LEXC=LEXC+1
S LEX(LEXC)="",LEX(0)=LEXC
Q
LIST ; List the contents of the LEX array
Q:'$G(LEX(0)) N LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
S (LEXLN,LEXLC)=0,LEXCONT=""
F Q:LEXLN=LEX(0)!(LEXCONT["^") D Q:LEXLN=LEX(0)!(LEXCONT["^")
.S LEXB=LEXLN+1,LEXE=LEXB+(IOSL-3)
.F LEXCL=LEXB:1:LEXE D
..I $D(LEX(LEXCL)) W !,LEX(LEXCL) S LEXLN=LEXCL,LEXLC=LEXLC+1
.I LEXLN'=LEX(0) D CONT Q
W !
S LEXLC=LEXLC+1
I LEXLC=(IOSL-3) D CONT
K LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
Q
CONT ; Continue listing - Press <Return> to Continue
W ! N X,Y S DIR(0)="E" D ^DIR S LEXLC=0,LEXCONT=X
K DIR,DTOUT,DUOUT,DIRUT,DIROUT W !
Q
LEXLK2 ;ISL/KER - Look Up - Expression Attributes ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**6,19,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.13) N/A
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ;
GET(Y) ; Build list in array LEX
+1 NEW LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP
+2 SET $EXTRACT(LEXSPC,42)=" "
+3 KILL LEX
+4 ; PCH 6 add MD and CLC
+5 DO MC
DO SY
DO LV
DO MD
DO DEF
DO STY
DO CLC
DO SRC
+6 KILL LEXC,LEXCODE,LEXCT,LEXDEF,LEXDIS,LEXEXP,LEXF
+7 KILL LEXFORM,LEXMC,LEXMCE,LEXNOM,LEXSCP,LEXSO,LEXSPC,LEXSPCR
+8 KILL LEXSR,LEXSRC,LEXSTR
+9 QUIT
MC ; Major Concept
+1 NEW LEXMEX
+2 SET LEXMC=+^LEX(757.01,+Y,1)
+3 SET LEXMCE=+Y
+4 SET LEXMEX=+^LEX(757,LEXMC,0)
+5 DO BL
DO BL
+6 SET LEXSTR="TERMS:"
DO TL
DO BL
+7 SET LEXSTR=" Concept: "_$EXTRACT(^LEX(757.01,LEXMEX,0),1,66)
DO TL
+8 SET LEXDIS=$$T(+Y)
SET LEXSTR=" "_LEXDIS
DO TL
+9 QUIT
SY ; Synonyms
+1 NEW LEXEXP
+2 SET LEXEXP=0
+3 FOR
SET LEXEXP=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXP))
IF +LEXEXP=0
QUIT
Begin DoDot:1
+4 IF $PIECE(^LEX(757.01,LEXEXP,1),U,2)=2
Begin DoDot:2
+5 SET LEXDIS=$$T(LEXEXP)
DO BL
+6 SET LEXSTR=" Synonym: "_$EXTRACT(^LEX(757.01,LEXEXP,0),1,66)
DO TL
+7 SET LEXSTR=" "_LEXDIS
DO TL
End DoDot:2
End DoDot:1
+8 QUIT
LV ; Lexical Variants
+1 NEW LEXEXP
+2 SET LEXEXP=0
+3 FOR
SET LEXEXP=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXP))
IF +LEXEXP=0
QUIT
Begin DoDot:1
+4 IF $PIECE(^LEX(757.01,LEXEXP,1),U,2)=3
Begin DoDot:2
+5 SET LEXDIS=$$T(LEXEXP)
DO BL
+6 SET LEXSTR=" Variant: "_$EXTRACT(^LEX(757.01,LEXEXP,0),1,66)
DO TL
+7 SET LEXSTR=" "_LEXDIS
DO TL
End DoDot:2
End DoDot:1
+8 QUIT
MD ; Modifiers/Descendants PCH 6 added
+1 IF '$DATA(^LEX(757.01,"APAR",LEXMCE))
QUIT
+2 DO BL
+3 NEW LEXCHD,LEXORD,LEXSTR,LEXNO,LEXE,LEXCT,LEXTY,LEXL
+4 SET (LEXCHD,LEXCT)=0
+5 SET LEXSTR=" Modified/Descendant Terms"
DO TL
DO BL
+6 FOR
SET LEXCHD=$ORDER(^LEX(757.01,"APAR",LEXMCE,LEXCHD))
IF +LEXCHD=0
QUIT
Begin DoDot:1
+7 SET LEXE=$PIECE($GET(^LEX(757.01,LEXCHD,0)),"^")
IF '$LENGTH(LEXE)
QUIT
+8 SET LEXTY=+$PIECE($GET(^LEX(757.01,LEXCHD,1)),"^",2)
IF LEXTY=0
QUIT
+9 SET LEXCT=LEXCT+1
+10 SET LEXORD=+$PIECE($GET(^LEX(757.01,LEXCHD,1)),"^",10)
+11 SET LEXNO=$SELECT(LEXORD>0:LEXORD,1:(9999+LEXCT))
+12 SET LEXL(LEXTY,LEXNO)=LEXE
End DoDot:1
+13 SET LEXTY=0
FOR
SET LEXTY=$ORDER(LEXL(LEXTY))
IF +LEXTY=0
QUIT
Begin DoDot:1
+14 SET LEXNO=0
FOR
SET LEXNO=$ORDER(LEXL(LEXTY,LEXNO))
IF +LEXNO=0
QUIT
Begin DoDot:2
+15 SET LEXSTR=" "_LEXL(LEXTY,LEXNO)
DO TL
End DoDot:2
End DoDot:1
+16 QUIT
DEF ; Definition
+1 DO BL
+2 IF $DATA(^LEX(757.01,+Y,3))
Begin DoDot:1
+3 SET LEXSTR="DEFINITION:"
DO TL
DO BL
+4 NEW LEXDEF
SET LEXDEF=0
+5 FOR
SET LEXDEF=$ORDER(^LEX(757.01,+Y,3,LEXDEF))
IF +LEXDEF=0
QUIT
Begin DoDot:2
+6 SET LEXSTR=" "_^LEX(757.01,+Y,3,LEXDEF,0)
DO TL
End DoDot:2
End DoDot:1
DO BL
+7 QUIT
STY ; Semantic Classes/Types
+1 SET LEXSTR="SEMANTICS:"
DO TL
DO BL
+2 SET LEXSTR=" CLASS TYPE"
DO TL
DO BL
+3 NEW LEXC,LEXT,LEXCT,LEXTT
SET LEXC=""
SET LEXT=0
+4 FOR
SET LEXC=$ORDER(^LEX(757.1,"AMCC",LEXMC,LEXC))
IF LEXC=""
QUIT
Begin DoDot:1
+5 SET LEXCT=$EXTRACT($PIECE(^LEX(757.11,+$ORDER(^LEX(757.11,"B",LEXC,0)),0),U,2),1,38)
+6 SET LEXSTR=" "_LEXCT
+7 SET LEXT=0
+8 FOR
SET LEXT=$ORDER(^LEX(757.1,"AMCC",LEXMC,LEXC,LEXT))
IF +LEXT=0
QUIT
Begin DoDot:2
+9 SET LEXTT=$EXTRACT($PIECE(^LEX(757.12,+$PIECE(^LEX(757.1,LEXT,0),U,3),0),U,2),1,38)
+10 SET LEXSPCR=$EXTRACT(LEXSPC,1,(40-$LENGTH(LEXSTR)))
+11 SET LEXSTR=LEXSTR_LEXSPCR_LEXTT
DO TL
SET LEXSTR=""
End DoDot:2
End DoDot:1
+12 QUIT
CLC ; Clinical Class PCH 6 added
+1 NEW LEXCL,LEXGP,LEXSTR,LEXFM,LEXIND,LEXP,LEXMEM,LEXT,LEXTC
+2 SET LEXCL=+$PIECE($GET(^LEX(757.01,+Y,1)),"^",11)
+3 IF LEXCL=0
SET LEXCL=+$PIECE($GET(^LEX(757.01,LEXMCE,1)),"^",11)
+4 IF LEXCL=0
QUIT
IF '$DATA(^LEX(757.13,LEXCL,0))
QUIT
+5 SET LEXGP=$GET(^LEX(757.13,LEXCL,5))
IF '$LENGTH(LEXGP)
QUIT
+6 DO BL
+7 SET LEXSTR="SOURCE CATEGORY: "_LEXGP
DO TL
DO BL
+8 SET LEXFM=$PIECE($GET(^LEX(757.13,LEXCL,3)),"^")
IF '$LENGTH(LEXFM)
QUIT
+9 SET LEXIND=" "
+10 FOR LEXP=1:1:$LENGTH(LEXFM,"~")
Begin DoDot:1
+11 SET LEXMEM=+$PIECE(LEXFM,"~",LEXP)
IF LEXMEM=0
QUIT
IF '$DATA(^LEX(757.13,LEXMEM,0))
QUIT
+12 SET LEXT=$PIECE($GET(^LEX(757.13,LEXMEM,0)),"^")
IF LEXT=""
QUIT
+13 SET LEXTC=$PIECE($GET(^LEX(757.13,LEXMEM,0)),"^",2)
+14 SET LEXIND=LEXIND_" "
+15 SET LEXSTR=LEXIND_LEXT
DO TL
End DoDot:1
+16 QUIT
SRC ; Classification Systems/Codes
+1 NEW LEXSR,LEXSO,LEXSPC
+2 KILL LEXSRC
+3 SET LEXSO=0
+4 FOR
SET LEXSO=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSO))
IF +LEXSO=0
QUIT
Begin DoDot:1
+5 IF $PIECE(^LEX(757.02,LEXSO,0),"^",6)=1
QUIT
+6 SET LEXNOM=$PIECE(^LEX(757.03,+$PIECE(^LEX(757.02,LEXSO,0),U,3),0),U,2)
+7 SET LEXSR=$PIECE(^LEX(757.03,+$PIECE(^LEX(757.02,LEXSO,0),U,3),0),U,3)
+8 SET $EXTRACT(LEXSPC,16)=" "
+9 SET LEXSPC=$EXTRACT(LEXSPC,1,$LENGTH(LEXSPC)-$LENGTH(LEXNOM))
+10 SET LEXSR=LEXNOM_LEXSPC_LEXSR
+11 SET LEXCODE=$PIECE(^LEX(757.02,LEXSO,0),U,2)
+12 SET LEXSRC(LEXSR,LEXCODE)=""
End DoDot:1
+13 IF $DATA(LEXSRC)
Begin DoDot:1
+14 DO BL
SET LEXSTR="CLASSIFICATION SYSTEMS/CODES:"
DO TL
DO BL
+15 SET LEXSR=""
+16 FOR
SET LEXSR=$ORDER(LEXSRC(LEXSR))
IF LEXSR=""
QUIT
Begin DoDot:2
+17 DO BL
SET LEXSTR=" "_LEXSR
DO TL
+18 SET (LEXSTR,LEXCODE)=""
+19 FOR
SET LEXCODE=$ORDER(LEXSRC(LEXSR,LEXCODE))
IF LEXCODE=""
QUIT
Begin DoDot:3
+20 SET LEXSTR=LEXSTR_"/"_LEXCODE
End DoDot:3
+21 IF $EXTRACT(LEXSTR)="/"
SET LEXSTR=$EXTRACT(LEXSTR,2,$LENGTH(LEXSTR))
+22 SET LEXSTR=" "_LEXSTR
+23 IF $LENGTH(LEXSTR)>18
DO TL
End DoDot:2
End DoDot:1
KILL LEXSRC
+24 QUIT
T(X) ; Get Term Type
+1 NEW LEXSCP,LEXF
+2 SET LEXF=""
SET LEXFORM=""
SET LEXEXP=+X
SET X=""
+3 SET LEXSCP=$PIECE(^LEX(757.01,LEXEXP,1),U,3)
+4 SET LEXSCP=$SELECT(LEXSCP="D":"Directly Linked to Concept",LEXSCP="I":"Indirectly Linked (via Synonym)",LEXSCP="B":"Broader View of Concept",LEXSCP="N":"Narrower View of Concept",LEXSCP="O":"Other View of Concept",1:"")
+5 SET LEXF=$PIECE(^LEX(757.01,LEXEXP,1),U,4)
IF +LEXF=0
SET LEXF=""
+6 IF +LEXF>0
SET LEXF=$PIECE($GET(^LEX(757.014,+LEXF,0)),U,2)
+7 SET X=LEXSCP_"/"_LEXF
IF $PIECE(X,"/",2)=""
SET X=$PIECE(X,"/",1)
+8 IF $EXTRACT(X)="/"
SET X=$EXTRACT(X,2,$LENGTH(X))
+9 KILL LEXSCP,LEXF
+10 QUIT X
TL ; Create a Text Line
+1 IF '$LENGTH($GET(LEXSTR))
QUIT
+2 NEW LEXC
+3 SET LEXC=+$GET(LEX(0))
SET LEXC=LEXC+1
+4 SET LEX(LEXC)=LEXSTR
+5 SET LEX(0)=LEXC
+6 QUIT
BL ; Create a Blank Line
+1 NEW LEXC
+2 SET LEXC=+$GET(LEX(0))
SET LEXC=LEXC+1
+3 SET LEX(LEXC)=""
SET LEX(0)=LEXC
+4 QUIT
LIST ; List the contents of the LEX array
+1 IF '$GET(LEX(0))
QUIT
NEW LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
+2 SET (LEXLN,LEXLC)=0
SET LEXCONT=""
+3 FOR
IF LEXLN=LEX(0)!(LEXCONT["^")
QUIT
Begin DoDot:1
+4 SET LEXB=LEXLN+1
SET LEXE=LEXB+(IOSL-3)
+5 FOR LEXCL=LEXB:1:LEXE
Begin DoDot:2
+6 IF $DATA(LEX(LEXCL))
WRITE !,LEX(LEXCL)
SET LEXLN=LEXCL
SET LEXLC=LEXLC+1
End DoDot:2
+7 IF LEXLN'=LEX(0)
DO CONT
QUIT
End DoDot:1
IF LEXLN=LEX(0)!(LEXCONT["^")
QUIT
+8 WRITE !
+9 SET LEXLC=LEXLC+1
+10 IF LEXLC=(IOSL-3)
DO CONT
+11 KILL LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
+12 QUIT
CONT ; Continue listing - Press <Return> to Continue
+1 WRITE !
NEW X,Y
SET DIR(0)="E"
DO ^DIR
SET LEXLC=0
SET LEXCONT=X
+2 KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
WRITE !
+3 QUIT
