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

BSTSSRCH.m

Go to the documentation of this file. 
  1. BSTSSRCH ;GDIT/HS/ALA-Search terms ; 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.  ;Make call to new search logic
  1.  Q $$SRC^BSTSLSRC(.OUT,.IN)
  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 global
  1.  S TMP=$NA(^TMP("BSTSSRCH",$J))
  1.  K @TMP
  1.  ;
  1.  ;Define FileMan scratch global
  1.  K ^TMP("DILIST",$J)
  1.  ;
  1.  ;Loop through each search term and perform look up
  1.  S SCREEN="I $P(^(0),U,8)="_INMID
  1.  S FILE=9002318.3,FIELD=".02;.03;.09;1",FLAGS="PCM",INDEX="E"
  1.  F II=1:1:$L(SEARCH," ") S VAL=$P(SEARCH," ",II) D
  1.  . N N,TOT,VALUE
  1.  . S VALUE=$$UP^XLFSTR(VAL)
  1.  . D FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",INDEX,SCREEN,"","","ERROR")
  1.  . S TOT=$P($G(^TMP("DILIST",$J,0)),"^",1)
  1.  . I TOT=0 Q
  1.  . F N=1:1:TOT D FND(N,SEARCH,NMID)
  1.  . Q
  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.  . I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" Q
  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.  . 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,^TMP("DILIST",$J,0)
  1.  ;
  1.  ;Return 1 on successful search
  1.  Q $S(OCNT>0:1,1:0)
  1.  ;
  1. FDESC(CIEN) ;EP - Retrieve Description Id of FSN
  1.  ;
  1.  N TIEN,NMID,DESC
  1.  ;
  1.  S NMID=$$GET1^DIQ(9002318.4,CIEN_",",.07,"E") Q:NMID="" ""
  1.  S (DESC,TIEN)="" F  S TIEN=$O(^BSTS(9002318.3,"C",NMID,CIEN,TIEN)) Q:TIEN=""  D  Q:DESC
  1.  . N TYPE
  1.  . S TYPE=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I") I TYPE'="F" Q
  1.  . S DESC=$$GET1^DIQ(9002318.3,TIEN_",",.02,"E")
  1.  ;
  1.  Q DESC
  1.  ;
  1. PDESC(CIEN) ;EP - Retrieve Description Id of Preferred Term
  1.  ;
  1.  N TIEN,NMID,DESC
  1.  ;
  1.  S NMID=$$GET1^DIQ(9002318.4,CIEN_",",.07,"E") Q:NMID="" ""
  1.  S (DESC,TIEN)="" F  S TIEN=$O(^BSTS(9002318.3,"C",NMID,CIEN,TIEN)) Q:TIEN=""  D  Q:DESC
  1.  . N TYPE,TERM
  1.  . S TYPE=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I")
  1.  . ;
  1.  . ;For SNOMED look for preferred
  1.  . ;For UNII look for FSN
  1.  . ;For RXNORM look for preferred
  1.  . I NMID=36,TYPE'="P" Q
  1.  . I NMID=5180,TYPE'="F" Q
  1.  . I NMID=1552,TYPE'="P" Q
  1.  . I NMID>32770,NMID<32780,TYPE'="F" Q
  1.  . ;
  1.  . S DESC=$$GET1^DIQ(9002318.3,TIEN_",",.02,"E")
  1.  . S TERM=$$GET1^DIQ(9002318.3,TIEN_",",1,"E")
  1.  . S DESC=DESC_U_TERM
  1.  ;
  1.  Q DESC
  1.  ;
  1. FND(N,SEARCH,NMID) ;Set up return entry
  1.  N ENT,CPT,FILTER,DESC,TERM,WGT,USEARCH,PC,UTERM
  1.  S CPT=$P(^TMP("DILIST",$J,N,0),U,4) Q:CPT=""
  1.  S ENT=$P(^BSTS(9002318.4,CPT,0),"^",2)_"^"_$P(^(0),"^",8)_"^"
  1.  S DESC=$P(^TMP("DILIST",$J,N,0),U,3) Q:DESC=""
  1.  S TERM=$P(^TMP("DILIST",$J,N,0),U,6)
  1.  ;
  1.  S FILTER=0
  1.  ;
  1.  ;Skip FSN terms and out of date entries
  1.  D  Q:FILTER
  1.  . N TIEN,TTYP
  1.  . S TIEN=$O(^BSTS(9002318.3,"D",INMID,DESC,"")) Q:TIEN=""
  1.  . S TTYP=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I")
  1.  . ;I TTYP="F" S FILTER=1
  1.  . I ((NMID<32771)!(NMID>32780)),TTYP="F" S FILTER=1 Q
  1.  . I $$GET1^DIQ(9002318.3,TIEN_",",.11,"I")="Y" S FILTER=1
  1.  ;
  1.  ;Implement AND logic - must have all terms
  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.  .. ;
  1.  .. ;Strip out comparison words
  1.  .. I (WD="")!(WD="OR")!(WD="AND")!(WD="NOT") Q
  1.  .. I ($$UP^XLFSTR(TERM))'[($$UP^XLFSTR(WD)) S FILTER=1
  1.  ;
  1.  ;Determine weight value (look for exact match)
  1.  S USEARCH=$$UP^XLFSTR(SEARCH)
  1.  S UTERM=$$UP^XLFSTR(TERM)
  1.  S WGT=1 F PC=1:1:$L(USEARCH," ") I $P(USEARCH," ",PC)=$P(UTERM," ",PC) S WGT=WGT+1
  1.  I UTERM=USEARCH S WGT=WGT+5
  1.  ;
  1.  ;Log entry
  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))+WGT
  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
  1.  ;
  1. SXF ;EP - Set cross-reference
  1.  S %1=1 F %=1:1:$L(X)+1 D
  1.  . S I=$E(X,%)
  1.  . I "(,.?! '/&:;)"[I S I=$E($E(X,%1,%-1),1,30),%1=%+1
  1.  . S I=$$UP^XLFSTR(I)
  1.  . I $L(I)>2,^DD("KWIC")'[I D
  1.  .. NEW CDSET
  1.  .. S CDSET=$$GET1^DIQ(9002318.3,DA_",",.08,"E") Q:CDSET=""
  1.  .. ;
  1.  .. ;Strip leading '-'/'+'
  1.  .. I "-+"[$E(I,1) S I=$E(I,2,9999)
  1.  .. ;
  1.  .. ;Strip quotes
  1.  .. S I=$TR(I,"""","")
  1.  .. ;
  1.  .. ;Save entry
  1.  .. S ^BSTS(9002318.3,"E",CDSET,I,DA)=""
  1.  Q
  1.  ;
  1. KXF ;EP - Kill cross-reference
  1.  S %1=1 F %=1:1:$L(X)+1 D
  1.  . S I=$E(X,%)
  1.  . I "(,.?! '/&:;)"[I S I=$E($E(X,%1,%-1),1,30),%1=%+1
  1.  . S I=$$UP^XLFSTR(I)
  1.  . I $L(I)>2 D
  1.  .. NEW CDSET
  1.  .. S CDSET=$$GET1^DIQ(9002318.3,DA_",",.08,"E") Q:CDSET=""
  1.  .. ;
  1.  .. ;Strip leading '-'/'+'
  1.  .. I "-+"[$E(I,1) S I=$E(I,2,9999)
  1.  .. ;
  1.  .. ;Strip quotes
  1.  .. S I=$TR(I,"""","")
  1.  .. ;
  1.  .. ;Kill entry
  1.  .. K ^BSTS(9002318.3,"E",CDSET,I,DA)
  1.  Q
  1.  ;
  1. DETAIL(OUT,BSTSWS,RESULT) ;EP - Return Details for each Concept/Term
  1.  ;
  1.  ;Return the concept detail
  1.  ;
  1.  ;Call moved to new routine because of space issues
  1.  Q $$DETAIL^BSTSCDET(OUT,.BSTSWS,.RESULT)