BQIUTB3 ;VNGT/HS/ALA-Taxonomy table ; 20 Feb 2013 7:50 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
EN(DATA,TAXTY) ;EP -- BQI GET TAXONOMIES
NEW UID,II,Z,FILE,TN,NM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIUTB3",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN"_$C(30)
S TAXTY=$G(TAXTY,""),FILE=""
I TAXTY'="" S FILE=$S(TAXTY="DX":80,TAXTY="M":50,TAXTY="CP":81,TAXTY="PR":80.1,TAXTY="LB":60,TAXTY="ED":9999999.09,1:"")
I TAXTY'="LB" D
. S TN=0
. F S TN=$O(^ATXAX(TN)) Q:'TN D
.. I FILE'="",$P(^ATXAX(TN,0),U,15)'=FILE Q
.. I $P(^ATXAX(TN,0),U,12)="" Q
.. I $O(^ATXAX(TN,21,0))="" Q
.. S NM=$P(^ATXAX(TN,0),U,1)
.. S Z(NM,TN)=""
. ;
. S NM=""
. F S NM=$O(Z(NM)) Q:NM="" D
.. S TN=""
.. F S TN=$O(Z(NM,TN)) Q:TN="" S II=II+1,@DATA@(II)=NM_U_TN_";ATXAX("_$C(30)
;
I TAXTY="LB" D
. S TN=0
. F S TN=$O(^ATXLAB(TN)) Q:'TN D
.. I FILE'="",$P(^ATXLAB(TN,0),U,9)'=FILE Q
.. ;I $P(^ATXLAB(TN,0),U,7)="" Q
.. I $O(^ATXLAB(TN,21,0))="" Q
.. S NM=$P(^ATXLAB(TN,0),U,1)
.. S Z(NM,TN)=""
. ;
. S NM=""
. F S NM=$O(Z(NM)) Q:NM="" D
.. S TN=""
.. F S TN=$O(Z(NM,TN)) Q:TN="" S II=II+1,@DATA@(II)=NM_U_TN_";ATXLAB("_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ALG(DATA) ;EP - Get a list of allergies
NEW TEXT,IEN,VALUE
K @DATA
S II=0
S @DATA@(II)="T00080IEN^T00080"_$C(30)
S VALUE=$NA(^TMP("BQIALGY",UID)) K @VALUE
S IEN=0
F S IEN=$O(^GMR(120.8,IEN)) Q:'IEN D
. S TEXT=$P($G(^GMR(120.8,IEN,0)),U,2) I TEXT="" Q
. I $P($G(^GMR(120.8,IEN,"ER")),U,1)=1 Q
. S TEXT=$$STRIP^BQIUL1(TEXT," ")
. S @VALUE@(TEXT)=""
;
S TEXT=""
F S TEXT=$O(@VALUE@(TEXT)) Q:TEXT="" S II=II+1,@DATA@(II)=TEXT_U_TEXT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
K @VALUE
Q
;
LAB(DATA) ;EP - Lab Tests
NEW LN
K @DATA
S II=0,LN=0
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S LN=$O(^AUPNVLAB("B",LN)) Q:LN="" D
. I $G(^LAB(60,LN,0))="" Q
. S II=II+1,@DATA@(II)=LN_U_$P(^LAB(60,LN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
LABR(DATA) ;EP - Lab Tests and results
NEW LN,TYP,TYPE,VALUE,LTYP
K @DATA
S II=0,LN=0
S @DATA@(II)="T00010IEN^T00060^T00010TYPE^T00030VALUE"_$C(30)
F S LN=$O(^AUPNVLAB("B",LN)) Q:LN="" D
. I $G(^LAB(60,LN,0))="" Q
. S TYP=$P(^LAB(60,LN,0),"^",12),VALUE="",TYPE="",LTYP=""
. I TYP'="" D LTY(TYP)
. I $O(^LAB(60,LN,2,0))'="" S LTYP="P",TYPE="PANEL"
. S II=II+1,@DATA@(II)=LN_U_$P(^LAB(60,LN,0),U,1)_$S(TYPE="":"",1:" ("_LTYP_")")_U_TYPE_U_VALUE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
LTY(TYP) ;EP - Lab results
NEW FLD,TEST
S FLD=$P(TYP,",",2)
D FIELD^DID(63.04,FLD,"","*","TEST")
S TYPE=$G(TEST("TYPE")) I TYPE'="" S LTYP=$E(TYPE,1,1)
S VALUE=$G(TEST("POINTER"))
Q
;
MED(DATA) ;EP - Medications
NEW MN
K @DATA
S II=0,MN=0
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S MN=$O(^AUPNVMED("B",MN)) Q:MN="" D
. I $G(^PSDRUG(MN,0))="" Q
. S II=II+1,@DATA@(II)=MN_U_$P(^PSDRUG(MN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
CPT(DATA) ; EP - CPT
NEW MN
K @DATA
S II=0,MN=""
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S MN=$O(^AUPNVCPT("B",MN)) Q:MN="" D
. I $G(^ICPT(MN,0))="" Q
. S II=II+1,@DATA@(II)=MN_U_$P(^ICPT(MN,0),U,1)_"-"_$P(^ICPT(MN,0),U,2)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
EXM(DATA) ;EP - Exams
NEW MN
K @DATA
S II=0,MN=""
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S MN=$O(^AUPNVXAM("B",MN)) Q:MN="" D
. I $G(^AUTTEXAM(MN,0))="" Q
. S II=II+1,@DATA@(II)=MN_U_$P(^AUTTEXAM(MN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DXN(DATA) ;EP - Diagnoses
NEW DN,VALUE
S II=0,DN=0
S @DATA@(II)="T00010IEN^T00030"_$C(30)
F S DN=$O(^XTMP("BQIPOV",DN)) Q:'DN D
. S VALUE=^XTMP("BQIPOV",DN)
. S II=II+1,@DATA@(II)=$P(VALUE,U,1)_U_$P(VALUE,U,2)_" ["_$P(VALUE,U,3)_"] ("_$P(VALUE,U,4)_")"_$C(30) Q
S II=II+1,@DATA@(II)=$C(31)
Q
;
TPOV(DATA,NUM) ;EP - Top # of POVs
NEW NM,DN,VALUE,CT
S II=0,NM="",CT=0
F S NM=$O(^XTMP("BQIPOV","Z",NM),-1) Q:NM="" D Q:CT>NUM
. S DN="" F S DN=$O(^XTMP("BQIPOV","Z",NM,DN)) Q:DN="" D
.. S VALUE=^XTMP("BQIPOV","Z",NM,DN)
.. S II=II+1,@DATA@(II)=DN_U_$P(VALUE,U,1)_" ["_$P(VALUE,U,2)_"]"_$C(30),CT=CT+1
Q
;
POVS(DATA) ;EP - Snomed IDs for POV
NEW DN,SN
K @DATA
S II=0,DN=0
S @DATA@(II)="T00100IEN^T00245"_$C(30)
F S DN=$O(^AUPNVPOV("ASCI",DN)) Q:DN="" D
. S SN=$O(^BSTS(9002318.4,"C",36,DN,""))
. S II=II+1,@DATA@(II)=DN_U_$G(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
PROB(DATA) ; EP - Problems
NEW DN
K @DATA
S II=0,DN=0
S @DATA@(II)="T00010IEN^T00030"_$C(30)
F S DN=$O(^AUPNPROB("B",DN)) Q:DN="" D
. I $G(^ICD9(DN,0))="" Q
. S II=II+1,@DATA@(II)=DN_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"_$C(30) Q
S II=II+1,@DATA@(II)=$C(31)
Q
;
PROBS(DATA) ;EP - Snomed IDs for Problems
NEW DN,SN
K @DATA
S II=0,DN=0
S @DATA@(II)="T00100IEN^T00245"_$C(30)
F S DN=$O(^AUPNPROB("ASCT",DN)) Q:DN="" D
. S SN=$O(^BSTS(9002318.4,"C",36,DN,""))
. S II=II+1,@DATA@(II)=DN_U_$G(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
EMP(DATA) ;EP - Employers
NEW EN
K @DATA
S II=0,EN=""
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S EN=$O(^AUPNPAT("AF",EN)) Q:EN="" D
. I $G(^AUTNEMPL(EN,0))="" Q
. S II=II+1,@DATA@(II)=EN_U_$P(^AUTNEMPL(EN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DIV(DATA) ;EP - Divisions
NEW NM
K @DATA
S II=0,NM=0
S @DATA@(II)="T00010IEN^T00060"_$C(30)
F S NM=$O(^XTMP("BQISYDIV",NM)) Q:NM="" D
. S IEN=^XTMP("BQISYDIV",NM)
. I $G(^DIC(4,IEN,0))="" Q
. S II=II+1,@DATA@(II)=IEN_U_NM_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
COD(DATA) ; EP - Cause of Death
NEW DN
K @DATA
S II=0
S @DATA@(II)="T00010IEN^T00010^T00030DESCRIPTION"_$C(30)
S DN=""
F S DN=$O(^XTMP("BQICOD",DN)) Q:DN="" D
. I $G(^ICD9(DN,0))="" Q
. I $$VERSION^XPDUTL("AICD")>3.51 S II=II+1,@DATA@(II)=DN_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"_$C(30) Q
. S II=II+1,@DATA@(II)=DN_U_$P(^ICD9(DN,0),U,3)_" ["_$P(^ICD9(DN,0),U,1)_"]"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
LANG(DATA) ;EP - Preferred Language
NEW DN
K @DATA
S II=0
S @DATA@(II)="T00010IEN^T00030"_$C(30)
S DN=""
F S DN=$O(^XTMP("BQILANG",DN)) Q:DN="" D
. I $G(^AUTTLANG(DN,0))="" Q
. S II=II+1,@DATA@(II)=DN_U_$P(^AUTTLANG(DN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DET(DATA) ;EP - Definition Detail list
NEW DN
K @DATA
S II=0
S @DATA@(II)="T00010CODE^T00030"_$C(30)
S DN=0
F S DN=$O(^BQI(90506.5,DN)) Q:'DN D
. I $P(^BQI(90506.5,DN,0),U,15)'=1 Q
. S II=II+1,@DATA@(II)=$P(^BQI(90506.5,DN,0),U,2)_U_$P(^BQI(90506.5,DN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQIUTB3 ;VNGT/HS/ALA-Taxonomy table ; 20 Feb 2013 7:50 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
EN(DATA,TAXTY) ;EP -- BQI GET TAXONOMIES
+1 NEW UID,II,Z,FILE,TN,NM
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIUTB3",UID))
+4 KILL @DATA
+5 SET II=0
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER"
+7 SET @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN"_$CHAR(30)
+8 SET TAXTY=$GET(TAXTY,"")
SET FILE=""
+9 IF TAXTY'=""
SET FILE=$SELECT(TAXTY="DX":80,TAXTY="M":50,TAXTY="CP":81,TAXTY="PR":80.1,TAXTY="LB":60,TAXTY="ED":9999999.09,1:"")
+10 IF TAXTY'="LB"
Begin DoDot:1
+11 SET TN=0
+12 FOR
SET TN=$ORDER(^ATXAX(TN))
IF 'TN
QUIT
Begin DoDot:2
+13 IF FILE'=""
IF $PIECE(^ATXAX(TN,0),U,15)'=FILE
QUIT
+14 IF $PIECE(^ATXAX(TN,0),U,12)=""
QUIT
+15 IF $ORDER(^ATXAX(TN,21,0))=""
QUIT
+16 SET NM=$PIECE(^ATXAX(TN,0),U,1)
+17 SET Z(NM,TN)=""
End DoDot:2
+18 ;
+19 SET NM=""
+20 FOR
SET NM=$ORDER(Z(NM))
IF NM=""
QUIT
Begin DoDot:2
+21 SET TN=""
+22 FOR
SET TN=$ORDER(Z(NM,TN))
IF TN=""
QUIT
SET II=II+1
SET @DATA@(II)=NM_U_TN_";ATXAX("_$CHAR(30)
End DoDot:2
End DoDot:1
+23 ;
+24 IF TAXTY="LB"
Begin DoDot:1
+25 SET TN=0
+26 FOR
SET TN=$ORDER(^ATXLAB(TN))
IF 'TN
QUIT
Begin DoDot:2
+27 IF FILE'=""
IF $PIECE(^ATXLAB(TN,0),U,9)'=FILE
QUIT
+28 ;I $P(^ATXLAB(TN,0),U,7)="" Q
+29 IF $ORDER(^ATXLAB(TN,21,0))=""
QUIT
+30 SET NM=$PIECE(^ATXLAB(TN,0),U,1)
+31 SET Z(NM,TN)=""
End DoDot:2
+32 ;
+33 SET NM=""
+34 FOR
SET NM=$ORDER(Z(NM))
IF NM=""
QUIT
Begin DoDot:2
+35 SET TN=""
+36 FOR
SET TN=$ORDER(Z(NM,TN))
IF TN=""
QUIT
SET II=II+1
SET @DATA@(II)=NM_U_TN_";ATXLAB("_$CHAR(30)
End DoDot:2
End DoDot:1
+37 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+38 QUIT
+39 ;
ALG(DATA) ;EP - Get a list of allergies
+1 NEW TEXT,IEN,VALUE
+2 KILL @DATA
+3 SET II=0
+4 SET @DATA@(II)="T00080IEN^T00080"_$CHAR(30)
+5 SET VALUE=$NAME(^TMP("BQIALGY",UID))
KILL @VALUE
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^GMR(120.8,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+8 SET TEXT=$PIECE($GET(^GMR(120.8,IEN,0)),U,2)
IF TEXT=""
QUIT
+9 IF $PIECE($GET(^GMR(120.8,IEN,"ER")),U,1)=1
QUIT
+10 SET TEXT=$$STRIP^BQIUL1(TEXT," ")
+11 SET @VALUE@(TEXT)=""
End DoDot:1
+12 ;
+13 SET TEXT=""
+14 FOR
SET TEXT=$ORDER(@VALUE@(TEXT))
IF TEXT=""
QUIT
SET II=II+1
SET @DATA@(II)=TEXT_U_TEXT_$CHAR(30)
+15 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+16 KILL @VALUE
+17 QUIT
+18 ;
LAB(DATA) ;EP - Lab Tests
+1 NEW LN
+2 KILL @DATA
+3 SET II=0
SET LN=0
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET LN=$ORDER(^AUPNVLAB("B",LN))
IF LN=""
QUIT
Begin DoDot:1
+6 IF $GET(^LAB(60,LN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=LN_U_$PIECE(^LAB(60,LN,0),U,1)_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
LABR(DATA) ;EP - Lab Tests and results
+1 NEW LN,TYP,TYPE,VALUE,LTYP
+2 KILL @DATA
+3 SET II=0
SET LN=0
+4 SET @DATA@(II)="T00010IEN^T00060^T00010TYPE^T00030VALUE"_$CHAR(30)
+5 FOR
SET LN=$ORDER(^AUPNVLAB("B",LN))
IF LN=""
QUIT
Begin DoDot:1
+6 IF $GET(^LAB(60,LN,0))=""
QUIT
+7 SET TYP=$PIECE(^LAB(60,LN,0),"^",12)
SET VALUE=""
SET TYPE=""
SET LTYP=""
+8 IF TYP'=""
DO LTY(TYP)
+9 IF $ORDER(^LAB(60,LN,2,0))'=""
SET LTYP="P"
SET TYPE="PANEL"
+10 SET II=II+1
SET @DATA@(II)=LN_U_$PIECE(^LAB(60,LN,0),U,1)_$SELECT(TYPE="":"",1:" ("_LTYP_")")_U_TYPE_U_VALUE_$CHAR(30)
End DoDot:1
+11 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+12 QUIT
+13 ;
LTY(TYP) ;EP - Lab results
+1 NEW FLD,TEST
+2 SET FLD=$PIECE(TYP,",",2)
+3 DO FIELD^DID(63.04,FLD,"","*","TEST")
+4 SET TYPE=$GET(TEST("TYPE"))
IF TYPE'=""
SET LTYP=$EXTRACT(TYPE,1,1)
+5 SET VALUE=$GET(TEST("POINTER"))
+6 QUIT
+7 ;
MED(DATA) ;EP - Medications
+1 NEW MN
+2 KILL @DATA
+3 SET II=0
SET MN=0
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET MN=$ORDER(^AUPNVMED("B",MN))
IF MN=""
QUIT
Begin DoDot:1
+6 IF $GET(^PSDRUG(MN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=MN_U_$PIECE(^PSDRUG(MN,0),U,1)_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
CPT(DATA) ; EP - CPT
+1 NEW MN
+2 KILL @DATA
+3 SET II=0
SET MN=""
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET MN=$ORDER(^AUPNVCPT("B",MN))
IF MN=""
QUIT
Begin DoDot:1
+6 IF $GET(^ICPT(MN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=MN_U_$PIECE(^ICPT(MN,0),U,1)_"-"_$PIECE(^ICPT(MN,0),U,2)_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
EXM(DATA) ;EP - Exams
+1 NEW MN
+2 KILL @DATA
+3 SET II=0
SET MN=""
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET MN=$ORDER(^AUPNVXAM("B",MN))
IF MN=""
QUIT
Begin DoDot:1
+6 IF $GET(^AUTTEXAM(MN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=MN_U_$PIECE(^AUTTEXAM(MN,0),U,1)_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
DXN(DATA) ;EP - Diagnoses
+1 NEW DN,VALUE
+2 SET II=0
SET DN=0
+3 SET @DATA@(II)="T00010IEN^T00030"_$CHAR(30)
+4 FOR
SET DN=$ORDER(^XTMP("BQIPOV",DN))
IF 'DN
QUIT
Begin DoDot:1
+5 SET VALUE=^XTMP("BQIPOV",DN)
+6 SET II=II+1
SET @DATA@(II)=$PIECE(VALUE,U,1)_U_$PIECE(VALUE,U,2)_" ["_$PIECE(VALUE,U,3)_"] ("_$PIECE(VALUE,U,4)_")"_$CHAR(30)
QUIT
End DoDot:1
+7 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+8 QUIT
+9 ;
TPOV(DATA,NUM) ;EP - Top # of POVs
+1 NEW NM,DN,VALUE,CT
+2 SET II=0
SET NM=""
SET CT=0
+3 FOR
SET NM=$ORDER(^XTMP("BQIPOV","Z",NM),-1)
IF NM=""
QUIT
Begin DoDot:1
+4 SET DN=""
FOR
SET DN=$ORDER(^XTMP("BQIPOV","Z",NM,DN))
IF DN=""
QUIT
Begin DoDot:2
+5 SET VALUE=^XTMP("BQIPOV","Z",NM,DN)
+6 SET II=II+1
SET @DATA@(II)=DN_U_$PIECE(VALUE,U,1)_" ["_$PIECE(VALUE,U,2)_"]"_$CHAR(30)
SET CT=CT+1
End DoDot:2
End DoDot:1
IF CT>NUM
QUIT
+7 QUIT
+8 ;
POVS(DATA) ;EP - Snomed IDs for POV
+1 NEW DN,SN
+2 KILL @DATA
+3 SET II=0
SET DN=0
+4 SET @DATA@(II)="T00100IEN^T00245"_$CHAR(30)
+5 FOR
SET DN=$ORDER(^AUPNVPOV("ASCI",DN))
IF DN=""
QUIT
Begin DoDot:1
+6 SET SN=$ORDER(^BSTS(9002318.4,"C",36,DN,""))
+7 SET II=II+1
SET @DATA@(II)=DN_U_$GET(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
PROB(DATA) ; EP - Problems
+1 NEW DN
+2 KILL @DATA
+3 SET II=0
SET DN=0
+4 SET @DATA@(II)="T00010IEN^T00030"_$CHAR(30)
+5 FOR
SET DN=$ORDER(^AUPNPROB("B",DN))
IF DN=""
QUIT
Begin DoDot:1
+6 IF $GET(^ICD9(DN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=DN_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"_$CHAR(30)
QUIT
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
PROBS(DATA) ;EP - Snomed IDs for Problems
+1 NEW DN,SN
+2 KILL @DATA
+3 SET II=0
SET DN=0
+4 SET @DATA@(II)="T00100IEN^T00245"_$CHAR(30)
+5 FOR
SET DN=$ORDER(^AUPNPROB("ASCT",DN))
IF DN=""
QUIT
Begin DoDot:1
+6 SET SN=$ORDER(^BSTS(9002318.4,"C",36,DN,""))
+7 SET II=II+1
SET @DATA@(II)=DN_U_$GET(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
EMP(DATA) ;EP - Employers
+1 NEW EN
+2 KILL @DATA
+3 SET II=0
SET EN=""
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET EN=$ORDER(^AUPNPAT("AF",EN))
IF EN=""
QUIT
Begin DoDot:1
+6 IF $GET(^AUTNEMPL(EN,0))=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=EN_U_$PIECE(^AUTNEMPL(EN,0),U,1)_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
DIV(DATA) ;EP - Divisions
+1 NEW NM
+2 KILL @DATA
+3 SET II=0
SET NM=0
+4 SET @DATA@(II)="T00010IEN^T00060"_$CHAR(30)
+5 FOR
SET NM=$ORDER(^XTMP("BQISYDIV",NM))
IF NM=""
QUIT
Begin DoDot:1
+6 SET IEN=^XTMP("BQISYDIV",NM)
+7 IF $GET(^DIC(4,IEN,0))=""
QUIT
+8 SET II=II+1
SET @DATA@(II)=IEN_U_NM_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
COD(DATA) ; EP - Cause of Death
+1 NEW DN
+2 KILL @DATA
+3 SET II=0
+4 SET @DATA@(II)="T00010IEN^T00010^T00030DESCRIPTION"_$CHAR(30)
+5 SET DN=""
+6 FOR
SET DN=$ORDER(^XTMP("BQICOD",DN))
IF DN=""
QUIT
Begin DoDot:1
+7 IF $GET(^ICD9(DN,0))=""
QUIT
+8 IF $$VERSION^XPDUTL("AICD")>3.51
SET II=II+1
SET @DATA@(II)=DN_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"_$CHAR(30)
QUIT
+9 SET II=II+1
SET @DATA@(II)=DN_U_$PIECE(^ICD9(DN,0),U,3)_" ["_$PIECE(^ICD9(DN,0),U,1)_"]"_$CHAR(30)
End DoDot:1
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
LANG(DATA) ;EP - Preferred Language
+1 NEW DN
+2 KILL @DATA
+3 SET II=0
+4 SET @DATA@(II)="T00010IEN^T00030"_$CHAR(30)
+5 SET DN=""
+6 FOR
SET DN=$ORDER(^XTMP("BQILANG",DN))
IF DN=""
QUIT
Begin DoDot:1
+7 IF $GET(^AUTTLANG(DN,0))=""
QUIT
+8 SET II=II+1
SET @DATA@(II)=DN_U_$PIECE(^AUTTLANG(DN,0),U,1)_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
DET(DATA) ;EP - Definition Detail list
+1 NEW DN
+2 KILL @DATA
+3 SET II=0
+4 SET @DATA@(II)="T00010CODE^T00030"_$CHAR(30)
+5 SET DN=0
+6 FOR
SET DN=$ORDER(^BQI(90506.5,DN))
IF 'DN
QUIT
Begin DoDot:1
+7 IF $PIECE(^BQI(90506.5,DN,0),U,15)'=1
QUIT
+8 SET II=II+1
SET @DATA@(II)=$PIECE(^BQI(90506.5,DN,0),U,2)_U_$PIECE(^BQI(90506.5,DN,0),U,1)_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
