ATXAPI ;GDIT/HS/ALA-Taxonomy APIs ; 13 Feb 2012 12:02 PM
;;5.1;TAXONOMY;**11,13**;FEB 4, 1997;Build 13
;
BLDSV(FILEREF,VAL,TARGET) ;PEP - Add a single value to a target
;Description
; Use this if no taxonomy was given but an individual code
;Input
; FILEREF - File where the code resides
; VAL - Value
; TARGET - reference where entry is to be placed
;
; The LOINC x-ref in LAB does not use the check digit (piece 2).
NEW INDEX,VAL,FILE,IEN,END,NAME
I FILEREF=95.3 S FILE="^LAB(60)",INDEX="AF",VAL=$P(VAL,"-")
I FILEREF=80 S FILE="^ICD9",INDEX="BA"
I FILEREF=80.1 S FILE="^ICD0",INDEX="BA"
I FILEREF=81 S FILE="^ICPT",INDEX="BA"
S END=VAL
;
; Backup one entry so loop can find all the entries in the range.
S VAL=$O(@FILE@(INDEX,VAL),-1)
F S VAL=$O(@FILE@(INDEX,VAL)) Q:VAL="" Q:$$CHECK(VAL,END) D
.S IEN=""
.F S IEN=$O(@FILE@(INDEX,VAL,IEN)) Q:IEN="" D
..S NAME=$P($G(@FILE@(IEN,0)),U,1)
..S @TARGET@(IEN)=NAME
;
K FILEREF,FILE,INDEX,VAL,END,NAME,IEN,TARGET
Q
;
CHECK(V,E) ;EP
N Z
I V=E Q 0
S Z(V)=""
S Z(E)=""
I $O(Z(""))=E Q 1
Q 0
;
BLDTAX(TAX,TARGET,TAXIEN,TAXTYP) ; PEP - Expand a taxonomy into a target
;
; Takes a taxonomy name and builds an array that can then be used
; to scan various V-File cross-references to see which records
; match an entry in the Taxonomy.
;
; Currently supported Taxonomies are as follows:
; (where FILE is field #.15 in the TAXONOMY file #9002226)
; ICD9 Diagnoses via ICD9 codes (^ICD9 - FILE 80)
; ICD9 Procedures via ICD9 codes (^ICD0 - FILE 80.1)
; CPT Procedures via CPT codes (^ICPT - FILE 81)
; Medications via NDC codes (^PSDRUG - FILE 2)
; Medications via MED IEN (^PSDRUG - FILE 50)
; Laboratory tests via LOINC codes (^LAB(60) - FILE 95.3)
; Patient Education Topics by name (^AUTTEDT - FILE 9999999.09)
; NOTE: Use BLDTAX1 below if providing a list of partial Patient Education Topic Codes to match.
; Immunizations via HL7/CVX codes (^AUTTIMM - FILE 9999999.14)
; Health Factors by Name (^AUTTHF - FILE 9999999.64)
; (where FILE is field #.09 in the LAB TAXONOMY file #9002228)
; Laboratory tests via LAB IEN (^LAB(60) - FILE 60)
; VA Drug Class (^PS(50.605 - FILE 50.605)
; Community (^AUTTCOM - FILE 9999999.05)
; Clinics (^DIC(40.7 - FILE 40.7)
; Dental ADA codes (^AUTTDA - FILE 9999999.31)
;
; Input:
; TAX = Name of Taxonomy from ATXAX or ATXLAB file.
; (required)
; TARGET = Closed array reference where the output will be stored.
; (required)
; This can be a local variable or global reference.
; (Ex. TARGET="ARRAY" or TARGET="^TMP($J)"
; TAXIEN = IEN of Taxonomy from ATXAX or ATXLAB file.
; TAXTYP = 'L' for lab, assumes ATXAX
;
; Output:
; An array in the local or global TARGET of the form:
; @TARGET@(IEN)=NAME (.01 field)
;
; NOTE: Kill the output array before calling the function unless
; you intend to group several Taxonomies of the same type.
;
N FILEREF,TAXREF,ENTRY,VALUE,VAL,END,FILE,INDEX,IEN,NAME,SYS,SYSN,SYSNM
N QFL,ATXNCAN
;
I $G(TARGET)=""!($G(TAX)="") Q
S TAXTYP=$G(TAXTYP,"")
;
I $G(TAXIEN)'="" D
. I $G(TAXTYP)="L" S TAXREF="^ATXLAB" Q
. S TAXREF="^ATXAX"
. I $P($G(@TAXREF@(TAXIEN,0)),U,1)'=TAX S TAXTYP="L",TAXREF="^ATXLAB"
;
I $G(TAXIEN)="" D
. I $G(TAXTYP)="L" S TAXIEN=$O(^ATXLAB("B",TAX,0)),TAXREF="^ATXLAB" Q
. S TAXIEN=$O(^ATXAX("B",TAX,0)),TAXREF="^ATXAX"
;
I TAXIEN="" Q
;
I TAXREF="^ATXAX" S FILEREF=$$GET1^DIQ(9002226,TAXIEN,.15,"I"),ATXNCAN=$$GET1^DIQ(9002226,TAXIEN,.13,"I")
I TAXREF="^ATXLAB" S FILEREF=$$GET1^DIQ(9002228,TAXIEN,.09,"I")
; The following file references from Taxonomy are supported:
;I $F(",40.7,80,80.1,81,50.67,50,95.3,9999999.09,9999999.14,9999999.64,60,50.605,9999999.05,",","_FILEREF_",")=0 Q
I '$D(^ATXTYPE("C",FILEREF)) Q
S ENTRY=0
F S ENTRY=$O(@TAXREF@(TAXIEN,21,ENTRY)) Q:'ENTRY D
.S VALUE=@TAXREF@(TAXIEN,21,ENTRY,0)
.S VAL=$P(VALUE,U,1),END=$P(VALUE,U,2),SYS=$P(VALUE,U,3)
.I FILEREF=80 D
..S SYSN=$S(SYS'="":SYS,1:1)
..S SYS=$S(SYS'="":$P(^ICDS(SYS,0),U,2),1:$P(^ICDS(1,0),U,2))
..S SYSNM=$P(^ICDS(SYSN,0),U,1)
.I FILEREF=80.1 D
..S SYSN=$S(SYS'="":SYS,1:2)
..S SYS=$S(SYS'="":$P(^ICDS(SYS,0),U,2),1:$P(^ICDS(2,0),U,2))
..S SYSNM=$P(^ICDS(SYSN,0),U,1)
.I +$G(ATXNCAN)=0 S QFL=1 D Q:QFL
..I FILEREF'=9999999.06,FILEREF'=9999999.09 S QFL=0 Q
..;I FILEREF=9999999.05 S QFL=0 Q
..;I FILEREF=9999999.64 S QFL=0 Q
..S FILE=$$ROOT^DILFD(FILEREF,"",1)
..I $E(VAL,$L(VAL))=" " S VAL=$E(VAL,1,$L(VAL)-1)
..I $E(END,$L(END))=" " S END=$E(END,1,$L(END)-1)
..I FILEREF=9999999.06 S NAME=$P($G(^DIC(4,VAL,0)),U,1),@TARGET@(VAL)=NAME Q
..I FILEREF=9999999.09,VAL'?.N S QFL=0 Q
..S NAME=$P($G(@FILE@(VAL,0)),U,1),@TARGET@(VAL)=NAME
.D SRCH(FILEREF)
Q
;
BLDEDU(TAX,TARGET) ;PEP - EDUCATION
;
; Takes a list of partial Patient Education topic names and
; builds an array that can then be used to scan a V-File
; cross-reference to see which records match an entry in the
; list.
;
; This tag only supports Patient Education:
; (where FILE is field #.15 in the TAXONOMY file #9002226)
; Patient Education Topic Codes (^AUTTEDT - FILE 9999999.09)
;
; Input:
; TAX = PATIENT EDUCATION TOPIC CODE LIST to search for
; (required)
;
; Example: "CD-,-CD,AOD-,-AOD"
; Example: "*BGP HIV/AIDS DXS"
;
; Returns items where the MNEMONIC field for the Patient
; Education entry contains one of the listed values.
;
; Second example shows an ICD taxonomy name.
; If used, will search for any Patient Education entry
; containing one of the values in that Taxonomy.
;
; TARGET : Closed array reference where the output will be stored.
; This can be a local variable or global reference.
; (Ex. TARGET="ARRAY" or TARGET="^TMP($J)"
;
; Output:
; An array in the local or global TARGET of the form:
; @TARGET@(IEN)=NAME (.01 field)
;
; NOTE: Kill the output array before calling the function unless
; you intend to group several Taxonomies of the same type.
;
N VAL,IEN,NAME,MNEMONIC,TAX1,I,ICDIEN,FLG
F I=1:1:$L(TAX,",") S TAX1=$P(TAX,",",I) I $E(TAX1)="*" D BLDTAX($E(TAX1,2,$L(TAX1)),"ICDIEN")
S VAL=""
F S VAL=$O(^AUTTEDT("B",VAL)) Q:VAL="" D
.S IEN=""
.F S IEN=$O(^AUTTEDT("B",VAL,IEN)) Q:IEN="" D
..S NAME=$$GET1^DIQ(9999999.09,IEN,.01,"I"),MNEMONIC=$$GET1^DIQ(9999999.09,IEN,1,"I"),FLG=0
..F I=1:1:$L(TAX,",") S TAX1=$P(TAX,",",I) I $E(TAX1)'="*",MNEMONIC[TAX1 S @TARGET@(IEN)=NAME_U_MNEMONIC,FLG=1 Q
..I FLG=1 Q
..S I=""
..;If an ICD is used as the MNEMONIC it will be formatted as "ICD-abbreviation".
..;For example, if the ICD is "042." and the patient education is 'alcohol or drugs' then the MNEMONIC would be "042.-AOD".
..F S I=$O(ICDIEN(I)) Q:I="" S TAX1=ICDIEN(I)_"-" I MNEMONIC[TAX1 S @TARGET@(IEN)=NAME_U_MNEMONIC,FLG=1 Q
..I FLG=1 Q
..Q
.Q
Q
;
ICD(TAXDX,TAX,TAXTY) ;PEP - Checks to see if ICD code is found in certain taxonomy
; Input:
; TAXDX=dx ifn
; TAX=taxonomy
; TAXTY=9 for dx or 0 for proc 1 for cpt
NEW TAXICD,TAXBEG,TAXEND,TAXFLG,TAXIEN,TAXREF,TAXARR
I TAX?.N S TAXIEN=TAX
I TAX'?.N D
. S TAXIEN=$O(^ATXAX("B",TAX,0)),TAXREF="^ATXAX"
S TAXFLG=0 I '$D(TAXDX)!'$D(TAXIEN)!'$D(TAXTY) Q TAXFLG
I (TAXDX="")!(TAXIEN="") Q TAXFLG
;I TAXTY=9 S SYS=$$CSI^ICDEX(80,TAXDX) S:SYS="" SYS=1
;I TAXTY=0 S SYS=$$CSI^ICDEX(80.1,TAXDX) S:SYS="" SYS=2
;S TAXICD=$S(TAXTY=1:$P($$CPT^ICPTCOD(TAXDX),U,2),1:$P($$ICDDX^ICDEX(SYS,TAXDX),U,2))
;IHS/CMI/LAB GDIT/ARLIS - MODIFIED TO USE AC IF IT EXISTS
S TAXARR=$NA(^ATXAX(TAXIEN,21,"AC"))
I '$D(^ATXAX(TAXIEN,21,"AC")) D BLDTAX($P(^ATXAX(TAXIEN,0),U),.TAXARR,TAXIEN)
I $D(^ATXAX(TAXIEN,21,"AC",TAXDX)) Q 1
Q TAXFLG
;
SRCH(FILEREF) ; Search for values
; LAB entries use the IEN and only specify one value.
I FILEREF=60 D Q
.S NAME=$P($G(^LAB(60,VAL,0)),U,1),@TARGET@(VAL)=NAME
; MED entries use the IEN and only specify one value.
I FILEREF=50.605 D Q
.NEW X,NVAL
.S NVAL=$O(^PS(50.605,"B",VAL,"")) Q:NVAL=""
.S X="" F S X=$O(^PSDRUG("VAC",NVAL,X)) Q:X="" D
..S NAME=$P($G(^PSDRUG(X,0)),U,1),@TARGET@(X)=NAME
I FILEREF=50 D Q
.S NAME=$P($G(^PSDRUG(VAL,0)),U,1),@TARGET@(VAL)=NAME
I FILEREF=40.7 D Q
.S NAME=$P($G(^DIC(40.7,VAL,0)),U,1),@TARGET@(VAL)=NAME
; Otherwise, treat all items as ranges (even if there is only one entry).
I END="" S END=VAL
D
.I FILEREF=95.3 D Q
..; The LOINC x-ref in LAB does not use the check digit (piece 2).
..S VAL=$P(VAL,"-"),END=$P(END,"-")
..S FILE="^LAB(60)",INDEX="AF"
.I FILEREF=50.67 S FILE="^PSDRUG",INDEX="D" Q
.I FILEREF=9999999.05 S FILE="^AUTTCOM",INDEX="B" Q
.I FILEREF=9999999.09 S FILE="^AUTTEDT",INDEX="B" Q
.I FILEREF=9999999.14 S FILE="^AUTTIMM",INDEX="C" Q
.I FILEREF=9999999.64 S FILE="^AUTTHF",INDEX="B" Q
.I FILEREF=9999999.31 S FILE="^AUTTADA",INDEX="B" Q
.; CPT, ICD9, and ICD0 require a SPACE be added to the code.
.; Some Taxonomy entries already have the space included.
.S:$E(VAL,$L(VAL))'=" " VAL=VAL_" "
.S:$E(END,$L(END))'=" " END=END_" "
.I FILEREF=80 S FILE="^ICD9",INDEX="BA" Q
.I FILEREF=80.1 S FILE="^ICD0",INDEX="BA" Q
.I FILEREF=81 S FILE="^ICPT",INDEX="BA" Q
; Backup one entry so loop can find all the entries in the range.
S VAL=$O(@FILE@(INDEX,VAL),-1)
F S VAL=$O(@FILE@(INDEX,VAL)) Q:VAL="" Q:$$CHECK(VAL,END) D
.S IEN=""
.F S IEN=$O(@FILE@(INDEX,VAL,IEN)) Q:IEN="" D
..S NAME=$P($G(@FILE@(IEN,0)),U,1)
..;Does coding system match
..I $G(SYSN),SYSN'=$P($G(@FILE@(IEN,1)),U,1) Q
..I $G(SYSN) S SYS=$P(^ICDS(SYSN,0),U,2),SYSNM=$P(^ICDS(SYSN,0),U,1)
..I $G(ORDER)'="CODE" S @TARGET@(IEN)=NAME_U_$G(SYSN)_U_$G(SYS)_U_$G(SYSNM) Q
..I $G(ORDER)="CODE" S @TARGET@(NAME_" ")=IEN_U_$G(SYSN)_U_$G(SYS)_U_$G(SYSNM)_U_NAME
Q
;
LST(SYSN,FILEREF,CODLS,ORDER,TARGET) ;PEP - LIST
; Input
; SYSN - System IEN from 80.4 (1, 2, 30 or 31)
; FILEREF - File reference
; CODLS - List of codes, can be range 250.00-250.99 or 250*
; ORDER - Format to get data back (blank returns in IEN order, "CODE" returns in CODE order)
; TARGET - Target reference
;
NEW VAL,END,LG,IEN,SYS,NAME,SYSNM,INDEX
S SYSN=$G(SYSN)
I $G(FILEREF)="" S FILEREF=$P(^ICDS(SYSN,0),U,3)
I CODLS["-" S VAL=$P(CODLS,"-",1),END=$P(CODLS,"-",2) D SRCH(FILEREF) Q
I CODLS["*" D
.S VAL=$P(CODLS,"*",1),END=VAL,LG=$L(END)
.; CPT, ICD9, and ICD0 require a SPACE be added to the code.
.; Some Taxonomy entries already have the space included.
.S:$E(VAL,$L(VAL))'=" " VAL=VAL_" "
.I FILEREF=80 S FILE="^ICD9",INDEX="BA"
.I FILEREF=80.1 S FILE="^ICD0",INDEX="BA"
.I FILEREF=81 S FILE="^ICPT",INDEX="BA"
.;
.F S VAL=$O(@FILE@(INDEX,VAL)) Q:VAL=""!($E(VAL,1,LG)'=END) D
..S IEN=""
..F S IEN=$O(@FILE@(INDEX,VAL,IEN)) Q:IEN="" D
...S NAME=$P($G(@FILE@(IEN,0)),U,1)
...;Does coding system match
...I $G(SYSN),SYSN'=$P($G(@FILE@(IEN,1)),U,1) Q
...I $G(SYSN) S SYS=$P(^ICDS(SYSN,0),U,2),SYSNM=$P(^ICDS(SYSN,0),U,1)
...I $G(ORDER)'="CODE" S @TARGET@(IEN)=NAME_U_$G(SYSN)_U_$G(SYS)_U_$G(SYSNM) Q
...I $G(ORDER)="CODE" S @TARGET@(NAME_" ")=IEN_U_$G(SYSN)_U_$G(SYS)_U_$G(SYSNM)_U_NAME
Q
ATXAPI ;GDIT/HS/ALA-Taxonomy APIs ; 13 Feb 2012 12:02 PM
+1 ;;5.1;TAXONOMY;**11,13**;FEB 4, 1997;Build 13
+2 ;
BLDSV(FILEREF,VAL,TARGET) ;PEP - Add a single value to a target
+1 ;Description
+2 ; Use this if no taxonomy was given but an individual code
+3 ;Input
+4 ; FILEREF - File where the code resides
+5 ; VAL - Value
+6 ; TARGET - reference where entry is to be placed
+7 ;
+8 ; The LOINC x-ref in LAB does not use the check digit (piece 2).
+9 NEW INDEX,VAL,FILE,IEN,END,NAME
+10 IF FILEREF=95.3
SET FILE="^LAB(60)"
SET INDEX="AF"
SET VAL=$PIECE(VAL,"-")
+11 IF FILEREF=80
SET FILE="^ICD9"
SET INDEX="BA"
+12 IF FILEREF=80.1
SET FILE="^ICD0"
SET INDEX="BA"
+13 IF FILEREF=81
SET FILE="^ICPT"
SET INDEX="BA"
+14 SET END=VAL
+15 ;
+16 ; Backup one entry so loop can find all the entries in the range.
+17 SET VAL=$ORDER(@FILE@(INDEX,VAL),-1)
+18 FOR
SET VAL=$ORDER(@FILE@(INDEX,VAL))
IF VAL=""
QUIT
IF $$CHECK(VAL,END)
QUIT
Begin DoDot:1
+19 SET IEN=""
+20 FOR
SET IEN=$ORDER(@FILE@(INDEX,VAL,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+21 SET NAME=$PIECE($GET(@FILE@(IEN,0)),U,1)
+22 SET @TARGET@(IEN)=NAME
End DoDot:2
End DoDot:1
+23 ;
+24 KILL FILEREF,FILE,INDEX,VAL,END,NAME,IEN,TARGET
+25 QUIT
+26 ;
CHECK(V,E) ;EP
+1 NEW Z
+2 IF V=E
QUIT 0
+3 SET Z(V)=""
+4 SET Z(E)=""
+5 IF $ORDER(Z(""))=E
QUIT 1
+6 QUIT 0
+7 ;
BLDTAX(TAX,TARGET,TAXIEN,TAXTYP) ; PEP - Expand a taxonomy into a target
+1 ;
+2 ; Takes a taxonomy name and builds an array that can then be used
+3 ; to scan various V-File cross-references to see which records
+4 ; match an entry in the Taxonomy.
+5 ;
+6 ; Currently supported Taxonomies are as follows:
+7 ; (where FILE is field #.15 in the TAXONOMY file #9002226)
+8 ; ICD9 Diagnoses via ICD9 codes (^ICD9 - FILE 80)
+9 ; ICD9 Procedures via ICD9 codes (^ICD0 - FILE 80.1)
+10 ; CPT Procedures via CPT codes (^ICPT - FILE 81)
+11 ; Medications via NDC codes (^PSDRUG - FILE 2)
+12 ; Medications via MED IEN (^PSDRUG - FILE 50)
+13 ; Laboratory tests via LOINC codes (^LAB(60) - FILE 95.3)
+14 ; Patient Education Topics by name (^AUTTEDT - FILE 9999999.09)
+15 ; NOTE: Use BLDTAX1 below if providing a list of partial Patient Education Topic Codes to match.
+16 ; Immunizations via HL7/CVX codes (^AUTTIMM - FILE 9999999.14)
+17 ; Health Factors by Name (^AUTTHF - FILE 9999999.64)
+18 ; (where FILE is field #.09 in the LAB TAXONOMY file #9002228)
+19 ; Laboratory tests via LAB IEN (^LAB(60) - FILE 60)
+20 ; VA Drug Class (^PS(50.605 - FILE 50.605)
+21 ; Community (^AUTTCOM - FILE 9999999.05)
+22 ; Clinics (^DIC(40.7 - FILE 40.7)
+23 ; Dental ADA codes (^AUTTDA - FILE 9999999.31)
+24 ;
+25 ; Input:
+26 ; TAX = Name of Taxonomy from ATXAX or ATXLAB file.
+27 ; (required)
+28 ; TARGET = Closed array reference where the output will be stored.
+29 ; (required)
+30 ; This can be a local variable or global reference.
+31 ; (Ex. TARGET="ARRAY" or TARGET="^TMP($J)"
+32 ; TAXIEN = IEN of Taxonomy from ATXAX or ATXLAB file.
+33 ; TAXTYP = 'L' for lab, assumes ATXAX
+34 ;
+35 ; Output:
+36 ; An array in the local or global TARGET of the form:
+37 ; @TARGET@(IEN)=NAME (.01 field)
+38 ;
+39 ; NOTE: Kill the output array before calling the function unless
+40 ; you intend to group several Taxonomies of the same type.
+41 ;
+42 NEW FILEREF,TAXREF,ENTRY,VALUE,VAL,END,FILE,INDEX,IEN,NAME,SYS,SYSN,SYSNM
+43 NEW QFL,ATXNCAN
+44 ;
+45 IF $GET(TARGET)=""!($GET(TAX)="")
QUIT
+46 SET TAXTYP=$GET(TAXTYP,"")
+47 ;
+48 IF $GET(TAXIEN)'=""
Begin DoDot:1
+49 IF $GET(TAXTYP)="L"
SET TAXREF="^ATXLAB"
QUIT
+50 SET TAXREF="^ATXAX"
+51 IF $PIECE($GET(@TAXREF@(TAXIEN,0)),U,1)'=TAX
SET TAXTYP="L"
SET TAXREF="^ATXLAB"
End DoDot:1
+52 ;
+53 IF $GET(TAXIEN)=""
Begin DoDot:1
+54 IF $GET(TAXTYP)="L"
SET TAXIEN=$ORDER(^ATXLAB("B",TAX,0))
SET TAXREF="^ATXLAB"
QUIT
+55 SET TAXIEN=$ORDER(^ATXAX("B",TAX,0))
SET TAXREF="^ATXAX"
End DoDot:1
+56 ;
+57 IF TAXIEN=""
QUIT
+58 ;
+59 IF TAXREF="^ATXAX"
SET FILEREF=$$GET1^DIQ(9002226,TAXIEN,.15,"I")
SET ATXNCAN=$$GET1^DIQ(9002226,TAXIEN,.13,"I")
+60 IF TAXREF="^ATXLAB"
SET FILEREF=$$GET1^DIQ(9002228,TAXIEN,.09,"I")
+61 ; The following file references from Taxonomy are supported:
+62 ;I $F(",40.7,80,80.1,81,50.67,50,95.3,9999999.09,9999999.14,9999999.64,60,50.605,9999999.05,",","_FILEREF_",")=0 Q
+63 IF '$DATA(^ATXTYPE("C",FILEREF))
QUIT
+64 SET ENTRY=0
+65 FOR
SET ENTRY=$ORDER(@TAXREF@(TAXIEN,21,ENTRY))
IF 'ENTRY
QUIT
Begin DoDot:1
+66 SET VALUE=@TAXREF@(TAXIEN,21,ENTRY,0)
+67 SET VAL=$PIECE(VALUE,U,1)
SET END=$PIECE(VALUE,U,2)
SET SYS=$PIECE(VALUE,U,3)
+68 IF FILEREF=80
Begin DoDot:2
+69 SET SYSN=$SELECT(SYS'="":SYS,1:1)
+70 SET SYS=$SELECT(SYS'="":$PIECE(^ICDS(SYS,0),U,2),1:$PIECE(^ICDS(1,0),U,2))
+71 SET SYSNM=$PIECE(^ICDS(SYSN,0),U,1)
End DoDot:2
+72 IF FILEREF=80.1
Begin DoDot:2
+73 SET SYSN=$SELECT(SYS'="":SYS,1:2)
+74 SET SYS=$SELECT(SYS'="":$PIECE(^ICDS(SYS,0),U,2),1:$PIECE(^ICDS(2,0),U,2))
+75 SET SYSNM=$PIECE(^ICDS(SYSN,0),U,1)
End DoDot:2
+76 IF +$GET(ATXNCAN)=0
SET QFL=1
Begin DoDot:2
+77 IF FILEREF'=9999999.06
IF FILEREF'=9999999.09
SET QFL=0
QUIT
+78 ;I FILEREF=9999999.05 S QFL=0 Q
+79 ;I FILEREF=9999999.64 S QFL=0 Q
+80 SET FILE=$$ROOT^DILFD(FILEREF,"",1)
+81 IF $EXTRACT(VAL,$LENGTH(VAL))=" "
SET VAL=$EXTRACT(VAL,1,$LENGTH(VAL)-1)
+82 IF $EXTRACT(END,$LENGTH(END))=" "
SET END=$EXTRACT(END,1,$LENGTH(END)-1)
+83 IF FILEREF=9999999.06
SET NAME=$PIECE($GET(^DIC(4,VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
QUIT
+84 IF FILEREF=9999999.09
IF VAL'?.N
SET QFL=0
QUIT
+85 SET NAME=$PIECE($GET(@FILE@(VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
End DoDot:2
IF QFL
QUIT
+86 DO SRCH(FILEREF)
End DoDot:1
+87 QUIT
+88 ;
BLDEDU(TAX,TARGET) ;PEP - EDUCATION
+1 ;
+2 ; Takes a list of partial Patient Education topic names and
+3 ; builds an array that can then be used to scan a V-File
+4 ; cross-reference to see which records match an entry in the
+5 ; list.
+6 ;
+7 ; This tag only supports Patient Education:
+8 ; (where FILE is field #.15 in the TAXONOMY file #9002226)
+9 ; Patient Education Topic Codes (^AUTTEDT - FILE 9999999.09)
+10 ;
+11 ; Input:
+12 ; TAX = PATIENT EDUCATION TOPIC CODE LIST to search for
+13 ; (required)
+14 ;
+15 ; Example: "CD-,-CD,AOD-,-AOD"
+16 ; Example: "*BGP HIV/AIDS DXS"
+17 ;
+18 ; Returns items where the MNEMONIC field for the Patient
+19 ; Education entry contains one of the listed values.
+20 ;
+21 ; Second example shows an ICD taxonomy name.
+22 ; If used, will search for any Patient Education entry
+23 ; containing one of the values in that Taxonomy.
+24 ;
+25 ; TARGET : Closed array reference where the output will be stored.
+26 ; This can be a local variable or global reference.
+27 ; (Ex. TARGET="ARRAY" or TARGET="^TMP($J)"
+28 ;
+29 ; Output:
+30 ; An array in the local or global TARGET of the form:
+31 ; @TARGET@(IEN)=NAME (.01 field)
+32 ;
+33 ; NOTE: Kill the output array before calling the function unless
+34 ; you intend to group several Taxonomies of the same type.
+35 ;
+36 NEW VAL,IEN,NAME,MNEMONIC,TAX1,I,ICDIEN,FLG
+37 FOR I=1:1:$LENGTH(TAX,",")
SET TAX1=$PIECE(TAX,",",I)
IF $EXTRACT(TAX1)="*"
DO BLDTAX($EXTRACT(TAX1,2,$LENGTH(TAX1)),"ICDIEN")
+38 SET VAL=""
+39 FOR
SET VAL=$ORDER(^AUTTEDT("B",VAL))
IF VAL=""
QUIT
Begin DoDot:1
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(^AUTTEDT("B",VAL,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+42 SET NAME=$$GET1^DIQ(9999999.09,IEN,.01,"I")
SET MNEMONIC=$$GET1^DIQ(9999999.09,IEN,1,"I")
SET FLG=0
+43 FOR I=1:1:$LENGTH(TAX,",")
SET TAX1=$PIECE(TAX,",",I)
IF $EXTRACT(TAX1)'="*"
IF MNEMONIC[TAX1
SET @TARGET@(IEN)=NAME_U_MNEMONIC
SET FLG=1
QUIT
+44 IF FLG=1
QUIT
+45 SET I=""
+46 ;If an ICD is used as the MNEMONIC it will be formatted as "ICD-abbreviation".
+47 ;For example, if the ICD is "042." and the patient education is 'alcohol or drugs' then the MNEMONIC would be "042.-AOD".
+48 FOR
SET I=$ORDER(ICDIEN(I))
IF I=""
QUIT
SET TAX1=ICDIEN(I)_"-"
IF MNEMONIC[TAX1
SET @TARGET@(IEN)=NAME_U_MNEMONIC
SET FLG=1
QUIT
+49 IF FLG=1
QUIT
+50 QUIT
End DoDot:2
+51 QUIT
End DoDot:1
+52 QUIT
+53 ;
ICD(TAXDX,TAX,TAXTY) ;PEP - Checks to see if ICD code is found in certain taxonomy
+1 ; Input:
+2 ; TAXDX=dx ifn
+3 ; TAX=taxonomy
+4 ; TAXTY=9 for dx or 0 for proc 1 for cpt
+5 NEW TAXICD,TAXBEG,TAXEND,TAXFLG,TAXIEN,TAXREF,TAXARR
+6 IF TAX?.N
SET TAXIEN=TAX
+7 IF TAX'?.N
Begin DoDot:1
+8 SET TAXIEN=$ORDER(^ATXAX("B",TAX,0))
SET TAXREF="^ATXAX"
End DoDot:1
+9 SET TAXFLG=0
IF '$DATA(TAXDX)!'$DATA(TAXIEN)!'$DATA(TAXTY)
QUIT TAXFLG
+10 IF (TAXDX="")!(TAXIEN="")
QUIT TAXFLG
+11 ;I TAXTY=9 S SYS=$$CSI^ICDEX(80,TAXDX) S:SYS="" SYS=1
+12 ;I TAXTY=0 S SYS=$$CSI^ICDEX(80.1,TAXDX) S:SYS="" SYS=2
+13 ;S TAXICD=$S(TAXTY=1:$P($$CPT^ICPTCOD(TAXDX),U,2),1:$P($$ICDDX^ICDEX(SYS,TAXDX),U,2))
+14 ;IHS/CMI/LAB GDIT/ARLIS - MODIFIED TO USE AC IF IT EXISTS
+15 SET TAXARR=$NAME(^ATXAX(TAXIEN,21,"AC"))
+16 IF '$DATA(^ATXAX(TAXIEN,21,"AC"))
DO BLDTAX($PIECE(^ATXAX(TAXIEN,0),U),.TAXARR,TAXIEN)
+17 IF $DATA(^ATXAX(TAXIEN,21,"AC",TAXDX))
QUIT 1
+18 QUIT TAXFLG
+19 ;
SRCH(FILEREF) ; Search for values
+1 ; LAB entries use the IEN and only specify one value.
+2 IF FILEREF=60
Begin DoDot:1
+3 SET NAME=$PIECE($GET(^LAB(60,VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
End DoDot:1
QUIT
+4 ; MED entries use the IEN and only specify one value.
+5 IF FILEREF=50.605
Begin DoDot:1
+6 NEW X,NVAL
+7 SET NVAL=$ORDER(^PS(50.605,"B",VAL,""))
IF NVAL=""
QUIT
+8 SET X=""
FOR
SET X=$ORDER(^PSDRUG("VAC",NVAL,X))
IF X=""
QUIT
Begin DoDot:2
+9 SET NAME=$PIECE($GET(^PSDRUG(X,0)),U,1)
SET @TARGET@(X)=NAME
End DoDot:2
End DoDot:1
QUIT
+10 IF FILEREF=50
Begin DoDot:1
+11 SET NAME=$PIECE($GET(^PSDRUG(VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
End DoDot:1
QUIT
+12 IF FILEREF=40.7
Begin DoDot:1
+13 SET NAME=$PIECE($GET(^DIC(40.7,VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
End DoDot:1
QUIT
+14 ; Otherwise, treat all items as ranges (even if there is only one entry).
+15 IF END=""
SET END=VAL
+16 Begin DoDot:1
+17 IF FILEREF=95.3
Begin DoDot:2
+18 ; The LOINC x-ref in LAB does not use the check digit (piece 2).
+19 SET VAL=$PIECE(VAL,"-")
SET END=$PIECE(END,"-")
+20 SET FILE="^LAB(60)"
SET INDEX="AF"
End DoDot:2
QUIT
+21 IF FILEREF=50.67
SET FILE="^PSDRUG"
SET INDEX="D"
QUIT
+22 IF FILEREF=9999999.05
SET FILE="^AUTTCOM"
SET INDEX="B"
QUIT
+23 IF FILEREF=9999999.09
SET FILE="^AUTTEDT"
SET INDEX="B"
QUIT
+24 IF FILEREF=9999999.14
SET FILE="^AUTTIMM"
SET INDEX="C"
QUIT
+25 IF FILEREF=9999999.64
SET FILE="^AUTTHF"
SET INDEX="B"
QUIT
+26 IF FILEREF=9999999.31
SET FILE="^AUTTADA"
SET INDEX="B"
QUIT
+27 ; CPT, ICD9, and ICD0 require a SPACE be added to the code.
+28 ; Some Taxonomy entries already have the space included.
+29 IF $EXTRACT(VAL,$LENGTH(VAL))'=" "
SET VAL=VAL_" "
+30 IF $EXTRACT(END,$LENGTH(END))'=" "
SET END=END_" "
+31 IF FILEREF=80
SET FILE="^ICD9"
SET INDEX="BA"
QUIT
+32 IF FILEREF=80.1
SET FILE="^ICD0"
SET INDEX="BA"
QUIT
+33 IF FILEREF=81
SET FILE="^ICPT"
SET INDEX="BA"
QUIT
End DoDot:1
+34 ; Backup one entry so loop can find all the entries in the range.
+35 SET VAL=$ORDER(@FILE@(INDEX,VAL),-1)
+36 FOR
SET VAL=$ORDER(@FILE@(INDEX,VAL))
IF VAL=""
QUIT
IF $$CHECK(VAL,END)
QUIT
Begin DoDot:1
+37 SET IEN=""
+38 FOR
SET IEN=$ORDER(@FILE@(INDEX,VAL,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+39 SET NAME=$PIECE($GET(@FILE@(IEN,0)),U,1)
+40 ;Does coding system match
+41 IF $GET(SYSN)
IF SYSN'=$PIECE($GET(@FILE@(IEN,1)),U,1)
QUIT
+42 IF $GET(SYSN)
SET SYS=$PIECE(^ICDS(SYSN,0),U,2)
SET SYSNM=$PIECE(^ICDS(SYSN,0),U,1)
+43 IF $GET(ORDER)'="CODE"
SET @TARGET@(IEN)=NAME_U_$GET(SYSN)_U_$GET(SYS)_U_$GET(SYSNM)
QUIT
+44 IF $GET(ORDER)="CODE"
SET @TARGET@(NAME_" ")=IEN_U_$GET(SYSN)_U_$GET(SYS)_U_$GET(SYSNM)_U_NAME
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
LST(SYSN,FILEREF,CODLS,ORDER,TARGET) ;PEP - LIST
+1 ; Input
+2 ; SYSN - System IEN from 80.4 (1, 2, 30 or 31)
+3 ; FILEREF - File reference
+4 ; CODLS - List of codes, can be range 250.00-250.99 or 250*
+5 ; ORDER - Format to get data back (blank returns in IEN order, "CODE" returns in CODE order)
+6 ; TARGET - Target reference
+7 ;
+8 NEW VAL,END,LG,IEN,SYS,NAME,SYSNM,INDEX
+9 SET SYSN=$GET(SYSN)
+10 IF $GET(FILEREF)=""
SET FILEREF=$PIECE(^ICDS(SYSN,0),U,3)
+11 IF CODLS["-"
SET VAL=$PIECE(CODLS,"-",1)
SET END=$PIECE(CODLS,"-",2)
DO SRCH(FILEREF)
QUIT
+12 IF CODLS["*"
Begin DoDot:1
+13 SET VAL=$PIECE(CODLS,"*",1)
SET END=VAL
SET LG=$LENGTH(END)
+14 ; CPT, ICD9, and ICD0 require a SPACE be added to the code.
+15 ; Some Taxonomy entries already have the space included.
+16 IF $EXTRACT(VAL,$LENGTH(VAL))'=" "
SET VAL=VAL_" "
+17 IF FILEREF=80
SET FILE="^ICD9"
SET INDEX="BA"
+18 IF FILEREF=80.1
SET FILE="^ICD0"
SET INDEX="BA"
+19 IF FILEREF=81
SET FILE="^ICPT"
SET INDEX="BA"
+20 ;
+21 FOR
SET VAL=$ORDER(@FILE@(INDEX,VAL))
IF VAL=""!($EXTRACT(VAL,1,LG)'=END)
QUIT
Begin DoDot:2
+22 SET IEN=""
+23 FOR
SET IEN=$ORDER(@FILE@(INDEX,VAL,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+24 SET NAME=$PIECE($GET(@FILE@(IEN,0)),U,1)
+25 ;Does coding system match
+26 IF $GET(SYSN)
IF SYSN'=$PIECE($GET(@FILE@(IEN,1)),U,1)
QUIT
+27 IF $GET(SYSN)
SET SYS=$PIECE(^ICDS(SYSN,0),U,2)
SET SYSNM=$PIECE(^ICDS(SYSN,0),U,1)
+28 IF $GET(ORDER)'="CODE"
SET @TARGET@(IEN)=NAME_U_$GET(SYSN)_U_$GET(SYS)_U_$GET(SYSNM)
QUIT
+29 IF $GET(ORDER)="CODE"
SET @TARGET@(NAME_" ")=IEN_U_$GET(SYSN)_U_$GET(SYS)_U_$GET(SYSNM)_U_NAME
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
