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

BGP3DARH.m

Go to the documentation of this file. 
  1. BGP3DARH ; IHS/CMI/LAB - ihs area AA ;
  1.  ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1.  ;
  1.  ;
  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 Aggregate AREA Annual Performance Report",80)
  1. INTRO ;
  1.  D EXIT
  1.  S BGPRTYPE=2
  1.  S BGPAREAA=1
  1. TP ;
  1.  D EXIT
  1.  S BGPRTYPE=2
  1.  S BGPAREAA=1
  1.  K BGPQUIT
  1.  S BGPQY=""
  1.  S (BGPBD,BGPED,BGPTP)=""
  1.  S DIR(0)="S^Q:Area Director's Quarter (Quarter 1, 2, 3 or 4);A:Area Director's Reporting Year (June-July);",DIR("A")="Run Report for which time period",DIR("B")="Q" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S BGPTP=Y
  1.  D @BGPTP
  1.  I $D(BGPQUIT) G TP
  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 to compare 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. 2003)"
  1.  D ^DIR KILL DIR
  1.  K DIC
  1.  I $D(DUOUT) S DIRUT=1 G TP
  1.  S BGPVDT=Y
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G BY
  1.  S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1.  S X=X_"0000"
  1.  S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1.  S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1.  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(^BGPGPDC(BGPX)) Q:BGPX'=+BGPX  S V=^BGPGPDC(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,7)=BGPPER,$P(V,U,12)=2,$P(V,U,5)=BGPBBD,$P(V,U,6)=BGPBED 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=^BGPGPDC(BGPSUL1(X),0) W !?2,X,")",?5,"FY: ",$$FMTE^XLFDT($P(BGP0,U,7)),?15,"QTR: ",$$VAL^XBDIQ1(90243,BGPSUL1(X),.08) D
  1.  ..W ?30,"SU: ",$$SU($P(BGP0,U,11)),?55,"Facility: ",$E($$FAC($P(BGP0,U,9)),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(^BGPGPDC(BGPSUL1(Y),0),U,9),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(^BGPGPDC(BGPX)) Q:BGPX'=+BGPX  S V=^BGPGPDC(BGPX,0) I $P(V,U)=BGPBD,$P(V,U,2)=BGPED,$P(V,U,7)=BGPPER,$P(V,U,5)=BGPBBD,$P(V,U,6)=BGPBED,$P(V,U,12)=2 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=^BGPGPDC(X,0) W !?5,"FY: ",$$FMTE^XLFDT($P(BGP0,U,7)),?15,"QTR: ",$$VAL^XBDIQ1(90243,X,.08),?30,"SU: ",$$SU($P(BGP0,U,11)),?55,"Facility: ",$E($$FAC($P(BGP0,U,9)),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. GI ;gather all gpra indicators
  1.  S X=0 F  S X=$O(^BGPINDC("AREA",X)) Q:X'=+X  S Y=0 F  S Y=$O(^BGPINDC("AREA",X,Y)) Q:Y'=+Y  S BGPIND($P(^BGPINDC(Y,0),U,1))=""
  1.  S BGPINDT="A"
  1.  ;
  1.  D PT^BGP3DSL
  1.  I BGPROT="" G ASU
  1.  ;W !! S %ZIS="PQM" D ^%ZIS
  1.  K IOP,%ZIS W !! S %ZIS=$S(BGPDELT'="S":"PQM",1:"PM") D ^%ZIS
  1.  ;I POP W !,"Report Aborted" S DA=BGPRPT,DIK="^BGPGPDC(" D ^DIK K DIK D EXIT Q
  1.  I $D(IO("Q")) G TSKMN
  1. DRIVER ;
  1.  U IO
  1.  D PRINT^BGP3PARP
  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^BGP3DARA",ZTDTH="",ZTDESC="GPRA REPORT" D ^%ZTLOAD D EXIT Q
  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.  D F
  1.  I BGPPER="" W !,"No YEAR entered" S BGPQUIT="" Q
  1.  S DIR(0)="N^1:4:0",DIR("A")="Which Area Director's 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)-2)_"1001",BGPED=($E(BGPPER,1,3)-1)_"0930" Q
  1.  I Y=2 S BGPBD=($E(BGPPER,1,3)-1)_"0101",BGPED=($E(BGPPER,1,3)-1)_"1231" Q
  1.  I Y=3 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331" Q
  1.  I Y=4 S BGPBD=$E(BGPPER,1,3)_"0401",BGPED=$E(BGPPER,1,3)_"0630" Q
  1.  Q
  1. F ;fiscal year
  1.  S BGPPER=""
  1.  W !
  1.  S BGPVDT=""
  1.  W !,"Enter the Fiscal Year (FY).  Use a 4 digit year, e.g. 2002, 2003"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter FY"
  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 F
  1.  S BGPPER=BGPVDT,BGPBD=($E(BGPVDT,1,3)-1)_"1001",BGPED=$E(BGPVDT,1,3)_"0930"
  1.  Q
  1. A ;area dir year
  1.  W !
  1.  S BGPVDT=""
  1.  W !,"Enter the appropriate AREA REPORTING YEAR.  Use a 4 digit year, e.g. 2002"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter AREA REPORTING 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 A
  1.  S BGPPER=BGPVDT,BGPBD=($E(BGPVDT,1,3)-1)_"0701",BGPED=$E(BGPVDT,1,3)_"0630"
  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.  ;