APCLW11 ; IHS/CMI/LAB - CALC WEIGHT REPORT ;
;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/12/2007 code set versioning PN
;
START ;EP
;calculate 365 days ago and 1095 days ago
S X1=APCLDATE,X2=-365 D C^%DTC S Y=X D DD^%DT S APCL1YR=Y
S X1=APCLDATE,X2=-1095 D C^%DTC S Y=X D DD^%DT S APCL3YR=Y
S Y=APCLDATE D DD^%DT S APCLDT=Y
S APCLJOB=$J,APCLBTH=$H,(DFN,APCLBTUP,APCLBBMI,APCLBOVR,APCLBOBE,APCLBHGH,APCLFTUP,APCLMTUP,APCLMBMI,APCLFBMI,APCLFOVR,APCLMOVR,APCLFOBE,APCLMOBE,APCLFHGH,APCLMHGH)=0,(APCLBLOW,APCLFLOW,APCLMLOW)=9999999
D XTMP^APCLOSUT("APCLW1","PCC OBESITY/PREVALANCE REPORT")
I APCLAGEG="G" D SETGROUP^APCLW12
I APCLAGEG'="G" F I=APCLLOWA:1:APCLHGHA F J="B","F","M" S ^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL USABLE PATS",J,I)=0,^XTMP("APCLW1",APCLJOB,APCLBTH,"LOW",J,I)=9999999,^XTMP("APCLW1",APCLJOB,APCLBTH,"HIGH",J,I)=0 D
.S ^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL BMI",J,I)=0,^XTMP("APCLW1",APCLJOB,APCLBTH,"OBESE",J,I)=0,^XTMP("APCLW1",APCLJOB,APCLBTH,"OVERWEIGHT",J,I)=0
;
PROC ;
F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19)
.Q:$P(^DPT(DFN,0),U,3)>APCLDATE ;born after as of date
.Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.I APCLSEAT]"" Q:'$D(^DIBT(APCLSEAT,1,DFN))
.I APCLCMS,'$$ONREG(DFN,APCLCMS,APCLSTAT) Q
.S Y=DFN D ^AUPNPAT
.Q:AUPNSEX=""
.Q:AUPNSEX="U" ;MU
.Q:APCLSEX'="B"&(APCLSEX'=AUPNSEX) ;quit if want only one sex and this patient isn't that sex
.Q:AUPNDOB=""
.S ^(AUPNSEX)=$S($D(^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL RECORDS",AUPNSEX)):^(AUPNSEX)+1,1:1)
.I APCLSEX="B" S ^("B")=$S($D(^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL RECORDS","B")):^("B")+1,1:1)
.S X2=AUPNDOB,X1=APCLDATE D ^%DTC S AUPNDAYS=X
.Q:AUPNDAYS<0
.S APCLAGE=(AUPNDAYS\365.25)
.;Q:APCLAGE<APCLLOWA
.;Q:APCLAGE>APCLHGHA
.S APCLHBD=$S(APCLAGE>19:$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(DFN,0),U,3),(19*365))),1:APCL1YR)
.S APCLBD=$S(APCLAGE>19:APCL3YR,1:APCL1YR) D GETWTHT
.Q:'$D(APCLGWT) ;quit if no weights
.Q:'$D(APCLGHT) ;quit if no heights
.S APCLCLAS=$$BEN^AUPNPAT(DFN,"C")
.Q:APCLCLAS=""
.Q:APCLIBEN=1&(APCLCLAS'="01")
.K APCLCWT,APCLCHT
.I APCLAGE>19 D GETRECNT
.I APCLAGE<20 D GETWHSD
.Q:'$D(APCLCWT)
.Q:'$D(APCLCHT)
.S X2=AUPNDOB,X1=$P(APCLCWT,U,2) D ^%DTC S APCLAGE=(X\365.25) ;recalculate age based on date of weight
.Q:APCLAGE<APCLLOWA
.Q:APCLAGE>APCLHGHA
.D CALCBMI
.;find entry in reference table
.;S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLAGE)) Q:APCLREF="" S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,"")) Q:APCLREF=""
.S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLAGE,0))
.I 'APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLAGE)) I APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,""))
.Q:'APCLREF
.I APCLBMI>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI<$P(^APCLBMI(APCLREF,0),U,6)) Q
.I APCLAGEG="G" D SETG^APCLW12
.I APCLAGEG'="G" D SETE^APCLW12
.Q
EOJ ;
K APCL1YR,APCL3YR,APCLA,APCLBD,APCLMGI,APCLCHT,APCLCWT,APCLGHT,APCLGWT,APCLROWT,APCLROHT,APCLER,APCLMHT,APCLMWT,APCLX,APCLY,APCLNN,APCLREF
K AUPNPAT,AUPNDOB,AUPNSEX,AUPNDAYS,AUPNDOD
K DFN,X,Y,V,A,D,I,J,Z
Q
CALCBMI ;calculate BMI value
;S APCLMWT=APCLCWT/2.21,APCLMHT=APCLCHT*.025,APCLBMI=APCLMWT/(APCLMHT*APCLMHT)
S APCLMWT=APCLCWT*.45359,APCLMHT=APCLCHT*.0254,APCLBMI=APCLMWT/(APCLMHT*APCLMHT)
Q
GETWTHT ;
K APCLGHT,APCLGWT
S APCLY="APCLGWT(",APCLX=DFN_"^ALL MEASUREMENT WT;DURING "_APCLBD_"-"_APCLDT S APCLER=$$START1^APCLDF(APCLX,APCLY)
;get rid of ones with no value
S X=0 F S X=$O(APCLGWT(X)) Q:X'=+X I '$P(APCLGWT(X),U,2) K APCLGWT(X)
S APCLY="APCLGHT(",APCLX=DFN_"^ALL MEASUREMENT HT;DURING "_APCLHBD_"-"_APCLDT S APCLER=$$START1^APCLDF(APCLX,APCLY)
S X=0 F S X=$O(APCLGHT(X)) Q:X'=+X I '$P(APCLGHT(X),U,2) K APCLGHT(X)
PN ;kill off those that have prenatal code as dx
;S X=0 F S X=$O(APCLGWT(X)) Q:X'=+X S V=$P(APCLGWT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P(^ICD9($P(^AUPNVPOV(P,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
S X=0 F S X=$O(APCLGWT(X)) Q:X'=+X S V=$P(APCLGWT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P($$ICDDX^ICDEX($P(^AUPNVPOV(P,0),U)),U,1) D ;cmi/anch/maw 9/12/2007 csv
.I $$ICD^ATXAPI(D,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) K APCLGWT(X) Q
.Q
;S X=0 F S X=$O(APCLGHT(X)) Q:X'=+X S V=$P(APCLGHT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P(^ICD9($P(^AUPNVPOV(P,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
S X=0 F S X=$O(APCLGHT(X)) Q:X'=+X S V=$P(APCLGHT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P($$ICDDX^ICDEX($P(^AUPNVPOV(P,0),U)),U,1) D ;cmi/anch/maw 9/12/2007 csv
.I $$ICD^ATXAPI(D,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) K APCLGHT(X) Q
.Q
RO ;set up by date
K APCLROWT,APCLROHT
S X=0 F S X=$O(APCLGWT(X)) Q:X'=+X S APCLROWT($P(APCLGWT(X),U))=X
S X=0 F S X=$O(APCLGHT(X)) Q:X'=+X S APCLROHT($P(APCLGHT(X),U))=X
Q
;
GETWHSD ;check for height and weight on same date
;reverse $O THRU APCLROWT & CHECK APCLROHT
S X=9999999 F S X=$O(APCLROWT(X),-1) Q:X=""!($D(APCLCHT)) I $D(APCLROHT(X)) S APCLCHT=$P(APCLGHT(APCLROHT(X)),U,2)_U_X,APCLCWT=$P(APCLGWT(APCLROWT(X)),U,2)_U_X
Q
GETRECNT ;get most recent in 3 yrs
S X=9999999,X=$O(APCLROWT(X),-1) Q:X="" S APCLCWT=$P(APCLGWT(APCLROWT(X)),U,2)_U_X
S X=9999999,X=$O(APCLROHT(X),-1) Q:X="" S APCLCHT=$P(APCLGHT(APCLROHT(X)),U,2)_U_X
Q
ONREG(P,R,S) ;is this patient on this register with this status
I $G(P)="" Q ""
I $G(R)="" Q ""
S S=$G(S)
NEW D S D=$G(^ACM(41,"AC",P,R))
I D="" Q ""
I S="" Q 1
I $P($G(^ACM(41,D,"DT")),U,1)'=S Q 0
Q 1
APCLW11 ; IHS/CMI/LAB - CALC WEIGHT REPORT ;
+1 ;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning PN
+4 ;
START ;EP
+1 ;calculate 365 days ago and 1095 days ago
+2 SET X1=APCLDATE
SET X2=-365
DO C^%DTC
SET Y=X
DO DD^%DT
SET APCL1YR=Y
+3 SET X1=APCLDATE
SET X2=-1095
DO C^%DTC
SET Y=X
DO DD^%DT
SET APCL3YR=Y
+4 SET Y=APCLDATE
DO DD^%DT
SET APCLDT=Y
+5 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
SET (DFN,APCLBTUP,APCLBBMI,APCLBOVR,APCLBOBE,APCLBHGH,APCLFTUP,APCLMTUP,APCLMBMI,APCLFBMI,APCLFOVR,APCLMOVR,APCLFOBE,APCLMOBE,APCLFHGH,APCLMHGH)=0
SET (APCLBLOW,APCLFLOW,APCLMLOW)=9999999
+6 DO XTMP^APCLOSUT("APCLW1","PCC OBESITY/PREVALANCE REPORT")
+7 IF APCLAGEG="G"
DO SETGROUP^APCLW12
+8 IF APCLAGEG'="G"
FOR I=APCLLOWA:1:APCLHGHA
FOR J="B","F","M"
SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL USABLE PATS",J,I)=0
SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"LOW",J,I)=9999999
SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"HIGH",J,I)=0
Begin DoDot:1
+9 SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL BMI",J,I)=0
SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"OBESE",J,I)=0
SET ^XTMP("APCLW1",APCLJOB,APCLBTH,"OVERWEIGHT",J,I)=0
End DoDot:1
+10 ;
PROC ;
+1 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+2 IF '$DATA(^DPT(DFN,0))
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 ;born after as of date
IF $PIECE(^DPT(DFN,0),U,3)>APCLDATE
QUIT
+5 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+6 IF APCLSEAT]""
IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+7 IF APCLCMS
IF '$$ONREG(DFN,APCLCMS,APCLSTAT)
QUIT
+8 SET Y=DFN
DO ^AUPNPAT
+9 IF AUPNSEX=""
QUIT
+10 ;MU
IF AUPNSEX="U"
QUIT
+11 ;quit if want only one sex and this patient isn't that sex
IF APCLSEX'="B"&(APCLSEX'=AUPNSEX)
QUIT
+12 IF AUPNDOB=""
QUIT
+13 SET ^(AUPNSEX)=$SELECT($DATA(^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL RECORDS",AUPNSEX)):^(AUPNSEX)+1,1:1)
+14 IF APCLSEX="B"
SET ^("B")=$SELECT($DATA(^XTMP("APCLW1",APCLJOB,APCLBTH,"TOTAL RECORDS","B")):^("B")+1,1:1)
+15 SET X2=AUPNDOB
SET X1=APCLDATE
DO ^%DTC
SET AUPNDAYS=X
+16 IF AUPNDAYS<0
QUIT
+17 SET APCLAGE=(AUPNDAYS\365.25)
+18 ;Q:APCLAGE<APCLLOWA
+19 ;Q:APCLAGE>APCLHGHA
+20 SET APCLHBD=$SELECT(APCLAGE>19:$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(^DPT(DFN,0),U,3),(19*365))),1:APCL1YR)
+21 SET APCLBD=$SELECT(APCLAGE>19:APCL3YR,1:APCL1YR)
DO GETWTHT
+22 ;quit if no weights
IF '$DATA(APCLGWT)
QUIT
+23 ;quit if no heights
IF '$DATA(APCLGHT)
QUIT
+24 SET APCLCLAS=$$BEN^AUPNPAT(DFN,"C")
+25 IF APCLCLAS=""
QUIT
+26 IF APCLIBEN=1&(APCLCLAS'="01")
QUIT
+27 KILL APCLCWT,APCLCHT
+28 IF APCLAGE>19
DO GETRECNT
+29 IF APCLAGE<20
DO GETWHSD
+30 IF '$DATA(APCLCWT)
QUIT
+31 IF '$DATA(APCLCHT)
QUIT
+32 ;recalculate age based on date of weight
SET X2=AUPNDOB
SET X1=$PIECE(APCLCWT,U,2)
DO ^%DTC
SET APCLAGE=(X\365.25)
+33 IF APCLAGE<APCLLOWA
QUIT
+34 IF APCLAGE>APCLHGHA
QUIT
+35 DO CALCBMI
+36 ;find entry in reference table
+37 ;S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLAGE)) Q:APCLREF="" S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,"")) Q:APCLREF=""
+38 SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLAGE,0))
+39 IF 'APCLREF
SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLAGE))
IF APCLREF
SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLREF,""))
+40 IF 'APCLREF
QUIT
+41 IF APCLBMI>$PIECE(^APCLBMI(APCLREF,0),U,7)!(APCLBMI<$PIECE(^APCLBMI(APCLREF,0),U,6))
QUIT
+42 IF APCLAGEG="G"
DO SETG^APCLW12
+43 IF APCLAGEG'="G"
DO SETE^APCLW12
+44 QUIT
End DoDot:1
EOJ ;
+1 KILL APCL1YR,APCL3YR,APCLA,APCLBD,APCLMGI,APCLCHT,APCLCWT,APCLGHT,APCLGWT,APCLROWT,APCLROHT,APCLER,APCLMHT,APCLMWT,APCLX,APCLY,APCLNN,APCLREF
+2 KILL AUPNPAT,AUPNDOB,AUPNSEX,AUPNDAYS,AUPNDOD
+3 KILL DFN,X,Y,V,A,D,I,J,Z
+4 QUIT
CALCBMI ;calculate BMI value
+1 ;S APCLMWT=APCLCWT/2.21,APCLMHT=APCLCHT*.025,APCLBMI=APCLMWT/(APCLMHT*APCLMHT)
+2 SET APCLMWT=APCLCWT*.45359
SET APCLMHT=APCLCHT*.0254
SET APCLBMI=APCLMWT/(APCLMHT*APCLMHT)
+3 QUIT
GETWTHT ;
+1 KILL APCLGHT,APCLGWT
+2 SET APCLY="APCLGWT("
SET APCLX=DFN_"^ALL MEASUREMENT WT;DURING "_APCLBD_"-"_APCLDT
SET APCLER=$$START1^APCLDF(APCLX,APCLY)
+3 ;get rid of ones with no value
+4 SET X=0
FOR
SET X=$ORDER(APCLGWT(X))
IF X'=+X
QUIT
IF '$PIECE(APCLGWT(X),U,2)
KILL APCLGWT(X)
+5 SET APCLY="APCLGHT("
SET APCLX=DFN_"^ALL MEASUREMENT HT;DURING "_APCLHBD_"-"_APCLDT
SET APCLER=$$START1^APCLDF(APCLX,APCLY)
+6 SET X=0
FOR
SET X=$ORDER(APCLGHT(X))
IF X'=+X
QUIT
IF '$PIECE(APCLGHT(X),U,2)
KILL APCLGHT(X)
PN ;kill off those that have prenatal code as dx
+1 ;S X=0 F S X=$O(APCLGWT(X)) Q:X'=+X S V=$P(APCLGWT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P(^ICD9($P(^AUPNVPOV(P,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET X=0
FOR
SET X=$ORDER(APCLGWT(X))
IF X'=+X
QUIT
SET V=$PIECE(APCLGWT(X),U,5)
SET P=0
FOR
SET P=$ORDER(^AUPNVPOV("AD",V,P))
IF P'=+P
QUIT
SET D=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(P,0),U)),U,1)
Begin DoDot:1
+3 IF $$ICD^ATXAPI(D,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
KILL APCLGWT(X)
QUIT
+4 QUIT
End DoDot:1
+5 ;S X=0 F S X=$O(APCLGHT(X)) Q:X'=+X S V=$P(APCLGHT(X),U,5),P=0 F S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P S D=$P(^ICD9($P(^AUPNVPOV(P,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
+6 ;cmi/anch/maw 9/12/2007 csv
SET X=0
FOR
SET X=$ORDER(APCLGHT(X))
IF X'=+X
QUIT
SET V=$PIECE(APCLGHT(X),U,5)
SET P=0
FOR
SET P=$ORDER(^AUPNVPOV("AD",V,P))
IF P'=+P
QUIT
SET D=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(P,0),U)),U,1)
Begin DoDot:1
+7 IF $$ICD^ATXAPI(D,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
KILL APCLGHT(X)
QUIT
+8 QUIT
End DoDot:1
RO ;set up by date
+1 KILL APCLROWT,APCLROHT
+2 SET X=0
FOR
SET X=$ORDER(APCLGWT(X))
IF X'=+X
QUIT
SET APCLROWT($PIECE(APCLGWT(X),U))=X
+3 SET X=0
FOR
SET X=$ORDER(APCLGHT(X))
IF X'=+X
QUIT
SET APCLROHT($PIECE(APCLGHT(X),U))=X
+4 QUIT
+5 ;
GETWHSD ;check for height and weight on same date
+1 ;reverse $O THRU APCLROWT & CHECK APCLROHT
+2 SET X=9999999
FOR
SET X=$ORDER(APCLROWT(X),-1)
IF X=""!($DATA(APCLCHT))
QUIT
IF $DATA(APCLROHT(X))
SET APCLCHT=$PIECE(APCLGHT(APCLROHT(X)),U,2)_U_X
SET APCLCWT=$PIECE(APCLGWT(APCLROWT(X)),U,2)_U_X
+3 QUIT
GETRECNT ;get most recent in 3 yrs
+1 SET X=9999999
SET X=$ORDER(APCLROWT(X),-1)
IF X=""
QUIT
SET APCLCWT=$PIECE(APCLGWT(APCLROWT(X)),U,2)_U_X
+2 SET X=9999999
SET X=$ORDER(APCLROHT(X),-1)
IF X=""
QUIT
SET APCLCHT=$PIECE(APCLGHT(APCLROHT(X)),U,2)_U_X
+3 QUIT
ONREG(P,R,S) ;is this patient on this register with this status
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(R)=""
QUIT ""
+3 SET S=$GET(S)
+4 NEW D
SET D=$GET(^ACM(41,"AC",P,R))
+5 IF D=""
QUIT ""
+6 IF S=""
QUIT 1
+7 IF $PIECE($GET(^ACM(41,D,"DT")),U,1)'=S
QUIT 0
+8 QUIT 1
