BGP8CTXC.m

BGP8CTXC ; IHS/CMI/LAB - TAXONOMY CHECK FOR FY04 CRS REPORT 18 Feb 2008 5:31 PM ;

 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008

 ;

 ;

 D HOME^%ZIS

 W:$D(IOF) @IOF

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

ZIS ;

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

 D ^XBDBQUE

 D XIT

 Q

TAXCHK ;EP

 ;D HOME^%ZIS

 K BGPQUIT

GUICHK ;EP

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

 NEW A,BGPX,I,Y,Z,J,BGPY,BGPT,BGPI,BGPM

 K A

 ;version 8.0

 I $D(BGPPLSTL) D THISRPT Q

 S BGPT="" F  S BGPT=$O(^BGPTAXE("B",BGPT)) Q:BGPT=""  D

 .S BGPY=$O(^BGPTAXE("B",BGPT,0))

 .Q:'$D(^BGPTAXE(BGPY,12,"B",5))

 .S BGPTYPE=$P(^BGPTAXE(BGPY,0),U,2),Y=$G(^BGPTAXE(BGPY,11,1,0))

 .I BGPTYPE'="L" D

 ..I '$D(^ATXAX("B",BGPT)) S A(BGPT)=Y_"^is Missing" Q

 ..S I=$O(^ATXAX("B",BGPT,0))

 ..I '$D(^ATXAX(I,21,"B")) S A(BGPT)=Y_"^has no entries "

 .I BGPTYPE="L" D

 ..I '$D(^ATXLAB("B",BGPT)) S A(BGPT)=Y_"^is Missing " Q

 ..S I=$O(^ATXLAB("B",BGPT,0))

 ..I '$D(^ATXLAB(I,21,"B")) S A(BGPT)=Y_"^has no entries "

 I '$D(A) W !,"All taxonomies are present.",! K A,BGPX,Y,I,Z D DONE Q

 W !!,"In order for the CMS Report to find all necessary data, several",!,"taxonomies must be established.  The following taxonomies are missing or have",!,"no entries:"

 S BGPX="" F  S BGPX=$O(A(BGPX)) Q:BGPX=""!($D(BGPQUIT))  D

 .I $Y>(IOSL-2) D PAGE Q:$D(BGPQUIT)

 .W !,$P(A(BGPX),U)," [",BGPX,"] ",$P(A(BGPX),U,2)

 .Q

DONE ;

 K BGPQUIT

 Q:$D(ZTQUEUED)

 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

THISRPT ;

 S BGPI=0 F  S BGPI=$O(BGPPLSTL(BGPI)) Q:BGPI'=+BGPI  D

 .S BGPM=0 F  S BGPM=$O(BGPPLSTL(BGPI,BGPM)) Q:BGPM'=+BGPM  D

 ..S BGPY=0 F  S BGPY=$O(^BGPCMSME(BGPI,11,"B",BGPY)) Q:BGPY'=+BGPY  D

 ...S BGPTYPE=$P(^BGPTAXE(BGPY,0),U,2),Y=$G(^BGPTAXE(BGPY,11,1,0)),BGPT=$P(^BGPTAXE(BGPY,0),U)

 ...I BGPTYPE'="L" D

 ....I '$D(^ATXAX("B",BGPT)) S A(BGPT)=Y_"^is Missing" Q

 ....S I=$O(^ATXAX("B",BGPT,0))

 ....I '$D(^ATXAX(I,21,"B")) S A(BGPT)=Y_"^has no entries "

 ...I BGPTYPE="L" D

 ....I '$D(^ATXLAB("B",BGPT)) S A(BGPT)=Y_"^is Missing " Q

 ....S I=$O(^ATXLAB("B",BGPT,0))

 ....I '$D(^ATXLAB(I,21,"B")) S A(BGPT)=Y_"^has no entries "

 I '$D(A) W !,"All taxonomies are present.",! K A,BGPX,Y,I,Z D DONE Q

 W !!,"In order for the CMS Report to find all necessary data, several",!,"taxonomies must be established.  The following taxonomies are missing or have",!,"no entries:"

 S BGPX="" F  S BGPX=$O(A(BGPX)) Q:BGPX=""!($D(BGPQUIT))  D

 .I $Y>(IOSL-2) D PAGE Q:$D(BGPQUIT)

 .W !,$P(A(BGPX),U)," [",BGPX,"] ",$P(A(BGPX),U,2)

 .Q

XIT ;EP

 K BGP,BGPX,BGPQUIT,BGPLINE,BGPJ,BGPX,BGPTEXT,BGP

 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 BGPQUIT="" Q

 Q

TAXS ;

 ;;BGP CMS AMI DXS

 ;;DM AUDIT ASPIRIN DRUGS

 ;;BGP CMS WARFARIN MEDS

 ;;BGP ANTI-PLATELET DRUGS

 ;;BGP CMS ANTI-PLATELET CLASS

 ;;BGP CMS LVSD DXS

 ;;BGP CMS EJECTION FRACTION PROC

 ;;BGP CMS EJECTION FRACTION CPTS

 ;;BGP CMS ACEI MEDS CLASS

 ;;BGP CMS ACEI MEDS

 ;;BGP ASA ALLERGY 995.0-995.3

 ;;BGP CMS AORTIC STENOSIS DXS

 ;;BGP CMS ARB MEDS CLASS

 ;;BGP CMS ARB MEDS

 ;;BGP CMS BETA BLOCKER MEDS

 ;;BGP CMS BETA BLOCKER CLASS

 ;;BGP CMS BETA BLOCKER NDC

 ;;BGP CMS BRADYCARDIA DXS

 ;;BGP CMS 2/3 HEART BLOCK DXS

 ;;BGP CMS HEART FAILURE DXS

 ;;BGP CMS CIRCULATORY SHOCK DXS

 ;;BGP CMS PNEUMONIA DXS

 ;;BGP CMS SEPTI/RESP FAIL DXS

 ;;BGP CMS ABG CPTS

 ;;BGP CMS ANTIBIOTIC MEDS

 ;;BGP CMS ANTIBIOTICS MEDS CLASS

 ;;

LAB ;

 ;;BGP CMS ABG TESTS

 ;;

BGP8CTXC  ; IHS/CMI/LAB - TAXONOMY CHECK FOR FY04 CRS REPORT 18 Feb 2008 5:31 PM ;

 +1       ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008

 +2       ;

 +3       ;

 +4        DO HOME^%ZIS

 +5        IF $DATA(IOF)

               WRITE @IOF

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

ZIS       ;

 +1        SET XBRC=""

           SET XBRP="TAXCHK^BGP8CTXC"

           SET XBNS=""

           SET XBRX="XIT^BGP8CTXC"

 +2        DO ^XBDBQUE

 +3        DO XIT

 +4        QUIT 

TAXCHK    ;EP

 +1       ;D HOME^%ZIS

 +2        KILL BGPQUIT

GUICHK    ;EP

 +1        WRITE !,"Checking for Taxonomies to support the CMS Report...",!

 +2        NEW A,BGPX,I,Y,Z,J,BGPY,BGPT,BGPI,BGPM

 +3        KILL A

 +4       ;version 8.0

 +5        IF $DATA(BGPPLSTL)

               DO THISRPT

               QUIT 

 +6        SET BGPT=""

           FOR 

               SET BGPT=$ORDER(^BGPTAXE("B",BGPT))

               IF BGPT=""

                   QUIT 

               Begin DoDot:1

 +7                SET BGPY=$ORDER(^BGPTAXE("B",BGPT,0))

 +8                IF '$DATA(^BGPTAXE(BGPY,12,"B",5))

                       QUIT 

 +9                SET BGPTYPE=$PIECE(^BGPTAXE(BGPY,0),U,2)

                   SET Y=$GET(^BGPTAXE(BGPY,11,1,0))

 +10               IF BGPTYPE'="L"

                       Begin DoDot:2

 +11                       IF '$DATA(^ATXAX("B",BGPT))

                               SET A(BGPT)=Y_"^is Missing"

                               QUIT 

 +12                       SET I=$ORDER(^ATXAX("B",BGPT,0))

 +13                       IF '$DATA(^ATXAX(I,21,"B"))

                               SET A(BGPT)=Y_"^has no entries "

                       End DoDot:2

 +14               IF BGPTYPE="L"

                       Begin DoDot:2

 +15                       IF '$DATA(^ATXLAB("B",BGPT))

                               SET A(BGPT)=Y_"^is Missing "

                               QUIT 

 +16                       SET I=$ORDER(^ATXLAB("B",BGPT,0))

 +17                       IF '$DATA(^ATXLAB(I,21,"B"))

                               SET A(BGPT)=Y_"^has no entries "

                       End DoDot:2

               End DoDot:1

 +18       IF '$DATA(A)

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

               KILL A,BGPX,Y,I,Z

               DO DONE

               QUIT 

 +19       WRITE !!,"In order for the CMS Report to find all necessary data, several",!,"taxonomies must be established.  The following taxonomies are missing or have",!,"no entries:"

 +20       SET BGPX=""

           FOR 

               SET BGPX=$ORDER(A(BGPX))

               IF BGPX=""!($DATA(BGPQUIT))

                   QUIT 

               Begin DoDot:1

 +21               IF $Y>(IOSL-2)

                       DO PAGE

                       IF $DATA(BGPQUIT)

                           QUIT 

 +22               WRITE !,$PIECE(A(BGPX),U)," [",BGPX,"] ",$PIECE(A(BGPX),U,2)

 +23               QUIT 

               End DoDot:1

DONE      ;

 +1        KILL BGPQUIT

 +2        IF $DATA(ZTQUEUED)

               QUIT 

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

 +4        QUIT 

THISRPT   ;

 +1        SET BGPI=0

           FOR 

               SET BGPI=$ORDER(BGPPLSTL(BGPI))

               IF BGPI'=+BGPI

                   QUIT 

               Begin DoDot:1

 +2                SET BGPM=0

                   FOR 

                       SET BGPM=$ORDER(BGPPLSTL(BGPI,BGPM))

                       IF BGPM'=+BGPM

                           QUIT 

                       Begin DoDot:2

 +3                        SET BGPY=0

                           FOR 

                               SET BGPY=$ORDER(^BGPCMSME(BGPI,11,"B",BGPY))

                               IF BGPY'=+BGPY

                                   QUIT 

                               Begin DoDot:3

 +4                                SET BGPTYPE=$PIECE(^BGPTAXE(BGPY,0),U,2)

                                   SET Y=$GET(^BGPTAXE(BGPY,11,1,0))

                                   SET BGPT=$PIECE(^BGPTAXE(BGPY,0),U)

 +5                                IF BGPTYPE'="L"

                                       Begin DoDot:4

 +6                                        IF '$DATA(^ATXAX("B",BGPT))

                                               SET A(BGPT)=Y_"^is Missing"

                                               QUIT 

 +7                                        SET I=$ORDER(^ATXAX("B",BGPT,0))

 +8                                        IF '$DATA(^ATXAX(I,21,"B"))

                                               SET A(BGPT)=Y_"^has no entries "

                                       End DoDot:4

 +9                                IF BGPTYPE="L"

                                       Begin DoDot:4

 +10                                       IF '$DATA(^ATXLAB("B",BGPT))

                                               SET A(BGPT)=Y_"^is Missing "

                                               QUIT 

 +11                                       SET I=$ORDER(^ATXLAB("B",BGPT,0))

 +12                                       IF '$DATA(^ATXLAB(I,21,"B"))

                                               SET A(BGPT)=Y_"^has no entries "

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13       IF '$DATA(A)

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

               KILL A,BGPX,Y,I,Z

               DO DONE

               QUIT 

 +14       WRITE !!,"In order for the CMS Report to find all necessary data, several",!,"taxonomies must be established.  The following taxonomies are missing or have",!,"no entries:"

 +15       SET BGPX=""

           FOR 

               SET BGPX=$ORDER(A(BGPX))

               IF BGPX=""!($DATA(BGPQUIT))

                   QUIT 

               Begin DoDot:1

 +16               IF $Y>(IOSL-2)

                       DO PAGE

                       IF $DATA(BGPQUIT)

                           QUIT 

 +17               WRITE !,$PIECE(A(BGPX),U)," [",BGPX,"] ",$PIECE(A(BGPX),U,2)

 +18               QUIT 

               End DoDot:1

XIT       ;EP

 +1        KILL BGP,BGPX,BGPQUIT,BGPLINE,BGPJ,BGPX,BGPTEXT,BGP

 +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 BGPQUIT=""

                       QUIT 

 +2        QUIT 

TAXS      ;

 +1       ;;BGP CMS AMI DXS

 +2       ;;DM AUDIT ASPIRIN DRUGS

 +3       ;;BGP CMS WARFARIN MEDS

 +4       ;;BGP ANTI-PLATELET DRUGS

 +5       ;;BGP CMS ANTI-PLATELET CLASS

 +6       ;;BGP CMS LVSD DXS

 +7       ;;BGP CMS EJECTION FRACTION PROC

 +8       ;;BGP CMS EJECTION FRACTION CPTS

 +9       ;;BGP CMS ACEI MEDS CLASS

 +10      ;;BGP CMS ACEI MEDS

 +11      ;;BGP ASA ALLERGY 995.0-995.3

 +12      ;;BGP CMS AORTIC STENOSIS DXS

 +13      ;;BGP CMS ARB MEDS CLASS

 +14      ;;BGP CMS ARB MEDS

 +15      ;;BGP CMS BETA BLOCKER MEDS

 +16      ;;BGP CMS BETA BLOCKER CLASS

 +17      ;;BGP CMS BETA BLOCKER NDC

 +18      ;;BGP CMS BRADYCARDIA DXS

 +19      ;;BGP CMS 2/3 HEART BLOCK DXS

 +20      ;;BGP CMS HEART FAILURE DXS

 +21      ;;BGP CMS CIRCULATORY SHOCK DXS

 +22      ;;BGP CMS PNEUMONIA DXS

 +23      ;;BGP CMS SEPTI/RESP FAIL DXS

 +24      ;;BGP CMS ABG CPTS

 +25      ;;BGP CMS ANTIBIOTIC MEDS

 +26      ;;BGP CMS ANTIBIOTICS MEDS CLASS

 +27      ;;

LAB       ;

 +1       ;;BGP CMS ABG TESTS

 +2       ;;