Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXNDX4

LEXNDX4.m

Go to the documentation of this file. 
  1. LEXNDX4 ;ISL/KER - Set/kill indexes (Part 4) Link ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(757.011)       N/A
  1.  ;    ^TMP("LEXTKN")      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$UP^XLFSTR         ICR  10103
  1.  ;    YN^DICN             ICR  10009
  1.  ;               
  1.  I $D(^LEX(757.05,DA,1,"B",1)) Q
  1.  W !,"LINK" S X=LEXBY D PTX^LEXTOKN N LEXTMP
  1.  S (LEXTMP,LEXLINK,LEXKEY)=""
  1.  I ^TMP("LEXTKN",$J,0)>0 D
  1.  . N LEXTMP S LEXTMP=$O(^TMP("LEXTKN",$J,0)) Q:LEXTMP'>0
  1.  . S LEXKEY=$O(^TMP("LEXTKN",$J,LEXTMP,LEXKEY))
  1.  Q:'$L(LEXKEY)  S LEXREC=0 F  S LEXREC=$O(^LEX(757.01,"AWRD",LEXKEY,LEXREC)) Q:+LEXREC=0!(LEXLINK[U)  D
  1.  . I ^TMP("LEXTKN",$J,0)=1 S LEXASK=1
  1.  . I ^TMP("LEXTKN",$J,0)>1 S LEXASK=1 D
  1.  . . S LEXA=1 F  S LEXA=$O(^TMP("LEXTKN",$J,LEXA)) Q:+LEXA'>0  D
  1.  . . . S LEXAKEY="",LEXAKEY=$O(^TMP("LEXTKN",$J,LEXA,LEXAKEY)) Q:'$L($G(LEXAKEY))
  1.  . . . S LEXSRC=$$UP^XLFSTR(^LEX(757.01,LEXREC,0))
  1.  . . . I LEXSRC'[$E(LEXAKEY,1,4) S LEXASK=0
  1.  . S LEXLINK="" I LEXASK D
  1.  . . I $D(^LEX(757.05,DA,1,"B",LEXREC)) Q
  1. MOK . . ; Prompt to Map/Link a keyword to an expression
  1.  . . W !!,"Map       ",^LEX(757.01,LEXREC,0),!,"To        ",LEXREP,!,"OK" S %=1 D YN^DICN S LEXLINK=% I %=-1 W ! S LEXLINK=U Q
  1.  . . I '% W !!,"By answering ""Yes"", an index reference will be made to link the",!,"term to the key word ",LEXREP G MOK
  1.  . I +LEXLINK=1 D
  1.  . . N LEXYPE,LEXT S ^LEX(757.05,"ALINK",DA,LEXREC)=""
  1.  . . S LEXYPE=+($P($G(^LEX(757.01,LEXREC,1)),U,2))
  1.  . . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
  1.  . . S:+LEXT>0 ^LEX(757.01,"AWRD",LEXREP,LEXREC,"LINKED")="" W !
  1.  . . I $D(^LEX(757.05,DA,1,0)) D
  1.  . . . S LEXSREC=0 F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  D
  1.  . . . . S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
  1.  . . . I '$D(^LEX(757.05,DA,1,"B",LEXREC)) D
  1.  . . . . S LEXSREC=0  F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  S LEXLNK=LEXSREC+1
  1.  . . . . K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=LEXREC
  1.  . . . . S ^LEX(757.05,DA,1,"B",LEXREC,LEXLNK)="",$P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
  1.  . . . . S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
  1.  . . I '$D(^LEX(757.05,DA,1,0)) S ^LEX(757.05,DA,1,1,0)=LEXREC,^LEX(757.05,DA,1,"B",LEXREC,1)="",^LEX(757.05,DA,1,0)="^757.53P^1^1"
  1.  D VERIFY K ^TMP("LEXTKN",$J),^TMP("LEXTKN",$J,0),LEXSRC,LEXKEY,LEXA,LEXAKEY,LEXREC,LEXASK,LEXLINK
  1.  Q
  1. VERIFY ; Display linkages made for user verification
  1.  Q:'$D(DA)
  1.  I '$D(^LEX(757.05,DA,1,0)) W !,"No Word Linkages Created",! Q
  1.  W !!,$P(^LEX(757.05,DA,0),"^",1)," has been linked to:  ",!
  1.  N LEXSREC S LEXSREC=0
  1.  F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  D
  1.  . W !,?4,$E(^LEX(757.01,^LEX(757.05,DA,1,LEXSREC,0),0),1,75)
  1.  W ! I +$$OK D  K LEXSREC,LEXLNK Q
  1.  . S LEXSREC=0  F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  S LEXLNK=LEXSREC+1
  1.  . K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=1,^LEX(757.05,DA,1,"B",1,LEXLNK)=""
  1.  . S $P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
  1.  . S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
  1.  D UNLINK
  1.  Q
  1. OK(LEXOK) ; Get user response
  1. OK1 ; Prompt "Is this correct"
  1.  W !,"Is this correct" S %=1 D YN^DICN
  1.  I %=-1!(%=2) K %,%Y Q 0
  1.  I %=1 K %,%Y Q 1
  1.  I '% D  G OK1
  1.  . W !,"By confirming the word linkages displayed above, a look-up"
  1.  . W !,"conducted on ",$P(^LEX(757.05,DA,0),"^",1)
  1.  . W " will retrieve the linked terms."
  1.  Q 0
  1.  Q:'$D(DA)  Q:'$D(^LEX(757.05,DA,1,1,0))
  1.  D SUB N LEXMC,LEXCTR,LEXSREC,LEXERM S (LEXCTR,LEXSREC)=0,LEXERM=$P(^LEX(757.05,DA,0),"^",1)
  1.  F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  D
  1.  . S LEXCTR=LEXCTR+1
  1.  . S ^LEX(757.05,DA,1,0)="^757.53P^"_LEXCTR_"^"_LEXCTR
  1.  . S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
  1.  . I ^LEX(757.05,DA,1,LEXSREC,0)'=1 D
  1.  . . S LEXMC=^LEX(757.05,DA,1,LEXSREC,0)
  1.  . . N LEXYPE,LEXT S LEXYPE=+($P($G(^LEX(757.01,LEXMC,1)),U,2))
  1.  . . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
  1.  . . I +LEXT>0 D
  1.  . . . S ^LEX(757.01,"AWRD",LEXERM,LEXMC,"LINKED")=""
  1.  . . . N X S X=LEXERM I $L(X) D
  1.  . . . . Q:$D(DCNT)&($G(DIKSAVE(1))["ASL")
  1.  . . . . Q:$D(DCNT)&($G(DIK(1))["ASL")
  1.  . . . . Q:$D(DCNT)&('$D(DIK(1)))
  1.  . . . . D SSF^LEXNDX6
  1.  . . S ^LEX(757.05,"ALINK",DA,LEXMC)=""
  1.  K LEXSREC,LEXERM N DCNT,DIKSAVE
  1.  Q
  1.  Q:'$D(^LEX(757.05,DA,1,0))  N LEXMC,LEXLNK
  1.  S LEXMC=0  F  S LEXMC=$O(^LEX(757.05,DA,1,"B",LEXMC)) Q:+LEXMC=0  D
  1.  . S LEXLNK=0  F  S LEXLNK=$O(^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)) Q:+LEXLNK=0  D
  1.  . . S LEXWRD=$P(^LEX(757.05,DA,0),U,1)
  1.  . . K ^LEX(757.01,"AWRD",LEXWRD,LEXMC,"LINKED")
  1.  . . N X S X=LEXWRD
  1.  . . I $D(X),X=0 D
  1.  . . . K ^LEX(757.05,DA,1,LEXLNK,0)
  1.  . . . K ^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)
  1.  . . . K ^LEX(757.05,DA,1,0)
  1.  . . I $L(X) D
  1.  . . . Q:$D(DCNT)&($G(DIKSAVE(1))["ASL")
  1.  . . . Q:$D(DCNT)&($G(DIK(1))["ASL")
  1.  . . . Q:$D(DCNT)&('$D(DIK(1)))
  1.  . . . D KSF^LEXNDX6
  1.  . . K ^LEX(757.05,"ALINK",DA,LEXMC)
  1.  K LEXLNK,LEXMC N DCNT,DIKSAVE
  1.  Q
  1. SUB ; Index linked words in sub-file before UNLINK and RELINK
  1.  Q:'$D(DA)  I $D(^LEX(757.05,DA,1,1,0)) N LEXSREC,LEXMC S LEXSREC=0 F  S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0  S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
  1.  Q