source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA3.m@ 1714

LEXA3 ; ISL Look-up (Loud) Functions             ; 01-13-97
 ;;2.0;LEXICON UTILITY;**1,4**;Sep 23, 1996;Build 1
 ;
DH ; Display Help                 LEX("HLP")
 Q:'$D(LEX("HLP"))  N LEXI S LEXI=0
 W ! F  S LEXI=$O(LEX("HLP",LEXI)) Q:+LEXI=0  D
 . W !,"  ",LEX("HLP",LEXI)
 Q
DL ; Display List                 LEX("LIST")
 I +($G(LEX))=1,$D(LEX("LIST",1)) D ONE Q
 D MULTI Q
DP ; Display Prompt      Select 1-LEX("MAX") or Ok?
 N LEXPRMT
 I +($G(LEX))>1 D
 . S LEXPRMT="Type ""^"" to STOP or Select:  "
 . S:+($G(LEX("MAX")))>0 LEXPRMT="Type ""^"" to STOP or Select 1-"_LEX("MAX")_":  "
 I +($G(LEX))=1 S LEXPRMT="    Ok?  YES//  ",DIC("B")="YES" W:+($G(LEX))>1 !
 W !!,LEXPRMT Q
 ;
MULTI ; Multiple entries       PCH 4 - LEXTP,LEXCT
 N LEXI,LEXT,LEXTP,LEXCT,LEXL,LEXP
 S (LEXCT,LEXI)=0,LEXL=70,LEXP=7 D MATCH
 W ! F  S LEXI=$O(LEX("LIST",LEXI)) Q:+LEXI=0  D
 . S LEXCT=LEXCT+1,LEXT=$P(LEX("LIST",LEXI),"^",2)
 . S LEXTP=$P($G(LEX("LIST",(LEXI-1))),"^",2)
 . ;W:LEXCT>1&($E(LEXT,1)=" ")&($E(LEXTP,1)'=" ")&($E(LEXTP,1)'="") !
 . ;W:LEXCT>1&($E(LEXT,1)'=" ")&($E(LEXTP,1)=" ") !
 . W !,$J(LEXI,4),?6
 . 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)
 . I $D(DIC("W")),DIC("W")'="" X DIC("W") Q
 . I $D(DIC("W")),DIC("W")="" W Y(0,0) Q
 . W:$L(LEXT)<(LEXL+1) ?LEXP,LEXT D:$L(LEXT)>LEXL LONG
 Q
MATCH ; Matches found
 I $D(LEX("MAT")) W !!,LEX("MAT") K LEX("MAT")
 Q
ONE ; One entry
 N LEXI,LEXT,LEXL,LEXP
 S LEXI=0,LEXL=75,LEXP=2,LEXT=$P(LEX("LIST",1),"^",2) W !!
 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)
 I $D(DIC("W")),DIC("W")'="" W ?LEXP X DIC("W") Q
 I $D(DIC("W")),DIC("W")="" W ?LEXP,Y(0,0) Q
 I '$D(DIC("W")) W:$L(LEXT)<(LEXL+1) ?LEXP,LEXT D:$L(LEXT)>LEXL LONG
 Q
LONG ; Handle a long string  PCH 4 -> LEXD1,LEXD1
 N LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD,LEXC
 N LEXWW,LEXD1,LEXD2
 S LEXLNN=0,LEXOLD=LEXT,LEXL=70,LEXP=+($G(LEXP))
 S LEXD1="" F LEXPSN=1:1 Q:$E(LEXT,LEXPSN)'=" "!(LEXPSN>$L(LEXT))  S LEXD1=LEXD1_" "
 S LEXD2=LEXD1 S:LEXT[":  "&($L(LEXD1)) LEXD2=LEXD2_"          "
 D PARSE(LEXT,LEXL,LEXD1,LEXD2)
 I $D(LEXWW),$O(LEXWW(0))>0 F LEXC=1:1 Q:'$D(LEXWW(LEXC))  D
 . W:LEXC>1 ! W ?LEXP,LEXWW(LEXC)
 Q
PARSE(LEXT,LEXL,LEXD1,LEXD2) ; Parse string
 S LEXT=$G(LEXT),LEXL=+($G(LEXL)),LEXD1=$G(LEXD1),LEXD2=$G(LEXD2)
 Q:LEXT=""  S:LEXL=0 LEXL=70 S LEXL=LEXL-$L(LEXD1)
 N LEXC S LEXC=0 F  Q:$L(LEXT)<(LEXL+1)  D
 . S LEXOK=0,LEXCHR=""
 . F LEXPSN=LEXL:-1:0 Q:+LEXOK=1  D  Q:+LEXOK=1
 . . I $E(LEXT,LEXPSN)=" " S LEXCHR=" ",LEXOK=1 Q
 . . I $E(LEXT,LEXPSN)="," S LEXCHR=",",LEXOK=1 Q
 . . I $E(LEXT,LEXPSN)="/"!($E(LEXT,LEXPSN)="-")!($E(LEXT,LEXPSN)=")") S LEXCHR=$E(LEXT,LEXPSN),LEXOK=1 Q
 . S LEXL=LEXL-($L(LEXD2)-$L(LEXD1)) D:LEXCHR=" " SPL1
 . D:LEXCHR="/"!(LEXCHR=",")!(LEXCHR="-")!(LEXCHR=")") SPL2
 . D:'LEXOK SPL4,SPC
 . S LEXT=LEXREM I $L(LEXSTO) S LEXC=LEXC+1 S:LEXC=1 LEXWW(LEXC)=(LEXD1_LEXSTO) S:LEXC>1 LEXWW(LEXC)=(LEXD2_LEXSTO)
 I $L(LEXT) S LEXC=LEXC+1 S:LEXC=1 LEXWW(LEXC)=(LEXD1_LEXT) S:LEXC>1 LEXWW(LEXC)=(LEXD2_LEXT)
 Q
SPL1 ; Split after character position
 S LEXSTO=$E(LEXT,1,LEXPSN-1),LEXREM=$E(LEXT,LEXPSN+1,$L(LEXT)) D SPL3,SPC Q
SPL2 ; Split at character position
 S LEXSTO=$E(LEXT,1,LEXPSN),LEXREM=$E(LEXT,(LEXPSN+1),$L(LEXT)) D SPL3,SPC Q
SPL3 ; Re-Split if STO<REM
 D:$L(LEXSTO)<$L(LEXREM)&($L(LEXL)-$L(LEXSTO)>15) SPL4 Q
SPL4 ; Split at string length LEXL
 S LEXSTO=$E(LEXT,1,LEXL),LEXREM=$E(LEXT,(LEXL+1),$L(LEXT)) Q
SPC ; Remove Spaces
 S LEXSTO=$$TRIM(LEXSTO),LEXREM=$$TRIM(LEXREM) S LEXOK=1 Q
TRIM(LEXX) ; Trim Spaces
 S LEXX=$G(LEXX) Q:LEXX'[" " LEXX Q:LEXX="" LEXX
 F  Q:$E(LEXX,1)'=" "  S LEXX=$E(LEXX,2,$L(LEXX))
 I $L(LEXX) F  Q:$E(LEXX,$L(LEXX))'=" "  S LEXX=$E(LEXX,1,($L(LEXX)-1))
 Q LEXX