source: WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGUTMTL.m@ 691

Last change on this file since 691 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1RGUTMTL ;CAIRO/DKM - Multi-term lookup support ;04-Sep-1998 11:26;DKM
2 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
3 ;=================================================================
4 ; Parse term into component words (KWIC)
5PARSE2(RGTRM,RGRTN,RGMIN) ;
6 N X,L,C,%
7 K RGRTN
8 S %="RGRTN(I)",X=$$UP^XLFSTR(RGTRM),RGMIN=+$G(RGMIN)
9 D S^XTLKWIC
10 S L="",C=0
11 F S L=$O(RGRTN(L)) Q:L="" D
12 .I $L(L)<RGMIN K RGRTN(L)
13 .E S C=C+1
14 Q C
15 ; Parse term into component words
16PARSE(RGTRM,RGRTN,RGMIN) ;
17 N X,Y,Z,L,C
18 K RGRTN
19 S RGTRM=$$UP^XLFSTR(RGTRM),C=0,RGMIN=+$G(RGMIN,1),Z=""
20 F X=1:1 Q:'$L(RGTRM) D:$E(RGTRM,X)'?1AN
21 .S Y=Z,Z=$E(RGTRM,X),L=$E(RGTRM,1,X-1),RGTRM=$E(RGTRM,X+1,999),X=0
22 .I $L(L)'<RGMIN,L'=+L,'$D(RGRTN(L)) S RGRTN(L)=Y,C=C+1,Y=""
23 Q C
24 ; Create/delete an MTL cross reference for term
25XREF(RGRT,RGTRM,RGDA,RGDEL) ;
26 N RGZ,RGG
27 S RGZ=$L(RGRT),RGG=$S($E(RGRT,RGZ)=")":$E(RGRT,1,RGZ-1)_",",1:RGRT_"(")_"RGZ,",RGZ=$C(1)
28 F S RGZ=$O(RGDA(RGZ),-1) Q:'RGZ S RGG=RGG_""""_RGDA(RGZ)_""","
29 S RGG=RGG_""""_RGDA_""")"
30 Q:'$$PARSE(RGTRM,.RGZ)
31 S RGZ="",RGDEL=''$G(RGDEL)
32 L +@RGRT
33 F S RGZ=$O(RGZ(RGZ)) Q:RGZ="" D
34 .I ''$D(@RGG)=RGDEL D
35 ..I RGDEL K @RGG K:$D(@RGRT@(RGZ))<10 @RGRT@(RGZ)
36 ..E D:'$D(@RGRT@(RGZ)) REFNEW(RGZ) S @RGG=""
37 ..D REFCNT(RGZ,$S(RGDEL:-1,1:1))
38 L -@RGRT
39 Q
40 ; Increment/decrement reference count for term and its stems
41REFCNT(RGX,RGI) ;
42 Q:'$L(RGX)
43 I $D(@RGRT@(RGX)) D
44 .N RGZ
45 .S RGZ=$G(@RGRT@(RGX))+RGI
46 .I RGZ<1 K @RGRT@(RGX)
47 .E S @RGRT@(RGX)=RGZ
48 D REFCNT($E(RGX,1,$L(RGX)-1),RGI)
49 Q
50 ; Create new term reference
51REFNEW(RGX) ;
52 N RGZ,RGC,RGABR
53 S RGZ=RGX,RGC=0,RGABR=0
54 F S RGZ=$$STEM(RGZ,RGX) Q:'$L(RGZ) S RGC=RGC+$G(@RGRT@(RGZ)),RGZ=RGZ_$C(255)
55 S @RGRT@(RGX)=RGC
56 Q
57 ; Lookup a term in an MTL index
58 ; RGRT = Root of index (e.g., ^RGCOD(990.9,"AD"))
59 ; RGTRM = Term to lookup
60 ; RGRTN = Root of returned array (note: killed before populated)
61 ; RGABR = If nonzero, user can abort lookup with ^
62LKP(RGRT,RGTRM,RGRTN,RGABR) ;
63 N RGX,RGY,RGW,RGF,RGIEN,RGL,RGM,RGTRM1
64 I $$NEWERR^%ZTER N $ET S $ET=""
65 K @RGRTN
66 S RGABR=+$G(RGABR),@$$TRAP^RGZOSF("LKP2^RGUTMTL")
67 I $$PARSE(RGTRM,.RGTRM)=1 S RGW(1,$O(RGTRM("")))=""
68 E D
69 .S RGTRM="",RGM=9999999999
70 .F S RGTRM=$O(RGTRM(RGTRM)) Q:RGTRM="" D Q:RGL<0
71 ..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~",RGTRM1="",RGL=$S(RGY:9999999999,1:-1)
72 ..I 'RGY F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" D:$D(^(RGTRM1))>1 Q:RGL>RGM
73 ...S:RGL=-1 RGL=0
74 ...S RGL=RGL+$G(^(RGTRM1))
75 ...S RGTRM1=RGTRM1_$C(255)
76 ..S RGW(RGL,RGTRM)=""
77 ..I RGL>0,RGL<RGM S RGM=RGL
78 ..D:RGABR ABORT
79 Q:$D(RGW(-1)) 0
80 S RGW="",RGF=0
81 F S RGW=$O(RGW(RGW)),RGTRM="" Q:RGW="" D Q:RGF=-1
82 .F S RGTRM=$O(RGW(RGW,RGTRM)) Q:RGTRM="" D Q:RGF=-1
83 ..S RGX=RGTRM(RGTRM)["=",RGY=RGTRM(RGTRM)["~"
84 ..I RGF D
85 ...S RGIEN=0
86 ...F S RGIEN=$O(@RGRTN@(RGIEN)),RGTRM1="" Q:'RGIEN D Q:RGF=-1
87 ....F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" Q:$D(^(RGTRM1,RGIEN))
88 ....I RGY-(RGTRM1="") K @RGRTN@(RGIEN) S:$D(@RGRTN)'>1 RGF=-1
89 ..E D
90 ...S RGTRM1="",RGF=1
91 ...F S RGTRM1=$$STEM(RGTRM1,RGTRM,RGX) Q:RGTRM1="" M @RGRTN=^(RGTRM1)
92 ...S:$D(@RGRTN)'>1 RGF=-1
93 Q $D(@RGRTN)>1
94LKP2 K @RGRTN
95 Q -1
96 ; Check for user abort
97ABORT N RGZ
98 R RGZ#1:0
99 D:RGZ=U RAISE^RGZOSF()
100 Q
101 ; Return in successive calls all terms sharing common stem
102 ; (sets naked reference)
103STEM(RGLAST,RGSTEM,RGF) ;
104 D:RGABR ABORT
105 I RGLAST="" S RGLAST=RGSTEM Q:$D(@RGRT@(RGLAST)) RGLAST
106 Q:$G(RGF) ""
107 S RGLAST=$O(@RGRT@(RGLAST))
108 Q $S($E(RGLAST,1,$L(RGSTEM))=RGSTEM:RGLAST,1:"")
Note: See TracBrowser for help on using the repository browser.