BUD1XTCH.m

BUD1XTCH ; IHS/CMI/LAB - TAXONOMY CHECK FOR FY04 GPRA REPORT ;

 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 ;

 ;

 D HOME^%ZIS

 W:$D(IOF) @IOF

 W !!,"Checking for Taxonomies to support the 2011 UDS Report. ",!,"Please enter the device for printing.",!

ZIS ;

 S XBRC="",XBRP="TAXCHK^BUD1TXCH",XBNS="",XBRX="XIT^BUD1TXCH"

 D ^XBDBQUE

 D XIT

 Q

TAXCHK ;EP

 D HOME^%ZIS

 K BUDQUIT

 W !,"Checking for Taxonomies to support the 2011 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 ;

 ;;BUD CPT HEPATITIS B TESTS

 ;;BUD CPT HEPATITIS C TESTS

 ;;BUD CPT HIV TESTS

 ;;BUD 11 CPT IMM LINE 24

 ;;BUD CPT PAP 10

 ;;BGP PAP LOINC CODES

 ;;BGP HIV TEST LOINC CODES

 ;;BGP PQA CONTROLLER MEDS

 ;;BGP CMS SMOKING CESSATION MEDS

 ;;BUD BMI PROCS

 ;;BUD TOBACCO SCREEN CPTS

 ;;BUD TOBACCO SCREEN DXS

 ;;

LAB ;

 ;;BGP PAP SMEAR TAX

 ;;BGP HIV TEST TAX

 ;;BUD HEPATITIS B TESTS

 ;;BUD HEPATITIS C TESTS

 ;;

LAB6B ;;

 ;;BGP PAP SMEAR TAX

 ;;

TAXB6 ;;

 ;;BUD HYSTERECTOMY CPTS

 ;;BUD HYSTERECTOMY PROCEDURES

 ;;BGP PAP LOINC CODES

 ;;BUD CPT PAP TABLE 6B 10

 ;;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

 ;;

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

 ;;

BUD1XTCH  ; IHS/CMI/LAB - TAXONOMY CHECK FOR FY04 GPRA REPORT ;

 +1       ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50

 +2       ;

 +3       ;

 +4        DO HOME^%ZIS

 +5        IF $DATA(IOF)

               WRITE @IOF

 +6        WRITE !!,"Checking for Taxonomies to support the 2011 UDS Report. ",!,"Please enter the device for printing.",!

ZIS       ;

 +1        SET XBRC=""

           SET XBRP="TAXCHK^BUD1TXCH"

           SET XBNS=""

           SET XBRX="XIT^BUD1TXCH"

 +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 2011 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       ;;BUD CPT HEPATITIS B TESTS

 +2       ;;BUD CPT HEPATITIS C TESTS

 +3       ;;BUD CPT HIV TESTS

 +4       ;;BUD 11 CPT IMM LINE 24

 +5       ;;BUD CPT PAP 10

 +6       ;;BGP PAP LOINC CODES

 +7       ;;BGP HIV TEST LOINC CODES

 +8       ;;BGP PQA CONTROLLER MEDS

 +9       ;;BGP CMS SMOKING CESSATION MEDS

 +10      ;;BUD BMI PROCS

 +11      ;;BUD TOBACCO SCREEN CPTS

 +12      ;;BUD TOBACCO SCREEN DXS

 +13      ;;

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       ;;

TAXB6     ;;

 +1       ;;BUD HYSTERECTOMY CPTS

 +2       ;;BUD HYSTERECTOMY PROCEDURES

 +3       ;;BGP PAP LOINC CODES

 +4       ;;BUD CPT PAP TABLE 6B 10

 +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      ;;

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       ;;