LEXA3 ;ISL/KER - Look-up (Loud) Functions ;04/21/2014
;;2.0;LEXICON UTILITY;**1,4,80**;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXA3 3836 printed Dec 13, 2024@02:06:50 Page 2
LEXA3 ;ISL/KER - Look-up (Loud) Functions ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**1,4,80**;Sep 23, 1996;Build 1
+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
