BGP9ASL.m

BGP9ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;

 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009

 ;; ;

EP ;EP - CALLED FROM OPTION

 K BGPSUL

 D EN

 Q

EOJ ;EP

 K BGPTIND,BGPHIGH,BGPANS,BGPC,BGPGANS,BGPGC,BGPGI,BGPI,BGPX

 Q

 ;; ;

EN ;EP -- main entry point

 D EN^VALM("BGP 09 AREA SELECT SITES")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="Area Aggregate Site Selection"

 S VALMHDR(2)="* indicates the site has been selected"

 S VALMHDR(3)="+ after the facility name denotes a CHS Only Site"

 S X="#",$E(X,6)="SU",$E(X,17)="FACILITY",$E(X,32)="BEG DATE",$E(X,42)="END DATE",$E(X,52)="BASE BEG",$E(X,62)="BASE END",$E(X,72)="DATE RUN"

 S VALMHDR(4)=X

 Q

 ;

INIT ; -- init variables and list array

 I BGPRTYPE=1 D NGR^BGP9ASL1 Q

 I BGPRTYPE=3 D HED^BGP9ASL1 Q

 I BGPRTYPE=5 D ELD^BGP9ASL1 Q

 I BGPRTYPE=6 D PED^BGP9ASL1 Q

 I BGPRTYPE=7 D ONM^BGP9ASL1 Q

 I BGPRTYPE=8 D EO^BGP9ASL1 Q

 Q

FAC(S) ;

 NEW N S N=$O(^AUTTLOC("C",S,0))

 I N="" Q N

 Q $P(^DIC(4,N,0),U)

SU(S) ;

 NEW N S N=$O(^AUTTSU("C",S,0))

 I N="" Q N

 Q $P(^AUTTSU(N,0),U)

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 Q

 ;

EXPND ; -- expand code

 Q

 ;

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

 Q

 ;

ADD ;EP

 W !

 S DIR(0)="LO^1:"_BGPHIGH,DIR("A")="Which Facility"

 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No facilities selected." G ADDX

 I $D(DIRUT) W !,"No facilities selected." G ADDX

 D FULL^VALM1 W:$D(IOF) @IOF

 S BGPANS=Y,BGPC="" F BGPI=1:1 S BGPC=$P(BGPANS,",",BGPI) Q:BGPC=""  S BGPSUL(BGPTIND(BGPC,BGPC))=""

ADDX ;

 D BACK

 Q

 ;

ADDALL ;

 F X=1:1:BGPHIGH S BGPSUL(BGPTIND(X,X))=""

 D BACK

 Q

 ;

REM ;

 W ! S DIR(0)="LO^1:"_BGPHIGH,DIR("A")="Which Facility(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No facilities selected." G ADDX

 I $D(DIRUT) W !,"No facilities selected." G ADDX

 D FULL^VALM1 W:$D(IOF) @IOF

 S BGPANS=Y,BGPC="" F BGPI=1:1 S BGPC=$P(BGPANS,",",BGPI) Q:BGPC=""  K BGPSUL(BGPTIND(BGPC,BGPC))

REMX ;

 D BACK

 Q

GET(BGPSUL,BGPFILE,BGPRT,BGPPER,BGPQTR,BGPVDT,BGPBEN) ;EP - CALLED FROM GUI TO GET FILES FOR DISPLAY ON AREA REPORT

 ;BGPSUL is array returned with iens from the file

 ;BGPFILE is the file these iens belong to and is returned to you

 ;input:

 ;  BGPRT:  1 if national gpra

 ;          9 if area performance

 ;          3 if HEDIS

 ;          5 if Elder report

 ;          8 if new childhood weight

 ;          7 if other national measures

 ;          

 ;  BGPPER - this is the year they select if they answered the above question

 ;           with a 1 through 4  e.g  305000 (fileman imprecise date for 2006)

 ;           if they chose 5 then this will be the end date the enter

 ;           if this is the national gpra report (AGP) you can pass a blank here

 ;   BGPQTR - this is equal to 1,2,3,4 or 5 depending on how the user answers the following

 ;           DIR call:

 ;               Select one of the following:

 ;

 ;         1         January 1 - December 31

 ;         2         April 1 - March 31

 ;         3         July 1 - June 30

 ;         4         October 1 - September 30

 ;         5         User defined date range

 ;       Enter the date range for your report:

 ;

 ;  BGPVDT - baseline year entered by user in internal fileman format, year only

 ;           e.g.  3010000

 ;           if this is the national gpra report (AGP) you can pass a blank here

 ;

 ;  BGPBEN - 1 for Indians only, 2 for Not Indian, 3 for both (see reader call

 ;           at subroutine BEN in BGP9DL 

 ;           if this is the national gpra report (AGP) you can pass a blank here

 ;

 ;               

 K BGPTIND S BGPHIGH=""

 S BGPSUCNT=0,BGPSU="",BGPSUC=0

 I BGPRT=1 D G1

 I BGPRT=3 D G3

 I BGPRT=5 D G5

 I BGPRT=9 D G9

 I BGPRT=8 D G8

 I BGPRT=7 D G7

 I BGPRT=6 D G6

 Q

G1 ;

 S X=$O(^BGPCTRL("B",2009,0))

 S Y=^BGPCTRL(X,0)

 S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)

 S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)

 S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)

 S BGPPER=$P(Y,U,14),BGPQTR=3

 I $G(BGPNGR09) D

 . S BGPBD=3090701,BGPED=3100630

 . S BGPPBD=3080701,BGPPED=3090630

 . S BGPPER=3100000

 ;LORI REMOVE THIS AFTER TESTING

 ;S BGPBD=3030101,BGPED=3031231

 ;S BGPBBD=3000101,BGPBED=3001231

 ;S BGPPBD=3020101,BGPPED=3021231

 ;S BGPPER=3030000,BGPQTR=3,BGPBEN=1

 ;

 S BGPBEN=1

 S BGPFILE=90536.03

 S BGPX=0 F  S BGPX=$O(^BGPGPDCN(BGPX)) Q:BGPX'=+BGPX  D

 . Q:'$D(^BGPGPDCN(BGPX,0))

 . S V=^BGPGPDCN(BGPX,0)

 . N BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=1

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPGPDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G3 ;

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPFILE=90537.03

 S BGPX=0 F  S BGPX=$O(^BGPHEDCN(BGPX)) Q:'BGPX  D

 . Q:'$D(^BGPHEDCN(BGPX,0))

 . S V=^BGPHEDCN(BGPX,0)

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=3

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPHEDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G5 ;

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPFILE=90538.03

 S BGPX=0 F  S BGPX=$O(^BGPELDCN(BGPX)) Q:'BGPX  D

 . Q:'$D(^BGPELDCN(BGPX,0))

 . S V=^BGPELDCN(BGPX,0)

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=5

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPELDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G6 ;

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPFILE=90538.03

 S BGPX=0 F  S BGPX=$O(^BGPPEDCN(BGPX)) Q:'BGPX  D

 . Q:'$D(^BGPPEDCN(BGPX,0))

 . S V=^BGPPEDCN(BGPX,0)

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,11)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,10)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13) ;_$S($P(^BGPELDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G7 ;

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPFILE=90536.03

 S BGPX=0 F  S BGPX=$O(^BGPGPDCN(BGPX)) Q:BGPX'=+BGPX  D

 . Q:'$D(^BGPGPDCN(BGPX,0))

 . S V=^BGPGPDCN(BGPX,0)

 . N BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=7

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPGPDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G9 ;

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPX=0 F  S BGPX=$O(^BGPGPDCN(BGPX)) Q:'BGPX  D

 . Q:'$D(^BGPGPDCN(BGPX,0))

 . S V=^BGPGPDCN(BGPX,0)

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=9

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPGPDCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

G8 ;childhood weight

 S X=$O(^BGPCTRL("B",2009,0))

 S Y=^BGPCTRL(X,0)

 ;S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)

 ;S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)

 ;S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)

 ;S BGPPER=$P(Y,U,14),BGPQTR=3

 ;S BGPBEN=1

 I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"

 I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"

 I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"

 I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"

 I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"

 S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)

 S X=X_"0000"

 S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)

 S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)

 S BGPX=0 F  S BGPX=$O(^BGPEOCN(BGPX)) Q:'BGPX  I BGPX S V=^BGPEOCN(BGPX,0) D

 .Q:$P(V,U)'=BGPBD

 .Q:$P(V,U,2)'=BGPED

 .Q:$P(V,U,7)'=BGPPER

 .Q:$P(V,U,12)'=8

 .;Q:'$O(^BGPEOCN(BGPX,88888,0))

 .Q:$P(V,U,5)'=BGPBBD

 .Q:$P(V,U,6)'=BGPBED

 .Q:$P(V,U,14)'=BGPBEN

 . S BGPSU=$E($$SU($P(V,U,11)),1,10)

 . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPEOCN(BGPX,0),U,17):" (CHS ONLY)",1:"")

 . S BGPEBD=$$DATE^BGP9UTL($P(V,U))

 . S BGPEED=$$DATE^BGP9UTL($P(V,U,2))

 . S BGPEBBD=$$DATE^BGP9UTL($P(V,U,5))

 . S BGPEBED=$$DATE^BGP9UTL($P(V,U,6))

 . S BGPEDRR=$$DATE^BGP9UTL($P(V,U,13))

 . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR

 .Q

 Q

BGP9ASL   ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;

 +1       ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009

 +2       ;; ;

EP        ;EP - CALLED FROM OPTION

 +1        KILL BGPSUL

 +2        DO EN

 +3        QUIT 

EOJ       ;EP

 +1        KILL BGPTIND,BGPHIGH,BGPANS,BGPC,BGPGANS,BGPGC,BGPGI,BGPI,BGPX

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point

 +1        DO EN^VALM("BGP 09 AREA SELECT SITES")

 +2        DO CLEAR^VALM1

 +3        DO FULL^VALM1

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        DO EOJ

 +6        QUIT 

 +7       ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="Area Aggregate Site Selection"

 +2        SET VALMHDR(2)="* indicates the site has been selected"

 +3        SET VALMHDR(3)="+ after the facility name denotes a CHS Only Site"

 +4        SET X="#"

           SET $EXTRACT(X,6)="SU"

           SET $EXTRACT(X,17)="FACILITY"

           SET $EXTRACT(X,32)="BEG DATE"

           SET $EXTRACT(X,42)="END DATE"

           SET $EXTRACT(X,52)="BASE BEG"

           SET $EXTRACT(X,62)="BASE END"

           SET $EXTRACT(X,72)="DATE RUN"

 +5        SET VALMHDR(4)=X

 +6        QUIT 

 +7       ;

INIT      ; -- init variables and list array

 +1        IF BGPRTYPE=1

               DO NGR^BGP9ASL1

               QUIT 

 +2        IF BGPRTYPE=3

               DO HED^BGP9ASL1

               QUIT 

 +3        IF BGPRTYPE=5

               DO ELD^BGP9ASL1

               QUIT 

 +4        IF BGPRTYPE=6

               DO PED^BGP9ASL1

               QUIT 

 +5        IF BGPRTYPE=7

               DO ONM^BGP9ASL1

               QUIT 

 +6        IF BGPRTYPE=8

               DO EO^BGP9ASL1

               QUIT 

 +7        QUIT 

FAC(S)    ;

 +1        NEW N

           SET N=$ORDER(^AUTTLOC("C",S,0))

 +2        IF N=""

               QUIT N

 +3        QUIT $PIECE(^DIC(4,N,0),U)

SU(S)     ;

 +1        NEW N

           SET N=$ORDER(^AUTTSU("C",S,0))

 +2        IF N=""

               QUIT N

 +3        QUIT $PIECE(^AUTTSU(N,0),U)

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        QUIT 

 +2       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

BACK      ;go back to listman

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3        DO INIT

 +4        DO HDR

 +5        KILL DIR

 +6        KILL X,Y,Z,I

 +7        QUIT 

 +8       ;

ADD       ;EP

 +1        WRITE !

 +2        SET DIR(0)="LO^1:"_BGPHIGH

           SET DIR("A")="Which Facility"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No facilities selected."

               GOTO ADDX

 +5        IF $DATA(DIRUT)

               WRITE !,"No facilities selected."

               GOTO ADDX

 +6        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +7        SET BGPANS=Y

           SET BGPC=""

           FOR BGPI=1:1

               SET BGPC=$PIECE(BGPANS,",",BGPI)

               IF BGPC=""

                   QUIT 

               SET BGPSUL(BGPTIND(BGPC,BGPC))=""

ADDX      ;

 +1        DO BACK

 +2        QUIT 

 +3       ;

ADDALL    ;

 +1        FOR X=1:1:BGPHIGH

               SET BGPSUL(BGPTIND(X,X))=""

 +2        DO BACK

 +3        QUIT 

 +4       ;

REM       ;

 +1        WRITE !

           SET DIR(0)="LO^1:"_BGPHIGH

           SET DIR("A")="Which Facility(s)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF Y=""

               WRITE !,"No facilities selected."

               GOTO ADDX

 +3        IF $DATA(DIRUT)

               WRITE !,"No facilities selected."

               GOTO ADDX

 +4        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +5        SET BGPANS=Y

           SET BGPC=""

           FOR BGPI=1:1

               SET BGPC=$PIECE(BGPANS,",",BGPI)

               IF BGPC=""

                   QUIT 

               KILL BGPSUL(BGPTIND(BGPC,BGPC))

REMX      ;

 +1        DO BACK

 +2        QUIT 

GET(BGPSUL,BGPFILE,BGPRT,BGPPER,BGPQTR,BGPVDT,BGPBEN) ;EP - CALLED FROM GUI TO GET FILES FOR DISPLAY ON AREA REPORT

 +1       ;BGPSUL is array returned with iens from the file

 +2       ;BGPFILE is the file these iens belong to and is returned to you

 +3       ;input:

 +4       ;  BGPRT:  1 if national gpra

 +5       ;          9 if area performance

 +6       ;          3 if HEDIS

 +7       ;          5 if Elder report

 +8       ;          8 if new childhood weight

 +9       ;          7 if other national measures

 +10      ;          

 +11      ;  BGPPER - this is the year they select if they answered the above question

 +12      ;           with a 1 through 4  e.g  305000 (fileman imprecise date for 2006)

 +13      ;           if they chose 5 then this will be the end date the enter

 +14      ;           if this is the national gpra report (AGP) you can pass a blank here

 +15      ;   BGPQTR - this is equal to 1,2,3,4 or 5 depending on how the user answers the following

 +16      ;           DIR call:

 +17      ;               Select one of the following:

 +18      ;

 +19      ;         1         January 1 - December 31

 +20      ;         2         April 1 - March 31

 +21      ;         3         July 1 - June 30

 +22      ;         4         October 1 - September 30

 +23      ;         5         User defined date range

 +24      ;       Enter the date range for your report:

 +25      ;

 +26      ;  BGPVDT - baseline year entered by user in internal fileman format, year only

 +27      ;           e.g.  3010000

 +28      ;           if this is the national gpra report (AGP) you can pass a blank here

 +29      ;

 +30      ;  BGPBEN - 1 for Indians only, 2 for Not Indian, 3 for both (see reader call

 +31      ;           at subroutine BEN in BGP9DL 

 +32      ;           if this is the national gpra report (AGP) you can pass a blank here

 +33      ;

 +34      ;               

 +35       KILL BGPTIND

           SET BGPHIGH=""

 +36       SET BGPSUCNT=0

           SET BGPSU=""

           SET BGPSUC=0

 +37       IF BGPRT=1

               DO G1

 +38       IF BGPRT=3

               DO G3

 +39       IF BGPRT=5

               DO G5

 +40       IF BGPRT=9

               DO G9

 +41       IF BGPRT=8

               DO G8

 +42       IF BGPRT=7

               DO G7

 +43       IF BGPRT=6

               DO G6

 +44       QUIT 

G1        ;

 +1        SET X=$ORDER(^BGPCTRL("B",2009,0))

 +2        SET Y=^BGPCTRL(X,0)

 +3        SET BGPBD=$PIECE(Y,U,8)

           SET BGPED=$PIECE(Y,U,9)

 +4        SET BGPPBD=$PIECE(Y,U,10)

           SET BGPPED=$PIECE(Y,U,11)

 +5        SET BGPBBD=$PIECE(Y,U,12)

           SET BGPBED=$PIECE(Y,U,13)

 +6        SET BGPPER=$PIECE(Y,U,14)

           SET BGPQTR=3

 +7        IF $GET(BGPNGR09)

               Begin DoDot:1

 +8                SET BGPBD=3090701

                   SET BGPED=3100630

 +9                SET BGPPBD=3080701

                   SET BGPPED=3090630