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

BGP5DLT.m

Go to the documentation of this file. 
  1. BGP5DLT ; IHS/CMI/LAB - national patient list 20 Dec 2004 9:24 AM ;
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1.  ;
  1.  ;
  1. START ;EP
  1.  I $G(BGPGUI) D  Q  ;cmi/maw added 10/30/2010
  1.  . S BGPPAGE=1
  1.  . S BGPSUBH="Lab Taxonomies for the: ",BGPSUBH1=BGPRPTN_" REPORT"
  1.  I '$G(BGPGUI) W:$D(IOF) @IOF  ;cmi/maw added 1/14/08
  1.  W !,$$CTR("Lab Taxonomy Report",80)
  1.  W !,$$CTR($$RPTVER^BGP5BAN,80)
  1. INTRO ;
  1.  W !!,"Site populated Lab Taxonomy Report for the: ",!?5,BGPRPTN," Report",!
  1.  S BGPSUBH="Lab Taxonomies for the: ",BGPSUBH1=BGPRPTN_" REPORT"
  1.  S BGPCTRL=$O(^BGPCTRL("B",2015,0))
  1.  S X=0 F  S X=$O(^BGPCTRL(BGPCTRL,43,X)) Q:X'=+X  W !,^BGPCTRL(BGPCTRL,43,X,0)
  1.  K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D XIT Q
  1.  I 'Y D XIT Q
  1. ZIS ;call to XBDBQUE
  1.  K ZTSK
  1.  K IOP,%ZIS S %ZIS="PQM" D ^%ZIS I POP S IO=IO(0) Q
  1.  G:$D(IO("Q")) QUE
  1. NOQUE ;
  1.  U IO
  1.  D PRINT
  1.  D ^%ZISC
  1.  D XIT
  1.  Q
  1. QUE ;
  1.  K ZTSAVE S ZTSAVE("BGP*")=""
  1.  S ZTRTN="PRINT^BGP5DLT",ZTDESC="BGP 15 LAB TAX REPORT",ZTIO=ION,ZTDTH=""
  1.  D ^%ZTLOAD
  1.  D HOME^%ZIS
  1.  D XIT
  1.  Q
  1. CMS ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="CMS",BGPRT(5)=""
  1.  D START
  1.  Q
  1. ELDER ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="ELDER CARE",BGPRT(4)=""
  1.  D START
  1.  Q
  1. HEDIS ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="HEDIS",BGPRT(3)=""
  1.  D START
  1.  Q
  1. CRS ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="SELECTED MEASURES (LOCAL)",BGPRT(2)=""
  1.  D START
  1.  Q
  1. ONM ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="OTHER NATIONAL MEASURES",BGPRT(7)=""
  1.  D START
  1.  Q
  1. GPRA ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="NATIONAL GPRA/GPRAMA and GPRA/GPRAMA PERFORMANCE",BGPRT(1)=""
  1.  D START
  1.  Q
  1. EO ;EP
  1.  I '$G(BGPGUI) D XIT  ;cmi/maw 10/30/2009
  1.  S BGPRPTN="EO QUALITY TRANSPARENCY MEASURES",BGPRT(8)=""
  1.  D START
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("BGP") I $D(ZTQUEUED) S ZTREQ="@"
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. PRINT ;
  1.  S (BGPPAGE,BGPQUIT)=0
  1.  S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
  1.  D HEADER
  1.  D N
  1.  D EOP
  1.  Q
  1. N ;GATHER UP AND DISPLAY ALL NATIONAL GPRA
  1.  S BGPC=0
  1.  I $Y>(BGPIOSL-5) D HEADER Q:BGPQUIT
  1.  S BGPTNAME="" F  S BGPTNAME=$O(^BGPTAXK("B",BGPTNAME)) Q:BGPTNAME=""!(BGPQUIT)  D
  1.  .S BGPTIEN=0,BGPTIEN=$O(^BGPTAXK("B",BGPTNAME,BGPTIEN))
  1.  .Q:'BGPTIEN  ;oops, error in xref
  1.  .Q:'$D(^BGPTAXK(BGPTIEN,0))  ;oops, error in xref
  1.  .Q:$P(^BGPTAXK(BGPTIEN,0),U,2)'="L"  ;only lab taxonomies in this report
  1.  .S (G,X)=0 F  S X=$O(^BGPTAXK(BGPTIEN,12,"B",X)) Q:X'=+X!(G)  D
  1.  ..I $D(BGPRT(X)) S G=1
  1.  .Q:'G
  1.  .;now eliminate those in BGPNO
  1.  .S (G,X)=0 F  S X=$O(^BGPTAXK(BGPTIEN,12,"B",X)) Q:X'=+X!(G)  D
  1.  ..I $D(BGPNO(X)) S G=1
  1.  .Q:G
  1.  .S BGPLTI=$O(^ATXLAB("B",BGPTNAME,0))
  1.  .S BGPC=BGPC+1
  1.  .I 'BGPLTI W !!?3,BGPC,".",?8,BGPTNAME,!?8,"WARNING - You are missing this taxonomy in the Lab Taxonomy file." Q
  1.  .;SET UP STRING OF ALL LAB TEST NAMES
  1.  .K BGPLABS S (BGPLC,BGPLC1)=0
  1.  .S BGPX=0 F  S BGPX=$O(^ATXLAB(BGPLTI,21,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..S X=$P($G(^LAB(60,BGPX,0)),U) D
  1.  ...Q:X=""
  1.  ...;I '(BGPLC#2) S BGPLC1=BGPLC1+1 S BGPLABS(BGPLC1)=X,BGPLC=BGPLC+1 Q
  1.  ...S BGPLC1=BGPLC1+1,BGPLABS(BGPLC1)=X
  1.  ...Q
  1.  ..Q
  1.  .I $Y>(BGPIOSL-5) D HEADER Q:BGPQUIT
  1.  .W !!?3,BGPC,".",?8,BGPTNAME,!?8,"Members: "
  1.  .I '$D(BGPLABS) W ?17,"NONE"
  1.  .S BGPY=0 F  S BGPY=$O(BGPLABS(BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-5) D HEADER Q:BGPQUIT
  1.  ..W:BGPY>1 ! W ?17,BGPY,")  ",BGPLABS(BGPY)
  1.  .Q
  1.  Q
  1.  G:'BGPPAGE HEADER1
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED),'$D(IO("S")) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQUIT=1 Q
  1. HEADER1 ;
  1.  S BGPPAGE=BGPPAGE+1
  1.  I BGPPAGE'=1 W:$D(IOF) @IOF
  1.  I $G(BGPGUI),BGPPAGE>1 W "ZZZZZZZ",!  ;maw
  1.  W $P(^VA(200,DUZ,0),U,2),?70,"Page ",BGPPAGE,!
  1.  W $$CTR("*** Lab Taxonomy Report ***",80),!
  1.  W $$CTR($$RPTVER^BGP5BAN,80),!
  1.  S X="Date Report Run: "_$$FMTE^XLFDT(DT) W $$CTR(X,80),!
  1.  S X="Site where Run: "_$P(^DIC(4,DUZ(2),0),U) W $$CTR(X,80),!
  1.  S X="Report Generated by: "_$P(^VA(200,DUZ,0),U) W $$CTR(X,80),!
  1.  ;
  1.  W !!,$$CTR(BGPSUBH1_" TAXONOMIES",80),! ;,$$CTR(BGPSUBH1,80),!
  1.  S X=$$REPEAT^XLFSTR("-",80) W !,X
  1.  W !
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIR,DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  W ! S DIR("A")="End of report.  Press ENTER to continue",DIR(0)="E" D ^DIR KILL DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1.  ;