BSTSRPCU ;GDIT/HS/BEE - SNOMED Utilities - RPC Universe Search ; 10 Aug 2012 9:24 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
USEARCH(DATA,SEARCH) ;EP - BSTS SNOMED UNIVERSE SEARCH
;
;Description
; Perform a Codeset Universe Lookup
; Returns a set of terms matching the specified search string
;
;Input
; SEARCH - The string to search on
;
;Output
; ^TMP("BSTSRPCU") - 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
;
S SEARCH=$TR(SEARCH,"|","^")
S $P(SEARCH,U,5)=""
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPCU",UID))
S SVAR=$NA(^TMP("BSTSRPC1",UID))
K @DATA,@SVAR
;
S BSTSII=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPCU D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
D UHDR
;
;Validate input
I $G(SEARCH)="" G UDONE
;
;Perform lookup
S STS=$$USEARCH^BSTSAPIF(SVAR,SEARCH)
;
;Output Results
S II=0 F S II=$O(@SVAR@(II)) Q:II="" D
. NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,ISA,SYN,PS,SUB
. NEW ASSC,MAPP
. ;
. ;Problem Description and Term
. S PRBD=$P($G(@SVAR@(II)),U,3)
. S PRBT=$P($G(@SVAR@(II)),U,2)
. S CONC=$P($G(@SVAR@(II)),U)
. S DTS=$P($G(@SVAR@(II)),U,8)
. S FSND=$P($G(@SVAR@(II)),U,5)
. S FSNT=$P($G(@SVAR@(II)),U,4)
. ;
. ;ISA
. S ISA=$P($G(@SVAR@(II)),U,7)
. ;
. ;Synonym
. S SYN=$P($G(@SVAR@(II)),U,6)
. ;
. ;Preferred/Synonym
. S PS=$P($G(@SVAR@(II)),U,10)
. ;
. ;Subsets
. S SUB=$P($G(@SVAR@(II)),U,9) D
. ;
. ;Associations
. S ASSC=$P($G(@SVAR@(II)),U,11)
. ;
. ;Mappings
. S MAPP=$P($G(@SVAR@(II)),U,12)
. ;
. ;Save entry
. S BSTSII=BSTSII+1,@DATA@(BSTSII)=PRBT_U_PRBD_U_PS_U_FSNT_U_CONC_U_FSND_U_SYN_U_ISA_U_DTS_U_SUB_U_ASSC_U_MAPP
. S @DATA@(BSTSII)=@DATA@(BSTSII)_$C(30)
;
;Reset Scratch Global
K @SVAR
;
UDONE ;
S BSTSII=BSTSII+1,@DATA@(BSTSII)=$C(31)
Q
;
UHDR ;
NEW HDR
S HDR="T00250PRB_TRM^T00050PRB_DSC^T00001PS^T00250FSN_TERM^T00250CONCID^T00050FSN_DSC"
S HDR=HDR_"^T04096SYNONYMS^T04096RELATION^T00050HIDDEN_DTSID^T04096SUBSETS^T04096ASSOCIATION^T04096MAPPING"
S @DATA@(BSTSII)=HDR_$C(30)
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
BSTSRPCU ;GDIT/HS/BEE - SNOMED Utilities - RPC Universe Search ; 10 Aug 2012 9:24 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
USEARCH(DATA,SEARCH) ;EP - BSTS SNOMED UNIVERSE SEARCH
+1 ;
+2 ;Description
+3 ; Perform a Codeset Universe Lookup
+4 ; Returns a set of terms matching the specified search string
+5 ;
+6 ;Input
+7 ; SEARCH - The string to search on
+8 ;
+9 ;Output
+10 ; ^TMP("BSTSRPCU") - 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
+16 ;
+17 SET SEARCH=$TRANSLATE(SEARCH,"|","^")
+18 SET $PIECE(SEARCH,U,5)=""
+19 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+20 SET DATA=$NAME(^TMP("BSTSRPCU",UID))
+21 SET SVAR=$NAME(^TMP("BSTSRPC1",UID))
+22 KILL @DATA,@SVAR
+23 ;
+24 SET BSTSII=0
+25 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPCU D UNWIND^%ZTER"
+26 ;
+27 DO UHDR
+28 ;
+29 ;Validate input
+30 IF $GET(SEARCH)=""
GOTO UDONE
+31 ;
+32 ;Perform lookup
+33 SET STS=$$USEARCH^BSTSAPIF(SVAR,SEARCH)
+34 ;
+35 ;Output Results
+36 SET II=0
FOR
SET II=$ORDER(@SVAR@(II))
IF II=""
QUIT
Begin DoDot:1
+37 NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,ISA,SYN,PS,SUB
+38 NEW ASSC,MAPP
+39 ;
+40 ;Problem Description and Term
+41 SET PRBD=$PIECE($GET(@SVAR@(II)),U,3)
+42 SET PRBT=$PIECE($GET(@SVAR@(II)),U,2)
+43 SET CONC=$PIECE($GET(@SVAR@(II)),U)
+44 SET DTS=$PIECE($GET(@SVAR@(II)),U,8)
+45 SET FSND=$PIECE($GET(@SVAR@(II)),U,5)
+46 SET FSNT=$PIECE($GET(@SVAR@(II)),U,4)
+47 ;
+48 ;ISA
+49 SET ISA=$PIECE($GET(@SVAR@(II)),U,7)
+50 ;
+51 ;Synonym
+52 SET SYN=$PIECE($GET(@SVAR@(II)),U,6)
+53 ;
+54 ;Preferred/Synonym
+55 SET PS=$PIECE($GET(@SVAR@(II)),U,10)
+56 ;
+57 ;Subsets
+58 SET SUB=$PIECE($GET(@SVAR@(II)),U,9)
Begin DoDot:2
End DoDot:2
+59 ;
+60 ;Associations
+61 SET ASSC=$PIECE($GET(@SVAR@(II)),U,11)
+62 ;
+63 ;Mappings
+64 SET MAPP=$PIECE($GET(@SVAR@(II)),U,12)
+65 ;
+66 ;Save entry
+67 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=PRBT_U_PRBD_U_PS_U_FSNT_U_CONC_U_FSND_U_SYN_U_ISA_U_DTS_U_SUB_U_ASSC_U_MAPP
+68 SET @DATA@(BSTSII)=@DATA@(BSTSII)_$CHAR(30)
End DoDot:1
+69 ;
+70 ;Reset Scratch Global
+71 KILL @SVAR
+72 ;
UDONE ;
+1 SET BSTSII=BSTSII+1
SET @DATA@(BSTSII)=$CHAR(31)
+2 QUIT
+3 ;
UHDR ;
+1 NEW HDR
+2 SET HDR="T00250PRB_TRM^T00050PRB_DSC^T00001PS^T00250FSN_TERM^T00250CONCID^T00050FSN_DSC"
+3 SET HDR=HDR_"^T04096SYNONYMS^T04096RELATION^T00050HIDDEN_DTSID^T04096SUBSETS^T04096ASSOCIATION^T04096MAPPING"
+4 SET @DATA@(BSTSII)=HDR_$CHAR(30)
+5 QUIT
+6 ;
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
