ETSRXNTX ;O-OIFO/FM23 - RxNorm Taxonomy Search ;03/17/2017
;;1.0;Enterprise Terminology Service;**1**;Mar 20, 2017;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
TAX(ETSVUID,ETSSUB,ETSCLASS) ; Get Taxonomy Information
;
; Input:
;
; ETSVUID VA Unique ID (VUID) Search Term (Required)
;
; ETSSUB Name of a subscript to use in the ^TMP global (optional)
;
; ^TMP(ETSSUB,$J,
; ^TMP("ETSCLA",$J, Default for $$VUICLASS
; ^TMP("ETSTAX",$J, Default for $$TAX
;
; ETSCLASS Call Flag (optional, default = 0)
;
; 0 This function was called from the $$TAX API - Get all VUIDs with the same value set as the VUID passed in
; 1 This function was called from the $$VUICLASS API - Get all VUIDs with the same drug class as the VUID passed in
;
; Output:
;
; $$TAX The number of codes found or -1 ^ error message
;
; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,0)
;
; 6-piece "^"-delimited string
;
; 1 File #129.2 IEN
; 2 RXCUI (Field #.01)
; 3 Source (SAB) (Field #.02)
; 4 Term_Type (TTY) (Field #.03)
; 5 Code (VUID) (Field #.04)
; 6 Suppression_Flag (SUPPRESS) (Field #.05)
;
; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,1) = Text (STR) (Field #1)
;
; For $$TAX:
; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,2) = Activation Date (Field #91)
;
N ETSC,ETSCNT,ETSCODE,ETSCODE5,ETSCTR,ETSDATA,ETSERR,ETSIEN,ETSNODE,ETSRELA,ETSRES,ETSRXCUI,ETSRXCU1,ETSRXCU2,ETSSAB
N ETSSUPP,ETSTTY,ETSTTYS
;
;Check for Parameter errors
I $G(ETSVUID)="" Q "-1^VUID missing"
;
;Set Default values for optional parameters
S:$G(ETSCLASS)'=1 ETSCLASS=0
S:$G(ETSSUB)="" ETSSUB=$S(ETSCLASS=1:"ETSCLA",1:"ETSTAX")
;
;Clear the temporary arrays in case there is older data in existence
K ^TMP(ETSSUB,$J)
D CLEANUP
;
;Set other defaults
S ETSTTYS=$S(ETSCLASS=1:",AB,CD,",1:",IN,PIN,") ;Term Types to search
S ^TMP(ETSSUB,$J,ETSVUID,"VUID")=0 ;Number of records found
;
;
;Step A -- Get initial RXCUI list from VUID
S ETSCNT=$$VUI2RXN^ETSRXN(ETSVUID,"","ETSSTEP A") I ETSCNT<1 Q ETSCNT
;
;Weed out suppressed records
S ETSCTR="" F S ETSCTR=$O(^TMP("ETSSTEP A",$J,ETSCTR)) Q:'ETSCTR D
.S ETSSUPP=$P($G(^TMP("ETSSTEP A",$J,ETSCTR,0)),U,6)
.I ETSSUPP=""!(ETSSUPP="N") Q
.S ETSCNT=ETSCNT-1 K ^TMP("ETSSTEP A",$J,ETSCTR)
.Q
;
I ETSCNT=0 Q ETSCNT
;
;Step B -- Find "inverse_isa" relationships
;S ETSRXCUI="",ETSCNT=0 F S ETSRXCUI=$O(^TMP("ETSSTEP A",$J,ETSRXCUI)) Q:ETSRXCUI="" D
S ETSCNT=0,ETSCTR="" F S ETSCTR=$O(^TMP("ETSSTEP A",$J,ETSCTR)) Q:'ETSCTR D
.S ETSNODE=^TMP("ETSSTEP A",$J,ETSCTR,0),ETSRXCUI=$P(ETSNODE,U,2) Q:ETSRXCUI=""
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.22,"B",ETSRXCUI,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
..S ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
..S ETSRXCU2=@ETSDATA@(.03) Q:ETSRXCU2=""
..S ETSRELA=@ETSDATA@(.04)
..S ETSSAB=@ETSDATA@(.05)
..S ETSSUPP=@ETSDATA@(.06)
..I ETSRELA'="inverse_isa" Q
..I ETSSAB'="RXNORM" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP B",$J,ETSRXCU2)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step C -- Find "ingredient_of" relationships, using RXCUI2 from the last list as RXCUI1 lookup for this one
S ETSRXCU1="",ETSCNT=0 F S ETSRXCU1=$O(^TMP("ETSSTEP B",$J,ETSRXCU1)) Q:ETSRXCU1="" D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.22,"B",ETSRXCU1,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
..S ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
..S ETSRXCU2=@ETSDATA@(.03) Q:ETSRXCU2=""
..S ETSRELA=@ETSDATA@(.04)
..S ETSSAB=@ETSDATA@(.05)
..S ETSSUPP=@ETSDATA@(.06)
..I ETSRELA'="ingredient_of" Q
..I ETSSAB'="RXNORM" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP C",$J,ETSRXCU2)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step D -- Get simple concept/atom attributes with SAB="ATC", using RXCUI2 from the last list as RXCUI lookup for this one
S ETSRXCUI="",ETSCNT=0 F S ETSRXCUI=$O(^TMP("ETSSTEP C",$J,ETSRXCUI)) Q:ETSRXCUI="" D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.21,"B",ETSRXCUI,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.21,ETSIEN_",",".02;.03;.05","","ETSDATA")
..S ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
..S ETSSAB=@ETSDATA@(.02)
..S ETSSUPP=@ETSDATA@(.03)
..S ETSCODE=@ETSDATA@(.05) Q:ETSCODE=""
..I ETSSAB'="ATC" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP D",$J,$E(ETSCODE,1,5))=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step E -- Get drug classes with CODE from the last list's 5-character abbreviation
S ETSCODE5="",ETSCNT=0 F S ETSCODE5=$O(^TMP("ETSSTEP D",$J,ETSCODE5)) Q:ETSCODE5="" D
.S ETSC="^ETSRXN(129.21,""C"",""IS_DRUG_CLASS"")" F S ETSC=$Q(@ETSC) Q:$QS(ETSC,3)'="IS_DRUG_CLASS" D
..S ETSIEN=$QS(ETSC,5)
..K ETSDATA D GETS^DIQ(129.21,ETSIEN_",",".01;.03;.05","","ETSDATA")
..S ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
..S ETSRXCUI=@ETSDATA@(.01) Q:ETSRXCUI=""
..S ETSSUPP=@ETSDATA@(.03)
..S ETSCODE=@ETSDATA@(.05)
..I ETSCODE'=ETSCODE5 Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP E",$J,ETSRXCUI)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step F -- Retrieve CODEs for these drug classes from concept names/sources file
S ETSCNT=0,ETSRXCUI="" F S ETSRXCUI=$O(^TMP("ETSSTEP E",$J,ETSRXCUI)) Q:'ETSRXCUI D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.2,"B",ETSRXCUI,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.2,ETSIEN_",",".04;.05","","ETSDATA")
..S ETSDATA="ETSDATA(129.2,"""_ETSIEN_","")"
..S ETSCODE=@ETSDATA@(.04) Q:ETSCODE=""
..S ETSSUPP=@ETSDATA@(.05)
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP F",$J,$E(ETSCODE,1,5))=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step G -- Get simple concept/atom attributes with ATN="ATC_LEVEL" and CODEs beginning with the last list's 5-character abbreviation
S ETSCODE5="",ETSCNT=0 F S ETSCODE5=$O(^TMP("ETSSTEP F",$J,ETSCODE5)) Q:ETSCODE5="" D
.S ETSC="^ETSRXN(129.21,""C"",""ATC_LEVEL"")" F S ETSC=$Q(@ETSC) Q:$QS(ETSC,3)'="ATC_LEVEL" D
..S ETSIEN=$QS(ETSC,5)
..K ETSDATA D GETS^DIQ(129.21,ETSIEN_",",".01;.03;.05","","ETSDATA")
..S ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
..S ETSRXCUI=@ETSDATA@(.01) Q:ETSRXCUI=""
..S ETSSUPP=@ETSDATA@(.03)
..S ETSCODE=@ETSDATA@(.05)
..I $E(ETSCODE,1,5)'=ETSCODE5 Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP G",$J,ETSRXCUI)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step H -- Retrieve concept names/sources for these drugs with SAB="RXNORM"
S ETSCNT=0,ETSRXCUI="" F S ETSRXCUI=$O(^TMP("ETSSTEP G",$J,ETSRXCUI)) Q:'ETSRXCUI D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.2,"B",ETSRXCUI,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.2,ETSIEN_",",".02;.05","","ETSDATA")
..S ETSDATA="ETSDATA(129.2,"""_ETSIEN_","")"
..S ETSSAB=@ETSDATA@(.02)
..S ETSSUPP=@ETSDATA@(.05)
..I ETSSAB'="RXNORM" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP H",$J,ETSRXCUI)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step I -- Find "has_ingredient" relationships
S ETSRXCUI="",ETSCNT=0 F S ETSRXCUI=$O(^TMP("ETSSTEP H",$J,ETSRXCUI)) Q:ETSRXCUI="" D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.22,"B",ETSRXCUI,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
..S ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
..S ETSRXCU2=@ETSDATA@(.03) Q:ETSRXCU2=""
..S ETSRELA=@ETSDATA@(.04)
..S ETSSAB=@ETSDATA@(.05)
..S ETSSUPP=@ETSDATA@(.06)
..I ETSRELA'="has_ingredient" Q
..I ETSSAB'="RXNORM" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP I",$J,ETSRXCU2)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step J -- Find "isa" relationships, using RXCUI2 from the last list as RXCUI1 lookup for this one
S ETSRXCU1="",ETSCNT=0 F S ETSRXCU1=$O(^TMP("ETSSTEP I",$J,ETSRXCU1)) Q:ETSRXCU1="" D
.S ETSIEN="" F S ETSIEN=$O(^ETSRXN(129.22,"B",ETSRXCU1,ETSIEN)) Q:'ETSIEN D
..K ETSDATA D GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
..S ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
..S ETSRXCU2=@ETSDATA@(.03) Q:ETSRXCU2=""
..S ETSRELA=@ETSDATA@(.04)
..S ETSSAB=@ETSDATA@(.05)
..S ETSSUPP=@ETSDATA@(.06)
..I ETSRELA'="isa" Q
..I ETSSAB'="RXNORM" Q
..I ETSSUPP'="",ETSSUPP'="N" Q
..S ETSCNT=ETSCNT+1
..S ^TMP("ETSSTEP J",$J,ETSRXCU2)=""
.Q
;
I ETSCNT=0 D CLEANUP Q ETSCNT
;
;Step K -- Retrieve concept names/sources for these RXCUIs with SAB="VANDF", using RXCUI2 from the last list as RXCUI lookup for this one
S ETSRES=0,ETSRXCUI="",ETSERR=0 F S ETSRXCUI=$O(^TMP("ETSSTEP J",$J,ETSRXCUI)) Q:ETSRXCUI=""!ETSERR D
.S ETSCNT=$$RXN2OUT^ETSRXN(ETSRXCUI,"ETSSTEP K") I ETSCNT<0 S ETSERR=1 Q
.I +ETSCNT=0 Q
.D FILTER
.Q
;
S ^TMP(ETSSUB,$J,ETSVUID,"VUID")=ETSRES
;
I ETSERR K ^TMP(ETSSUB,$J)
;
D CLEANUP Q ETSRES
;
;
FILTER ;Weed out suppressed records and filter by TTY
S ETSCTR="" F S ETSCTR=$O(^TMP("ETSSTEP K",$J,ETSRXCUI,"VUID",ETSCTR)) Q:'ETSCTR D
.S ETSNODE=^TMP("ETSSTEP K",$J,ETSRXCUI,"VUID",ETSCTR,0)
.S ETSTTY=$P(ETSNODE,U,4)
.S ETSSUPP=$P(ETSNODE,U,6)
.I ETSTTYS'[(","_ETSTTY_",") Q
.I ETSSUPP'="",ETSSUPP'="N" Q
.S ETSRES=ETSRES+1
.S ^TMP(ETSSUB,$J,ETSVUID,"VUID",ETSRES,0)=ETSNODE
.S ^TMP(ETSSUB,$J,ETSVUID,"VUID",ETSRES,1)=^TMP("ETSSTEP K",$J,ETSRXCUI,"VUID",ETSCTR,1)
.I 'ETSCLASS S ^TMP(ETSSUB,$J,ETSVUID,"VUID",ETSRES,2)=$$GET1^DIQ(129.2,$P(ETSNODE,U)_",",91)
.Q
Q
;
CLEANUP ;Kill intermediate globals
F ETSCTR="ETSSTEP A","ETSSTEP B","ETSSTEP C","ETSSTEP D","ETSSTEP E","ETSSTEP F","ETSSTEP G","ETSSTEP H","ETSSTEP I","ETSSTEP J","ETSSTEP K" K ^TMP(ETSCTR,$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HETSRXNTX 10045 printed Dec 13, 2024@01:54:04 Page 2
ETSRXNTX ;O-OIFO/FM23 - RxNorm Taxonomy Search ;03/17/2017
+1 ;;1.0;Enterprise Terminology Service;**1**;Mar 20, 2017;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
TAX(ETSVUID,ETSSUB,ETSCLASS) ; Get Taxonomy Information
+1 ;
+2 ; Input:
+3 ;
+4 ; ETSVUID VA Unique ID (VUID) Search Term (Required)
+5 ;
+6 ; ETSSUB Name of a subscript to use in the ^TMP global (optional)
+7 ;
+8 ; ^TMP(ETSSUB,$J,
+9 ; ^TMP("ETSCLA",$J, Default for $$VUICLASS
+10 ; ^TMP("ETSTAX",$J, Default for $$TAX
+11 ;
+12 ; ETSCLASS Call Flag (optional, default = 0)
+13 ;
+14 ; 0 This function was called from the $$TAX API - Get all VUIDs with the same value set as the VUID passed in
+15 ; 1 This function was called from the $$VUICLASS API - Get all VUIDs with the same drug class as the VUID passed in
+16 ;
+17 ; Output:
+18 ;
+19 ; $$TAX The number of codes found or -1 ^ error message
+20 ;
+21 ; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,0)
+22 ;
+23 ; 6-piece "^"-delimited string
+24 ;
+25 ; 1 File #129.2 IEN
+26 ; 2 RXCUI (Field #.01)
+27 ; 3 Source (SAB) (Field #.02)
+28 ; 4 Term_Type (TTY) (Field #.03)
+29 ; 5 Code (VUID) (Field #.04)
+30 ; 6 Suppression_Flag (SUPPRESS) (Field #.05)
+31 ;
+32 ; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,1) = Text (STR) (Field #1)
+33 ;
+34 ; For $$TAX:
+35 ; ^TMP(ETSSUB,$J,ETSVUID,"VUID"),#,2) = Activation Date (Field #91)
+36 ;
+37 NEW ETSC,ETSCNT,ETSCODE,ETSCODE5,ETSCTR,ETSDATA,ETSERR,ETSIEN,ETSNODE,ETSRELA,ETSRES,ETSRXCUI,ETSRXCU1,ETSRXCU2,ETSSAB
+38 NEW ETSSUPP,ETSTTY,ETSTTYS
+39 ;
+40 ;Check for Parameter errors
+41 IF $GET(ETSVUID)=""
QUIT "-1^VUID missing"
+42 ;
+43 ;Set Default values for optional parameters
+44 if $GET(ETSCLASS)'=1
SET ETSCLASS=0
+45 if $GET(ETSSUB)=""
SET ETSSUB=$SELECT(ETSCLASS=1:"ETSCLA",1:"ETSTAX")
+46 ;
+47 ;Clear the temporary arrays in case there is older data in existence
+48 KILL ^TMP(ETSSUB,$JOB)
+49 DO CLEANUP
+50 ;
+51 ;Set other defaults
+52 ;Term Types to search
SET ETSTTYS=$SELECT(ETSCLASS=1:",AB,CD,",1:",IN,PIN,")
+53 ;Number of records found
SET ^TMP(ETSSUB,$JOB,ETSVUID,"VUID")=0
+54 ;
+55 ;
+56 ;Step A -- Get initial RXCUI list from VUID
+57 SET ETSCNT=$$VUI2RXN^ETSRXN(ETSVUID,"","ETSSTEP A")
IF ETSCNT<1
QUIT ETSCNT
+58 ;
+59 ;Weed out suppressed records
+60 SET ETSCTR=""
FOR
SET ETSCTR=$ORDER(^TMP("ETSSTEP A",$JOB,ETSCTR))
if 'ETSCTR
QUIT
Begin DoDot:1
+61 SET ETSSUPP=$PIECE($GET(^TMP("ETSSTEP A",$JOB,ETSCTR,0)),U,6)
+62 IF ETSSUPP=""!(ETSSUPP="N")
QUIT
+63 SET ETSCNT=ETSCNT-1
KILL ^TMP("ETSSTEP A",$JOB,ETSCTR)
+64 QUIT
End DoDot:1
+65 ;
+66 IF ETSCNT=0
QUIT ETSCNT
+67 ;
+68 ;Step B -- Find "inverse_isa" relationships
+69 ;S ETSRXCUI="",ETSCNT=0 F S ETSRXCUI=$O(^TMP("ETSSTEP A",$J,ETSRXCUI)) Q:ETSRXCUI="" D
+70 SET ETSCNT=0
SET ETSCTR=""
FOR
SET ETSCTR=$ORDER(^TMP("ETSSTEP A",$JOB,ETSCTR))
if 'ETSCTR
QUIT
Begin DoDot:1
+71 SET ETSNODE=^TMP("ETSSTEP A",$JOB,ETSCTR,0)
SET ETSRXCUI=$PIECE(ETSNODE,U,2)
if ETSRXCUI=""
QUIT
+72 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.22,"B",ETSRXCUI,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+73 KILL ETSDATA
DO GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
+74 SET ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
+75 SET ETSRXCU2=@ETSDATA@(.03)
if ETSRXCU2=""
QUIT
+76 SET ETSRELA=@ETSDATA@(.04)
+77 SET ETSSAB=@ETSDATA@(.05)
+78 SET ETSSUPP=@ETSDATA@(.06)
+79 IF ETSRELA'="inverse_isa"
QUIT
+80 IF ETSSAB'="RXNORM"
QUIT
+81 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+82 SET ETSCNT=ETSCNT+1
+83 SET ^TMP("ETSSTEP B",$JOB,ETSRXCU2)=""
End DoDot:2
+84 QUIT
End DoDot:1
+85 ;
+86 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+87 ;
+88 ;Step C -- Find "ingredient_of" relationships, using RXCUI2 from the last list as RXCUI1 lookup for this one
+89 SET ETSRXCU1=""
SET ETSCNT=0
FOR
SET ETSRXCU1=$ORDER(^TMP("ETSSTEP B",$JOB,ETSRXCU1))
if ETSRXCU1=""
QUIT
Begin DoDot:1
+90 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.22,"B",ETSRXCU1,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+91 KILL ETSDATA
DO GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
+92 SET ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
+93 SET ETSRXCU2=@ETSDATA@(.03)
if ETSRXCU2=""
QUIT
+94 SET ETSRELA=@ETSDATA@(.04)
+95 SET ETSSAB=@ETSDATA@(.05)
+96 SET ETSSUPP=@ETSDATA@(.06)
+97 IF ETSRELA'="ingredient_of"
QUIT
+98 IF ETSSAB'="RXNORM"
QUIT
+99 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+100 SET ETSCNT=ETSCNT+1
+101 SET ^TMP("ETSSTEP C",$JOB,ETSRXCU2)=""
End DoDot:2
+102 QUIT
End DoDot:1
+103 ;
+104 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+105 ;
+106 ;Step D -- Get simple concept/atom attributes with SAB="ATC", using RXCUI2 from the last list as RXCUI lookup for this one
+107 SET ETSRXCUI=""
SET ETSCNT=0
FOR
SET ETSRXCUI=$ORDER(^TMP("ETSSTEP C",$JOB,ETSRXCUI))
if ETSRXCUI=""
QUIT
Begin DoDot:1
+108 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.21,"B",ETSRXCUI,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+109 KILL ETSDATA
DO GETS^DIQ(129.21,ETSIEN_",",".02;.03;.05","","ETSDATA")
+110 SET ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
+111 SET ETSSAB=@ETSDATA@(.02)
+112 SET ETSSUPP=@ETSDATA@(.03)
+113 SET ETSCODE=@ETSDATA@(.05)
if ETSCODE=""
QUIT
+114 IF ETSSAB'="ATC"
QUIT
+115 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+116 SET ETSCNT=ETSCNT+1
+117 SET ^TMP("ETSSTEP D",$JOB,$EXTRACT(ETSCODE,1,5))=""
End DoDot:2
+118 QUIT
End DoDot:1
+119 ;
+120 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+121 ;
+122 ;Step E -- Get drug classes with CODE from the last list's 5-character abbreviation
+123 SET ETSCODE5=""
SET ETSCNT=0
FOR
SET ETSCODE5=$ORDER(^TMP("ETSSTEP D",$JOB,ETSCODE5))
if ETSCODE5=""
QUIT
Begin DoDot:1
+124 SET ETSC="^ETSRXN(129.21,""C"",""IS_DRUG_CLASS"")"
FOR
SET ETSC=$QUERY(@ETSC)
if $QSUBSCRIPT(ETSC,3)'="IS_DRUG_CLASS"
QUIT
Begin DoDot:2
+125 SET ETSIEN=$QSUBSCRIPT(ETSC,5)
+126 KILL ETSDATA
DO GETS^DIQ(129.21,ETSIEN_",",".01;.03;.05","","ETSDATA")
+127 SET ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
+128 SET ETSRXCUI=@ETSDATA@(.01)
if ETSRXCUI=""
QUIT
+129 SET ETSSUPP=@ETSDATA@(.03)
+130 SET ETSCODE=@ETSDATA@(.05)
+131 IF ETSCODE'=ETSCODE5
QUIT
+132 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+133 SET ETSCNT=ETSCNT+1
+134 SET ^TMP("ETSSTEP E",$JOB,ETSRXCUI)=""
End DoDot:2
+135 QUIT
End DoDot:1
+136 ;
+137 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+138 ;
+139 ;Step F -- Retrieve CODEs for these drug classes from concept names/sources file
+140 SET ETSCNT=0
SET ETSRXCUI=""
FOR
SET ETSRXCUI=$ORDER(^TMP("ETSSTEP E",$JOB,ETSRXCUI))
if 'ETSRXCUI
QUIT
Begin DoDot:1
+141 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.2,"B",ETSRXCUI,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+142 KILL ETSDATA
DO GETS^DIQ(129.2,ETSIEN_",",".04;.05","","ETSDATA")
+143 SET ETSDATA="ETSDATA(129.2,"""_ETSIEN_","")"
+144 SET ETSCODE=@ETSDATA@(.04)
if ETSCODE=""
QUIT
+145 SET ETSSUPP=@ETSDATA@(.05)
+146 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+147 SET ETSCNT=ETSCNT+1
+148 SET ^TMP("ETSSTEP F",$JOB,$EXTRACT(ETSCODE,1,5))=""
End DoDot:2
+149 QUIT
End DoDot:1
+150 ;
+151 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+152 ;
+153 ;Step G -- Get simple concept/atom attributes with ATN="ATC_LEVEL" and CODEs beginning with the last list's 5-character abbreviation
+154 SET ETSCODE5=""
SET ETSCNT=0
FOR
SET ETSCODE5=$ORDER(^TMP("ETSSTEP F",$JOB,ETSCODE5))
if ETSCODE5=""
QUIT
Begin DoDot:1
+155 SET ETSC="^ETSRXN(129.21,""C"",""ATC_LEVEL"")"
FOR
SET ETSC=$QUERY(@ETSC)
if $QSUBSCRIPT(ETSC,3)'="ATC_LEVEL"
QUIT
Begin DoDot:2
+156 SET ETSIEN=$QSUBSCRIPT(ETSC,5)
+157 KILL ETSDATA
DO GETS^DIQ(129.21,ETSIEN_",",".01;.03;.05","","ETSDATA")
+158 SET ETSDATA="ETSDATA(129.21,"""_ETSIEN_","")"
+159 SET ETSRXCUI=@ETSDATA@(.01)
if ETSRXCUI=""
QUIT
+160 SET ETSSUPP=@ETSDATA@(.03)
+161 SET ETSCODE=@ETSDATA@(.05)
+162 IF $EXTRACT(ETSCODE,1,5)'=ETSCODE5
QUIT
+163 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+164 SET ETSCNT=ETSCNT+1
+165 SET ^TMP("ETSSTEP G",$JOB,ETSRXCUI)=""
End DoDot:2
+166 QUIT
End DoDot:1
+167 ;
+168 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+169 ;
+170 ;Step H -- Retrieve concept names/sources for these drugs with SAB="RXNORM"
+171 SET ETSCNT=0
SET ETSRXCUI=""
FOR
SET ETSRXCUI=$ORDER(^TMP("ETSSTEP G",$JOB,ETSRXCUI))
if 'ETSRXCUI
QUIT
Begin DoDot:1
+172 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.2,"B",ETSRXCUI,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+173 KILL ETSDATA
DO GETS^DIQ(129.2,ETSIEN_",",".02;.05","","ETSDATA")
+174 SET ETSDATA="ETSDATA(129.2,"""_ETSIEN_","")"
+175 SET ETSSAB=@ETSDATA@(.02)
+176 SET ETSSUPP=@ETSDATA@(.05)
+177 IF ETSSAB'="RXNORM"
QUIT
+178 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+179 SET ETSCNT=ETSCNT+1
+180 SET ^TMP("ETSSTEP H",$JOB,ETSRXCUI)=""
End DoDot:2
+181 QUIT
End DoDot:1
+182 ;
+183 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+184 ;
+185 ;Step I -- Find "has_ingredient" relationships
+186 SET ETSRXCUI=""
SET ETSCNT=0
FOR
SET ETSRXCUI=$ORDER(^TMP("ETSSTEP H",$JOB,ETSRXCUI))
if ETSRXCUI=""
QUIT
Begin DoDot:1
+187 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.22,"B",ETSRXCUI,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+188 KILL ETSDATA
DO GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
+189 SET ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
+190 SET ETSRXCU2=@ETSDATA@(.03)
if ETSRXCU2=""
QUIT
+191 SET ETSRELA=@ETSDATA@(.04)
+192 SET ETSSAB=@ETSDATA@(.05)
+193 SET ETSSUPP=@ETSDATA@(.06)
+194 IF ETSRELA'="has_ingredient"
QUIT
+195 IF ETSSAB'="RXNORM"
QUIT
+196 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+197 SET ETSCNT=ETSCNT+1
+198 SET ^TMP("ETSSTEP I",$JOB,ETSRXCU2)=""
End DoDot:2
+199 QUIT
End DoDot:1
+200 ;
+201 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+202 ;
+203 ;Step J -- Find "isa" relationships, using RXCUI2 from the last list as RXCUI1 lookup for this one
+204 SET ETSRXCU1=""
SET ETSCNT=0
FOR
SET ETSRXCU1=$ORDER(^TMP("ETSSTEP I",$JOB,ETSRXCU1))
if ETSRXCU1=""
QUIT
Begin DoDot:1
+205 SET ETSIEN=""
FOR
SET ETSIEN=$ORDER(^ETSRXN(129.22,"B",ETSRXCU1,ETSIEN))
if 'ETSIEN
QUIT
Begin DoDot:2
+206 KILL ETSDATA
DO GETS^DIQ(129.22,ETSIEN_",",".03;.04;.05;.06","","ETSDATA")
+207 SET ETSDATA="ETSDATA(129.22,"""_ETSIEN_","")"
+208 SET ETSRXCU2=@ETSDATA@(.03)
if ETSRXCU2=""
QUIT
+209 SET ETSRELA=@ETSDATA@(.04)
+210 SET ETSSAB=@ETSDATA@(.05)
+211 SET ETSSUPP=@ETSDATA@(.06)
+212 IF ETSRELA'="isa"
QUIT
+213 IF ETSSAB'="RXNORM"
QUIT
+214 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+215 SET ETSCNT=ETSCNT+1
+216 SET ^TMP("ETSSTEP J",$JOB,ETSRXCU2)=""
End DoDot:2
+217 QUIT
End DoDot:1
+218 ;
+219 IF ETSCNT=0
DO CLEANUP
QUIT ETSCNT
+220 ;
+221 ;Step K -- Retrieve concept names/sources for these RXCUIs with SAB="VANDF", using RXCUI2 from the last list as RXCUI lookup for this one
+222 SET ETSRES=0
SET ETSRXCUI=""
SET ETSERR=0
FOR
SET ETSRXCUI=$ORDER(^TMP("ETSSTEP J",$JOB,ETSRXCUI))
if ETSRXCUI=""!ETSERR
QUIT
Begin DoDot:1
+223 SET ETSCNT=$$RXN2OUT^ETSRXN(ETSRXCUI,"ETSSTEP K")
IF ETSCNT<0
SET ETSERR=1
QUIT
+224 IF +ETSCNT=0
QUIT
+225 DO FILTER
+226 QUIT
End DoDot:1
+227 ;
+228 SET ^TMP(ETSSUB,$JOB,ETSVUID,"VUID")=ETSRES
+229 ;
+230 IF ETSERR
KILL ^TMP(ETSSUB,$JOB)
+231 ;
+232 DO CLEANUP
QUIT ETSRES
+233 ;
+234 ;
FILTER ;Weed out suppressed records and filter by TTY
+1 SET ETSCTR=""
FOR
SET ETSCTR=$ORDER(^TMP("ETSSTEP K",$JOB,ETSRXCUI,"VUID",ETSCTR))
if 'ETSCTR
QUIT
Begin DoDot:1
+2 SET ETSNODE=^TMP("ETSSTEP K",$JOB,ETSRXCUI,"VUID",ETSCTR,0)
+3 SET ETSTTY=$PIECE(ETSNODE,U,4)
+4 SET ETSSUPP=$PIECE(ETSNODE,U,6)
+5 IF ETSTTYS'[(","_ETSTTY_",")
QUIT
+6 IF ETSSUPP'=""
IF ETSSUPP'="N"
QUIT
+7 SET ETSRES=ETSRES+1
+8 SET ^TMP(ETSSUB,$JOB,ETSVUID,"VUID",ETSRES,0)=ETSNODE
+9 SET ^TMP(ETSSUB,$JOB,ETSVUID,"VUID",ETSRES,1)=^TMP("ETSSTEP K",$JOB,ETSRXCUI,"VUID",ETSCTR,1)
+10 IF 'ETSCLASS
SET ^TMP(ETSSUB,$JOB,ETSVUID,"VUID",ETSRES,2)=$$GET1^DIQ(129.2,$PIECE(ETSNODE,U)_",",91)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
CLEANUP ;Kill intermediate globals
+1 FOR ETSCTR="ETSSTEP A","ETSSTEP B","ETSSTEP C","ETSSTEP D","ETSSTEP E","ETSSTEP F","ETSSTEP G","ETSSTEP H","ETSSTEP I","ETSSTEP J","ETSSTEP K"
KILL ^TMP(ETSCTR,$JOB)
+2 QUIT
