source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPRNT.m@ 1361

Last change on this file since 1361 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1LEXPRNT ; ISL Print Utilities for the Lexicon ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4XTLK ; XTLK Display format for MTLU
5 ; Uses XTLKH, XTLKMULT, XTLKREF0, LEXSHOW
6 N LEXIFN,LEXEXP,LEXCODE,LEXSOID
7 S LEXIFN=0,LEXEXP=-1 S:'$D(LEXSHOW) LEXSHOW=""
8 S:'$D(LEXSUB) LEXSUB="WRD"
9 S (LEXEXP,LEXIFN)=+($P(XTLKREF0,",",2)) G:+LEXIFN'>0 XTQ
10 D:XTLKMULT MULTI
11 D:'XTLKMULT ONE
12XTQ K LEXCODE,LEXSOID,LEXIFN,LEXEXP
13 Q
14MULTI ; Multiple entries on the selection list
15 N LEXNUM,LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
16 S LEXNUM=XTLKH,(LEXSTR,LEXDP,LEXCCS)="",LEXL=70,LEXP=7
17 D COMMON
18 W:LEXNUM>1 ! W:LEXNUM>1&(LEXNUM#5=1) !
19 W $J(LEXNUM,4),":" W:$L(LEXSTR)<(LEXL+1) ?LEXP,LEXSTR
20 D:$L(LEXSTR)>LEXL LONG
21 W:LEXNUM#5=0&(+($G(LEXHLPF))=0) !
22 W:LEXNUM#5'=0&(LEXNUM=+($G(^TMP("XTLKHITS",$J))))&(+($G(LEXHLPF))=0) !
23 Q
24ONE ; One entry on the selection list
25 N LEXSTR,LEXDP,LEXCCS,LEXL,LEXP
26 S (LEXSTR,LEXDP,LEXCCS)="",LEXL=75,LEXP=2
27 D COMMON
28 W:$L(LEXSTR)<(LEXL+1) ?LEXP,LEXSTR
29 D:$L(LEXSTR)>LEXL LONG
30 Q
31COMMON ; Parse LEXSHOW for both MULTI and ONE
32 S:LEXSUB="WRD" LEXSTR=^LEX(757.01,LEXEXP,0)
33 S:LEXSUB'="WRD" LEXSTR=^LEX(757.01,+(@(DIC_LEXEXP_",0)")),0)
34 S LEXDP=$S($D(^LEX(757.01,$S(LEXSUB="WRD":LEXEXP,1:+(@(DIC_LEXEXP_",0)"))),3)):" *",1:"")
35 I LEXSUB'="WRD" S LEXEXP=+(@(DIC_LEXEXP_",0)"))
36 I $D(LEXSHOW),LEXSHOW'="" F LEXSOID=1:1:$L(LEXSHOW,"/") D
37 . S LEXCODE=$P(LEXSHOW,"/",LEXSOID) N @LEXCODE S @LEXCODE=""
38 . S @LEXCODE=$S(LEXSUB="WRD":$$CODE(LEXIFN,LEXCODE),1:$$CODE(LEXEXP,LEXCODE))
39 . I @LEXCODE'="" S LEXCCS=LEXCCS_" ("_@LEXCODE_")"
40 S LEXSTR=LEXSTR_LEXDP_LEXCCS
41 Q
42LONG ; Handle a long string
43 N LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD S LEXLNN=0,LEXOLD=LEXSTR
44 F Q:$L(LEXSTR)<(LEXL+1) D PARSE Q:$L(LEXSTR)<(LEXL+1)
45 S LEXLNN=LEXLNN+1
46 W:LEXLNN>1 ! W ?LEXP,LEXSTR
47 Q
48PARSE ; Parse a long string into screen length strings
49 S LEXOK=0,LEXCHR=""
50 F LEXPSN=LEXL:-1:0 Q:+LEXOK=1 D Q:+LEXOK=1
51 . I $E(LEXSTR,LEXPSN)=" " S LEXCHR=" ",LEXOK=1 Q
52 . I $E(LEXSTR,LEXPSN)="," S LEXCHR=",",LEXOK=1 Q
53 . I $E(LEXSTR,LEXPSN)="/" S LEXCHR="/",LEXOK=1 Q
54 . I $E(LEXSTR,LEXPSN)="-" S LEXCHR="-",LEXOK=1 Q
55 I LEXCHR=" " S LEXSTO=$E(LEXSTR,1,LEXPSN-1),LEXREM=$E(LEXSTR,LEXPSN+1,$L(LEXSTR))
56 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))
57 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))
58 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))
59 S LEXSTR=LEXREM
60 S LEXLNN=LEXLNN+1
61 W:LEXLNN>1 ! W ?LEXP,LEXSTO
62 Q
63CODE(LEXEX,LEXSO) ; Returns codes (defined in XTLK^LEXPRNT) for a Term
64 N LEXMC,LEXCREC,LEXI,LEXCID S (LEXI,LEXCID)="",LEXCREC=0
65 I '$D(^LEX(757.01,LEXEX)) Q LEXCID
66 S LEXMC=$P(^LEX(757.01,LEXEX,1),U,1)
67 I LEXSUB="WRD" D
68 . F S LEXCREC=$O(^LEX(757.02,"AMC",LEXMC,LEXCREC)) Q:+LEXCREC=0 D
69 . . I $D(^LEX(757.02,"ASRC",LEXSO,LEXCREC)) D
70 . . . S LEXI=$P(^LEX(757.02,LEXCREC,0),U,2)
71 . . . I LEXI'="NOCODE",LEXI'?1"U"2"0"4N,LEXCID'[LEXI D
72 . . . . S LEXCID=LEXCID_"/"_LEXI
73 I LEXSUB'="WRD" D
74 . F S LEXCREC=$O(^LEX(757.02,"B",LEXEX,LEXCREC)) Q:+LEXCREC=0 D
75 . . 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
76 S:LEXCID'="" LEXCID=LEXSO_" "_$E(LEXCID,2,999)
77 K LEXCREC,LEXMC,LEXI
78 S LEXEX=LEXCID Q LEXEX
Note: See TracBrowser for help on using the repository browser.