Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIUTB3

BQIUTB3.m

Go to the documentation of this file. 
  1. BQIUTB3 ;VNGT/HS/ALA-Taxonomy table ; 20 Feb 2013  7:50 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,TAXTY) ;EP -- BQI GET TAXONOMIES
  1.  NEW UID,II,Z,FILE,TN,NM
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIUTB3",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN"_$C(30)
  1.  S TAXTY=$G(TAXTY,""),FILE=""
  1.  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:"")
  1.  I TAXTY'="LB" D
  1.  . S TN=0
  1.  . F  S TN=$O(^ATXAX(TN)) Q:'TN  D
  1.  .. I FILE'="",$P(^ATXAX(TN,0),U,15)'=FILE Q
  1.  .. I $P(^ATXAX(TN,0),U,12)="" Q
  1.  .. I $O(^ATXAX(TN,21,0))="" Q
  1.  .. S NM=$P(^ATXAX(TN,0),U,1)
  1.  .. S Z(NM,TN)=""
  1.  . ;
  1.  . S NM=""
  1.  . F  S NM=$O(Z(NM)) Q:NM=""  D
  1.  .. S TN=""
  1.  .. F  S TN=$O(Z(NM,TN)) Q:TN=""  S II=II+1,@DATA@(II)=NM_U_TN_";ATXAX("_$C(30)
  1.  ;
  1.  I TAXTY="LB" D
  1.  . S TN=0
  1.  . F  S TN=$O(^ATXLAB(TN)) Q:'TN  D
  1.  .. I FILE'="",$P(^ATXLAB(TN,0),U,9)'=FILE Q
  1.  .. ;I $P(^ATXLAB(TN,0),U,7)="" Q
  1.  .. I $O(^ATXLAB(TN,21,0))="" Q
  1.  .. S NM=$P(^ATXLAB(TN,0),U,1)
  1.  .. S Z(NM,TN)=""
  1.  . ;
  1.  . S NM=""
  1.  . F  S NM=$O(Z(NM)) Q:NM=""  D
  1.  .. S TN=""
  1.  .. F  S TN=$O(Z(NM,TN)) Q:TN=""  S II=II+1,@DATA@(II)=NM_U_TN_";ATXLAB("_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ALG(DATA) ;EP - Get a list of allergies
  1.  NEW TEXT,IEN,VALUE
  1.  K @DATA
  1.  S II=0
  1.  S @DATA@(II)="T00080IEN^T00080"_$C(30)
  1.  S VALUE=$NA(^TMP("BQIALGY",UID)) K @VALUE
  1.  S IEN=0
  1.  F  S IEN=$O(^GMR(120.8,IEN)) Q:'IEN  D
  1.  . S TEXT=$P($G(^GMR(120.8,IEN,0)),U,2) I TEXT="" Q
  1.  . I $P($G(^GMR(120.8,IEN,"ER")),U,1)=1 Q
  1.  . S TEXT=$$STRIP^BQIUL1(TEXT," ")
  1.  . S @VALUE@(TEXT)=""
  1.  ;
  1.  S TEXT=""
  1.  F  S TEXT=$O(@VALUE@(TEXT)) Q:TEXT=""  S II=II+1,@DATA@(II)=TEXT_U_TEXT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  K @VALUE
  1.  Q
  1.  ;
  1. LAB(DATA) ;EP - Lab Tests
  1.  NEW LN
  1.  K @DATA
  1.  S II=0,LN=0
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S LN=$O(^AUPNVLAB("B",LN)) Q:LN=""  D
  1.  . I $G(^LAB(60,LN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=LN_U_$P(^LAB(60,LN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. LABR(DATA) ;EP - Lab Tests and results
  1.  NEW LN,TYP,TYPE,VALUE,LTYP
  1.  K @DATA
  1.  S II=0,LN=0
  1.  S @DATA@(II)="T00010IEN^T00060^T00010TYPE^T00030VALUE"_$C(30)
  1.  F  S LN=$O(^AUPNVLAB("B",LN)) Q:LN=""  D
  1.  . I $G(^LAB(60,LN,0))="" Q
  1.  . S TYP=$P(^LAB(60,LN,0),"^",12),VALUE="",TYPE="",LTYP=""
  1.  . I TYP'="" D LTY(TYP)
  1.  . I $O(^LAB(60,LN,2,0))'="" S LTYP="P",TYPE="PANEL"
  1.  . 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)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. LTY(TYP) ;EP - Lab results
  1.  NEW FLD,TEST
  1.  S FLD=$P(TYP,",",2)
  1.  D FIELD^DID(63.04,FLD,"","*","TEST")
  1.  S TYPE=$G(TEST("TYPE")) I TYPE'="" S LTYP=$E(TYPE,1,1)
  1.  S VALUE=$G(TEST("POINTER"))
  1.  Q
  1.  ;
  1. MED(DATA) ;EP - Medications
  1.  NEW MN
  1.  K @DATA
  1.  S II=0,MN=0
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S MN=$O(^AUPNVMED("B",MN)) Q:MN=""  D
  1.  . I $G(^PSDRUG(MN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=MN_U_$P(^PSDRUG(MN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CPT(DATA) ; EP - CPT
  1.  NEW MN
  1.  K @DATA
  1.  S II=0,MN=""
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S MN=$O(^AUPNVCPT("B",MN)) Q:MN=""  D
  1.  . I $G(^ICPT(MN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=MN_U_$P(^ICPT(MN,0),U,1)_"-"_$P(^ICPT(MN,0),U,2)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EXM(DATA) ;EP - Exams
  1.  NEW MN
  1.  K @DATA
  1.  S II=0,MN=""
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S MN=$O(^AUPNVXAM("B",MN)) Q:MN=""  D
  1.  . I $G(^AUTTEXAM(MN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=MN_U_$P(^AUTTEXAM(MN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. DXN(DATA) ;EP - Diagnoses
  1.  NEW DN,VALUE
  1.  S II=0,DN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S DN=$O(^XTMP("BQIPOV",DN)) Q:'DN  D
  1.  . S VALUE=^XTMP("BQIPOV",DN)
  1.  . 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
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. TPOV(DATA,NUM) ;EP - Top # of POVs
  1.  NEW NM,DN,VALUE,CT
  1.  S II=0,NM="",CT=0
  1.  F  S NM=$O(^XTMP("BQIPOV","Z",NM),-1) Q:NM=""  D  Q:CT>NUM
  1.  . S DN="" F  S DN=$O(^XTMP("BQIPOV","Z",NM,DN)) Q:DN=""  D
  1.  .. S VALUE=^XTMP("BQIPOV","Z",NM,DN)
  1.  .. S II=II+1,@DATA@(II)=DN_U_$P(VALUE,U,1)_" ["_$P(VALUE,U,2)_"]"_$C(30),CT=CT+1
  1.  Q
  1.  ;
  1. POVS(DATA) ;EP - Snomed IDs for POV
  1.  NEW DN,SN
  1.  K @DATA
  1.  S II=0,DN=0
  1.  S @DATA@(II)="T00100IEN^T00245"_$C(30)
  1.  F  S DN=$O(^AUPNVPOV("ASCI",DN)) Q:DN=""  D
  1.  . S SN=$O(^BSTS(9002318.4,"C",36,DN,""))
  1.  . S II=II+1,@DATA@(II)=DN_U_$G(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PROB(DATA) ; EP - Problems
  1.  NEW DN
  1.  K @DATA
  1.  S II=0,DN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S DN=$O(^AUPNPROB("B",DN)) Q:DN=""  D
  1.  . I $G(^ICD9(DN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=DN_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"_$C(30) Q
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PROBS(DATA) ;EP - Snomed IDs for Problems
  1.  NEW DN,SN
  1.  K @DATA
  1.  S II=0,DN=0
  1.  S @DATA@(II)="T00100IEN^T00245"_$C(30)
  1.  F  S DN=$O(^AUPNPROB("ASCT",DN)) Q:DN=""  D
  1.  . S SN=$O(^BSTS(9002318.4,"C",36,DN,""))
  1.  . S II=II+1,@DATA@(II)=DN_U_$G(^BSTS(9002318.4,SN,1))_" ["_DN_"]"_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EMP(DATA) ;EP - Employers
  1.  NEW EN
  1.  K @DATA
  1.  S II=0,EN=""
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S EN=$O(^AUPNPAT("AF",EN)) Q:EN=""  D
  1.  . I $G(^AUTNEMPL(EN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=EN_U_$P(^AUTNEMPL(EN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. DIV(DATA) ;EP - Divisions
  1.  NEW NM
  1.  K @DATA
  1.  S II=0,NM=0
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S NM=$O(^XTMP("BQISYDIV",NM)) Q:NM=""  D
  1.  . S IEN=^XTMP("BQISYDIV",NM)
  1.  . I $G(^DIC(4,IEN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=IEN_U_NM_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. COD(DATA) ; EP - Cause of Death
  1.  NEW DN
  1.  K @DATA
  1.  S II=0
  1.  S @DATA@(II)="T00010IEN^T00010^T00030DESCRIPTION"_$C(30)
  1.  S DN=""
  1.  F  S DN=$O(^XTMP("BQICOD",DN)) Q:DN=""  D
  1.  . I $G(^ICD9(DN,0))="" Q
  1.  . 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
  1.  . S II=II+1,@DATA@(II)=DN_U_$P(^ICD9(DN,0),U,3)_" ["_$P(^ICD9(DN,0),U,1)_"]"_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. LANG(DATA) ;EP - Preferred Language
  1.  NEW DN
  1.  K @DATA
  1.  S II=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  S DN=""
  1.  F  S DN=$O(^XTMP("BQILANG",DN)) Q:DN=""  D
  1.  . I $G(^AUTTLANG(DN,0))="" Q
  1.  . S II=II+1,@DATA@(II)=DN_U_$P(^AUTTLANG(DN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. DET(DATA) ;EP - Definition Detail list
  1.  NEW DN
  1.  K @DATA
  1.  S II=0
  1.  S @DATA@(II)="T00010CODE^T00030"_$C(30)
  1.  S DN=0
  1.  F  S DN=$O(^BQI(90506.5,DN)) Q:'DN  D
  1.  . I $P(^BQI(90506.5,DN,0),U,15)'=1 Q
  1.  . 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)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q