- 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
