- 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:"")