BQITXPRT ;GDIT/HS/ALA-Print LOINC Taxonomies ; 14 Jun 2012 7:48 AM
;;2.3;ICARE MANAGEMENT SYSTEM;**1,2**;Apr 18, 2012;Build 14
;
EN ; EP
NEW BQIRUN,ZTRTN,J,L,P,POP,Y,ABORT,CT,DTOUT,DIRUT
S BQIRUN=$$HTE^XLFDT($H,1)
S ZTDESC="CANES LOINC REPORT",ZTRTN="BEG^BQITXPRT"
S %ZIS="QM" D ^%ZIS G END:POP
I '$D(IO("Q")) K ZTDESC G @ZTRTN
S ZTIO=ION,ZTSAVE("*")=""
D ^%ZTLOAD
Q
;
BEG ;EP
S (P,L,ABORT,CT)=0
U IO D HDR I $G(ABORT)=1 Q
NEW I,TAX,TREF
S TREF=$NA(^TMP("BQITAX",$J))
F I=1:1 S TAX=$P($T(TX+I),";;",2) Q:TAX="" D Q:$G(ABORT)=1
. K @TREF
. D BLD(TAX,TREF)
. I L+4>IOSL D HDR Q:$G(ABORT)=1
. W !,TAX S L=L+1
. I L+4>IOSL D HDR Q:$G(ABORT)=1
. S J="" F S J=$O(@TREF@(J)) Q:J="" D
.. W !,?5,$P(@TREF@(J),U,2),?17,$P(@TREF@(J),U,1) S L=L+1
. W ! S L=L+1
. I L+4>IOSL D HDR Q:$G(ABORT)=1
;
Q
;
END ;
Q
;
HDR ;EP
K DIR
S DIR(0)="E"
I $E(IOST,1,2)="C-",P D ^DIR I $G(DIRUT)=1!($G(DTOUT)=1) S ABORT=1 Q
I $E(IOST,1,2)="C-"!P W @IOF
S P=P+1,L=5
W "CANES LOINC REPORT",?30,"Run Date: ",BQIRUN,?65,"Page ",$J(P,3)
W !,"Taxonomy Name"
W !,?5,"LOINC Code",?17,"Lab Test"
W !,$TR($J(" ",IOM)," ","-"),!
Q
;
BLD(TAX,TARGET) ;EP
N FILEREF,TAXIEN,TAXREF,ENTRY,VALUE,VAL,END,FILE,INDEX,IEN,NAME
I TARGET=""!(TAX="") Q
S TAXIEN=$O(^ATXAX("B",TAX,0)),TAXREF="^ATXAX"
I TAXIEN="" S TAXIEN=$O(^ATXLAB("B",TAX,0)),TAXREF="^ATXLAB"
I TAXIEN="" Q
I TAXREF="^ATXAX" S FILEREF=$$GET1^DIQ(9002226,TAXIEN,.15,"I")
I TAXREF="^ATXLAB" S FILEREF=$$GET1^DIQ(9002228,TAXIEN,.09,"I")
;
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)
.; 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
.; 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"
.; 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^BQITUIX(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_U_$P(VALUE,U,1)
Q
;
TX ;
;;BKMV CD4 ABS LOINC CODES
;;BQI C.TRACH SPECIFIC LOINC
;;BQI C.TRACH NON-SPECIFIC LOINC
;;BQI C.TRACH DNA QUANT LOINC
;;SURVEILLANCE RAPID FLU LOINC
;;BQI HEP A TESTS LOINC
;;BQI HEP B CORE TEST LOINC
;;BQI HEP B QUAL TEST LOINC
;;BQI HEP B QUANT TEST LOINC
;;BQI HEP C QUAL TEST LOINC
;;BQI HEP C QUANT TEST LOINC
;;BQI ALT/AST/GGT TEST LOINC
;;BQI HIB QUAL TEST LOINC
;;BQI HIB CULTURE TEST LOINC
;;BQI HIB QUANT TEST LOINC
;;BQI HIV AB QUAL SCREEN LOINC
;;BQI HIV AB QUANT SCREEN LOINC
;;BQI HIV QUAL ANTIGEN LOINC
;;BQI HIV QUANT ANTIGEN LOINC
;;BQI HIV QUAL CONFIRM LOINC
;;BQI HIV QUANT CONFIRM LOINC
;;BQI HIV ID SPEC CONFIRM LOINC
;;BQI HIV QUAL NUC ACID LOINC
;;BQI HIV QUANT NUC ACID LOINC
;;BQI HIV VIROLOGIC TEST LOINC
;;BQI MEASLES QUAL TEST LOINC
;;BQI MEASLES ID SPEC TEST LOINC
;;BQI MEASLES QUAN TEST LOINC
;;BQI MENINGITIS QUAL TEST LOINC
;;BQI MENINGITIS ID SPEC LOINC
;;BQI MENINGITIS QUAN LOINC
;;BQI MYCOBACT TB CULT LOINC
;;BQI S PNEUM CULTURE TEST LOINC
;;BQI S PNEUM SUSCEPT TEST LOINC
;;BQI SYPHILIS TP-AB LOINC
;;BQI SYPHILIS REAGIN LOINC
;;BQI TB SPECIFIC AFB TEST LOINC
;;BQI TB NONSPEC AFB TEST LOINC
;;BQI TB GAMMA REL QUAL TEST LNC
;;BQI TB RNA DNA QUAL TEST LOINC
;;BQI TB RNA DNA QUANT TEST LNC
;;BQI PPD DIAMETER LOINC
BQITXPRT ;GDIT/HS/ALA-Print LOINC Taxonomies ; 14 Jun 2012 7:48 AM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**1,2**;Apr 18, 2012;Build 14
+2 ;
EN ; EP
+1 NEW BQIRUN,ZTRTN,J,L,P,POP,Y,ABORT,CT,DTOUT,DIRUT
+2 SET BQIRUN=$$HTE^XLFDT($HOROLOG,1)
+3 SET ZTDESC="CANES LOINC REPORT"
SET ZTRTN="BEG^BQITXPRT"
+4 SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO END
+5 IF '$DATA(IO("Q"))
KILL ZTDESC
GOTO @ZTRTN
+6 SET ZTIO=ION
SET ZTSAVE("*")=""
+7 DO ^%ZTLOAD
+8 QUIT
+9 ;
BEG ;EP
+1 SET (P,L,ABORT,CT)=0
+2 USE IO
DO HDR
IF $GET(ABORT)=1
QUIT
+3 NEW I,TAX,TREF
+4 SET TREF=$NAME(^TMP("BQITAX",$JOB))
+5 FOR I=1:1
SET TAX=$PIECE($TEXT(TX+I),";;",2)
IF TAX=""
QUIT
Begin DoDot:1
+6 KILL @TREF
+7 DO BLD(TAX,TREF)
+8 IF L+4>IOSL
DO HDR
IF $GET(ABORT)=1
QUIT
+9 WRITE !,TAX
SET L=L+1
+10 IF L+4>IOSL
DO HDR
IF $GET(ABORT)=1
QUIT
+11 SET J=""
FOR
SET J=$ORDER(@TREF@(J))
IF J=""
QUIT
Begin DoDot:2
+12 WRITE !,?5,$PIECE(@TREF@(J),U,2),?17,$PIECE(@TREF@(J),U,1)
SET L=L+1
End DoDot:2
+13 WRITE !
SET L=L+1
+14 IF L+4>IOSL
DO HDR
IF $GET(ABORT)=1
QUIT
End DoDot:1
IF $GET(ABORT)=1
QUIT
+15 ;
+16 QUIT
+17 ;
END ;
+1 QUIT
+2 ;
HDR ;EP
+1 KILL DIR
+2 SET DIR(0)="E"
+3 IF $EXTRACT(IOST,1,2)="C-"
IF P
DO ^DIR
IF $GET(DIRUT)=1!($GET(DTOUT)=1)
SET ABORT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"!P
WRITE @IOF
+5 SET P=P+1
SET L=5
+6 WRITE "CANES LOINC REPORT",?30,"Run Date: ",BQIRUN,?65,"Page ",$JUSTIFY(P,3)
+7 WRITE !,"Taxonomy Name"
+8 WRITE !,?5,"LOINC Code",?17,"Lab Test"
+9 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-"),!
+10 QUIT
+11 ;
BLD(TAX,TARGET) ;EP
+1 NEW FILEREF,TAXIEN,TAXREF,ENTRY,VALUE,VAL,END,FILE,INDEX,IEN,NAME
+2 IF TARGET=""!(TAX="")
QUIT
+3 SET TAXIEN=$ORDER(^ATXAX("B",TAX,0))
SET TAXREF="^ATXAX"
+4 IF TAXIEN=""
SET TAXIEN=$ORDER(^ATXLAB("B",TAX,0))
SET TAXREF="^ATXLAB"
+5 IF TAXIEN=""
QUIT
+6 IF TAXREF="^ATXAX"
SET FILEREF=$$GET1^DIQ(9002226,TAXIEN,.15,"I")
+7 IF TAXREF="^ATXLAB"
SET FILEREF=$$GET1^DIQ(9002228,TAXIEN,.09,"I")
+8 ;
+9 SET ENTRY=0
+10 FOR
SET ENTRY=$ORDER(@TAXREF@(TAXIEN,21,ENTRY))
IF 'ENTRY
QUIT
Begin DoDot:1
+11 SET VALUE=@TAXREF@(TAXIEN,21,ENTRY,0)
+12 SET VAL=$PIECE(VALUE,U,1)
SET END=$PIECE(VALUE,U,2)
+13 ; LAB entries use the IEN and only specify one value.
+14 IF FILEREF=60
Begin DoDot:2
+15 SET NAME=$PIECE($GET(^LAB(60,VAL,0)),U,1)
SET @TARGET@(VAL)=NAME
End DoDot:2
QUIT
+16 ; Otherwise, treat all items as ranges (even if there is only one entry).
+17 IF END=""
SET END=VAL
+18 Begin DoDot:2
+19 IF FILEREF=95.3
Begin DoDot:3
+20 ; The LOINC x-ref in LAB does not use the check digit (piece 2).
+21 SET VAL=$PIECE(VAL,"-")
SET END=$PIECE(END,"-")
+22 SET FILE="^LAB(60)"
SET INDEX="AF"
End DoDot:3
QUIT
End DoDot:2
+23 ; Backup one entry so loop can find all the entries in the range.
+24 SET VAL=$ORDER(@FILE@(INDEX,VAL),-1)
+25 FOR
SET VAL=$ORDER(@FILE@(INDEX,VAL))
IF VAL=""
QUIT
IF $$CHECK^BQITUIX(VAL,END)
QUIT
Begin DoDot:2
+26 SET IEN=""
+27 FOR
SET IEN=$ORDER(@FILE@(INDEX,VAL,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+28 SET NAME=$PIECE($GET(@FILE@(IEN,0)),U,1)
+29 SET @TARGET@(IEN)=NAME_U_$PIECE(VALUE,U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
TX ;
+1 ;;BKMV CD4 ABS LOINC CODES
+2 ;;BQI C.TRACH SPECIFIC LOINC
+3 ;;BQI C.TRACH NON-SPECIFIC LOINC
+4 ;;BQI C.TRACH DNA QUANT LOINC
+5 ;;SURVEILLANCE RAPID FLU LOINC
+6 ;;BQI HEP A TESTS LOINC
+7 ;;BQI HEP B CORE TEST LOINC
+8 ;;BQI HEP B QUAL TEST LOINC
+9 ;;BQI HEP B QUANT TEST LOINC
+10 ;;BQI HEP C QUAL TEST LOINC
+11 ;;BQI HEP C QUANT TEST LOINC
+12 ;;BQI ALT/AST/GGT TEST LOINC
+13 ;;BQI HIB QUAL TEST LOINC
+14 ;;BQI HIB CULTURE TEST LOINC
+15 ;;BQI HIB QUANT TEST LOINC
+16 ;;BQI HIV AB QUAL SCREEN LOINC
+17 ;;BQI HIV AB QUANT SCREEN LOINC
+18 ;;BQI HIV QUAL ANTIGEN LOINC
+19 ;;BQI HIV QUANT ANTIGEN LOINC
+20 ;;BQI HIV QUAL CONFIRM LOINC
+21 ;;BQI HIV QUANT CONFIRM LOINC
+22 ;;BQI HIV ID SPEC CONFIRM LOINC
+23 ;;BQI HIV QUAL NUC ACID LOINC
+24 ;;BQI HIV QUANT NUC ACID LOINC
+25 ;;BQI HIV VIROLOGIC TEST LOINC
+26 ;;BQI MEASLES QUAL TEST LOINC
+27 ;;BQI MEASLES ID SPEC TEST LOINC
+28 ;;BQI MEASLES QUAN TEST LOINC
+29 ;;BQI MENINGITIS QUAL TEST LOINC
+30 ;;BQI MENINGITIS ID SPEC LOINC
+31 ;;BQI MENINGITIS QUAN LOINC
+32 ;;BQI MYCOBACT TB CULT LOINC
+33 ;;BQI S PNEUM CULTURE TEST LOINC
+34 ;;BQI S PNEUM SUSCEPT TEST LOINC
+35 ;;BQI SYPHILIS TP-AB LOINC
+36 ;;BQI SYPHILIS REAGIN LOINC
+37 ;;BQI TB SPECIFIC AFB TEST LOINC
+38 ;;BQI TB NONSPEC AFB TEST LOINC
+39 ;;BQI TB GAMMA REL QUAL TEST LNC
+40 ;;BQI TB RNA DNA QUAL TEST LOINC
+41 ;;BQI TB RNA DNA QUANT TEST LNC
+42 ;;BQI PPD DIAMETER LOINC
