Routine: BQILKSMD

BQILKSMD ;GDIT/HS/BEE - SNOMED Utilities ; 10 Aug 2012  9:24 AM

 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

SEARCH(DATA,SEARCH) ;EP - BQI SNOMED SEARCH

 ;Description

 ;  Returns a list of SNOMED CT Terms matching the specified search string

 ;Input

 ;  SEARCH - The string to search on

 ;Output

 ;  ^TMP("BQILKSMD") - Name of global (passed by reference) in which the data is stored.

 ;Variables Used

 ;  UID - Unique TMP global subscript.

 N UID,BQII,SVAR,STS,II

 S SEARCH=$TR(SEARCH,"|","^")

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQILKSMD",UID))

 S SVAR=$NA(^TMP("BQILKSER",UID))

 K @DATA,@SVAR

 S BQII=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQILKSMD D UNWIND^%ZTER" ; SAC 2009 2.2.3.17

 D HDR

 ;Validate input

 I $G(SEARCH)="" G DONE

 ;Perform lookup

 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

 . NEW ISA,ICD9,SUB,SYN,MICD,D10,ISHDR

. ;

 . ;Problem Description and Term

 . S PRBD=$G(@SVAR@(II,"PRB","DSC"))

 . S PRBT=$G(@SVAR@(II,"PRB","TRM"))

 . W !,II,?10,"PRBD: ",PRBD,"|",PRBT

 . 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")

. ;

 . ;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

 ... S DTS=$G(@SVAR@(II,"ISA",ICNT,"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

. ;

 . ;ICD9

 . S ICD9="" I $D(@SVAR@(II,"ICD")) D

 .. NEW ICNT

 .. S ICNT="" F  S ICNT=$O(@SVAR@(II,"ICD",ICNT)) Q:ICNT=""  D

 ... NEW ICD

 ... S ICD=$G(@SVAR@(II,"ICD",ICNT,"COD"))

 ... S ICD9=ICD9_$S(ICD9]"":$C(28),1:"")_ICD

. ;

 . ;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" 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"

. ;

 . S MICD=ICD9

 . ;Save entry

 . S BQII=BQII+1,@DATA@(BQII)=PRBD_U_PRBT_U_CONC_U_DTS_U_FSND_U_FSNT_U_ISA

 . S @DATA@(BQII)=@DATA@(BQII)_U_ICD9_U_SUB_U_D10_U_SYN_U_ISHDR_U_MICD_$C(30)

DONE ;

 S BQII=BQII+1,@DATA@(BQII)=$C(31)

HDR ;

 NEW HDR

 S HDR="T00050PRB_DSC^T00250PRB_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"

 S HDR=HDR_"^T04096ISA^T04096ICD9^T04096SUBSETS^T0409610D^T04096SYNONYMS"

 S HDR=HDR_"^T00001ISA_SYN_HDR^T04096MAPPED_ICD"

 S @DATA@(BQII)=HDR_$C(30)

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(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)

BQILKSMD  ;GDIT/HS/BEE - SNOMED Utilities ; 10 Aug 2012  9:24 AM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66

 +2       ;

 +3        QUIT

 +4       ;

SEARCH(DATA,SEARCH) ;EP - BQI 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       ;

 +8       ;Output

 +9       ;  ^TMP("BQILKSMD") - Name of global (passed by reference) in which the data is stored.

 +10      ;

 +11      ;Variables Used

 +12      ;  UID - Unique TMP global subscript.

 +13      ;

 +14       NEW UID,BQII,SVAR,STS,II

 +15      ;

 +16       SET SEARCH=$TRANSLATE(SEARCH,"|","^")

 +17       SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

 +18       SET DATA=$NAME(^TMP("BQILKSMD",UID))

 +19       SET SVAR=$NAME(^TMP("BQILKSER",UID))

 +20       KILL @DATA,@SVAR

 +21      ;

 +22       SET BQII=0

 +23      ; SAC 2009 2.2.3.17

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQILKSMD D UNWIND^%ZTER"

 +24      ;

 +25       DO HDR

 +26      ;

 +27      ;Validate input

 +28       IF $GET(SEARCH)=""

               GOTO DONE

 +29      ;

 +30      ;Perform lookup

 +31       SET STS=$$SEARCH^BSTSAPI(SVAR,SEARCH)

 +32      ;

 +33      ;Output Results

 +34       SET II=0

FOR

               SET II=$ORDER(@SVAR@(II))

               IF II=""

                   QUIT

               Begin DoDot:1

 +35               NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET

 +36               NEW ISA,ICD9,SUB,SYN,MICD,D10,ISHDR

 +37      ;

 +38      ;Problem Description and Term

 +39               SET PRBD=$GET(@SVAR@(II,"PRB","DSC"))

 +40               SET PRBT=$GET(@SVAR@(II,"PRB","TRM"))

 +41               WRITE !,II,?10,"PRBD: ",PRBD,"|",PRBT

 +42               SET CONC=$GET(@SVAR@(II,"CON"))

 +43               SET DTS=$GET(@SVAR@(II,"DTS"))

 +44               SET FSND=$GET(@SVAR@(II,"FSN","DSC"))

 +45               SET FSNT=$GET(@SVAR@(II,"FSN","TRM"))

 +46               SET PRED=$GET(@SVAR@(II,"PRE","DSC"))

 +47               SET PRET=$GET(@SVAR@(II,"PRE","TRM"))

 +48               SET ISHDR=$SELECT(PRED=PRBD:"",1:"S")

 +49      ;

 +50      ;ISA

 +51               SET ISA=""

                   IF $DATA(@SVAR@(II,"ISA"))

                       Begin DoDot:2

 +52                       NEW ICNT

 +53                       SET ICNT=""

FOR

                               SET ICNT=$ORDER(@SVAR@(II,"ISA",ICNT))

                               IF ICNT=""

                                   QUIT

                               Begin DoDot:3

 +54                               NEW DTS,CON,TRM

 +55                               SET DTS=$GET(@SVAR@(II,"ISA",ICNT,"DTS"))

 +56                               SET CON=$GET(@SVAR@(II,"ISA",ICNT,"CON"))

 +57                               SET TRM=$GET(@SVAR@(II,"ISA",ICNT,"TRM"))

 +58                               SET ISA=ISA_$SELECT(ISA]"":$CHAR(28),1:"")_DTS_$CHAR(29)_CON_$CHAR(29)_TRM

                               End DoDot:3

                       End DoDot:2

 +59      ;

 +60      ;ICD9

 +61               SET ICD9=""

                   IF $DATA(@SVAR@(II,"ICD"))

                       Begin DoDot:2

 +62                       NEW ICNT

 +63                       SET ICNT=""

FOR

                               SET ICNT=$ORDER(@SVAR@(II,"ICD",ICNT))

                               IF ICNT=""

                                   QUIT

                               Begin DoDot:3

 +64                               NEW ICD

 +65                               SET ICD=$GET(@SVAR@(II,"ICD",ICNT,"COD"))

 +66                               SET ICD9=ICD9_$SELECT(ICD9]"":$CHAR(28),1:"")_ICD

                               End DoDot:3

                       End DoDot:2

 +67      ;

 +68      ;ICD10

 +69               SET D10=""

 +70      ;

 +71      ;Subsets

 +72               SET SUB=""

                   IF $DATA(@SVAR@(II,"SUB"))

                       Begin DoDot:2

 +73                       NEW ICNT

 +74                       SET ICNT=""

FOR

                               SET ICNT=$ORDER(@SVAR@(II,"SUB",ICNT))

                               IF ICNT=""

                                   QUIT

                               Begin DoDot:3

 +75                               NEW SB

 +76                               SET SB=$GET(@SVAR@(II,"SUB",ICNT,"SUB"))

 +77                               SET SUB=SUB_$SELECT(SUB]"":$CHAR(28),1:"")_SB

                               End DoDot:3

                       End DoDot:2

 +78      ;

 +79      ;Synonyms

 +80               SET SYN=PRED_$CHAR(29)_PRET_$CHAR(29)_"Preferred"

                   IF $DATA(@SVAR@(II,"SYN"))

                       Begin DoDot:2

 +81                       NEW ICNT

 +82                       SET ICNT=""

FOR

                               SET ICNT=$ORDER(@SVAR@(II,"SYN",ICNT))

                               IF ICNT=""

                                   QUIT

                               Begin DoDot:3

 +83                               NEW TRM,DSC

 +84                               SET TRM=$GET(@SVAR@(II,"SYN",ICNT,"TRM"))

 +85                               SET DSC=$GET(@SVAR@(II,"SYN",ICNT,"DSC"))

 +86                               SET SYN=SYN_$SELECT(SYN]"":$CHAR(28),1:"")_DSC_$CHAR(29)_TRM_$CHAR(29)_"Synonym"

                               End DoDot:3

                       End DoDot:2

 +87      ;

 +88               SET MICD=ICD9

 +89      ;Save entry

 +90               SET BQII=BQII+1

                   SET @DATA@(BQII)=PRBD_U_PRBT_U_CONC_U_DTS_U_FSND_U_FSNT_U_ISA

 +91               SET @DATA@(BQII)=@DATA@(BQII)_U_ICD9_U_SUB_U_D10_U_SYN_U_ISHDR_U_MICD_$CHAR(30)

               End DoDot:1

 +92      ;

DONE      ;

 +1        SET BQII=BQII+1

           SET @DATA@(BQII)=$CHAR(31)

 +2        QUIT

 +3       ;

HDR       ;

 +1        NEW HDR

 +2        SET HDR="T00050PRB_DSC^T00250PRB_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"

 +5        SET @DATA@(BQII)=HDR_$CHAR(30)

 +6        QUIT

 +7       ;

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(BQII)

               IF $DATA(DATA)

                   SET BQII=BQII+1

                   SET @DATA@(BQII)=$CHAR(31)

 +6        QUIT

BQILKSMD.m