BQITAXX5 ;GDIT/HS/ALA-Taxonomy Items ; 28 Oct 2013 9:53 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
ITM(DATA,IVALUE) ; EP -- BQI GET TAXONOMY ITEMS
;
; Input
; IVALUE - Internal entry number of taxonomy in structure, IEN;FILE REF
; because this is a variable pointer value
;
NEW UID,II,FNAME,FNBR,ROOT,FILE,IEN,FLD,VIEN,FDESC,LIEN,HIEN,BQIH,BQIJ,X,TTXT
NEW TEXT,HIGH,LOW,DTCRT,DTMOD,ALL,NOREC
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITXITM",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S IVALUE=$G(IVALUE,"")
S ALL=(IVALUE="")
;
I IVALUE="" D
. S BQIH=$$SPM^BQIGPUTL()
. ;S II=II+1
. D HDR
. S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^"_HDR_$C(30)
. S BQIJ=0
. F S BQIJ=$O(^BQI(90508,BQIH,10,BQIJ)) Q:'BQIJ D
.. NEW DA,IENS,IVALUE,TTXT,TEXT,ID,CAT
.. S IVALUE=$P(^BQI(90508,BQIH,10,BQIJ,0),U,2) Q:IVALUE=""
.. S DA(1)=BQIH,DA=BQIJ,IENS=$$IENS^DILF(.DA)
.. S TTXT=$$GET1^DIQ(90508.03,IENS,.01,"E"),TIEN=$$GET1^DIQ(90508.03,IENS,.02,"I")
.. D FCAT(TIEN)
.. S TEXT=TTXT_"^"_TIEN_"^"_ID
.. S TEXT=TEXT_"^"_$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_CAT
.. 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")_"^"
.. D GET
;
I IVALUE'="" D
. D HDR S @DATA@(II)=HDR_$C(30)
. S TEXT=""
. I IVALUE'["BSTS" D GET Q
. NEW BQILIST,BQISUB,OK,CODE,DESC,TSYS,FNAME,FNBR,FDESC,LIEN
. S BQILIST=$NA(^TMP("BQISNSB",$J)) K @BQILIST
. S BQISUB=$P(IVALUE,";",1)
. S OK=$$SUBLST^BSTSAPI(BQILIST,BQISUB_"^36^1")
. S BQSN=0
. F S BQSN=$O(@BQILIST@(BQSN)) Q:BQSN="" D
.. S CODE=$P(@BQILIST@(BQSN),"^",1),DESC=$P(@BQILIST@(BQSN),"^",3),TSYS="SNOMED CT US Extension"
.. S FNAME="BSTS CONCEPT",FNBR="9002318.4",FDESC=BQISUB,DTCRT="",DTMOD=""
.. S LIEN=$O(^BSTS(9002318.4,"C",36,CODE,""))
.. S II=II+1
.. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$C(30)
. K @BQILIST
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
GET ;
NEW TSYS,DESC,CODE,INAC
S IEN=$P(IVALUE,";",1),FILE=$$GREF(IVALUE),ROOT=$$ROOT^DILFD(FILE,"",1)
I FILE=9002226 S FLD=".15"
I FILE=9002228 S FLD=".09"
S FNAME=$$GET1^DIQ(FILE,IEN,FLD,"E")
S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
S FDESC=$$GET1^DIQ(FILE,IEN,.02,"E")
S TAX=$$GET1^DIQ(FILE,IEN,.01,"E")
;
I FILE=9002226 S DTCRT=$$GET1^DIQ(FILE,IEN,.09,"I"),DTMOD=""
I FILE=9002228 S DTMOD=$$GET1^DIQ(FILE,IEN,.06,"I"),DTCRT=""
;
S VIEN=0
; If there aren't any items (For complete listing only)
I '$O(@ROOT@(IEN,21,VIEN)) D:$G(ALL) Q
. S II=II+1
. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^^^^^^^"_$C(30)
I FNBR=80!(FNBR=80.1)!(FNBR=81) D Q
. NEW TREF
. S TREF=$NA(^TMP("BQITAX",$J)) K @TREF
. D BLD^BQITUTL(TAX,.TREF)
. NEW DESC,TSYS,CODE,INAC
. S LIEN=0
. F S LIEN=$O(@TREF@(LIEN)) Q:'LIEN D
.. S CODE=$P(@TREF@(LIEN),"^",1),TSYS=$P(@TREF@(LIEN),"^",4),II=II+1
.. I FNBR=80 D
... S DESC=$$ICD9^BQIUL3(LIEN,,4),INAC=$$INIC(FNBR,LIEN)
... I INAC="",$$CSI^ICDEX(80,LIEN)=1 S INAC=3150930
.. I FNBR=80.1 D
... S DESC=$$ICD0^BQIUL3(LIEN,,5),INAC=$$INIC(FNBR,LIEN)
... I INAC="",$$CSI^ICDEX(80.1,LIEN)=2 S INAC=3150930
.. I FNBR=81 S DESC=$P($$CPT^ICPTCOD(LIEN,,3),U,3),TSYS="CPT",INAC=$$INCP(LIEN)
.. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$$FMTE^BQIUL1(INAC)_$C(30)
. K @TREF
I FILE=9002228 D Q
. S TREF=$NA(^TMP(UID,"BQITAX")) K @TREF
. D BLD^BQITUTL(TAX,.TREF,"L")
. S LIEN=""
. F S LIEN=$O(@TREF@(LIEN)) Q:LIEN="" D
.. S II=II+1,DESC=$P(@TREF@(LIEN),U,1)
.. S VIEN=$O(^ATXLAB(IEN,21,"B",LIEN,""))
.. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$G(LIEN)_"^"_$G(LOW)_"^"_$G(DESC)_"^"_$G(TSYS)_"^"_$C(30)
; If there are items
F S VIEN=$O(@ROOT@(IEN,21,VIEN)) Q:'VIEN D
. S II=II+1,NOREC=0
. NEW DA,IENS
. S DA(1)=IEN,DA=VIEN,IENS=$$IENS^DILF(.DA)
. S LOW=$$GET1^DIQ(FILE_".02101",IENS,.01,"E")
. S LIEN=$$GET1^DIQ(FILE_".02101",IENS,.01,"I")
. I LOW'="" D
.. I LIEN=LOW D
... S LIEN=$$FIND1^DIC(FNBR,,"MP",LOW)
... S:LIEN<1 LIEN=LOW
. S HIGH=$$GET1^DIQ(FILE_".02101",IENS,.02,"E")
. S HIEN=$$GET1^DIQ(FILE_".02101",IENS,.02,"I")
. I HIGH="" S HIEN=""
. I HIGH'="" D
.. I HIEN=HIGH D
... S HIEN=$$FIND1^DIC(FNBR,,"MP",HIGH)
... S:HIEN<1 HIEN=HIGH
. I FNBR=50.67!(TAX[" NDC") D
.. ;NEW NDC
.. S LIEN=$O(^PSDRUG("D",LOW,"")),DESC="",TSYS="NDC"
.. I FNAME="" S FNAME="DRUG"
.. I FNBR="" S FNBR=50
.. I LIEN'="" S DESC=$P(^PSDRUG(LIEN,0),U,1)
. I FNBR=95.3 D
.. NEW LNC
.. S LNC=$P(LOW,"-",1),LIEN=$O(^LAB(60,"AF",LNC,"")),DESC="",TSYS="LOINC"
.. I LIEN'="" S DESC=$P(^LAB(60,LIEN,0),U,1)
. I FNBR=9999999.14!(FDESC["CVX") S NOREC=0 D
.. NEW CVXLN,CVXHN
.. S CVXLN=$O(^AUTTIMM("C",LOW,"")),DESC=""
.. I CVXLN="" S NOREC=1 Q
.. S DESC=$P(^AUTTIMM(CVXLN,0),U,1)
. I FNBR'=9999999.31,LOW?.N D
.. I NOREC Q
.. I FNBR["50."!(TAX[" NDC")!(FNBR=9999999.14)!(TAX[" CVX") Q
.. S DESC=$$GET1^DIQ(FNBR,LOW_",",.01,"E")
.. I FNBR=50 S LIEN=LOW,LOW=""
. I FNBR'=9999999.31,LOW'?.N D
.. I NOREC Q
.. I FNBR["50."!(FNBR=95.3)!(TAX[" NDC") Q
.. S DESC=LOW,LOW="",LIEN=""
. I FNBR=9999999.31 D
.. I NOREC Q
.. S TSYS="ADA",DESC="",LOW=$P(^AUTTADA(LIEN,0),"^",1)
.. I LIEN="" S NOREC=1 Q
.. S DESC=$P(^AUTTADA(LIEN,0),"^",2)
. ;
. I NOREC Q
. I FNBR'=50 D
.. I LOW="",LIEN'="" S LOW=LIEN,LIEN=""
.. I HIGH="",HIEN'="" S HIGH=HIEN,HIEN=""
. ;S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_VIEN_"^"_LOW_"^"_LIEN_"^"_HIGH_"^"_HIEN_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_$C(30)
. S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$G(LIEN)_"^"_$G(LOW)_"^"_$G(DESC)_"^"_$G(TSYS)_$C(30)
Q
;
ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
;
;Input
; TAXV - Taxonomy internal entry number
;
NEW IEN,GLOBAL
I TAXV="" Q 0
S IEN=$P(TAXV,";",1),GLOBAL="^"_$P(TAXV,";",2)_IEN_")"
I $O(@GLOBAL@(21,0))'="" Q 1
Q 0
;
GREF(VAL) ; EP - Returns the file number
NEW GL,FILN
S GL="^"_$P(VAL,";",2)_"0)"
S FILN=$P($G(@GL),U,2)
S FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q FILN
;
HDR ; EP - Header
S HDR="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^D00015DATE_CREATED^D00015DATE_MODIFIED^I00010TVAL_IEN^"
S HDR=HDR_"I00010IVAL_IEN^T00020IVAL_CODE^T00060IVAL_DESC^T00015IVAL_TSYS^D00015INACTIVE"
;S @DATA@(II)="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
;S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030FILE_NAME^"
;S @DATA@(II)=@DATA@(II)_"I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
Q
;
FCAT(TXIEN) ;EP
NEW IEN,FILE,ROOT,FLD,FNBR
S IEN=$P(TXIEN,";",1),FILE=$$GREF(TXIEN),ROOT=$$ROOT^DILFD(FILE,"",1)
I FILE=9002226 S FLD=".15"
I FILE=9002228 S FLD=".09"
S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
I FNBR=80 S ID="DIAGNOSES",CAT="Diagnoses" Q
I FNBR=81 S ID="CPTS",CAT="CPT Procedures" Q
I FNBR=80.1 S ID="PROCEDURES",CAT="ICD Procedures" Q
I FNBR=60!(FNBR=95.3) S ID="LAB TESTS",CAT="Lab Tests" Q
I FNBR=50!(FNBR=50.57)!(FNBR=50.67) S ID="MEDICATIONS",CAT="Medications" Q
I FNBR=9999999.05 S ID="COMMUNITIES",CAT="Communities" Q
S ID="OTHERS",CAT="Other"
Q
;
INCP(IIEN) ;EP - Inactive CPT
NEW VALUE,EFF,ACT,INA
S VALUE=$$CPT^ICPTCOD(IIEN,DT)
S EFF=$P(VALUE,U,6),ACT=$P(VALUE,U,9),INA=$P(VALUE,U,8)
I ACT=EFF Q ""
I INA=EFF Q INA
;
INIC(FILE,IIEN) ;EP
I FILE=80 S ICDTMP=$$ICDDX^ICDCODE(IIEN,DT)
I FILE=80.1 S ICDTMP=$$ICDOP^ICDCODE(IIEN,DT)
I '$P(ICDTMP,U,10) Q $P(ICDTMP,U,12)
Q ""
BQITAXX5 ;GDIT/HS/ALA-Taxonomy Items ; 28 Oct 2013 9:53 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
ITM(DATA,IVALUE) ; EP -- BQI GET TAXONOMY ITEMS
+1 ;
+2 ; Input
+3 ; IVALUE - Internal entry number of taxonomy in structure, IEN;FILE REF
+4 ; because this is a variable pointer value
+5 ;
+6 NEW UID,II,FNAME,FNBR,ROOT,FILE,IEN,FLD,VIEN,FDESC,LIEN,HIEN,BQIH,BQIJ,X,TTXT
+7 NEW TEXT,HIGH,LOW,DTCRT,DTMOD,ALL,NOREC
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("BQITXITM",UID))
+10 KILL @DATA
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER"
+14 ;
+15 SET IVALUE=$GET(IVALUE,"")
+16 SET ALL=(IVALUE="")
+17 ;
+18 IF IVALUE=""
Begin DoDot:1
+19 SET BQIH=$$SPM^BQIGPUTL()
+20 ;S II=II+1
+21 DO HDR
+22 SET @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^"_HDR_$CHAR(30)
+23 SET BQIJ=0
+24 FOR
SET BQIJ=$ORDER(^BQI(90508,BQIH,10,BQIJ))
IF 'BQIJ
QUIT
Begin DoDot:2
+25 NEW DA,IENS,IVALUE,TTXT,TEXT,ID,CAT
+26 SET IVALUE=$PIECE(^BQI(90508,BQIH,10,BQIJ,0),U,2)
IF IVALUE=""
QUIT
+27 SET DA(1)=BQIH
SET DA=BQIJ
SET IENS=$$IENS^DILF(.DA)
+28 SET TTXT=$$GET1^DIQ(90508.03,IENS,.01,"E")
SET TIEN=$$GET1^DIQ(90508.03,IENS,.02,"I")
+29 DO FCAT(TIEN)
+30 SET TEXT=TTXT_"^"_TIEN_"^"_ID
+31 SET TEXT=TEXT_"^"_$SELECT($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_CAT
+32 SET TEXT=TEXT_"^"_$SELECT($$GET1^DIQ(90508.03,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90508.03,IENS,.07,"I")=1:"YES",'$$ENTRS(IVALUE):"NO",1:"YES")_"^"
+33 DO GET
End DoDot:2
End DoDot:1
+34 ;
+35 IF IVALUE'=""
Begin DoDot:1
+36 DO HDR
SET @DATA@(II)=HDR_$CHAR(30)
+37 SET TEXT=""
+38 IF IVALUE'["BSTS"
DO GET
QUIT
+39 NEW BQILIST,BQISUB,OK,CODE,DESC,TSYS,FNAME,FNBR,FDESC,LIEN
+40 SET BQILIST=$NAME(^TMP("BQISNSB",$JOB))
KILL @BQILIST
+41 SET BQISUB=$PIECE(IVALUE,";",1)
+42 SET OK=$$SUBLST^BSTSAPI(BQILIST,BQISUB_"^36^1")
+43 SET BQSN=0
+44 FOR
SET BQSN=$ORDER(@BQILIST@(BQSN))
IF BQSN=""
QUIT
Begin DoDot:2
+45 SET CODE=$PIECE(@BQILIST@(BQSN),"^",1)
SET DESC=$PIECE(@BQILIST@(BQSN),"^",3)
SET TSYS="SNOMED CT US Extension"
+46 SET FNAME="BSTS CONCEPT"
SET FNBR="9002318.4"
SET FDESC=BQISUB
SET DTCRT=""
SET DTMOD=""
+47 SET LIEN=$ORDER(^BSTS(9002318.4,"C",36,CODE,""))
+48 SET II=II+1
+49 SET @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$CHAR(30)
End DoDot:2
+50 KILL @BQILIST
End DoDot:1
+51 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
GET ;
+1 NEW TSYS,DESC,CODE,INAC
+2 SET IEN=$PIECE(IVALUE,";",1)
SET FILE=$$GREF(IVALUE)
SET ROOT=$$ROOT^DILFD(FILE,"",1)
+3 IF FILE=9002226
SET FLD=".15"
+4 IF FILE=9002228
SET FLD=".09"
+5 SET FNAME=$$GET1^DIQ(FILE,IEN,FLD,"E")
+6 SET FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
+7 SET FDESC=$$GET1^DIQ(FILE,IEN,.02,"E")
+8 SET TAX=$$GET1^DIQ(FILE,IEN,.01,"E")
+9 ;
+10 IF FILE=9002226
SET DTCRT=$$GET1^DIQ(FILE,IEN,.09,"I")
SET DTMOD=""
+11 IF FILE=9002228
SET DTMOD=$$GET1^DIQ(FILE,IEN,.06,"I")
SET DTCRT=""
+12 ;
+13 SET VIEN=0
+14 ; If there aren't any items (For complete listing only)
+15 IF '$ORDER(@ROOT@(IEN,21,VIEN))
IF $GET(ALL)
Begin DoDot:1
+16 SET II=II+1
+17 SET @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^^^^^^^"_$CHAR(30)
End DoDot:1
QUIT
+18 IF FNBR=80!(FNBR=80.1)!(FNBR=81)
Begin DoDot:1
+19 NEW TREF
+20 SET TREF=$NAME(^TMP("BQITAX",$JOB))
KILL @TREF
+21 DO BLD^BQITUTL(TAX,.TREF)
+22 NEW DESC,TSYS,CODE,INAC
+23 SET LIEN=0
+24 FOR
SET LIEN=$ORDER(@TREF@(LIEN))
IF 'LIEN
QUIT
Begin DoDot:2
+25 SET CODE=$PIECE(@TREF@(LIEN),"^",1)
SET TSYS=$PIECE(@TREF@(LIEN),"^",4)
SET II=II+1
+26 IF FNBR=80
Begin DoDot:3
+27 SET DESC=$$ICD9^BQIUL3(LIEN,,4)
SET INAC=$$INIC(FNBR,LIEN)
+28 IF INAC=""
IF $$CSI^ICDEX(80,LIEN)=1
SET INAC=3150930
End DoDot:3
+29 IF FNBR=80.1
Begin DoDot:3
+30 SET DESC=$$ICD0^BQIUL3(LIEN,,5)
SET INAC=$$INIC(FNBR,LIEN)
+31 IF INAC=""
IF $$CSI^ICDEX(80.1,LIEN)=2
SET INAC=3150930
End DoDot:3
+32 IF FNBR=81
SET DESC=$PIECE($$CPT^ICPTCOD(LIEN,,3),U,3)
SET TSYS="CPT"
SET INAC=$$INCP(LIEN)
+33 SET @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^^"_LIEN_"^"_CODE_"^"_DESC_"^"_TSYS_"^"_$$FMTE^BQIUL1(INAC)_$CHAR(30)
End DoDot:2
+34 KILL @TREF
End DoDot:1
QUIT
+35 IF FILE=9002228
Begin DoDot:1
+36 SET TREF=$NAME(^TMP(UID,"BQITAX"))
KILL @TREF
+37 DO BLD^BQITUTL(TAX,.TREF,"L")
+38 SET LIEN=""
+39 FOR
SET LIEN=$ORDER(@TREF@(LIEN))
IF LIEN=""
QUIT
Begin DoDot:2
+40 SET II=II+1
SET DESC=$PIECE(@TREF@(LIEN),U,1)
+41 SET VIEN=$ORDER(^ATXLAB(IEN,21,"B",LIEN,""))
+42 SET @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(LIEN)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(LOW)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(DESC)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(TSYS)_"^"_$CHAR(30)
End DoDot:2
End DoDot:1
QUIT
+43 ; If there are items
+44 FOR
SET VIEN=$ORDER(@ROOT@(IEN,21,VIEN))
IF 'VIEN
QUIT
Begin DoDot:1
+45 SET II=II+1
SET NOREC=0
+46 NEW DA,IENS
+47 SET DA(1)=IEN
SET DA=VIEN
SET IENS=$$IENS^DILF(.DA)
+48 SET LOW=$$GET1^DIQ(FILE_".02101",IENS,.01,"E")
+49 SET LIEN=$$GET1^DIQ(FILE_".02101",IENS,.01,"I")
+50 IF LOW'=""
Begin DoDot:2
+51 IF LIEN=LOW
Begin DoDot:3
+52 SET LIEN=$$FIND1^DIC(FNBR,,"MP",LOW)
+53 IF LIEN<1
SET LIEN=LOW
End DoDot:3
End DoDot:2
+54 SET HIGH=$$GET1^DIQ(FILE_".02101",IENS,.02,"E")
+55 SET HIEN=$$GET1^DIQ(FILE_".02101",IENS,.02,"I")
+56 IF HIGH=""
SET HIEN=""
+57 IF HIGH'=""
Begin DoDot:2
+58 IF HIEN=HIGH
Begin DoDot:3
+59 SET HIEN=$$FIND1^DIC(FNBR,,"MP",HIGH)
+60 IF HIEN<1
SET HIEN=HIGH
End DoDot:3
End DoDot:2
+61 IF FNBR=50.67!(TAX[" NDC")
Begin DoDot:2
+62 ;NEW NDC
+63 SET LIEN=$ORDER(^PSDRUG("D",LOW,""))
SET DESC=""
SET TSYS="NDC"
+64 IF FNAME=""
SET FNAME="DRUG"
+65 IF FNBR=""
SET FNBR=50
+66 IF LIEN'=""
SET DESC=$PIECE(^PSDRUG(LIEN,0),U,1)
End DoDot:2
+67 IF FNBR=95.3
Begin DoDot:2
+68 NEW LNC
+69 SET LNC=$PIECE(LOW,"-",1)
SET LIEN=$ORDER(^LAB(60,"AF",LNC,""))
SET DESC=""
SET TSYS="LOINC"
+70 IF LIEN'=""
SET DESC=$PIECE(^LAB(60,LIEN,0),U,1)
End DoDot:2
+71 IF FNBR=9999999.14!(FDESC["CVX")
SET NOREC=0
Begin DoDot:2
+72 NEW CVXLN,CVXHN
+73 SET CVXLN=$ORDER(^AUTTIMM("C",LOW,""))
SET DESC=""
+74 IF CVXLN=""
SET NOREC=1
QUIT
+75 SET DESC=$PIECE(^AUTTIMM(CVXLN,0),U,1)
End DoDot:2
+76 IF FNBR'=9999999.31
IF LOW?.N
Begin DoDot:2
+77 IF NOREC
QUIT
+78 IF FNBR["50."!(TAX[" NDC")!(FNBR=9999999.14)!(TAX[" CVX")
QUIT
+79 SET DESC=$$GET1^DIQ(FNBR,LOW_",",.01,"E")
+80 IF FNBR=50
SET LIEN=LOW
SET LOW=""
End DoDot:2
+81 IF FNBR'=9999999.31
IF LOW'?.N
Begin DoDot:2
+82 IF NOREC
QUIT
+83 IF FNBR["50."!(FNBR=95.3)!(TAX[" NDC")
QUIT
+84 SET DESC=LOW
SET LOW=""
SET LIEN=""
End DoDot:2
+85 IF FNBR=9999999.31
Begin DoDot:2
+86 IF NOREC
QUIT
+87 SET TSYS="ADA"
SET DESC=""
SET LOW=$PIECE(^AUTTADA(LIEN,0),"^",1)
+88 IF LIEN=""
SET NOREC=1
QUIT
+89 SET DESC=$PIECE(^AUTTADA(LIEN,0),"^",2)
End DoDot:2
+90 ;
+91 IF NOREC
QUIT
+92 IF FNBR'=50
Begin DoDot:2
+93 IF LOW=""
IF LIEN'=""
SET LOW=LIEN
SET LIEN=""
+94 IF HIGH=""
IF HIEN'=""
SET HIGH=HIEN
SET HIEN=""
End DoDot:2
+95 ;S @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_VIEN_"^"_LOW_"^"_LIEN_"^"_HIGH_"^"_HIEN_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_$C(30)
+96 SET @DATA@(II)=TEXT_FNAME_"^"_FNBR_"^"_FDESC_"^"_$$FMTE^BQIUL1(DTCRT)_"^"_$$FMTE^BQIUL1(DTMOD)_"^"_VIEN_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(LIEN)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(LOW)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(DESC)_"^"_$GET">GET">GET">GET">GET">GET">GET">GET(TSYS)_$CHAR(30)
End DoDot:1
+97 QUIT
+98 ;
ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
+1 ;
+2 ;Input
+3 ; TAXV - Taxonomy internal entry number
+4 ;
+5 NEW IEN,GLOBAL
+6 IF TAXV=""
QUIT 0
+7 SET IEN=$PIECE(TAXV,";",1)
SET GLOBAL="^"_$PIECE(TAXV,";",2)_IEN_")"
+8 IF $ORDER(@GLOBAL@(21,0))'=""
QUIT 1
+9 QUIT 0
+10 ;
GREF(VAL) ; EP - Returns the file number
+1 NEW GL,FILN
+2 SET GL="^"_$PIECE(VAL,";",2)_"0)"
+3 SET FILN=$PIECE($GET(@GL),U,2)
+4 SET FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+5 QUIT FILN
+6 ;
HDR ; EP - Header
+1 SET HDR="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^D00015DATE_CREATED^D00015DATE_MODIFIED^I00010TVAL_IEN^"
+2 SET HDR=HDR_"I00010IVAL_IEN^T00020IVAL_CODE^T00060IVAL_DESC^T00015IVAL_TSYS^D00015INACTIVE"
+3 ;S @DATA@(II)="T00030FILE_NAME^I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
+4 ;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
+5 ;S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030FILE_NAME^"
+6 ;S @DATA@(II)=@DATA@(II)_"I00010FILE_NBR^T00050TAX_DESC^I00010TVAL_IEN^T00063LOW_VALUE^I00010LOW_IEN^T00063HIGH_VALUE^I00010HIGH_IEN^"
+7 ;S @DATA@(II)=@DATA@(II)_"D00015DATE_CREATED^D00015DATE_MODIFIED"_$C(30)
+8 QUIT
+9 ;
FCAT(TXIEN) ;EP
+1 NEW IEN,FILE,ROOT,FLD,FNBR
+2 SET IEN=$PIECE(TXIEN,";",1)
SET FILE=$$GREF(TXIEN)
SET ROOT=$$ROOT^DILFD(FILE,"",1)
+3 IF FILE=9002226
SET FLD=".15"
+4 IF FILE=9002228
SET FLD=".09"
+5 SET FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
+6 IF FNBR=80
SET ID="DIAGNOSES"
SET CAT="Diagnoses"
QUIT
+7 IF FNBR=81
SET ID="CPTS"
SET CAT="CPT Procedures"
QUIT
+8 IF FNBR=80.1
SET ID="PROCEDURES"
SET CAT="ICD Procedures"
QUIT
+9 IF FNBR=60!(FNBR=95.3)
SET ID="LAB TESTS"
SET CAT="Lab Tests"
QUIT
+10 IF FNBR=50!(FNBR=50.57)!(FNBR=50.67)
SET ID="MEDICATIONS"
SET CAT="Medications"
QUIT
+11 IF FNBR=9999999.05
SET ID="COMMUNITIES"
SET CAT="Communities"
QUIT
+12 SET ID="OTHERS"
SET CAT="Other"
+13 QUIT
+14 ;
INCP(IIEN) ;EP - Inactive CPT
+1 NEW VALUE,EFF,ACT,INA
+2 SET VALUE=$$CPT^ICPTCOD(IIEN,DT)
+3 SET EFF=$PIECE(VALUE,U,6)
SET ACT=$PIECE(VALUE,U,9)
SET INA=$PIECE(VALUE,U,8)
+4 IF ACT=EFF
QUIT ""
+5 IF INA=EFF
QUIT INA
+6 ;
INIC(FILE,IIEN) ;EP
+1 IF FILE=80
SET ICDTMP=$$ICDDX^ICDCODE(IIEN,DT)
+2 IF FILE=80.1
SET ICDTMP=$$ICDOP^ICDCODE(IIEN,DT)
+3 IF '$PIECE(ICDTMP,U,10)
QUIT $PIECE(ICDTMP,U,12)
+4 QUIT ""
