BSTSRPC ;GDIT/HS/BEE - SNOMED Utilities - RPC Search ; 10 Aug 2012 9:24 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
SEARCH(DATA,SEARCH,PC) ;EP - BSTS SNOMED SEARCH
;
;Description
; Returns a list of SNOMED CT Terms matching the specified search string
;
;Input
; SEARCH - The string to search on
; PC - Return Parent/Children
;
;Output
; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
N UID,BSTSII,SVAR,STS,II,%D,NMID
;
S SEARCH=$TR(SEARCH,"|","^")
S $P(SEARCH,U,5)=""
S PC=$G(PC)
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC",UID))
S SVAR=$NA(^TMP("BSTSRPC1",UID))
K @DATA,@SVAR
;
S BSTSII=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
D HDR
;
;Validate input
I $G(SEARCH)="" G DONE
;
;Perform lookup
S NMID=$P(SEARCH,U,3) S:NMID="" NMID=36
S STS=$$SEARCH^BSTSAPI(SVAR,SEARCH)
;
;Output Results
S II=0 F S II=$O(@SVAR@(II)) Q:II="" D
. NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET,CHD
. NEW ISA,ICD,SUB,SYN,MICD,D10,ISHDR,LAT,DFSTS,REPI
. ;
. ;Problem Description and Term
. S PRBD=$G(@SVAR@(II,"PRB","DSC"))
. S PRBT=$G(@SVAR@(II,"PRB","TRM"))
. S CONC=$G(@SVAR@(II,"CON"))
. S DTS=$G(@SVAR@(II,"DTS"))
. S FSND=$G(@SVAR@(II,"FSN","DSC"))
. S FSNT=$G(@SVAR@(II,"FSN","TRM"))
. S PRED=$G(@SVAR@(II,"PRE","DSC"))
. S PRET=$G(@SVAR@(II,"PRE","TRM"))
. S ISHDR=$S(PRED=PRBD:"",1:"S")
. S LAT=$S($G(@SVAR@(II,"LAT"))=1:1,1:0)
. S DFSTS=$G(@SVAR@(II,"STS"))
. S REPI=$S($G(@SVAR@(II,"EPI"))=1:1,1:0)
. ;
. ;ICD
. S ICD="" I $D(@SVAR@(II,"ICD")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@SVAR@(II,"ICD",ICNT)) Q:ICNT="" D
... NEW ICDE
... S ICDE=$G(@SVAR@(II,"ICD",ICNT,"COD"))
... S ICD=ICD_$S(ICD]"":$C(28),1:"")_ICDE
. ;
. ;ICD10
. S D10=""
. ;
. ;Subsets
. S SUB="" I $D(@SVAR@(II,"SUB")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@SVAR@(II,"SUB",ICNT)) Q:ICNT="" D
... NEW SB
... S SB=$G(@SVAR@(II,"SUB",ICNT,"SUB"))
... S SUB=SUB_$S(SUB]"":$C(28),1:"")_SB
. ;
. ;Synonyms
. S SYN=PRED_$C(29)_PRET_$C(29)_"Preferred"_$C(29)_"1" I $D(@SVAR@(II,"SYN")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@SVAR@(II,"SYN",ICNT)) Q:ICNT="" D
... NEW TRM,DSC
... S TRM=$G(@SVAR@(II,"SYN",ICNT,"TRM"))
... S DSC=$G(@SVAR@(II,"SYN",ICNT,"DSC"))
... S SYN=SYN_$S(SYN]"":$C(28),1:"")_DSC_$C(29)_TRM_$C(29)_"Synonym"_$C(29)_2
. ;
. ;ISA
. S ISA="" I $D(@SVAR@(II,"ISA")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@SVAR@(II,"ISA",ICNT)) Q:ICNT="" D
... NEW DTS,CON,TRM,CIEN
... S DTS=$G(@SVAR@(II,"ISA",ICNT,"DTS")) Q:DTS=""
... S CON=$G(@SVAR@(II,"ISA",ICNT,"CON"))
... S TRM=$G(@SVAR@(II,"ISA",ICNT,"TRM"))
... S ISA=ISA_$S(ISA]"":$C(28),1:"")_DTS_$C(29)_CON_$C(29)_TRM
... ;
... ;BSTSv2.0;Added parents to expansion list
... Q:'PC
... S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTS,"")) Q:CIEN=""
... I $$GET1^DIQ(9002318.4,CIEN_",",".03","I")'="P",$$GET1^DIQ(9002318.4,CIEN_",",".15","I")="" Q
... S SYN=SYN_$S(SYN]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"Parent"_$C(29)_3
. ;
. ;BSTSv2.0;Added children to expansion list
. ;Children
. I PC S CHD="" I $D(@SVAR@(II,"CHD")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@SVAR@(II,"CHD",ICNT)) Q:ICNT="" D
... NEW DTS,CON,TRM,CIEN
... S DTS=$G(@SVAR@(II,"CHD",ICNT,"DTS")) Q:DTS=""
... S CON=$G(@SVAR@(II,"CHD",ICNT,"CON"))
... S TRM=$G(@SVAR@(II,"CHD",ICNT,"TRM"))
... ;
... ;BSTSv2.0;Added parents to expansion list
... S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTS,"")) Q:CIEN=""
... I $$GET1^DIQ(9002318.4,CIEN_",",".03","I")'="P",$$GET1^DIQ(9002318.4,CIEN_",",".15","I")="" Q
... S SYN=SYN_$S(SYN]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"Child"_$C(29)_4
. ;
. S MICD=ICD
. ;Save entry
. S BSTSII=BSTSII+1,@DATA@(BSTSII)=PRBD_U_PRBT_U_PRED_U_PRET_U_CONC_U_DTS_U_FSND_U_FSNT_U_ISA
. S @DATA@(BSTSII)=@DATA@(BSTSII)_U_ICD_U_SUB_U_D10_U_SYN_U_ISHDR_U_MICD_U_LAT_U_DFSTS_U_REPI_$C(30)
;
DONE ;
S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
;
USEARCH(DATA,SEARCH) ;EP - BSTS SNOMED UNIVERSE SEARCH
;
;BSTS*1.0*8;Moved to new routine to free up space
D USEARCH^BSTSRPCU(.DATA,.SEARCH)
Q
;
ICD2SMD(DATA,INPUT) ;EP - BSTS ICD9 TO SNOMED
;
;Description
; Returns a list of SNOMED CT Terms matching the specified ICD9 code
;
;Input
; INPUT - "|" Delimited string
; [1] ICD9 Code
; [2] Subset(s) (Optional) - Include only concepts in these subsets
; (multiple subsets delimited by "~")
;
;Output
; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
N UID,BSTSII,SVAR,STS,II,SUBSETS,SNAPDT,%D
;
S INPUT=$G(INPUT,"")
S INPUT=$TR(INPUT,"|","^")
;
;Strip off trailing "."
S $P(INPUT,U)=$$TKO^BSTSUTIL($P(INPUT,U),".")
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC",UID))
;S SVAR=$NA(^TMP("BSTSRPC1",UID)) ;Switch to local
K @DATA
;
S BSTSII=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
D IHDR
;
;Validate input
I $P(INPUT,U)="" G IDONE
S SUBSETS=$P(INPUT,U,2) S:SUBSETS]"" SUBSETS="~"_SUBSETS_"~"
S SNAPDT=$P(INPUT,U,3)
;
;Perform lookup - ICD9
I $E($P(INPUT,U),1)'="?" S STS=$$ICD2SMD^BSTSAPI("SVAR",$P(INPUT,U)_"^BCIX^")
;
;Perform lookup - Text
I $E($P(INPUT,U),1)="?" D
. NEW STRING
. S STRING=$E($P(INPUT,U),2,9999)
. S STS=$$SEARCH^BSTSAPI("SVAR",STRING_"^F^^^^^BCIX")
;
;Output Results
S II=0 F S II=$O(SVAR(II)) Q:II="" D
. NEW CONC,DESC,PTERM,REL,SCHK,SUB,ICD
. ;
. ;Perform subset check to see it this Concept should be returned
. S SCHK=0 I SUBSETS]"",$D(SVAR(II,"SUB")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(SVAR(II,"SUB",ICNT)) Q:ICNT="" D
... NEW SB
... S SB=$G(SVAR(II,"SUB",ICNT,"SUB"))
... I SUBSETS[("~"_SB_"~") S SCHK=1
. I SUBSETS]"",'SCHK Q
. ;
. ;Get Concept ID
. S CONC=$G(SVAR(II,"CON")) Q:CONC=""
. ;
. ;Get Description Id of Preferred Term
. S DESC=$G(SVAR(II,"PRB","DSC")) Q:DESC=""
. ;
. ;Get Preferred Term
. S PTERM=$G(SVAR(II,"PRB","TRM")) Q:PTERM=""
. ;
. ;ICD9
. S ICD="" I $D(SVAR(II,"ICD")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(SVAR(II,"ICD",ICNT)) Q:ICNT="" D
... NEW ICDE
... S ICDE=$G(SVAR(II,"IC9",ICNT,"COD"))
... S ICD=ICD_$S(ICD]"":$C(28),1:"")_ICDE
. ;
. ;Initialize Relations Value
. S REL=""
. ;
. ;Subsets
. S SUB="" I $D(SVAR(II,"SUB")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(SVAR(II,"SUB",ICNT)) Q:ICNT="" D
... NEW SB
... S SB=$G(SVAR(II,"SUB",ICNT,"SUB"))
... S SUB=SUB_$S(SUB]"":$C(28),1:"")_SB
. ;
. ;Get ISA (Parents) first
. I $D(SVAR(II,"ISA")) D
.. NEW ICNT,PICD
.. S ICNT="" F S ICNT=$O(SVAR(II,"ISA",ICNT)) Q:ICNT="" D
... NEW DTS,PDSC,PTRM,VR,STS,PCNC,SCHK
... ;
... ;Pull DTSId of Parent
... S DTS=$G(SVAR(II,"ISA",ICNT,"DTS")) Q:DTS=""
... ;
... ;Look up entry
... S STS=$$DTSLKP^BSTSAPI("VR",DTS_"^^^1")
... ;
... ;Perform subset check to see it this Concept should be returned
... S SCHK=0 I SUBSETS]"",$D(VR(1,"SUB")) D
.... NEW ICNT
.... S ICNT="" F S ICNT=$O(VR(1,"SUB",ICNT)) Q:ICNT="" D
..... NEW SB
..... S SB=$G(VR(1,"SUB",ICNT,"SUB"))
..... I SUBSETS[("~"_SB_"~") S SCHK=1
... I SUBSETS]"",'SCHK Q
... ;
... S PDSC=$G(VR(1,"PRE","DSC")) Q:PDSC=""
... S PTRM=$G(VR(1,"PRE","TRM")) Q:PTRM=""
... S PCNC=$G(VR(1,"CON")) Q:PCNC=""
... ;
... ;ICD9 - Parent
... S PICD="" I $D(VR(1,"IC9")) D
.... NEW ICNT
.... S ICNT="" F S ICNT=$O(VR(1,"IC9",ICNT)) Q:ICNT="" D
..... NEW ICDE
..... S ICDE=$G(VR(1,"IC9",ICNT,"COD"))
..... S PICD=PICD_$S(PICD]"":$C(26),1:"")_ICDE
... ;
... ;Set up output
... S REL=REL_$S(REL]"":$C(28),1:"")_"P"_$C(29)_PCNC_$C(29)_PDSC_$C(29)_PTRM_$C(29)_PICD
. ;
. ;Now get Children
. I $D(SVAR(II,"CHD")) D
.. NEW ICNT,CICD
.. S ICNT="" F S ICNT=$O(SVAR(II,"CHD",ICNT)) Q:ICNT="" D
... NEW DTS,PDSC,PTRM,VR,STS,PCNC,SCHK
... ;
... ;Pull DTSId of Child
... S DTS=$G(SVAR(II,"CHD",ICNT,"DTS")) Q:DTS=""
... ;
... ;Look up entry
... S STS=$$DTSLKP^BSTSAPI("VR",DTS_"^^^1")
... ;
... ;Perform subset check to see it this Concept should be returned
... S SCHK=0 I SUBSETS]"",$D(VR(1,"SUB")) D
.... NEW ICNT
.... S ICNT="" F S ICNT=$O(VR(1,"SUB",ICNT)) Q:ICNT="" D
..... NEW SB
..... S SB=$G(VR(1,"SUB",ICNT,"SUB"))
..... I SUBSETS[("~"_SB_"~") S SCHK=1
... I SUBSETS]"",'SCHK Q
... ;
... S PDSC=$G(VR(1,"PRE","DSC")) Q:PDSC=""
... S PTRM=$G(VR(1,"PRE","TRM")) Q:PTRM=""
... S PCNC=$G(VR(1,"CON")) Q:PCNC=""
... ;
... ;ICD - Children
... S CICD="" I $D(VR(1,"IC9")) D
.... NEW ICNT
.... S ICNT="" F S ICNT=$O(VR(1,"IC9",ICNT)) Q:ICNT="" D
..... NEW ICDE
..... S ICDE=$G(VR(1,"IC9",ICNT,"COD"))
..... S CICD=CICD_$S(CICD]"":$C(26),1:"")_ICDE
... ;
... ;Set up output
... S REL=REL_$S(REL]"":$C(28),1:"")_"C"_$C(29)_PCNC_$C(29)_PDSC_$C(29)_PTRM_$C(29)_CICD
. ;
. ;Save entry
. S BSTSII=BSTSII+1
. S @DATA@(BSTSII)=CONC_U_DESC_U_PTERM_U_REL_U_SUB_U_ICD_$C(30)
;
IDONE ;
S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
;
IHDR ;
NEW HDR
S HDR="T00050CONCID^T00050DESC_ID^T00250PREF_TRM^T04096RELATIONS^T04096SUBSETS^T04096ICD9"
S @DATA@(BSTSII)=HDR_$C(30)
Q
;
HDR ;
NEW HDR
S HDR="T00050PRB_DSC^T00250PRB_TRM^T00050PREF_DSC^T00250PREF_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"
S HDR=HDR_"^T04096ISA^T04096ICD9^T04096SUBSETS^T0409610D^T04096SYNONYMS"
S HDR=HDR_"^T00001ISA_SYN_HDR^T04096MAPPED_ICD^T00001PROMPT_LATERALITY^T00020DEFAULT_STATUS^T00001REQUIRE_EPISODICITY"
S @DATA@(BSTSII)=HDR_$C(30)
Q
;
SUBSET(DATA,INPUT) ;EP - BSTS GET SUBSET LIST
;
;Description
; Returns a list of Subsets available to select from
;
;Input
; INPUT - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
; - P2 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P3 (Optional) - DEBUG - Pass 1 to display debug information
; - P4 (Optional) - IPL - Pass 1 to return only problem list subsets (SRCH*)
;
;Output
; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
;Always look LOCAL
S $P(INPUT,"|",2)=1
;
N UID,BSTSII,STS,II,VAR,IPL,%D
;
S INPUT=$TR($G(INPUT),"|","^")
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC",UID))
K @DATA
;
S BSTSII=0
S IPL=$P(INPUT,"^",4)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S STS=$$SUBSET^BSTSAPI("VAR",$P(INPUT,U,1,3))
;
;Define header
S @DATA@(0)="T04096SUBSET^T04096DISPLAY_SUBSETS"_$C(30)
;
;Loop through list and set up results
S II="" F S II=$O(VAR(II)) Q:II="" D
. ;
. NEW DISPSB
. ;
. ;Filter for Integrated Problem List
. I IPL,$E(VAR(II),1,4)'="SRCH" Q
. S DISPSB=VAR(II) I $E(VAR(II),1,5)="SRCH " S DISPSB=$E(VAR(II),6,999)
. ;
. S BSTSII=BSTSII+1,@DATA@(BSTSII)=VAR(II)_U_DISPSB_$C(30)
;
S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
;
CDSET(DATA,INPUT) ;EP - BSTS GET CODESETS
;
;Description
; Returns a list of Codesets available to select from
;
;Input
; INPUT - P1 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P2 (Optional) - DEBUG - Pass 1 to display debug information
; - P3 (Optional) - Pass 1 to return codesets for the standalone search tool
;
; 10 ICD-9-CM
;X 32768 IHS
;X 32769 SNOMED CT to ICD-10-CM Old
;X 32770 ECLIPS
;X 32771 IHS VANDF
;X 32772 GMRA Signs Symptoms
;X 32773 GMRA Allergies with Maps
;X 35290 SNOMED CT US Ext to ICD-10-CM
;X 32774 IHS Med Route
; 1552 RxNorm R
; 36 SNOMED CT US Extension
; 30 SNOMED CT
; 5180 FDA UNII
;
;Output
; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
N UID,BSTSII,STS,II,VAR,SA,%D
;
S INPUT=$TR($G(INPUT),"|","^")
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC",UID))
K @DATA
;
S BSTSII=0
S SA=$P(INPUT,"^",3)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S STS=$$CODESETS^BSTSAPI("VAR",$P(INPUT,U,1,2))
;
;Define header
S @DATA@(0)="T00010CODE^T04096CODESET_NAME"_$C(30)
;
;Loop through list and set up results
S II="" F S II=$O(VAR(II)) Q:II="" D
. ;
. NEW CODE,CODESET
. ;
. S CODE=$P(VAR(II),U)
. S CODESET=$P(VAR(II),U,3)
. ;
. ;Filter for Standalone
. I SA=1,CODE<32770,CODE>32667 Q
. I SA=1,CODE=35290 Q
. ;
. ;Save entry
. S BSTSII=BSTSII+1,@DATA@(BSTSII)=CODE_U_CODESET_$C(30)
;
S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(BSTSII),$D(DATA) S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
BSTSRPC ;GDIT/HS/BEE - SNOMED Utilities - RPC Search ; 10 Aug 2012 9:24 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
SEARCH(DATA,SEARCH,PC) ;EP - BSTS SNOMED SEARCH
+1 ;
+2 ;Description
+3 ; Returns a list of SNOMED CT Terms matching the specified search string
+4 ;
+5 ;Input
+6 ; SEARCH - The string to search on
+7 ; PC - Return Parent/Children
+8 ;
+9 ;Output
+10 ; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
+11 ;
+12 ;Variables Used
+13 ; UID - Unique TMP global subscript.
+14 ;
+15 NEW UID,BSTSII,SVAR,STS,II,%D,NMID
+16 ;
+17 SET SEARCH=$TRANSLATE(SEARCH,"|","^")
+18 SET $PIECE(SEARCH,U,5)=""
+19 SET PC=$GET(PC)
+20 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+21 SET DATA=$NAME(^TMP("BSTSRPC",UID))
+22 SET SVAR=$NAME(^TMP("BSTSRPC1",UID))
+23 KILL @DATA,@SVAR
+24 ;
+25 SET BSTSII=0
+26 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER"
+27 ;
+28 DO HDR
+29 ;
+30 ;Validate input
+31 IF $GET(SEARCH)=""
GOTO DONE
+32 ;
+33 ;Perform lookup
+34 SET NMID=$PIECE(SEARCH,U,3)
IF NMID=""
SET NMID=36
+35 SET STS=$$SEARCH^BSTSAPI(SVAR,SEARCH)
+36 ;
+37 ;Output Results
+38 SET II=0
FOR
SET II=$ORDER(@SVAR@(II))
IF II=""
QUIT
Begin DoDot:1
+39 NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET,CHD
+40 NEW ISA,ICD,SUB,SYN,MICD,D10,ISHDR,LAT,DFSTS,REPI
+41 ;
+42 ;Problem Description and Term
+43 SET PRBD=$GET(@SVAR@(II,"PRB","DSC"))
+44 SET PRBT=$GET(@SVAR@(II,"PRB","TRM"))
+45 SET CONC=$GET(@SVAR@(II,"CON"))
+46 SET DTS=$GET(@SVAR@(II,"DTS"))
+47 SET FSND=$GET(@SVAR@(II,"FSN","DSC"))
+48 SET FSNT=$GET(@SVAR@(II,"FSN","TRM"))
+49 SET PRED=$GET(@SVAR@(II,"PRE","DSC"))
+50 SET PRET=$GET(@SVAR@(II,"PRE","TRM"))
+51 SET ISHDR=$SELECT(PRED=PRBD:"",1:"S")
+52 SET LAT=$SELECT($GET(@SVAR@(II,"LAT"))=1:1,1:0)
+53 SET DFSTS=$GET(@SVAR@(II,"STS"))
+54 SET REPI=$SELECT($GET(@SVAR@(II,"EPI"))=1:1,1:0)
+55 ;
+56 ;ICD
+57 SET ICD=""
IF $DATA(@SVAR@(II,"ICD"))
Begin DoDot:2
+58 NEW ICNT
+59 SET ICNT=""
FOR
SET ICNT=$ORDER(@SVAR@(II,"ICD",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+60 NEW ICDE
+61 SET ICDE=$GET(@SVAR@(II,"ICD",ICNT,"COD"))
+62 SET ICD=ICD_$SELECT(ICD]"":$CHAR(28),1:"")_ICDE
End DoDot:3
End DoDot:2
+63 ;
+64 ;ICD10
+65 SET D10=""
+66 ;
+67 ;Subsets
+68 SET SUB=""
IF $DATA(@SVAR@(II,"SUB"))
Begin DoDot:2
+69 NEW ICNT
+70 SET ICNT=""
FOR
SET ICNT=$ORDER(@SVAR@(II,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+71 NEW SB
+72 SET SB=$GET(@SVAR@(II,"SUB",ICNT,"SUB"))
+73 SET SUB=SUB_$SELECT(SUB]"":$CHAR(28),1:"")_SB
End DoDot:3
End DoDot:2
+74 ;
+75 ;Synonyms
+76 SET SYN=PRED_$CHAR(29)_PRET_$CHAR(29)_"Preferred"_$CHAR(29)_"1"
IF $DATA(@SVAR@(II,"SYN"))
Begin DoDot:2
+77 NEW ICNT
+78 SET ICNT=""
FOR
SET ICNT=$ORDER(@SVAR@(II,"SYN",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+79 NEW TRM,DSC
+80 SET TRM=$GET(@SVAR@(II,"SYN",ICNT,"TRM"))
+81 SET DSC=$GET(@SVAR@(II,"SYN",ICNT,"DSC"))
+82 SET SYN=SYN_$SELECT(SYN]"":$CHAR(28),1:"")_DSC_$CHAR(29)_TRM_$CHAR(29)_"Synonym"_$CHAR(29)_2
End DoDot:3
End DoDot:2
+83 ;
+84 ;ISA
+85 SET ISA=""
IF $DATA(@SVAR@(II,"ISA"))
Begin DoDot:2
+86 NEW ICNT
+87 SET ICNT=""
FOR
SET ICNT=$ORDER(@SVAR@(II,"ISA",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+88 NEW DTS,CON,TRM,CIEN
+89 SET DTS=$GET(@SVAR@(II,"ISA",ICNT,"DTS"))
IF DTS=""
QUIT
+90 SET CON=$GET(@SVAR@(II,"ISA",ICNT,"CON"))
+91 SET TRM=$GET(@SVAR@(II,"ISA",ICNT,"TRM"))
+92 SET ISA=ISA_$SELECT(ISA]"":$CHAR(28),1:"")_DTS_$CHAR(29)_CON_$CHAR(29)_TRM
+93 ;
+94 ;BSTSv2.0;Added parents to expansion list
+95 IF 'PC
QUIT
+96 SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTS,""))
IF CIEN=""
QUIT
+97 IF $$GET1^DIQ(9002318.4,CIEN_",",".03","I")'="P"
IF $$GET1^DIQ(9002318.4,CIEN_",",".15","I")=""
QUIT
+98 SET SYN=SYN_$SELECT(SYN]"":$CHAR(28),1:"")_DTS_$CHAR(29)_TRM_$CHAR(29)_"Parent"_$CHAR(29)_3
End DoDot:3
End DoDot:2
+99 ;
+100 ;BSTSv2.0;Added children to expansion list
+101 ;Children
+102 IF PC
SET CHD=""
IF $DATA(@SVAR@(II,"CHD"))
Begin DoDot:2
+103 NEW ICNT
+104 SET ICNT=""
FOR
SET ICNT=$ORDER(@SVAR@(II,"CHD",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+105 NEW DTS,CON,TRM,CIEN
+106 SET DTS=$GET(@SVAR@(II,"CHD",ICNT,"DTS"))
IF DTS=""
QUIT
+107 SET CON=$GET(@SVAR@(II,"CHD",ICNT,"CON"))
+108 SET TRM=$GET(@SVAR@(II,"CHD",ICNT,"TRM"))
+109 ;
+110 ;BSTSv2.0;Added parents to expansion list
+111 SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTS,""))
IF CIEN=""
QUIT
+112 IF $$GET1^DIQ(9002318.4,CIEN_",",".03","I")'="P"
IF $$GET1^DIQ(9002318.4,CIEN_",",".15","I")=""
QUIT
+113 SET SYN=SYN_$SELECT(SYN]"":$CHAR(28),1:"")_DTS_$CHAR(29)_TRM_$CHAR(29)_"Child"_$CHAR(29)_4
End DoDot:3
End DoDot:2
+114 ;
+115 SET MICD=ICD
+116 ;Save entry
+117 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=PRBD_U_PRBT_U_PRED_U_PRET_U_CONC_U_DTS_U_FSND_U_FSNT_U_ISA
+118 SET @DATA@(BSTSII)=@DATA@(BSTSII)_U_ICD_U_SUB_U_D10_U_SYN_U_ISHDR_U_MICD_U_LAT_U_DFSTS_U_REPI_$CHAR(30)
End DoDot:1
+119 ;
DONE ;
+1 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+2 QUIT
+3 ;
USEARCH(DATA,SEARCH) ;EP - BSTS SNOMED UNIVERSE SEARCH
+1 ;
+2 ;BSTS*1.0*8;Moved to new routine to free up space
+3 DO USEARCH^BSTSRPCU(.DATA,.SEARCH)
+4 QUIT
+5 ;
ICD2SMD(DATA,INPUT) ;EP - BSTS ICD9 TO SNOMED
+1 ;
+2 ;Description
+3 ; Returns a list of SNOMED CT Terms matching the specified ICD9 code
+4 ;
+5 ;Input
+6 ; INPUT - "|" Delimited string
+7 ; [1] ICD9 Code
+8 ; [2] Subset(s) (Optional) - Include only concepts in these subsets
+9 ; (multiple subsets delimited by "~")
+10 ;
+11 ;Output
+12 ; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
+13 ;
+14 ;Variables Used
+15 ; UID - Unique TMP global subscript.
+16 ;
+17 NEW UID,BSTSII,SVAR,STS,II,SUBSETS,SNAPDT,%D
+18 ;
+19 SET INPUT=$GET(INPUT,"")
+20 SET INPUT=$TRANSLATE(INPUT,"|","^")
+21 ;
+22 ;Strip off trailing "."
+23 SET $PIECE(INPUT,U)=$$TKO^BSTSUTIL($PIECE(INPUT,U),".")
+24 ;
+25 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+26 SET DATA=$NAME(^TMP("BSTSRPC",UID))
+27 ;S SVAR=$NA(^TMP("BSTSRPC1",UID)) ;Switch to local
+28 KILL @DATA
+29 ;
+30 SET BSTSII=0
+31 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER"
+32 ;
+33 DO IHDR
+34 ;
+35 ;Validate input
+36 IF $PIECE(INPUT,U)=""
GOTO IDONE
+37 SET SUBSETS=$PIECE(INPUT,U,2)
IF SUBSETS]""
SET SUBSETS="~"_SUBSETS_"~"
+38 SET SNAPDT=$PIECE(INPUT,U,3)
+39 ;
+40 ;Perform lookup - ICD9
+41 IF $EXTRACT($PIECE(INPUT,U),1)'="?"
SET STS=$$ICD2SMD^BSTSAPI("SVAR",$PIECE(INPUT,U)_"^BCIX^")
+42 ;
+43 ;Perform lookup - Text
+44 IF $EXTRACT($PIECE(INPUT,U),1)="?"
Begin DoDot:1
+45 NEW STRING
+46 SET STRING=$EXTRACT($PIECE(INPUT,U),2,9999)
+47 SET STS=$$SEARCH^BSTSAPI("SVAR",STRING_"^F^^^^^BCIX")
End DoDot:1
+48 ;
+49 ;Output Results
+50 SET II=0
FOR
SET II=$ORDER(SVAR(II))
IF II=""
QUIT
Begin DoDot:1
+51 NEW CONC,DESC,PTERM,REL,SCHK,SUB,ICD
+52 ;
+53 ;Perform subset check to see it this Concept should be returned
+54 SET SCHK=0
IF SUBSETS]""
IF $DATA(SVAR(II,"SUB"))
Begin DoDot:2
+55 NEW ICNT
+56 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(II,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+57 NEW SB
+58 SET SB=$GET(SVAR(II,"SUB",ICNT,"SUB"))
+59 IF SUBSETS[("~"_SB_"~")
SET SCHK=1
End DoDot:3
End DoDot:2
+60 IF SUBSETS]""
IF 'SCHK
QUIT
+61 ;
+62 ;Get Concept ID
+63 SET CONC=$GET(SVAR(II,"CON"))
IF CONC=""
QUIT
+64 ;
+65 ;Get Description Id of Preferred Term
+66 SET DESC=$GET(SVAR(II,"PRB","DSC"))
IF DESC=""
QUIT
+67 ;
+68 ;Get Preferred Term
+69 SET PTERM=$GET(SVAR(II,"PRB","TRM"))
IF PTERM=""
QUIT
+70 ;
+71 ;ICD9
+72 SET ICD=""
IF $DATA(SVAR(II,"ICD"))
Begin DoDot:2
+73 NEW ICNT
+74 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(II,"ICD",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+75 NEW ICDE
+76 SET ICDE=$GET(SVAR(II,"IC9",ICNT,"COD"))
+77 SET ICD=ICD_$SELECT(ICD]"":$CHAR(28),1:"")_ICDE
End DoDot:3
End DoDot:2
+78 ;
+79 ;Initialize Relations Value
+80 SET REL=""
+81 ;
+82 ;Subsets
+83 SET SUB=""
IF $DATA(SVAR(II,"SUB"))
Begin DoDot:2
+84 NEW ICNT
+85 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(II,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+86 NEW SB
+87 SET SB=$GET(SVAR(II,"SUB",ICNT,"SUB"))
+88 SET SUB=SUB_$SELECT(SUB]"":$CHAR(28),1:"")_SB
End DoDot:3
End DoDot:2
+89 ;
+90 ;Get ISA (Parents) first
+91 IF $DATA(SVAR(II,"ISA"))
Begin DoDot:2
+92 NEW ICNT,PICD
+93 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(II,"ISA",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+94 NEW DTS,PDSC,PTRM,VR,STS,PCNC,SCHK
+95 ;
+96 ;Pull DTSId of Parent
+97 SET DTS=$GET(SVAR(II,"ISA",ICNT,"DTS"))
IF DTS=""
QUIT
+98 ;
+99 ;Look up entry
+100 SET STS=$$DTSLKP^BSTSAPI("VR",DTS_"^^^1")
+101 ;
+102 ;Perform subset check to see it this Concept should be returned
+103 SET SCHK=0
IF SUBSETS]""
IF $DATA(VR(1,"SUB"))
Begin DoDot:4
+104 NEW ICNT
+105 SET ICNT=""
FOR
SET ICNT=$ORDER(VR(1,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:5
+106 NEW SB
+107 SET SB=$GET(VR(1,"SUB",ICNT,"SUB"))
+108 IF SUBSETS[("~"_SB_"~")
SET SCHK=1
End DoDot:5
End DoDot:4
+109 IF SUBSETS]""
IF 'SCHK
QUIT
+110 ;
+111 SET PDSC=$GET(VR(1,"PRE","DSC"))
IF PDSC=""
QUIT
+112 SET PTRM=$GET(VR(1,"PRE","TRM"))
IF PTRM=""
QUIT
+113 SET PCNC=$GET(VR(1,"CON"))
IF PCNC=""
QUIT
+114 ;
+115 ;ICD9 - Parent
+116 SET PICD=""
IF $DATA(VR(1,"IC9"))
Begin DoDot:4
+117 NEW ICNT
+118 SET ICNT=""
FOR
SET ICNT=$ORDER(VR(1,"IC9",ICNT))
IF ICNT=""
QUIT
Begin DoDot:5
+119 NEW ICDE
+120 SET ICDE=$GET(VR(1,"IC9",ICNT,"COD"))
+121 SET PICD=PICD_$SELECT(PICD]"":$CHAR(26),1:"")_ICDE
End DoDot:5
End DoDot:4
+122 ;
+123 ;Set up output
+124 SET REL=REL_$SELECT(REL]"":$CHAR(28),1:"")_"P"_$CHAR(29)_PCNC_$CHAR(29)_PDSC_$CHAR(29)_PTRM_$CHAR(29)_PICD
End DoDot:3
End DoDot:2
+125 ;
+126 ;Now get Children
+127 IF $DATA(SVAR(II,"CHD"))
Begin DoDot:2
+128 NEW ICNT,CICD
+129 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(II,"CHD",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+130 NEW DTS,PDSC,PTRM,VR,STS,PCNC,SCHK
+131 ;
+132 ;Pull DTSId of Child
+133 SET DTS=$GET(SVAR(II,"CHD",ICNT,"DTS"))
IF DTS=""
QUIT
+134 ;
+135 ;Look up entry
+136 SET STS=$$DTSLKP^BSTSAPI("VR",DTS_"^^^1")
+137 ;
+138 ;Perform subset check to see it this Concept should be returned
+139 SET SCHK=0
IF SUBSETS]""
IF $DATA(VR(1,"SUB"))
Begin DoDot:4
+140 NEW ICNT
+141 SET ICNT=""
FOR
SET ICNT=$ORDER(VR(1,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:5
+142 NEW SB
+143 SET SB=$GET(VR(1,"SUB",ICNT,"SUB"))
+144 IF SUBSETS[("~"_SB_"~")
SET SCHK=1
End DoDot:5
End DoDot:4
+145 IF SUBSETS]""
IF 'SCHK
QUIT
+146 ;
+147 SET PDSC=$GET(VR(1,"PRE","DSC"))
IF PDSC=""
QUIT
+148 SET PTRM=$GET(VR(1,"PRE","TRM"))
IF PTRM=""
QUIT
+149 SET PCNC=$GET(VR(1,"CON"))
IF PCNC=""
QUIT
+150 ;
+151 ;ICD - Children
+152 SET CICD=""
IF $DATA(VR(1,"IC9"))
Begin DoDot:4
+153 NEW ICNT
+154 SET ICNT=""
FOR
SET ICNT=$ORDER(VR(1,"IC9",ICNT))
IF ICNT=""
QUIT
Begin DoDot:5
+155 NEW ICDE
+156 SET ICDE=$GET(VR(1,"IC9",ICNT,"COD"))
+157 SET CICD=CICD_$SELECT(CICD]"":$CHAR(26),1:"")_ICDE
End DoDot:5
End DoDot:4
+158 ;
+159 ;Set up output
+160 SET REL=REL_$SELECT(REL]"":$CHAR(28),1:"")_"C"_$CHAR(29)_PCNC_$CHAR(29)_PDSC_$CHAR(29)_PTRM_$CHAR(29)_CICD
End DoDot:3
End DoDot:2
+161 ;
+162 ;Save entry
+163 SET BSTSII=BSTSII+1
+164 SET @DATA@(BSTSII)=CONC_U_DESC_U_PTERM_U_REL_U_SUB_U_ICD_$CHAR(30)
End DoDot:1
+165 ;
IDONE ;
+1 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+2 QUIT
+3 ;
IHDR ;
+1 NEW HDR
+2 SET HDR="T00050CONCID^T00050DESC_ID^T00250PREF_TRM^T04096RELATIONS^T04096SUBSETS^T04096ICD9"
+3 SET @DATA@(BSTSII)=HDR_$CHAR(30)
+4 QUIT
+5 ;
HDR ;
+1 NEW HDR
+2 SET HDR="T00050PRB_DSC^T00250PRB_TRM^T00050PREF_DSC^T00250PREF_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"
+3 SET HDR=HDR_"^T04096ISA^T04096ICD9^T04096SUBSETS^T0409610D^T04096SYNONYMS"
+4 SET HDR=HDR_"^T00001ISA_SYN_HDR^T04096MAPPED_ICD^T00001PROMPT_LATERALITY^T00020DEFAULT_STATUS^T00001REQUIRE_EPISODICITY"
+5 SET @DATA@(BSTSII)=HDR_$CHAR(30)
+6 QUIT
+7 ;
SUBSET(DATA,INPUT) ;EP - BSTS GET SUBSET LIST
+1 ;
+2 ;Description
+3 ; Returns a list of Subsets available to select from
+4 ;
+5 ;Input
+6 ; INPUT - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
+7 ; - P2 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+8 ; blank for remote listing
+9 ; - P3 (Optional) - DEBUG - Pass 1 to display debug information
+10 ; - P4 (Optional) - IPL - Pass 1 to return only problem list subsets (SRCH*)
+11 ;
+12 ;Output
+13 ; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
+14 ;
+15 ;Variables Used
+16 ; UID - Unique TMP global subscript.
+17 ;
+18 ;Always look LOCAL
+19 SET $PIECE(INPUT,"|",2)=1
+20 ;
+21 NEW UID,BSTSII,STS,II,VAR,IPL,%D
+22 ;
+23 SET INPUT=$TRANSLATE($GET(INPUT),"|","^")
+24 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+25 SET DATA=$NAME(^TMP("BSTSRPC",UID))
+26 KILL @DATA
+27 ;
+28 SET BSTSII=0
+29 SET IPL=$PIECE(INPUT,"^",4)
+30 ;
+31 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER"
+32 ;
+33 SET STS=$$SUBSET^BSTSAPI("VAR",$PIECE(INPUT,U,1,3))
+34 ;
+35 ;Define header
+36 SET @DATA@(0)="T04096SUBSET^T04096DISPLAY_SUBSETS"_$CHAR(30)
+37 ;
+38 ;Loop through list and set up results
+39 SET II=""
FOR
SET II=$ORDER(VAR(II))
IF II=""
QUIT
Begin DoDot:1
+40 ;
+41 NEW DISPSB
+42 ;
+43 ;Filter for Integrated Problem List
+44 IF IPL
IF $EXTRACT(VAR(II),1,4)'="SRCH"
QUIT
+45 SET DISPSB=VAR(II)
IF $EXTRACT(VAR(II),1,5)="SRCH "
SET DISPSB=$EXTRACT(VAR(II),6,999)
+46 ;
+47 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=VAR(II)_U_DISPSB_$CHAR(30)
End DoDot:1
+48 ;
+49 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+50 QUIT
+51 ;
CDSET(DATA,INPUT) ;EP - BSTS GET CODESETS
+1 ;
+2 ;Description
+3 ; Returns a list of Codesets available to select from
+4 ;
+5 ;Input
+6 ; INPUT - P1 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+7 ; blank for remote listing
+8 ; - P2 (Optional) - DEBUG - Pass 1 to display debug information
+9 ; - P3 (Optional) - Pass 1 to return codesets for the standalone search tool
+10 ;
+11 ; 10 ICD-9-CM
+12 ;X 32768 IHS
+13 ;X 32769 SNOMED CT to ICD-10-CM Old
+14 ;X 32770 ECLIPS
+15 ;X 32771 IHS VANDF
+16 ;X 32772 GMRA Signs Symptoms
+17 ;X 32773 GMRA Allergies with Maps
+18 ;X 35290 SNOMED CT US Ext to ICD-10-CM
+19 ;X 32774 IHS Med Route
+20 ; 1552 RxNorm R
+21 ; 36 SNOMED CT US Extension
+22 ; 30 SNOMED CT
+23 ; 5180 FDA UNII
+24 ;
+25 ;Output
+26 ; ^TMP("BSTSRPC") - Name of global (passed by reference) in which the data is stored.
+27 ;
+28 ;Variables Used
+29 ; UID - Unique TMP global subscript.
+30 ;
+31 NEW UID,BSTSII,STS,II,VAR,SA,%D
+32 ;
+33 SET INPUT=$TRANSLATE($GET(INPUT),"|","^")
+34 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+35 SET DATA=$NAME(^TMP("BSTSRPC",UID))
+36 KILL @DATA
+37 ;
+38 SET BSTSII=0
+39 SET SA=$PIECE(INPUT,"^",3)
+40 ;
+41 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC D UNWIND^%ZTER"
+42 ;
+43 SET STS=$$CODESETS^BSTSAPI("VAR",$PIECE(INPUT,U,1,2))
+44 ;
+45 ;Define header
+46 SET @DATA@(0)="T00010CODE^T04096CODESET_NAME"_$CHAR(30)
+47 ;
+48 ;Loop through list and set up results
+49 SET II=""
FOR
SET II=$ORDER(VAR(II))
IF II=""
QUIT
Begin DoDot:1
+50 ;
+51 NEW CODE,CODESET
+52 ;
+53 SET CODE=$PIECE(VAR(II),U)
+54 SET CODESET=$PIECE(VAR(II),U,3)
+55 ;
+56 ;Filter for Standalone
+57 IF SA=1
IF CODE<32770
IF CODE>32667
QUIT
+58 IF SA=1
IF CODE=35290
QUIT
+59 ;
+60 ;Save entry
+61 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=CODE_U_CODESET_$CHAR(30)
End DoDot:1
+62 ;
+63 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+64 QUIT
+65 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(BSTSII)
IF $DATA(DATA)
SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+6 QUIT
