- 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
