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

RGUTMTL.m

Go to the documentation of this file.
  1. RGUTMTL ;CAIRO/DKM - Multi-term lookup support ;04-Sep-1998 11:26;DKM
  1. ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
  1. ;=================================================================
  1. ; Parse term into component words (KWIC)
  1. PARSE2(RGTRM,RGRTN,RGMIN) ;
  1. N X,L,C,%
  1. K RGRTN
  1. S %="RGRTN(I)",X=$$UP^XLFSTR(RGTRM),RGMIN=+$G(RGMIN)
  1. D S^XTLKWIC
  1. S L="",C=0
  1. F S L=$O(RGRTN(L)) Q:L="" D
  1. .I $L(L)<RGMIN K RGRTN(L)
  1. .E S C=C+1
  1. Q C
  1. ; Parse term into component words
  1. PARSE(RGTRM,RGRTN,RGMIN) ;
  1. N X,Y,Z,L,C
  1. K RGRTN
  1. S RGTRM=$$UP^XLFSTR(RGTRM),C=0,RGMIN=+$G(RGMIN,1),Z=""
  1. F X=1:1 Q:'$L(RGTRM) D:$E(RGTRM,X)'?1AN
  1. .S Y=Z,Z=$E(RGTRM,X),L=$E(RGTRM,1,X-1),RGTRM=$E(RGTRM,X+1,999),X=0
  1. .I $L(L)'<RGMIN,L'=+L,'$D(RGRTN(L)) S RGRTN(L)=Y,C=C+1,Y=""
  1. Q C
  1. ; Create/delete an MTL cross reference for term
  1. XREF(RGRT,RGTRM,RGDA,RGDEL) ;
  1. N RGZ,RGG
  1. S RGZ=$L(RGRT),RGG=$S($E(RGRT,RGZ)=")":$E(RGRT,1,RGZ-1)_",",1:RGRT_"(")_"RGZ,",RGZ=$C(1)
  1. F S RGZ=$O(RGDA(RGZ),-1) Q:'RGZ S RGG=RGG_""""_RGDA(RGZ)_""","
  1. S RGG=RGG_""""_RGDA_""")"
  1. Q:'$$PARSE(RGTRM,.RGZ)
  1. S RGZ="",RGDEL=''$G(RGDEL)
  1. L +@RGRT
  1. F S RGZ=$O(RGZ(RGZ)) Q:RGZ="" D
  1. .I ''$D(@RGG)=RGDEL D
  1. ..I RGDEL K @RGG K:$D(@RGRT@(RGZ))<10 @RGRT@(RGZ)
  1. ..E D:'$D(@RGRT@(RGZ)) REFNEW(RGZ) S @RGG=""
  1. ..D REFCNT(RGZ,$S(RGDEL:-1,1:1))
  1. L -@RGRT
  1. Q
  1. ; Increment/decrement reference count for term and its stems
  1. REFCNT(RGX,RGI) ;
  1. Q:'$L(RGX)
  1. I $D(@RGRT@(RGX)) D
  1. .N RGZ
  1. .S RGZ=$G(@RGRT@(RGX))+RGI
  1. .I RGZ<1 K @RGRT@(RGX)
  1. .E S @RGRT@(RGX)=RGZ
  1. D REFCNT($E(RGX,1,$L(RGX)-1),RGI)
  1. Q
  1. ; Create new term reference
  1. REFNEW(RGX) ;
  1. N RGZ,RGC,RGABR
  1. S RGZ=RGX,RGC=0,RGABR=0
  1. F S RGZ=$$STEM(RGZ,RGX) Q:'$L(RGZ) S RGC=RGC+$G(@RGRT@(RGZ)),RGZ=RGZ_$C(255)
  1. S @RGRT@(RGX)=RGC
  1. Q
  1. ; Lookup a term in an MTL index
  1. ; RGRT = Root of index (e.g., ^RGCOD(990.9,"AD"))
  1. ; RGTRM = Term to lookup
  1. ; RGRTN = Root of returned array (note: killed before populated)
  1. ; RGABR = If nonzero, user can abort lookup with ^
  1. LKP(RGRT,RGTRM,RGRTN,RGABR) ;
  1. N RGX,RGY,RGW,RGF,RGIEN,RGL,RGM,RGTRM1
  1. I $$NEWERR^%ZTER N $ET S $ET=""
  1. K @RGRTN
  1. S RGABR=+$G(RGABR),@$$TRAP^RGZOSF("LKP2^RGUTMTL")
  1. I $$PARSE(RGTRM,.RGTRM)=1 S RGW(1,$O(RGTRM("")))=""
  1. E D
  1. .S RGTRM="",RGM=9999999999
  1. .F S RGTRM=$O(RGTRM(RGTRM)) Q:RGTRM="" D Q:RGL<0
  1. ..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~",RGTRM1="",RGL=$S(RGY:9999999999,1:-1)
  1. ..I 'RGY F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" D:$D(^(RGTRM1))>1 Q:RGL>RGM
  1. ...S:RGL=-1 RGL=0
  1. ...S RGL=RGL+$G(^(RGTRM1))
  1. ...S RGTRM1=RGTRM1_$C(255)
  1. ..S RGW(RGL,RGTRM)=""
  1. ..I RGL>0,RGL<RGM S RGM=RGL
  1. ..D:RGABR ABORT
  1. Q:$D(RGW(-1)) 0
  1. S RGW="",RGF=0
  1. F S RGW=$O(RGW(RGW)),RGTRM="" Q:RGW="" D Q:RGF=-1
  1. .F S RGTRM=$O(RGW(RGW,RGTRM)) Q:RGTRM="" D Q:RGF=-1
  1. ..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~"
  1. ..I RGF D
  1. ...S RGIEN=0
  1. ...F S RGIEN=$O(@RGRTN@(RGIEN)),RGTRM1="" Q:'RGIEN D Q:RGF=-1
  1. ....F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" Q:$D(^(RGTRM1,RGIEN))
  1. ....I RGY-(RGTRM1="") K @RGRTN@(RGIEN) S:$D(@RGRTN)'>1 RGF=-1
  1. ..E D
  1. ...S RGTRM1="",RGF=1
  1. ...F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" M @RGRTN=^(RGTRM1)
  1. ...S:$D(@RGRTN)'>1 RGF=-1
  1. Q $D(@RGRTN)>1
  1. LKP2 K @RGRTN
  1. Q -1
  1. ; Check for user abort
  1. ABORT N RGZ
  1. R RGZ#1:0
  1. D:RGZ=U RAISE^RGZOSF()
  1. Q
  1. ; Return in successive calls all terms sharing common stem
  1. ; (sets naked reference)
  1. STEM(RGLAST,RGSTEM,RGF) ;
  1. D:RGABR ABORT
  1. I RGLAST="" S RGLAST=RGSTEM Q:$D(@RGRT@(RGLAST)) RGLAST
  1. Q:$G(RGF) ""
  1. S RGLAST=$O(@RGRT@(RGLAST))
  1. Q $S($E(RGLAST,1,$L(RGSTEM))=RGSTEM:RGLAST,1:"")