BUD9XTCH.m

BUD9XTCH ; 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 2009 UDS Report. ",!,"Please enter the device for printing.",!

ZIS ;

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

 D ^XBDBQUE

 D XIT

 Q

TAXCHK ;EP

 D HOME^%ZIS

 K BUDQUIT

 W !,"Checking for Taxonomies to support the 2009 UDS Report...",!

 NEW A,BUDX,I,Y,Z,J

 K A

 S T=$S($G(BUDTAXT)]"":BUDTAXT,1:"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 "

 S T=$S($G(BUDTAXT)]"":"LAB"_BUDTAXT,1:"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 '$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 L26 CPTS

 ;;BUD IMM CPTS

 ;;BUD CPT HIV TESTS

 ;;BGP HIV TEST LOINC CODES

 ;;BUD CPT PAP 07

 ;;BGP PAP LOINC CODES

 ;;BUD CPT PAP 03

 ;;BUD CPT PAP 04

 ;;BUD CPT PAP 05

 ;;BUD CPT PAP 08

 ;;BUD TABLE 6 LINE 16

 ;;BUD TABLE 6 LINE 17

 ;;BUD TABLE 6 LINE 19

 ;;BUD TABLE 6 LINE 20

 ;;BGP CPT MAMMOGRAM

 ;;

LAB ;

 ;;BGP PAP SMEAR TAX

 ;;BGP HIV TEST TAX

 ;;

LAB6B ;;

 ;;BGP PAP SMEAR TAX

 ;;

B6 ;;

 ;;BUD HYSTERECTOMY CPTS

 ;;BUD HYSTERECTOMY PROCEDURES

 ;;BGP PAP LOINC CODES

 ;;BUD CPT PAP 08

 ;;BUD IPV EVID DISEASE

 ;;BGP MMR CONTRAINDICATIONS

 ;;BGP MEASLES EVIDENCE

 ;;BGP MUMPS EVIDENCE

 ;;BGP HEP EVIDENCE

 ;;BGP RUBELLA EVIDENCE

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

 ;;

7 ;;

 ;;BGP HIV/AIDS DXS

 ;;BUD HYPERTENSION DXS

 ;;BUD CPT NORMAL SYSTOLIC

 ;;BUD CPT NORMAL DIASTOLIC

 ;;BGP GPRA PREGNANCY DIAGNOSES

 ;;BGP MISCARRIAGE/ABORTION DXS

 ;;BGP ABORTION PROCEDURES

 ;;BGP CPT ABORTION

 ;;BGP CPT MISCARRIAGE

 ;;SURVEILLANCE DIABETES

 ;;BUD HYPERTENSION DXS

 ;;BUD GEST/STEROID DM DX

 ;;BUD HGBA1C CPTS

 ;;BGP HGBA1C LOINC CODES

 ;;

LAB7 ;;

 ;;DM AUDIT HGB A1C TAX

 ;;

BUD9XTCH  ; 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 2009 UDS Report. ",!,"Please enter the device for printing.",!

ZIS       ;

 +1        SET XBRC=""

           SET XBRP="TAXCHK^BUD9TXCH"

           SET XBNS=""

           SET XBRX="XIT^BUD9TXCH"

 +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 2009 UDS Report...",!

 +4        NEW A,BUDX,I,Y,Z,J

 +5        KILL A

 +6        SET T=$SELECT($GET(BUDTAXT)]"":BUDTAXT,1:"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       SET T=$SELECT($GET(BUDTAXT)]"":"LAB"_BUDTAXT,1:"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 '$DATA(A)

               WRITE !,"All taxonomies are present.",!

               KILL A,BUDX,Y,I,Z

               DO DONE

               QUIT 

 +15       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:"

 +16       SET BUDX=""

           FOR 

               SET BUDX=$ORDER(A(BUDX))

               IF BUDX=""!($DATA(BUDQUIT))

                   QUIT 

               Begin DoDot:1

 +17      ;I $Y>(IOSL-2) D PAGE Q:$D(BUDQUIT)

 +18               WRITE !,$PIECE(A(BUDX),U)," [",BUDX,"] ",$PIECE(A(BUDX),U,2)

 +19               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 L26 CPTS

 +2       ;;BUD IMM CPTS

 +3       ;;BUD CPT HIV TESTS

 +4       ;;BGP HIV TEST LOINC CODES

 +5       ;;BUD CPT PAP 07

 +6       ;;BGP PAP LOINC CODES

 +7       ;;BUD CPT PAP 03

 +8       ;;BUD CPT PAP 04

 +9       ;;BUD CPT PAP 05

 +10      ;;BUD CPT PAP 08

 +11      ;;BUD TABLE 6 LINE 16

 +12      ;;BUD TABLE 6 LINE 17

 +13      ;;BUD TABLE 6 LINE 19

 +14      ;;BUD TABLE 6 LINE 20

 +15      ;;BGP CPT MAMMOGRAM

 +16      ;;

LAB       ;

 +1       ;;BGP PAP SMEAR TAX

 +2       ;;BGP HIV TEST TAX

 +3       ;;

LAB6B     ;;

 +1       ;;BGP PAP SMEAR TAX

 +2       ;;

B6        ;;

 +1       ;;BUD HYSTERECTOMY CPTS

 +2       ;;BUD HYSTERECTOMY PROCEDURES

 +3       ;;BGP PAP LOINC CODES

 +4       ;;BUD CPT PAP 08

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

7         ;;

 +1       ;;BGP HIV/AIDS DXS

 +2       ;;BUD HYPERTENSION DXS

 +3       ;;BUD CPT NORMAL SYSTOLIC

 +4       ;;BUD CPT NORMAL DIASTOLIC

 +5       ;;BGP GPRA PREGNANCY DIAGNOSES

 +6       ;;BGP MISCARRIAGE/ABORTION DXS

 +7       ;;BGP ABORTION PROCEDURES

 +8       ;;BGP CPT ABORTION

 +9       ;;BGP CPT MISCARRIAGE

 +10      ;;SURVEILLANCE DIABETES

 +11      ;;BUD HYPERTENSION DXS

 +12      ;;BUD GEST/STEROID DM DX

 +13      ;;BUD HGBA1C CPTS

 +14      ;;BGP HGBA1C LOINC CODES

 +15      ;;

LAB7      ;;

 +1       ;;DM AUDIT HGB A1C TAX

 +2       ;;