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