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

BGP6DCHA.m

Go to the documentation of this file. 
  1. BGP6DCHA ; IHS/CMI/LAB - ihs area GPRA 02 Sep 2004 1:11 PM ;
  1.  ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  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 Height and Weight Data Export",80)
  1.  W !!,"This option is used to produce an area aggregate Height and"
  1.  W !,"Weight Export file. This is a single delimited file that will be comprised"
  1.  W !,"of height and weight data.  This file should be exported to the Division"
  1.  W !,"of Epidemiology, where it will construct frequency curves of BMI as"
  1.  W !,"a GPRA developmental performance measure.",!!
  1. INTRO ;
  1.  D EXIT
  1. TP ;
  1.  S BGPAREAA=1
  1.  S BGPRTYPE=1,BGPBEN=1,BGP6RPTH=""
  1.  ;W !!,"for testing purposes only, please enter a report year",!
  1.  ;D F
  1.  ;I BGPPER="" W !!,"no year entered..bye" D EXIT Q
  1.  ;S BGPQTR=3
  1.  ;S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
  1.  ;S BGPPBD=($E(BGPPER,1,3)-1)_"0101",BGPPED=($E(BGPPER,1,3)-1)_"1231"
  1.  ;W !!,"for testing purposes only, please enter a BASELINE year",!
  1.  ;D B
  1.  ;I BGPBPER="" W !!,"no year entered..bye" D EXIT Q
  1.  ;S BGPBBD=$E(BGPBPER,1,3)_"0101",BGPBED=$E(BGPBPER,1,3)_"1231"
  1.  ;END TEST STUFF
  1.  S BGPBD=3050701,BGPED=3060630
  1.  S BGPBBD=2990701,BGPBED=3000630
  1.  S BGPPBD=3040701,BGPPED=3050630
  1.  S BGPPER=3060000,BGPQTR=3
  1.  W !,"This file will contain height and weight data for the time period"
  1.  W !,$$FMTE^XLFDT(BGPBBD)," through ",$$FMTE^XLFDT(BGPED)," for all Active Clinical"
  1.  W !,"patients 0-18 who have both a height and weight value documented"
  1.  W !,"on a visit and for all Active Clinical patients age 19 and older who"
  1.  W !,"have a height and/or weight value documented on a visit."
  1.  ;W !!,"The date ranges for this report are:"
  1.  ;W !?5,"Report 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.  W !!!,"You will now be able to select which sites to use in the export.",!
  1.  S DIR(0)="E",DIR("A")="Press Enter to Continue" KILL DA D ^DIR KILL DIR
  1.  K BGPSUL
  1.  S BGPCHWE=1
  1.  D EN^BGP6ASL
  1.  I '$D(BGPSUL) W !!,"No sites selected" D EXIT Q
  1.  S X=0,C=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S C=C+1
  1.  W !!,"A total of ",C," facilities have been selected.",!!
  1. ZIS ;call to XBDBQUE
  1. EISSEX ;
  1.  S BGPEXCEL=""
  1.  S BGPUF=""
  1.  I ^%ZOSF("OS")["PC"!(^%ZOSF("OS")["NT")!($P($G(^AUTTSITE(1,0)),U,21)=2) S BGPUF=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:"C:\EXPORT")
  1.  I $P(^AUTTSITE(1,0),U,21)=1 S BGPUF="/usr/spool/uucppublic"
  1.  S BGPASUF=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  S BGPNOW=$$NOW^XLFDT() S BGPNOW=$$NOW^XLFDT() S BGPNOW=$$D($P(BGPNOW,"."))_$P(BGPNOW,".",2)
  1.  S BDWC=0,X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S BDWC=BDWC+1
  1.  I BGPUF="" W:'$D(ZTQUEUED) !!,"Cannot continue.....can't find export directory name. File not written." Q
  1.  S BGPFN="HW"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D(BGPBBD)_$$D(BGPED)_BGPNOW_".TXT"
  1.  W !!,"A file will be created called ",BGPFN,!,"and will reside in the ",BGPUF," directory. This file can be used in Excel.",!
  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.  W !
  1.  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 EXIT Q
  1.  I 'Y D EXIT Q
  1. DRIVER ;
  1.  D GS
  1.  D ^%ZISC
  1.  D EXIT
  1.  Q
  1.  ;
  1. EXIT ;
  1.  D EN^XBVK("BGP")
  1.  D KILL^AUPNPAT
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. GS ;EP - write out file
  1.  K ^TMP($J)
  1.  L +^BGPDATA:300 E  W:'$D(ZTQUEUED) "Unable to lock global" Q
  1.  ;NOTE:  Kill of unsubscripted global.  Export to area.  Using standard name.
  1.  S (BGPC,BGPX)=0 F  S BGPX=$O(BGPSUL(BGPX)) Q:BGPX'=+BGPX  D
  1.  .S BGPY=0 F  S BGPY=$O(^BGPGPDCS(BGPX,88888,BGPY)) Q:BGPY'=+BGPY  D
  1.  ..S BGPC=BGPC+1
  1.  ..S ^BGPDATA(BGPC)=^BGPGPDCS(BGPX,88888,BGPY,0)
  1.  ..Q
  1.  .Q
  1.  S XBGL="BGPDATA"
  1.  S XBMED="F",XBFN=BGPFN,XBTLE="SAVE OF HT/WT DATA FOR - "_$P(^AUTTLOC(DUZ(2),0),U,10),XBF=0,XBFLT=1
  1.  D ^XBGSAVE
  1.  L -^BGPDATA
  1.  K ^TMP($J),^BGPDATA ;NOTE:  kill of unsubscripted global for use in export to area.
  1.  Q
  1.  ;
  1. B ;fiscal year
  1.  S (BGPBPER,BGPVDT)=""
  1.  W !!,"Enter the BASELINE year for the report.  Use a 4 digit ",!,"year, e.g. 2005"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter BASELINE year"
  1.  S DIR("?")="This report is compiled for a period.  Enter a valid date."
  1.  D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I $D(DUOUT) S DIRUT=1 Q
  1.  S BGPVDT=Y
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G F
  1.  S BGPBPER=BGPVDT
  1.  Q
  1. F ;fiscal year
  1.  S BGPPER=""
  1.  W !
  1.  S BGPVDT=""
  1.  W !,"Enter the Fiscal Year (FY) for the report END date.  Use a 4 digit",!,"year, e.g. 2002, 2005"
  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. 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.  ;
  1. D(D) ;EP
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)