BUDEXTCH ;IHS/CMI/LAB - UDS TAXONOMY CHECK;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
D HOME^%ZIS
W:$D(IOF) @IOF
W !!,"Checking for Taxonomies to support the 2017 UDS Report. ",!,"Please enter the device for printing.",!
ZIS ;
S XBRC="",XBRP="TAXCHK^BUDETXCH",XBNS="",XBRX="XIT^BUDETXCH"
D ^XBDBQUE
D XIT
Q
TAXCHK ;EP
D HOME^%ZIS
K BUDQUIT
W !,"Checking for Taxonomies to support the 2017 UDS Report...",!
NEW A,BUDX,I,Y,Z,J
K A
I $G(BUDT6) S T="TAXS" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXAX("B",BUDX)) S A(BUDX)=Y_"^is Missing" Q
.S I=$O(^ATXAX("B",BUDX,0))
.I '$D(^ATXAX(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I $G(BUDT6) S T="LAB" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXLAB("B",BUDX)) S A(BUDX)=Y_"^is Missing " Q
.S I=$O(^ATXLAB("B",BUDX,0))
.I '$D(^ATXLAB(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I $G(BUDT6B) S T="TAXB6" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXAX("B",BUDX)) S A(BUDX)=Y_"^is Missing" Q
.S I=$O(^ATXAX("B",BUDX,0))
.I '$D(^ATXAX(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I $G(BUDT6B) S T="LAB6B" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXLAB("B",BUDX)) S A(BUDX)=Y_"^is Missing " Q
.S I=$O(^ATXLAB("B",BUDX,0))
.I '$D(^ATXLAB(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I $G(BUDT7) S T="TAX7" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXAX("B",BUDX)) S A(BUDX)=Y_"^is Missing" Q
.S I=$O(^ATXAX("B",BUDX,0))
.I '$D(^ATXAX(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I $G(BUDT7) S T="LAB7" F J=1:1 S Z=$T(@T+J),BUDX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BUDX="" D
.I '$D(^ATXLAB("B",BUDX)) S A(BUDX)=Y_"^is Missing " Q
.S I=$O(^ATXLAB("B",BUDX,0))
.I '$D(^ATXLAB(I,21,"B")) S A(BUDX)=Y_"^has no entries "
I '$D(A) W !,"All taxonomies are present.",! K A,BUDX,Y,I,Z D DONE Q
W !!,"In order for the UDS Report to find all necessary data, several",!,"taxonomies must be established. The following taxonomies are missing or have",!,"no entries:"
S BUDX="" F S BUDX=$O(A(BUDX)) Q:BUDX=""!($D(BUDQUIT)) D
.;I $Y>(IOSL-2) D PAGE Q:$D(BUDQUIT)
.W !,$P(A(BUDX),U)," [",BUDX,"] ",$P(A(BUDX),U,2)
.Q
DONE ;
K BUDQUIT
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of taxonomy check. PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
XIT ;EP
K BUD,BUDX,BUDQUIT,BUDLINE,BUDJ,BUDX,BUDTEXT,BUD
K X,Y,J
Q
PAGE ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT="" Q
Q
TAXS ;
;;BGP PAP LOINC CODES
;;BGP HIV TEST LOINC CODES
;;
LAB ;
;;BGP PAP SMEAR TAX
;;BGP HIV TEST TAX
;;BUD HEPATITIS B TESTS
;;BUD HEPATITIS C TESTS
;;
LAB6B ;;
;;BGP PAP SMEAR TAX
;;BGP GPRA FOB TESTS
;;BGP HIV TEST TAX
;;
TAXB6 ;;
;;BUD HYSTERECTOMY CPTS
;;BUD HYSTERECTOMY PROCEDURES
;;BGP PAP LOINC CODES
;;BUD CPT PAP TABLE 6B V8
;;BUD IPV EVID DISEASE
;;BGP MMR CONTRAINDICATIONS
;;BGP MEASLES EVIDENCE
;;BGP MUMPS EVIDENCE
;;BGP HEP EVIDENCE
;;BGP RUBELLA EVIDENCE
;;BUD HIB EVIDENCE
;;BGP VARICELLA EVIDENCE
;;BGP PERTUSSIS EVIDENCE
;;BGP DIPHTHERIA EVIDENCE
;;BGP GPRA PREGNANCY DIAGNOSES
;;BGP MISCARRIAGE/ABORTION DXS
;;BGP ABORTION PROCEDURES
;;BGP CPT ABORTION
;;BGP CPT MISCARRIAGE
;;BGP PQA SABA MEDS
;;BUD CAD DXS
;;BUD CAD CPTS
;;BUD IVD DXS
;;BUD CABG PTCA PROCS
;;BUD CABG PTCA CPTS
;;BUD CABG PTCA DXS
;;BUD COLORECTAL CANCER DXS
;;BUD COLORECTAL CANCER PROCS
;;BUD COLORECTAL CANCER CPTS
;;BGP COLO PROCS
;;BGP COLO CPTS
;;BGP COLO DXS
;;BGP SIG PROCS
;;BGP SIG CPTS
;;BGP FOBT LOINC CODES
;;BGPMU IVD ANTIPLATELET NDCS
;;BUD LIPID LOWERING MEDS
;;BUD ANTIPLATELET MEDS
;;DM AUDIT ASPIRIN DRUGS
;;BGPMU LIPID LOWERING NDCS
;;BGP PQA NON-WARF ANTICOAG MEDS
;;BGP PQA WARFARIN MEDS
;;
TAX7 ;;
;;BGP HIV/AIDS DXS
;;BGP GPRA PREGNANCY DIAGNOSES
;;BGP MISCARRIAGE/ABORTION DXS
;;BGP ABORTION PROCEDURES
;;BGP CPT ABORTION
;;BGP CPT MISCARRIAGE
;;BUD HYPERTENSION DXS
;;BUD GEST/STEROID DM DX
;;BUD HGBA1C CPTS
;;BGP HGBA1C LOINC CODES
;;BUD DIABETES MEDS NDC
;;BUD DIABETES MEDS TAX
;;BUD DIABETES DXS FOR TABLE 7
;;BUD DIASTOLIC BP CPTS
;;BUD SYSTOLIC BP CPTS
;;
LAB7 ;;
;;DM AUDIT HGB A1C TAX
;;
BUDEXTCH ;IHS/CMI/LAB - UDS TAXONOMY CHECK;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
+4 DO HOME^%ZIS
+5 IF $DATA(IOF)
WRITE @IOF
+6 WRITE !!,"Checking for Taxonomies to support the 2017 UDS Report. ",!,"Please enter the device for printing.",!
ZIS ;
+1 SET XBRC=""
SET XBRP="TAXCHK^BUDETXCH"
SET XBNS=""
SET XBRX="XIT^BUDETXCH"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
TAXCHK ;EP
+1 DO HOME^%ZIS
+2 KILL BUDQUIT
+3 WRITE !,"Checking for Taxonomies to support the 2017 UDS Report...",!
+4 NEW A,BUDX,I,Y,Z,J
+5 KILL A
+6 IF $GET(BUDT6)
SET T="TAXS"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+7 IF '$DATA(^ATXAX("B",BUDX))
SET A(BUDX)=Y_"^is Missing"
QUIT
+8 SET I=$ORDER(^ATXAX("B",BUDX,0))
+9 IF '$DATA(^ATXAX(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+10 IF $GET(BUDT6)
SET T="LAB"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+11 IF '$DATA(^ATXLAB("B",BUDX))
SET A(BUDX)=Y_"^is Missing "
QUIT
+12 SET I=$ORDER(^ATXLAB("B",BUDX,0))
+13 IF '$DATA(^ATXLAB(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+14 IF $GET(BUDT6B)
SET T="TAXB6"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+15 IF '$DATA(^ATXAX("B",BUDX))
SET A(BUDX)=Y_"^is Missing"
QUIT
+16 SET I=$ORDER(^ATXAX("B",BUDX,0))
+17 IF '$DATA(^ATXAX(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+18 IF $GET(BUDT6B)
SET T="LAB6B"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+19 IF '$DATA(^ATXLAB("B",BUDX))
SET A(BUDX)=Y_"^is Missing "
QUIT
+20 SET I=$ORDER(^ATXLAB("B",BUDX,0))
+21 IF '$DATA(^ATXLAB(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+22 IF $GET(BUDT7)
SET T="TAX7"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+23 IF '$DATA(^ATXAX("B",BUDX))
SET A(BUDX)=Y_"^is Missing"
QUIT
+24 SET I=$ORDER(^ATXAX("B",BUDX,0))
+25 IF '$DATA(^ATXAX(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+26 IF $GET(BUDT7)
SET T="LAB7"
FOR J=1:1
SET Z=$TEXT(@T+J)
SET BUDX=$PIECE(Z,";;",2)
SET Y=$PIECE(Z,";;",3)
IF BUDX=""
QUIT
Begin DoDot:1
+27 IF '$DATA(^ATXLAB("B",BUDX))
SET A(BUDX)=Y_"^is Missing "
QUIT
+28 SET I=$ORDER(^ATXLAB("B",BUDX,0))
+29 IF '$DATA(^ATXLAB(I,21,"B"))
SET A(BUDX)=Y_"^has no entries "
End DoDot:1
+30 IF '$DATA(A)
WRITE !,"All taxonomies are present.",!
KILL A,BUDX,Y,I,Z
DO DONE
QUIT
+31 WRITE !!,"In order for the UDS Report to find all necessary data, several",!,"taxonomies must be established. The following taxonomies are missing or have",!,"no entries:"
+32 SET BUDX=""
FOR
SET BUDX=$ORDER(A(BUDX))
IF BUDX=""!($DATA(BUDQUIT))
QUIT
Begin DoDot:1
+33 ;I $Y>(IOSL-2) D PAGE Q:$D(BUDQUIT)
+34 WRITE !,$PIECE(A(BUDX),U)," [",BUDX,"] ",$PIECE(A(BUDX),U,2)
+35 QUIT
End DoDot:1
DONE ;
+1 KILL BUDQUIT
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of taxonomy check. PRESS ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
XIT ;EP
+1 KILL BUD,BUDX,BUDQUIT,BUDLINE,BUDJ,BUDX,BUDTEXT,BUD
+2 KILL X,Y,J
+3 QUIT
PAGE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=""
QUIT
+2 QUIT
TAXS ;
+1 ;;BGP PAP LOINC CODES
+2 ;;BGP HIV TEST LOINC CODES
+3 ;;
LAB ;
+1 ;;BGP PAP SMEAR TAX
+2 ;;BGP HIV TEST TAX
+3 ;;BUD HEPATITIS B TESTS
+4 ;;BUD HEPATITIS C TESTS
+5 ;;
LAB6B ;;
+1 ;;BGP PAP SMEAR TAX
+2 ;;BGP GPRA FOB TESTS
+3 ;;BGP HIV TEST TAX
+4 ;;
TAXB6 ;;
+1 ;;BUD HYSTERECTOMY CPTS
+2 ;;BUD HYSTERECTOMY PROCEDURES
+3 ;;BGP PAP LOINC CODES
+4 ;;BUD CPT PAP TABLE 6B V8
+5 ;;BUD IPV EVID DISEASE
+6 ;;BGP MMR CONTRAINDICATIONS
+7 ;;BGP MEASLES EVIDENCE
+8 ;;BGP MUMPS EVIDENCE
+9 ;;BGP HEP EVIDENCE
+10 ;;BGP RUBELLA EVIDENCE
+11 ;;BUD HIB EVIDENCE
+12 ;;BGP VARICELLA EVIDENCE
+13 ;;BGP PERTUSSIS EVIDENCE
+14 ;;BGP DIPHTHERIA EVIDENCE
+15 ;;BGP GPRA PREGNANCY DIAGNOSES
+16 ;;BGP MISCARRIAGE/ABORTION DXS
+17 ;;BGP ABORTION PROCEDURES
+18 ;;BGP CPT ABORTION
+19 ;;BGP CPT MISCARRIAGE
+20 ;;BGP PQA SABA MEDS
+21 ;;BUD CAD DXS
+22 ;;BUD CAD CPTS
+23 ;;BUD IVD DXS
+24 ;;BUD CABG PTCA PROCS
+25 ;;BUD CABG PTCA CPTS
+26 ;;BUD CABG PTCA DXS
+27 ;;BUD COLORECTAL CANCER DXS
+28 ;;BUD COLORECTAL CANCER PROCS
+29 ;;BUD COLORECTAL CANCER CPTS
+30 ;;BGP COLO PROCS
+31 ;;BGP COLO CPTS
+32 ;;BGP COLO DXS
+33 ;;BGP SIG PROCS
+34 ;;BGP SIG CPTS
+35 ;;BGP FOBT LOINC CODES
+36 ;;BGPMU IVD ANTIPLATELET NDCS
+37 ;;BUD LIPID LOWERING MEDS
+38 ;;BUD ANTIPLATELET MEDS
+39 ;;DM AUDIT ASPIRIN DRUGS
+40 ;;BGPMU LIPID LOWERING NDCS
+41 ;;BGP PQA NON-WARF ANTICOAG MEDS
+42 ;;BGP PQA WARFARIN MEDS
+43 ;;
TAX7 ;;
+1 ;;BGP HIV/AIDS DXS
+2 ;;BGP GPRA PREGNANCY DIAGNOSES
+3 ;;BGP MISCARRIAGE/ABORTION DXS
+4 ;;BGP ABORTION PROCEDURES
+5 ;;BGP CPT ABORTION
+6 ;;BGP CPT MISCARRIAGE
+7 ;;BUD HYPERTENSION DXS
+8 ;;BUD GEST/STEROID DM DX
+9 ;;BUD HGBA1C CPTS
+10 ;;BGP HGBA1C LOINC CODES
+11 ;;BUD DIABETES MEDS NDC
+12 ;;BUD DIABETES MEDS TAX
+13 ;;BUD DIABETES DXS FOR TABLE 7
+14 ;;BUD DIASTOLIC BP CPTS
+15 ;;BUD SYSTOLIC BP CPTS
+16 ;;
LAB7 ;;
+1 ;;DM AUDIT HGB A1C TAX
+2 ;;
