CIAUMTL ;MSC/IND/DKM - Multi-term lookup support ;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Parse term into component words (KWIC)
PARSE2(CIATRM,CIARTN,CIAMIN) ;
N X,L,C,%
K CIARTN
S %="CIARTN(I)",X=$$UP^XLFSTR(CIATRM),CIAMIN=+$G(CIAMIN)
D S^XTLKWIC
S L="",C=0
F S L=$O(CIARTN(L)) Q:L="" D
.I $L(L)<CIAMIN K CIARTN(L)
.E S C=C+1
Q C
; Parse term into component words
PARSE(CIATRM,CIARTN,CIAMIN) ;
N X,Y,Z,L,C
K CIARTN
S CIATRM=$$UP^XLFSTR(CIATRM),C=0,CIAMIN=+$G(CIAMIN,1),Z=""
F X=1:1 Q:'$L(CIATRM) D:$E(CIATRM,X)'?1AN
.S Y=Z,Z=$E(CIATRM,X),L=$E(CIATRM,1,X-1),CIATRM=$E(CIATRM,X+1,999),X=0
.I $L(L)'<CIAMIN,L'=+L,'$D(CIARTN(L)) S CIARTN(L)=Y,C=C+1,Y=""
Q C
; Create/delete an MTL cross reference for term
XREF(CIART,CIATRM,CIADA,CIADEL) ;
N CIAZ,CIAG
S CIAZ=$L(CIART),CIAG=$S($E(CIART,CIAZ)=")":$E(CIART,1,CIAZ-1)_",",1:CIART_"(")_"CIAZ,",CIAZ=$C(1)
F S CIAZ=$O(CIADA(CIAZ),-1) Q:'CIAZ S CIAG=CIAG_""""_CIADA(CIAZ)_""","
S CIAG=CIAG_""""_CIADA_""")"
Q:'$$PARSE(CIATRM,.CIAZ)
S CIAZ="",CIADEL=''$G(CIADEL)
L +@CIART:30
F S CIAZ=$O(CIAZ(CIAZ)) Q:CIAZ="" D
.I ''$D(@CIAG)=CIADEL D
..I CIADEL K @CIAG K:$D(@CIART@(CIAZ))<10 @CIART@(CIAZ)
..E D:'$D(@CIART@(CIAZ)) REFNEW(CIAZ) S @CIAG=""
..D REFCNT(CIAZ,$S(CIADEL:-1,1:1))
L -@CIART
Q
; Increment/decrement reference count for term and its stems
REFCNT(CIAX,CIAI) ;
Q:'$L(CIAX)
I $D(@CIART@(CIAX)) D
.N CIAZ
.S CIAZ=$G(@CIART@(CIAX))+CIAI
.I CIAZ<1 K @CIART@(CIAX)
.E S @CIART@(CIAX)=CIAZ
D REFCNT($E(CIAX,1,$L(CIAX)-1),CIAI)
Q
; Create new term reference
REFNEW(CIAX) ;
N CIAZ,CIAC,CIAABR
S CIAZ=CIAX,CIAC=0,CIAABR=0
F S CIAZ=$$STEM(CIAZ,CIAX) Q:'$L(CIAZ) S CIAC=CIAC+$G(@CIART@(CIAZ)),CIAZ=CIAZ_$C(255)
S @CIART@(CIAX)=CIAC
Q
; Lookup a term in an MTL index
; CIART = Root of index (e.g., ^CIACOD(990.9,"AD"))
; CIATRM = Term to lookup
; CIARTN = Root of returned array (note: killed before populated)
; CIAABR = If nonzero, user can abort lookup with ^
LKP(CIART,CIATRM,CIARTN,CIAABR) ;
N CIAX,CIAY,CIAW,CIAF,CIAIEN,CIAL,CIAM,CIATRM1
I $$NEWERR^%ZTER N $ET S $ET=""
K @CIARTN
S CIAABR=+$G(CIAABR),@$$TRAP^CIAUOS("LKP2^CIAUMTL")
I $$PARSE(CIATRM,.CIATRM)=1 S CIAW(1,$O(CIATRM("")))=""
E D
.S CIATRM="",CIAM=9999999999
.F S CIATRM=$O(CIATRM(CIATRM)) Q:CIATRM="" D Q:CIAL<0
..S CIAX=CIATRM(CIATRM)["=",CIAY=CIATRM(CIATRM)["~",CIATRM1="",CIAL=$S(CIAY:9999999999,1:-1)
..I 'CIAY F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" D:$D(^(CIATRM1))>1 Q:CIAL>CIAM
...S:CIAL=-1 CIAL=0
...S CIAL=CIAL+$G(^(CIATRM1))
...S CIATRM1=CIATRM1_$C(255)
..S CIAW(CIAL,CIATRM)=""
..I CIAL>0,CIAL<CIAM S CIAM=CIAL
..D:CIAABR ABORT
Q:$D(CIAW(-1)) 0
S CIAW="",CIAF=0
F S CIAW=$O(CIAW(CIAW)),CIATRM="" Q:CIAW="" D Q:CIAF=-1
.F S CIATRM=$O(CIAW(CIAW,CIATRM)) Q:CIATRM="" D Q:CIAF=-1
..S CIAX=CIATRM(CIATRM)["=",CIAY=CIATRM(CIATRM)["~"
..I CIAF D
...S CIAIEN=0
...F S CIAIEN=$O(@CIARTN@(CIAIEN)),CIATRM1="" Q:'CIAIEN D Q:CIAF=-1
....F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" Q:$D(^(CIATRM1,CIAIEN))
....I CIAY-(CIATRM1="") K @CIARTN@(CIAIEN) S:$D(@CIARTN)'>1 CIAF=-1
..E D
...S CIATRM1="",CIAF=1
...F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" M @CIARTN=^(CIATRM1)
...S:$D(@CIARTN)'>1 CIAF=-1
Q $D(@CIARTN)>1
LKP2 K @CIARTN
Q -1
; Check for user abort
ABORT N CIAZ
R CIAZ#1:0
D:CIAZ=U RAISE^CIAUOS()
Q
; Return in successive calls all terms sharing common stem
; (sets naked reference)
STEM(CIALAST,CIASTEM,CIAF) ;
D:CIAABR ABORT
I CIALAST="" S CIALAST=CIASTEM Q:$D(@CIART@(CIALAST)) CIALAST
Q:$G(CIAF) ""
S CIALAST=$O(@CIART@(CIALAST))
Q $S($E(CIALAST,1,$L(CIASTEM))=CIASTEM:CIALAST,1:"")
CIAUMTL ;MSC/IND/DKM - Multi-term lookup support ;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Parse term into component words (KWIC)
PARSE2(CIATRM,CIARTN,CIAMIN) ;
+1 NEW X,L,C,%
+2 KILL CIARTN
+3 SET %="CIARTN(I)"
SET X=$$UP^XLFSTR(CIATRM)
SET CIAMIN=+$GET(CIAMIN)
+4 DO S^XTLKWIC
+5 SET L=""
SET C=0
+6 FOR
SET L=$ORDER(CIARTN(L))
IF L=""
QUIT
Begin DoDot:1
+7 IF $LENGTH(L)<CIAMIN
KILL CIARTN(L)
+8 IF '$TEST
SET C=C+1
End DoDot:1
+9 QUIT C
+10 ; Parse term into component words
PARSE(CIATRM,CIARTN,CIAMIN) ;
+1 NEW X,Y,Z,L,C
+2 KILL CIARTN
+3 SET CIATRM=$$UP^XLFSTR(CIATRM)
SET C=0
SET CIAMIN=+$GET(CIAMIN,1)
SET Z=""
+4 FOR X=1:1
IF '$LENGTH(CIATRM)
QUIT
IF $EXTRACT(CIATRM,X)'?1AN
Begin DoDot:1
+5 SET Y=Z
SET Z=$EXTRACT(CIATRM,X)
SET L=$EXTRACT(CIATRM,1,X-1)
SET CIATRM=$EXTRACT(CIATRM,X+1,999)
SET X=0
+6 IF $LENGTH(L)'<CIAMIN
IF L'=+L
IF '$DATA(CIARTN(L))
SET CIARTN(L)=Y
SET C=C+1
SET Y=""
End DoDot:1
+7 QUIT C
+8 ; Create/delete an MTL cross reference for term
XREF(CIART,CIATRM,CIADA,CIADEL) ;
+1 NEW CIAZ,CIAG
+2 SET CIAZ=$LENGTH(CIART)
SET CIAG=$SELECT($EXTRACT(CIART,CIAZ)=")":$EXTRACT(CIART,1,CIAZ-1)_",",1:CIART_"(")_"CIAZ,"
SET CIAZ=$CHAR(1)
+3 FOR
SET CIAZ=$ORDER(CIADA(CIAZ),-1)
IF 'CIAZ
QUIT
SET CIAG=CIAG_""""_CIADA(CIAZ)_""","
+4 SET CIAG=CIAG_""""_CIADA_""")"
+5 IF '$$PARSE(CIATRM,.CIAZ)
QUIT
+6 SET CIAZ=""
SET CIADEL=''$GET(CIADEL)
+7 LOCK +@CIART:30
+8 FOR
SET CIAZ=$ORDER(CIAZ(CIAZ))
IF CIAZ=""
QUIT
Begin DoDot:1
+9 IF ''$DATA(@CIAG)=CIADEL
Begin DoDot:2
+10 IF CIADEL
KILL @CIAG
IF $DATA(@CIART@(CIAZ))<10
KILL @CIART@(CIAZ)
+11 IF '$TEST
IF '$DATA(@CIART@(CIAZ))
DO REFNEW(CIAZ)
SET @CIAG=""
+12 DO REFCNT(CIAZ,$SELECT(CIADEL:-1,1:1))
End DoDot:2
End DoDot:1
+13 LOCK -@CIART
+14 QUIT
+15 ; Increment/decrement reference count for term and its stems
REFCNT(CIAX,CIAI) ;
+1 IF '$LENGTH(CIAX)
QUIT
+2 IF $DATA(@CIART@(CIAX))
Begin DoDot:1
+3 NEW CIAZ
+4 SET CIAZ=$GET(@CIART@(CIAX))+CIAI
+5 IF CIAZ<1
KILL @CIART@(CIAX)
+6 IF '$TEST
SET @CIART@(CIAX)=CIAZ
End DoDot:1
+7 DO REFCNT($EXTRACT(CIAX,1,$LENGTH(CIAX)-1),CIAI)
+8 QUIT
+9 ; Create new term reference
REFNEW(CIAX) ;
+1 NEW CIAZ,CIAC,CIAABR
+2 SET CIAZ=CIAX
SET CIAC=0
SET CIAABR=0
+3 FOR
SET CIAZ=$$STEM(CIAZ,CIAX)
IF '$LENGTH(CIAZ)
QUIT
SET CIAC=CIAC+$GET(@CIART@(CIAZ))
SET CIAZ=CIAZ_$CHAR(255)
+4 SET @CIART@(CIAX)=CIAC
+5 QUIT
+6 ; Lookup a term in an MTL index
+7 ; CIART = Root of index (e.g., ^CIACOD(990.9,"AD"))
+8 ; CIATRM = Term to lookup
+9 ; CIARTN = Root of returned array (note: killed before populated)
+10 ; CIAABR = If nonzero, user can abort lookup with ^
LKP(CIART,CIATRM,CIARTN,CIAABR) ;
+1 NEW CIAX,CIAY,CIAW,CIAF,CIAIEN,CIAL,CIAM,CIATRM1
+2 IF $$NEWERR^%ZTER
NEW $ETRAP
SET $ETRAP=""
+3 KILL @CIARTN
+4 SET CIAABR=+$GET(CIAABR)
SET @$$TRAP^CIAUOS("LKP2^CIAUMTL")
+5 IF $$PARSE(CIATRM,.CIATRM)=1
SET CIAW(1,$ORDER(CIATRM("")))=""
+6 IF '$TEST
Begin DoDot:1
+7 SET CIATRM=""
SET CIAM=9999999999
+8 FOR
SET CIATRM=$ORDER(CIATRM(CIATRM))
IF CIATRM=""
QUIT
Begin DoDot:2
+9 SET CIAX=CIATRM(CIATRM)["="
SET CIAY=CIATRM(CIATRM)["~"
SET CIATRM1=""
SET CIAL=$SELECT(CIAY:9999999999,1:-1)
+10 IF 'CIAY
FOR
SET CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX)
IF CIATRM1=""
QUIT
IF $DATA(^(CIATRM1))>1
Begin DoDot:3
+11 IF CIAL=-1
SET CIAL=0
+12 SET CIAL=CIAL+$GET(^(CIATRM1))
+13 SET CIATRM1=CIATRM1_$CHAR(255)
End DoDot:3
IF CIAL>CIAM
QUIT
+14 SET CIAW(CIAL,CIATRM)=""
+15 IF CIAL>0
IF CIAL<CIAM
SET CIAM=CIAL
+16 IF CIAABR
DO ABORT
End DoDot:2
IF CIAL<0
QUIT
End DoDot:1
+17 IF $DATA(CIAW(-1))
QUIT 0
+18 SET CIAW=""
SET CIAF=0
+19 FOR
SET CIAW=$ORDER(CIAW(CIAW))
SET CIATRM=""
IF CIAW=""
QUIT
Begin DoDot:1
+20 FOR
SET CIATRM=$ORDER(CIAW(CIAW,CIATRM))
IF CIATRM=""
QUIT
Begin DoDot:2
+21 SET CIAX=CIATRM(CIATRM)["="
SET CIAY=CIATRM(CIATRM)["~"
+22 IF CIAF
Begin DoDot:3
+23 SET CIAIEN=0
+24 FOR
SET CIAIEN=$ORDER(@CIARTN@(CIAIEN))
SET CIATRM1=""
IF 'CIAIEN
QUIT
Begin DoDot:4
+25 FOR
SET CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX)
IF CIATRM1=""
QUIT
IF $DATA(^(CIATRM1,CIAIEN))
QUIT
+26 IF CIAY-(CIATRM1="")
KILL @CIARTN@(CIAIEN)
IF $DATA(@CIARTN)'>1
SET CIAF=-1
End DoDot:4
IF CIAF=-1
QUIT
End DoDot:3
+27 IF '$TEST
Begin DoDot:3
+28 SET CIATRM1=""
SET CIAF=1
+29 FOR
SET CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX)
IF CIATRM1=""
QUIT
MERGE @CIARTN=^(CIATRM1)
+30 IF $DATA(@CIARTN)'>1
SET CIAF=-1
End DoDot:3
End DoDot:2
IF CIAF=-1
QUIT
End DoDot:1
IF CIAF=-1
QUIT
+31 QUIT $DATA(@CIARTN)>1
LKP2 KILL @CIARTN
+1 QUIT -1
+2 ; Check for user abort
ABORT NEW CIAZ
+1 READ CIAZ#1:0
+2 IF CIAZ=U
DO RAISE^CIAUOS()
+3 QUIT
+4 ; Return in successive calls all terms sharing common stem
+5 ; (sets naked reference)
STEM(CIALAST,CIASTEM,CIAF) ;
+1 IF CIAABR
DO ABORT
+2 IF CIALAST=""
SET CIALAST=CIASTEM
IF $DATA(@CIART@(CIALAST))
QUIT CIALAST
+3 IF $GET(CIAF)
QUIT ""
+4 SET CIALAST=$ORDER(@CIART@(CIALAST))
+5 QUIT $SELECT($EXTRACT(CIALAST,1,$LENGTH(CIASTEM))=CIASTEM:CIALAST,1:"")
