LEXRXXP ;ISL/KER - Re-Index Parse ;04/21/2014
;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX( SACC 1.3
; ^LEX(757, SACC 1.3
; ^LEX(757.01, SACC 1.3
; ^LEX(757.05, SACC 1.3
; ^TMP("LEXTKN") SACC 2.3.2.5.1
; ^UTILITY($J ICR 10011
;
; External References
; ^DIWP ICR 10011
; $$UP^XLFSTR ICR 10104
;
Q
AWRD(X,LEX1,LEXI) ; Get Words
N LEXEX,LEXE,LEXT,LEXMC,LEXMCE,LEXW K LEX1 S LEX1(0)=0 S LEXEX=+($G(X)) Q:+LEXEX'>0!('$D(^LEX(757.01,+LEXEX,0)))
S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXMCE=$$MCE(LEXEX) Q:'$D(^LEX(757,+LEXMC,0)) Q:'$D(^LEX(757.01,+LEXMCE,0))
S LEXE=0 F S LEXE=$O(^LEX(757.01,"AMC",LEXMC,LEXE)) Q:+LEXE'>0 D
. N LEX2,LEXT S LEXT=$P($G(^LEX(757.01,+LEXE,0)),"^",1)
. D WORDS(LEXT,.LEX2) S LEXT="" F S LEXT=$O(LEX2(LEXT)) Q:'$L(LEXT) D
. . S LEX1("W",LEXT,LEXMCE,LEXE)=""
S LEX1(0)="Word^Major Concept Expression IEN^Expression IEN"
Q
WORDS(X,LEXA) ;
K LEXA N LEXIDX,LEXI1,LEXI2,LEX1,LEXW S X=$$UP^XLFSTR(X) S:+($G(LEXI))>0 LEXIDX="" K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI1=0 F S LEXI1=$O(^TMP("LEXTKN",$J,LEXI1)) Q:+LEXI1'>0 D
. S LEXI2="" F LEXI2=$O(^TMP("LEXTKN",$J,LEXI1,LEXI2)) Q:'$L(LEXI2) S LEXA(LEXI2)=""
K ^TMP("LEXTKN",$J)
Q
SUP(X,LEX1,LEXI) ; Get Supplemental Words
N LEXEX,LEXE,LEXT,LEXMC,LEXMCE,LEXW K LEX1 S LEX1(0)=0 S LEXEX=+($G(X)) Q:+LEXEX'>0!('$D(^LEX(757.01,+LEXEX,0)))
S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXMCE=$$MCE(LEXEX) Q:'$D(^LEX(757,+LEXMC,0)) Q:'$D(^LEX(757.01,+LEXMCE,0))
S LEXE=0 F S LEXE=$O(^LEX(757.01,LEXEX,5,LEXE)) Q:+LEXE'>0 D
. N LEX2,LEXT S LEXT=$P($G(^LEX(757.01,LEXEX,5,+LEXE,0)),"^",1)
. S:$L(LEXT) LEX1("S",LEXT,LEXEX,LEXMCE,+LEXE)=""
S LEX1(0)="Word^Expression IEN^Major Concept Expression IEN"
Q
LINK(X,LEX1) ; Get Linked Words
K LEX1 N LEXE,LEXEX,LEXMC,LEXMCE,LEXW,LEXTK,LEXB,LEXC,LEXI,LEXIEN S LEXEX=$G(X) Q:'$D(^LEX(757.01,+LEXEX,0))
S LEXMC=+($P($G(^LEX(757.01,+LEXEX,1)),"^",1)) Q:'$D(^LEX(757,+LEXMC,0)) S LEXMCE=$$MCE(LEXEX) Q:'$D(^LEX(757.01,+LEXMCE,0))
; Physical
D AWRD(LEXEX,.LEXW,0) S LEXE=0 F S LEXE=$O(^LEX(757.01,LEXEX,5,LEXE)) Q:+LEXE'>0 D
. N LEXT S LEXT=$P($G(^LEX(757.01,LEXEX,5,+LEXE,0)),"^",1) S:$L(LEXT) LEXW("W",LEXT,LEXEX,LEXMCE,+LEXE)=""
S LEXB=$E($$UP^XLFSTR($P($G(^LEX(757.01,+LEXEX,0)),"^",1)),1,63)
S LEXI=0 S:$L(LEXB) LEXI=$O(^LEX(757.05,"C",LEXB,0))
S:+LEXI>0&($L(LEXB)) LEXW("W",LEXB,LEXEX,LEXMCE)=LEXI
S LEXTK="" F S LEXTK=$O(LEXW("W",LEXTK)) Q:'$L(LEXTK) D
. N LEXI,LEXIEN,LEXPH S LEXPH=$$UP^XLFSTR($E(LEXTK,1,40)),LEXIEN=+($G(LEXW("W",LEXTK,LEXEX,LEXMCE)))
. S LEXI=0 F S LEXI=$O(^LEX(757.05,"B",LEXPH,LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="" S:+LEXI>0 LEXT=$P($G(^LEX(757.05,+LEXI,0)),"^",3)
. . S:$L(LEXPH)&(+LEXI>0) LEX1("TXT",LEXPH)=LEXI,LEX1("IEN",+LEXI,LEXPH)=LEXT
. . I $D(^LEX(757.05,+LEXI,1,"B",+LEXEX)),$L(LEXT) D
. . . S LEX1(LEXT,LEXPH,LEXEX,"LINKED")=LEXI_"^"_$G(^LEX(757.05,+LEXI,0))
. . . K:$L(LEXT) LEX1("IEN"),LEX1("TXT")
. I LEXIEN>0 S LEXT=$P($G(^LEX(757.05,+LEXIEN,0)),"^",3) S:$L(LEXT) LEX1("TXT",$$UP^XLFSTR(LEXTK))=LEXIEN,LEX1("IEN",+LEXIEN,$$UP^XLFSTR(LEXTK))=LEXT
; Replacement
S LEXI=0 F S LEXI=$O(LEX1("IEN",LEXI)) Q:+LEXI'>0 D
. N LEXPH S LEXPH="" F S LEXPH=$O(LEX1("IEN",LEXI,LEXPH)) Q:'$L(LEXPH) D
. . N LEXT S LEXT=$G(LEX1("IEN",LEXI,LEXPH)) D:LEXT="R"
. . . N LEXA,LEXB S X=LEXPH N LEXIDX D PTX^LEXTOKN
. . . I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXA=0 F S LEXA=$O(^TMP("LEXTKN",$J,LEXA)) Q:+LEXA'>0 D
. . . . N LEXB S LEXB="" F S LEXB=$O(^TMP("LEXTKN",$J,LEXA,LEXB)) Q:'$L(LEXB) D
. . . . . N LEXMCE S LEXMCE=$$MCE(LEXEX)
. . . . . S LEX1("IEN",LEXI,LEXPH,"W",LEXB)="",LEX1(LEXT,LEXB,LEXMCE,"LINKED")=LEXI_"^"_$G(^LEX(757.05,+LEXI,0))
. . K:$L(LEXT) LEX1("IEN"),LEX1("TXT")
Q
PR(LEX,X) ; Parse Array LEX in X Length Strings (default 79)
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC K ^UTILITY($J,"W") Q:'$D(LEX)
S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
S DIWL=1,DIWF="C"_+LEXLEN S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0 S X=$G(LEX(LEXI)) D ^DIWP
K LEX S (LEXC,LEXI)=0 F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
. S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
Q
MCE(X) ; Major Concept Expression
S X=+($G(^LEX(757,+($G(^LEX(757.01,+($G(X)),1))),0)))
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
LEXRXXP ;ISL/KER - Re-Index Parse ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX( SACC 1.3
+5 ; ^LEX(757, SACC 1.3
+6 ; ^LEX(757.01, SACC 1.3
+7 ; ^LEX(757.05, SACC 1.3
+8 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+9 ; ^UTILITY($J ICR 10011
+10 ;
+11 ; External References
+12 ; ^DIWP ICR 10011
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 QUIT
AWRD(X,LEX1,LEXI) ; Get Words
+1 NEW LEXEX,LEXE,LEXT,LEXMC,LEXMCE,LEXW
KILL LEX1
SET LEX1(0)=0
SET LEXEX=+($GET(X))
IF +LEXEX'>0!('$DATA(^LEX(757.01,+LEXEX,0)))
QUIT
+2 SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
SET LEXMCE=$$MCE(LEXEX)
IF '$DATA(^LEX(757,+LEXMC,0))
QUIT
IF '$DATA(^LEX(757.01,+LEXMCE,0))
QUIT
+3 SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXE))
IF +LEXE'>0
QUIT
Begin DoDot:1
+4 NEW LEX2,LEXT
SET LEXT=$PIECE($GET(^LEX(757.01,+LEXE,0)),"^",1)
+5 DO WORDS(LEXT,.LEX2)
SET LEXT=""
FOR
SET LEXT=$ORDER(LEX2(LEXT))
IF '$LENGTH(LEXT)
QUIT
Begin DoDot:2
+6 SET LEX1("W",LEXT,LEXMCE,LEXE)=""
End DoDot:2
End DoDot:1
+7 SET LEX1(0)="Word^Major Concept Expression IEN^Expression IEN"
+8 QUIT
WORDS(X,LEXA) ;
+1 KILL LEXA
NEW LEXIDX,LEXI1,LEXI2,LEX1,LEXW
SET X=$$UP^XLFSTR(X)
IF +($GET(LEXI))>0
SET LEXIDX=""
KILL ^TMP("LEXTKN",$JOB)
DO PTX^LEXTOKN
+2 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXI1=0
FOR
SET LEXI1=$ORDER(^TMP("LEXTKN",$JOB,LEXI1))
IF +LEXI1'>0
QUIT
Begin DoDot:1
+3 SET LEXI2=""
FOR LEXI2=$ORDER(^TMP("LEXTKN",$JOB,LEXI1,LEXI2))
IF '$LENGTH(LEXI2)
QUIT
SET LEXA(LEXI2)=""
End DoDot:1
+4 KILL ^TMP("LEXTKN",$JOB)
+5 QUIT
SUP(X,LEX1,LEXI) ; Get Supplemental Words
+1 NEW LEXEX,LEXE,LEXT,LEXMC,LEXMCE,LEXW
KILL LEX1
SET LEX1(0)=0
SET LEXEX=+($GET(X))
IF +LEXEX'>0!('$DATA(^LEX(757.01,+LEXEX,0)))
QUIT
+2 SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
SET LEXMCE=$$MCE(LEXEX)
IF '$DATA(^LEX(757,+LEXMC,0))
QUIT
IF '$DATA(^LEX(757.01,+LEXMCE,0))
QUIT
+3 SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.01,LEXEX,5,LEXE))
IF +LEXE'>0
QUIT
Begin DoDot:1
+4 NEW LEX2,LEXT
SET LEXT=$PIECE($GET(^LEX(757.01,LEXEX,5,+LEXE,0)),"^",1)
+5 IF $LENGTH(LEXT)
SET LEX1("S",LEXT,LEXEX,LEXMCE,+LEXE)=""
End DoDot:1
+6 SET LEX1(0)="Word^Expression IEN^Major Concept Expression IEN"
+7 QUIT
LINK(X,LEX1) ; Get Linked Words
+1 KILL LEX1
NEW LEXE,LEXEX,LEXMC,LEXMCE,LEXW,LEXTK,LEXB,LEXC,LEXI,LEXIEN
SET LEXEX=$GET(X)
IF '$DATA(^LEX(757.01,+LEXEX,0))
QUIT
+2 SET LEXMC=+($PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",1))
IF '$DATA(^LEX(757,+LEXMC,0))
QUIT
SET LEXMCE=$$MCE(LEXEX)
IF '$DATA(^LEX(757.01,+LEXMCE,0))
QUIT
+3 ; Physical
+4 DO AWRD(LEXEX,.LEXW,0)
SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.01,LEXEX,5,LEXE))
IF +LEXE'>0
QUIT
Begin DoDot:1
+5 NEW LEXT
SET LEXT=$PIECE($GET(^LEX(757.01,LEXEX,5,+LEXE,0)),"^",1)
IF $LENGTH(LEXT)
SET LEXW("W",LEXT,LEXEX,LEXMCE,+LEXE)=""
End DoDot:1
+6 SET LEXB=$EXTRACT($$UP^XLFSTR($PIECE($GET(^LEX(757.01,+LEXEX,0)),"^",1)),1,63)
+7 SET LEXI=0
IF $LENGTH(LEXB)
SET LEXI=$ORDER(^LEX(757.05,"C",LEXB,0))
+8 IF +LEXI>0&($LENGTH(LEXB))
SET LEXW("W",LEXB,LEXEX,LEXMCE)=LEXI
+9 SET LEXTK=""
FOR
SET LEXTK=$ORDER(LEXW("W",LEXTK))
IF '$LENGTH(LEXTK)
QUIT
Begin DoDot:1
+10 NEW LEXI,LEXIEN,LEXPH
SET LEXPH=$$UP^XLFSTR($EXTRACT(LEXTK,1,40))
SET LEXIEN=+($GET(LEXW("W",LEXTK,LEXEX,LEXMCE)))
+11 SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(757.05,"B",LEXPH,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+12 NEW LEXT
SET LEXT=""
IF +LEXI>0
SET LEXT=$PIECE($GET(^LEX(757.05,+LEXI,0)),"^",3)
+13 IF $LENGTH(LEXPH)&(+LEXI>0)
SET LEX1("TXT",LEXPH)=LEXI
SET LEX1("IEN",+LEXI,LEXPH)=LEXT
+14 IF $DATA(^LEX(757.05,+LEXI,1,"B",+LEXEX))
IF $LENGTH(LEXT)
Begin DoDot:3
+15 SET LEX1(LEXT,LEXPH,LEXEX,"LINKED")=LEXI_"^"_$GET(^LEX(757.05,+LEXI,0))
+16 IF $LENGTH(LEXT)
KILL LEX1("IEN"),LEX1("TXT")
End DoDot:3
End DoDot:2
+17 IF LEXIEN>0
SET LEXT=$PIECE($GET(^LEX(757.05,+LEXIEN,0)),"^",3)
IF $LENGTH(LEXT)
SET LEX1("TXT",$$UP^XLFSTR(LEXTK))=LEXIEN
SET LEX1("IEN",+LEXIEN,$$UP^XLFSTR(LEXTK))=LEXT
End DoDot:1
+18 ; Replacement
+19 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX1("IEN",LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+20 NEW LEXPH
SET LEXPH=""
FOR
SET LEXPH=$ORDER(LEX1("IEN",LEXI,LEXPH))
IF '$LENGTH(LEXPH)
QUIT
Begin DoDot:2
+21 NEW LEXT
SET LEXT=$GET(LEX1("IEN",LEXI,LEXPH))
IF LEXT="R"
Begin DoDot:3
+22 NEW LEXA,LEXB
SET X=LEXPH
NEW LEXIDX
DO PTX^LEXTOKN
+23 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
SET LEXA=0
FOR
SET LEXA=$ORDER(^TMP("LEXTKN",$JOB,LEXA))
IF +LEXA'>0
QUIT
Begin DoDot:4
+24 NEW LEXB
SET LEXB=""
FOR
SET LEXB=$ORDER(^TMP("LEXTKN",$JOB,LEXA,LEXB))
IF '$LENGTH(LEXB)
QUIT
Begin DoDot:5
+25 NEW LEXMCE
SET LEXMCE=$$MCE(LEXEX)
+26 SET LEX1("IEN",LEXI,LEXPH,"W",LEXB)=""
SET LEX1(LEXT,LEXB,LEXMCE,"LINKED")=LEXI_"^"_$GET(^LEX(757.05,+LEXI,0))
End DoDot:5
End DoDot:4
End DoDot:3
+27 IF $LENGTH(LEXT)
KILL LEX1("IEN"),LEX1("TXT")
End DoDot:2
End DoDot:1
+28 QUIT
PR(LEX,X) ; Parse Array LEX in X Length Strings (default 79)
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC
KILL ^UTILITY($JOB,"W")
IF '$DATA(LEX)
QUIT
+2 SET LEXLEN=+($GET(X))
IF +LEXLEN'>0
SET LEXLEN=79
SET LEXC=+($GET(LEX))
IF +($GET(LEXC))'>0
SET LEXC=$ORDER(LEX(" "),-1)
IF +LEXC'>0
QUIT
+3 SET DIWL=1
SET DIWF="C"_+LEXLEN
SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI=0
QUIT
SET X=$GET(LEX(LEXI))
DO ^DIWP
+4 KILL LEX
SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+5 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
SET LEXC=LEXC+1
End DoDot:1
+6 IF $LENGTH(LEXC)
SET LEX=LEXC
KILL ^UTILITY($JOB,"W")
+7 QUIT
MCE(X) ; Major Concept Expression
+1 SET X=+($GET(^LEX(757,+($GET(^LEX(757.01,+($GET(X)),1))),0)))
+2 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
IF X=""
QUIT X
SET Y=$GET(Y)
IF '$LENGTH(Y)
SET Y=" "
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
