LEXERI ;ISL/KER - Exc/Rep Word Input Transformations ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; $$UP^XLFSTR ICR 10103
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
; ^DIK ICR 10013
;
Q
EXC ; Input transformation for ^LEX(757.04, - .01
Q:'$D(X) S LEXX=X
I LEXX[" " D K X Q
. W !,$C(34),X,$C(34)," contains a space"
S LEXX=$$CVT(LEXX)
I $D(^LEX(757.04,"AB",$E(LEXX,1,40))) D Q
. N LEXDA S LEXDA=$G(DA) I +LEXDA>0,$D(^LEX(757.04,"AB",$E(LEXX,1,40),LEXDA)) Q
. W !,$C(34),LEXX,$C(34)," is already defined as an excluded word" K X
I $D(^LEX(757.05,"AB",$E(LEXX,1,40))) D Q
. W !,$C(34),LEXX,$C(34)," has been defined as a replacement word (file #757.05)"
. W !!,"You can not exclude a word from a search which is to be replaced"
. W !,"by another expression prior to performing the search"
I $D(^LEX(757.05,"C",$E($$UP^XLFSTR(LEXX),1,40))) D K X Q
. W !,$C(34),LEXX,$C(34)," has been defined as a replacement word (file #757.05)"
. W !!,"You can not exclude a word from a search which is to be inserted"
. W !,"as replacement text prior to performing the search"
S X=LEXX
Q
REP ; Input Transformation for ^LEX(757.05, - .01
Q:'$D(X) S LEXX=X
N LEXOK,LEXPSN S LEXOK=1 F LEXPSN=1:1:$L(LEXX) D
. I $E(LEXX,LEXPSN)'?1A&($E(LEXX,LEXPSN)'="/") S LEXOK=0
I 'LEXOK D K X Q
. W !,"Alpha-numeric expression. The only punctuation allowed is the slash ""/"""
S LEXX=$$CVT(LEXX)
I $D(^LEX(757.04,"AB",$E(X,1,40))) N LEX S LEX=0 D I 'LEX K X Q
. W !!,$C(7),$C(34),LEXX,$C(34)," already exist in the Excluded Words file."
. W !,"Do you want to delete it from the Excluded Words file"
. W !,"and continue to add it as a replacement word? No// "
REP2 . R LEX:300 I '$T!(LEX="")!(LEX[U) S LEX=0 Q
. I LEX["?" D G REP2
. . W !!,"Yes",!,"Add ",LEXX," to the Replacement Words file and delete it",!,"from the Excluded Words file"
. . W !!,"No",!,"Do not add ",LEXX," to the Replacement Words file and ",!,"retain it in the Excluded Words file"
. . W !!,"",!,"Delete? No// "
. I $E(LEX,1)'="Y"&($E(LEX,1)'="N")&($E(LEX,1)'="y")&($E(LEX,1)'="n") W !!,"",!,"Delete? No// " G REP2
. I $E(LEX,1)="Y"!($E(LEX,1)="y") S LEX=1 D Q
. . S ZTSAVE("X")="",ZTRTN="DEXC^LEXERI",ZTDESC="Deleting "_X_" from Excluded Words file #757.04"
. . S ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS W:$D(ZTSK) !!,"Deleting "_X_" from Excluded Words file #757.04" K Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
. S LEX=0
I $D(^LEX(757.05,"AB",$E(X,1,40))) D K:+($G(LEX)) LEX,LEXR Q
. I $O(^LEX(757.05,"AB",$E(X,1,40),0))=+DA Q
. S (LEX,LEXR)=0 F S LEXR=$O(^LEX(757.05,"AB",$E(X,1,40),LEXR)) D Q:+LEXR=0
. . I +LEXR>0,$D(^LEX(757.05,LEXR,0)),$P(^LEX(757.05,LEXR,0),"^",3)="R" D S LEXR=0
. . . W !!,$C(34),LEXX,$C(34)," already exist in the Replacement Words file (#757.05)"
. . . W !,"as a (R)eplaced word. You may alter the original entry to be a"
. . . W !,"(L)inked word, but you can not (R)eplace ",$C(34),LEXX,$C(34)," with multiple"
. . . W !,"expressions/concepts",!!
. . . S LEX=1
S X=LEXX
Q
DEXC ; Delete entry from Excluded Words file #757.04
Q:'$D(X) Q:'$D(^LEX(757.04,"AB",$E(X,1,40))) S DA=$O(^LEX(757.04,"AB",$E(X,1,40),0)),DIK="^LEX(757.04," D ^DIK K DA,DIK S:$D(ZTQUEUED) ZTREQ="@" Q
REPBY ; Input Transformation for ^LEX(757.05, - 1
Q:'$D(X) N LEXX S LEXX=$$CVT(X)
Q:$D(^LEX(757.05,"C",$E(LEXX,1,40),DA))
I '+($$EXIST^LEXERF(LEXX)) D K X,LEXX Q
. W !!,$C(34),LEXX,$C(34)," does not exist in the Lexicon. You"
. W !,"may not replace a word with text not found in the Lexicon,"
. W !,"resulting in unsuccessful searches."
N LEXOK,LEXJ,LEXI S (LEXOK,LEXJ)=1,LEXI=""
F S LEXI=$P(LEXX," ",LEXJ) D S LEXJ=LEXJ+1 I 'LEXOK!($P(LEXX," ",LEXJ)="") Q
. I $D(^LEX(757.05,"AB",$E(LEXI,1,40))) D
. . N LEXR S LEXR=0 W !,LEXI
. . F S LEXR=$O(^LEX(757.05,"AB",$E(LEXI,1,40),LEXR)) D Q:+LEXR=0
. . . I +LEXR'=0,$D(^LEX(757.05,LEXR,0)),$P(^LEX(757.05,LEXR,0),"^",3)="R" D S LEXR=0
. . . . W !!,"WARNING: Your input contains the word ",$C(34),LEXI,$C(34)," which is"
. . . . W !,"already defined in the Replacement Words file (#757.05) as a (R)eplaced"
. . . . W !,"word. This may cause problems (i.e., circular definition of a word) "
. . . . W !,"resulting in an unsuccessful search in the Lexicon."
. . . . W !!," Example of a circular definition:"
. . . . W !!," Replace: CA with CANCER and"
. . . . W !," Replace: CALCIUM with CA ",!!
. . . . W !!," Searching for ",$C(34),"CALCIUM",$C(34)," may result in a listing of CANCER's,"
. . . . W !," depending on the order of replacement."
. . . . S LEXOK=0
S X=LEXX K:'LEXOK X K LEXOK,LEXI,LEXJ,LEXR,LEXX
Q
CVT(LEXX) ; Convert Text
S LEXX=$$UP^XLFSTR(LEXX) N LEXI,LEXJ S LEXJ="" F LEXI=1:1:$L(LEXX) D
. I $A($E(LEXX,LEXI))=47!($A($E(LEXX,LEXI))>64&($A($E(LEXX,LEXI))<91)) S LEXJ=LEXJ_$E(LEXX,LEXI)
. E S LEXJ=LEXJ_" "
S LEXX=LEXJ K LEXI,LEXJ Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXERI 5169 printed Oct 16, 2024@18:08:43 Page 2
LEXERI ;ISL/KER - Exc/Rep Word Input Transformations ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$UP^XLFSTR ICR 10103
+8 ; HOME^%ZIS ICR 10086
+9 ; ^%ZTLOAD ICR 10063
+10 ; ^DIK ICR 10013
+11 ;
+12 QUIT
EXC ; Input transformation for ^LEX(757.04, - .01
+1 if '$DATA(X)
QUIT
SET LEXX=X
+2 IF LEXX[" "
Begin DoDot:1
+3 WRITE !,$CHAR(34),X,$CHAR(34)," contains a space"
End DoDot:1
KILL X
QUIT
+4 SET LEXX=$$CVT(LEXX)
+5 IF $DATA(^LEX(757.04,"AB",$EXTRACT(LEXX,1,40)))
Begin DoDot:1
+6 NEW LEXDA
SET LEXDA=$GET(DA)
IF +LEXDA>0
IF $DATA(^LEX(757.04,"AB",$EXTRACT(LEXX,1,40),LEXDA))
QUIT
+7 WRITE !,$CHAR(34),LEXX,$CHAR(34)," is already defined as an excluded word"
KILL X
End DoDot:1
QUIT
+8 IF $DATA(^LEX(757.05,"AB",$EXTRACT(LEXX,1,40)))
Begin DoDot:1
+9 WRITE !,$CHAR(34),LEXX,$CHAR(34)," has been defined as a replacement word (file #757.05)"
+10 WRITE !!,"You can not exclude a word from a search which is to be replaced"
+11 WRITE !,"by another expression prior to performing the search"
End DoDot:1
QUIT
+12 IF $DATA(^LEX(757.05,"C",$EXTRACT($$UP^XLFSTR(LEXX),1,40)))
Begin DoDot:1
+13 WRITE !,$CHAR(34),LEXX,$CHAR(34)," has been defined as a replacement word (file #757.05)"
+14 WRITE !!,"You can not exclude a word from a search which is to be inserted"
+15 WRITE !,"as replacement text prior to performing the search"
End DoDot:1
KILL X
QUIT
+16 SET X=LEXX
+17 QUIT
REP ; Input Transformation for ^LEX(757.05, - .01
+1 if '$DATA(X)
QUIT
SET LEXX=X
+2 NEW LEXOK,LEXPSN
SET LEXOK=1
FOR LEXPSN=1:1:$LENGTH(LEXX)
Begin DoDot:1
+3 IF $EXTRACT(LEXX,LEXPSN)'?1A&($EXTRACT(LEXX,LEXPSN)'="/")
SET LEXOK=0
End DoDot:1
+4 IF 'LEXOK
Begin DoDot:1
+5 WRITE !,"Alpha-numeric expression. The only punctuation allowed is the slash ""/"""
End DoDot:1
KILL X
QUIT
+6 SET LEXX=$$CVT(LEXX)
+7 IF $DATA(^LEX(757.04,"AB",$EXTRACT(X,1,40)))
NEW LEX
SET LEX=0
Begin DoDot:1
+8 WRITE !!,$CHAR(7),$CHAR(34),LEXX,$CHAR(34)," already exist in the Excluded Words file."
+9 WRITE !,"Do you want to delete it from the Excluded Words file"
+10 WRITE !,"and continue to add it as a replacement word? No// "
REP2 READ LEX:300
IF '$TEST!(LEX="")!(LEX[U)
SET LEX=0
QUIT
+1 IF LEX["?"
Begin DoDot:2
+2 WRITE !!,"Yes",!,"Add ",LEXX," to the Replacement Words file and delete it",!,"from the Excluded Words file"
+3 WRITE !!,"No",!,"Do not add ",LEXX," to the Replacement Words file and ",!,"retain it in the Excluded Words file"
+4 WRITE !!,"",!,"Delete? No// "
End DoDot:2
GOTO REP2
+5 IF $EXTRACT(LEX,1)'="Y"&($EXTRACT(LEX,1)'="N")&($EXTRACT(LEX,1)'="y")&($EXTRACT(LEX,1)'="n")
WRITE !!,"",!,"Delete? No// "
GOTO REP2
+6 IF $EXTRACT(LEX,1)="Y"!($EXTRACT(LEX,1)="y")
SET LEX=1
Begin DoDot:2
+7 SET ZTSAVE("X")=""
SET ZTRTN="DEXC^LEXERI"
SET ZTDESC="Deleting "_X_" from Excluded Words file #757.04"
+8 SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
if $DATA(ZTSK)
WRITE !!,"Deleting "_X_" from Excluded Words file #757.04"
KILL Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
End DoDot:2
QUIT
+9 SET LEX=0
End DoDot:1
IF 'LEX
KILL X
QUIT
+10 IF $DATA(^LEX(757.05,"AB",$EXTRACT(X,1,40)))
Begin DoDot:1
+11 IF $ORDER(^LEX(757.05,"AB",$EXTRACT(X,1,40),0))=+DA
QUIT
+12 SET (LEX,LEXR)=0
FOR
SET LEXR=$ORDER(^LEX(757.05,"AB",$EXTRACT(X,1,40),LEXR))
Begin DoDot:2
+13 IF +LEXR>0
IF $DATA(^LEX(757.05,LEXR,0))
IF $PIECE(^LEX(757.05,LEXR,0),"^",3)="R"
Begin DoDot:3
+14 WRITE !!,$CHAR(34),LEXX,$CHAR(34)," already exist in the Replacement Words file (#757.05)"
+15 WRITE !,"as a (R)eplaced word. You may alter the original entry to be a"
+16 WRITE !,"(L)inked word, but you can not (R)eplace ",$CHAR(34),LEXX,$CHAR(34)," with multiple"
+17 WRITE !,"expressions/concepts",!!
+18 SET LEX=1
End DoDot:3
SET LEXR=0
End DoDot:2
if +LEXR=0
QUIT
End DoDot:1
if +($GET(LEX))
KILL LEX,LEXR
QUIT
+19 SET X=LEXX
+20 QUIT
DEXC ; Delete entry from Excluded Words file #757.04
+1 if '$DATA(X)
QUIT
if '$DATA(^LEX(757.04,"AB",$EXTRACT(X,1,40)))
QUIT
SET DA=$ORDER(^LEX(757.04,"AB",$EXTRACT(X,1,40),0))
SET DIK="^LEX(757.04,"
DO ^DIK
KILL DA,DIK
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
REPBY ; Input Transformation for ^LEX(757.05, - 1
+1 if '$DATA(X)
QUIT
NEW LEXX
SET LEXX=$$CVT(X)
+2 if $DATA(^LEX(757.05,"C",$EXTRACT(LEXX,1,40),DA))
QUIT
+3 IF '+($$EXIST^LEXERF(LEXX))
Begin DoDot:1
+4 WRITE !!,$CHAR(34),LEXX,$CHAR(34)," does not exist in the Lexicon. You"
+5 WRITE !,"may not replace a word with text not found in the Lexicon,"
+6 WRITE !,"resulting in unsuccessful searches."
End DoDot:1
KILL X,LEXX
QUIT
+7 NEW LEXOK,LEXJ,LEXI
SET (LEXOK,LEXJ)=1
SET LEXI=""
+8 FOR
SET LEXI=$PIECE(LEXX," ",LEXJ)
Begin DoDot:1
+9 IF $DATA(^LEX(757.05,"AB",$EXTRACT(LEXI,1,40)))
Begin DoDot:2
+10 NEW LEXR
SET LEXR=0
WRITE !,LEXI
+11 FOR
SET LEXR=$ORDER(^LEX(757.05,"AB",$EXTRACT(LEXI,1,40),LEXR))
Begin DoDot:3
+12 IF +LEXR'=0
IF $DATA(^LEX(757.05,LEXR,0))
IF $PIECE(^LEX(757.05,LEXR,0),"^",3)="R"
Begin DoDot:4
+13 WRITE !!,"WARNING: Your input contains the word ",$CHAR(34),LEXI,$CHAR(34)," which is"
+14 WRITE !,"already defined in the Replacement Words file (#757.05) as a (R)eplaced"
+15 WRITE !,"word. This may cause problems (i.e., circular definition of a word) "
+16 WRITE !,"resulting in an unsuccessful search in the Lexicon."
+17 WRITE !!," Example of a circular definition:"
+18 WRITE !!," Replace: CA with CANCER and"
+19 WRITE !," Replace: CALCIUM with CA ",!!
+20 WRITE !!," Searching for ",$CHAR(34),"CALCIUM",$CHAR(34)," may result in a listing of CANCER's,"
+21 WRITE !," depending on the order of replacement."
+22 SET LEXOK=0
End DoDot:4
SET LEXR=0
End DoDot:3
if +LEXR=0
QUIT
End DoDot:2
End DoDot:1
SET LEXJ=LEXJ+1
IF 'LEXOK!($PIECE(LEXX," ",LEXJ)="")
QUIT
+23 SET X=LEXX
if 'LEXOK
KILL X
KILL LEXOK,LEXI,LEXJ,LEXR,LEXX
+24 QUIT
CVT(LEXX) ; Convert Text
+1 SET LEXX=$$UP^XLFSTR(LEXX)
NEW LEXI,LEXJ
SET LEXJ=""
FOR LEXI=1:1:$LENGTH(LEXX)
Begin DoDot:1
+2 IF $ASCII($EXTRACT(LEXX,LEXI))=47!($ASCII($EXTRACT(LEXX,LEXI))>64&($ASCII($EXTRACT(LEXX,LEXI))<91))
SET LEXJ=LEXJ_$EXTRACT(LEXX,LEXI)
+3 IF '$TEST
SET LEXJ=LEXJ_" "
End DoDot:1
+4 SET LEXX=LEXJ
KILL LEXI,LEXJ
QUIT LEXX
