CIMGAGP4 ; CMI/TUCSON/LAB - aberdeen area GPRA ; [ 03/13/00 9:45 AM ]
;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000
;
;
IND2023 ;obesity
S CIMAGE=$$AGE^AUPNPAT(DFN,CIMEDATE)
I CIMAGE=3!(CIMAGE=4)!(CIMAGE=5) D
.D S(CIMRPT,$S(CIMTIME:19,1:20),14,1)
.S V=$$OVERW(DFN,CIMEDATE)
.I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),23,1)
.I V D S(CIMRPT,$S(CIMTIME:19,1:20),29,1)
.I $D(CIMLIST(13)),CIMTIME,V S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)="OVERWEIGHT"
.S V=$$OBESE(DFN,CIMEDATE)
.I V D S(CIMRPT,$S(CIMTIME:19,1:20),15,1)
.I $D(CIMLIST(13)),CIMTIME,V S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)="OBESE"
I CIMAGE=8!(CIMAGE=9)!(CIMAGE=10) D
.D S(CIMRPT,$S(CIMTIME:19,1:20),16,1)
.S V=$$OVERW(DFN,CIMEDATE)
.I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),24,1)
.I V D S(CIMRPT,$S(CIMTIME:19,1:20),30,1)
.I $D(CIMLIST(13)),CIMTIME,V S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)="OVERWEIGHT"
.S V=$$OBESE(DFN,CIMEDATE)
.I V D S(CIMRPT,$S(CIMTIME:19,1:20),17,1)
.I $D(CIMLIST(13)),CIMTIME,V S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)="OBESE"
Q
S(R,N,P,V) ;
I 'R Q
S $P(^CIMAGP(R,N),U,P)=$P($G(^CIMAGP(R,N)),U,P)+V
Q
;
OBESE(P,EDATE) ;
;get all weights and heights edate-365 to edate
;get last weight/height on same day
;calculate BMI
;if obese return 1
;return 2 if not obese
;return null if unable to calculate
NEW BDATE
S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW CIMGHT,CIMGWT,%,E,Y
K CIMGHT,CIMGWT
S %="CIMGWT(",Y=P_"^ALL MEASUREMENT WT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(Y,%)
S %="CIMGHT(",Y=P_"^ALL MEASUREMENT HT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(Y,%)
I '$D(CIMGHT(1)) Q ""
I '$D(CIMGWT(1)) Q ""
NEW CIMROWT,CIMROHT K CIMROWT,CIMROHT
S Y=0 F S Y=$O(CIMGWT(Y)) Q:Y'=+Y S CIMROWT($P(CIMGWT(Y),U))=Y
S Y=0 F S Y=$O(CIMGHT(Y)) Q:Y'=+Y S CIMROHT($P(CIMGHT(Y),U))=Y
;get ht/wt on same date
NEW X,CHT,CWT
S X=9999999 F S X=$O(CIMROWT(X),-1) Q:X=""!($D(CHT)) I $D(CIMROHT(X)) S CHT=$P(CIMGHT(CIMROHT(X)),U,2),CWT=$P(CIMGWT(CIMROWT(X)),U,2)
I '$D(CHT) Q ""
;calc bmi
NEW MWT,MHT,BMI
S MWT=CWT/2.21,MHT=CHT*.025,BMI=MWT/(MHT*MHT)
;determine if obese or not based on table
NEW AGE S AGE=$$AGE^AUPNPAT(P,EDATE)
NEW R S R=$O(^APCLBMI("H",$P(^DPT(P,0),U,2),AGE,0))
I 'R Q ""
I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q ""
I BMI>$P(^APCLBMI(R,0),U,5) Q 1
Q 0
OVERW(P,EDATE) ;
;get all weights and heights edate-365 to edate
;get last weight/height on same day
;calculate BMI
;if overweight return 1
;return 2 if not overweight
;return null if unable to calculate
NEW BDATE
S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW CIMGHT,CIMGWT,%,E,Y
K CIMGHT,CIMGWT
S %="CIMGWT(",Y=P_"^ALL MEASUREMENT WT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(Y,%)
S %="CIMGHT(",Y=P_"^ALL MEASUREMENT HT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(Y,%)
I '$D(CIMGHT(1)) Q ""
I '$D(CIMGWT(1)) Q ""
NEW CIMROWT,CIMROHT K CIMROWT,CIMROHT
S Y=0 F S Y=$O(CIMGWT(Y)) Q:Y'=+Y S CIMROWT($P(CIMGWT(Y),U))=Y
S Y=0 F S Y=$O(CIMGHT(Y)) Q:Y'=+Y S CIMROHT($P(CIMGHT(Y),U))=Y
;get ht/wt on same date
NEW X,CHT,CWT
S X=9999999 F S X=$O(CIMROWT(X),-1) Q:X=""!($D(CHT)) I $D(CIMROHT(X)) S CHT=$P(CIMGHT(CIMROHT(X)),U,2),CWT=$P(CIMGWT(CIMROWT(X)),U,2)
I '$D(CHT) Q ""
;calc bmi
NEW MWT,MHT,BMI
S MWT=CWT/2.21,MHT=CHT*.025,BMI=MWT/(MHT*MHT)
;determine if overweight or not based on table
NEW AGE S AGE=$$AGE^AUPNPAT(P,EDATE)
NEW R S R=$O(^APCLBMI("H",$P(^DPT(P,0),U,2),AGE,0))
I 'R Q ""
I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q ""
I BMI>$P(^APCLBMI(R,0),U,4) Q 1
Q 0
CIMGAGP4 ; CMI/TUCSON/LAB - aberdeen area GPRA ; [ 03/13/00 9:45 AM ]
+1 ;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000
+2 ;
+3 ;
IND2023 ;obesity
+1 SET CIMAGE=$$AGE^AUPNPAT(DFN,CIMEDATE)
+2 IF CIMAGE=3!(CIMAGE=4)!(CIMAGE=5)
Begin DoDot:1
+3 DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),14,1)
+4 SET V=$$OVERW(DFN,CIMEDATE)
+5 IF V]""
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),23,1)
+6 IF V
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),29,1)
+7 IF $DATA(CIMLIST(13))
IF CIMTIME
IF V
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)="OVERWEIGHT"
+8 SET V=$$OBESE(DFN,CIMEDATE)
+9 IF V
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),15,1)
+10 IF $DATA(CIMLIST(13))
IF CIMTIME
IF V
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)="OBESE"
End DoDot:1
+11 IF CIMAGE=8!(CIMAGE=9)!(CIMAGE=10)
Begin DoDot:1
+12 DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),16,1)
+13 SET V=$$OVERW(DFN,CIMEDATE)
+14 IF V]""
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),24,1)
+15 IF V
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),30,1)
+16 IF $DATA(CIMLIST(13))
IF CIMTIME
IF V
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)="OVERWEIGHT"
+17 SET V=$$OBESE(DFN,CIMEDATE)
+18 IF V
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),17,1)
+19 IF $DATA(CIMLIST(13))
IF CIMTIME
IF V
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",13,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)="OBESE"
End DoDot:1
+20 QUIT
S(R,N,P,V) ;
+1 IF 'R
QUIT
+2 SET $PIECE(^CIMAGP(R,N),U,P)=$PIECE($GET(^CIMAGP(R,N)),U,P)+V
+3 QUIT
+4 ;
OBESE(P,EDATE) ;
+1 ;get all weights and heights edate-365 to edate
+2 ;get last weight/height on same day
+3 ;calculate BMI
+4 ;if obese return 1
+5 ;return 2 if not obese
+6 ;return null if unable to calculate
+7 NEW BDATE
+8 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+9 NEW CIMGHT,CIMGWT,%,E,Y
+10 KILL CIMGHT,CIMGWT
+11 SET %="CIMGWT("
SET Y=P_"^ALL MEASUREMENT WT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(Y,%)
+12 SET %="CIMGHT("
SET Y=P_"^ALL MEASUREMENT HT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(Y,%)
+13 IF '$DATA(CIMGHT(1))
QUIT ""
+14 IF '$DATA(CIMGWT(1))
QUIT ""
+15 NEW CIMROWT,CIMROHT
KILL CIMROWT,CIMROHT
+16 SET Y=0
FOR
SET Y=$ORDER(CIMGWT(Y))
IF Y'=+Y
QUIT
SET CIMROWT($PIECE(CIMGWT(Y),U))=Y
+17 SET Y=0
FOR
SET Y=$ORDER(CIMGHT(Y))
IF Y'=+Y
QUIT
SET CIMROHT($PIECE(CIMGHT(Y),U))=Y
+18 ;get ht/wt on same date
+19 NEW X,CHT,CWT
+20 SET X=9999999
FOR
SET X=$ORDER(CIMROWT(X),-1)
IF X=""!($DATA(CHT))
QUIT
IF $DATA(CIMROHT(X))
SET CHT=$PIECE(CIMGHT(CIMROHT(X)),U,2)
SET CWT=$PIECE(CIMGWT(CIMROWT(X)),U,2)
+21 IF '$DATA(CHT)
QUIT ""
+22 ;calc bmi
+23 NEW MWT,MHT,BMI
+24 SET MWT=CWT/2.21
SET MHT=CHT*.025
SET BMI=MWT/(MHT*MHT)
+25 ;determine if obese or not based on table
+26 NEW AGE
SET AGE=$$AGE^AUPNPAT(P,EDATE)
+27 NEW R
SET R=$ORDER(^APCLBMI("H",$PIECE(^DPT(P,0),U,2),AGE,0))
+28 IF 'R
QUIT ""
+29 IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))
QUIT ""
+30 IF BMI>$PIECE(^APCLBMI(R,0),U,5)
QUIT 1
+31 QUIT 0
OVERW(P,EDATE) ;
+1 ;get all weights and heights edate-365 to edate
+2 ;get last weight/height on same day
+3 ;calculate BMI
+4 ;if overweight return 1
+5 ;return 2 if not overweight
+6 ;return null if unable to calculate
+7 NEW BDATE
+8 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+9 NEW CIMGHT,CIMGWT,%,E,Y
+10 KILL CIMGHT,CIMGWT
+11 SET %="CIMGWT("
SET Y=P_"^ALL MEASUREMENT WT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(Y,%)
+12 SET %="CIMGHT("
SET Y=P_"^ALL MEASUREMENT HT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(Y,%)
+13 IF '$DATA(CIMGHT(1))
QUIT ""
+14 IF '$DATA(CIMGWT(1))
QUIT ""
+15 NEW CIMROWT,CIMROHT
KILL CIMROWT,CIMROHT
+16 SET Y=0
FOR
SET Y=$ORDER(CIMGWT(Y))
IF Y'=+Y
QUIT
SET CIMROWT($PIECE(CIMGWT(Y),U))=Y
+17 SET Y=0
FOR
SET Y=$ORDER(CIMGHT(Y))
IF Y'=+Y
QUIT
SET CIMROHT($PIECE(CIMGHT(Y),U))=Y
+18 ;get ht/wt on same date
+19 NEW X,CHT,CWT
+20 SET X=9999999
FOR
SET X=$ORDER(CIMROWT(X),-1)
IF X=""!($DATA(CHT))
QUIT
IF $DATA(CIMROHT(X))
SET CHT=$PIECE(CIMGHT(CIMROHT(X)),U,2)
SET CWT=$PIECE(CIMGWT(CIMROWT(X)),U,2)
+21 IF '$DATA(CHT)
QUIT ""
+22 ;calc bmi
+23 NEW MWT,MHT,BMI
+24 SET MWT=CWT/2.21
SET MHT=CHT*.025
SET BMI=MWT/(MHT*MHT)
+25 ;determine if overweight or not based on table
+26 NEW AGE
SET AGE=$$AGE^AUPNPAT(P,EDATE)
+27 NEW R
SET R=$ORDER(^APCLBMI("H",$PIECE(^DPT(P,0),U,2),AGE,0))
+28 IF 'R
QUIT ""
+29 IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))
QUIT ""
+30 IF BMI>$PIECE(^APCLBMI(R,0),U,4)
QUIT 1
+31 QUIT 0
