BGP0ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
;; ;
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 10 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^BGP0ASL1 Q
I BGPRTYPE=3 D HED^BGP0ASL1 Q
I BGPRTYPE=5 D ELD^BGP0ASL1 Q
I BGPRTYPE=6 D PED^BGP0ASL1 Q
I BGPRTYPE=7 D ONM^BGP0ASL1 Q
I BGPRTYPE=8 D EO^BGP0ASL1 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 BGP0DL
; 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",2010,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=3100701,BGPED=3110630
. S BGPPBD=3090701,BGPPED=3100630
. S BGPPER=3110000
G NT ;LORI UNCOMMENT AFTER TESTING
S BGPBD=3030101,BGPED=3031231
S BGPBBD=3000101,BGPBED=3001231
S BGPPBD=3020111,BGPPED=3021231
S BGPPER=3030000,BGPQTR=3,BGPBEN=1
NT ;
S BGPBEN=1
S BGPFILE=90377.03
S BGPX=0 F S BGPX=$O(^BGPGPDCT(BGPX)) Q:BGPX'=+BGPX D
. Q:'$D(^BGPGPDCT(BGPX,0))
. S V=^BGPGPDCT(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(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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=90378.03
S BGPX=0 F S BGPX=$O(^BGPHEDCT(BGPX)) Q:'BGPX D
. Q:'$D(^BGPHEDCT(BGPX,0))
. S V=^BGPHEDCT(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(^BGPHEDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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=90379.03
S BGPX=0 F S BGPX=$O(^BGPELDCT(BGPX)) Q:'BGPX D
. Q:'$D(^BGPELDCT(BGPX,0))
. S V=^BGPELDCT(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(^BGPELDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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=90379.03
S BGPX=0 F S BGPX=$O(^BGPPEDCT(BGPX)) Q:'BGPX D
. Q:'$D(^BGPPEDCT(BGPX,0))
. S V=^BGPPEDCT(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(^BGPELDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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=90377.03
S BGPX=0 F S BGPX=$O(^BGPGPDCT(BGPX)) Q:BGPX'=+BGPX D
. Q:'$D(^BGPGPDCT(BGPX,0))
. S V=^BGPGPDCT(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(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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(^BGPGPDCT(BGPX)) Q:'BGPX D
. Q:'$D(^BGPGPDCT(BGPX,0))
. S V=^BGPGPDCT(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(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($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",2010,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(^BGPEOCT(BGPX)) Q:'BGPX I BGPX S V=^BGPEOCT(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(^BGPEOCT(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(^BGPEOCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
. S BGPEBD=$$DATE^BGP0UTL($P(V,U))
. S BGPEED=$$DATE^BGP0UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP0UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP0UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP0UTL($P(V,U,13))
. S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
.Q
Q
BGP0ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
+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 10 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^BGP0ASL1
QUIT
+2 IF BGPRTYPE=3
DO HED^BGP0ASL1
QUIT
+3 IF BGPRTYPE=5
DO ELD^BGP0ASL1
QUIT
+4 IF BGPRTYPE=6
DO PED^BGP0ASL1
QUIT
+5 IF BGPRTYPE=7
DO ONM^BGP0ASL1
QUIT
+6 IF BGPRTYPE=8
DO EO^BGP0ASL1
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 BGP0DL
+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",2010,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=3100701
SET BGPED=3110630
+9 SET BGPPBD=3090701
SET BGPPED=3100630
+10 SET BGPPER=3110000
End DoDot:1
+11 ;LORI UNCOMMENT AFTER TESTING
GOTO NT
+12 SET BGPBD=3030101
SET BGPED=3031231
+13 SET BGPBBD=3000101
SET BGPBED=3001231
+14 SET BGPPBD=3020111
SET BGPPED=3021231
+15 SET BGPPER=3030000
SET BGPQTR=3
SET BGPBEN=1
NT ;
+1 SET BGPBEN=1
+2 SET BGPFILE=90377.03
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCT(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCT(BGPX,0))
QUIT
+5 SET V=^BGPGPDCT(BGPX,0)
+6 NEW BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR
+7 IF $PIECE(V,U)'=BGPBD
QUIT
+8 IF $PIECE(V,U,2)'=BGPED
QUIT
+9 IF $PIECE(V,U,7)'=BGPPER
QUIT
+10 IF $PIECE(V,U,12)'=1
QUIT
+11 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+12 IF $PIECE(V,U,6)'=BGPBED
QUIT
+13 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+14 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+15 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+16 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+17 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+18 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+19 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+20 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+21 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+22 QUIT
End DoDot:1
+23 QUIT
G3 ;
+1 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+2 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+3 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+4 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+5 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+6 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+7 SET X=X_"0000"
+8 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+9 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+10 SET BGPFILE=90378.03
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPHEDCT(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPHEDCT(BGPX,0))
QUIT
+13 SET V=^BGPHEDCT(BGPX,0)
+14 IF $PIECE(V,U)'=BGPBD
QUIT
+15 IF $PIECE(V,U,2)'=BGPED
QUIT
+16 IF $PIECE(V,U,7)'=BGPPER
QUIT
+17 IF $PIECE(V,U,12)'=3
QUIT
+18 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+19 IF $PIECE(V,U,6)'=BGPBED
QUIT
+20 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+21 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+22 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPHEDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+23 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+24 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+25 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+26 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+27 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+28 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+29 QUIT
End DoDot:1
+30 QUIT
G5 ;
+1 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+2 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+3 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+4 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+5 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+6 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+7 SET X=X_"0000"
+8 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+9 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+10 SET BGPFILE=90379.03
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELDCT(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPELDCT(BGPX,0))
QUIT
+13 SET V=^BGPELDCT(BGPX,0)
+14 IF $PIECE(V,U)'=BGPBD
QUIT
+15 IF $PIECE(V,U,2)'=BGPED
QUIT
+16 IF $PIECE(V,U,7)'=BGPPER
QUIT
+17 IF $PIECE(V,U,12)'=5
QUIT
+18 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+19 IF $PIECE(V,U,6)'=BGPBED
QUIT
+20 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+21 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+22 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPELDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+23 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+24 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+25 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+26 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+27 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+28 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+29 QUIT
End DoDot:1
+30 QUIT
G6 ;
+1 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+2 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+3 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+4 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+5 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+6 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+7 SET X=X_"0000"
+8 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+9 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+10 SET BGPFILE=90379.03
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEDCT(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPPEDCT(BGPX,0))
QUIT
+13 SET V=^BGPPEDCT(BGPX,0)
+14 IF $PIECE(V,U)'=BGPBD
QUIT
+15 IF $PIECE(V,U,2)'=BGPED
QUIT
+16 IF $PIECE(V,U,7)'=BGPPER
QUIT
+17 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+18 IF $PIECE(V,U,6)'=BGPBED
QUIT
+19 IF $PIECE(V,U,11)'=BGPBEN
QUIT
+20 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,10)),1,10)
+21 ;_$S($P(^BGPELDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)
+22 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+23 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+24 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+25 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+26 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+27 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+28 QUIT
End DoDot:1
+29 QUIT
G7 ;
+1 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+2 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+3 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+4 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+5 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+6 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+7 SET X=X_"0000"
+8 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+9 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+10 SET BGPFILE=90377.03
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCT(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPGPDCT(BGPX,0))
QUIT
+13 SET V=^BGPGPDCT(BGPX,0)
+14 NEW BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR
+15 IF $PIECE(V,U)'=BGPBD
QUIT
+16 IF $PIECE(V,U,2)'=BGPED
QUIT
+17 IF $PIECE(V,U,7)'=BGPPER
QUIT
+18 IF $PIECE(V,U,12)'=7
QUIT
+19 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+20 IF $PIECE(V,U,6)'=BGPBED
QUIT
+21 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+22 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+23 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+24 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+25 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+26 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+27 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+28 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+29 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+30 QUIT
End DoDot:1
+31 QUIT
G9 ;
+1 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+2 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+3 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+4 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+5 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+6 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+7 SET X=X_"0000"
+8 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+9 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+10 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCT(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+11 IF '$DATA(^BGPGPDCT(BGPX,0))
QUIT
+12 SET V=^BGPGPDCT(BGPX,0)
+13 IF $PIECE(V,U)'=BGPBD
QUIT
+14 IF $PIECE(V,U,2)'=BGPED
QUIT
+15 IF $PIECE(V,U,7)'=BGPPER
QUIT
+16 IF $PIECE(V,U,12)'=9
QUIT
+17 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+18 IF $PIECE(V,U,6)'=BGPBED
QUIT
+19 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+20 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+21 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+22 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+23 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+24 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+25 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+26 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+27 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+28 QUIT
End DoDot:1
+29 QUIT
G8 ;childhood weight
+1 SET X=$ORDER(^BGPCTRL("B",2010,0))
+2 SET Y=^BGPCTRL(X,0)
+3 ;S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)
+4 ;S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
+5 ;S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
+6 ;S BGPPER=$P(Y,U,14),BGPQTR=3
+7 ;S BGPBEN=1
+8 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+9 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+10 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+11 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+12 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+13 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+14 SET X=X_"0000"
+15 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+16 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
+17 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOCT(BGPX))
IF 'BGPX
QUIT
IF BGPX
SET V=^BGPEOCT(BGPX,0)
Begin DoDot:1
+18 IF $PIECE(V,U)'=BGPBD
QUIT
+19 IF $PIECE(V,U,2)'=BGPED
QUIT
+20 IF $PIECE(V,U,7)'=BGPPER
QUIT
+21 IF $PIECE(V,U,12)'=8
QUIT
+22 ;Q:'$O(^BGPEOCT(BGPX,88888,0))
+23 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+24 IF $PIECE(V,U,6)'=BGPBED
QUIT
+25 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+26 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+27 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPEOCT(BGPX,0),U,17):" (CHS ONLY)",1:"")
+28 SET BGPEBD=$$DATE^BGP0UTL($PIECE(V,U))
+29 SET BGPEED=$$DATE^BGP0UTL($PIECE(V,U,2))
+30 SET BGPEBBD=$$DATE^BGP0UTL($PIECE(V,U,5))
+31 SET BGPEBED=$$DATE^BGP0UTL($PIECE(V,U,6))
+32 SET BGPEDRR=$$DATE^BGP0UTL($PIECE(V,U,13))
+33 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+34 QUIT
End DoDot:1
+35 QUIT
