BSTSLKP ;GDIT/HS/BEE-Standard Terminology Lookups ; 15 Nov 2012 4:26 PM
;;2.0;IHS STANDARD TERMINOLOGY;**2**;Dec 01, 2016;Build 1
Q
;
DSC(OUT,BSTSWS) ;EP - Perform Lookup on Description Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; BSTSWS("SEARCH") - The Description/Concept Id to lookup
; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
;
;Output
; @VAR@(#) - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Descriptor ID
;
N DESC,IEN,NMID,SDATE,INMID,TIEN,CONC,DTS,CIEN
;
S DESC=$G(BSTSWS("SEARCH")) Q:DESC="" "0"
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SDATE=$G(BSTSWS("SNAPDT")) S:SDATE="" SDATE=DT
;
;Pull internal Code Set ID
S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) Q:INMID="" "0"
;
;Lookup of ID
S TIEN=$O(^BSTS(9002318.3,"D",INMID,DESC,"")) Q:TIEN="" "0"
S CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I") Q:CIEN="0"
S CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
S DTS=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
S @OUT@(1)=CONC_U_DTS_U_DESC
;
Q 1
;
DTS(OUT,BSTSWS) ;EP - Perform lookup on DTS Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; BSTSWS("SEARCH") - The DTS Id to lookup
; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
;
;Output
; @VAR@(#) - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Descriptor ID
;
N DTS,IEN,NMID,SDATE,CONC,CIEN
;
S DTS=$G(BSTSWS("SEARCH")) Q:DTS="" "0"
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SDATE=$G(BSTSWS("SNAPDT")) S:SDATE="" SDATE=DT
;
;Lookup of ID
S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTS,"")) Q:CIEN="" "0"
S CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I") Q:CONC="" "0"
S @OUT@(1)=CONC_U_DTS_U
;
Q 1
;
CNC(OUT,BSTSWS) ;EP - Perform lookup on Concept Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; BSTSWS("SEARCH") - The Concept Id to lookup
; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
;
;Output
; @VAR@(#) - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Descriptor ID
;
N DTS,IEN,NMID,SDATE,CONC,CIEN
;
S CONC=$G(BSTSWS("SEARCH")) Q:CONC="" "0"
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SDATE=$G(BSTSWS("SNAPDT")) S:SDATE="" SDATE=DT
;
;Lookup of ID
S CIEN=$O(^BSTS(9002318.4,"C",NMID,CONC,"")) Q:CIEN="" "0"
S DTS=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
S @OUT@(1)=CONC_U_DTS_U
;
Q 1
;
VNLKP(OUT,BSTSWS) ;EP - Perform local NDC/VUID lookup
;
NEW NMID,CONC,DTS,CCT,NMIEN
S CCT=0
;
;Get internal namespace IEN
S NMID=$G(BSTSWS("NAMESPACEID"))
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) I NMIEN="" Q CCT
;
;NDC Search
;
I $G(BSTSWS("LTYPE"))="N" D Q CCT
. NEW NDC,CIEN
. ;
. ;Get NDC
. S NDC=$G(BSTSWS("SEARCH")) I NDC="" Q
. ;
. ;Lookup the entry
. S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"G",NMIEN,NDC,CIEN)) Q:CIEN="" D
.. NEW CONC,DTSID
.. S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","I") Q:CONC=""
.. S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I") Q:DTSID=""
.. S CCT=CCT+1,@OUT@(CCT)=CONC_U_DTSID
;
;VUID search
;
I $G(BSTSWS("LTYPE"))="V" D Q CCT
. NEW VUID,CIEN
. ;
. ;Get VUID
. S VUID=$G(BSTSWS("SEARCH")) I VUID="" Q
. ;
. ;Lookup the entry
. S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"H",NMIEN,VUID,CIEN)) Q:CIEN="" D
.. NEW CONC,DTSID
.. S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","I") Q:CONC=""
.. S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I") Q:DTSID=""
.. S CCT=CCT+1,@OUT@(CCT)=CONC_U_DTSID
;
Q 0
;
CIEN(CONC,NMID) ;EP - Return the CIEN for the concept
;
I $G(CONC)="" Q ""
I $G(NMID)="" Q ""
;
NEW TRNCONC,FOUND,CIEN
;
S TRNCONC=$E(CONC,1,30)
;
S FOUND=""
S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"C",NMID,TRNCONC,CIEN),-1) Q:CIEN="" D I FOUND]"" Q
. NEW CONCID
. S CONCID=$$GET1^DIQ(9002318.4,CIEN_",",".02","I") Q:CONCID=""
. I CONC'=CONCID Q
. S FOUND=CIEN
Q FOUND
BSTSLKP ;GDIT/HS/BEE-Standard Terminology Lookups ; 15 Nov 2012 4:26 PM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;**2**;Dec 01, 2016;Build 1
+2 QUIT
+3 ;
DSC(OUT,BSTSWS) ;EP - Perform Lookup on Description Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; BSTSWS("SEARCH") - The Description/Concept Id to lookup
+5 ; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
+6 ; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
+7 ;
+8 ;Output
+9 ; @VAR@(#) - [1]^[2]^[3]
+10 ; [1] - Concept ID
+11 ; [2] - DTS ID
+12 ; [3] - Descriptor ID
+13 ;
+14 NEW DESC,IEN,NMID,SDATE,INMID,TIEN,CONC,DTS,CIEN
+15 ;
+16 SET DESC=$GET(BSTSWS("SEARCH"))
IF DESC=""
QUIT "0"
+17 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+18 SET SDATE=$GET(BSTSWS("SNAPDT"))
IF SDATE=""
SET SDATE=DT
+19 ;
+20 ;Pull internal Code Set ID
+21 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0"
+22 ;
+23 ;Lookup of ID
+24 SET TIEN=$ORDER(^BSTS(9002318.3,"D",INMID,DESC,""))
IF TIEN=""
QUIT "0"
+25 SET CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I")
IF CIEN="0"
QUIT
+26 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
+27 SET DTS=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
+28 SET @OUT@(1)=CONC_U_DTS_U_DESC
+29 ;
+30 QUIT 1
+31 ;
DTS(OUT,BSTSWS) ;EP - Perform lookup on DTS Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; BSTSWS("SEARCH") - The DTS Id to lookup
+5 ; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
+6 ; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
+7 ;
+8 ;Output
+9 ; @VAR@(#) - [1]^[2]^[3]
+10 ; [1] - Concept ID
+11 ; [2] - DTS ID
+12 ; [3] - Descriptor ID
+13 ;
+14 NEW DTS,IEN,NMID,SDATE,CONC,CIEN
+15 ;
+16 SET DTS=$GET(BSTSWS("SEARCH"))
IF DTS=""
QUIT "0"
+17 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+18 SET SDATE=$GET(BSTSWS("SNAPDT"))
IF SDATE=""
SET SDATE=DT
+19 ;
+20 ;Lookup of ID
+21 SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTS,""))
IF CIEN=""
QUIT "0"
+22 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
IF CONC=""
QUIT "0"
+23 SET @OUT@(1)=CONC_U_DTS_U
+24 ;
+25 QUIT 1
+26 ;
CNC(OUT,BSTSWS) ;EP - Perform lookup on Concept Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; BSTSWS("SEARCH") - The Concept Id to lookup
+5 ; BSTSWS("NAMESPACEID") (Optional) - The code set Id (default SNOMED US EXT '36')
+6 ; BSTSWS("SNAPDT") (Optional) - Snapshot Date to check (default DT)
+7 ;
+8 ;Output
+9 ; @VAR@(#) - [1]^[2]^[3]
+10 ; [1] - Concept ID
+11 ; [2] - DTS ID
+12 ; [3] - Descriptor ID
+13 ;
+14 NEW DTS,IEN,NMID,SDATE,CONC,CIEN
+15 ;
+16 SET CONC=$GET(BSTSWS("SEARCH"))
IF CONC=""
QUIT "0"
+17 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+18 SET SDATE=$GET(BSTSWS("SNAPDT"))
IF SDATE=""
SET SDATE=DT
+19 ;
+20 ;Lookup of ID
+21 SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,CONC,""))
IF CIEN=""
QUIT "0"
+22 SET DTS=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
+23 SET @OUT@(1)=CONC_U_DTS_U
+24 ;
+25 QUIT 1
+26 ;
VNLKP(OUT,BSTSWS) ;EP - Perform local NDC/VUID lookup
+1 ;
+2 NEW NMID,CONC,DTS,CCT,NMIEN
+3 SET CCT=0
+4 ;
+5 ;Get internal namespace IEN
+6 SET NMID=$GET(BSTSWS("NAMESPACEID"))
+7 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT CCT
+8 ;
+9 ;NDC Search
+10 ;
+11 IF $GET(BSTSWS("LTYPE"))="N"
Begin DoDot:1
+12 NEW NDC,CIEN
+13 ;
+14 ;Get NDC
+15 SET NDC=$GET(BSTSWS("SEARCH"))
IF NDC=""
QUIT
+16 ;
+17 ;Lookup the entry
+18 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"G",NMIEN,NDC,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+19 NEW CONC,DTSID
+20 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","I")
IF CONC=""
QUIT
+21 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I")
IF DTSID=""
QUIT
+22 SET CCT=CCT+1
SET @OUT@(CCT)=CONC_U_DTSID
End DoDot:2
End DoDot:1
QUIT CCT
+23 ;
+24 ;VUID search
+25 ;
+26 IF $GET(BSTSWS("LTYPE"))="V"
Begin DoDot:1
+27 NEW VUID,CIEN
+28 ;
+29 ;Get VUID
+30 SET VUID=$GET(BSTSWS("SEARCH"))
IF VUID=""
QUIT
+31 ;
+32 ;Lookup the entry
+33 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"H",NMIEN,VUID,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+34 NEW CONC,DTSID
+35 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","I")
IF CONC=""
QUIT
+36 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I")
IF DTSID=""
QUIT
+37 SET CCT=CCT+1
SET @OUT@(CCT)=CONC_U_DTSID
End DoDot:2
End DoDot:1
QUIT CCT
+38 ;
+39 QUIT 0
+40 ;
CIEN(CONC,NMID) ;EP - Return the CIEN for the concept
+1 ;
+2 IF $GET(CONC)=""
QUIT ""
+3 IF $GET(NMID)=""
QUIT ""
+4 ;
+5 NEW TRNCONC,FOUND,CIEN
+6 ;
+7 SET TRNCONC=$EXTRACT(CONC,1,30)
+8 ;
+9 SET FOUND=""
+10 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,TRNCONC,CIEN),-1)
IF CIEN=""
QUIT
Begin DoDot:1
+11 NEW CONCID
+12 SET CONCID=$$GET1^DIQ(9002318.4,CIEN_",",".02","I")
IF CONCID=""
QUIT
+13 IF CONC'=CONCID
QUIT
+14 SET FOUND=CIEN
End DoDot:1
IF FOUND]""
QUIT
+15 QUIT FOUND
