Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8ASL

BGP8ASL.m

Go to the documentation of this file.
  1. 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
  1. ;; ;
  1. EP ;EP - CALLED FROM OPTION
  1. K BGPSUL
  1. D EN
  1. Q
  1. EOJ ;EP
  1. K BGPTIND,BGPHIGH,BGPANS,BGPC,BGPGANS,BGPGC,BGPGI,BGPI,BGPX
  1. Q
  1. ;; ;
  1. EN ;EP -- main entry point
  1. D EN^VALM("BGP 18 AREA SELECT SITES")
  1. D CLEAR^VALM1
  1. D FULL^VALM1
  1. W:$D(IOF) @IOF
  1. D EOJ
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)="Area Aggregate Site Selection"
  1. S VALMHDR(2)="* indicates the site has been selected"
  1. 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"
  1. S VALMHDR(4)=X
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. I BGPRTYPE=1 D NGR^BGP8ASL1 Q
  1. I BGPRTYPE=5 D ELD^BGP8ASL1 Q
  1. I BGPRTYPE=6 D PED^BGP8ASL1 Q
  1. I BGPRTYPE=7 D ONM^BGP8ASL1 Q
  1. Q
  1. FAC(S) ;
  1. NEW N S N=$O(^AUTTLOC("C",S,0))
  1. I N="" Q N
  1. Q $P(^DIC(4,N,0),U)
  1. SU(S) ;
  1. NEW N S N=$O(^AUTTSU("C",S,0))
  1. I N="" Q N
  1. Q $P(^AUTTSU(N,0),U)
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. BACK ;go back to listman
  1. D TERM^VALM0
  1. S VALMBCK="R"
  1. D INIT
  1. D HDR
  1. K DIR
  1. K X,Y,Z,I
  1. Q
  1. ;
  1. ADD ;EP
  1. W !
  1. S DIR(0)="LO^1:"_BGPHIGH,DIR("A")="Which Facility"
  1. D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1. I Y="" W !,"No facilities selected." G ADDX
  1. I $D(DIRUT) W !,"No facilities selected." G ADDX
  1. D FULL^VALM1 W:$D(IOF) @IOF
  1. S BGPANS=Y,BGPC="" F BGPI=1:1 S BGPC=$P(BGPANS,",",BGPI) Q:BGPC="" S BGPSUL(BGPTIND(BGPC,BGPC))=""
  1. ADDX ;
  1. D BACK
  1. Q
  1. ;
  1. ADDALL ;
  1. F X=1:1:BGPHIGH S BGPSUL(BGPTIND(X,X))=""
  1. D BACK
  1. Q
  1. ;
  1. REM ;
  1. W ! S DIR(0)="LO^1:"_BGPHIGH,DIR("A")="Which Facility(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1. I Y="" W !,"No facilities selected." G ADDX
  1. I $D(DIRUT) W !,"No facilities selected." G ADDX
  1. D FULL^VALM1 W:$D(IOF) @IOF
  1. S BGPANS=Y,BGPC="" F BGPI=1:1 S BGPC=$P(BGPANS,",",BGPI) Q:BGPC="" K BGPSUL(BGPTIND(BGPC,BGPC))
  1. REMX ;
  1. D BACK
  1. Q
  1. 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
  1. ;BGPFILE is the file these iens belong to and is returned to you
  1. ;input:
  1. ; BGPRT: 1 if national gpra
  1. ; 9 if area performance
  1. ; 3 if HEDIS
  1. ; 5 if Elder report
  1. ; 8 if new childhood weight
  1. ; 7 if other national measures
  1. ;
  1. ; BGPPER - this is the year they select if they answered the above question
  1. ; with a 1 through 4 e.g 305000 (fileman imprecise date for 2006)
  1. ; if they chose 5 then this will be the end date the enter
  1. ; if this is the national gpra report (AGP) you can pass a blank here
  1. ; BGPQTR - this is equal to 1,2,3,4 or 5 depending on how the user answers the following
  1. ; DIR call:
  1. ; Select one of the following:
  1. ;
  1. ; 1 January 1 - December 31
  1. ; 2 April 1 - March 31
  1. ; 3 July 1 - June 30
  1. ; 4 October 1 - September 30
  1. ; 5 User defined date range
  1. ; Enter the date range for your report:
  1. ;
  1. ; BGPVDT - baseline year entered by user in internal fileman format, year only
  1. ; e.g. 3010000
  1. ; if this is the national gpra report (AGP) you can pass a blank here
  1. ;
  1. ; BGPBEN - 1 for Indians only, 2 for Not Indian, 3 for both (see reader call
  1. ; at subroutine BEN in BGP8DL
  1. ; if this is the national gpra report (AGP) you can pass a blank here
  1. ;
  1. ;
  1. K BGPTIND S BGPHIGH=""
  1. S BGPSUCNT=0,BGPSU="",BGPSUC=0
  1. I BGPRT=1 D G1
  1. I BGPRT=5 D G5
  1. I BGPRT=9 D G9
  1. I BGPRT=7 D G7
  1. I BGPRT=6 D G6
  1. Q
  1. G1 ;
  1. S X=$O(^BGPCTRL("B",2018,0))
  1. S Y=^BGPCTRL(X,0)
  1. S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)
  1. S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
  1. S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
  1. S BGPPER=$P(Y,U,14),BGPQTR=4
  1. I $G(BGPNGR09) D
  1. . S BGPBD=3160701,BGPED=3140630
  1. . S BGPPBD=3130701,BGPPBD=3140630
  1. . S BGPPER=3120000
  1. G NT ;LORI UNCOMMENT AFTER TESTING
  1. S BGPBD=3151001,BGPED=3160930
  1. S BGPBBD=3100101,BGPBED=3101231
  1. S BGPPBD=3120101,BGPPED=3121231
  1. S BGPPER=3030000,BGPQTR=3,BGPBEN=1
  1. NT ;
  1. S BGPBEN=1
  1. S BGPFILE=90560.03
  1. S BGPX=0 F S BGPX=$O(^BGPGPDCR(BGPX)) Q:BGPX'=+BGPX D
  1. . Q:'$D(^BGPGPDCR(BGPX,0))
  1. . S V=^BGPGPDCR(BGPX,0)
  1. . N BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR
  1. .Q:$P(V,U)'=BGPBD
  1. .Q:$P(V,U,2)'=BGPED
  1. .Q:$P(V,U,7)'=BGPPER
  1. .Q:$P(V,U,21)'=$$VER^BGP8BAN()
  1. .;I $G(BGPCHWE) Q:'$O(^BGPGPDCR(BGPX,88888,0))
  1. .Q:$P(V,U,12)'=1
  1. .Q:$P(V,U,20) ;DESG PROV
  1. .Q:$P(V,U,5)'=BGPBBD
  1. .Q:$P(V,U,6)'=BGPBED
  1. .Q:$P(V,U,14)'=BGPBEN
  1. . S BGPSU=$E($$SU($P(V,U,11)),1,10)
  1. . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
  1. . S BGPEBD=$$DATE^BGP8UTL($P(V,U))
  1. . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
  1. . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
  1. . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
  1. . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
  1. . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
  1. .Q
  1. Q
  1. G5 ;
  1. I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
  1. I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"
  1. I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"
  1. I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"
  1. 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"
  1. S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1. S X=X_"0000"
  1. S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1. S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1. S BGPFILE=90561.03
  1. S BGPX=0 F S BGPX=$O(^BGPEDLCR(BGPX)) Q:'BGPX D
  1. . Q:'$D(^BGPEDLCR(BGPX,0))
  1. . S V=^BGPEDLCR(BGPX,0)
  1. .Q:$P(V,U)'=BGPBD
  1. .Q:$P(V,U,2)'=BGPED
  1. .Q:$P(V,U,7)'=BGPPER
  1. .Q:$P(V,U,12)'=5
  1. .Q:$P(V,U,5)'=BGPBBD
  1. .Q:$P(V,U,6)'=BGPBED
  1. .Q:$P(V,U,14)'=BGPBEN
  1. . S BGPSU=$E($$SU($P(V,U,11)),1,10)
  1. . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
  1. . S BGPEBD=$$DATE^BGP8UTL($P(V,U))
  1. . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
  1. . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
  1. . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
  1. . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
  1. . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
  1. .Q
  1. Q
  1. G6 ;
  1. I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
  1. I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"
  1. I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"
  1. I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"
  1. I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
  1. S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1. S X=X_"0000"
  1. S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1. S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1. S BGPFILE=90560.12
  1. S BGPX=0 F S BGPX=$O(^BGPPEDCR(BGPX)) Q:'BGPX D
  1. . Q:'$D(^BGPPEDCR(BGPX,0))
  1. . S V=^BGPPEDCR(BGPX,0)
  1. .Q:$P(V,U)'=BGPBD
  1. .Q:$P(V,U,2)'=BGPED
  1. .Q:$P(V,U,7)'=BGPPER
  1. .Q:$P(V,U,5)'=BGPBBD
  1. .Q:$P(V,U,6)'=BGPBED
  1. .Q:$P(V,U,11)'=BGPBEN
  1. .Q:$P(V,U,20) ;MEGAN
  1. . S BGPSU=$E($$SU($P(V,U,10)),1,10)
  1. . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
  1. . S BGPEBD=$$DATE^BGP8UTL($P(V,U))
  1. . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
  1. . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
  1. . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
  1. . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
  1. . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
  1. .Q
  1. Q
  1. G7 ;
  1. I BGPQTR D
  1. .I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
  1. .I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"
  1. .I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"
  1. .I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"
  1. .I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
  1. .S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1. .S X=X_"0000"
  1. .S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1. .S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1. S BGPFILE=90560.03
  1. I 'BGPQTR D
  1. .S X=$O(^BGPCTRL("B",2018,0))
  1. .S Y=^BGPCTRL(X,0)
  1. .S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)
  1. .S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
  1. .S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
  1. .S BGPPER=$P(Y,U,14),BGPQTR=4
  1. .S BGPBEN=1
  1. S BGPX=0 F S BGPX=$O(^BGPGPDCR(BGPX)) Q:BGPX'=+BGPX D
  1. . Q:'$D(^BGPGPDCR(BGPX,0))
  1. . S V=^BGPGPDCR(BGPX,0)
  1. . N BGPSU,BGPFAC,BGPEBD,BGPEED,BGPEBBD,BGPEBED,BGPEDRR
  1. .Q:$P(V,U)'=BGPBD
  1. .Q:$P(V,U,2)'=BGPED
  1. .Q:$P(V,U,7)'=BGPPER
  1. .Q:$P(V,U,21)'=$$VER^BGP8BAN()
  1. .Q:$P(V,U,12)'=7
  1. .Q:$P(V,U,5)'=BGPBBD
  1. .Q:$P(V,U,6)'=BGPBED
  1. .Q:$P(V,U,14)'=BGPBEN
  1. . S BGPSU=$E($$SU($P(V,U,11)),1,10)
  1. . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
  1. . S BGPEBD=$$DATE^BGP8UTL($P(V,U))
  1. . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
  1. . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
  1. . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
  1. . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
  1. . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
  1. .Q
  1. Q
  1. G9 ;
  1. I BGPQTR=1 S BGPBD=$E(BGPPER,1,3)_"0101",BGPED=$E(BGPPER,1,3)_"1231"
  1. I BGPQTR=2 S BGPBD=($E(BGPPER,1,3)-1)_"0401",BGPED=$E(BGPPER,1,3)_"0331"
  1. I BGPQTR=3 S BGPBD=($E(BGPPER,1,3)-1)_"0701",BGPED=$E(BGPPER,1,3)_"0630"
  1. I BGPQTR=4 S BGPBD=($E(BGPPER,1,3)-1)_"1001",BGPED=$E(BGPPER,1,3)_"0930"
  1. I BGPQTR=5 S BGPBD=$$FMADD^XLFDT(BGPPER,-364),BGPED=BGPPER,BGPPER=$E(BGPED,1,3)_"0000"
  1. S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1. S X=X_"0000"
  1. S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1. S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1. S BGPX=0 F S BGPX=$O(^BGPGPDCR(BGPX)) Q:'BGPX D
  1. . Q:'$D(^BGPGPDCR(BGPX,0))
  1. . S V=^BGPGPDCR(BGPX,0)
  1. .Q:$P(V,U)'=BGPBD
  1. .Q:$P(V,U,2)'=BGPED
  1. .Q:$P(V,U,7)'=BGPPER
  1. .Q:$P(V,U,12)'=9
  1. .Q:$P(V,U,5)'=BGPBBD
  1. .Q:$P(V,U,6)'=BGPBED
  1. .Q:$P(V,U,14)'=BGPBEN
  1. . S BGPSU=$E($$SU($P(V,U,11)),1,10)
  1. . S BGPFAC=$E($$FAC($P(V,U,9)),1,13)
  1. . S BGPEBD=$$DATE^BGP8UTL($P(V,U))
  1. . S BGPEED=$$DATE^BGP8UTL($P(V,U,2))
  1. . S BGPEBBD=$$DATE^BGP8UTL($P(V,U,5))
  1. . S BGPEBED=$$DATE^BGP8UTL($P(V,U,6))
  1. . S BGPEDRR=$$DATE^BGP8UTL($P(V,U,13))
  1. . S BGPSUL(BGPX)=BGPSU_U_BGPFAC_U_BGPEBD_U_BGPEED_U_BGPEBBD_U_BGPEBED_U_BGPEDRR
  1. .Q
  1. Q