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

CIAUMTL.m

Go to the documentation of this file.
  1. CIAUMTL ;MSC/IND/DKM - Multi-term lookup support ;04-May-2006 08:19;DKM
  1. ;;1.2;CIA UTILITIES;;Mar 20, 2007
  1. ;;Copyright 2000-2006, Medsphere Systems Corporation
  1. ;=================================================================
  1. ; Parse term into component words (KWIC)
  1. PARSE2(CIATRM,CIARTN,CIAMIN) ;
  1. N X,L,C,%
  1. K CIARTN
  1. S %="CIARTN(I)",X=$$UP^XLFSTR(CIATRM),CIAMIN=+$G(CIAMIN)
  1. D S^XTLKWIC
  1. S L="",C=0
  1. F S L=$O(CIARTN(L)) Q:L="" D
  1. .I $L(L)<CIAMIN K CIARTN(L)
  1. .E S C=C+1
  1. Q C
  1. ; Parse term into component words
  1. PARSE(CIATRM,CIARTN,CIAMIN) ;
  1. N X,Y,Z,L,C
  1. K CIARTN
  1. S CIATRM=$$UP^XLFSTR(CIATRM),C=0,CIAMIN=+$G(CIAMIN,1),Z=""
  1. F X=1:1 Q:'$L(CIATRM) D:$E(CIATRM,X)'?1AN
  1. .S Y=Z,Z=$E(CIATRM,X),L=$E(CIATRM,1,X-1),CIATRM=$E(CIATRM,X+1,999),X=0
  1. .I $L(L)'<CIAMIN,L'=+L,'$D(CIARTN(L)) S CIARTN(L)=Y,C=C+1,Y=""
  1. Q C
  1. ; Create/delete an MTL cross reference for term
  1. XREF(CIART,CIATRM,CIADA,CIADEL) ;
  1. N CIAZ,CIAG
  1. S CIAZ=$L(CIART),CIAG=$S($E(CIART,CIAZ)=")":$E(CIART,1,CIAZ-1)_",",1:CIART_"(")_"CIAZ,",CIAZ=$C(1)
  1. F S CIAZ=$O(CIADA(CIAZ),-1) Q:'CIAZ S CIAG=CIAG_""""_CIADA(CIAZ)_""","
  1. S CIAG=CIAG_""""_CIADA_""")"
  1. Q:'$$PARSE(CIATRM,.CIAZ)
  1. S CIAZ="",CIADEL=''$G(CIADEL)
  1. L +@CIART:30
  1. F S CIAZ=$O(CIAZ(CIAZ)) Q:CIAZ="" D
  1. .I ''$D(@CIAG)=CIADEL D
  1. ..I CIADEL K @CIAG K:$D(@CIART@(CIAZ))<10 @CIART@(CIAZ)
  1. ..E D:'$D(@CIART@(CIAZ)) REFNEW(CIAZ) S @CIAG=""
  1. ..D REFCNT(CIAZ,$S(CIADEL:-1,1:1))
  1. L -@CIART
  1. Q
  1. ; Increment/decrement reference count for term and its stems
  1. REFCNT(CIAX,CIAI) ;
  1. Q:'$L(CIAX)
  1. I $D(@CIART@(CIAX)) D
  1. .N CIAZ
  1. .S CIAZ=$G(@CIART@(CIAX))+CIAI
  1. .I CIAZ<1 K @CIART@(CIAX)
  1. .E S @CIART@(CIAX)=CIAZ
  1. D REFCNT($E(CIAX,1,$L(CIAX)-1),CIAI)
  1. Q
  1. ; Create new term reference
  1. REFNEW(CIAX) ;
  1. N CIAZ,CIAC,CIAABR
  1. S CIAZ=CIAX,CIAC=0,CIAABR=0
  1. F S CIAZ=$$STEM(CIAZ,CIAX) Q:'$L(CIAZ) S CIAC=CIAC+$G(@CIART@(CIAZ)),CIAZ=CIAZ_$C(255)
  1. S @CIART@(CIAX)=CIAC
  1. Q
  1. ; Lookup a term in an MTL index
  1. ; CIART = Root of index (e.g., ^CIACOD(990.9,"AD"))
  1. ; CIATRM = Term to lookup
  1. ; CIARTN = Root of returned array (note: killed before populated)
  1. ; CIAABR = If nonzero, user can abort lookup with ^
  1. LKP(CIART,CIATRM,CIARTN,CIAABR) ;
  1. N CIAX,CIAY,CIAW,CIAF,CIAIEN,CIAL,CIAM,CIATRM1
  1. I $$NEWERR^%ZTER N $ET S $ET=""
  1. K @CIARTN
  1. S CIAABR=+$G(CIAABR),@$$TRAP^CIAUOS("LKP2^CIAUMTL")
  1. I $$PARSE(CIATRM,.CIATRM)=1 S CIAW(1,$O(CIATRM("")))=""
  1. E D
  1. .S CIATRM="",CIAM=9999999999
  1. .F S CIATRM=$O(CIATRM(CIATRM)) Q:CIATRM="" D Q:CIAL<0
  1. ..S CIAX=CIATRM(CIATRM)["=",CIAY=CIATRM(CIATRM)["~",CIATRM1="",CIAL=$S(CIAY:9999999999,1:-1)
  1. ..I 'CIAY F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" D:$D(^(CIATRM1))>1 Q:CIAL>CIAM
  1. ...S:CIAL=-1 CIAL=0
  1. ...S CIAL=CIAL+$G(^(CIATRM1))
  1. ...S CIATRM1=CIATRM1_$C(255)
  1. ..S CIAW(CIAL,CIATRM)=""
  1. ..I CIAL>0,CIAL<CIAM S CIAM=CIAL
  1. ..D:CIAABR ABORT
  1. Q:$D(CIAW(-1)) 0
  1. S CIAW="",CIAF=0
  1. F S CIAW=$O(CIAW(CIAW)),CIATRM="" Q:CIAW="" D Q:CIAF=-1
  1. .F S CIATRM=$O(CIAW(CIAW,CIATRM)) Q:CIATRM="" D Q:CIAF=-1
  1. ..S CIAX=CIATRM(CIATRM)["=",CIAY=CIATRM(CIATRM)["~"
  1. ..I CIAF D
  1. ...S CIAIEN=0
  1. ...F S CIAIEN=$O(@CIARTN@(CIAIEN)),CIATRM1="" Q:'CIAIEN D Q:CIAF=-1
  1. ....F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" Q:$D(^(CIATRM1,CIAIEN))
  1. ....I CIAY-(CIATRM1="") K @CIARTN@(CIAIEN) S:$D(@CIARTN)'>1 CIAF=-1
  1. ..E D
  1. ...S CIATRM1="",CIAF=1
  1. ...F S CIATRM1=$$STEM(CIATRM1,CIATRM,CIAX) Q:CIATRM1="" M @CIARTN=^(CIATRM1)
  1. ...S:$D(@CIARTN)'>1 CIAF=-1
  1. Q $D(@CIARTN)>1
  1. LKP2 K @CIARTN
  1. Q -1
  1. ; Check for user abort
  1. ABORT N CIAZ
  1. R CIAZ#1:0
  1. D:CIAZ=U RAISE^CIAUOS()
  1. Q
  1. ; Return in successive calls all terms sharing common stem
  1. ; (sets naked reference)
  1. STEM(CIALAST,CIASTEM,CIAF) ;
  1. D:CIAABR ABORT
  1. I CIALAST="" S CIALAST=CIASTEM Q:$D(@CIART@(CIALAST)) CIALAST
  1. Q:$G(CIAF) ""
  1. S CIALAST=$O(@CIART@(CIALAST))
  1. Q $S($E(CIALAST,1,$L(CIASTEM))=CIASTEM:CIALAST,1:"")