LEXDFSI ;ISL/KER - Default Filter - Include Semantics ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; ^DIR ICR 10026
;
; Called from LEXDFSB (set the INCLUDE/EXCLUDE string)
;
; LEXC Counter
; LEXCC Semantic Class Mnemonic
; LEXCCN Semantic Class Counter
; LEXCCOK Semantic Class OK (Y/N)
; LEXCCR Semantic Class Pointer in #757.11
; LEXF Flag for user input
; LEXS Semantic Type Sources from #757.03
; LEXX String returned to LEXDSTS
;
EN(LEXX) ; Semantic Type string INCLUDE/EXCLUDE
K LEXA N LEXF S LEXX="",LEXF=1
D CLASS Q LEXX
;
CLASS ; Semantic Classes
N LEXCCOK,LEXCC,LEXCCR,LEXCCN S (LEXCCOK,LEXCC)=""
F S LEXCC=$O(^LEX(757.11,"B",LEXCC)) Q:LEXCC=""!(LEXCCOK[U) D
. S LEXCCOK=0 I LEXCC'="UNK" D Q:LEXCCOK[U
. . S LEXCCR=$$IEN(LEXCC),LEXCCN=+($G(LEXCCN))+1
. . W !!,$J(LEXCCN,2),": ",$$CC(LEXCCR)," ",$$NAME(LEXCCR),!
. . D SY(LEXCCR),CAT(LEXCCR)
. . D:+($G(LEXF)) INCLUDE I LEXCCOK D SAVE(LEXCCR)
. Q:LEXCCOK["^" I LEXCCOK D EXCLUDE
I +($G(LEXF))>0 S LEXX=LEXCCOK
Q
;
SY(LEXX) ; List Classification Systems
N LEXS,LEXC Q:'$D(^LEX(757.11,LEXX,2,"B")) S LEXS="",LEXC=0
W !!,?4,"This Semantic Class contains terms from, or mapped to,"
W !,?4,"the following classification systems: ",!
F S LEXS=$O(^LEX(757.11,LEXX,2,"B",LEXS)) Q:LEXS="" D
. S LEXC=LEXC+1 W:LEXC=1 ! W:LEXC=1 ?8,LEXS
. W:LEXC=2 ?32,LEXS W:LEXC=3 ?56,LEXS S:LEXC=3 LEXC=0
W ! Q
CAT(LEXX) ; List semantic types
N LEXC S LEXC=0 Q:'$D(^LEX(757.11,LEXX,1,0))
W !!,?4,"Semantic Types: ",!
F S LEXC=$O(^LEX(757.11,LEXX,1,LEXC)) Q:+LEXC=0 D
. W !,?4,^LEX(757.11,LEXX,1,LEXC,0)
Q
CC(LEXX) ; Semantic Class Mnemonic
Q $P(^LEX(757.11,LEXX,0),U,1)
NAME(LEXX) ; Semantic Class Name
Q $P(^LEX(757.11,LEXX,0),U,2)
IEN(LEXX) ; Internal Entry number based on Semantic Class
S LEXX=$O(^LEX(757.11,"B",LEXX,0)) Q LEXX
;
INCLUDE ; Include a Semantic Classes
W ! N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR("A")="Include this class: "
S (DIR("??"),DIR("?"))="^D INH^LEXDFSI"
S DIR("B")="YES",DIR(0)="YAO"
D ^DIR K DIR S LEXCCOK=Y Q
;
INH ; Include help
W !!," Semantic Class: "
W $$CC(LEXCCR)," - ",$$NAME(LEXCCR) Q
;
EXCLUDE ; Exclude Semantic Types
W ! N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR("A",1)="Do you want to ""exclude"" any of"
S DIR("A")="the semantic types listed above: "
S DIR("B")="NO",(DIR("?"),DIR("??"))="^D EXH^LEXDFSI",DIR(0)="YAO"
D ^DIR K DIR S LEXCCOK=0 S:Y["^^" LEXCCOK=Y D:+Y>0 EN^LEXDFSE(LEXCCR) Q
EXH ; Exclude help
W !!,"By including the semantical class ",$$CC(LEXCCR)
W " you will also be including"
W !,"all of the semantical types contained within the class." Q
;
SAVE(LEXX) ; Save Semantic Class
Q:LEXCCOK[U N LEXC S LEXCCOK=1,LEXC=$G(LEXA(0))+1
S LEXA(0)=LEXC,LEXA(LEXC,0)=$$CC(LEXX),LEXA(LEXC,1,0)=0,LEXA(LEXC,2,0)=0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDFSI 3039 printed Dec 13, 2024@02:07:43 Page 2
LEXDFSI ;ISL/KER - Default Filter - Include Semantics ;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 ; ^DIR ICR 10026
+8 ;
+9 ; Called from LEXDFSB (set the INCLUDE/EXCLUDE string)
+10 ;
+11 ; LEXC Counter
+12 ; LEXCC Semantic Class Mnemonic
+13 ; LEXCCN Semantic Class Counter
+14 ; LEXCCOK Semantic Class OK (Y/N)
+15 ; LEXCCR Semantic Class Pointer in #757.11
+16 ; LEXF Flag for user input
+17 ; LEXS Semantic Type Sources from #757.03
+18 ; LEXX String returned to LEXDSTS
+19 ;
EN(LEXX) ; Semantic Type string INCLUDE/EXCLUDE
+1 KILL LEXA
NEW LEXF
SET LEXX=""
SET LEXF=1
+2 DO CLASS
QUIT LEXX
+3 ;
CLASS ; Semantic Classes
+1 NEW LEXCCOK,LEXCC,LEXCCR,LEXCCN
SET (LEXCCOK,LEXCC)=""
+2 FOR
SET LEXCC=$ORDER(^LEX(757.11,"B",LEXCC))
if LEXCC=""!(LEXCCOK[U)
QUIT
Begin DoDot:1
+3 SET LEXCCOK=0
IF LEXCC'="UNK"
Begin DoDot:2
+4 SET LEXCCR=$$IEN(LEXCC)
SET LEXCCN=+($GET(LEXCCN))+1
+5 WRITE !!,$JUSTIFY(LEXCCN,2),": ",$$CC(LEXCCR)," ",$$NAME(LEXCCR),!
+6 DO SY(LEXCCR)
DO CAT(LEXCCR)
+7 if +($GET(LEXF))
DO INCLUDE
IF LEXCCOK
DO SAVE(LEXCCR)
End DoDot:2
if LEXCCOK[U
QUIT
+8 if LEXCCOK["^"
QUIT
IF LEXCCOK
DO EXCLUDE
End DoDot:1
+9 IF +($GET(LEXF))>0
SET LEXX=LEXCCOK
+10 QUIT
+11 ;
SY(LEXX) ; List Classification Systems
+1 NEW LEXS,LEXC
if '$DATA(^LEX(757.11,LEXX,2,"B"))
QUIT
SET LEXS=""
SET LEXC=0
+2 WRITE !!,?4,"This Semantic Class contains terms from, or mapped to,"
+3 WRITE !,?4,"the following classification systems: ",!
+4 FOR
SET LEXS=$ORDER(^LEX(757.11,LEXX,2,"B",LEXS))
if LEXS=""
QUIT
Begin DoDot:1
+5 SET LEXC=LEXC+1
if LEXC=1
WRITE !
if LEXC=1
WRITE ?8,LEXS
+6 if LEXC=2
WRITE ?32,LEXS
if LEXC=3
WRITE ?56,LEXS
if LEXC=3
SET LEXC=0
End DoDot:1
+7 WRITE !
QUIT
CAT(LEXX) ; List semantic types
+1 NEW LEXC
SET LEXC=0
if '$DATA(^LEX(757.11,LEXX,1,0))
QUIT
+2 WRITE !!,?4,"Semantic Types: ",!
+3 FOR
SET LEXC=$ORDER(^LEX(757.11,LEXX,1,LEXC))
if +LEXC=0
QUIT
Begin DoDot:1
+4 WRITE !,?4,^LEX(757.11,LEXX,1,LEXC,0)
End DoDot:1
+5 QUIT
CC(LEXX) ; Semantic Class Mnemonic
+1 QUIT $PIECE(^LEX(757.11,LEXX,0),U,1)
NAME(LEXX) ; Semantic Class Name
+1 QUIT $PIECE(^LEX(757.11,LEXX,0),U,2)
IEN(LEXX) ; Internal Entry number based on Semantic Class
+1 SET LEXX=$ORDER(^LEX(757.11,"B",LEXX,0))
QUIT LEXX
+2 ;
INCLUDE ; Include a Semantic Classes
+1 WRITE !
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR("A")="Include this class: "
+3 SET (DIR("??"),DIR("?"))="^D INH^LEXDFSI"
+4 SET DIR("B")="YES"
SET DIR(0)="YAO"
+5 DO ^DIR
KILL DIR
SET LEXCCOK=Y
QUIT
+6 ;
INH ; Include help
+1 WRITE !!," Semantic Class: "
+2 WRITE $$CC(LEXCCR)," - ",$$NAME(LEXCCR)
QUIT
+3 ;
EXCLUDE ; Exclude Semantic Types
+1 WRITE !
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR("A",1)="Do you want to ""exclude"" any of"
+3 SET DIR("A")="the semantic types listed above: "
+4 SET DIR("B")="NO"
SET (DIR("?"),DIR("??"))="^D EXH^LEXDFSI"
SET DIR(0)="YAO"
+5 DO ^DIR
KILL DIR
SET LEXCCOK=0
if Y["^^"
SET LEXCCOK=Y
if +Y>0
DO EN^LEXDFSE(LEXCCR)
QUIT
EXH ; Exclude help
+1 WRITE !!,"By including the semantical class ",$$CC(LEXCCR)
+2 WRITE " you will also be including"
+3 WRITE !,"all of the semantical types contained within the class."
QUIT
+4 ;
SAVE(LEXX) ; Save Semantic Class
+1 if LEXCCOK[U
QUIT
NEW LEXC
SET LEXCCOK=1
SET LEXC=$GET(LEXA(0))+1
+2 SET LEXA(0)=LEXC
SET LEXA(LEXC,0)=$$CC(LEXX)
SET LEXA(LEXC,1,0)=0
SET LEXA(LEXC,2,0)=0
QUIT
