BGPDFTA ; IHS/CMI/LAB - IHS area GPRA ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
;
W:$D(IOF) @IOF
W !!,$$CTR("IHS GPRA Indicator Report - for Export to Area",80)
INTRO ;
D EXIT
W !!,"This report will produce a GPRA Indicator Report for a Fiscal Year or Quarter",!,"that you specify.",!,"You will be asked to provide the baseline year and also to specify",!
W "the community taxonomy to be used.",!!
W "This option will produce a report in export format for the Area Office to use",!,"in Area aggregated data. Depending on site-specific configuration, the",!
W "export file will either be automatically transmitted directly to the Area or ",!,"the site will have to send the file manually.",!
W !,"You will be provided the opportunity to have lists of patients printed for",!,"the indicators. Please be careful when answering this questions as the",!,"lists can be very long and use lots of paper.",!
D TAXCHK^BGPDT
DATES ;
S BGPFTA=1
K BGPBD,BGPED,BGPPER
S BGPQTR=0
D Y
I $D(BGPQUIT) D EXIT Q
S BGPQY=""
S DIR(0)="S^Q:One Quarter in FY "_$$FMTE^XLFDT(BGPPER)_";F:Full Fiscal Year",DIR("A")="Run the report for a",DIR("B")="Q" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
S BGPQY=Y
I BGPQY="Q" D Q I $D(BGPQUIT) G DATES
BY ;get baseline year
W !
S BGPVDT=""
W !,"Enter the Baseline Year that you would like to compare the data to.",!,"Use a 4 digit year, e.g. 1999, 2000"
S DIR(0)="D^::EP"
S DIR("A")="Enter Year (e.g. 1999)"
D ^DIR
K DIC
I $D(DUOUT) S DIRUT=1 G DATES
S BGPVDT=Y
I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G BY
I BGPQTR=0 S BGPBBD=($E(BGPVDT,1,3)-1)_"1001",BGPBED=$E(BGPVDT,1,3)_"0930" G N
I BGPQTR=1 S BGPBBD=($E(BGPVDT,1,3)-1)_"1001",BGPBED=($E(BGPVDT,1,3)-1)_"1231" G N
I BGPQTR=2 S BGPBBD=$E(BGPVDT,1,3)_"0101",BGPBED=$E(BGPVDT,1,3)_"0331" G N
I BGPQTR=3 S BGPBBD=$E(BGPVDT,1,3)_"0401",BGPBED=$E(BGPVDT,1,3)_"0630" G N
I BGPQTR=4 S BGPBBD=$E(BGPVDT,1,3)_"0701",BGPBED=$E(BGPVDT,1,3)_"0930" G N
N S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)
S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)
W !!,"The date ranges for this report are:"
W !?5,"Reporting Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)
W !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)
W !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)
COMM ;
W !!,"You must now specify the community taxonomy to use when determining which",!,"patients will be included in the GPRA report. You should have created",!,"this taxonomy using QMAN or some other software.",!
K BGPTAX
S BGPX=""
D ^XBFMK
S DIC("S")="I $P(^(0),U,15)=9999999.05",DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Community Taxonomy: " D ^DIC
I Y=-1 G INTRO
S BGPX=+Y
COM1 S X=0
F S X=$O(^ATXAX(BGPX,21,X)) Q:'X D
.S BGPTAX($P(^ATXAX(BGPX,21,X,0),U))=""
.Q
I '$D(BGPTAX) W !!,"There are no communities in that taxonomy." G COMM
HOME ;
K DIC S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Please enter the Location for HOME Visits: " D ^DIC
I Y=-1 W !,"No HOME Location entered!!! PHN Visits counts to Home will be calculated",!,"using clinic 11 only!!" H 2 S BGPHOME="" G LISTS
S BGPHOME=+Y
LISTS ;any lists with indicators?
F X=1:1:35 S BGPIND(X)="" ;all indicators
K BGPIND(23) ;no indicator 23 this version
W !!
K BGPLIST
S DIR(0)="Y",DIR("A")="Do you want any individual lists for the indicators",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT)!(Y="") G HOME
I Y=0 G ZIS
K BGPLIST
D EN^BGPDL
I '$D(BGPLIST) W !!,"No lists selected.",!
ZIS ;call to XBDBQUE
;CREATE REPORT ENTRY IN FILEMAN FILE
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPD(",DLAYGO=90240.01,DIADD=1
S DIC("DR")=".02////"_BGPED_";.03////"_BGPPER_";.04///"_BGPQTR_";.05////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.06////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.08////"_BGPBBD_";.09////"_BGPBED
D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S BGPQUIT=1 D EXIT Q
S BGPRPT=+Y
;add communities to 28 multiple
K ^BGPD(BGPRPT,28)
S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPD(BGPRPT,28,C,0)=X,^BGPD(BGPRPT,28,"B",X,C)=""
S ^BGPD(BGPRPT,28,0)="^19257.28A^"_C_"^"_C
D ^XBFMK
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
W !!,"A file will be created called BG",$P(^AUTTLOC(DUZ(2),0),U,10)_"."_BGPRPT," and will reside",!,"in the export/public directory.",!
W !,"Depending on your site configuration, this file may need to be manually",!,"sent to your Area Office.",!
;
W !! S %ZIS="PQM" D ^%ZIS
I POP W !,"Report Aborted" S DA=BGPRPT,DIK="^BGPD(" D ^DIK K DIK D EXIT Q
I $D(IO("Q")) G TSKMN
DRIVER ;
D ^BGPD1
U IO
D ^BGPDP
D ^%ZISC
D GS
D EXIT
Q
;
TSKMN ;EP ENTRY POINT FROM TASKMAN
S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))
I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
K ZTSAVE S ZTSAVE("BGP*")=""
S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^BGPDFTA",ZTDTH="",ZTDESC="GPRA REPORT" D ^%ZTLOAD D EXIT Q
EXIT1 ;
D HOME^%ZIS
K IOPAR
D GS
EXIT ;
D EN^XBVK("BGP")
K X,X1,X2,X3,X4,X5,X6
K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
K N,N1,N2,N3,N4,N5,N6
D KILL^AUPNPAT
D ^XBFMK
D HOME^%ZIS
Q
;
SET6 ;
I $G(^BGPD(BGPRPT,X,X2,X3,X4,X5,X6))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",6)=X6,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4,X5,X6)
Q
GS ;EP called from xbnew
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
;NOTE: Kill of unscripted global. Export to area. Using standar name.
K ^BGPDATA S X="",C=0 F S X=$O(^BGPD(BGPRPT,X)) Q:X'=+X D
.I $G(^BGPD(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X)
.S X2="" F S X2=$O(^BGPD(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPD(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPD(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPD(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPD(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPD(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPD(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPD(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4,X5)
.....S X6="" F S X6=$O(^BGPD(BGPRPT,X,X2,X3,X4,X5,X6)) Q:X6'=+X6 D SET6
S XBGL="BGPDATA"
S F="BG"_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_BGPRPT
S XBMED="F",XBFN=F,XBTLE="SAVE OF GPRA DATA BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBFLT=1
D ^XBGSAVE
L -^BGPDATA
K ^TMP($J),^BGPDATA ;NOTE: kill of unsubscripted global for use in export to area.
Q
Q ;which quarter
S DIR(0)="N^1:4:0",DIR("A")="Which Quarter" KILL DA D ^DIR KILL DIR
I $D(DIRUT)!(Y="") S BGPQUIT="" Q
S BGPQTR=Y
I Y=1 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=($E(BGPPER,1,3)-1)_"1231" Q
I Y=2 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"0331" Q
I Y=3 S BGPBD=$E(BGPPER,1,3)_"0401",BGPED=$E(BGPPER,1,3)_"0630" Q
I Y=4 S BGPBD=$E(BGPPER,1,3)_"0701",BGPED=$E(BGPPER,1,3)_"0930" Q
Q
Y ;fiscal year
W !
S BGPVDT=""
W !,"Enter the FY of interest. Use a 4 digit year, e.g. 1999, 2000"
S DIR(0)="D^::EP"
S DIR("A")="Enter Fiscal year (e.g. 1999)"
S DIR("?")="This report is compiled for a period. Enter a valid date."
D ^DIR
K DIC
I $D(DUOUT) S DIRUT=1 S BGPQUIT="" Q
S BGPVDT=Y
I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G Y
S BGPPER=BGPVDT,BGPBD=($E(BGPVDT,1,3)-1)_"1001",BGPED=$E(BGPVDT,1,3)_"0930"
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 DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^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")
;----------
;
INDSL ;;
;;1C Diabetes Prevalence - List of Patients with a Diabetes Diagnosis
;;1C Diabetes Incidence - List Patients Newly Diagnoses with Diabetes
;;2C Diabetes - List Diabetics and their Glycemic Control
;;3C Diabetes - List Diabetics/Hypertensives and their BP
;;4 Diabetes - List Diabetics and whether they had a an LDL
;;4 Diabetes - List Diabetics with LDL>130 or TG>200
;;5 Diabetes - List Diabetics and whether they had a Urine Protein
;;5 Diabetes - List Diabetics with Microalbuminuria >30
;;6C Women's Health - List Women over 17 and whether they had a Pap
;;7C Women's Health - List women 40 and over and whether they had a Mammogram
;;7CC Women's Health - List women over 17 and whether they had a Brast Exam
;;8 Child Health - List Patients w/ 4 Well Child Visits by 27 months of age
;;10 Fetal Alcohol Syndrome - List Women w/ Prenatal Risk Screening
;;12 Dental Health - List Patients with Access to Dental Services
;;13 Dental Health - List Patients who Received Dental Sealants
;;23 Child Health Immunization - List 2 mon/o Pts w/ Immunization Status
;;24 List all Patient Injuries
;;29C Child Health - List Obese Children
;;24 Adult Immunizations - List Patients >65 with Pneumovax Status
;;24 Adult Immunizations - List Pts >65 with Flu Shot Status in Past yr
;;30C Smoking Prevalence - List Current Tobacco Users
;;C1 Mental Health - List Diabetic Patients w/depressive disorder
;;C2 Prostate Cancer - List males 40 yr/age and over and DRE status
;;C3 Colorectal Cancer - List patients over 44 and annual screening status
;;END
BGPDFTA ; IHS/CMI/LAB - IHS area GPRA ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!,$$CTR("IHS GPRA Indicator Report - for Export to Area",80)
INTRO ;
+1 DO EXIT
+2 WRITE !!,"This report will produce a GPRA Indicator Report for a Fiscal Year or Quarter",!,"that you specify.",!,"You will be asked to provide the baseline year and also to specify",!
+3 WRITE "the community taxonomy to be used.",!!
+4 WRITE "This option will produce a report in export format for the Area Office to use",!,"in Area aggregated data. Depending on site-specific configuration, the",!
+5 WRITE "export file will either be automatically transmitted directly to the Area or ",!,"the site will have to send the file manually.",!
+6 WRITE !,"You will be provided the opportunity to have lists of patients printed for",!,"the indicators. Please be careful when answering this questions as the",!,"lists can be very long and use lots of paper.",!
+7 DO TAXCHK^BGPDT
DATES ;
+1 SET BGPFTA=1
+2 KILL BGPBD,BGPED,BGPPER
+3 SET BGPQTR=0
+4 DO Y
+5 IF $DATA(BGPQUIT)
DO EXIT
QUIT
+6 SET BGPQY=""
+7 SET DIR(0)="S^Q:One Quarter in FY "_$$FMTE^XLFDT(BGPPER)_";F:Full Fiscal Year"
SET DIR("A")="Run the report for a"
SET DIR("B")="Q"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
DO EXIT
QUIT
+9 SET BGPQY=Y
+10 IF BGPQY="Q"
DO Q
IF $DATA(BGPQUIT)
GOTO DATES
BY ;get baseline year
+1 WRITE !
+2 SET BGPVDT=""
+3 WRITE !,"Enter the Baseline Year that you would like to compare the data to.",!,"Use a 4 digit year, e.g. 1999, 2000"
+4 SET DIR(0)="D^::EP"
+5 SET DIR("A")="Enter Year (e.g. 1999)"
+6 DO ^DIR
+7 KILL DIC
+8 IF $DATA(DUOUT)
SET DIRUT=1
GOTO DATES
+9 SET BGPVDT=Y
+10 IF $EXTRACT(Y,4,7)'="0000"
WRITE !!,"Please enter a year only!",!
GOTO BY
+11 IF BGPQTR=0
SET BGPBBD=($EXTRACT(BGPVDT,1,3)-1)_"1001"
SET BGPBED=$EXTRACT(BGPVDT,1,3)_"0930"
GOTO N
+12 IF BGPQTR=1
SET BGPBBD=($EXTRACT(BGPVDT,1,3)-1)_"1001"
SET BGPBED=($EXTRACT(BGPVDT,1,3)-1)_"1231"
GOTO N
+13 IF BGPQTR=2
SET BGPBBD=$EXTRACT(BGPVDT,1,3)_"0101"
SET BGPBED=$EXTRACT(BGPVDT,1,3)_"0331"
GOTO N
+14 IF BGPQTR=3
SET BGPBBD=$EXTRACT(BGPVDT,1,3)_"0401"
SET BGPBED=$EXTRACT(BGPVDT,1,3)_"0630"
GOTO N
+15 IF BGPQTR=4
SET BGPBBD=$EXTRACT(BGPVDT,1,3)_"0701"
SET BGPBED=$EXTRACT(BGPVDT,1,3)_"0930"
GOTO N
N SET BGPPBD=($EXTRACT(BGPBD,1,3)-1)_$EXTRACT(BGPBD,4,7)
+1 SET BGPPED=($EXTRACT(BGPED,1,3)-1)_$EXTRACT(BGPED,4,7)
+2 WRITE !!,"The date ranges for this report are:"
+3 WRITE !?5,"Reporting Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)
+4 WRITE !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)
+5 WRITE !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)
COMM ;
+1 WRITE !!,"You must now specify the community taxonomy to use when determining which",!,"patients will be included in the GPRA report. You should have created",!,"this taxonomy using QMAN or some other software.",!
+2 KILL BGPTAX
+3 SET BGPX=""
+4 DO ^XBFMK
+5 SET DIC("S")="I $P(^(0),U,15)=9999999.05"
SET DIC="^ATXAX("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Community Taxonomy: "
DO ^DIC
+6 IF Y=-1
GOTO INTRO
+7 SET BGPX=+Y
COM1 SET X=0
+1 FOR
SET X=$ORDER(^ATXAX(BGPX,21,X))
IF 'X
QUIT
Begin DoDot:1
+2 SET BGPTAX($PIECE(^ATXAX(BGPX,21,X,0),U))=""
+3 QUIT
End DoDot:1
+4 IF '$DATA(BGPTAX)
WRITE !!,"There are no communities in that taxonomy."
GOTO COMM
HOME ;
+1 KILL DIC
SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
SET DIC("A")="Please enter the Location for HOME Visits: "
DO ^DIC
+2 IF Y=-1
WRITE !,"No HOME Location entered!!! PHN Visits counts to Home will be calculated",!,"using clinic 11 only!!"
HANG 2
SET BGPHOME=""
GOTO LISTS
+3 SET BGPHOME=+Y
LISTS ;any lists with indicators?
+1 ;all indicators
FOR X=1:1:35
SET BGPIND(X)=""
+2 ;no indicator 23 this version
KILL BGPIND(23)
+3 WRITE !!
+4 KILL BGPLIST
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want any individual lists for the indicators"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)!(Y="")
GOTO HOME
+7 IF Y=0
GOTO ZIS
+8 KILL BGPLIST
+9 DO EN^BGPDL
+10 IF '$DATA(BGPLIST)
WRITE !!,"No lists selected.",!
ZIS ;call to XBDBQUE
+1 ;CREATE REPORT ENTRY IN FILEMAN FILE
+2 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPD("
SET DLAYGO=90240.01
SET DIADD=1
+3 SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPER_";.04///"_BGPQTR_";.05////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.06////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.08////"_BGPBBD_";.09////"_BGPBED
+4 DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET BGPQUIT=1
DO EXIT
QUIT
+5 SET BGPRPT=+Y
+6 ;add communities to 28 multiple
+7 KILL ^BGPD(BGPRPT,28)
+8 SET C=0
SET X=""
FOR
SET X=$ORDER(BGPTAX(X))
IF X=""
QUIT
SET C=C+1
SET ^BGPD(BGPRPT,28,C,0)=X
SET ^BGPD(BGPRPT,28,"B",X,C)=""
+9 SET ^BGPD(BGPRPT,28,0)="^19257.28A^"_C_"^"_C
+10 DO ^XBFMK
+11 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+12 WRITE !!,"A file will be created called BG",$PIECE(^AUTTLOC(DUZ(2),0),U,10)_"."_BGPRPT," and will reside",!,"in the export/public directory.",!
+13 WRITE !,"Depending on your site configuration, this file may need to be manually",!,"sent to your Area Office.",!
+14 ;
+15 WRITE !!
SET %ZIS="PQM"
DO ^%ZIS
+16 IF POP
WRITE !,"Report Aborted"
SET DA=BGPRPT
SET DIK="^BGPD("
DO ^DIK
KILL DIK
DO EXIT
QUIT
+17 IF $DATA(IO("Q"))
GOTO TSKMN
DRIVER ;
+1 DO ^BGPD1
+2 USE IO
+3 DO ^BGPDP
+4 DO ^%ZISC
+5 DO GS
+6 DO EXIT
+7 QUIT
+8 ;
TSKMN ;EP ENTRY POINT FROM TASKMAN
+1 SET ZTIO=$SELECT($DATA(ION):ION,1:IO)
IF $DATA(IOST)#2
IF IOST]""
SET ZTIO=ZTIO_";"_IOST
+2 IF $GET(IO("DOC"))]""
SET ZTIO=ZTIO_";"_$GET(IO("DOC"))
+3 IF $DATA(IOM)#2
IF IOM
SET ZTIO=ZTIO_";"_IOM
IF $DATA(IOSL)#2
IF IOSL
SET ZTIO=ZTIO_";"_IOSL
+4 KILL ZTSAVE
SET ZTSAVE("BGP*")=""
+5 SET ZTCPU=$GET(IOCPU)
SET ZTRTN="DRIVER^BGPDFTA"
SET ZTDTH=""
SET ZTDESC="GPRA REPORT"
DO ^%ZTLOAD
DO EXIT
QUIT
EXIT1 ;
+1 DO HOME^%ZIS
+2 KILL IOPAR
+3 DO GS
EXIT ;
+1 DO EN^XBVK("BGP")
+2 KILL X,X1,X2,X3,X4,X5,X6
+3 KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+4 KILL N,N1,N2,N3,N4,N5,N6
+5 DO KILL^AUPNPAT
+6 DO ^XBFMK
+7 DO HOME^%ZIS
+8 QUIT
+9 ;
SET6 ;
+1 IF $GET(^BGPD(BGPRPT,X,X2,X3,X4,X5,X6))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+2 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",6)=X6
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4,X5,X6)
+3 QUIT
GS ;EP called from xbnew
+1 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+2 ;NOTE: Kill of unscripted global. Export to area. Using standar name.
+3 KILL ^BGPDATA
SET X=""
SET C=0
FOR
SET X=$ORDER(^BGPD(BGPRPT,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF $GET(^BGPD(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X)
+5 SET X2=""
FOR
SET X2=$ORDER(^BGPD(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+6 IF $GET(^BGPD(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2)
+7 SET X3=""
FOR
SET X3=$ORDER(^BGPD(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+8 IF $GET(^BGPD(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3)
+9 SET X4=""
FOR
SET X4=$ORDER(^BGPD(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+10 IF $GET(^BGPD(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4)
+11 SET X5=""
FOR
SET X5=$ORDER(^BGPD(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+12 IF $GET(^BGPD(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+13 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPD(BGPRPT,X,X2,X3,X4,X5)
+14 SET X6=""
FOR
SET X6=$ORDER(^BGPD(BGPRPT,X,X2,X3,X4,X5,X6))
IF X6'=+X6
QUIT
DO SET6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET XBGL="BGPDATA"
+16 SET F="BG"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_"."_BGPRPT
+17 SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF GPRA DATA BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBFLT=1
+18 DO ^XBGSAVE
+19 LOCK -^BGPDATA
+20 ;NOTE: kill of unsubscripted global for use in export to area.
KILL ^TMP($JOB),^BGPDATA
+21 QUIT
Q ;which quarter
+1 SET DIR(0)="N^1:4:0"
SET DIR("A")="Which Quarter"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)!(Y="")
SET BGPQUIT=""
QUIT
+3 SET BGPQTR=Y
+4 IF Y=1
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=($EXTRACT(BGPPER,1,3)-1)_"1231"
QUIT
+5 IF Y=2
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
QUIT
+6 IF Y=3
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
QUIT
+7 IF Y=4
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
QUIT
+8 QUIT
Y ;fiscal year
+1 WRITE !
+2 SET BGPVDT=""
+3 WRITE !,"Enter the FY of interest. Use a 4 digit year, e.g. 1999, 2000"
+4 SET DIR(0)="D^::EP"
+5 SET DIR("A")="Enter Fiscal year (e.g. 1999)"
+6 SET DIR("?")="This report is compiled for a period. Enter a valid date."
+7 DO ^DIR
+8 KILL DIC
+9 IF $DATA(DUOUT)
SET DIRUT=1
SET BGPQUIT=""
QUIT
+10 SET BGPVDT=Y
+11 IF $EXTRACT(Y,4,7)'="0000"
WRITE !!,"Please enter a year only!",!
GOTO Y
+12 SET BGPPER=BGPVDT
SET BGPBD=($EXTRACT(BGPVDT,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPVDT,1,3)_"0930"
+13 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 DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^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 ;
INDSL ;;
+1 ;;1C Diabetes Prevalence - List of Patients with a Diabetes Diagnosis
+2 ;;1C Diabetes Incidence - List Patients Newly Diagnoses with Diabetes
+3 ;;2C Diabetes - List Diabetics and their Glycemic Control
+4 ;;3C Diabetes - List Diabetics/Hypertensives and their BP
+5 ;;4 Diabetes - List Diabetics and whether they had a an LDL
+6 ;;4 Diabetes - List Diabetics with LDL>130 or TG>200
+7 ;;5 Diabetes - List Diabetics and whether they had a Urine Protein
+8 ;;5 Diabetes - List Diabetics with Microalbuminuria >30
+9 ;;6C Women's Health - List Women over 17 and whether they had a Pap
+10 ;;7C Women's Health - List women 40 and over and whether they had a Mammogram
+11 ;;7CC Women's Health - List women over 17 and whether they had a Brast Exam
+12 ;;8 Child Health - List Patients w/ 4 Well Child Visits by 27 months of age
+13 ;;10 Fetal Alcohol Syndrome - List Women w/ Prenatal Risk Screening
+14 ;;12 Dental Health - List Patients with Access to Dental Services
+15 ;;13 Dental Health - List Patients who Received Dental Sealants
+16 ;;23 Child Health Immunization - List 2 mon/o Pts w/ Immunization Status
+17 ;;24 List all Patient Injuries
+18 ;;29C Child Health - List Obese Children
+19 ;;24 Adult Immunizations - List Patients >65 with Pneumovax Status
+20 ;;24 Adult Immunizations - List Pts >65 with Flu Shot Status in Past yr
+21 ;;30C Smoking Prevalence - List Current Tobacco Users
+22 ;;C1 Mental Health - List Diabetic Patients w/depressive disorder
+23 ;;C2 Prostate Cancer - List males 40 yr/age and over and DRE status
+24 ;;C3 Colorectal Cancer - List patients over 44 and annual screening status
+25 ;;END
