LEXPRNT ;ISL/KER - Print Utilities for the Lexicon ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^TMP("XTLKHITS") SACC 2.3.2.5.1
;
; External References
; None
;
XTLK ; XTLK Display format for MTLU
; Uses XTLKH, XTLKMULT, XTLKREF0, LEXSHOW
N LEXIFN,LEXEXP,LEXCODE,LEXSOID
S LEXIFN=0,LEXEXP=-1 S:'$D(LEXSHOW) LEXSHOW=""
S:'$D(LEXSUB) LEXSUB="WRD"
S (LEXEXP,LEXIFN)=+($P(XTLKREF0,",",2)) G:+LEXIFN'>0 XTQ
D:XTLKMULT MULTI
D:'XTLKMULT ONE
XTQ K LEXCODE,LEXSOID,LEXIFN,LEXEXP
Q
MULTI ; Multiple entries on the selection list
N LEXNUM,LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
S LEXNUM=XTLKH,(LEXSTR,LEXDP,LEXCCS)="",LEXL=70,LEXP=7
D COMMON
W:LEXNUM>1 ! W:LEXNUM>1&(LEXNUM#5=1) !
W $J(LEXNUM,4),":" W:$L(LEXSTR)<(LEXL+1) ?LEXP,LEXSTR
D:$L(LEXSTR)>LEXL LONG
W:LEXNUM#5=0&(+($G(LEXHLPF))=0) !
W:LEXNUM#5'=0&(LEXNUM=+($G(^TMP("XTLKHITS",$J))))&(+($G(LEXHLPF))=0) !
Q
ONE ; One entry on the selection list
N LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
S (LEXSTR,LEXDP,LEXCCS)="",LEXL=75,LEXP=2
D COMMON
W:$L(LEXSTR)<(LEXL+1) ?LEXP,LEXSTR
D:$L(LEXSTR)>LEXL LONG
Q
COMMON ; Parse LEXSHOW for both MULTI and ONE
S:LEXSUB="WRD" LEXSTR=^LEX(757.01,LEXEXP,0)
S:LEXSUB'="WRD" LEXSTR=^LEX(757.01,+(@(DIC_LEXEXP_",0)")),0)
S LEXDP=$S($D(^LEX(757.01,$S(LEXSUB="WRD":LEXEXP,1:+(@(DIC_LEXEXP_",0)"))),3)):" *",1:"")
I LEXSUB'="WRD" S LEXEXP=+(@(DIC_LEXEXP_",0)"))
I $D(LEXSHOW),LEXSHOW'="" F LEXSOID=1:1:$L(LEXSHOW,"/") D
. S LEXCODE=$P(LEXSHOW,"/",LEXSOID) N @LEXCODE S @LEXCODE=""
. S @LEXCODE=$S(LEXSUB="WRD":$$CODE(LEXIFN,LEXCODE),1:$$CODE(LEXEXP,LEXCODE))
. I @LEXCODE'="" S LEXCCS=LEXCCS_" ("_@LEXCODE_")"
S LEXSTR=LEXSTR_LEXDP_LEXCCS
Q
LONG ; Handle a long string
N LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD S LEXLNN=0,LEXOLD=LEXSTR
F Q:$L(LEXSTR)<(LEXL+1) D PARSE Q:$L(LEXSTR)<(LEXL+1)
S LEXLNN=LEXLNN+1
W:LEXLNN>1 ! W ?LEXP,LEXSTR
Q
PARSE ; Parse a long string into screen length strings
S LEXOK=0,LEXCHR=""
F LEXPSN=LEXL:-1:0 Q:+LEXOK=1 D Q:+LEXOK=1
. I $E(LEXSTR,LEXPSN)=" " S LEXCHR=" ",LEXOK=1 Q
. I $E(LEXSTR,LEXPSN)="," S LEXCHR=",",LEXOK=1 Q
. I $E(LEXSTR,LEXPSN)="/" S LEXCHR="/",LEXOK=1 Q
. I $E(LEXSTR,LEXPSN)="-" S LEXCHR="-",LEXOK=1 Q
I LEXCHR=" " S LEXSTO=$E(LEXSTR,1,LEXPSN-1),LEXREM=$E(LEXSTR,LEXPSN+1,$L(LEXSTR))
I LEXCHR="," S LEXSTO=$E(LEXSTR,1,LEXPSN),LEXREM=$E(LEXSTR,(LEXPSN+1),$L(LEXSTR)) S:$E(LEXREM,1)=" " LEXREM=$E(LEXREM,2,$L(LEXREM))
I LEXCHR="/" S LEXSTO=$E(LEXSTR,1,LEXPSN),LEXREM=$E(LEXSTR,(LEXPSN+1),$L(LEXSTR)) S:$E(LEXREM,1)=" " LEXREM=$E(LEXREM,2,$L(LEXREM))
I LEXCHR="-" S LEXSTO=$E(LEXSTR,1,LEXPSN),LEXREM=$E(LEXSTR,(LEXPSN+1),$L(LEXSTR)) S:$E(LEXREM,1)=" " LEXREM=$E(LEXREM,2,$L(LEXREM))
S LEXSTR=LEXREM
S LEXLNN=LEXLNN+1
W:LEXLNN>1 ! W ?LEXP,LEXSTO
Q
CODE(LEXEX,LEXSO) ; Returns codes (defined in XTLK^LEXPRNT) for a Term
N LEXMC,LEXCREC,LEXI,LEXCID S (LEXI,LEXCID)="",LEXCREC=0
I '$D(^LEX(757.01,LEXEX)) Q LEXCID
S LEXMC=$P(^LEX(757.01,LEXEX,1),U,1)
I LEXSUB="WRD" D
. F S LEXCREC=$O(^LEX(757.02,"AMC",LEXMC,LEXCREC)) Q:+LEXCREC=0 D
. . I $D(^LEX(757.02,"ASRC",LEXSO,LEXCREC)) D
. . . S LEXI=$P(^LEX(757.02,LEXCREC,0),U,2)
. . . I LEXI'="NOCODE",LEXI'?1"U"2"0"4N,LEXCID'[LEXI D
. . . . S LEXCID=LEXCID_"/"_LEXI
I LEXSUB'="WRD" D
. F S LEXCREC=$O(^LEX(757.02,"B",LEXEX,LEXCREC)) Q:+LEXCREC=0 D
. . I $D(^LEX(757.02,"ASRC",LEXSO,LEXCREC)) S LEXI=$P(^LEX(757.02,LEXCREC,0),U,2) I LEXI'="NOCODE",LEXI'?1"U"2"0"4N,LEXCID'[LEXI S LEXCID=LEXCID_"/"_LEXI
S:LEXCID'="" LEXCID=LEXSO_" "_$E(LEXCID,2,999)
K LEXCREC,LEXMC,LEXI
S LEXEX=LEXCID Q LEXEX
LEXPRNT ;ISL/KER - Print Utilities for the Lexicon ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^TMP("XTLKHITS") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; None
+8 ;
XTLK ; XTLK Display format for MTLU
+1 ; Uses XTLKH, XTLKMULT, XTLKREF0, LEXSHOW
+2 NEW LEXIFN,LEXEXP,LEXCODE,LEXSOID
+3 SET LEXIFN=0
SET LEXEXP=-1
IF '$DATA(LEXSHOW)
SET LEXSHOW=""
+4 IF '$DATA(LEXSUB)
SET LEXSUB="WRD"
+5 SET (LEXEXP,LEXIFN)=+($PIECE(XTLKREF0,",",2))
IF +LEXIFN'>0
GOTO XTQ
+6 IF XTLKMULT
DO MULTI
+7 IF 'XTLKMULT
DO ONE
XTQ KILL LEXCODE,LEXSOID,LEXIFN,LEXEXP
+1 QUIT
MULTI ; Multiple entries on the selection list
+1 NEW LEXNUM,LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
+2 SET LEXNUM=XTLKH
SET (LEXSTR,LEXDP,LEXCCS)=""
SET LEXL=70
SET LEXP=7
+3 DO COMMON
+4 IF LEXNUM>1
WRITE !
IF LEXNUM>1&(LEXNUM#5=1)
WRITE !
+5 WRITE $JUSTIFY(LEXNUM,4),":"
IF $LENGTH(LEXSTR)<(LEXL+1)
WRITE ?LEXP,LEXSTR
+6 IF $LENGTH(LEXSTR)>LEXL
DO LONG
+7 IF LEXNUM#5=0&(+($GET(LEXHLPF))=0)
WRITE !
+8 IF LEXNUM#5'=0&(LEXNUM=+($GET(^TMP("XTLKHITS",$JOB))))&(+($GET(LEXHLPF))=0)
WRITE !
+9 QUIT
ONE ; One entry on the selection list
+1 NEW LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
+2 SET (LEXSTR,LEXDP,LEXCCS)=""
SET LEXL=75
SET LEXP=2
+3 DO COMMON
+4 IF $LENGTH(LEXSTR)<(LEXL+1)
WRITE ?LEXP,LEXSTR
+5 IF $LENGTH(LEXSTR)>LEXL
DO LONG
+6 QUIT
COMMON ; Parse LEXSHOW for both MULTI and ONE
+1 IF LEXSUB="WRD"
SET LEXSTR=^LEX(757.01,LEXEXP,0)
+2 IF LEXSUB'="WRD"
SET LEXSTR=^LEX(757.01,+(@(DIC_LEXEXP_",0)")),0)
+3 SET LEXDP=$SELECT($DATA(^LEX(757.01,$SELECT(LEXSUB="WRD":LEXEXP,1:+(@(DIC_LEXEXP_",0)"))),3)):" *",1:"")
+4 IF LEXSUB'="WRD"
SET LEXEXP=+(@(DIC_LEXEXP_",0)"))
+5 IF $DATA(LEXSHOW)
IF LEXSHOW'=""
FOR LEXSOID=1:1:$LENGTH(LEXSHOW,"/")
Begin DoDot:1
+6 SET LEXCODE=$PIECE(LEXSHOW,"/",LEXSOID)
NEW @LEXCODE
SET @LEXCODE=""
+7 SET @LEXCODE=$SELECT(LEXSUB="WRD":$$CODE(LEXIFN,LEXCODE),1:$$CODE(LEXEXP,LEXCODE))
+8 IF @LEXCODE'=""
SET LEXCCS=LEXCCS_" ("_@LEXCODE_")"
End DoDot:1
+9 SET LEXSTR=LEXSTR_LEXDP_LEXCCS
+10 QUIT
LONG ; Handle a long string
+1 NEW LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD
SET LEXLNN=0
SET LEXOLD=LEXSTR
+2 FOR
IF $LENGTH(LEXSTR)<(LEXL+1)
QUIT
DO PARSE
IF $LENGTH(LEXSTR)<(LEXL+1)
QUIT
+3 SET LEXLNN=LEXLNN+1
+4 IF LEXLNN>1
WRITE !
WRITE ?LEXP,LEXSTR
+5 QUIT
PARSE ; Parse a long string into screen length strings
+1 SET LEXOK=0
SET LEXCHR=""
+2 FOR LEXPSN=LEXL:-1:0
IF +LEXOK=1
QUIT
Begin DoDot:1
+3 IF $EXTRACT(LEXSTR,LEXPSN)=" "
SET LEXCHR=" "
SET LEXOK=1
QUIT
+4 IF $EXTRACT(LEXSTR,LEXPSN)=","
SET LEXCHR=","
SET LEXOK=1
QUIT
+5 IF $EXTRACT(LEXSTR,LEXPSN)="/"
SET LEXCHR="/"
SET LEXOK=1
QUIT
+6 IF $EXTRACT(LEXSTR,LEXPSN)="-"
SET LEXCHR="-"
SET LEXOK=1
QUIT
End DoDot:1
IF +LEXOK=1
QUIT
+7 IF LEXCHR=" "
SET LEXSTO=$EXTRACT(LEXSTR,1,LEXPSN-1)
SET LEXREM=$EXTRACT(LEXSTR,LEXPSN+1,$LENGTH(LEXSTR))
+8 IF LEXCHR=","
SET LEXSTO=$EXTRACT(LEXSTR,1,LEXPSN)
SET LEXREM=$EXTRACT(LEXSTR,(LEXPSN+1),$LENGTH(LEXSTR))
IF $EXTRACT(LEXREM,1)=" "
SET LEXREM=$EXTRACT(LEXREM,2,$LENGTH(LEXREM))
+9 IF LEXCHR="/"
SET LEXSTO=$EXTRACT(LEXSTR,1,LEXPSN)
SET LEXREM=$EXTRACT(LEXSTR,(LEXPSN+1),$LENGTH(LEXSTR))
IF $EXTRACT(LEXREM,1)=" "
SET LEXREM=$EXTRACT(LEXREM,2,$LENGTH(LEXREM))
+10 IF LEXCHR="-"
SET LEXSTO=$EXTRACT(LEXSTR,1,LEXPSN)
SET LEXREM=$EXTRACT(LEXSTR,(LEXPSN+1),$LENGTH(LEXSTR))
IF $EXTRACT(LEXREM,1)=" "
SET LEXREM=$EXTRACT(LEXREM,2,$LENGTH(LEXREM))
+11 SET LEXSTR=LEXREM
+12 SET LEXLNN=LEXLNN+1
+13 IF LEXLNN>1
WRITE !
WRITE ?LEXP,LEXSTO
+14 QUIT
CODE(LEXEX,LEXSO) ; Returns codes (defined in XTLK^LEXPRNT) for a Term
+1 NEW LEXMC,LEXCREC,LEXI,LEXCID
SET (LEXI,LEXCID)=""
SET LEXCREC=0
+2 IF '$DATA(^LEX(757.01,LEXEX))
QUIT LEXCID
+3 SET LEXMC=$PIECE(^LEX(757.01,LEXEX,1),U,1)
+4 IF LEXSUB="WRD"
Begin DoDot:1
+5 FOR
SET LEXCREC=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXCREC))
IF +LEXCREC=0
QUIT
Begin DoDot:2
+6 IF $DATA(^LEX(757.02,"ASRC",LEXSO,LEXCREC))
Begin DoDot:3
+7 SET LEXI=$PIECE(^LEX(757.02,LEXCREC,0),U,2)
+8 IF LEXI'="NOCODE"
IF LEXI'?1"U"2"0"4N
IF LEXCID'[LEXI
Begin DoDot:4
+9 SET LEXCID=LEXCID_"/"_LEXI
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF LEXSUB'="WRD"
Begin DoDot:1
+11 FOR
SET LEXCREC=$ORDER(^LEX(757.02,"B",LEXEX,LEXCREC))
IF +LEXCREC=0
QUIT
Begin DoDot:2
+12 IF $DATA(^LEX(757.02,"ASRC",LEXSO,LEXCREC))
SET LEXI=$PIECE(^LEX(757.02,LEXCREC,0),U,2)
IF LEXI'="NOCODE"
IF LEXI'?1"U"2"0"4N
IF LEXCID'[LEXI
SET LEXCID=LEXCID_"/"_LEXI
End DoDot:2
End DoDot:1
+13 IF LEXCID'=""
SET LEXCID=LEXSO_" "_$EXTRACT(LEXCID,2,999)
+14 KILL LEXCREC,LEXMC,LEXI
+15 SET LEXEX=LEXCID
QUIT LEXEX
