BGP0DNE ; IHS/CMI/LAB - NATL COMP EXPORT 05 Dec 2006 7:09 PM 07 Mar 2009 2:29 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
W:$D(IOF) @IOF
INTRO ;
D XIT
S BGPXPFYC=$O(^BGPCTRL("B","2010",0))
S X=0 F S X=$O(^BGPCTRL(BGPXPFYC,54,X)) Q:X'=+X D
.I $Y>(IOSL-3) D EOP W @IOF
.W !,^BGPCTRL(BGPXPFYC,54,X,0)
D TAXCHK^BGP0XTCN
TP ;
S BGPRTYPE=1,BGPXPRP=1,BGPXPFYY=2010,BGPXPFYI=309
S BGPXPBD=2990701,BGPXPTDT=3100630
W !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPTDT)
COMM ;
W !!,"Specify the community taxonomy to determine which patients will be",!,"included in the report. You should have created this taxonomy using QMAN.",!
K BGPTAX
S BGPTAXI=""
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: "
S B=$P($G(^BGPSITE(DUZ(2),0)),U,5) I B S DIC("B")=$P(^ATXAX(B,0),U)
D ^DIC K DIC
I Y=-1 Q
S BGPTAXI=+Y
COM1 ;
S X=0
F S X=$O(^ATXAX(BGPTAXI,21,X)) Q:'X D
.S BGPTAX($P(^ATXAX(BGPTAXI,21,X,0),U))=""
.Q
I '$D(BGPTAX) W !!,"There are no communities in that taxonomy." G COMM
S X=0,G=0
F S X=$O(^ATXAX(BGPTAXI,21,X)) Q:'X D
.S C=$P(^ATXAX(BGPTAXI,21,X,0),U)
.I '$D(^AUTTCOM("B",C)) W !!,"*** Warning: Community ",C," is in the taxonomy but was not",!,"found in the standard community table." S G=1
.Q
I G D I BGPQUIT D XIT Q
.W !!,"These communities may have been renamed or there may be patients"
.W !,"who have been reassigned from this community to a new community and this"
.W !,"could reduce your patient population."
.S BGPQUIT=0
.S DIR(0)="Y",DIR("A")="Do you want to cancel the report and review the communities" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S BGPQUIT=1
.I Y S BGPQUIT=1
.Q
MFIC K BGPQUIT
S BGPMFITI=""
I $P($G(^BGPSITE(DUZ(2),0)),U,8)=1 D I BGPMFITI="" G COMM
.S BGPMFITI=""
.W !!,"Specify the LOCATION taxonomy to determine which patient visits will be"
.W !,"used to determine whether a patient is in the denominators for the report."
.W !,"You should have created this taxonomy using QMAN.",!
.K BGPMFIT
.S BGPMFITI=""
.D ^XBFMK
.S DIC("S")="I $P(^(0),U,15)=9999999.06",DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Location/Facility Taxonomy: "
.S B=$P($G(^BGPSITE(DUZ(2),0)),U,9) I B S DIC("B")=$P(^ATXAX(B,0),U)
.D ^DIC
.I Y=-1 Q
.S BGPMFITI=+Y
BEN ;
S BGPBEN=1
HOME ;
S BGPHOME=$P($G(^BGPSITE(DUZ(2),0)),U,2)
;I BGPHOME="" W !!,"Home Location not found in Site File!!",!,"PHN Visits counts to Home will be calculated using clinic 11 only!!" H 2 G EXPORT
;W !,"Your HOME location is defined as: ",$P(^DIC(4,BGPHOME,0),U)," asufac: ",$P(^AUTTLOC(BGPHOME,0),U,10)
EXPORT ;export to area or not?
S BGPEXPT=""
S DIR(0)="Y",DIR("A")="Do you wish to export this data to Area" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G COMM
S BGPEXPT=Y
S BGPXPDR=DT
S BGPNOW=$$NOW^XLFDT
S BGPUF=$$GETDIR^BGP0UTL2()
;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")
;I $P(^AUTTSITE(1,0),U,21)=1 S BGPUF="/usr/spool/uucppublic/"
I BGPEXPT,BGPUF="" W:'$D(ZTQUEUED) !!,"Cannot continue.....can't find export directory name. EXCEL file",!,"not written." D PAUSE^BGP0CL,XIT Q
S BGPFN="CRSCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_001_of_001.TXT"
LOCALF ;
S BGPLOCAL=""
S DIR(0)="Y",DIR("A")="Do you want to create local delimited files for use in Excel",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G EXPORT
S BGPLOCAL=Y
I 'BGPLOCAL,'BGPEXPT W !!,"You have chosen not to create any files.....exiting" H 3 D XIT Q
SUM ;
W:$D(IOF) @IOF
W !,$$CTR("SUMMARY OF NATIONAL GPRA EXPORT FILE TO BE GENERATED")
W !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPTDT)
W !!,"The COMMUNITY Taxonomy to be used is: ",$P(^ATXAX(BGPTAXI,0),U)
I $G(BGPMFITI) W !!,"The MFI Location Taxonomy to be used is: ",$P(^ATXAX(BGPMFITI,0),U)
;I BGPHOME W !,"The HOME location is: ",$P(^DIC(4,BGPHOME,0),U)," ",$P(^AUTTLOC(BGPHOME,0),U,10)
;I 'BGPHOME W !,"No HOME Location selected."
I BGPEXPT D
.W !,"The Area Export file will be named: ",!,BGPFN
.W !,"and will reside in the ",BGPUF," directory. This is the file you should"
.W !,"export to your Area Office. Depending on your site configuration, the"
.W !,"file may need to be manually sent to your Area Office.",!
I BGPLOCAL D
.W !,"The local files will all begin with ""","CRSLCNT","""and will have the"
.W !,"same name except for the last 10 characters, which represent the number"
.W !,"of files (e.g. 001_of_003).",!
.W !,"NOTE: If the data will fit into one file, only one file beginning"
.W !,"with ""","CRSCNT","""will be created, which should be used for"
.W !,"both Area Exporting and local use.",!
ZIS ;call to XBDBQUE
;CREATE REPORT ENTRY
K DIC S X=$P(^VA(200,DUZ,0),U)_"-"_$$D^BGP0UTL(BGPNOW),DIC(0)="L",DIC="^BGPXPT(",DLAYGO=90377.11,DIADD=1
S DIC("DR")=".02////"_BGPXPBD_";.03////"_BGPXPTDT_";.04////"_$P(^ATXAX(BGPTAXI,0),U)_";.05////"_$S(BGPMFITI:$P(^ATXAX(BGPMFITI,0),U),1:"")
D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 S BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!" H 4 D XIT Q
S BGPXPRPT=+Y
K ^BGPXPT(BGPXPRPT,13)
S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPXPT(BGPXPRPT,13,C,0)=X,^BGPXPT(BGPXPRPT,13,"B",X,C)=""
S ^BGPXPT(BGPXPRPT,13,0)="^90377.111301A^"_C_"^"_C
K ^BGPXPT(BGPXPRPT,14)
I $G(BGPMFITI) S C=0,X="" F S X=$O(^ATXAX(BGPMFITI,21,"B",X)) Q:X="" S C=C+1,Y=$P($G(^DIC(4,X,0)),U) S ^BGPXPT(BGPXPRPT,14,C,0)=Y,^BGPXPT(BGPXPRPT,14,"B",Y,C)=""
S ^BGPXPT(BGPXPRPT,14,0)="^90377.111401A^"_C_"^"_C
ONEF ;
S BGPONEF=""
K IOP,%ZIS W !! S %ZIS="PQM" D ^%ZIS
I POP W !,"Report Aborted" S DA=BGPXPRPT,DIK="^BGPXPT(" D ^DIK K DIK D XIT Q
I $D(IO("Q")) G TSKMN
DRIVER ;
D PROC^BGP0DNE
U IO
D PRINT^BGP0DNE
D ^%ZISC
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^BGP0DNE",ZTDTH="",ZTDESC="NATIONAL GPRA REPORT 09" D ^%ZTLOAD D XIT Q
Q
;
XIT ;
D ^%ZISC
D EN^XBVK("BGP") I $D(ZTQUEUED) S ZTREQ="@"
K DIRUT,DUOUT,DIR,DOD
K DIADD,DLAYGO
D KILL^AUPNPAT
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
K BD,ED
D KILL^AUPNPAT
D ^XBFMK
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)!$D(IO("S"))
W !
NEW DIR,X
K DIR,DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR KILL DIR
Q
;----------
USR() ;EP -
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - .
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
;
CNTSF ;EP
I '$D(ZTQUEUED) W !!,"Writing out National GPRA Export file...."
I BGPEXPT D CNTSF1
I 'BGPLOCAL G STOP
;count up total # of records and divide by 65,536
S BGPX=0,BGPTOT=0 F S BGPX=$O(^BGPXPT(BGPXPRPT,11,BGPX)) Q:BGPX'=+BGPX S BGPTOT=BGPTOT+1
S BGPNF1=BGPTOT/65536
I BGPNF1'>1,BGPEXPT G STOP ; - only 1 and it is created already
S BGPNF=$S($P(BGPNF1,".",2)]"":BGPNF1+1,1:BGPNF1)
S BGPNF=$P(BGPNF,".")
S BGPX=0,BGPLX=0
S ^BGPXPT(BGPXPRPT,12,0)="^90377.111201A^"_BGPNF_"^"_BGPNF
F BGPZ=1:1:BGPNF D
.S BGPFN="CRSLCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_"_$$LZERO^BGP0UTL(BGPZ,3)_"_of_"_$$LZERO^BGP0UTL(BGPNF,3)_".TXT"
.S ^BGPXPT(BGPXPRPT,12,BGPZ+1,0)=BGPFN_" --- "_BGPUF
.I '$D(ZTQUEUED) U IO W !?10,BGPFN
.S Y=$$OPEN^%ZISH(BGPUF,BGPFN,"W")
.I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
.U IO
.S Y="SITE NAME^ASUFAC^DATE FILE RUN^FILE BEGIN DATE^FILE END DATE^PATIENT UNIQUE REGISTRATION ID^DOB^GENDER^STATE^COUNTY^MEASURE ID^MEASURE"
.S P=13 F X=2000:1:BGPXPFYY S $P(Y,U,P)="GPRA YR "_X,P=P+1
.W Y,!
.S BGPC=1,BGPX=$S(BGPLX:BGPLX,1:0)
.F S BGPX=$O(^BGPXPT(BGPXPRPT,11,BGPX)) Q:BGPX'=+BGPX!(BGPC>65535) D
..W $G(^BGPXPT(BGPXPRPT,11,BGPX,0)),!
..S BGPC=BGPC+1
..S BGPLX=BGPX
.D ^%ZISC
STOP ;
K ^BGPXPT(BGPXPRPT,11)
Q
CNTSF1 ;EP
;write out one flie only
S BGPZ=1,BGPFN="CRSCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_001_of_001.TXT"
S ^BGPXPT(BGPXPRPT,12,BGPZ,0)=BGPFN_" --- "_BGPUF
I '$D(ZTQUEUED) U IO W !?10,BGPFN
L +^BGPDATA:10 Q:'$T
K ^BGPDATA ;EXPORT GLOBAL FOR AREA EXPORT
S BGPC=0
S Y="SITE NAME^ASUFAC^DATE FILE RUN^FILE BEGIN DATE^FILE END DATE^PATIENT UNIQUE REGISTRATION ID^DOB^GENDER^STATE^COUNTY^MEASURE ID^MEASURE"
S P=13 F X=2000:1:BGPXPFYY S $P(Y,U,P)="GPRA YR "_X,P=P+1
S BGPC=BGPC+1
S ^BGPDATA(BGPC)=Y
S BGPX=0
F S BGPX=$O(^BGPXPT(BGPXPRPT,11,BGPX)) Q:BGPX'=+BGPX D
.S BGPC=BGPC+1
.S ^BGPDATA(BGPC)=$G(^BGPXPT(BGPXPRPT,11,BGPX,0))
;D ^%ZISC
S XBGL="BGPDATA"
S XBMED="F",XBFN=BGPFN,XBTLE="SAVE OF NATIONAL GPRA EXPORT 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
PROC ;EP
S BGPBT=$H
D JRNL^BGP0UTL
S BGPXPXPX=1 ;in xp report
S BGPJ=$J,BGPH=$H
S BGPCHSO=$P($G(^BGPSITE(DUZ(2),0)),U,6)
S BGPXPTOT=0
PROC1 ;process each patient
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D
.;S DFN=4812 D
.Q:'$D(^DPT(DFN,0))
.Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"
.I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))
.S BGPXPUP=""
.F BGPXPCY=300:1:BGPXPFYI D
..;set beginning date and ending date
..S BGPXXX=BGPXPCY_"0630"
..Q:'$$ACTUP^BGP0D1(DFN,$$FMADD^XLFDT(BGPXXX,-(3*365)),BGPXXX,BGPTAXI,1)
..S BGPXPUP=1
.Q:'BGPXPUP ;NOT IN ANY USER POP
.D PROCYRS
.S X=0 F S X=$O(BGPXPDAT(X)) Q:X'=+X D
..S BGPXPTOT=BGPXPTOT+1
..S ^BGPXPT(BGPXPRPT,11,BGPXPTOT,0)=BGPXPDAT(X)
.Q
S ^BGPXPT(BGPXPRPT,11,0)="^90377.111101A^"_BGPXPTOT_"^"_BGPXPTOT
S BGPET=$H
D CNTSF
Q
PROCYRS ;
;process each year from 2000, starting at "^" piece 13, loop through all measures
S BGPXPPIE=12
K BGPXPDAT
F BGPXPCY=300:1:BGPXPFYI D
.;set beginning date and ending date
.S BGPBD=(BGPXPCY-1)_"0701",BGPED=BGPXPCY_"0630",BGPXPPIE=BGPXPPIE+1
.S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
.D PROCCY^BGP0D1
.D PROCIND
.Q
Q
PROCIND ;
S BGPXPPD=$P(^DIC(4,DUZ(2),0),U)
S $P(BGPXPPD,U,2)=$P(^AUTTLOC(DUZ(2),0),U,10)
S $P(BGPXPPD,U,3)=$$EDT^BGP0UTL(DT)
S $P(BGPXPPD,U,4)=$$EDT^BGP0UTL(BGPXPBD)
S $P(BGPXPPD,U,5)=$$EDT^BGP0UTL(BGPXPTDT)
S $P(BGPXPPD,U,6)=$$UID^BGP0DCHW(DFN)
S $P(BGPXPPD,U,7)=$$EDT^BGP0UTL($P(^DPT(DFN,0),U,3))
S $P(BGPXPPD,U,8)=$P(^DPT(DFN,0),U,2)
S $P(BGPXPPD,U,9)=$$STATE^BGP0DCHW(DFN)
S $P(BGPXPPD,U,10)=$$COUNTY(DFN)
;process each measure and set record BGPXPDAT per measure
S BGPXPMI=0 F S BGPXPMI=$O(^BGPCTRL(BGPXPFYC,55,BGPXPMI)) Q:'BGPXPMI D
.S BGPXPX=$P(^BGPCTRL(BGPXPFYC,55,BGPXPMI,0),U,1)
.K BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
.K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30
.K BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13
.K BGPNUMV
.S BGPXPTV=""
.K ^TMP($J)
.I $D(^BGPINDT(BGPXPX,1)) X ^BGPINDT(BGPXPX,1)
.;now get each individual measure and set value
.S BGPXPT=0 F S BGPXPT=$O(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT)) Q:BGPXPT'=+BGPXPT D
..S BGPXPMID=$P(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,0),U,1)
..I '$D(BGPXPDAT(BGPXPMID)) S BGPXPDAT(BGPXPMID)=BGPXPPD
..S $P(BGPXPDAT(BGPXPMID),U,11)=BGPXPMID
..S $P(BGPXPDAT(BGPXPMID),U,12)=$P(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,0),U,3)
..S X=""
..X ^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,1)
..S $P(BGPXPDAT(BGPXPMID),U,BGPXPPIE)=X
..Q
.K BGPVAL,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
.K ^TMP($J)
Q
COUNTY(P) ;EP
S C=$$COMMRES^AUPNPAT(P,"C")
I C="" Q ""
S S=$E(C,1,4)
S S=$O(^AUTTCTY("C",S,0))
I S="" Q S
Q $P($G(^AUTTCTY(S,0)),U,1)
;
PRINT ;EP - CALLED FROM XBDBQUE
S BGPGPG=0,BGPQUIT=""
S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
D HEADER
W !!,"Community Taxonomy: ",$P(^ATXAX(BGPTAXI,0),U)
I '$G(BGPALLPT),'$G(BGPSEAT) W !?10,"The following communities are included in this report:",! D
.S BGPZZ="",BGPN=0,BGPY="" F S BGPZZ=$O(BGPTAX(BGPZZ)) Q:BGPZZ=""!(BGPQUIT) S BGPN=BGPN+1,BGPY=BGPY_$S(BGPN=1:"",1:";")_BGPZZ
.S BGPZZ=0,C=0 F BGPZZ=1:3:BGPN D Q:$G(BGPQUIT)
..I $Y>(BGPIOSL-2) D HEADER Q:$G(BGPQUIT)
..W !?10,$E($P(BGPY,";",BGPZZ),1,20),?30,$E($P(BGPY,";",(BGPZZ+1)),1,20),?60,$E($P(BGPY,";",(BGPZZ+2)),1,20)
..Q
Q:BGPQUIT
I $G(BGPMFITI) W !!?10,"MFI Visit Location Taxonomy Name: ",$P(^ATXAX(BGPMFITI,0),U)
I $G(BGPMFITI) W !?10,"The following Locations are used for patient visits in this report:",! D
.S BGPZZ="",BGPN=0,BGPY="" F S BGPZZ=$O(^ATXAX(BGPMFITI,21,"B",BGPZZ)) Q:BGPZZ="" S BGPN=BGPN+1,BGPY=BGPY_$S(BGPN=1:"",1:";")_$P($G(^DIC(4,BGPZZ,0)),U)
.S BGPZZ=0,C=0 F BGPZZ=1:3:BGPN D Q:$G(BGPQUIT)
..I $Y>(BGPIOSL-2) D HEADER Q:$G(BGPQUIT)
..W !?10,$E($P(BGPY,";",BGPZZ),1,20),?30,$E($P(BGPY,";",(BGPZZ+1)),1,20),?60,$E($P(BGPY,";",(BGPZZ+2)),1,20)
..Q
Q:BGPQUIT
I $Y>(IOSL-3) D HEADER Q:BGPQUIT
W !!,"The following files were created: "
S BGPX=0 F S BGPX=$O(^BGPXPT(BGPXPRPT,12,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(IOSL-3) D HEADER Q:BGPQUIT
.W !?5,$P(^BGPXPT(BGPXPRPT,12,BGPX,0),U)
K BGPX,BGPQUIT
Q
G:'BGPGPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQUIT=1 Q
W:$D(IOF) @IOF S BGPGPG=BGPGPG+1
I $G(BGPGUI) W "ZZZZZZZ",! ;maw
W $P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
W $$CTR("*** IHS 2010 Comprehensive National GPRA Export ***",80),!
W !,$$CTR($$RPTVER^BGP0BAN,80)
W !,$$CTR("Date Export Run: "_$$FMTE^XLFDT(DT),80)
W !,$$CTR("Site where Run: "_$P(^DIC(4,DUZ(2),0),U),80)
W !,$$CTR("Report Generated by: "_$$USR,80)
S X="Time Period: "_$$FMTE^XLFDT(BGPXPBD)_" to "_$$FMTE^XLFDT(BGPXPTDT) W !,$$CTR(X,80),!
W $TR($J("",80)," ","-")
Q
BGP0DNE ; IHS/CMI/LAB - NATL COMP EXPORT 05 Dec 2006 7:09 PM 07 Mar 2009 2:29 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
INTRO ;
+1 DO XIT
+2 SET BGPXPFYC=$ORDER(^BGPCTRL("B","2010",0))
+3 SET X=0
FOR
SET X=$ORDER(^BGPCTRL(BGPXPFYC,54,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO EOP
WRITE @IOF
+5 WRITE !,^BGPCTRL(BGPXPFYC,54,X,0)
End DoDot:1
+6 DO TAXCHK^BGP0XTCN
TP ;
+1 SET BGPRTYPE=1
SET BGPXPRP=1
SET BGPXPFYY=2010
SET BGPXPFYI=309
+2 SET BGPXPBD=2990701
SET BGPXPTDT=3100630
+3 WRITE !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPTDT)
COMM ;
+1 WRITE !!,"Specify the community taxonomy to determine which patients will be",!,"included in the report. You should have created this taxonomy using QMAN.",!
+2 KILL BGPTAX
+3 SET BGPTAXI=""
+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: "
+6 SET B=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,5)
IF B
SET DIC("B")=$PIECE(^ATXAX(B,0),U)
+7 DO ^DIC
KILL DIC
+8 IF Y=-1
QUIT
+9 SET BGPTAXI=+Y
COM1 ;
+1 SET X=0
+2 FOR
SET X=$ORDER(^ATXAX(BGPTAXI,21,X))
IF 'X
QUIT
Begin DoDot:1
+3 SET BGPTAX($PIECE(^ATXAX(BGPTAXI,21,X,0),U))=""
+4 QUIT
End DoDot:1
+5 IF '$DATA(BGPTAX)
WRITE !!,"There are no communities in that taxonomy."
GOTO COMM
+6 SET X=0
SET G=0
+7 FOR
SET X=$ORDER(^ATXAX(BGPTAXI,21,X))
IF 'X
QUIT
Begin DoDot:1
+8 SET C=$PIECE(^ATXAX(BGPTAXI,21,X,0),U)
+9 IF '$DATA(^AUTTCOM("B",C))
WRITE !!,"*** Warning: Community ",C," is in the taxonomy but was not",!,"found in the standard community table."
SET G=1
+10 QUIT
End DoDot:1
+11 IF G
Begin DoDot:1
+12 WRITE !!,"These communities may have been renamed or there may be patients"
+13 WRITE !,"who have been reassigned from this community to a new community and this"
+14 WRITE !,"could reduce your patient population."
+15 SET BGPQUIT=0
+16 SET DIR(0)="Y"
SET DIR("A")="Do you want to cancel the report and review the communities"
KILL DA
DO ^DIR
KILL DIR
+17 IF $DATA(DIRUT)
SET BGPQUIT=1
+18 IF Y
SET BGPQUIT=1
+19 QUIT
End DoDot:1
IF BGPQUIT
DO XIT
QUIT
MFIC KILL BGPQUIT
+1 SET BGPMFITI=""
+2 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,8)=1
Begin DoDot:1
+3 SET BGPMFITI=""
+4 WRITE !!,"Specify the LOCATION taxonomy to determine which patient visits will be"
+5 WRITE !,"used to determine whether a patient is in the denominators for the report."
+6 WRITE !,"You should have created this taxonomy using QMAN.",!
+7 KILL BGPMFIT
+8 SET BGPMFITI=""
+9 DO ^XBFMK
+10 SET DIC("S")="I $P(^(0),U,15)=9999999.06"
SET DIC="^ATXAX("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Location/Facility Taxonomy: "
+11 SET B=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,9)
IF B
SET DIC("B")=$PIECE(^ATXAX(B,0),U)
+12 DO ^DIC
+13 IF Y=-1
QUIT
+14 SET BGPMFITI=+Y
End DoDot:1
IF BGPMFITI=""
GOTO COMM
BEN ;
+1 SET BGPBEN=1
HOME ;
+1 SET BGPHOME=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,2)
+2 ;I BGPHOME="" W !!,"Home Location not found in Site File!!",!,"PHN Visits counts to Home will be calculated using clinic 11 only!!" H 2 G EXPORT
+3 ;W !,"Your HOME location is defined as: ",$P(^DIC(4,BGPHOME,0),U)," asufac: ",$P(^AUTTLOC(BGPHOME,0),U,10)
EXPORT ;export to area or not?
+1 SET BGPEXPT=""
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to export this data to Area"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO COMM
+4 SET BGPEXPT=Y
+5 SET BGPXPDR=DT
+6 SET BGPNOW=$$NOW^XLFDT
+7 SET BGPUF=$$GETDIR^BGP0UTL2()
+8 ;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")
+9 ;I $P(^AUTTSITE(1,0),U,21)=1 S BGPUF="/usr/spool/uucppublic/"
+10 IF BGPEXPT
IF BGPUF=""
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot continue.....can't find export directory name. EXCEL file",!,"not written."
DO PAUSE^BGP0CL
DO XIT
QUIT
+11 SET BGPFN="CRSCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_001_of_001.TXT"
LOCALF ;
+1 SET BGPLOCAL=""
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to create local delimited files for use in Excel"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO EXPORT
+4 SET BGPLOCAL=Y
+5 IF 'BGPLOCAL
IF 'BGPEXPT
WRITE !!,"You have chosen not to create any files.....exiting"
HANG 3
DO XIT
QUIT
SUM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR("SUMMARY OF NATIONAL GPRA EXPORT FILE TO BE GENERATED")
+3 WRITE !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPTDT)
+4 WRITE !!,"The COMMUNITY Taxonomy to be used is: ",$PIECE(^ATXAX(BGPTAXI,0),U)
+5 IF $GET(BGPMFITI)
WRITE !!,"The MFI Location Taxonomy to be used is: ",$PIECE(^ATXAX(BGPMFITI,0),U)
+6 ;I BGPHOME W !,"The HOME location is: ",$P(^DIC(4,BGPHOME,0),U)," ",$P(^AUTTLOC(BGPHOME,0),U,10)
+7 ;I 'BGPHOME W !,"No HOME Location selected."
+8 IF BGPEXPT
Begin DoDot:1
+9 WRITE !,"The Area Export file will be named: ",!,BGPFN
+10 WRITE !,"and will reside in the ",BGPUF," directory. This is the file you should"
+11 WRITE !,"export to your Area Office. Depending on your site configuration, the"
+12 WRITE !,"file may need to be manually sent to your Area Office.",!
End DoDot:1
+13 IF BGPLOCAL
Begin DoDot:1
+14 WRITE !,"The local files will all begin with ""","CRSLCNT","""and will have the"
+15 WRITE !,"same name except for the last 10 characters, which represent the number"
+16 WRITE !,"of files (e.g. 001_of_003).",!
+17 WRITE !,"NOTE: If the data will fit into one file, only one file beginning"
+18 WRITE !,"with ""","CRSCNT","""will be created, which should be used for"
+19 WRITE !,"both Area Exporting and local use.",!
End DoDot:1
ZIS ;call to XBDBQUE
+1 ;CREATE REPORT ENTRY
+2 KILL DIC
SET X=$PIECE(^VA(200,DUZ,0),U)_"-"_$$D^BGP0UTL(BGPNOW)
SET DIC(0)="L"
SET DIC="^BGPXPT("
SET DLAYGO=90377.11
SET DIADD=1
+3 SET DIC("DR")=".02////"_BGPXPBD_";.03////"_BGPXPTDT_";.04////"_$PIECE(^ATXAX(BGPTAXI,0),U)_";.05////"_$SELECT(BGPMFITI:$PIECE(^ATXAX(BGPMFITI,0),U),1:"")
+4 DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
SET BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!"
HANG 4
DO XIT
QUIT
+5 SET BGPXPRPT=+Y
+6 KILL ^BGPXPT(BGPXPRPT,13)
+7 SET C=0
SET X=""
FOR
SET X=$ORDER(BGPTAX(X))
IF X=""
QUIT
SET C=C+1
SET ^BGPXPT(BGPXPRPT,13,C,0)=X
SET ^BGPXPT(BGPXPRPT,13,"B",X,C)=""
+8 SET ^BGPXPT(BGPXPRPT,13,0)="^90377.111301A^"_C_"^"_C
+9 KILL ^BGPXPT(BGPXPRPT,14)
+10 IF $GET(BGPMFITI)
SET C=0
SET X=""
FOR
SET X=$ORDER(^ATXAX(BGPMFITI,21,"B",X))
IF X=""
QUIT
SET C=C+1
SET Y=$PIECE($GET(^DIC(4,X,0)),U)
SET ^BGPXPT(BGPXPRPT,14,C,0)=Y
SET ^BGPXPT(BGPXPRPT,14,"B",Y,C)=""
+11 SET ^BGPXPT(BGPXPRPT,14,0)="^90377.111401A^"_C_"^"_C
ONEF ;
+1 SET BGPONEF=""
+2 KILL IOP,%ZIS
WRITE !!
SET %ZIS="PQM"
DO ^%ZIS
+3 IF POP
WRITE !,"Report Aborted"
SET DA=BGPXPRPT
SET DIK="^BGPXPT("
DO ^DIK
KILL DIK
DO XIT
QUIT
+4 IF $DATA(IO("Q"))
GOTO TSKMN
DRIVER ;
+1 DO PROC^BGP0DNE
+2 USE IO
+3 DO PRINT^BGP0DNE
+4 DO ^%ZISC
+5 QUIT
+6 ;
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^BGP0DNE"
SET ZTDTH=""
SET ZTDESC="NATIONAL GPRA REPORT 09"
DO ^%ZTLOAD
DO XIT
QUIT
+6 QUIT
+7 ;
XIT ;
+1 DO ^%ZISC
+2 DO EN^XBVK("BGP")
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL DIRUT,DUOUT,DIR,DOD
+4 KILL DIADD,DLAYGO
+5 DO KILL^AUPNPAT
+6 KILL X,X1,X2,X3,X4,X5,X6
+7 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
+8 KILL N,N1,N2,N3,N4,N5,N6
+9 KILL BD,ED
+10 DO KILL^AUPNPAT
+11 DO ^XBFMK
+12 QUIT
+13 ;
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)!$DATA(IO("S"))
QUIT
+3 WRITE !
+4 NEW DIR,X
+5 KILL DIR,DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
DO ^DIR
KILL DIR
+7 QUIT
+8 ;----------
USR() ;EP -
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - .
+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 ;
CNTSF ;EP
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out National GPRA Export file...."
+2 IF BGPEXPT
DO CNTSF1
+3 IF 'BGPLOCAL
GOTO STOP
+4 ;count up total # of records and divide by 65,536
+5 SET BGPX=0
SET BGPTOT=0
FOR
SET BGPX=$ORDER(^BGPXPT(BGPXPRPT,11,BGPX))
IF BGPX'=+BGPX
QUIT
SET BGPTOT=BGPTOT+1
+6 SET BGPNF1=BGPTOT/65536
+7 ; - only 1 and it is created already
IF BGPNF1'>1
IF BGPEXPT
GOTO STOP
+8 SET BGPNF=$SELECT($PIECE(BGPNF1,".",2)]"":BGPNF1+1,1:BGPNF1)
+9 SET BGPNF=$PIECE(BGPNF,".")
+10 SET BGPX=0
SET BGPLX=0
+11 SET ^BGPXPT(BGPXPRPT,12,0)="^90377.111201A^"_BGPNF_"^"_BGPNF
+12 FOR BGPZ=1:1:BGPNF
Begin DoDot:1
+13 SET BGPFN="CRSLCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_"_$$LZERO^BGP0UTL(BGPZ,3)_"_of_"_$$LZERO^BGP0UTL(BGPNF,3)_".TXT"
+14 SET ^BGPXPT(BGPXPRPT,12,BGPZ+1,0)=BGPFN_" --- "_BGPUF
+15 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,BGPFN
+16 SET Y=$$OPEN^%ZISH(BGPUF,BGPFN,"W")
+17 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+18 USE IO
+19 SET Y="SITE NAME^ASUFAC^DATE FILE RUN^FILE BEGIN DATE^FILE END DATE^PATIENT UNIQUE REGISTRATION ID^DOB^GENDER^STATE^COUNTY^MEASURE ID^MEASURE"
+20 SET P=13
FOR X=2000:1:BGPXPFYY
SET $PIECE(Y,U,P)="GPRA YR "_X
SET P=P+1
+21 WRITE Y,!
+22 SET BGPC=1
SET BGPX=$SELECT(BGPLX:BGPLX,1:0)
+23 FOR
SET BGPX=$ORDER(^BGPXPT(BGPXPRPT,11,BGPX))
IF BGPX'=+BGPX!(BGPC>65535)
QUIT
Begin DoDot:2
+24 WRITE $GET(^BGPXPT(BGPXPRPT,11,BGPX,0)),!
+25 SET BGPC=BGPC+1
+26 SET BGPLX=BGPX
End DoDot:2
+27 DO ^%ZISC
End DoDot:1
STOP ;
+1 KILL ^BGPXPT(BGPXPRPT,11)
+2 QUIT
CNTSF1 ;EP
+1 ;write out one flie only
+2 SET BGPZ=1
SET BGPFN="CRSCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP0UTL(BGPXPBD)_$$D^BGP0UTL(BGPXPTDT)_$$D^BGP0UTL(BGPNOW)_"_001_of_001.TXT"
+3 SET ^BGPXPT(BGPXPRPT,12,BGPZ,0)=BGPFN_" --- "_BGPUF
+4 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,BGPFN
+5 LOCK +^BGPDATA:10
IF '$TEST
QUIT
+6 ;EXPORT GLOBAL FOR AREA EXPORT
KILL ^BGPDATA
+7 SET BGPC=0
+8 SET Y="SITE NAME^ASUFAC^DATE FILE RUN^FILE BEGIN DATE^FILE END DATE^PATIENT UNIQUE REGISTRATION ID^DOB^GENDER^STATE^COUNTY^MEASURE ID^MEASURE"
+9 SET P=13
FOR X=2000:1:BGPXPFYY
SET $PIECE(Y,U,P)="GPRA YR "_X
SET P=P+1
+10 SET BGPC=BGPC+1
+11 SET ^BGPDATA(BGPC)=Y
+12 SET BGPX=0
+13 FOR
SET BGPX=$ORDER(^BGPXPT(BGPXPRPT,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+14 SET BGPC=BGPC+1
+15 SET ^BGPDATA(BGPC)=$GET(^BGPXPT(BGPXPRPT,11,BGPX,0))
End DoDot:1
+16 ;D ^%ZISC
+17 SET XBGL="BGPDATA"
+18 SET XBMED="F"
SET XBFN=BGPFN
SET XBTLE="SAVE OF NATIONAL GPRA EXPORT DATA BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBFLT=1
+19 DO ^XBGSAVE
+20 LOCK -^BGPDATA
+21 ;NOTE: kill of unsubscripted global for use in export to area.
KILL ^TMP($JOB),^BGPDATA
+22 QUIT
PROC ;EP
+1 SET BGPBT=$HOROLOG
+2 DO JRNL^BGP0UTL
+3 ;in xp report
SET BGPXPXPX=1
+4 SET BGPJ=$JOB
SET BGPH=$HOROLOG
+5 SET BGPCHSO=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,6)
+6 SET BGPXPTOT=0
PROC1 ;process each patient
+1 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+2 ;S DFN=4812 D
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"
QUIT
+5 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,12)
IF $DATA(^DIBT($PIECE(^BGPSITE(DUZ(2),0),U,12),1,DFN))
QUIT
+6 SET BGPXPUP=""
+7 FOR BGPXPCY=300:1:BGPXPFYI
Begin DoDot:2
+8 ;set beginning date and ending date
+9 SET BGPXXX=BGPXPCY_"0630"
+10 IF '$$ACTUP^BGP0D1(DFN,$$FMADD^XLFDT(BGPXXX,-(3*365)),BGPXXX,BGPTAXI,1)
QUIT
+11 SET BGPXPUP=1
End DoDot:2
+12 ;NOT IN ANY USER POP
IF 'BGPXPUP
QUIT
+13 DO PROCYRS
+14 SET X=0
FOR
SET X=$ORDER(BGPXPDAT(X))
IF X'=+X
QUIT
Begin DoDot:2
+15 SET BGPXPTOT=BGPXPTOT+1
+16 SET ^BGPXPT(BGPXPRPT,11,BGPXPTOT,0)=BGPXPDAT(X)
End DoDot:2
+17 QUIT
End DoDot:1
+18 SET ^BGPXPT(BGPXPRPT,11,0)="^90377.111101A^"_BGPXPTOT_"^"_BGPXPTOT
+19 SET BGPET=$HOROLOG
+20 DO CNTSF
+21 QUIT
PROCYRS ;
+1 ;process each year from 2000, starting at "^" piece 13, loop through all measures
+2 SET BGPXPPIE=12
+3 KILL BGPXPDAT
+4 FOR BGPXPCY=300:1:BGPXPFYI
Begin DoDot:1
+5 ;set beginning date and ending date
+6 SET BGPBD=(BGPXPCY-1)_"0701"
SET BGPED=BGPXPCY_"0630"
SET BGPXPPIE=BGPXPPIE+1
+7 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+8 DO PROCCY^BGP0D1
+9 DO PROCIND
+10 QUIT
End DoDot:1
+11 QUIT
PROCIND ;
+1 SET BGPXPPD=$PIECE(^DIC(4,DUZ(2),0),U)
+2 SET $PIECE(BGPXPPD,U,2)=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+3 SET $PIECE(BGPXPPD,U,3)=$$EDT^BGP0UTL(DT)
+4 SET $PIECE(BGPXPPD,U,4)=$$EDT^BGP0UTL(BGPXPBD)
+5 SET $PIECE(BGPXPPD,U,5)=$$EDT^BGP0UTL(BGPXPTDT)
+6 SET $PIECE(BGPXPPD,U,6)=$$UID^BGP0DCHW(DFN)
+7 SET $PIECE(BGPXPPD,U,7)=$$EDT^BGP0UTL($PIECE(^DPT(DFN,0),U,3))
+8 SET $PIECE(BGPXPPD,U,8)=$PIECE(^DPT(DFN,0),U,2)
+9 SET $PIECE(BGPXPPD,U,9)=$$STATE^BGP0DCHW(DFN)
+10 SET $PIECE(BGPXPPD,U,10)=$$COUNTY(DFN)
+11 ;process each measure and set record BGPXPDAT per measure
+12 SET BGPXPMI=0
FOR
SET BGPXPMI=$ORDER(^BGPCTRL(BGPXPFYC,55,BGPXPMI))
IF 'BGPXPMI
QUIT
Begin DoDot:1
+13 SET BGPXPX=$PIECE(^BGPCTRL(BGPXPFYC,55,BGPXPMI,0),U,1)
+14 KILL BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+15 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30
+16 KILL BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13
+17 KILL BGPNUMV
+18 SET BGPXPTV=""
+19 KILL ^TMP($JOB)
+20 IF $DATA(^BGPINDT(BGPXPX,1))
XECUTE ^BGPINDT(BGPXPX,1)
+21 ;now get each individual measure and set value
+22 SET BGPXPT=0
FOR
SET BGPXPT=$ORDER(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT))
IF BGPXPT'=+BGPXPT
QUIT
Begin DoDot:2
+23 SET BGPXPMID=$PIECE(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,0),U,1)
+24 IF '$DATA(BGPXPDAT(BGPXPMID))
SET BGPXPDAT(BGPXPMID)=BGPXPPD
+25 SET $PIECE(BGPXPDAT(BGPXPMID),U,11)=BGPXPMID
+26 SET $PIECE(BGPXPDAT(BGPXPMID),U,12)=$PIECE(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,0),U,3)
+27 SET X=""
+28 XECUTE ^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPT,1)
+29 SET $PIECE(BGPXPDAT(BGPXPMID),U,BGPXPPIE)=X
+30 QUIT
End DoDot:2
+31 KILL BGPVAL,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+32 KILL ^TMP($JOB)
End DoDot:1
+33 QUIT
COUNTY(P) ;EP
+1 SET C=$$COMMRES^AUPNPAT(P,"C")
+2 IF C=""
QUIT ""
+3 SET S=$EXTRACT(C,1,4)
+4 SET S=$ORDER(^AUTTCTY("C",S,0))
+5 IF S=""
QUIT S
+6 QUIT $PIECE($GET(^AUTTCTY(S,0)),U,1)
+7 ;
PRINT ;EP - CALLED FROM XBDBQUE
+1 SET BGPGPG=0
SET BGPQUIT=""
+2 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+3 DO HEADER
+4 WRITE !!,"Community Taxonomy: ",$PIECE(^ATXAX(BGPTAXI,0),U)
+5 IF '$GET(BGPALLPT)
IF '$GET(BGPSEAT)
WRITE !?10,"The following communities are included in this report:",!
Begin DoDot:1
+6 SET BGPZZ=""
SET BGPN=0
SET BGPY=""
FOR
SET BGPZZ=$ORDER(BGPTAX(BGPZZ))
IF BGPZZ=""!(BGPQUIT)
QUIT
SET BGPN=BGPN+1
SET BGPY=BGPY_$SELECT(BGPN=1:"",1:";")_BGPZZ
+7 SET BGPZZ=0
SET C=0
FOR BGPZZ=1:3:BGPN
Begin DoDot:2
+8 IF $Y>(BGPIOSL-2)
DO HEADER
IF $GET(BGPQUIT)
QUIT
+9 WRITE !?10,$EXTRACT($PIECE(BGPY,";",BGPZZ),1,20),?30,$EXTRACT($PIECE(BGPY,";",(BGPZZ+1)),1,20),?60,$EXTRACT($PIECE(BGPY,";",(BGPZZ+2)),1,20)
+10 QUIT
End DoDot:2
IF $GET(BGPQUIT)
QUIT
End DoDot:1
+11 IF BGPQUIT
QUIT
+12 IF $GET(BGPMFITI)
WRITE !!?10,"MFI Visit Location Taxonomy Name: ",$PIECE(^ATXAX(BGPMFITI,0),U)
+13 IF $GET(BGPMFITI)
WRITE !?10,"The following Locations are used for patient visits in this report:",!
Begin DoDot:1
+14 SET BGPZZ=""
SET BGPN=0
SET BGPY=""
FOR
SET BGPZZ=$ORDER(^ATXAX(BGPMFITI,21,"B",BGPZZ))
IF BGPZZ=""
QUIT
SET BGPN=BGPN+1
SET BGPY=BGPY_$SELECT(BGPN=1:"",1:";")_$PIECE($GET(^DIC(4,BGPZZ,0)),U)
+15 SET BGPZZ=0
SET C=0
FOR BGPZZ=1:3:BGPN
Begin DoDot:2
+16 IF $Y>(BGPIOSL-2)
DO HEADER
IF $GET(BGPQUIT)
QUIT
+17 WRITE !?10,$EXTRACT($PIECE(BGPY,";",BGPZZ),1,20),?30,$EXTRACT($PIECE(BGPY,";",(BGPZZ+1)),1,20),?60,$EXTRACT($PIECE(BGPY,";",(BGPZZ+2)),1,20)
+18 QUIT
End DoDot:2
IF $GET(BGPQUIT)
QUIT
End DoDot:1
+19 IF BGPQUIT
QUIT
+20 IF $Y>(IOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+21 WRITE !!,"The following files were created: "
+22 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPXPT(BGPXPRPT,12,BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:1
+23 IF $Y>(IOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+24 WRITE !?5,$PIECE(^BGPXPT(BGPXPRPT,12,BGPX,0),U)
End DoDot:1
+25 KILL BGPX,BGPQUIT
+26 QUIT
+1 IF 'BGPGPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BGPQUIT=1
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET BGPGPG=BGPGPG+1
+2 ;maw
IF $GET(BGPGUI)
WRITE "ZZZZZZZ",!
+3 WRITE $PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
+4 WRITE $$CTR("*** IHS 2010 Comprehensive National GPRA Export ***",80),!
+5 WRITE !,$$CTR($$RPTVER^BGP0BAN,80)
+6 WRITE !,$$CTR("Date Export Run: "_$$FMTE^XLFDT(DT),80)
+7 WRITE !,$$CTR("Site where Run: "_$PIECE(^DIC(4,DUZ(2),0),U),80)
+8 WRITE !,$$CTR("Report Generated by: "_$$USR,80)
+9 SET X="Time Period: "_$$FMTE^XLFDT(BGPXPBD)_" to "_$$FMTE^XLFDT(BGPXPTDT)
WRITE !,$$CTR(X,80),!
+10 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+11 QUIT
