source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA3.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1LEXA3 ; ISL Look-up (Loud) Functions ; 01-13-97
2 ;;2.0;LEXICON UTILITY;**1,4**;Sep 23, 1996
3 ;
4DH ; Display Help LEX("HLP")
5 Q:'$D(LEX("HLP")) N LEXI S LEXI=0
6 W ! F S LEXI=$O(LEX("HLP",LEXI)) Q:+LEXI=0 D
7 . W !," ",LEX("HLP",LEXI)
8 Q
9DL ; Display List LEX("LIST")
10 I +($G(LEX))=1,$D(LEX("LIST",1)) D ONE Q
11 D MULTI Q
12DP ; Display Prompt Select 1-LEX("MAX") or Ok?
13 N LEXPRMT
14 I +($G(LEX))>1 D
15 . S LEXPRMT="Type ""^"" to STOP or Select: "
16 . S:+($G(LEX("MAX")))>0 LEXPRMT="Type ""^"" to STOP or Select 1-"_LEX("MAX")_": "
17 I +($G(LEX))=1 S LEXPRMT=" Ok? YES// ",DIC("B")="YES" W:+($G(LEX))>1 !
18 W !!,LEXPRMT Q
19 ;
20MULTI ; Multiple entries PCH 4 - LEXTP,LEXCT
21 N LEXI,LEXT,LEXTP,LEXCT,LEXL,LEXP
22 S (LEXCT,LEXI)=0,LEXL=70,LEXP=7 D MATCH
23 W ! F S LEXI=$O(LEX("LIST",LEXI)) Q:+LEXI=0 D
24 . S LEXCT=LEXCT+1,LEXT=$P(LEX("LIST",LEXI),"^",2)
25 . S LEXTP=$P($G(LEX("LIST",(LEXI-1))),"^",2)
26 . ;W:LEXCT>1&($E(LEXT,1)=" ")&($E(LEXTP,1)'=" ")&($E(LEXTP,1)'="") !
27 . ;W:LEXCT>1&($E(LEXT,1)'=" ")&($E(LEXTP,1)=" ") !
28 . W !,$J(LEXI,4),?6
29 . N Y S Y=+($G(LEX("LIST",LEXI))),Y(0)=$G(^LEX(757.01,+Y,0)),Y(0,0)=$P($G(^LEX(757.01,+Y,0)),"^",1)
30 . I $D(DIC("W")),DIC("W")'="" X DIC("W") Q
31 . I $D(DIC("W")),DIC("W")="" W Y(0,0) Q
32 . W:$L(LEXT)<(LEXL+1) ?LEXP,LEXT D:$L(LEXT)>LEXL LONG
33 Q
34MATCH ; Matches found
35 I $D(LEX("MAT")) W !!,LEX("MAT") K LEX("MAT")
36 Q
37ONE ; One entry
38 N LEXI,LEXT,LEXL,LEXP
39 S LEXI=0,LEXL=75,LEXP=2,LEXT=$P(LEX("LIST",1),"^",2) W !!
40 N Y S Y=+($G(LEX("LIST",LEXI))),Y(0)=$G(^LEX(757.01,+Y,0)),Y(0,0)=$P($G(^LEX(757.01,+Y,0)),"^",1)
41 I $D(DIC("W")),DIC("W")'="" W ?LEXP X DIC("W") Q
42 I $D(DIC("W")),DIC("W")="" W ?LEXP,Y(0,0) Q
43 I '$D(DIC("W")) W:$L(LEXT)<(LEXL+1) ?LEXP,LEXT D:$L(LEXT)>LEXL LONG
44 Q
45LONG ; Handle a long string PCH 4 -> LEXD1,LEXD1
46 N LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD,LEXC
47 N LEXWW,LEXD1,LEXD2
48 S LEXLNN=0,LEXOLD=LEXT,LEXL=70,LEXP=+($G(LEXP))
49 S LEXD1="" F LEXPSN=1:1 Q:$E(LEXT,LEXPSN)'=" "!(LEXPSN>$L(LEXT)) S LEXD1=LEXD1_" "
50 S LEXD2=LEXD1 S:LEXT[": "&($L(LEXD1)) LEXD2=LEXD2_" "
51 D PARSE(LEXT,LEXL,LEXD1,LEXD2)
52 I $D(LEXWW),$O(LEXWW(0))>0 F LEXC=1:1 Q:'$D(LEXWW(LEXC)) D
53 . W:LEXC>1 ! W ?LEXP,LEXWW(LEXC)
54 Q
55PARSE(LEXT,LEXL,LEXD1,LEXD2) ; Parse string
56 S LEXT=$G(LEXT),LEXL=+($G(LEXL)),LEXD1=$G(LEXD1),LEXD2=$G(LEXD2)
57 Q:LEXT="" S:LEXL=0 LEXL=70 S LEXL=LEXL-$L(LEXD1)
58 N LEXC S LEXC=0 F Q:$L(LEXT)<(LEXL+1) D
59 . S LEXOK=0,LEXCHR=""
60 . F LEXPSN=LEXL:-1:0 Q:+LEXOK=1 D Q:+LEXOK=1
61 . . I $E(LEXT,LEXPSN)=" " S LEXCHR=" ",LEXOK=1 Q
62 . . I $E(LEXT,LEXPSN)="," S LEXCHR=",",LEXOK=1 Q
63 . . I $E(LEXT,LEXPSN)="/"!($E(LEXT,LEXPSN)="-")!($E(LEXT,LEXPSN)=")") S LEXCHR=$E(LEXT,LEXPSN),LEXOK=1 Q
64 . S LEXL=LEXL-($L(LEXD2)-$L(LEXD1)) D:LEXCHR=" " SPL1
65 . D:LEXCHR="/"!(LEXCHR=",")!(LEXCHR="-")!(LEXCHR=")") SPL2
66 . D:'LEXOK SPL4,SPC
67 . S LEXT=LEXREM I $L(LEXSTO) S LEXC=LEXC+1 S:LEXC=1 LEXWW(LEXC)=(LEXD1_LEXSTO) S:LEXC>1 LEXWW(LEXC)=(LEXD2_LEXSTO)
68 I $L(LEXT) S LEXC=LEXC+1 S:LEXC=1 LEXWW(LEXC)=(LEXD1_LEXT) S:LEXC>1 LEXWW(LEXC)=(LEXD2_LEXT)
69 Q
70SPL1 ; Split after character position
71 S LEXSTO=$E(LEXT,1,LEXPSN-1),LEXREM=$E(LEXT,LEXPSN+1,$L(LEXT)) D SPL3,SPC Q
72SPL2 ; Split at character position
73 S LEXSTO=$E(LEXT,1,LEXPSN),LEXREM=$E(LEXT,(LEXPSN+1),$L(LEXT)) D SPL3,SPC Q
74SPL3 ; Re-Split if STO<REM
75 D:$L(LEXSTO)<$L(LEXREM)&($L(LEXL)-$L(LEXSTO)>15) SPL4 Q
76SPL4 ; Split at string length LEXL
77 S LEXSTO=$E(LEXT,1,LEXL),LEXREM=$E(LEXT,(LEXL+1),$L(LEXT)) Q
78SPC ; Remove Spaces
79 S LEXSTO=$$TRIM(LEXSTO),LEXREM=$$TRIM(LEXREM) S LEXOK=1 Q
80TRIM(LEXX) ; Trim Spaces
81 S LEXX=$G(LEXX) Q:LEXX'[" " LEXX Q:LEXX="" LEXX
82 F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
83 I $L(LEXX) F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
84 Q LEXX
Note: See TracBrowser for help on using the repository browser.