- BGP4DP6 ; IHS/CMI/LAB - print ind H ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;
- ;
- IC1 ;EP
- S BGPORXX=$P(^BGPINDJ(BGPIC,12),U,6)
- I $Y>(BGPIOSL-16),'$G(BGPSUMON) D HEADER^BGP4DPH Q:BGPQUIT W !,^BGPINDJ(BGPIC,53,1,0) W:$D(^BGPINDJ(BGPIC,53,2,0)) !,^BGPINDJ(BGPIC,53,2,0)
- D H1^BGP4DPH
- F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3" Q:BGPQUIT D PI^BGP4DP1C
- Q:BGPQUIT
- D:'$G(BGPSUMON) HEADER^BGP4DPH
- F BGPPC1=BGPORXX_".4",BGPORXX_".5",BGPORXX_".6" Q:BGPQUIT D PI^BGP4DP1C
- Q:BGPQUIT
- D:'$G(BGPSUMON) HEADER^BGP4DPH
- F BGPPC1=BGPORXX_".7",BGPORXX_".8",BGPORXX_".9" Q:BGPQUIT D PI^BGP4DP1C
- Q:BGPQUIT
- D I1AGE
- Q
- I1AGE ;EP special age tallies
- Q:BGPINDJ="D"
- Q:BGPRTYPE'=4
- I BGPINDJ="W",BGPRTYPE=4 G FEM
- S BGPHD1="TOTAL OBESE ACTIVE CLINICAL POPULATION",BGPHD2="# Obese Active Clinical"
- I '$G(BGPSUMON) D HEADER^BGP4DPH Q:BGPQUIT W !,^BGPINDJ(BGPIC,53,1,0) W:$D(^BGPINDJ(BGPIC,53,2,0)) !,^BGPINDJ(BGPIC,53,2,0) D H3
- K BGPDAC,BGPDAP,BGPDAB S (C,D)=0 F BGPX="ED","EG","EJ","EM","EP" D I1AGE1,I1AGE2
- D I1AGEP
- Q:BGPQUIT
- S BGPHD1="MALE OBESE ACTIVE CLINICAL POPULATION",BGPHD2="MALE Obese Active Clinical"
- I '$G(BGPSUMON) D HEADER^BGP4DPH Q:BGPQUIT W !,^BGPINDJ(BGPIC,53,1,0) W:$D(^BGPINDJ(BGPIC,53,2,0)) !,^BGPINDJ(BGPIC,53,2,0) D H3
- K BGPDAC,BGPDAP,BGPDAB S (D,C)=0 F BGPX="EE","EH","EK","EN","EQ" D I1AGE1,I1AGE2
- D I1AGEP
- Q:BGPQUIT
- FEM ;
- S BGPHD1="FEMALE OBESE ACTIVE CLINICAL POPULATION",BGPHD2="FEMALE Obese Active Clinical"
- I '$G(BGPSUMON) D HEADER^BGP4DPH Q:BGPQUIT W !,^BGPINDJ(BGPIC,53,1,0) W:$D(^BGPINDJ(BGPIC,53,2,0)) !,^BGPINDJ(BGPIC,53,2,0) D H3
- K BGPDAC,BGPDAP,BGPDAB S (C,D)=0 F BGPX="EF","EI","EL","EO","ER" D I1AGE1,I1AGE2
- D I1AGEP
- Q
- I1AGE1 ;
- ;gather up all #'s
- S C=C+1
- S BGPF="C-1."_BGPX_".3" S BGPPC=$O(^BGPINDJC("C",BGPF,0))
- S BGPDF=$P(^BGPINDJC(BGPPC,0),U,8)
- S BGPNP=$P(^DD(90552.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S $P(BGPDAC(C),U)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- S $P(BGPDAP(C),U)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- S $P(BGPDAB(C),U)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- ;set 2nd piece to numerator and 3rd to %
- S BGPNF=$P(^BGPINDJC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90552.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S $P(BGPDAC(C),U,2)=$$V^BGP4DP1C(1,BGPRPT,N,P),$P(BGPDAC(C),U,3)=$S($P(BGPDAC(C),U,1):($P(BGPDAC(C),U,2)/$P(BGPDAC(C),U)*100),1:"")
- S $P(BGPDAP(C),U,2)=$$V^BGP4DP1C(2,BGPRPT,N,P),$P(BGPDAP(C),U,3)=$S($P(BGPDAP(C),U,1):($P(BGPDAP(C),U,2)/$P(BGPDAP(C),U)*100),1:"")
- S $P(BGPDAB(C),U,2)=$$V^BGP4DP1C(3,BGPRPT,N,P),$P(BGPDAB(C),U,3)=$S($P(BGPDAB(C),U,1):($P(BGPDAB(C),U,2)/$P(BGPDAB(C),U)*100),1:"")
- Q
- I1AGE2 ;
- S D=D+1
- S BGPF="C-1."_BGPX_".2" S BGPPC=$O(^BGPINDJC("C",BGPF,0))
- ;set 4th piece to numerator and 5th to %
- S BGPNF=$P(^BGPINDJC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90552.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S $P(BGPDAC(D),U,4)=$$V^BGP4DP1C(1,BGPRPT,N,P),$P(BGPDAC(D),U,5)=$S($P(BGPDAC(D),U,1):($P(BGPDAC(D),U,4)/$P(BGPDAC(D),U,1)*100),1:"")
- S $P(BGPDAP(D),U,4)=$$V^BGP4DP1C(2,BGPRPT,N,P),$P(BGPDAP(D),U,5)=$S($P(BGPDAP(D),U,1):($P(BGPDAP(D),U,4)/$P(BGPDAP(D),U,1)*100),1:"")
- S $P(BGPDAB(D),U,4)=$$V^BGP4DP1C(3,BGPRPT,N,P),$P(BGPDAB(D),U,5)=$S($P(BGPDAB(D),U,1):($P(BGPDAB(D),U,4)/$P(BGPDAB(D),U,1)*100),1:"")
- I1AGE3 ;
- S BGPF="C-1."_BGPX_".1" S BGPPC=$O(^BGPINDJC("C",BGPF,0))
- ;set 6th piece to numerator and 7th to %
- S BGPNF=$P(^BGPINDJC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90552.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S $P(BGPDAC(D),U,6)=$$V^BGP4DP1C(1,BGPRPT,N,P),$P(BGPDAC(D),U,7)=$S($P(BGPDAC(D),U,1):($P(BGPDAC(D),U,6)/$P(BGPDAC(D),U,1)*100),1:"")
- S $P(BGPDAP(D),U,6)=$$V^BGP4DP1C(2,BGPRPT,N,P),$P(BGPDAP(D),U,7)=$S($P(BGPDAP(D),U,1):($P(BGPDAP(D),U,6)/$P(BGPDAP(D),U,1)*100),1:"")
- S $P(BGPDAB(D),U,6)=$$V^BGP4DP1C(3,BGPRPT,N,P),$P(BGPDAB(D),U,7)=$S($P(BGPDAB(D),U,1):($P(BGPDAB(D),U,6)/$P(BGPDAB(D),U,1)*100),1:"")
- I1AGE4 ;
- S BGPF="C-1."_BGPX_".4" S BGPPC=$O(^BGPINDJC("C",BGPF,0))
- ;set 8th piece to numerator and 9th to %
- S BGPNF=$P(^BGPINDJC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90552.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S $P(BGPDAC(D),U,8)=$$V^BGP4DP1C(1,BGPRPT,N,P),$P(BGPDAC(D),U,9)=$S($P(BGPDAC(D),U,1):($P(BGPDAC(D),U,8)/$P(BGPDAC(D),U,1)*100),1:"")
- S $P(BGPDAP(D),U,8)=$$V^BGP4DP1C(2,BGPRPT,N,P),$P(BGPDAP(D),U,9)=$S($P(BGPDAP(D),U,1):($P(BGPDAP(D),U,8)/$P(BGPDAP(D),U,1)*100),1:"")
- S $P(BGPDAB(D),U,8)=$$V^BGP4DP1C(3,BGPRPT,N,P),$P(BGPDAB(D),U,9)=$S($P(BGPDAB(D),U,1):($P(BGPDAB(D),U,8)/$P(BGPDAB(D),U,1)*100),1:"")
- Q
- I1AGEP ;
- D I1AGEP^BGP4DP60
- Q
- V(T,R,N,P) ;EP
- I $G(BGPAREAA) G VA
- I T=1 Q $P($G(^BGPGPDCJ(R,N)),U,P)
- I T=2 Q $P($G(^BGPGPDPJ(R,N)),U,P)
- I T=3 Q $P($G(^BGPGPDBJ(R,N)),U,P)
- Q ""
- VA ;
- NEW X,V,C S X=0,C="" F S X=$O(BGPSUL(X)) Q:X'=+X D
- .I T=1 S C=C+$P($G(^BGPGPDCJ(X,N)),U,P)
- .I T=2 S C=C+$P($G(^BGPGPDPJ(X,N)),U,P)
- .I T=3 S C=C+$P($G(^BGPGPDBJ(X,N)),U,P)
- .Q
- Q C
- ;
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- ;----------
- H3 ;EP
- Q:$G(BGPSUMON)
- W !!,$$CTR(BGPHD1,80)
- W !?40,"Age Distribution"
- W !,BGPHD2,?32,"6-11",?39,"12-19",?48,"20-39",?57,"40-59",?66,"=>60",!
- Q
- BGP4DP6 ; IHS/CMI/LAB - print ind H ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +2 ;
- +3 ;
- IC1 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDJ(BGPIC,12),U,6)
- +2 IF $Y>(BGPIOSL-16)
- IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !,^BGPINDJ(BGPIC,53,1,0)
- IF $DATA(^BGPINDJ(BGPIC,53,2,0))
- WRITE !,^BGPINDJ(BGPIC,53,2,0)
- +3 DO H1^BGP4DPH
- +4 FOR BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3"
- IF BGPQUIT
- QUIT
- DO PI^BGP4DP1C
- +5 IF BGPQUIT
- QUIT
- +6 IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- +7 FOR BGPPC1=BGPORXX_".4",BGPORXX_".5",BGPORXX_".6"
- IF BGPQUIT
- QUIT
- DO PI^BGP4DP1C
- +8 IF BGPQUIT
- QUIT
- +9 IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- +10 FOR BGPPC1=BGPORXX_".7",BGPORXX_".8",BGPORXX_".9"
- IF BGPQUIT
- QUIT
- DO PI^BGP4DP1C
- +11 IF BGPQUIT
- QUIT
- +12 DO I1AGE
- +13 QUIT
- I1AGE ;EP special age tallies
- +1 IF BGPINDJ="D"
- QUIT
- +2 IF BGPRTYPE'=4
- QUIT
- +3 IF BGPINDJ="W"
- IF BGPRTYPE=4
- GOTO FEM
- +4 SET BGPHD1="TOTAL OBESE ACTIVE CLINICAL POPULATION"
- SET BGPHD2="# Obese Active Clinical"
- +5 IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !,^BGPINDJ(BGPIC,53,1,0)
- IF $DATA(^BGPINDJ(BGPIC,53,2,0))
- WRITE !,^BGPINDJ(BGPIC,53,2,0)
- DO H3
- +6 KILL BGPDAC,BGPDAP,BGPDAB
- SET (C,D)=0
- FOR BGPX="ED","EG","EJ","EM","EP"
- DO I1AGE1
- DO I1AGE2
- +7 DO I1AGEP
- +8 IF BGPQUIT
- QUIT
- +9 SET BGPHD1="MALE OBESE ACTIVE CLINICAL POPULATION"
- SET BGPHD2="MALE Obese Active Clinical"
- +10 IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !,^BGPINDJ(BGPIC,53,1,0)
- IF $DATA(^BGPINDJ(BGPIC,53,2,0))
- WRITE !,^BGPINDJ(BGPIC,53,2,0)
- DO H3
- +11 KILL BGPDAC,BGPDAP,BGPDAB
- SET (D,C)=0
- FOR BGPX="EE","EH","EK","EN","EQ"
- DO I1AGE1
- DO I1AGE2
- +12 DO I1AGEP
- +13 IF BGPQUIT
- QUIT
- FEM ;
- +1 SET BGPHD1="FEMALE OBESE ACTIVE CLINICAL POPULATION"
- SET BGPHD2="FEMALE Obese Active Clinical"
- +2 IF '$GET(BGPSUMON)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !,^BGPINDJ(BGPIC,53,1,0)
- IF $DATA(^BGPINDJ(BGPIC,53,2,0))
- WRITE !,^BGPINDJ(BGPIC,53,2,0)
- DO H3
- +3 KILL BGPDAC,BGPDAP,BGPDAB
- SET (C,D)=0
- FOR BGPX="EF","EI","EL","EO","ER"
- DO I1AGE1
- DO I1AGE2
- +4 DO I1AGEP
- +5 QUIT
- I1AGE1 ;
- +1 ;gather up all #'s
- +2 SET C=C+1
- +3 SET BGPF="C-1."_BGPX_".3"
- SET BGPPC=$ORDER(^BGPINDJC("C",BGPF,0))
- +4 SET BGPDF=$PIECE(^BGPINDJC(BGPPC,0),U,8)
- +5 SET BGPNP=$PIECE(^DD(90552.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +6 SET $PIECE(BGPDAC(C),U)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- +7 SET $PIECE(BGPDAP(C),U)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- +8 SET $PIECE(BGPDAB(C),U)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- +9 ;set 2nd piece to numerator and 3rd to %
- +10 SET BGPNF=$PIECE(^BGPINDJC(BGPPC,0),U,9)
- +11 SET BGPNP=$PIECE(^DD(90552.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +12 SET $PIECE(BGPDAC(C),U,2)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- SET $PIECE(BGPDAC(C),U,3)=$SELECT($PIECE(BGPDAC(C),U,1):($PIECE(BGPDAC(C),U,2)/$PIECE(BGPDAC(C),U)*100),1:"")
- +13 SET $PIECE(BGPDAP(C),U,2)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- SET $PIECE(BGPDAP(C),U,3)=$SELECT($PIECE(BGPDAP(C),U,1):($PIECE(BGPDAP(C),U,2)/$PIECE(BGPDAP(C),U)*100),1:"")
- +14 SET $PIECE(BGPDAB(C),U,2)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- SET $PIECE(BGPDAB(C),U,3)=$SELECT($PIECE(BGPDAB(C),U,1):($PIECE(BGPDAB(C),U,2)/$PIECE(BGPDAB(C),U)*100),1:"")
- +15 QUIT
- I1AGE2 ;
- +1 SET D=D+1
- +2 SET BGPF="C-1."_BGPX_".2"
- SET BGPPC=$ORDER(^BGPINDJC("C",BGPF,0))
- +3 ;set 4th piece to numerator and 5th to %
- +4 SET BGPNF=$PIECE(^BGPINDJC(BGPPC,0),U,9)
- +5 SET BGPNP=$PIECE(^DD(90552.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +6 SET $PIECE(BGPDAC(D),U,4)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- SET $PIECE(BGPDAC(D),U,5)=$SELECT($PIECE(BGPDAC(D),U,1):($PIECE(BGPDAC(D),U,4)/$PIECE(BGPDAC(D),U,1)*100),1:"")
- +7 SET $PIECE(BGPDAP(D),U,4)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- SET $PIECE(BGPDAP(D),U,5)=$SELECT($PIECE(BGPDAP(D),U,1):($PIECE(BGPDAP(D),U,4)/$PIECE(BGPDAP(D),U,1)*100),1:"")
- +8 SET $PIECE(BGPDAB(D),U,4)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- SET $PIECE(BGPDAB(D),U,5)=$SELECT($PIECE(BGPDAB(D),U,1):($PIECE(BGPDAB(D),U,4)/$PIECE(BGPDAB(D),U,1)*100),1:"")
- I1AGE3 ;
- +1 SET BGPF="C-1."_BGPX_".1"
- SET BGPPC=$ORDER(^BGPINDJC("C",BGPF,0))
- +2 ;set 6th piece to numerator and 7th to %
- +3 SET BGPNF=$PIECE(^BGPINDJC(BGPPC,0),U,9)
- +4 SET BGPNP=$PIECE(^DD(90552.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +5 SET $PIECE(BGPDAC(D),U,6)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- SET $PIECE(BGPDAC(D),U,7)=$SELECT($PIECE(BGPDAC(D),U,1):($PIECE(BGPDAC(D),U,6)/$PIECE(BGPDAC(D),U,1)*100),1:"")
- +6 SET $PIECE(BGPDAP(D),U,6)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- SET $PIECE(BGPDAP(D),U,7)=$SELECT($PIECE(BGPDAP(D),U,1):($PIECE(BGPDAP(D),U,6)/$PIECE(BGPDAP(D),U,1)*100),1:"")
- +7 SET $PIECE(BGPDAB(D),U,6)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- SET $PIECE(BGPDAB(D),U,7)=$SELECT($PIECE(BGPDAB(D),U,1):($PIECE(BGPDAB(D),U,6)/$PIECE(BGPDAB(D),U,1)*100),1:"")
- I1AGE4 ;
- +1 SET BGPF="C-1."_BGPX_".4"
- SET BGPPC=$ORDER(^BGPINDJC("C",BGPF,0))
- +2 ;set 8th piece to numerator and 9th to %
- +3 SET BGPNF=$PIECE(^BGPINDJC(BGPPC,0),U,9)
- +4 SET BGPNP=$PIECE(^DD(90552.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +5 SET $PIECE(BGPDAC(D),U,8)=$$V^BGP4DP1C(1,BGPRPT,N,P)
- SET $PIECE(BGPDAC(D),U,9)=$SELECT($PIECE(BGPDAC(D),U,1):($PIECE(BGPDAC(D),U,8)/$PIECE(BGPDAC(D),U,1)*100),1:"")
- +6 SET $PIECE(BGPDAP(D),U,8)=$$V^BGP4DP1C(2,BGPRPT,N,P)
- SET $PIECE(BGPDAP(D),U,9)=$SELECT($PIECE(BGPDAP(D),U,1):($PIECE(BGPDAP(D),U,8)/$PIECE(BGPDAP(D),U,1)*100),1:"")
- +7 SET $PIECE(BGPDAB(D),U,8)=$$V^BGP4DP1C(3,BGPRPT,N,P)
- SET $PIECE(BGPDAB(D),U,9)=$SELECT($PIECE(BGPDAB(D),U,1):($PIECE(BGPDAB(D),U,8)/$PIECE(BGPDAB(D),U,1)*100),1:"")
- +8 QUIT
- I1AGEP ;
- +1 DO I1AGEP^BGP4DP60
- +2 QUIT
- V(T,R,N,P) ;EP
- +1 IF $GET(BGPAREAA)
- GOTO VA
- +2 IF T=1
- QUIT $PIECE($GET(^BGPGPDCJ(R,N)),U,P)
- +3 IF T=2
- QUIT $PIECE($GET(^BGPGPDPJ(R,N)),U,P)
- +4 IF T=3
- QUIT $PIECE($GET(^BGPGPDBJ(R,N)),U,P)
- +5 QUIT ""
- VA ;
- +1 NEW X,V,C
- SET X=0
- SET C=""
- FOR
- SET X=$ORDER(BGPSUL(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +2 IF T=1
- SET C=C+$PIECE($GET(^BGPGPDCJ(X,N)),U,P)
- +3 IF T=2
- SET C=C+$PIECE($GET(^BGPGPDPJ(X,N)),U,P)
- +4 IF T=3
- SET C=C+$PIECE($GET(^BGPGPDBJ(X,N)),U,P)
- +5 QUIT
- End DoDot:1
- +6 QUIT C
- +7 ;
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
- CTR(X,Y) ;EP - Center X in a field Y wide.
- +1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
- +2 ;----------
- H3 ;EP
- +1 IF $GET(BGPSUMON)
- QUIT
- +2 WRITE !!,$$CTR(BGPHD1,80)
- +3 WRITE !?40,"Age Distribution"
- +4 WRITE !,BGPHD2,?32,"6-11",?39,"12-19",?48,"20-39",?57,"40-59",?66,"=>60",!
- +5 QUIT