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

BSTSRPC1.m

Go to the documentation of this file. 
  1. BSTSRPC1 ;GDIT/HS/BEE - SNOMED Utilities - RPC Calls ; 10 Aug 2012  9:24 AM
  1.  ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
  1.  ;
  1.  Q
  1.  ;
  1. DETAIL(DATA,DTSID) ;EP - BSTS GET CONCEPT DETAIL
  1.  ;
  1.  ;Description
  1.  ;  Returns the detail for a passed in concept
  1.  ;  
  1.  ;Input
  1.  ;  DTSID - The internal DTS IEN
  1.  ;
  1.  ;Output
  1.  ;  ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
  1.  ;
  1.  ;Variables Used
  1.  ;  UID - Unique TMP global subscript.
  1.  ;
  1.  N UID,II,STS,SVAR,REC,CIEN,CONCID
  1.  ;
  1.  I $G(DTSID)="" S BMXSEC="BSTS GET CONCEPT DETAIL - DTSID is Null" Q
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BSTSRPC1",UID))
  1.  K @DATA
  1.  S II=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  D HDR
  1.  ;
  1.  ;Look for the entry in local cache
  1.  S CONCID="",CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
  1.  I CIEN]"" S CONCID=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
  1.  ;
  1.  ;Perform local lookup
  1.  I CONCID]"" S STS=$$CNCLKP^BSTSAPI("SVAR",CONCID)
  1.  ;
  1.  ;Perform lookup
  1.  I CONCID="" S STS=$$DTSLKP^BSTSAPI("SVAR",DTSID)
  1.  ;
  1.  ;Output Results
  1.  S REC=1 I $D(SVAR(REC)) D
  1.  . NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET
  1.  . NEW ICD,LAT,DFSTS,REPI,PAF,SEL
  1.  . ;
  1.  . ;Problem Description and Term
  1.  . S PRBD=$G(SVAR(REC,"PRB","DSC"))
  1.  . S PRBT=$G(SVAR(REC,"PRB","TRM"))
  1.  . S CONC=$G(SVAR(REC,"CON"))
  1.  . S DTS=$G(SVAR(REC,"DTS"))
  1.  . S FSND=$G(SVAR(REC,"FSN","DSC"))
  1.  . S FSNT=$G(SVAR(REC,"FSN","TRM"))
  1.  . S PRED=$G(SVAR(REC,"PRE","DSC"))
  1.  . S PRET=$G(SVAR(REC,"PRE","TRM"))
  1.  . S LAT=$S($G(SVAR(REC,"LAT"))=1:1,1:0)
  1.  . S DFSTS=$G(SVAR(REC,"STS"))
  1.  . S REPI=$S($G(SVAR(REC,"EPI"))=1:1,1:0)
  1.  . S PAF=$S($G(SVAR(REC,"ABN"))=1:1,1:0)
  1.  . S SEL=$S($G(SVAR(REC,"PAS"))=1:"Y",1:"")
  1.  . ;
  1.  . ;ICD
  1.  . S ICD="" I $D(SVAR(REC,"ICD")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(SVAR(REC,"ICD",ICNT)) Q:ICNT=""  D
  1.  ... NEW ICDE
  1.  ... S ICDE=$G(SVAR(REC,"ICD",ICNT,"COD"))
  1.  ... S ICD=ICD_$S(ICD]"":$C(28),1:"")_ICDE
  1.  . ;
  1.  . ;Save entry
  1.  . S II=II+1,@DATA@(II)=PRBD_U_PRBT_U_PRED_U_PRET_U_CONC_U_DTS_U_FSND_U_FSNT
  1.  . S @DATA@(II)=@DATA@(II)_U_ICD_U_LAT_U_DFSTS_U_REPI_U_PAF_U_SEL_$C(30)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. TAHEAD(DATA,NMID,COUNT,SEARCH,SUBSETS) ;EP - BSTS SEARCH TYPE AHEAD
  1.  ;
  1.  ;Description
  1.  ;  This call returns some recommended concepts based on what the user has typed
  1.  ;  in so far. Since the call has to be very fast, straight global reads are being
  1.  ;  performed instead of FileMan utility reads.
  1.  ;  
  1.  ;Input
  1.  ;     NMID - External codeset namespace id
  1.  ;    COUNT - Number of results to return
  1.  ;   SEARCH - String to search on
  1.  ; SUBSET(S) - Subsets to limit results to - delimit subsets by "~"
  1.  ;
  1.  ;Output
  1.  ;  ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
  1.  ;
  1.  ;Variables Used
  1.  ;  UID - Unique TMP global subscript.
  1.  ;
  1.  N UID,II,WORD,WRD,TIEN,SUBLST,I,P,SUB,FND,CIEN,R,CNT,FLVL,UPTRM,UPSRC,OWRD,TRM,OWLST
  1.  ;
  1.  ;Check input variables
  1.  S:$G(NMID)="" NMID=36 ;Default to SNOMED
  1.  S:$G(COUNT)="" COUNT=10
  1.  I $TR($G(SEARCH)," ")="" S BMXSEC="BSTS SEARCH TYPE AHEAD - SEARCH is Null" Q
  1.  S SUBSETS=$G(SUBSETS)
  1.  ;
  1.  ;Implement SNOMED galaxy filtering
  1.  I NMID=36,SUBSETS="" S SUBSETS="IHS PROBLEM ALL SNOMED"
  1.  ;
  1.  ;Put subsets in an array
  1.  I $TR(SUBSETS,"~")]"" F I=1:1:$L(SUBSETS,"~") S SUB=$P(SUBSETS,"~",I) I SUB]"" S SUBLST(SUB)=""
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BSTSRPC1",UID))
  1.  K @DATA
  1.  S II=0,CNT=1
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(0)="T04096RESULTS"_$C(30)
  1.  ;
  1.  ;Process first word in the string to establish base list
  1.  S UPSRC=$$UP^XLFSTR(SEARCH)
  1.  S WORD=$P(UPSRC," ") I WORD="" G XTAHEAD
  1.  S OWRD=$S($L(UPSRC," ")>1:0,1:1)
  1.  ;
  1.  ;Match check
  1.  S WRD=$$PREV(WORD) F  S WRD=$O(^BSTS(9002318.3,"E",NMID,WRD)) Q:(WRD="")!(WRD'[WORD)  D  I OWRD,CNT>COUNT Q
  1.  . ;
  1.  . S TIEN="" F  S TIEN=$O(^BSTS(9002318.3,"E",NMID,WRD,TIEN)) Q:TIEN=""  D  I OWRD,CNT>COUNT Q
  1.  .. ;
  1.  .. ;Subset check
  1.  .. S FND="" I $TR(SUBSETS,"~")]"" D  Q:FND=""
  1.  ... S CIEN=$P($G(^BSTS(9002318.3,TIEN,0)),U,3) Q:CIEN=""
  1.  ... S SUB="" F  S SUB=$O(SUBLST(SUB)) Q:SUB=""  D  I FND Q
  1.  .... I $D(^BSTS(9002318.4,CIEN,4,"B",SUB)) S FND=1
  1.  .. ;
  1.  .. ;Handle single word entry
  1.  .. I OWRD D  Q
  1.  ... I '$D(OWLST($$MIXC(WRD))) S R("S",99999-CNT,$$MIXC(WRD))="",OWLST($$MIXC(WRD))="",CNT=CNT+1
  1.  .. ;
  1.  .. ;Filter out FSN for SNOMED
  1.  .. I NMID=36,$P($G(^BSTS(9002318.3,TIEN,0)),U,9)="F" Q
  1.  .. ;
  1.  .. ;Set up the entry
  1.  .. S UPTRM=$$UP^XLFSTR($P($G(^BSTS(9002318.3,TIEN,1)),U)) Q:UPTRM=""
  1.  .. S R("R",UPTRM)=TIEN_U_$S(WRD=WORD:3,1:1)
  1.  .. S CNT=CNT+1
  1.  ;
  1.  ;Now loop through remaining words and filter
  1.  ;
  1.  ;Process remaining words
  1.  I 'OWRD,$D(R)>9 F P=2:1:$L(UPSRC," ") S WORD=$P(UPSRC," ",P) I WORD]"" D
  1.  . S (FND,UPTRM)="" F  S UPTRM=$O(R("R",UPTRM)) Q:UPTRM=""  D
  1.  .. S FND="" F I=1:1:$L(UPTRM," ") S WRD=$P(UPTRM," ",I) I WRD]"",$E(WRD,1,$L(WORD))=WORD D  S FND=1 Q
  1.  ... S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+$S(WRD=WORD:3,1:1)
  1.  .. I 'FND K R("R",UPTRM)
  1.  . Q
  1.  ;
  1.  ;Add extra weighting
  1.  I 'OWRD S UPTRM="" F  S UPTRM=$O(R("R",UPTRM)) Q:UPTRM=""  D
  1.  . I UPSRC=UPTRM S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+100
  1.  . F I=1:1:$L(UPSRC," ") D
  1.  .. I $E($P(UPTRM," ",I),1,$L($P(UPSRC," ",I)))=$P(UPSRC," ",I) S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+5
  1.  . S TIEN=$P(R("R",UPTRM),U),TRM=$P($G(^BSTS(9002318.3,TIEN,1)),U) Q:TRM=""
  1.  . S R("S",$P(R("R",UPTRM),U,2),TRM)=""
  1.  . K R("R",UPTRM)
  1.  ;
  1.  ;Now output
  1.  S R="" F  S R=$O(R("S",R),-1) Q:R=""  D  I II'<COUNT Q
  1.  . S TRM="" F  S TRM=$O(R("S",R,TRM)) Q:TRM=""  D  I II'<COUNT Q
  1.  .. S II=II+1,@DATA@(II)=TRM_$C(30)
  1.  ;
  1. XTAHEAD ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. MIXC(WORD) ;Convert to mix case
  1.  ;
  1.  Q $E(WORD,1)_$$LOW^XLFSTR($E(WORD,2,9999))
  1.  ;
  1. PREV(WORD) ;Return string right before passed in string
  1.  ;
  1.  NEW L,A,LST
  1.  ;
  1.  ;Get last character
  1.  S L=$E(WORD,$L(WORD)) Q:L="" ""
  1.  ;
  1.  ;Get ASCII of previous character
  1.  S A=$A(L) S:A>1 A=A-1
  1.  ;
  1.  ;Define highest ASCII
  1.  S LST=$C(65535)
  1.  ;
  1.  ;Return word string just before word
  1.  S WORD=$E(WORD,1,$L(WORD)-1)_$C(A)_LST_LST_LST_LST
  1.  ;
  1.  Q WORD
  1.  ;
  1. HDR ;
  1.  NEW HDR
  1.  S HDR="T00050PRB_DSC^T00250PRB_TRM^T00050PREF_DSC^T00250PREF_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"
  1.  S HDR=HDR_"^T04096ICD^T00001PROMPT_LATERALITY^T00020DEFAULT_STATUS^T00001REQUIRE_EPISODICITY^T00001PROMPT_AF^T00001SELECTABLE"
  1.  S @DATA@(0)=HDR_$C(30)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q