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

BSTSLSRC.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1.  ;
  1. SRC(OUT,IN) ;Input
  1.  ; OUT - Output variable/global to return information in (VAR)
  1.  ;  IN - BSTSWS Array
  1.  ;
  1.  ;Output
  1.  ; @VAR@(#) - [1]^[2]^[3]
  1.  ; [1] - Concept ID
  1.  ; [2] - DTS ID
  1.  ; [3] - Descriptor ID
  1.  ;
  1.  N II,TEXT,ARRAY,NM,TMP,SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,DEBUG,CHKDT
  1.  N SCREEN,FILE,FIELD,FLAGS,INDEX,VAL,ERROR,TMP2,RES,RCNT,OCNT,CNT,%,%1,I,X,INMID
  1.  ;
  1.  ;Define input variables 
  1.  F II=1:1 S TEXT=$P($T(FLD+II),";;",2) Q:TEXT=""  S ARRAY($P(TEXT,"^",1))=$P(TEXT,"^",2)
  1.  S NM="" F  S NM=$O(IN(NM)) Q:NM=""  I $G(ARRAY(NM))'="" S @ARRAY(NM)=IN(NM)
  1.  S:$G(NMID)="" NMID=36
  1.  ;
  1.  S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) I INMID="" Q "0^Invalid Codeset"
  1.  ;
  1.  S CHKDT=$P($$DATE^BSTSUTIL(IN("SNAPDT")),".") I CHKDT="" Q "0^Invalid Check Date"
  1.  ;
  1.  ;Define scratch globals
  1.  S TMP=$NA(^TMP("BSTSSRCH",$J))
  1.  K @TMP
  1.  ;
  1.  ;Convert to uppercase
  1.  S SEARCH=$$UP^XLFSTR(SEARCH)
  1.  ;
  1.  ;Loop through each search term and perform look up
  1.  F II=1:1:$L(SEARCH," ") S VAL=$P(SEARCH," ",II) I VAL]"" D
  1.  . NEW WORD,TIEN
  1.  . ;
  1.  . ;Strip out common words
  1.  . I ^DD("KWIC")[(U_VAL_U) Q
  1.  . ;
  1.  . ;Look for exact matches
  1.  . S TIEN="" F  S TIEN=$O(^BSTS(9002318.3,"E",NMID,VAL,TIEN)) Q:TIEN=""  D MATCH(10000,VAL,TIEN,NMID,SEARCH,STYPE)
  1.  . ;
  1.  . ;Look for partial matches
  1.  . S WORD=VAL F  S WORD=$O(^BSTS(9002318.3,"E",NMID,WORD)) Q:WORD'[VAL  D
  1.  .. S TIEN="" F  S TIEN=$O(^BSTS(9002318.3,"E",NMID,WORD,TIEN)) Q:TIEN=""  D MATCH(5000,VAL,TIEN,NMID,SEARCH,STYPE)
  1.  ;
  1.  ;Now Filter and Sort by finding count
  1.  S TMP2=$NA(^TMP("BSTSSRCH2",$J)) K @TMP2
  1.  S RES="" F  S RES=$O(@TMP@(RES)) Q:RES=""  D
  1.  . N FILTER,CNT,CONC,CIEN,RIN,ROUT
  1.  . S FILTER=0
  1.  . ;
  1.  . ;GET THE CONC and CIEN
  1.  . S CONC=$P(RES,U) Q:CONC=""
  1.  . S CIEN=$$CIEN^BSTSLKP(CONC,NMID) Q:CIEN=""
  1.  . ;
  1.  . ;Quit if out of date
  1.  . ;BSTS*1.0*4;Change to out of date checking
  1.  . ;Allow out of date concepts since server is probably offline
  1.  . ;but queue for later update
  1.  . ;I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" Q
  1.  . I ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="") S ^XTMP("BSTSPROCQ","C",CIEN)=""
  1.  . ;
  1.  . ;Check revision dates
  1.  . S RIN=$$GET1^DIQ(9002318.4,CIEN_",",".05","I")
  1.  . S ROUT=$$GET1^DIQ(9002318.4,CIEN_",",".06","I")
  1.  . I CHKDT]"",RIN]"",CHKDT<RIN Q  ;Check date is before revision in
  1.  . I CHKDT]"",ROUT]"",CHKDT>ROUT Q  ;Check date is after revision out
  1.  . ;
  1.  . ;Subset filter
  1.  . ;BSTS*1.0*6;ALL search now filter by IHS PROBLEM ALL SNOMED
  1.  . ;I SUB]"",SUB'["ALL" D  Q:FILTER
  1.  . I SUB]"" D  Q:FILTER
  1.  .. N SB,ISB
  1.  .. S FILTER=1
  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
  1.  . ;
  1.  . S CNT=@TMP@(RES),@TMP2@(CNT,RES)=""
  1.  ;
  1.  ;Set up output
  1.  S (RCNT,OCNT)=0,CNT="" F  S CNT=$O(@TMP2@(CNT),-1) Q:CNT=""  D
  1.  . N RES
  1.  . S RES="" F  S RES=$O(@TMP2@(CNT,RES),-1) Q:RES=""  D
  1.  .. N D,DI
  1.  .. S RCNT=RCNT+1 Q:RCNT>MAX
  1.  .. ;
  1.  .. ;Start at record
  1.  .. I +BCTCHRC>0,RCNT<(+BCTCHRC) Q
  1.  .. S OCNT=OCNT+1
  1.  .. ;
  1.  .. ;Grab BCTCHCT records
  1.  .. I +BCTCHCT>0,OCNT>(+BCTCHCT) Q
  1.  .. ;
  1.  .. ;Set up output
  1.  .. S @OUT@(OCNT)=RES
  1.  ;
  1.  K @TMP,@TMP2
  1.  ;
  1.  ;Return 1 on successful search
  1.  Q $S(OCNT>0:1,1:0)
  1.  ;
  1. MATCH(WT,VAL,TIEN,NMID,SEARCH,STYPE) ;Perform matching checks/weighting
  1.  ;
  1.  NEW TERM,TYPE,CPT,ENT,DESC,FILTER,CIEN
  1.  ;
  1.  ;Get the type - skip FSN for SNOMED
  1.  S TYPE=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I") Q:TYPE=""
  1.  I TYPE="F",NMID=36 Q
  1.  ;
  1.  ;Get the term
  1.  S TERM=$$UP^XLFSTR($$GET1^DIQ(9002318.3,TIEN_",",1,"E")) Q:TERM=""
  1.  ;
  1.  ;Implement AND logic - must have all terms
  1.  S FILTER=0
  1.  D  Q:FILTER
  1.  . NEW PC
  1.  . FOR PC=1:1:$L(SEARCH," ") D  Q:FILTER
  1.  .. NEW WD
  1.  .. S WD=$P(SEARCH," ",PC)
  1.  .. I TERM'[WD S FILTER=1
  1.  ;
  1.  ;Put greatest weight on exact match
  1.  I SEARCH=TERM S WT=WT+500000000
  1.  ;
  1.  ;BSTS*1.0*6;SRCH Common Terms weighting
  1.  S CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I") I CIEN]"" D
  1.  . I $O(^BSTS(9002318.4,"E",INMID,"SRCH Common Terms",CIEN,""))]"" S WT=WT+50000000
  1.  ;
  1.  ;Look for starting match - Heavily weight starting matches with search string
  1.  I STYPE="F",(TYPE="P"!(TYPE="F")),SEARCH=$E(TERM,1,$L(SEARCH)) S WT=WT+500000
  1.  I STYPE="S",SEARCH=$E(TERM,1,$L(SEARCH)) S WT=WT+100000
  1.  ;
  1.  ;Put higher weight if term starts with any word
  1.  I VAL=$E(TERM,1,$L(VAL)) S WT=WT+100000
  1.  ;
  1.  ;Give higher weight to preferred terms in FSN searches
  1.  I STYPE="F",(TYPE="P"!(TYPE="F")) S WT=WT+500000
  1.  ;
  1.  ;Log entry
  1.  S CPT=$$GET1^DIQ(9002318.3,TIEN_",",".03","I") Q:CPT=""
  1.  S ENT=$$GET1^DIQ(9002318.4,CPT_",",".02","I")_U_$$GET1^DIQ(9002318.4,CPT_",",".08","I")_U
  1.  S DESC=$$GET1^DIQ(9002318.3,TIEN_",",".02","I")
  1.  ;
  1.  ;If FSN search pull FSN ID
  1.  I STYPE="F" S DESC=$P($$PDESC^BSTSSRCH(CPT),U) Q:DESC=""
  1.  S ENT=ENT_DESC
  1.  S @TMP@(ENT)=$G(@TMP@(ENT))+WT
  1.  ;
  1.  Q
  1.  ;
  1. FLD ;;
  1.  ;;SEARCH^SEARCH
  1.  ;;STYPE^STYPE
  1.  ;;NAMESPACEID^NMID
  1.  ;;SUBSET^SUB
  1.  ;;SNAPDT^SNAPDT
  1.  ;;MAXRECS^MAX
  1.  ;;BCTCHRC^BCTCHRC
  1.  ;;BCTCHCT^BCTCHCT
  1.  ;;DEBUG^DEBUG
  1.  Q