BGP6ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;; ;
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 16 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 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^BGP6ASL1 Q
I BGPRTYPE=5 D ELD^BGP6ASL1 Q
I BGPRTYPE=6 D PED^BGP6ASL1 Q
I BGPRTYPE=7 D ONM^BGP6ASL1 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 BGP6DL
; 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=5 D G5
I BGPRT=9 D G9
I BGPRT=7 D G7
I BGPRT=6 D G6
Q
G1 ;
S X=$O(^BGPCTRL("B",2016,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=3150701,BGPED=3140630
. S BGPPBD=3130701,BGPPBD=3140630
. S BGPPER=3120000
G NT ;LORI UNCOMMENT AFTER TESTING
S BGPBD=3130101,BGPED=3131231
S BGPBBD=3100101,BGPBED=3101231
S BGPPBD=3120101,BGPPED=3121231
S BGPPER=3030000,BGPQTR=3,BGPBEN=1
NT ;
S BGPBEN=1
S BGPFILE=90556.03
S BGPX=0 F S BGPX=$O(^BGPGPDCM(BGPX)) Q:BGPX'=+BGPX D
. Q:'$D(^BGPGPDCM(BGPX,0))
. S V=^BGPGPDCM(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,21)'="16"
.;I $G(BGPCHWE) Q:'$O(^BGPGPDCM(BGPX,88888,0))
.Q:$P(V,U,12)'=1
.Q:$P(V,U,20) ;DESG PROV
.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 BGPEBD=$$DATE^BGP6UTL($P(V,U))
. S BGPEED=$$DATE^BGP6UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP6UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP6UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP6UTL($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=90557.03
S BGPX=0 F S BGPX=$O(^BGPELDCM(BGPX)) Q:'BGPX D
. Q:'$D(^BGPELDCM(BGPX,0))
. S V=^BGPELDCM(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 BGPEBD=$$DATE^BGP6UTL($P(V,U))
. S BGPEED=$$DATE^BGP6UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP6UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP6UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP6UTL($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=90556.12
S BGPX=0 F S BGPX=$O(^BGPPEDCM(BGPX)) Q:'BGPX D
. Q:'$D(^BGPPEDCM(BGPX,0))
. S V=^BGPPEDCM(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
.Q:$P(V,U,20) ;MEGAN
. S BGPSU=$E($$SU($P(V,U,10)),1,10)
. S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
. S BGPEBD=$$DATE^BGP6UTL($P(V,U))
. S BGPEED=$$DATE^BGP6UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP6UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP6UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP6UTL($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 D
.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=90556.03
I 'BGPQTR D
.S X=$O(^BGPCTRL("B",2016,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
S BGPX=0 F S BGPX=$O(^BGPGPDCM(BGPX)) Q:BGPX'=+BGPX D
. Q:'$D(^BGPGPDCM(BGPX,0))
. S V=^BGPGPDCM(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,21)'="16"
.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 BGPEBD=$$DATE^BGP6UTL($P(V,U))
. S BGPEED=$$DATE^BGP6UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP6UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP6UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP6UTL($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(^BGPGPDCM(BGPX)) Q:'BGPX D
. Q:'$D(^BGPGPDCM(BGPX,0))
. S V=^BGPGPDCM(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 BGPEBD=$$DATE^BGP6UTL($P(V,U))
. S BGPEED=$$DATE^BGP6UTL($P(V,U,2))
. S BGPEBBD=$$DATE^BGP6UTL($P(V,U,5))
. S BGPEBED=$$DATE^BGP6UTL($P(V,U,6))
. S BGPEDRR=$$DATE^BGP6UTL($P(V,U,13))
. S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
.Q
Q
BGP6ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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 16 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 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"
+4 SET VALMHDR(4)=X
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 IF BGPRTYPE=1
DO NGR^BGP6ASL1
QUIT
+2 IF BGPRTYPE=5
DO ELD^BGP6ASL1
QUIT
+3 IF BGPRTYPE=6
DO PED^BGP6ASL1
QUIT
+4 IF BGPRTYPE=7
DO ONM^BGP6ASL1
QUIT
+5 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 BGP6DL
+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=5
DO G5
+39 IF BGPRT=9
DO G9
+40 IF BGPRT=7
DO G7
+41 IF BGPRT=6
DO G6
+42 QUIT
G1 ;
+1 SET X=$ORDER(^BGPCTRL("B",2016,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=3150701
SET BGPED=3140630
+9 SET BGPPBD=3130701
SET BGPPBD=3140630
+10 SET BGPPER=3120000
End DoDot:1
+11 ;LORI UNCOMMENT AFTER TESTING
GOTO NT
+12 SET BGPBD=3130101
SET BGPED=3131231
+13 SET BGPBBD=3100101
SET BGPBED=3101231
+14 SET BGPPBD=3120101
SET BGPPED=3121231
+15 SET BGPPER=3030000
SET BGPQTR=3
SET BGPBEN=1
NT ;
+1 SET BGPBEN=1
+2 SET BGPFILE=90556.03
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCM(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCM(BGPX,0))
QUIT
+5 SET V=^BGPGPDCM(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,21)'="16"
QUIT
+11 ;I $G(BGPCHWE) Q:'$O(^BGPGPDCM(BGPX,88888,0))
+12 IF $PIECE(V,U,12)'=1
QUIT
+13 ;DESG PROV
IF $PIECE(V,U,20)
QUIT
+14 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+15 IF $PIECE(V,U,6)'=BGPBED
QUIT
+16 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+17 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+18 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)
+19 SET BGPEBD=$$DATE^BGP6UTL($PIECE(V,U))
+20 SET BGPEED=$$DATE^BGP6UTL($PIECE(V,U,2))
+21 SET BGPEBBD=$$DATE^BGP6UTL($PIECE(V,U,5))
+22 SET BGPEBED=$$DATE^BGP6UTL($PIECE(V,U,6))
+23 SET BGPEDRR=$$DATE^BGP6UTL($PIECE(V,U,13))
+24 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+25 QUIT
End DoDot:1
+26 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=90557.03
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELDCM(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPELDCM(BGPX,0))
QUIT
+13 SET V=^BGPELDCM(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)
+23 SET BGPEBD=$$DATE^BGP6UTL($PIECE(V,U))
+24 SET BGPEED=$$DATE^BGP6UTL($PIECE(V,U,2))
+25 SET BGPEBBD=$$DATE^BGP6UTL($PIECE(V,U,5))
+26 SET BGPEBED=$$DATE^BGP6UTL($PIECE(V,U,6))
+27 SET BGPEDRR=$$DATE^BGP6UTL($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=90556.12
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEDCM(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPPEDCM(BGPX,0))
QUIT
+13 SET V=^BGPPEDCM(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 ;MEGAN
IF $PIECE(V,U,20)
QUIT
+21 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,10)),1,10)
+22 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)
+23 SET BGPEBD=$$DATE^BGP6UTL($PIECE(V,U))
+24 SET BGPEED=$$DATE^BGP6UTL($PIECE(V,U,2))
+25 SET BGPEBBD=$$DATE^BGP6UTL($PIECE(V,U,5))
+26 SET BGPEBED=$$DATE^BGP6UTL($PIECE(V,U,6))
+27 SET BGPEDRR=$$DATE^BGP6UTL($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
G7 ;
+1 IF BGPQTR
Begin DoDot:1
+2 IF BGPQTR=1
SET BGPBD=$EXTRACT(BGPPER,1,3)_"0101"
SET BGPED=$EXTRACT(BGPPER,1,3)_"1231"
+3 IF BGPQTR=2
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0401"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0331"
+4 IF BGPQTR=3
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"0701"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0630"
+5 IF BGPQTR=4
SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_"1001"
SET BGPED=$EXTRACT(BGPPER,1,3)_"0930"
+6 IF BGPQTR=5
SET BGPBD=$$FMADD^XLFDT(BGPPER,-364)
SET BGPED=BGPPER
SET BGPPER=$EXTRACT(BGPED,1,3)_"0000"
+7 SET X=$EXTRACT(BGPPER,1,3)-$EXTRACT(BGPVDT,1,3)
+8 SET X=X_"0000"
+9 SET BGPBBD=BGPBD-X
SET BGPBBD=$EXTRACT(BGPBBD,1,3)_$EXTRACT(BGPBD,4,7)
+10 SET BGPBED=BGPED-X
SET BGPBED=$EXTRACT(BGPBED,1,3)_$EXTRACT(BGPED,4,7)
End DoDot:1
+11 SET BGPFILE=90556.03
+12 IF 'BGPQTR
Begin DoDot:1
+13 SET X=$ORDER(^BGPCTRL("B",2016,0))
+14 SET Y=^BGPCTRL(X,0)
+15 SET BGPBD=$PIECE(Y,U,8)
SET BGPED=$PIECE(Y,U,9)
+16 SET BGPPBD=$PIECE(Y,U,10)
SET BGPPED=$PIECE(Y,U,11)
+17 SET BGPBBD=$PIECE(Y,U,12)
SET BGPBED=$PIECE(Y,U,13)
+18 SET BGPPER=$PIECE(Y,U,14)
SET BGPQTR=3
+19 SET BGPBEN=1
End DoDot:1
+20 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCM(BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+21 IF '$DATA(^BGPGPDCM(BGPX,0))
QUIT
+22 SET V=^BGPGPDCM(BGPX,0)
+23 NEW BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR
+24 IF $PIECE(V,U)'=BGPBD
QUIT
+25 IF $PIECE(V,U,2)'=BGPED
QUIT
+26 IF $PIECE(V,U,7)'=BGPPER
QUIT
+27 IF $PIECE(V,U,21)'="16"
QUIT
+28 IF $PIECE(V,U,12)'=7
QUIT
+29 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+30 IF $PIECE(V,U,6)'=BGPBED
QUIT
+31 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+32 SET BGPSU=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+33 SET BGPFAC=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)
+34 SET BGPEBD=$$DATE^BGP6UTL($PIECE(V,U))
+35 SET BGPEED=$$DATE^BGP6UTL($PIECE(V,U,2))
+36 SET BGPEBBD=$$DATE^BGP6UTL($PIECE(V,U,5))
+37 SET BGPEBED=$$DATE^BGP6UTL($PIECE(V,U,6))
+38 SET BGPEDRR=$$DATE^BGP6UTL($PIECE(V,U,13))
+39 SET BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
+40 QUIT
End DoDot:1
+41 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(^BGPGPDCM(BGPX))
IF 'BGPX
QUIT
Begin DoDot:1
+11 IF '$DATA(^BGPGPDCM(BGPX,0))
QUIT
+12 SET V=^BGPGPDCM(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)
+22 SET BGPEBD=$$DATE^BGP6UTL($PIECE(V,U))
+23 SET BGPEED=$$DATE^BGP6UTL($PIECE(V,U,2))
+24 SET BGPEBBD=$$DATE^BGP6UTL($PIECE(V,U,5))
+25 SET BGPEBED=$$DATE^BGP6UTL($PIECE(V,U,6))
+26 SET BGPEDRR=$$DATE^BGP6UTL($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
