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

BQITAXX5.m

Go to the documentation of this file. 
  1. BQITAXX5 ;GDIT/HS/ALA-Taxonomy Items ; 28 Oct 2013  9:53 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. ITM(DATA,IVALUE) ; EP -- BQI GET TAXONOMY ITEMS
  1.  ;
  1.  ; Input
  1.  ;   IVALUE - Internal entry number of taxonomy in structure, IEN;FILE REF
  1.  ;            because this is a variable pointer value
  1.  ;
  1.  NEW UID,II,FNAME,FNBR,ROOT,FILE,IEN,FLD,VIEN,FDESC,LIEN,HIEN,BQIH,BQIJ,X,TTXT
  1.  NEW TEXT,HIGH,LOW,DTCRT,DTMOD,ALL,NOREC
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITXITM",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S IVALUE=$G(IVALUE,"")
  1.  S ALL=(IVALUE="")
  1.  ;
  1.  I IVALUE="" D
  1.  . S BQIH=$$SPM^BQIGPUTL()
  1.  . ;S II=II+1
  1.  . D HDR
  1.  . S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^"_HDR_$C(30)
  1.  . S BQIJ=0
  1.  . F  S BQIJ=$O(^BQI(90508,BQIH,10,BQIJ)) Q:'BQIJ  D
  1.  .. NEW DA,IENS,IVALUE,TTXT,TEXT,ID,CAT
  1.  .. S IVALUE=$P(^BQI(90508,BQIH,10,BQIJ,0),U,2) Q:IVALUE=""
  1.  .. S DA(1)=BQIH,DA=BQIJ,IENS=$$IENS^DILF(.DA)
  1.  .. S TTXT=$$GET1^DIQ(90508.03,IENS,.01,"E"),TIEN=$$GET1^DIQ(90508.03,IENS,.02,"I")
  1.  .. D FCAT(TIEN)
  1.  .. S TEXT=TTXT_"^"_TIEN_"^"_ID
  1.  .. S TEXT=TEXT_"^"_$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_CAT
  1.  .. S TEXT=TEXT_"^"_$S($$GET1^DIQ(90508.03,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90508.03,IENS,.07,"I")=1:"YES",'$$ENTRS(IVALUE):"NO",1:"YES")_"^"
  1.  .. D GET
  1.  ;
  1.  I IVALUE'="" D
  1.  . D HDR S @DATA@(II)=HDR_$C(30)
  1.  . S TEXT=""
  1.  . I IVALUE'["BSTS" D GET Q
  1.  . NEW BQILIST,BQISUB,OK,CODE,DESC,TSYS,FNAME,FNBR,FDESC,LIEN
  1.  . S BQILIST=$NA(^TMP("BQISNSB",$J)) K @BQILIST
  1.  . S BQISUB=$P(IVALUE,";",1)
  1.  . S OK=$$SUBLST^BSTSAPI(BQILIST,BQISUB_"^36^1")
  1.  . S BQSN=0
  1.  . F  S BQSN=$O(@BQILIST@(BQSN)) Q:BQSN=""  D
  1.  .. S CODE=$P(@BQILIST@(BQSN),"^",1),DESC=$P(@BQILIST@(BQSN),"^",3),TSYS="SNOMED CT US Extension"
  1.  .. S FNAME="BSTS CONCEPT",FNBR="9002318.4",FDESC=BQISUB,DTCRT="",DTMOD=""
  1.  .. S LIEN=$O(^BSTS(9002318.4,"C",36,CODE,""))
  1.  .. S II=II+1
  1.  .. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$C(30)
  1.  . K @BQILIST
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. GET ;
  1.  NEW TSYS,DESC,CODE,INAC
  1.  S IEN=$P(IVALUE,";",1),FILE=$$GREF(IVALUE),ROOT=$$ROOT^DILFD(FILE,"",1)
  1.  I FILE=9002226 S FLD=".15"
  1.  I FILE=9002228 S FLD=".09"
  1.  S FNAME=$$GET1^DIQ(FILE,IEN,FLD,"E")
  1.  S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
  1.  S FDESC=$$GET1^DIQ(FILE,IEN,.02,"E")
  1.  S TAX=$$GET1^DIQ(FILE,IEN,.01,"E")
  1.  ;
  1.  I FILE=9002226 S DTCRT=$$GET1^DIQ(FILE,IEN,.09,"I"),DTMOD=""
  1.  I FILE=9002228 S DTMOD=$$GET1^DIQ(FILE,IEN,.06,"I"),DTCRT=""
  1.  ;
  1.  S VIEN=0
  1.  ; If there aren't any items (For complete listing only)
  1.  I '$O(@ROOT@(IEN,21,VIEN)) D:$G(ALL)  Q
  1.  . S II=II+1
  1.  . S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^^^^^^^"_$C(30)
  1.  I FNBR=80!(FNBR=80.1)!(FNBR=81) D  Q
  1.  . NEW TREF
  1.  . S TREF=$NA(^TMP("BQITAX",$J)) K @TREF
  1.  . D BLD^BQITUTL(TAX,.TREF)
  1.  . NEW DESC,TSYS,CODE,INAC
  1.  . S LIEN=0
  1.  . F  S LIEN=$O(@TREF@(LIEN)) Q:'LIEN  D
  1.  .. S CODE=$P(@TREF@(LIEN),"^",1),TSYS=$P(@TREF@(LIEN),"^",4),II=II+1
  1.  .. I FNBR=80 D
  1.  ... S DESC=$$ICD9^BQIUL3(LIEN,,4),INAC=$$INIC(FNBR,LIEN)
  1.  ... I INAC="",$$CSI^ICDEX(80,LIEN)=1 S INAC=3150930
  1.  .. I FNBR=80.1 D
  1.  ... S DESC=$$ICD0^BQIUL3(LIEN,,5),INAC=$$INIC(FNBR,LIEN)
  1.  ... I INAC="",$$CSI^ICDEX(80.1,LIEN)=2 S INAC=3150930
  1.  .. I FNBR=81 S DESC=$P($$CPT^ICPTCOD(LIEN,,3),U,3),TSYS="CPT",INAC=$$INCP(LIEN)
  1.  .. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$$FMTE^BQIUL1(INAC)_$C(30)
  1.  . K @TREF
  1.  I FILE=9002228 D  Q
  1.  . S TREF=$NA(^TMP(UID,"BQITAX")) K @TREF
  1.  . D BLD^BQITUTL(TAX,.TREF,"L")
  1.  . S LIEN=""
  1.  . F  S LIEN=$O(@TREF@(LIEN)) Q:LIEN=""  D
  1.  .. S II=II+1,DESC=$P(@TREF@(LIEN),U,1)
  1.  .. S VIEN=$O(^ATXLAB(IEN,21,"B",LIEN,""))
  1.  .. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$G(LIEN)_"^"_$G(LOW)_"^"_$G(DESC)_"^"_$G(TSYS)_"^"_$C(30)
  1.  ; If there are items
  1.  F  S VIEN=$O(@ROOT@(IEN,21,VIEN)) Q:'VIEN  D
  1.  . S II=II+1,NOREC=0
  1.  . NEW DA,IENS
  1.  . S DA(1)=IEN,DA=VIEN,IENS=$$IENS^DILF(.DA)
  1.  . S LOW=$$GET1^DIQ(FILE_".02101",IENS,.01,"E")
  1.  . S LIEN=$$GET1^DIQ(FILE_".02101",IENS,.01,"I")
  1.  . I LOW'="" D
  1.  .. I LIEN=LOW D
  1.  ... S LIEN=$$FIND1^DIC(FNBR,,"MP",LOW)
  1.  ... S:LIEN<1 LIEN=LOW
  1.  . S HIGH=$$GET1^DIQ(FILE_".02101",IENS,.02,"E")
  1.  . S HIEN=$$GET1^DIQ(FILE_".02101",IENS,.02,"I")
  1.  . I HIGH="" S HIEN=""
  1.  . I HIGH'="" D
  1.  .. I HIEN=HIGH D
  1.  ... S HIEN=$$FIND1^DIC(FNBR,,"MP",HIGH)
  1.  ... S:HIEN<1 HIEN=HIGH
  1.  . I FNBR=50.67!(TAX[" NDC") D
  1.  .. ;NEW NDC
  1.  .. S LIEN=$O(^PSDRUG("D",LOW,"")),DESC="",TSYS="NDC"
  1.  .. I FNAME="" S FNAME="DRUG"
  1.  .. I FNBR="" S FNBR=50
  1.  .. I LIEN'="" S DESC=$P(^PSDRUG(LIEN,0),U,1)
  1.  . I FNBR=95.3 D
  1.  .. NEW LNC
  1.  .. S LNC=$P(LOW,"-",1),LIEN=$O(^LAB(60,"AF",LNC,"")),DESC="",TSYS="LOINC"
  1.  .. I LIEN'="" S DESC=$P(^LAB(60,LIEN,0),U,1)
  1.  . I FNBR=9999999.14!(FDESC["CVX") S NOREC=0 D
  1.  .. NEW CVXLN,CVXHN
  1.  .. S CVXLN=$O(^AUTTIMM("C",LOW,"")),DESC=""
  1.  .. I CVXLN="" S NOREC=1 Q
  1.  .. S DESC=$P(^AUTTIMM(CVXLN,0),U,1)
  1.  . I FNBR'=9999999.31,LOW?.N D
  1.  .. I NOREC Q
  1.  .. I FNBR["50."!(TAX[" NDC")!(FNBR=9999999.14)!(TAX[" CVX") Q
  1.  .. S DESC=$$GET1^DIQ(FNBR,LOW_",",.01,"E")
  1.  .. I FNBR=50 S LIEN=LOW,LOW=""
  1.  . I FNBR'=9999999.31,LOW'?.N D
  1.  .. I NOREC Q
  1.  .. I FNBR["50."!(FNBR=95.3)!(TAX[" NDC") Q
  1.  .. S DESC=LOW,LOW="",LIEN=""
  1.  . I FNBR=9999999.31 D
  1.  .. I NOREC Q
  1.  .. S TSYS="ADA",DESC="",LOW=$P(^AUTTADA(LIEN,0),"^",1)
  1.  .. I LIEN="" S NOREC=1 Q
  1.  .. S DESC=$P(^AUTTADA(LIEN,0),"^",2)
  1.  . ;
  1.  . I NOREC Q
  1.  . I FNBR'=50 D
  1.  .. I LOW="",LIEN'="" S LOW=LIEN,LIEN=""
  1.  .. I HIGH="",HIEN'="" S HIGH=HIEN,HIEN=""
  1.  . ;S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_VIEN_"^"_LOW_"^"_LIEN_"^"_HIGH_"^"_HIEN_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_$C(30)
  1.  . S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$G(LIEN)_"^"_$G(LOW)_"^"_$G(DESC)_"^"_$G(TSYS)_$C(30)
  1.  Q
  1.  ;
  1. ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
  1.  ;
  1.  ;Input
  1.  ;  TAXV - Taxonomy internal entry number
  1.  ;
  1.  NEW IEN,GLOBAL
  1.  I TAXV="" Q 0
  1.  S IEN=$P(TAXV,";",1),GLOBAL="^"_$P(TAXV,";",2)_IEN_")"
  1.  I $O(@GLOBAL@(21,0))'="" Q 1
  1.  Q 0
  1.  ;
  1. GREF(VAL) ; EP - Returns the file number
  1.  NEW GL,FILN
  1.  S GL="^"_$P(VAL,";",2)_"0)"
  1.  S FILN=$P($G(@GL),U,2)
  1.  S FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  Q FILN
  1.  ;
  1. HDR ; EP - Header
  1.  S HDR="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^D00015DATE_CREATED^D00015DATE_MODIFIED^I00010TVAL_IEN^"
  1.  S HDR=HDR_"I00010IVAL_IEN^T00020IVAL_CODE^T00060IVAL_DESC^T00015IVAL_TSYS^D00015INACTIVE"
  1.  ;S @DATA@(II)="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
  1.  ;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
  1.  ;S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030FILE_NAME^"
  1.  ;S @DATA@(II)=@DATA@(II)_"I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
  1.  ;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
  1.  Q
  1.  ;
  1. FCAT(TXIEN) ;EP
  1.  NEW IEN,FILE,ROOT,FLD,FNBR
  1.  S IEN=$P(TXIEN,";",1),FILE=$$GREF(TXIEN),ROOT=$$ROOT^DILFD(FILE,"",1)
  1.  I FILE=9002226 S FLD=".15"
  1.  I FILE=9002228 S FLD=".09"
  1.  S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
  1.  I FNBR=80 S ID="DIAGNOSES",CAT="Diagnoses" Q
  1.  I FNBR=81 S ID="CPTS",CAT="CPT Procedures" Q
  1.  I FNBR=80.1 S ID="PROCEDURES",CAT="ICD Procedures" Q
  1.  I FNBR=60!(FNBR=95.3) S ID="LAB TESTS",CAT="Lab Tests" Q
  1.  I FNBR=50!(FNBR=50.57)!(FNBR=50.67) S ID="MEDICATIONS",CAT="Medications" Q
  1.  I FNBR=9999999.05 S ID="COMMUNITIES",CAT="Communities" Q
  1.  S ID="OTHERS",CAT="Other"
  1.  Q
  1.  ;
  1. INCP(IIEN) ;EP - Inactive CPT
  1.  NEW VALUE,EFF,ACT,INA
  1.  S VALUE=$$CPT^ICPTCOD(IIEN,DT)
  1.  S EFF=$P(VALUE,U,6),ACT=$P(VALUE,U,9),INA=$P(VALUE,U,8)
  1.  I ACT=EFF Q ""
  1.  I INA=EFF Q INA
  1.  ;
  1. INIC(FILE,IIEN) ;EP
  1.  I FILE=80 S ICDTMP=$$ICDDX^ICDCODE(IIEN,DT)
  1.  I FILE=80.1 S ICDTMP=$$ICDOP^ICDCODE(IIEN,DT)
  1.  I '$P(ICDTMP,U,10) Q $P(ICDTMP,U,12)
  1.  Q ""