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

BGP2DCHA.m

Go to the documentation of this file. 
  1. BGP2DCHA ; IHS/CMI/LAB - ihs area GPRA 02 Sep 2004 1:11 PM 02 Jul 2010 2:14 PM ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  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 will be used by 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,BGPYRPTH=""
  1.  S X=$O(^BGPCTRL("B",2012,0))
  1.  S Y=^BGPCTRL(X,0)
  1.  S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)
  1.  S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
  1.  S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
  1.  S BGPPER=$P(Y,U,14),BGPQTR=3
  1.  ;BEGIN TEST
  1.  G NT  ;comment out when testing in TEHR
  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.  G START
  1. NT ;END TEST STUFF
  1. START ;
  1.  W !,"This file will contain height and weight data for the time period"
  1.  W !,$$FMTE^XLFDT(BGPBD)," 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-65 who"
  1.  W !,"have a height and/or weight value documented on visits during this time"
  1.  W !,"period."
  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^BGP2ASL
  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=$$GETDIR^BGP2UTL2()
  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 BGPC=0,X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  S BGPC=BGPC+1
  1.  I BGPUF="" W:'$D(ZTQUEUED) !!,"Cannot continue.....can't find export directory name. File not written." Q
  1.  ;S BGPFN="CRSHW"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D(BGPBBD)_$$D(BGPED)_BGPNOW_".TXT"
  1.  S BGPFN="CRSHW"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D(BGPBD)_$$D(BGPED)_BGPNOW_"_001_of_001"_".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. ONEF ;
  1.  S BGPONEF=""
  1.  W !!!,"An Area wide Height/Weight Export file will be created.  You can choose"
  1.  W !,"to create one file of data or multiple files of data.  If you are"
  1.  W !,"planning to review this data using Microsoft Excel please keep in"
  1.  W !,"mind that Excel can only handle 65,536 records per file.  If you"
  1.  W !,"are using this data for your own use and will be using Microsoft"
  1.  W !,"Excel to review the data you must choose to create multiple files."
  1.  W !,"If you are creating this file to send to the Division of Epidemiology"
  1.  W !,"then you should select to create one file.  If you want to both review"
  1.  W !,"and export your data you will need to run this option twice."
  1.  W !,"If you choose to create one file it will be called:"
  1.  W !?5,BGPFN,!?5,"and will reside in the ",BGPUF," directory."
  1.  W !,"If you have multiple files generated they will all have the"
  1.  W !,"same name with the last 10 characters of the filename being a"
  1.  W !,"of the number of files (e.g. _001_of_003)."
  1.  ; 
  1.  S DIR(0)="S^O:ONE File of data;M:MULTIPLE Files of data",DIR("A")="Do you want to create one file or multiple files",DIR("B")="M" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  S BGPONEF=Y
  1. DRIVER ;
  1.  D GS
  1.  D ^%ZISC
  1.  D EXIT
  1.  Q
  1.  ;
  1. EXIT ;
  1.  D ^%ZISC
  1.  D EN^XBVK("BGP") I $D(ZTQUEUED) S ZTREQ="@"
  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(^BGPGPDCW(BGPX,88888,BGPY)) Q:BGPY'=+BGPY  D
  1.  ;..S BGPC=BGPC+1
  1.  ;..S ^BGPDATA(BGPC)=^BGPGPDCW(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) ;NOTE:  kill of unsubscripted global for use in export to area.
  1.  I '$D(ZTQUEUED) W !!,"Writing out Ht/Wt file...."
  1.  ;count up total # of records and divide by 65,536
  1.  K BGPFNX
  1.  S BGPRPT=0,BGPTOT=0 F  S BGPRPT=$O(BGPSUL(BGPRPT)) Q:BGPRPT'=+BGPRPT  D HWSF2
  1.  D HWSF3
  1.  Q
  1. HWSF2 ;
  1.  S BGPX=0 F  S BGPX=$O(^BGPGPDCW(BGPRPT,88888,BGPX)) Q:BGPX'=+BGPX  S BGPTOT=BGPTOT+1,^TMP($J,"HTWTR",BGPTOT)=^BGPGPDCW(BGPRPT,88888,BGPX,0)
  1.  Q
  1. HWSF3 ;
  1.  I BGPONEF="O" D HWSF1 Q
  1.  S BGPNF1=BGPTOT/65536
  1.  S BGPNF=$S($P(BGPNF1,".",2)]"":BGPNF1+1,1:BGPNF1)
  1.  S BGPNF=$P(BGPNF,".")
  1.  S BGPX=0,BGPLX=0
  1.  F BGPZ=1:1:BGPNF D
  1.  .S BGPFN="CRSHW"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D(BGPBD)_$$D(BGPED)_BGPNOW_"_"_$$LZERO^BGP2UTL(BGPZ,3)_"_of_"_$$LZERO^BGP2UTL(BGPNF,3)_".TXT"
  1.  .S BGPFNX(BGPZ)=BGPFN
  1.  .S Y=$$OPEN^%ZISH(BGPUF,BGPFN,"W")
  1.  .I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  .U IO
  1.  .W "SERVICE UNIT^ASUFAC^UNIQUE DB ID^DATE RUN^BEG DATE^END DATE^PATIENT UID^DOB^TRIBE CODE^GENDER^STATE OF RESIDENCE^UNIQUE VISIT ID^DATE OF VISIT^TIME OF VISIT^HT CM^WT KG",!
  1.  .S BGPC=1,BGPX=$S(BGPLX:BGPLX,1:0)
  1.  .F  S BGPX=$O(^TMP($J,"HTWTR",BGPX)) Q:BGPX'=+BGPX!(BGPC>65535)  D
  1.  ..W $G(^TMP($J,"HTWTR",BGPX)),!
  1.  ..S BGPC=BGPC+1
  1.  ..S BGPLX=BGPX
  1.  .D ^%ZISC
  1.  Q
  1. HWSF1 ;EP
  1.  ;write out one flie only
  1.  S BGPZ=1,BGPFN="CRSHW"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D(BGPBD)_$$D(BGPED)_BGPNOW_"_001_of_001.TXT"
  1.  S BGPFNX(BGPZ)=BGPFN
  1.  I '$D(ZTQUEUED) U IO W !?10,BGPFN
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFN,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  W "SERVICE UNIT^ASUFAC^UNIQUE DB ID^DATE RUN^BEG DATE^END DATE^PATIENT UID^DOB^TRIBE CODE^GENDER^STATE OF RESIDENCE^UNIQUE VISIT ID^DATE OF VISIT^TIME OF VISIT^HT CM^WT KG",!
  1.  S BGPC=1,BGPX=0
  1.  F  S BGPX=$O(^TMP($J,"HTWTR",BGPX)) Q:BGPX'=+BGPX  D
  1.  .W $G(^TMP($J,"HTWTR",BGPX)),!
  1.  D ^%ZISC
  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)