BGP7DNE8 ; IHS/CMI/LAB - NATL COMP EXPORT ; 17 Jul 2008 9:24 AM
;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
;
;
W:$D(IOF) @IOF
INTRO ;
D XIT
S BGPXPFYC=$O(^BGPCTRL("B","2007",0))
S X=0 F S X=$O(^BGPCTRL(BGPXPFYC,53,X)) Q:X'=+X D
.I $Y>(IOSL-3) D EOP W @IOF
.W !,^BGPCTRL(BGPXPFYC,53,X,0)
K DIR S DIR(0)="E",DIR("A")="Press enter to continue: " D ^DIR K DIR
D TAXCHK^BGP7XTCN
TP ;
S BGPRTYPE=1,BGPXPRP=1,BGPXPFYY=2008,BGPXPFYI=308
S BGPXPBD=3060701,BGPXPEDT=3080630
W !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPEDT)
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)
;
EXPORT ;export to area or not?
S BGPEXPT=""
S DIR(0)="Y",DIR("A")="Do you wish to create the export file for NPIRS" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G COMM
S BGPEXPT=Y
S BGPXPDR=DT
S BGPNOW=$$NOW^XLFDT
S BGPUF=""
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/"
S BGPFN="CRSCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(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(BGPXPEDT)
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 NPIRS Export file will be named: ",!,BGPFN
.W !,"and will reside in the ",BGPUF," directory. This is the file you should"
.W !,"export to NPIRS. ",!
I BGPLOCAL D
.W !,"If you chose to create local files, they will all begin with ""","CRSLCNT",""""
.W !,"and will have the same name except for the last 10 characters, which"
.W !,"represent the number of files (e.g. 001_of_003). Do NOT export these files"
.W !,"to NPIRS as they are for your local use only. Only export the file as named"
.W !,"above.",!
.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 exporting to NPIRS and local use.",!
ZIS ;call to XBDBQUE
;CREATE REPORT ENTRY
K DIC S X=$P(^VA(200,DUZ,0),U)_"-"_$$D^BGP7UTL(BGPNOW),DIC(0)="L",DIC="^BGPXPA(",DLAYGO=90530.11,DIADD=1
S DIC("DR")=".02////"_BGPXPBD_";.03////"_BGPXPEDT_";.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 ^BGPXPA(BGPXPRPT,13)
S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPXPA(BGPXPRPT,13,C,0)=X,^BGPXPA(BGPXPRPT,13,"B",X,C)=""
S ^BGPXPA(BGPXPRPT,13,0)="^90530.111301A^"_C_"^"_C
K ^BGPXPA(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 ^BGPXPA(BGPXPRPT,14,C,0)=Y,^BGPXPA(BGPXPRPT,14,"B",Y,C)=""
S ^BGPXPA(BGPXPRPT,14,0)="^90530.111401A^"_C_"^"_C
ONEF ;
S BGPONEF=""
K IOP,%ZIS W !! S %ZIS="PQM" D ^%ZIS
I POP W !,"Report Aborted" S DA=BGPXPRPT,DIK="^BGPXPA(" D ^DIK K DIK D XIT Q
I $D(IO("Q")) G TSKMN
DRIVER ;
D PROC^BGP7DNE8
U IO
D PRINT^BGP7DNE8
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^BGP7DNE8",ZTDTH="",ZTDESC="NATIONAL GPRA REPORT 07" D ^%ZTLOAD D XIT Q
Q
;
XIT ;
D ^%ZISC
D EN^XBVK("BGP")
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 ^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(^BGPXPA(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 ^BGPXPA(BGPXPRPT,12,0)="^90530.111201A^"_BGPNF_"^"_BGPNF
F BGPZ=1:1:BGPNF D
.S BGPFN="CRSLCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(BGPNOW)_"_"_$$LZERO^BGP7UTL(BGPZ,3)_"_of_"_$$LZERO^BGP7UTL(BGPNF,3)_".TXT"
.S ^BGPXPA(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=2007: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(^BGPXPA(BGPXPRPT,11,BGPX)) Q:BGPX'=+BGPX!(BGPC>65535) D
..W $G(^BGPXPA(BGPXPRPT,11,BGPX,0)),!
..S BGPC=BGPC+1
..S BGPLX=BGPX
.D ^%ZISC
STOP ;
K ^BGPXPA(BGPXPRPT,11)
Q
CNTSF1 ;EP
;write out one file only
S BGPZ=1,BGPFN="CRSCNT"_$P(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(BGPNOW)_"_001_of_001.TXT"
S ^BGPXPA(BGPXPRPT,12,BGPZ,0)=BGPFN_" --- "_BGPUF
I '$D(ZTQUEUED) U IO W !?10,BGPFN
L +^BGPDATA:10 I '$T W:'$D(ZTQUEUED) "Unable to lock global" Q
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=2007: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(^BGPXPA(BGPXPRPT,11,BGPX)) Q:BGPX'=+BGPX D
.S BGPC=BGPC+1
.S ^BGPDATA(BGPC)=$G(^BGPXPA(BGPXPRPT,11,BGPX,0))
;D ^%ZISC
S XBGL="BGPDATA",XBQ="N" ;do not send to area
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^BGP7UTL
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
.Q:'$D(^DPT(DFN,0))
.Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"
.S BGPXPUP=""
.F BGPXPCY=307:1:BGPXPFYI D
..;set beginning date and ending date
..S BGPXXX=BGPXPCY_"0630"
..Q:'$$ACTUP^BGP7D1(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 ^BGPXPA(BGPXPRPT,11,BGPXPTOT,0)=BGPXPDAT(X)
.Q
S ^BGPXPA(BGPXPRPT,11,0)="^90530.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=307: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,-(3*365))
.D PROCCY^BGP7D1
.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^BGP7UTL(DT)
S $P(BGPXPPD,U,4)=$$EDT^BGP7UTL(BGPXPBD)
S $P(BGPXPPD,U,5)=$$EDT^BGP7UTL(BGPXPEDT)
S $P(BGPXPPD,U,6)=$$UID^BGP7DCHW(DFN)
S $P(BGPXPPD,U,7)=$$EDT^BGP7UTL($P(^DPT(DFN,0),U,3))
S $P(BGPXPPD,U,8)=$P(^DPT(DFN,0),U,2)
S $P(BGPXPPD,U,9)=$$STATE^BGP7DCHW(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 BGPXPNV=""
.K ^TMP($J)
.I $D(^BGPINDA(BGPXPX,1)) X ^BGPINDA(BGPXPX,1)
.;now get each individual measure and set value
.S BGPXPA=0 F S BGPXPA=$O(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA)) Q:BGPXPA'=+BGPXPA D
..S BGPXPMID=$P(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA,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,BGPXPA,0),U,3)
..S X=""
..X ^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA,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(^BGPXPA(BGPXPRPT,12,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(IOSL-3) D HEADER Q:BGPQUIT
.W !?5,$P(^BGPXPA(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 2007 Comprehensive National GPRA Export ***",80),!
W !,$$CTR("CRS 2007, Version 7.0",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(BGPXPEDT) W !,$$CTR(X,80),!
W $TR($J("",80)," ","-")
Q
BGP7DNE8 ; IHS/CMI/LAB - NATL COMP EXPORT ; 17 Jul 2008 9:24 AM
+1 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
INTRO ;
+1 DO XIT
+2 SET BGPXPFYC=$ORDER(^BGPCTRL("B","2007",0))
+3 SET X=0
FOR
SET X=$ORDER(^BGPCTRL(BGPXPFYC,53,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO EOP
WRITE @IOF
+5 WRITE !,^BGPCTRL(BGPXPFYC,53,X,0)
End DoDot:1
+6 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press enter to continue: "
DO ^DIR
KILL DIR
+7 DO TAXCHK^BGP7XTCN
TP ;
+1 SET BGPRTYPE=1
SET BGPXPRP=1
SET BGPXPFYY=2008
SET BGPXPFYI=308
+2 SET BGPXPBD=3060701
SET BGPXPEDT=3080630
+3 WRITE !!,"The date ranges for this report are: ",$$FMTE^XLFDT(BGPXPBD)," to ",?31,$$FMTE^XLFDT(BGPXPEDT)
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 ;
EXPORT ;export to area or not?
+1 SET BGPEXPT=""
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to create the export file for NPIRS"
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=""
+8 IF ^%ZOSF("OS")["PC"!(^%ZOSF("OS")["NT")!($PIECE($GET(^AUTTSITE(1,0)),U,21)=2)
SET BGPUF=$SELECT($PIECE($GET(^AUTTSITE(1,1)),U,2)]"":$PIECE(^AUTTSITE(1,1),U,2),1:"C:\EXPORT")
+9 IF $PIECE(^AUTTSITE(1,0),U,21)=1
SET BGPUF="/usr/spool/uucppublic/"
+10 SET BGPFN="CRSCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(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(BGPXPEDT)
+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 NPIRS 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 NPIRS. ",!
End DoDot:1
+12 IF BGPLOCAL
Begin DoDot:1
+13 WRITE !,"If you chose to create local files, they will all begin with ""","CRSLCNT",""""
+14 WRITE !,"and will have the same name except for the last 10 characters, which"
+15 WRITE !,"represent the number of files (e.g. 001_of_003). Do NOT export these files"
+16 WRITE !,"to NPIRS as they are for your local use only. Only export the file as named"
+17 WRITE !,"above.",!
+18 WRITE !,"NOTE: If the data will fit into one file, only one file beginning"
+19 WRITE !,"with ""","CRSCNT","""will be created, which should be used for"
+20 WRITE !,"both exporting to NPIRS 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^BGP7UTL(BGPNOW)
SET DIC(0)="L"
SET DIC="^BGPXPA("
SET DLAYGO=90530.11
SET DIADD=1
+3 SET DIC("DR")=".02////"_BGPXPBD_";.03////"_BGPXPEDT_";.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 ^BGPXPA(BGPXPRPT,13)
+7 SET C=0
SET X=""
FOR
SET X=$ORDER(BGPTAX(X))
IF X=""
QUIT
SET C=C+1
SET ^BGPXPA(BGPXPRPT,13,C,0)=X
SET ^BGPXPA(BGPXPRPT,13,"B",X,C)=""
+8 SET ^BGPXPA(BGPXPRPT,13,0)="^90530.111301A^"_C_"^"_C
+9 KILL ^BGPXPA(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 ^BGPXPA(BGPXPRPT,14,C,0)=Y
SET ^BGPXPA(BGPXPRPT,14,"B",Y,C)=""
+11 SET ^BGPXPA(BGPXPRPT,14,0)="^90530.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="^BGPXPA("
DO ^DIK
KILL DIK
DO XIT
QUIT
+4 IF $DATA(IO("Q"))
GOTO TSKMN
DRIVER ;
+1 DO PROC^BGP7DNE8
+2 USE IO
+3 DO PRINT^BGP7DNE8
+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^BGP7DNE8"
SET ZTDTH=""
SET ZTDESC="NATIONAL GPRA REPORT 07"
DO ^%ZTLOAD
DO XIT
QUIT
+6 QUIT
+7 ;
XIT ;
+1 DO ^%ZISC
+2 DO EN^XBVK("BGP")
+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 ^XBFMK
+11 QUIT
+12 ;
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(^BGPXPA(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 ^BGPXPA(BGPXPRPT,12,0)="^90530.111201A^"_BGPNF_"^"_BGPNF
+12 FOR BGPZ=1:1:BGPNF
Begin DoDot:1
+13 SET BGPFN="CRSLCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(BGPNOW)_"_"_$$LZERO^BGP7UTL(BGPZ,3)_"_of_"_$$LZERO^BGP7UTL(BGPNF,3)_".TXT"
+14 SET ^BGPXPA(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=2007: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(^BGPXPA(BGPXPRPT,11,BGPX))
IF BGPX'=+BGPX!(BGPC>65535)
QUIT
Begin DoDot:2
+24 WRITE $GET(^BGPXPA(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 ^BGPXPA(BGPXPRPT,11)
+2 QUIT
CNTSF1 ;EP
+1 ;write out one file only
+2 SET BGPZ=1
SET BGPFN="CRSCNT"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$$D^BGP7UTL(BGPXPBD)_$$D^BGP7UTL(BGPXPEDT)_$$D^BGP7UTL(BGPNOW)_"_001_of_001.TXT"
+3 SET ^BGPXPA(BGPXPRPT,12,BGPZ,0)=BGPFN_" --- "_BGPUF
+4 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,BGPFN
+5 LOCK +^BGPDATA:10
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
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=2007: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(^BGPXPA(BGPXPRPT,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+14 SET BGPC=BGPC+1
+15 SET ^BGPDATA(BGPC)=$GET(^BGPXPA(BGPXPRPT,11,BGPX,0))
End DoDot:1
+16 ;D ^%ZISC
+17 ;do not send to area
SET XBGL="BGPDATA"
SET XBQ="N"
+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^BGP7UTL
+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 IF '$DATA(^DPT(DFN,0))
QUIT
+3 IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"
QUIT
+4 SET BGPXPUP=""
+5 FOR BGPXPCY=307:1:BGPXPFYI
Begin DoDot:2
+6 ;set beginning date and ending date
+7 SET BGPXXX=BGPXPCY_"0630"
+8 IF '$$ACTUP^BGP7D1(DFN,$$FMADD^XLFDT(BGPXXX,-(3*365)),BGPXXX,BGPTAXI,1)
QUIT
+9 SET BGPXPUP=1
End DoDot:2
+10 ;NOT IN ANY USER POP
IF 'BGPXPUP
QUIT
+11 DO PROCYRS
+12 SET X=0
FOR
SET X=$ORDER(BGPXPDAT(X))
IF X'=+X
QUIT
Begin DoDot:2
+13 SET BGPXPTOT=BGPXPTOT+1
+14 SET ^BGPXPA(BGPXPRPT,11,BGPXPTOT,0)=BGPXPDAT(X)
End DoDot:2
+15 QUIT
End DoDot:1
+16 SET ^BGPXPA(BGPXPRPT,11,0)="^90530.111101A^"_BGPXPTOT_"^"_BGPXPTOT
+17 SET BGPET=$HOROLOG
+18 DO CNTSF
+19 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=307: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,-(3*365))
+8 DO PROCCY^BGP7D1
+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^BGP7UTL(DT)
+4 SET $PIECE(BGPXPPD,U,4)=$$EDT^BGP7UTL(BGPXPBD)
+5 SET $PIECE(BGPXPPD,U,5)=$$EDT^BGP7UTL(BGPXPEDT)
+6 SET $PIECE(BGPXPPD,U,6)=$$UID^BGP7DCHW(DFN)
+7 SET $PIECE(BGPXPPD,U,7)=$$EDT^BGP7UTL($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^BGP7DCHW(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 BGPXPNV=""
+19 KILL ^TMP($JOB)
+20 IF $DATA(^BGPINDA(BGPXPX,1))
XECUTE ^BGPINDA(BGPXPX,1)
+21 ;now get each individual measure and set value
+22 SET BGPXPA=0
FOR
SET BGPXPA=$ORDER(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA))
IF BGPXPA'=+BGPXPA
QUIT
Begin DoDot:2
+23 SET BGPXPMID=$PIECE(^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA,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,BGPXPA,0),U,3)
+27 SET X=""
+28 XECUTE ^BGPCTRL(BGPXPFYC,55,BGPXPMI,11,BGPXPA,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(^BGPXPA(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(^BGPXPA(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 2007 Comprehensive National GPRA Export ***",80),!
+5 WRITE !,$$CTR("CRS 2007, Version 7.0",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(BGPXPEDT)
WRITE !,$$CTR(X,80),!
+10 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+11 QUIT
