BSTSLKP.m

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