- 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 Feb 19, 2025@00:03:54 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:"")