Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP0XTCN

BGP0XTCN.m

Go to the documentation of this file.
  1. BGP0XTCN ; IHS/CMI/LAB - TAXONOMY CHECK FOR FY04 CRS REPORT ;
  1. ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  1. ;
  1. ;
  1. D HOME^%ZIS
  1. W:$D(IOF) @IOF
  1. W !!,"Checking for Taxonomies to support the National GPRA & PART/GPRA & PART Performance Reports.",!,"Please enter the device for printing.",!
  1. ZIS ;
  1. S BGPTCO=1
  1. S XBRC="",XBRP="TAXCHK^BGP0XTCN",XBNS="BGPTCO",XBRX="XIT^BGP0XTCN"
  1. D ^XBDBQUE
  1. D XIT
  1. Q
  1. TAXCHK ;EP
  1. ;D HOME^%ZIS
  1. ;W:$D(IOF) @IOF
  1. K BGPQUIT
  1. GUICHK ;EP
  1. W !,"Checking for Taxonomies to support the "
  1. W $S($G(BGPTCO)=1:"National GPRA & PART/GPRA & PART Performance Reports...",'$G(BGP0GPU):"National GPRA & PART Report...",1:"GPRA & PART Performance Report..."),!
  1. NEW A,BGPX,I,Y,Z,J,BGPY,BGPT
  1. K A
  1. ;S T="TAXS" F J=1:1 S Z=$T(@T+J),BGPX=$P(Z,";;",2),Y=$P(Z,";;",3) Q:BGPX="" D
  1. S BGPT="" F S BGPT=$O(^BGPTAXT("B",BGPT)) Q:BGPT="" D
  1. .S BGPY=$O(^BGPTAXT("B",BGPT,0))
  1. .Q:'$D(^BGPTAXT(BGPY,12,"B",1))
  1. .;I $P(^BGPTAXT(BGPY,0),U,2)'="L" S BGPX=$O(^ATXAX("B",BGPT,0))
  1. .;I $P(^BGPTAXT(BGPY,0),U,2)="L" S BGPX=$O(^ATXLAB("B",BGPT,0))
  1. .S BGPTYPE=$P(^BGPTAXT(BGPY,0),U,2),Y=$G(^BGPTAXT(BGPY,11,1,0))
  1. .I BGPTYPE'="L" D
  1. ..I '$D(^ATXAX("B",BGPT)) S A(BGPT)=Y_"^is Missing" Q
  1. ..S I=$O(^ATXAX("B",BGPT,0))
  1. ..I '$D(^ATXAX(I,21,"B")) S A(BGPT)=Y_"^has no entries "
  1. .I BGPTYPE="L" D
  1. ..I '$D(^ATXLAB("B",BGPT)) S A(BGPT)=Y_"^is Missing " Q
  1. ..S I=$O(^ATXLAB("B",BGPT,0))
  1. ..I '$D(^ATXLAB(I,21,"B")) S A(BGPT)=Y_"^has no entries "
  1. I '$D(A) W !,"All taxonomies are present.",! K A,BGPX,Y,I,Z D DONE Q
  1. W !,"In order for the National GRPA & PART Report to find all necessary data, several",!,"taxonomies must be established. The following taxonomies are missing or have",!,"no entries:"
  1. S BGPX="" F S BGPX=$O(A(BGPX)) Q:BGPX=""!($D(BGPQUIT)) D
  1. .;I $Y>(IOSL-2) D PAGE Q:$D(BGPQUIT)
  1. .W !,$P(A(BGPX),U)," [",BGPX,"] ",$P(A(BGPX),U,2)
  1. .Q
  1. DONE ;
  1. K BGPQUIT
  1. Q:$D(ZTQUEUED)
  1. 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
  1. Q
  1. XIT ;EP
  1. K BGP,BGPX,BGPQUIT,BGPLINE,BGPJ,BGPX,BGPTEXT,BGP
  1. K X,Y,J
  1. Q
  1. PAGE ;
  1. 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
  1. Q