BUD4TXCH ; 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 2004 UDS Report. ",!,"Please enter the device for printing.",!
ZIS ;
S XBRC="",XBRP="TAXCHK^BUD4TXCH",XBNS="",XBRX="XIT^BUD4TXCH"
D ^XBDBQUE
D XIT
Q
TAXCHK ;EP
D HOME^%ZIS
K BUDQUIT
W !,"Checking for Taxonomies to support the 2004 UDS Report...",!
NEW A,BUDX,I,Y,Z,J
K A
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 "
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 '$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 04;;Pap CPTs Taxonomy
;;BGP PAP LOINC CODES
;;
LAB ;
;;BGP PAP SMEAR TAX
;;BGP HIV TEST TAX
;;
BUD4TXCH ; 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 2004 UDS Report. ",!,"Please enter the device for printing.",!
ZIS ;
+1 SET XBRC=""
SET XBRP="TAXCHK^BUD4TXCH"
SET XBNS=""
SET XBRX="XIT^BUD4TXCH"
+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 2004 UDS Report...",!
+4 NEW A,BUDX,I,Y,Z,J
+5 KILL A
+6 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 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 '$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 04;;Pap CPTs Taxonomy
+6 ;;BGP PAP LOINC CODES
+7 ;;
LAB ;
+1 ;;BGP PAP SMEAR TAX
+2 ;;BGP HIV TEST TAX
+3 ;;
