source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXABC2.m@ 1710

LEXABC2 ; ISL Look-up by Code (part 2)             ; 01-25-97
 ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
 ;
REO ; Reorder list
 Q:'$D(^TMP("LEXL",$J))  N LEXS,LEXT,LEXP,LEXE,LEXEX,LEXFT,LEXM,LEXX S LEXS="" F  S LEXS=$O(^TMP("LEXL",$J,LEXS)) Q:LEXS=""  S LEXT=0 F  S LEXT=$O(^TMP("LEXL",$J,LEXS,LEXT)) Q:+LEXT=0  D
 . S LEXP=0 F  S LEXP=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP)) Q:+LEXP=0  S LEXE=0 F  S LEXE=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)) Q:+LEXE=0  D
 . . Q:LEXP=3
 . . I LEXP=1 D MC Q
 . . I LEXP=4,$G(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE))["ICD" D SP Q
 . . D OT
 Q
MC ; Major concept
 S LEXM=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1),LEXFT="A"
 S ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
 K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
 Q
SP ; Joint term/code
 N LEXS2,LEXT2,LEXP2,LEXF2,LEXE2,LEXEX,LEXFT,LEXM,LEXF
 N LEXX,LEXTM,LEXTE,LEXHM,LEXHE,LEXHD,LEXOK
 S LEXOK=0,LEXS2="" F  S LEXS2=$O(^TMP("LEXL",$J,LEXS2)) Q:LEXS2=""!(LEXOK)  S LEXT2=0 F  S LEXT2=$O(^TMP("LEXL",$J,LEXS2,LEXT2)) Q:+LEXT2=0!(LEXOK)  D
 . S LEXP2=0 F  S LEXP2=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2)) Q:+LEXP2=0!(LEXOK)  S LEXF=99999999999  F  S LEXF=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF)) Q:LEXF=""!(LEXOK)  D
 . . S LEXE2=0 F  S LEXE2=$O(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2)) Q:+LEXE2=0!(LEXOK)  D
 . . . S LEXTM=$P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",1)
 . . . S LEXTE=$P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",2)
 . . . S LEXHM=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1)
 . . . S LEXHE=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",2)
 . . . S LEXHD=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",4)
 . . . I LEXTM=LEXHM,LEXTE=LEXHE S $P(^TMP("LEXL",$J,LEXS2,LEXT2,LEXP2,LEXF,LEXE2),"^",4)=LEXHD K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE) S LEXOK=1 Q
 I 'LEXOK D OT
 Q
OT ; Other than Major Concept
 S:LEXP>1 LEXX=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",1)
 S LEXFT=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",5)
 ; Primary --> <major concept>=<primary concept>
 I +($G(LEXM))=+($G(LEXX)) D  Q
 . S:LEXFT="" LEXFT="B"
 . S:$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Other:    " $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Synonym: ",LEXFT="B"
 . S ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE) K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
 Q:+($G(LEXM))=+($G(LEXX))
 ; Other --> <major concept>'=<primary concept>
 S LEXFT="F"
 S $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",7)=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)
 S $P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE),"^",6)="Other:    "
 S ^TMP("LEXL",$J,LEXS,LEXT,3,LEXFT,LEXE)=^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
 K ^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXE)
 Q
SCH(LEXX) ; $Orderable variable
 S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
ADD ; Add codes expressions to the selection list
 ;
 ; Use local array LEXL
 ;
 ;   S ^TMP("LEXL",$J,<Code>,<Type>,<Preference>,<Form>,<IEN>)=
 ;  <IEN 757>^<IEN 757.01>^<Description>^<Display>^<Form Type>^<Form>
 ;
 N LEXS,LEXT,LEXP,LEXFT,LEXSIEN,LEXPM
 S LEXS="" F  S LEXS=$O(^TMP("LEXL",$J,LEXS)) Q:LEXS=""  D
 . S LEXT=0 F  S LEXT=$O(^TMP("LEXL",$J,LEXS,LEXT)) Q:+LEXT=0  D
 . . S (LEXP,LEXPM)=0 F  S LEXP=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP)) Q:+LEXP=0  D
 . . . S LEXFT="" F  S LEXFT=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT)) Q:LEXFT=""  D
 . . . . S LEXSIEN=0 F  S LEXSIEN=$O(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN)) Q:+LEXSIEN=0  D SAVE
 Q
SAVE ; Save in ^TMP
 N LEXMI,LEXEI,LEXDF,LEXDS,LEXFM,LEXTP,LEXPX,LEXSX,LEXFQ,LEXSTR
 S LEXSTR="",LEXMI=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",1),LEXEI=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",2),LEXDF=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",3)
 S LEXDS=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",4),LEXFM=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",4),LEXTP=$P(^TMP("LEXL",$J,LEXS,LEXT,LEXP,LEXFT,LEXSIEN),"^",6),(LEXSX,LEXPX)="" S:LEXP=1 LEXPM=LEXMI
 ; Prefix
 I LEXP>1 S LEXPX=LEXTP S:LEXPX["Concept" LEXPX="Synonym:  " S:LEXPX="" LEXPX="Other:    "
 ; Suffix
 I LEXP>1 S LEXSX="" S:LEXPX["Other:" LEXSX="classified as" S:LEXPX="" LEXSX="classified as",LEXPX="Other:    "
 ; Display
 S:$L(LEXSX)&($G(LEXSO2)["+") LEXDS=LEXSX_" "_LEXDS S:$L(LEXDS) LEXDS="("_LEXDS_")"
 ; String
 S LEXSTR=$$TERM(LEXEI) S:$L(LEXDF) LEXSTR=LEXSTR_" "_LEXDF S:$L(LEXDS) LEXSTR=LEXSTR_" "_LEXDS S:$L(LEXPX) LEXSTR=LEXPX_LEXSTR S:LEXP>1 LEXSTR="  "_LEXSTR
 ; ^TMP("LEXFND",$J,FQ,IEN)
 S LEXFQ=$G(^TMP("LEXFND",$J,0)) S:+LEXFQ=0 LEXFQ=-999999 S LEXFQ=LEXFQ+1
 S:'$D(^TMP("LEXFND",$J,-LEXFQ,LEXEI)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,LEXFQ,LEXEI)=LEXSTR,^TMP("LEXFND",$J,0)=LEXFQ,LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
TERM(LEXX) ; Get expression
 Q $G(^LEX(757.01,+($G(LEXX)),0))