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

BGPDAREA.m

Go to the documentation of this file. 
  1. BGPDAREA ; IHS/CMI/LAB - ihs area GPRA ;
  1.  ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1.  ;
  1.  ;
  1.  ;IHS/CMI/LAB - patch 1 modified to allow July-June report
  1.  W:$D(IOF) @IOF
  1.  S BGPA=$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2),BGPA=$O(^AUTTAREA("C",BGPA,0)) S BGPA=$S(BGPA:$P(^AUTTAREA(BGPA,0),U),1:"UNKNOWN AREA")
  1.  W !!,$$CTR(BGPA_" Area GPRA Report",80)
  1. INTRO ;
  1.  D EXIT
  1.  S BGPAREAA=1
  1. DATES ;
  1.  K BGPBD,BGPED,BGPPER
  1.  S BGPQTR=0
  1.  D Y
  1.  I $D(BGPQUIT) D EXIT Q
  1.  S BGPQY=""
  1.  S DIR(0)="S^Q:One Quarter in FY "_$$FMTE^XLFDT(BGPPER)_";F:Full Fiscal Year;A:AREA REPORTING YEAR (July 1 - June 30)",DIR("A")="Run the report for a",DIR("B")="Q" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S BGPQY=Y
  1.  I BGPQY="F"!(BGPQY="Q") S BGPBD=($E(BGPVDT,1,3)-1)_"1001",BGPED=$E(BGPVDT,1,3)_"0930"
  1.  I BGPQY="A" S BGPBD=($E(BGPVDT,1,3)-1)_"0701",BGPED=$E(BGPVDT,1,3)_"0630"
  1.  I BGPQY="Q" D Q I $D(BGPQUIT) G INTRO
  1. BY ;get baseline year
  1.  W !
  1.  S BGPVDT=""
  1.  W !,"Enter the Baseline Year that you would like to compare the data to.",!,"Use a 4 digit year, e.g. 1999, 2000"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter Year (e.g. 1999)"
  1.  D ^DIR
  1.  K DIC
  1.  I $D(DUOUT) S DIRUT=1 G DATES
  1.  S BGPVDT=Y
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G BY
  1.  I BGPQTR=0,BGPQY="F" S BGPBBD=($E(BGPVDT,1,3)-1)_"1001",BGPBED=$E(BGPVDT,1,3)_"0930" G N
  1.  I BGPQTR=1 S BGPBBD=($E(BGPVDT,1,3)-1)_"1001",BGPBED=($E(BGPVDT,1,3)-1)_"1231" G N
  1.  I BGPQTR=0,BGPQY="A" S BGPBBD=($E(BGPVDT,1,3)-1)_"0701",BGPBED=$E(BGPVDT,1,3)_"0630" G N
  1.  I BGPQTR=2 S BGPBBD=$E(BGPVDT,1,3)_"0101",BGPBED=$E(BGPVDT,1,3)_"0331" G N
  1.  I BGPQTR=3 S BGPBBD=$E(BGPVDT,1,3)_"0401",BGPBED=$E(BGPVDT,1,3)_"0630" G N
  1.  I BGPQTR=4 S BGPBBD=$E(BGPVDT,1,3)_"0701",BGPBED=$E(BGPVDT,1,3)_"0930" G N
  1. N S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)
  1.  S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)
  1.  W !!,"The date ranges for this report are:"
  1.  W !?5,"Reporting Period: ",?31,$$FMTE^XLFDT(BGPBD)," to ",?31,$$FMTE^XLFDT(BGPED)
  1.  W !?5,"Previous Year Period: ",?31,$$FMTE^XLFDT(BGPPBD)," to ",?31,$$FMTE^XLFDT(BGPPED)
  1.  W !?5,"Baseline Period: ",?31,$$FMTE^XLFDT(BGPBBD)," to ",?31,$$FMTE^XLFDT(BGPBED)
  1. ASU ;
  1.  S BGPSUCNT=0
  1.  S BGPRPTT=""
  1.  S DIR(0)="S^A:AREA Aggregate;F:One Facility",DIR("A")="Run Report for",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  G:$D(DIRUT) BY
  1.  S BGPRPTT=Y
  1.  I BGPRPTT="F" D  G:$D(BGPQUIT) ASU
  1.  .S BGPSUCNT=0,BGPSU="",BGPSUC="" K BGPSUL
  1.  .K BGPSUL S BGPX=0 F  S BGPX=$O(^BGPD(BGPX)) Q:BGPX'=+BGPX  S V=^BGPD(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,3)=BGPPER,$P(V,U,4)=BGPQTR S BGPSUL(BGPX)="",BGPSUCNT=BGPSUCNT+1
  1.  .I '$D(BGPSUL) W !!,"No data from that time period has been uploaded from the service units.",! S BGPQUIT=1 Q
  1.  .W !!,"Data from the following Facilities has been received.",!,"Please select the facility.",!
  1.  .K BGPSUL1 S X=0,C=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S C=C+1,BGPSUL1(C)=X
  1.  .S X=0 F  S X=$O(BGPSUL1(X)) Q:X'=+X  S BGP0=^BGPD(BGPSUL1(X),0) W !?2,X,")",?5,"FY: ",$$FMTE^XLFDT($P(BGP0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(90240.01,BGPSUL1(X),.04),?30,"SU: ",$$SU($P(BGP0,U,6)),?55,"Facility: ",$E($$FAC($P(BGP0,U,5)),1,15)
  1.  .W !?2,"0)",?5,"None of the Above"
  1.  .S DIR(0)="N^0:"_C_":0",DIR("A")="Please Select the Facility",DIR("B")="0" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S BGPQUIT=1 Q
  1.  .I 'Y S BGPQUIT=1 Q
  1.  .K BGPSUL S BGPSUL(BGPSUL1(Y))="",BGPSUCNT=1,X=$P(^BGPD(BGPSUL1(Y),0),U,5),X=$O(^AUTTLOC("C",X,0)) I X S BGPSUNM=$P(^DIC(4,X,0),U)
  1.  .Q
  1.  G:BGPRPTT="F" ZIS
  1. GETSU ;
  1.  K BGPSUL S BGPX=0 F  S BGPX=$O(^BGPD(BGPX)) Q:BGPX'=+BGPX  S V=^BGPD(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,3)=BGPPER,$P(V,U,4)=BGPQTR,$P(V,U,8)=BGPBBD,$P(V,U,9)=BGPBED S BGPSUL(BGPX)=""
  1.  I '$D(BGPSUL) W !!,"No data from that time period has been uploaded from the service units.",! G INTRO
  1.  W !!,"Data from the following Facilities has been received and will be used",!,"in the Area Aggregate Report:",!
  1.  S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S BGP0=^BGPD(X,0) W !?5,"FY: ",$$FMTE^XLFDT($P(BGP0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(90240.01,X,.04),?30,"SU: ",$$SU($P(BGP0,U,6)),?55,"Facility: ",$E($$FAC($P(BGP0,U,5)),1,15)
  1. ZIS ;call to XBDBQUE
  1.  S BGPASUF=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  D ^XBFMK
  1.  K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
  1.  F X=1:1:30 S BGPIND(X)=""
  1.  ;
  1.  W !! S %ZIS="PQM" D ^%ZIS
  1.  ;I POP W !,"Report Aborted" S DA=BGPRPT,DIK="^BGPD(" D ^DIK K DIK D EXIT Q
  1.  I $D(IO("Q")) G TSKMN
  1. DRIVER ;
  1.  U IO
  1.  D PRINT^BGPDPARP
  1.  D ^%ZISC
  1.  D EXIT
  1.  Q
  1.  ;
  1. TSKMN ;EP ENTRY POINT FROM TASKMAN
  1.  S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
  1.  I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))
  1.  I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
  1.  K ZTSAVE S ZTSAVE("BGP*")=""
  1.  S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^BGPDAREA",ZTDTH="",ZTDESC="GPRA REPORT" D ^%ZTLOAD D EXIT Q
  1.  Q
  1. OLD ;
  1.  S XBRP="PRINT^BGPDPARP",XBRC="",XBRX="EXIT^BGPDAREA",XBNS="BGP"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1.  ;
  1. FAC(S) ;
  1.  NEW N S N=$O(^AUTTLOC("C",S,0))
  1.  I N="" Q N
  1.  Q $P(^DIC(4,N,0),U)
  1. SU(S) ;
  1.  NEW N S N=$O(^AUTTSU("C",S,0))
  1.  I N="" Q N
  1.  Q $P(^AUTTSU(N,0),U)
  1. EXIT ;
  1.  D EN^XBVK("BGP")
  1.  D KILL^AUPNPAT
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. Q ;which quarter
  1.  S DIR(0)="N^1:4:0",DIR("A")="Which Quarter" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT)!(Y="") S BGPQUIT="" Q
  1.  S BGPQTR=Y
  1.  I Y=1 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=($E(BGPPER,1,3)-1)_"1231" Q
  1.  I Y=2 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"0331" Q
  1.  I Y=3 S BGPBD=$E(BGPPER,1,3)_"0401",BGPED=$E(BGPPER,1,3)_"0630" Q
  1.  I Y=4 S BGPBD=$E(BGPPER,1,3)_"0701",BGPED=$E(BGPPER,1,3)_"0930" Q
  1.  Q
  1. Y ;fiscal year
  1.  W !
  1.  S BGPVDT=""
  1.  W !,"Enter the YEAR of interest.  Use a 4 digit year, e.g. 2002"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter the year (e.g. 1999)"
  1.  S DIR("?")="This report is compiled for a period.  Enter a valid date."
  1.  D ^DIR
  1.  K DIC
  1.  I $D(DUOUT) S DIRUT=1 S BGPQUIT="" Q
  1.  S BGPVDT=Y
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G Y
  1.  S BGPPER=BGPVDT
  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 DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^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.  ;