RGUTMTL ;CAIRO/DKM - Multi-term lookup support ;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
; Parse term into component words (KWIC)
PARSE2(RGTRM,RGRTN,RGMIN) ;
N X,L,C,%
K RGRTN
S %="RGRTN(I)",X=$$UP^XLFSTR(RGTRM),RGMIN=+$G(RGMIN)
D S^XTLKWIC
S L="",C=0
F S L=$O(RGRTN(L)) Q:L="" D
.I $L(L)<RGMIN K RGRTN(L)
.E S C=C+1
Q C
; Parse term into component words
PARSE(RGTRM,RGRTN,RGMIN) ;
N X,Y,Z,L,C
K RGRTN
S RGTRM=$$UP^XLFSTR(RGTRM),C=0,RGMIN=+$G(RGMIN,1),Z=""
F X=1:1 Q:'$L(RGTRM) D:$E(RGTRM,X)'?1AN
.S Y=Z,Z=$E(RGTRM,X),L=$E(RGTRM,1,X-1),RGTRM=$E(RGTRM,X+1,999),X=0
.I $L(L)'<RGMIN,L'=+L,'$D(RGRTN(L)) S RGRTN(L)=Y,C=C+1,Y=""
Q C
; Create/delete an MTL cross reference for term
XREF(RGRT,RGTRM,RGDA,RGDEL) ;
N RGZ,RGG
S RGZ=$L(RGRT),RGG=$S($E(RGRT,RGZ)=")":$E(RGRT,1,RGZ-1)_",",1:RGRT_"(")_"RGZ,",RGZ=$C(1)
F S RGZ=$O(RGDA(RGZ),-1) Q:'RGZ S RGG=RGG_""""_RGDA(RGZ)_""","
S RGG=RGG_""""_RGDA_""")"
Q:'$$PARSE(RGTRM,.RGZ)
S RGZ="",RGDEL=''$G(RGDEL)
L +@RGRT
F S RGZ=$O(RGZ(RGZ)) Q:RGZ="" D
.I ''$D(@RGG)=RGDEL D
..I RGDEL K @RGG K:$D(@RGRT@(RGZ))<10 @RGRT@(RGZ)
..E D:'$D(@RGRT@(RGZ)) REFNEW(RGZ) S @RGG=""
..D REFCNT(RGZ,$S(RGDEL:-1,1:1))
L -@RGRT
Q
; Increment/decrement reference count for term and its stems
REFCNT(RGX,RGI) ;
Q:'$L(RGX)
I $D(@RGRT@(RGX)) D
.N RGZ
.S RGZ=$G(@RGRT@(RGX))+RGI
.I RGZ<1 K @RGRT@(RGX)
.E S @RGRT@(RGX)=RGZ
D REFCNT($E(RGX,1,$L(RGX)-1),RGI)
Q
; Create new term reference
REFNEW(RGX) ;
N RGZ,RGC,RGABR
S RGZ=RGX,RGC=0,RGABR=0
F S RGZ=$$STEM(RGZ,RGX) Q:'$L(RGZ) S RGC=RGC+$G(@RGRT@(RGZ)),RGZ=RGZ_$C(255)
S @RGRT@(RGX)=RGC
Q
; Lookup a term in an MTL index
; RGRT = Root of index (e.g., ^RGCOD(990.9,"AD"))
; RGTRM = Term to lookup
; RGRTN = Root of returned array (note: killed before populated)
; RGABR = If nonzero, user can abort lookup with ^
LKP(RGRT,RGTRM,RGRTN,RGABR) ;
N RGX,RGY,RGW,RGF,RGIEN,RGL,RGM,RGTRM1
I $$NEWERR^%ZTER N $ET S $ET=""
K @RGRTN
S RGABR=+$G(RGABR),@$$TRAP^RGZOSF("LKP2^RGUTMTL")
I $$PARSE(RGTRM,.RGTRM)=1 S RGW(1,$O(RGTRM("")))=""
E D
.S RGTRM="",RGM=9999999999
.F S RGTRM=$O(RGTRM(RGTRM)) Q:RGTRM="" D Q:RGL<0
..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~",RGTRM1="",RGL=$S(RGY:9999999999,1:-1)
..I 'RGY F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" D:$D(^(RGTRM1))>1 Q:RGL>RGM
...S:RGL=-1 RGL=0
...S RGL=RGL+$G(^(RGTRM1))
...S RGTRM1=RGTRM1_$C(255)
..S RGW(RGL,RGTRM)=""
..I RGL>0,RGL<RGM S RGM=RGL
..D:RGABR ABORT
Q:$D(RGW(-1)) 0
S RGW="",RGF=0
F S RGW=$O(RGW(RGW)),RGTRM="" Q:RGW="" D Q:RGF=-1
.F S RGTRM=$O(RGW(RGW,RGTRM)) Q:RGTRM="" D Q:RGF=-1
..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~"
..I RGF D
...S RGIEN=0
...F S RGIEN=$O(@RGRTN@(RGIEN)),RGTRM1="" Q:'RGIEN D Q:RGF=-1
....F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" Q:$D(^(RGTRM1,RGIEN))
....I RGY-(RGTRM1="") K @RGRTN@(RGIEN) S:$D(@RGRTN)'>1 RGF=-1
..E D
...S RGTRM1="",RGF=1
...F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" M @RGRTN=^(RGTRM1)
...S:$D(@RGRTN)'>1 RGF=-1
Q $D(@RGRTN)>1
LKP2 K @RGRTN
Q -1
; Check for user abort
ABORT N RGZ
R RGZ#1:0
D:RGZ=U RAISE^RGZOSF()
Q
; Return in successive calls all terms sharing common stem
; (sets naked reference)
STEM(RGLAST,RGSTEM,RGF) ;
D:RGABR ABORT
I RGLAST="" S RGLAST=RGSTEM Q:$D(@RGRT@(RGLAST)) RGLAST
Q:$G(RGF) ""
S RGLAST=$O(@RGRT@(RGLAST))
Q $S($E(RGLAST,1,$L(RGSTEM))=RGSTEM:RGLAST,1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTMTL 3594 printed Apr 09, 2024@21:39:51 Page 2
RGUTMTL ;CAIRO/DKM - Multi-term lookup support ;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
+3 ; Parse term into component words (KWIC)
PARSE2(RGTRM,RGRTN,RGMIN) ;
+1 NEW X,L,C,%
+2 KILL RGRTN
+3 SET %="RGRTN(I)"
SET X=$$UP^XLFSTR(RGTRM)
SET RGMIN=+$GET(RGMIN)
+4 DO S^XTLKWIC
+5 SET L=""
SET C=0
+6 FOR
SET L=$ORDER(RGRTN(L))
if L=""
QUIT
Begin DoDot:1
+7 IF $LENGTH(L)<RGMIN
KILL RGRTN(L)
+8 IF '$TEST
SET C=C+1
End DoDot:1
+9 QUIT C
+10 ; Parse term into component words
PARSE(RGTRM,RGRTN,RGMIN) ;
+1 NEW X,Y,Z,L,C
+2 KILL RGRTN
+3 SET RGTRM=$$UP^XLFSTR(RGTRM)
SET C=0
SET RGMIN=+$GET(RGMIN,1)
SET Z=""
+4 FOR X=1:1
if '$LENGTH(RGTRM)
QUIT
if $EXTRACT(RGTRM,X)'?1AN
Begin DoDot:1
+5 SET Y=Z
SET Z=$EXTRACT(RGTRM,X)
SET L=$EXTRACT(RGTRM,1,X-1)
SET RGTRM=$EXTRACT(RGTRM,X+1,999)
SET X=0
+6 IF $LENGTH(L)'<RGMIN
IF L'=+L
IF '$DATA(RGRTN(L))
SET RGRTN(L)=Y
SET C=C+1
SET Y=""
End DoDot:1
+7 QUIT C
+8 ; Create/delete an MTL cross reference for term
XREF(RGRT,RGTRM,RGDA,RGDEL) ;
+1 NEW RGZ,RGG
+2 SET RGZ=$LENGTH(RGRT)
SET RGG=$SELECT($EXTRACT(RGRT,RGZ)=")":$EXTRACT(RGRT,1,RGZ-1)_",",1:RGRT_"(")_"RGZ,"
SET RGZ=$CHAR(1)
+3 FOR
SET RGZ=$ORDER(RGDA(RGZ),-1)
if 'RGZ
QUIT
SET RGG=RGG_""""_RGDA(RGZ)_""","
+4 SET RGG=RGG_""""_RGDA_""")"
+5 if '$$PARSE(RGTRM,.RGZ)
QUIT
+6 SET RGZ=""
SET RGDEL=''$GET(RGDEL)
+7 LOCK +@RGRT
+8 FOR
SET RGZ=$ORDER(RGZ(RGZ))
if RGZ=""
QUIT
Begin DoDot:1
+9 IF ''$DATA(@RGG)=RGDEL
Begin DoDot:2
+10 IF RGDEL
KILL @RGG
if $DATA(@RGRT@(RGZ))<10
KILL @RGRT@(RGZ)
+11 IF '$TEST
if '$DATA(@RGRT@(RGZ))
DO REFNEW(RGZ)
SET @RGG=""
+12 DO REFCNT(RGZ,$SELECT(RGDEL:-1,1:1))
End DoDot:2
End DoDot:1
+13 LOCK -@RGRT
+14 QUIT
+15 ; Increment/decrement reference count for term and its stems
REFCNT(RGX,RGI) ;
+1 if '$LENGTH(RGX)
QUIT
+2 IF $DATA(@RGRT@(RGX))
Begin DoDot:1
+3 NEW RGZ
+4 SET RGZ=$GET(@RGRT@(RGX))+RGI
+5 IF RGZ<1
KILL @RGRT@(RGX)
+6 IF '$TEST
SET @RGRT@(RGX)=RGZ
End DoDot:1
+7 DO REFCNT($EXTRACT(RGX,1,$LENGTH(RGX)-1),RGI)
+8 QUIT
+9 ; Create new term reference
REFNEW(RGX) ;
+1 NEW RGZ,RGC,RGABR
+2 SET RGZ=RGX
SET RGC=0
SET RGABR=0
+3 FOR
SET RGZ=$$STEM(RGZ,RGX)
if '$LENGTH(RGZ)
QUIT
SET RGC=RGC+$GET(@RGRT@(RGZ))
SET RGZ=RGZ_$CHAR(255)
+4 SET @RGRT@(RGX)=RGC
+5 QUIT
+6 ; Lookup a term in an MTL index
+7 ; RGRT = Root of index (e.g., ^RGCOD(990.9,"AD"))
+8 ; RGTRM = Term to lookup
+9 ; RGRTN = Root of returned array (note: killed before populated)
+10 ; RGABR = If nonzero, user can abort lookup with ^
LKP(RGRT,RGTRM,RGRTN,RGABR) ;
+1 NEW RGX,RGY,RGW,RGF,RGIEN,RGL,RGM,RGTRM1
+2 IF $$NEWERR^%ZTER
NEW $ETRAP
SET $ETRAP=""
+3 KILL @RGRTN
+4 SET RGABR=+$GET(RGABR)
SET @$$TRAP^RGZOSF("LKP2^RGUTMTL")
+5 IF $$PARSE(RGTRM,.RGTRM)=1
SET RGW(1,$ORDER(RGTRM("")))=""
+6 IF '$TEST
Begin DoDot:1
+7 SET RGTRM=""
SET RGM=9999999999
+8 FOR
SET RGTRM=$ORDER(RGTRM(RGTRM))
if RGTRM=""
QUIT
Begin DoDot:2
+9 SET RGX=RGTRM(RGTRM)["="
SET RGY=RGTRM(RGTRM)["~"
SET RGTRM1=""
SET RGL=$SELECT(RGY:9999999999,1:-1)
+10 IF 'RGY
FOR
SET RGTRM1=$$STEM(RGTRM1,RGTRM,RGX)
if RGTRM1=""
QUIT
if $DATA(^(RGTRM1))>1
Begin DoDot:3
+11 if RGL=-1
SET RGL=0
+12 SET RGL=RGL+$GET(^(RGTRM1))
+13 SET RGTRM1=RGTRM1_$CHAR(255)
End DoDot:3
if RGL>RGM
QUIT
+14 SET RGW(RGL,RGTRM)=""
+15 IF RGL>0
IF RGL<RGM
SET RGM=RGL
+16 if RGABR
DO ABORT
End DoDot:2
if RGL<0
QUIT
End DoDot:1
+17 if $DATA(RGW(-1))
QUIT 0
+18 SET RGW=""
SET RGF=0
+19 FOR
SET RGW=$ORDER(RGW(RGW))
SET RGTRM=""
if RGW=""
QUIT
Begin DoDot:1
+20 FOR
SET RGTRM=$ORDER(RGW(RGW,RGTRM))
if RGTRM=""
QUIT
Begin DoDot:2
+21 SET RGX=RGTRM(RGTRM)["="
SET RGY=RGTRM(RGTRM)["~"
+22 IF RGF
Begin DoDot:3
+23 SET RGIEN=0
+24 FOR
SET RGIEN=$ORDER(@RGRTN@(RGIEN))
SET RGTRM1=""
if 'RGIEN
QUIT
Begin DoDot:4
+25 FOR
SET RGTRM1=$$STEM(RGTRM1,RGTRM,RGX)
if RGTRM1=""
QUIT
if $DATA(^(RGTRM1,RGIEN))
QUIT
+26 IF RGY-(RGTRM1="")
KILL @RGRTN@(RGIEN)
if $DATA(@RGRTN)'>1
SET RGF=-1
End DoDot:4
if RGF=-1
QUIT
End DoDot:3
+27 IF '$TEST
Begin DoDot:3
+28 SET RGTRM1=""
SET RGF=1
+29 FOR
SET RGTRM1=$$STEM(RGTRM1,RGTRM,RGX)
if RGTRM1=""
QUIT
MERGE @RGRTN=^(RGTRM1)
+30 if $DATA(@RGRTN)'>1
SET RGF=-1
End DoDot:3
End DoDot:2
if RGF=-1
QUIT
End DoDot:1
if RGF=-1
QUIT
+31 QUIT $DATA(@RGRTN)>1
LKP2 KILL @RGRTN
+1 QUIT -1
+2 ; Check for user abort
ABORT NEW RGZ
+1 READ RGZ#1:0
+2 if RGZ=U
DO RAISE^RGZOSF()
+3 QUIT
+4 ; Return in successive calls all terms sharing common stem
+5 ; (sets naked reference)
STEM(RGLAST,RGSTEM,RGF) ;
+1 if RGABR
DO ABORT
+2 IF RGLAST=""
SET RGLAST=RGSTEM
if $DATA(@RGRT@(RGLAST))
QUIT RGLAST
+3 if $GET(RGF)
QUIT ""
+4 SET RGLAST=$ORDER(@RGRT@(RGLAST))
+5 QUIT $SELECT($EXTRACT(RGLAST,1,$LENGTH(RGSTEM))=RGSTEM:RGLAST,1:"")
