- BGP8ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
- ;; ;
- 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 18 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^BGP8ASL1 Q
- I BGPRTYPE=5 D ELD^BGP8ASL1 Q
- I BGPRTYPE=6 D PED^BGP8ASL1 Q
- I BGPRTYPE=7 D ONM^BGP8ASL1 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 BGP8DL
- ; 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",2018,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=4
- I $G(BGPNGR09) D
- . S BGPBD=3160701,BGPED=3140630
- . S BGPPBD=3130701,BGPPBD=3140630
- . S BGPPER=3120000
- G NT ;LORI UNCOMMENT AFTER TESTING
- S BGPBD=3151001,BGPED=3160930
- S BGPBBD=3100101,BGPBED=3101231
- S BGPPBD=3120101,BGPPED=3121231
- S BGPPER=3030000,BGPQTR=3,BGPBEN=1
- NT ;
- S BGPBEN=1
- S BGPFILE=90560.03
- S BGPX=0 F S BGPX=$O(^BGPGPDCR(BGPX)) Q:BGPX'=+BGPX D
- . Q:'$D(^BGPGPDCR(BGPX,0))
- . S V=^BGPGPDCR(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)'=$$VER^BGP8BAN()
- .;I $G(BGPCHWE) Q:'$O(^BGPGPDCR(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^BGP8UTL($P(V,U))
- . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
- . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
- . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
- . S BGPEDRR=$$DATE^BGP8UTL($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 D=$$FMADD^XLFDT(BGPPER,1) S BGPBD=($E(BGPPER,1,3)-1)_$E(D,4,7),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=90561.03
- S BGPX=0 F S BGPX=$O(^BGPEDLCR(BGPX)) Q:'BGPX D
- . Q:'$D(^BGPEDLCR(BGPX,0))
- . S V=^BGPEDLCR(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^BGP8UTL($P(V,U))
- . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
- . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
- . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
- . S BGPEDRR=$$DATE^BGP8UTL($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=90560.12
- S BGPX=0 F S BGPX=$O(^BGPPEDCR(BGPX)) Q:'BGPX D
- . Q:'$D(^BGPPEDCR(BGPX,0))
- . S V=^BGPPEDCR(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^BGP8UTL($P(V,U))
- . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
- . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
- . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
- . S BGPEDRR=$$DATE^BGP8UTL($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=90560.03
- I 'BGPQTR D
- .S X=$O(^BGPCTRL("B",2018,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=4
- .S BGPBEN=1
- S BGPX=0 F S BGPX=$O(^BGPGPDCR(BGPX)) Q:BGPX'=+BGPX D
- . Q:'$D(^BGPGPDCR(BGPX,0))
- . S V=^BGPGPDCR(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)'=$$VER^BGP8BAN()
- .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^BGP8UTL($P(V,U))
- . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
- . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
- . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
- . S BGPEDRR=$$DATE^BGP8UTL($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(^BGPGPDCR(BGPX)) Q:'BGPX D
- . Q:'$D(^BGPGPDCR(BGPX,0))
- . S V=^BGPGPDCR(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^BGP8UTL($P(V,U))
- . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
- . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
- . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
- . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
- . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
- .Q
- Q
- BGP8ASL ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- +1 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
- +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 18 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^BGP8ASL1
- QUIT
- +2 IF BGPRTYPE=5
- DO ELD^BGP8ASL1
- QUIT
- +3 IF BGPRTYPE=6
- DO PED^BGP8ASL1
- QUIT
- +4 IF BGPRTYPE=7
- DO ONM^BGP8ASL1
- 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 BGP8DL
- +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",2018,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=4
- +7 IF $GET(BGPNGR09)
- Begin DoDot:1
- +8 SET BGPBD=3160701
- 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=3151001
- SET BGPED=3160930
- +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=90560.03
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPGPDCR(BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:1
- +4 IF '$DATA(^BGPGPDCR(BGPX,0))
- QUIT
- +5 SET V=^BGPGPDCR(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)'=$$VER^BGP8BAN()
- QUIT
- +11 ;I $G(BGPCHWE) Q:'$O(^BGPGPDCR(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^BGP8UTL($PIECE(V,U))
- +20 SET BGPEED=$$DATE^BGP8UTL($PIECE(V,U,2))
- +21 SET BGPEBBD=$$DATE^BGP8UTL($PIECE(V,U,5))
- +22 SET BGPEBED=$$DATE^BGP8UTL($PIECE(V,U,6))
- +23 SET BGPEDRR=$$DATE^BGP8UTL($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 D=$$FMADD^XLFDT(BGPPER,1)
- SET BGPBD=($EXTRACT(BGPPER,1,3)-1)_$EXTRACT(D,4,7)
- 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=90561.03
- +11 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPEDLCR(BGPX))
- IF 'BGPX
- QUIT
- Begin DoDot:1
- +12 IF '$DATA(^BGPEDLCR(BGPX,0))
- QUIT
- +13 SET V=^BGPEDLCR(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^BGP8UTL($PIECE(V,U))
- +24 SET BGPEED=$$DATE^BGP8UTL($PIECE(V,U,2))
- +25 SET BGPEBBD=$$DATE^BGP8UTL($PIECE(V,U,5))
- +26 SET BGPEBED=$$DATE^BGP8UTL($PIECE(V,U,6))
- +27 SET BGPEDRR=$$DATE^BGP8UTL($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=90560.12
- +11 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPPEDCR(BGPX))
- IF 'BGPX
- QUIT
- Begin DoDot:1
- +12 IF '$DATA(^BGPPEDCR(BGPX,0))
- QUIT
- +13 SET V=^BGPPEDCR(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^BGP8UTL($PIECE(V,U))
- +24 SET BGPEED=$$DATE^BGP8UTL($PIECE(V,U,2))
- +25 SET BGPEBBD=$$DATE^BGP8UTL($PIECE(V,U,5))
- +26 SET BGPEBED=$$DATE^BGP8UTL($PIECE(V,U,6))
- +27 SET BGPEDRR=$$DATE^BGP8UTL($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=90560.03
- +12 IF 'BGPQTR
- Begin DoDot:1
- +13 SET X=$ORDER(^BGPCTRL("B",2018,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=4
- +19 SET BGPBEN=1
- End DoDot:1
- +20 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPGPDCR(BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:1
- +21 IF '$DATA(^BGPGPDCR(BGPX,0))
- QUIT
- +22 SET V=^BGPGPDCR(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)'=$$VER^BGP8BAN()
- 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^BGP8UTL($PIECE(V,U))
- +35 SET BGPEED=$$DATE^BGP8UTL($PIECE(V,U,2))
- +36 SET BGPEBBD=$$DATE^BGP8UTL($PIECE(V,U,5))
- +37 SET BGPEBED=$$DATE^BGP8UTL($PIECE(V,U,6))
- +38 SET BGPEDRR=$$DATE^BGP8UTL($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(^BGPGPDCR(BGPX))
- IF 'BGPX
- QUIT
- Begin DoDot:1
- +11 IF '$DATA(^BGPGPDCR(BGPX,0))
- QUIT
- +12 SET V=^BGPGPDCR(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^BGP8UTL($PIECE(V,U))
- +23 SET BGPEED=$$DATE^BGP8UTL($PIECE(V,U,2))
- +24 SET BGPEBBD=$$DATE^BGP8UTL($PIECE(V,U,5))
- +25 SET BGPEBED=$$DATE^BGP8UTL($PIECE(V,U,6))
- +26 SET BGPEDRR=$$DATE^BGP8UTL($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