- LEXA3 ;ISL/KER - Look-up (Loud) Functions ;04/21/2014
- ;;2.0;LEXICON UTILITY;**1,4,80**;Sep 23, 1996;Build 10
- ;
- 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
- LEXA3 ;ISL/KER - Look-up (Loud) Functions ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**1,4,80**;Sep 23, 1996;Build 10
- +2 ;
- DH ; Display Help LEX("HLP")
- +1 IF '$DATA(LEX("HLP"))
- QUIT
- NEW LEXI
- SET LEXI=0
- +2 WRITE !
- FOR
- SET LEXI=$ORDER(LEX("HLP",LEXI))
- IF +LEXI=0
- QUIT
- Begin DoDot:1
- +3 WRITE !," ",LEX("HLP",LEXI)
- End DoDot:1
- +4 QUIT
- DL ; Display List LEX("LIST")
- +1 IF +($GET(LEX))=1
- IF $DATA(LEX("LIST",1))
- DO ONE
- QUIT
- +2 DO MULTI
- QUIT
- DP ; Display Prompt Select 1-LEX("MAX") or Ok?
- +1 NEW LEXPRMT
- +2 IF +($GET(LEX))>1
- Begin DoDot:1
- +3 SET LEXPRMT="Type ""^"" to STOP or Select: "
- +4 IF +($GET(LEX("MAX")))>0
- SET LEXPRMT="Type ""^"" to STOP or Select 1-"_LEX("MAX")_": "
- End DoDot:1
- +5 IF +($GET(LEX))=1
- SET LEXPRMT=" Ok? YES// "
- SET DIC("B")="YES"
- IF +($GET(LEX))>1
- WRITE !
- +6 WRITE !!,LEXPRMT
- QUIT
- +7 ;
- MULTI ; Multiple entries PCH 4 - LEXTP,LEXCT
- +1 NEW LEXI,LEXT,LEXTP,LEXCT,LEXL,LEXP
- +2 SET (LEXCT,LEXI)=0
- SET LEXL=70
- SET LEXP=7
- DO MATCH
- +3 WRITE !
- FOR
- SET LEXI=$ORDER(LEX("LIST",LEXI))
- IF +LEXI=0
- QUIT
- Begin DoDot:1
- +4 SET LEXCT=LEXCT+1
- SET LEXT=$PIECE(LEX("LIST",LEXI),"^",2)
- +5 SET LEXTP=$PIECE($GET(LEX("LIST",(LEXI-1))),"^",2)
- +6 ;W:LEXCT>1&($E(LEXT,1)=" ")&($E(LEXTP,1)'=" ")&($E(LEXTP,1)'="") !
- +7 ;W:LEXCT>1&($E(LEXT,1)'=" ")&($E(LEXTP,1)=" ") !
- +8 WRITE !,$JUSTIFY(LEXI,4),?6
- +9 NEW Y
- SET Y=+($GET(LEX("LIST",LEXI)))
- SET Y(0)=$GET(^LEX(757.01,+Y,0))
- SET Y(0,0)=$PIECE($GET(^LEX(757.01,+Y,0)),"^",1)
- +10 IF $DATA(DIC("W"))
- IF DIC("W")'=""
- XECUTE DIC("W")
- QUIT
- +11 IF $DATA(DIC("W"))
- IF DIC("W")=""
- WRITE Y(0,0)
- QUIT
- +12 IF $LENGTH(LEXT)<(LEXL+1)
- WRITE ?LEXP,LEXT
- IF $LENGTH(LEXT)>LEXL
- DO LONG
- End DoDot:1
- +13 QUIT
- MATCH ; Matches found
- +1 IF $DATA(LEX("MAT"))
- WRITE !!,LEX("MAT")
- KILL LEX("MAT")
- +2 QUIT
- ONE ; One entry
- +1 NEW LEXI,LEXT,LEXL,LEXP
- +2 SET LEXI=0
- SET LEXL=75
- SET LEXP=2
- SET LEXT=$PIECE(LEX("LIST",1),"^",2)
- WRITE !!
- +3 NEW Y
- SET Y=+($GET(LEX("LIST",LEXI)))
- SET Y(0)=$GET(^LEX(757.01,+Y,0))
- SET Y(0,0)=$PIECE($GET(^LEX(757.01,+Y,0)),"^",1)
- +4 IF $DATA(DIC("W"))
- IF DIC("W")'=""
- WRITE ?LEXP
- XECUTE DIC("W")
- QUIT
- +5 IF $DATA(DIC("W"))
- IF DIC("W")=""
- WRITE ?LEXP,Y(0,0)
- QUIT
- +6 IF '$DATA(DIC("W"))
- IF $LENGTH(LEXT)<(LEXL+1)
- WRITE ?LEXP,LEXT
- IF $LENGTH(LEXT)>LEXL
- DO LONG
- +7 QUIT
- LONG ; Handle a long string PCH 4 -> LEXD1,LEXD1
- +1 NEW LEXOK,LEXCHR,LEXPSN,LEXSTO,LEXREM,LEXLNN,LEXOLD,LEXC
- +2 NEW LEXWW,LEXD1,LEXD2
- +3 SET LEXLNN=0
- SET LEXOLD=LEXT
- SET LEXL=70
- SET LEXP=+($GET(LEXP))
- +4 SET LEXD1=""
- FOR LEXPSN=1:1
- IF $EXTRACT(LEXT,LEXPSN)'=" "!(LEXPSN>$LENGTH(LEXT))
- QUIT
- SET LEXD1=LEXD1_" "
- +5 SET LEXD2=LEXD1
- IF LEXT["
- SET LEXD2=LEXD2_" "
- +6 DO PARSE(LEXT,LEXL,LEXD1,LEXD2)
- +7 IF $DATA(LEXWW)
- IF $ORDER(LEXWW(0))>0
- FOR LEXC=1:1
- IF '$DATA(LEXWW(LEXC))
- QUIT
- Begin DoDot:1
- +8 IF LEXC>1
- WRITE !
- WRITE ?LEXP,LEXWW(LEXC)
- End DoDot:1
- +9 QUIT
- PARSE(LEXT,LEXL,LEXD1,LEXD2) ; Parse string
- +1 SET LEXT=$GET(LEXT)
- SET LEXL=+($GET(LEXL))
- SET LEXD1=$GET(LEXD1)
- SET LEXD2=$GET(LEXD2)
- +2 IF LEXT=""
- QUIT
- IF LEXL=0
- SET LEXL=70
- SET LEXL=LEXL-$LENGTH(LEXD1)
- +3 NEW LEXC
- SET LEXC=0
- FOR
- IF $LENGTH(LEXT)<(LEXL+1)
- QUIT
- Begin DoDot:1
- +4 SET LEXOK=0
- SET LEXCHR=""
- +5 FOR LEXPSN=LEXL:-1:0
- IF +LEXOK=1
- QUIT
- Begin DoDot:2
- +6 IF $EXTRACT(LEXT,LEXPSN)=" "
- SET LEXCHR=" "
- SET LEXOK=1
- QUIT
- +7 IF $EXTRACT(LEXT,LEXPSN)=","
- SET LEXCHR=","
- SET LEXOK=1
- QUIT
- +8 IF $EXTRACT(LEXT,LEXPSN)="/"!($EXTRACT(LEXT,LEXPSN)="-")!($EXTRACT(LEXT,LEXPSN)=")")
- SET LEXCHR=$EXTRACT(LEXT,LEXPSN)
- SET LEXOK=1
- QUIT
- End DoDot:2
- IF +LEXOK=1
- QUIT
- +9 SET LEXL=LEXL-($LENGTH(LEXD2)-$LENGTH(LEXD1))
- IF LEXCHR=" "
- DO SPL1
- +10 IF LEXCHR="/"!(LEXCHR=",")!(LEXCHR="-")!(LEXCHR=")")
- DO SPL2
- +11 IF 'LEXOK
- DO SPL4
- DO SPC
- +12 SET LEXT=LEXREM
- IF $LENGTH(LEXSTO)
- SET LEXC=LEXC+1
- IF LEXC=1
- SET LEXWW(LEXC)=(LEXD1_LEXSTO)
- IF LEXC>1
- SET LEXWW(LEXC)=(LEXD2_LEXSTO)
- End DoDot:1
- +13 IF $LENGTH(LEXT)
- SET LEXC=LEXC+1
- IF LEXC=1
- SET LEXWW(LEXC)=(LEXD1_LEXT)
- IF LEXC>1
- SET LEXWW(LEXC)=(LEXD2_LEXT)
- +14 QUIT
- SPL1 ; Split after character position
- +1 SET LEXSTO=$EXTRACT(LEXT,1,LEXPSN-1)
- SET LEXREM=$EXTRACT(LEXT,LEXPSN+1,$LENGTH(LEXT))
- DO SPL3
- DO SPC
- QUIT
- SPL2 ; Split at character position
- +1 SET LEXSTO=$EXTRACT(LEXT,1,LEXPSN)
- SET LEXREM=$EXTRACT(LEXT,(LEXPSN+1),$LENGTH(LEXT))
- DO SPL3
- DO SPC
- QUIT
- SPL3 ; Re-Split if STO<REM
- +1 IF $LENGTH(LEXSTO)<$LENGTH(LEXREM)&($LENGTH(LEXL)-$LENGTH(LEXSTO)>15)
- DO SPL4
- QUIT
- SPL4 ; Split at string length LEXL
- +1 SET LEXSTO=$EXTRACT(LEXT,1,LEXL)
- SET LEXREM=$EXTRACT(LEXT,(LEXL+1),$LENGTH(LEXT))
- QUIT
- SPC ; Remove Spaces
- +1 SET LEXSTO=$$TRIM(LEXSTO)
- SET LEXREM=$$TRIM(LEXREM)
- SET LEXOK=1
- QUIT
- TRIM(LEXX) ; Trim Spaces
- +1 SET LEXX=$GET(LEXX)
- IF LEXX'[" "
- QUIT LEXX
- IF LEXX=""
- QUIT LEXX
- +2 FOR
- IF $EXTRACT(LEXX,1)'=" "
- QUIT
- SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
- +3 IF $LENGTH(LEXX)
- FOR
- IF $EXTRACT(LEXX,$LENGTH(LEXX))'=" "
- QUIT
- SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))
- +4 QUIT LEXX
