BGPD1 ; IHS/CMI/LAB - IHS area GPRA ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
PROC ;EP
S BGPBT=$H
D JRNL
S BGPJ=$J,BGPH=$H
;calculate 3 years before end of each time frame
S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
F X=1:1:18 S $P(^BGPD(BGPRPT,10),U,X)="0!0",$P(^BGPD(BGPRPT,40),U,X)="0!0",$P(^BGPD(BGPRPT,80),U,X)="0!0" ;indicator 1
F X=1:1:4 S $P(^BGPD(BGPRPT,18),U,X)="0!0",$P(^BGPD(BGPRPT,48),U,X)="0!0",$P(^BGPD(BGPRPT,88),U,X)="0!0"
S ^BGPD(BGPRPT,480,0)="^90240.048A^0^0"
S ^BGPD(BGPRPT,880,0)="^90240.088A^0^0"
S ^BGPD(BGPRPT,180,0)="^90240.018A^0^0"
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D PROC1,PROCPR,PROC98
S DIK="^BGPD(" D IXALL^DIK
K DIK
S BGPET=$H
Q
;
JRNL ;
N (DT,U) S %=$$NOJOURN^ZIBGCHAR("BGPD")
Q
PROC1 ;current time period
S (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
K BGPHV,BGPBPV ;kill glycemic value array
S BGPHV(1)="",BGPHV(0)="",BGPHV(8)=""
S BGPBPV(1)="",BGPBPV(0)="",BGPBPV(8)=""
Q:$$BEN^AUPNPAT(DFN,"C")'="01"
S DOD=$$DOD^AUPNPAT(DFN) I DOD]"",DOD<BGPED Q
S X=$P($G(^AUPNPAT(DFN,11)),U,18) Q:X=""
Q:'$D(BGPTAX($P(^AUPNPAT(DFN,11),U,18)))
S X=$$LASTVD(DFN,BGP3YE,BGPED)
Q:X="" ;not an active user
S BGPACT=1 ;an active user by end of time frame
S BGPEDATE=BGPED,BGPTIME=1,BGPBDATE=BGPBD
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
D CALCIND
Q
PROCPR ;
S (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
Q:$$BEN^AUPNPAT(DFN,"C")'="01"
S DOD=$$DOD^AUPNPAT(DFN) I DOD]"",DOD<BGPPED Q
S X=$P($G(^AUPNPAT(DFN,11)),U,18) Q:X=""
Q:'$D(BGPTAX($P(^AUPNPAT(DFN,11),U,18))) ;not a community of interest)
S X=$$LASTVD(DFN,BGPP3YE,BGPPED)
Q:X="" ;not an active user
S BGPACT=1 ;an active user by end of time frame
S BGPEDATE=BGPPED,BGPBDATE=BGPPBD,BGPTIME=0
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
D CALCIND
Q
PROC98 ;
S (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
Q:$$BEN^AUPNPAT(DFN,"C")'="01"
S DOD=$$DOD^AUPNPAT(DFN) I DOD]"",DOD<BGPBED Q
S X=$P($G(^AUPNPAT(DFN,11)),U,18) Q:X=""
Q:'$D(BGPTAX($P(^AUPNPAT(DFN,11),U,18))) ;not a community of interest)
S X=$$LASTVD(DFN,BGPB3YE,BGPBED)
Q:X="" ;not an active user
S BGPACT=1 ;an active user by end of time frame
S BGPEDATE=BGPBED,BGPBDATE=BGPBBD,BGPTIME=8
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
D CALCIND
Q
CALCIND ;
D I1A
I $D(BGPIND(1))!($D(BGPIND(2)))!($D(BGPIND(3)))!($D(BGPIND(4)))!($D(BGPIND(5)))!($D(BGPIND(6)))!($D(BGPIND(7)))!($D(BGPIND(8)))!($D(BGPIND(9)))!($D(BGPIND(10)))!($D(BGPIND(11)))!($D(BGPIND(12)))!($D(BGPIND(13)))!($D(BGPIND(14))) D
.D I1
.D I1B^BGPD1B
.D I2A^BGPD2
.D I2B^BGPD2
.D I2C^BGPD2
.D I3A^BGPD3
.D I3B^BGPD3
.D I3C^BGPD3
.D I4A^BGPD4
.D I4B^BGPD4
.D I4C^BGPD4
.D I5A^BGPD5
.D I5B^BGPD5
.D I5C^BGPD5
I $D(BGPIND(15))!($D(BGPIND(16))) D I6^BGPD6
I $D(BGPIND(16)) D I6A^BGPD6
I $D(BGPIND(17)) D I7^BGPD7
I $D(BGPIND(18))!($D(BGPIND(23))) D I8^BGPD8
I $D(BGPIND(19)) D I12^BGPD12
I $D(BGPIND(20)) D I13^BGPD13
I $D(BGPIND(21)) D I14^BGPD14
I $D(BGPIND(22)) D I22^BGPD22
;I $D(BGPIND(23)) D I23^BGPD23
I $D(BGPIND(24)) D I24^BGPD24
I $D(BGPIND(25)) D I29^BGPD29
I $D(BGPIND(26)) D I30^BGPD30
I $D(BGPIND(27)) D IA^BGPDA
I $D(BGPIND(28)) D IB^BGPDB
I $D(BGPIND(29)) D IC^BGPDC
I $D(BGPIND(30)) D ID^BGPDD
Q
I1A ;EP - indicator 1
S BGPSEX=$P(^DPT(DFN,0),U,2),BGPSEX=$S(BGPSEX="M":1,1:2)
D SAGE(BGPRPT,$S(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:"999"),1,BGPSEX,BGPACT) ;set total denom for 1 prevalence
S BGPAGEEP=$S(BGPAGEE<15:2,BGPAGEE>14&(BGPAGEE<20):3,BGPAGEE>19&(BGPAGEE<25):4,BGPAGEE>24&(BGPAGEE<35):5,BGPAGEE>34&(BGPAGEE<45):6,BGPAGEE>44&(BGPAGEE<55):7,BGPAGEE>54&(BGPAGEE<65):8,BGPAGEE>64:9,1:"")
D SAGE(BGPRPT,$S(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:999),BGPAGEEP,BGPSEX,1)
Q
I1 ;
S BGPDMPAT=$$DM(DFN,BGPEDATE)
D SAGE(BGPRPT,$S(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:"999"),10,BGPSEX,BGPDMPAT)
S BGPAGEEP=$S(BGPAGEE<15:11,BGPAGEE>14&(BGPAGEE<20):12,BGPAGEE>19&(BGPAGEE<25):13,BGPAGEE>24&(BGPAGEE<35):14,BGPAGEE>34&(BGPAGEE<45):15,BGPAGEE>44&(BGPAGEE<55):16,BGPAGEE>54&(BGPAGEE<65):17,BGPAGEE>64:18,1:"")
D SAGE(BGPRPT,$S(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:999),BGPAGEEP,BGPSEX,BGPDMPAT)
I BGPDMPAT,$D(BGPLIST(1)),BGPTIME=1 S ^XTMP("BGPD",BGPJ,BGPH,"LIST",1,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEE,DFN)=""
Q
SAGE(R,N,P,S,V) ;set age into file
I 'V Q ;no value
NEW X,Y
S X=$P($G(^BGPD(R,N)),U,P)
S $P(X,"!",S)=$P(X,"!",S)+V
S $P(^BGPD(R,N),U,P)=X
Q
S(R,N,P,V) ;
I 'V Q ;no value to add
S $P(^BGPD(R,N),U,P)=$P($G(^BGPD(R,N)),U,P)+V
Q
DM(P,EDATE) ;EP is patient diabetic 1 or 0
I $G(P)="" Q ""
;check povs
NEW X,E,BGPG,Y
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1 ;has a dx
Q 0
;
LASTVD(P,BDATE,EDATE) ;
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,V,X,G
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.S G=1
.Q
Q G
BGPD1 ; IHS/CMI/LAB - IHS area GPRA ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
PROC ;EP
+1 SET BGPBT=$HOROLOG
+2 DO JRNL
+3 SET BGPJ=$JOB
SET BGPH=$HOROLOG
+4 ;calculate 3 years before end of each time frame
+5 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+6 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+7 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+8 ;indicator 1
FOR X=1:1:18
SET $PIECE(^BGPD(BGPRPT,10),U,X)="0!0"
SET $PIECE(^BGPD(BGPRPT,40),U,X)="0!0"
SET $PIECE(^BGPD(BGPRPT,80),U,X)="0!0"
+9 FOR X=1:1:4
SET $PIECE(^BGPD(BGPRPT,18),U,X)="0!0"
SET $PIECE(^BGPD(BGPRPT,48),U,X)="0!0"
SET $PIECE(^BGPD(BGPRPT,88),U,X)="0!0"
+10 SET ^BGPD(BGPRPT,480,0)="^90240.048A^0^0"
+11 SET ^BGPD(BGPRPT,880,0)="^90240.088A^0^0"
+12 SET ^BGPD(BGPRPT,180,0)="^90240.018A^0^0"
+13 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
DO PROC1
DO PROCPR
DO PROC98
+14 SET DIK="^BGPD("
DO IXALL^DIK
+15 KILL DIK
+16 SET BGPET=$HOROLOG
+17 QUIT
+18 ;
JRNL ;
+1 NEW (DT,U)
SET %=$$NOJOURN^ZIBGCHAR("BGPD")
+2 QUIT
PROC1 ;current time period
+1 SET (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
+2 ;kill glycemic value array
KILL BGPHV,BGPBPV
+3 SET BGPHV(1)=""
SET BGPHV(0)=""
SET BGPHV(8)=""
+4 SET BGPBPV(1)=""
SET BGPBPV(0)=""
SET BGPBPV(8)=""
+5 IF $$BEN^AUPNPAT(DFN,"C")'="01"
QUIT
+6 SET DOD=$$DOD^AUPNPAT(DFN)
IF DOD]""
IF DOD<BGPED
QUIT
+7 SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF X=""
QUIT
+8 IF '$DATA(BGPTAX($PIECE(^AUPNPAT(DFN,11),U,18)))
QUIT
+9 SET X=$$LASTVD(DFN,BGP3YE,BGPED)
+10 ;not an active user
IF X=""
QUIT
+11 ;an active user by end of time frame
SET BGPACT=1
+12 SET BGPEDATE=BGPED
SET BGPTIME=1
SET BGPBDATE=BGPBD
+13 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+14 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+15 DO CALCIND
+16 QUIT
PROCPR ;
+1 SET (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
+2 IF $$BEN^AUPNPAT(DFN,"C")'="01"
QUIT
+3 SET DOD=$$DOD^AUPNPAT(DFN)
IF DOD]""
IF DOD<BGPPED
QUIT
+4 SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF X=""
QUIT
+5 ;not a community of interest)
IF '$DATA(BGPTAX($PIECE(^AUPNPAT(DFN,11),U,18)))
QUIT
+6 SET X=$$LASTVD(DFN,BGPP3YE,BGPPED)
+7 ;not an active user
IF X=""
QUIT
+8 ;an active user by end of time frame
SET BGPACT=1
+9 SET BGPEDATE=BGPPED
SET BGPBDATE=BGPPBD
SET BGPTIME=0
+10 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+11 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+12 DO CALCIND
+13 QUIT
PROC98 ;
+1 SET (BGPDMPAT,BGPMBP,BGPLHGB,BGPHGBV,BGP2BD,BGP2CD,BGP4LP,BGP4TG,BGP4LDL,BGP4HDL,BGPUP,BGPACT)=""
+2 IF $$BEN^AUPNPAT(DFN,"C")'="01"
QUIT
+3 SET DOD=$$DOD^AUPNPAT(DFN)
IF DOD]""
IF DOD<BGPBED
QUIT
+4 SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF X=""
QUIT
+5 ;not a community of interest)
IF '$DATA(BGPTAX($PIECE(^AUPNPAT(DFN,11),U,18)))
QUIT
+6 SET X=$$LASTVD(DFN,BGPB3YE,BGPBED)
+7 ;not an active user
IF X=""
QUIT
+8 ;an active user by end of time frame
SET BGPACT=1
+9 SET BGPEDATE=BGPBED
SET BGPBDATE=BGPBBD
SET BGPTIME=8
+10 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+11 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+12 DO CALCIND
+13 QUIT
CALCIND ;
+1 DO I1A
+2 IF $DATA(BGPIND(1))!($DATA(BGPIND(2)))!($DATA(BGPIND(3)))!($DATA(BGPIND(4)))!($DATA(BGPIND(5)))!($DATA(BGPIND(6)))!($DATA(BGPIND(7)))!(...
... $DATA(BGPIND(8)))!($DATA(BGPIND(9)))!($DATA(BGPIND(10)))!($DATA(BGPIND(11)))!($DATA(BGPIND(12)))!($DATA(BGPIND(13)))!($DATA(BGPIND(14)))
Begin DoDot:1
+3 DO I1
+4 DO I1B^BGPD1B
+5 DO I2A^BGPD2
+6 DO I2B^BGPD2
+7 DO I2C^BGPD2
+8 DO I3A^BGPD3
+9 DO I3B^BGPD3
+10 DO I3C^BGPD3
+11 DO I4A^BGPD4
+12 DO I4B^BGPD4
+13 DO I4C^BGPD4
+14 DO I5A^BGPD5
+15 DO I5B^BGPD5
+16 DO I5C^BGPD5
End DoDot:1
+17 IF $DATA(BGPIND(15))!($DATA(BGPIND(16)))
DO I6^BGPD6
+18 IF $DATA(BGPIND(16))
DO I6A^BGPD6
+19 IF $DATA(BGPIND(17))
DO I7^BGPD7
+20 IF $DATA(BGPIND(18))!($DATA(BGPIND(23)))
DO I8^BGPD8
+21 IF $DATA(BGPIND(19))
DO I12^BGPD12
+22 IF $DATA(BGPIND(20))
DO I13^BGPD13
+23 IF $DATA(BGPIND(21))
DO I14^BGPD14
+24 IF $DATA(BGPIND(22))
DO I22^BGPD22
+25 ;I $D(BGPIND(23)) D I23^BGPD23
+26 IF $DATA(BGPIND(24))
DO I24^BGPD24
+27 IF $DATA(BGPIND(25))
DO I29^BGPD29
+28 IF $DATA(BGPIND(26))
DO I30^BGPD30
+29 IF $DATA(BGPIND(27))
DO IA^BGPDA
+30 IF $DATA(BGPIND(28))
DO IB^BGPDB
+31 IF $DATA(BGPIND(29))
DO IC^BGPDC
+32 IF $DATA(BGPIND(30))
DO ID^BGPDD
+33 QUIT
I1A ;EP - indicator 1
+1 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
SET BGPSEX=$SELECT(BGPSEX="M":1,1:2)
+2 ;set total denom for 1 prevalence
DO SAGE(BGPRPT,$SELECT(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:"999"),1,BGPSEX,BGPACT)
+3 SET BGPAGEEP=$SELECT(BGPAGEE<15:2,BGPAGEE>14&(BGPAGEE<20):3,BGPAGEE>19&(BGPAGEE<25):4,BGPAGEE>24&(BGPAGEE<35):5,BGPAGEE>34&(BGPAGEE<45):6,BGPAGEE>44&(BGPAGEE<55):7,BGPAGEE>54&(BGPAGEE<65):8,BGPAGEE>64:9,1:"")
+4 DO SAGE(BGPRPT,$SELECT(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:999),BGPAGEEP,BGPSEX,1)
+5 QUIT
I1 ;
+1 SET BGPDMPAT=$$DM(DFN,BGPEDATE)
+2 DO SAGE(BGPRPT,$SELECT(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:"999"),10,BGPSEX,BGPDMPAT)
+3 SET BGPAGEEP=$SELECT(BGPAGEE<15:11,BGPAGEE>14&(BGPAGEE<20):12,BGPAGEE>19&(BGPAGEE<25):13,BGPAGEE>24&(BGPAGEE<35):14,BGPAGEE>34&(BGPAGEE<45):15,BGPAGEE>44&(BGPAGEE<55):16,BGPAGEE>54&(BGPAGEE<65):17,BGPAGEE>64:18,1:"")
+4 DO SAGE(BGPRPT,$SELECT(BGPTIME=1:10,BGPTIME=0:40,BGPTIME=8:80,1:999),BGPAGEEP,BGPSEX,BGPDMPAT)
+5 IF BGPDMPAT
IF $DATA(BGPLIST(1))
IF BGPTIME=1
SET ^XTMP("BGPD",BGPJ,BGPH,"LIST",1,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEE,DFN)=""
+6 QUIT
SAGE(R,N,P,S,V) ;set age into file
+1 ;no value
IF 'V
QUIT
+2 NEW X,Y
+3 SET X=$PIECE($GET(^BGPD(R,N)),U,P)
+4 SET $PIECE(X,"!",S)=$PIECE(X,"!",S)+V
+5 SET $PIECE(^BGPD(R,N),U,P)=X
+6 QUIT
S(R,N,P,V) ;
+1 ;no value to add
IF 'V
QUIT
+2 SET $PIECE(^BGPD(R,N),U,P)=$PIECE($GET(^BGPD(R,N)),U,P)+V
+3 QUIT
DM(P,EDATE) ;EP is patient diabetic 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 ;check povs
+3 NEW X,E,BGPG,Y
+4 KILL BGPG
+5 SET Y="BGPG("
+6 SET X=P_"^LAST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;has a dx
IF $DATA(BGPG(1))
QUIT 1
+8 QUIT 0
+9 ;
LASTVD(P,BDATE,EDATE) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 NEW A,B,E,V,X,G
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+12 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+13 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 QUIT G
