- LEXPRNT ;ISL/KER - Print Utilities for the Lexicon ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- ; 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXPRNT 3710 printed Feb 18, 2025@23:34:25 Page 2
- LEXPRNT ;ISL/KER - Print Utilities for the Lexicon ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +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
