BSTSLSRC ;GDIT/HS/BEE BSTS - New local Search ; 15 Nov 2012 4:26 PM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
Q
;
SRC(OUT,IN) ;Input
; OUT - Output variable/global to return information in (VAR)
; IN - BSTSWS Array
;
;Output
; @VAR@(#) - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Descriptor ID
;
N II,TEXT,ARRAY,NM,TMP,SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,DEBUG,CHKDT
N SCREEN,FILE,FIELD,FLAGS,INDEX,VAL,ERROR,TMP2,RES,RCNT,OCNT,CNT,%,%1,I,X,INMID
;
;Define input variables
F II=1:1 S TEXT=$P($T(FLD+II),";;",2) Q:TEXT="" S ARRAY($P(TEXT,"^",1))=$P(TEXT,"^",2)
S NM="" F S NM=$O(IN(NM)) Q:NM="" I $G(ARRAY(NM))'="" S @ARRAY(NM)=IN(NM)
S:$G(NMID)="" NMID=36
;
S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) I INMID="" Q "0^Invalid Codeset"
;
S CHKDT=$P($$DATE^BSTSUTIL(IN("SNAPDT")),".") I CHKDT="" Q "0^Invalid Check Date"
;
;Define scratch globals
S TMP=$NA(^TMP("BSTSSRCH",$J))
K @TMP
;
;Convert to uppercase
S SEARCH=$$UP^XLFSTR(SEARCH)
;
;Loop through each search term and perform look up
F II=1:1:$L(SEARCH," ") S VAL=$P(SEARCH," ",II) I VAL]"" D
. NEW WORD,TIEN
. ;
. ;Strip out common words
. I ^DD("KWIC")[(U_VAL_U) Q
. ;
. ;Look for exact matches
. S TIEN="" F S TIEN=$O(^BSTS(9002318.3,"E",NMID,VAL,TIEN)) Q:TIEN="" D MATCH(10000,VAL,TIEN,NMID,SEARCH,STYPE)
. ;
. ;Look for partial matches
. S WORD=VAL F S WORD=$O(^BSTS(9002318.3,"E",NMID,WORD)) Q:WORD'[VAL D
.. S TIEN="" F S TIEN=$O(^BSTS(9002318.3,"E",NMID,WORD,TIEN)) Q:TIEN="" D MATCH(5000,VAL,TIEN,NMID,SEARCH,STYPE)
;
;Now Filter and Sort by finding count
S TMP2=$NA(^TMP("BSTSSRCH2",$J)) K @TMP2
S RES="" F S RES=$O(@TMP@(RES)) Q:RES="" D
. N FILTER,CNT,CONC,CIEN,RIN,ROUT
. S FILTER=0
. ;
. ;GET THE CONC and CIEN
. S CONC=$P(RES,U) Q:CONC=""
. S CIEN=$$CIEN^BSTSLKP(CONC,NMID) Q:CIEN=""
. ;
. ;Quit if out of date
. ;BSTS*1.0*4;Change to out of date checking
. ;Allow out of date concepts since server is probably offline
. ;but queue for later update
. ;I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" Q
. I ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="") S ^XTMP("BSTSPROCQ","C",CIEN)=""
. ;
. ;Check revision dates
. S RIN=$$GET1^DIQ(9002318.4,CIEN_",",".05","I")
. S ROUT=$$GET1^DIQ(9002318.4,CIEN_",",".06","I")
. I CHKDT]"",RIN]"",CHKDT<RIN Q ;Check date is before revision in
. I CHKDT]"",ROUT]"",CHKDT>ROUT Q ;Check date is after revision out
. ;
. ;Subset filter
. ;BSTS*1.0*6;ALL search now filter by IHS PROBLEM ALL SNOMED
. ;I SUB]"",SUB'["ALL" D Q:FILTER
. I SUB]"" D Q:FILTER
.. N SB,ISB
.. S FILTER=1
.. F ISB=1:1:$L(SUB,"~") S SB=$P(SUB,"~",ISB) I SB]"",$D(^BSTS(9002318.4,CIEN,4,"B",SB)) S FILTER=0
. ;
. S CNT=@TMP@(RES),@TMP2@(CNT,RES)=""
;
;Set up output
S (RCNT,OCNT)=0,CNT="" F S CNT=$O(@TMP2@(CNT),-1) Q:CNT="" D
. N RES
. S RES="" F S RES=$O(@TMP2@(CNT,RES),-1) Q:RES="" D
.. N D,DI
.. S RCNT=RCNT+1 Q:RCNT>MAX
.. ;
.. ;Start at record
.. I +BCTCHRC>0,RCNT<(+BCTCHRC) Q
.. S OCNT=OCNT+1
.. ;
.. ;Grab BCTCHCT records
.. I +BCTCHCT>0,OCNT>(+BCTCHCT) Q
.. ;
.. ;Set up output
.. S @OUT@(OCNT)=RES
;
K @TMP,@TMP2
;
;Return 1 on successful search
Q $S(OCNT>0:1,1:0)
;
MATCH(WT,VAL,TIEN,NMID,SEARCH,STYPE) ;Perform matching checks/weighting
;
NEW TERM,TYPE,CPT,ENT,DESC,FILTER,CIEN
;
;Get the type - skip FSN for SNOMED
S TYPE=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I") Q:TYPE=""
I TYPE="F",NMID=36 Q
;
;Get the term
S TERM=$$UP^XLFSTR($$GET1^DIQ(9002318.3,TIEN_",",1,"E")) Q:TERM=""
;
;Implement AND logic - must have all terms
S FILTER=0
D Q:FILTER
. NEW PC
. FOR PC=1:1:$L(SEARCH," ") D Q:FILTER
.. NEW WD
.. S WD=$P(SEARCH," ",PC)
.. I TERM'[WD S FILTER=1
;
;Put greatest weight on exact match
I SEARCH=TERM S WT=WT+500000000
;
;BSTS*1.0*6;SRCH Common Terms weighting
S CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I") I CIEN]"" D
. I $O(^BSTS(9002318.4,"E",INMID,"SRCH Common Terms",CIEN,""))]"" S WT=WT+50000000
;
;Look for starting match - Heavily weight starting matches with search string
I STYPE="F",(TYPE="P"!(TYPE="F")),SEARCH=$E(TERM,1,$L(SEARCH)) S WT=WT+500000
I STYPE="S",SEARCH=$E(TERM,1,$L(SEARCH)) S WT=WT+100000
;
;Put higher weight if term starts with any word
I VAL=$E(TERM,1,$L(VAL)) S WT=WT+100000
;
;Give higher weight to preferred terms in FSN searches
I STYPE="F",(TYPE="P"!(TYPE="F")) S WT=WT+500000
;
;Log entry
S CPT=$$GET1^DIQ(9002318.3,TIEN_",",".03","I") Q:CPT=""
S ENT=$$GET1^DIQ(9002318.4,CPT_",",".02","I")_U_$$GET1^DIQ(9002318.4,CPT_",",".08","I")_U
S DESC=$$GET1^DIQ(9002318.3,TIEN_",",".02","I")
;
;If FSN search pull FSN ID
I STYPE="F" S DESC=$P($$PDESC^BSTSSRCH(CPT),U) Q:DESC=""
S ENT=ENT_DESC
S @TMP@(ENT)=$G(@TMP@(ENT))+WT
;
Q
;
FLD ;;
;;SEARCH^SEARCH
;;STYPE^STYPE
;;NAMESPACEID^NMID
;;SUBSET^SUB
;;SNAPDT^SNAPDT
;;MAXRECS^MAX
;;BCTCHRC^BCTCHRC
;;BCTCHCT^BCTCHCT
;;DEBUG^DEBUG
Q
BSTSLSRC ;GDIT/HS/BEE BSTS - New local Search ; 15 Nov 2012 4:26 PM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 QUIT
+3 ;
SRC(OUT,IN) ;Input
+1 ; OUT - Output variable/global to return information in (VAR)
+2 ; IN - BSTSWS Array
+3 ;
+4 ;Output
+5 ; @VAR@(#) - [1]^[2]^[3]
+6 ; [1] - Concept ID
+7 ; [2] - DTS ID
+8 ; [3] - Descriptor ID
+9 ;
+10 NEW II,TEXT,ARRAY,NM,TMP,SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,DEBUG,CHKDT
+11 NEW SCREEN,FILE,FIELD,FLAGS,INDEX,VAL,ERROR,TMP2,RES,RCNT,OCNT,CNT,%,%1,I,X,INMID
+12 ;
+13 ;Define input variables
+14 FOR II=1:1
SET TEXT=$PIECE($TEXT(FLD+II),";;",2)
IF TEXT=""
QUIT
SET ARRAY($PIECE(TEXT,"^",1))=$PIECE(TEXT,"^",2)
+15 SET NM=""
FOR
SET NM=$ORDER(IN(NM))
IF NM=""
QUIT
IF $GET(ARRAY(NM))'=""
SET @ARRAY(NM)=IN(NM)
+16 IF $GET(NMID)=""
SET NMID=36
+17 ;
+18 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0^Invalid Codeset"
+19 ;
+20 SET CHKDT=$PIECE($$DATE^BSTSUTIL(IN("SNAPDT")),".")
IF CHKDT=""
QUIT "0^Invalid Check Date"
+21 ;
+22 ;Define scratch globals
+23 SET TMP=$NAME(^TMP("BSTSSRCH",$JOB))
+24 KILL @TMP
+25 ;
+26 ;Convert to uppercase
+27 SET SEARCH=$$UP^XLFSTR(SEARCH)
+28 ;
+29 ;Loop through each search term and perform look up
+30 FOR II=1:1:$LENGTH(SEARCH," ")
SET VAL=$PIECE(SEARCH," ",II)
IF VAL]""
Begin DoDot:1
+31 NEW WORD,TIEN
+32 ;
+33 ;Strip out common words
+34 IF ^DD("KWIC")[(U_VAL_U)
QUIT
+35 ;
+36 ;Look for exact matches
+37 SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"E",NMID,VAL,TIEN))
IF TIEN=""
QUIT
DO MATCH(10000,VAL,TIEN,NMID,SEARCH,STYPE)
+38 ;
+39 ;Look for partial matches
+40 SET WORD=VAL
FOR
SET WORD=$ORDER(^BSTS(9002318.3,"E",NMID,WORD))
IF WORD'[VAL
QUIT
Begin DoDot:2
+41 SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"E",NMID,WORD,TIEN))
IF TIEN=""
QUIT
DO MATCH(5000,VAL,TIEN,NMID,SEARCH,STYPE)
End DoDot:2
End DoDot:1
+42 ;
+43 ;Now Filter and Sort by finding count
+44 SET TMP2=$NAME(^TMP("BSTSSRCH2",$JOB))
KILL @TMP2
+45 SET RES=""
FOR
SET RES=$ORDER(@TMP@(RES))
IF RES=""
QUIT
Begin DoDot:1
+46 NEW FILTER,CNT,CONC,CIEN,RIN,ROUT
+47 SET FILTER=0
+48 ;
+49 ;GET THE CONC and CIEN
+50 SET CONC=$PIECE(RES,U)
IF CONC=""
QUIT
+51 SET CIEN=$$CIEN^BSTSLKP(CONC,NMID)
IF CIEN=""
QUIT
+52 ;
+53 ;Quit if out of date
+54 ;BSTS*1.0*4;Change to out of date checking
+55 ;Allow out of date concepts since server is probably offline
+56 ;but queue for later update
+57 ;I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" Q
+58 IF ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="")
SET ^XTMP("BSTSPROCQ","C",CIEN)=""
+59 ;
+60 ;Check revision dates
+61 SET RIN=$$GET1^DIQ(9002318.4,CIEN_",",".05","I")
+62 SET ROUT=$$GET1^DIQ(9002318.4,CIEN_",",".06","I")
+63 ;Check date is before revision in
IF CHKDT]""
IF RIN]""
IF CHKDT<RIN
QUIT
+64 ;Check date is after revision out
IF CHKDT]""
IF ROUT]""
IF CHKDT>ROUT
QUIT
+65 ;
+66 ;Subset filter
+67 ;BSTS*1.0*6;ALL search now filter by IHS PROBLEM ALL SNOMED
+68 ;I SUB]"",SUB'["ALL" D Q:FILTER
+69 IF SUB]""
Begin DoDot:2
+70 NEW SB,ISB
+71 SET FILTER=1
+72 FOR ISB=1:1:$LENGTH(SUB,"~")
SET SB=$PIECE(SUB,"~",ISB)
IF SB]""
IF $DATA(^BSTS(9002318.4,CIEN,4,"B",SB))
SET FILTER=0
End DoDot:2
IF FILTER
QUIT
+73 ;
+74 SET CNT=@TMP@(RES)
SET @TMP2@(CNT,RES)=""
End DoDot:1
+75 ;
+76 ;Set up output
+77 SET (RCNT,OCNT)=0
SET CNT=""
FOR
SET CNT=$ORDER(@TMP2@(CNT),-1)
IF CNT=""
QUIT
Begin DoDot:1
+78 NEW RES
+79 SET RES=""
FOR
SET RES=$ORDER(@TMP2@(CNT,RES),-1)
IF RES=""
QUIT
Begin DoDot:2
+80 NEW D,DI
+81 SET RCNT=RCNT+1
IF RCNT>MAX
QUIT
+82 ;
+83 ;Start at record
+84 IF +BCTCHRC>0
IF RCNT<(+BCTCHRC)
QUIT
+85 SET OCNT=OCNT+1
+86 ;
+87 ;Grab BCTCHCT records
+88 IF +BCTCHCT>0
IF OCNT>(+BCTCHCT)
QUIT
+89 ;
+90 ;Set up output
+91 SET @OUT@(OCNT)=RES
End DoDot:2
End DoDot:1
+92 ;
+93 KILL @TMP,@TMP2
+94 ;
+95 ;Return 1 on successful search
+96 QUIT $SELECT(OCNT>0:1,1:0)
+97 ;
MATCH(WT,VAL,TIEN,NMID,SEARCH,STYPE) ;Perform matching checks/weighting
+1 ;
+2 NEW TERM,TYPE,CPT,ENT,DESC,FILTER,CIEN
+3 ;
+4 ;Get the type - skip FSN for SNOMED
+5 SET TYPE=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I")
IF TYPE=""
QUIT
+6 IF TYPE="F"
IF NMID=36
QUIT
+7 ;
+8 ;Get the term
+9 SET TERM=$$UP^XLFSTR($$GET1^DIQ(9002318.3,TIEN_",",1,"E"))
IF TERM=""
QUIT
+10 ;
+11 ;Implement AND logic - must have all terms
+12 SET FILTER=0
+13 Begin DoDot:1
+14 NEW PC
+15 FOR PC=1:1:$LENGTH(SEARCH," ")
Begin DoDot:2
+16 NEW WD
+17 SET WD=$PIECE(SEARCH," ",PC)
+18 IF TERM'[WD
SET FILTER=1
End DoDot:2
IF FILTER
QUIT
End DoDot:1
IF FILTER
QUIT
+19 ;
+20 ;Put greatest weight on exact match
+21 IF SEARCH=TERM
SET WT=WT+500000000
+22 ;
+23 ;BSTS*1.0*6;SRCH Common Terms weighting
+24 SET CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I")
IF CIEN]""
Begin DoDot:1
+25 IF $ORDER(^BSTS(9002318.4,"E",INMID,"SRCH Common Terms",CIEN,""))]""
SET WT=WT+50000000
End DoDot:1
+26 ;
+27 ;Look for starting match - Heavily weight starting matches with search string
+28 IF STYPE="F"
IF (TYPE="P"!(TYPE="F"))
IF SEARCH=$EXTRACT(TERM,1,$LENGTH(SEARCH))
SET WT=WT+500000
+29 IF STYPE="S"
IF SEARCH=$EXTRACT(TERM,1,$LENGTH(SEARCH))
SET WT=WT+100000
+30 ;
+31 ;Put higher weight if term starts with any word
+32 IF VAL=$EXTRACT(TERM,1,$LENGTH(VAL))
SET WT=WT+100000
+33 ;
+34 ;Give higher weight to preferred terms in FSN searches
+35 IF STYPE="F"
IF (TYPE="P"!(TYPE="F"))
SET WT=WT+500000
+36 ;
+37 ;Log entry
+38 SET CPT=$$GET1^DIQ(9002318.3,TIEN_",",".03","I")
IF CPT=""
QUIT
+39 SET ENT=$$GET1^DIQ(9002318.4,CPT_",",".02","I")_U_$$GET1^DIQ(9002318.4,CPT_",",".08","I")_U
+40 SET DESC=$$GET1^DIQ(9002318.3,TIEN_",",".02","I")
+41 ;
+42 ;If FSN search pull FSN ID
+43 IF STYPE="F"
SET DESC=$PIECE($$PDESC^BSTSSRCH(CPT),U)
IF DESC=""
QUIT
+44 SET ENT=ENT_DESC
+45 SET @TMP@(ENT)=$GET(@TMP@(ENT))+WT
+46 ;
+47 QUIT
+48 ;
FLD ;;
+1 ;;SEARCH^SEARCH
+2 ;;STYPE^STYPE
+3 ;;NAMESPACEID^NMID
+4 ;;SUBSET^SUB
+5 ;;SNAPDT^SNAPDT
+6 ;;MAXRECS^MAX
+7 ;;BCTCHRC^BCTCHRC
+8 ;;BCTCHCT^BCTCHCT
+9 ;;DEBUG^DEBUG
+10 QUIT
