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