APCLW21 ; IHS/CMI/LAB - CALC WEIGHT REPORT ;
;;2.0;IHS PCC SUITE;**8,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=DT,X2=-365 D C^%DTC S Y=X D DD^%DT S APCL1YR=Y
S X1=DT,X2=-1095 D C^%DTC S Y=X D DD^%DT S APCL3YR=Y
S Y=DT D DD^%DT S APCLDT=Y
S APCLJOB=$J,APCLBTH=$H,(DFN,APCLGRAN)=0
D XTMP^APCLOSUT("APCLW2","PCC OBESITY/PREVALANCE REPORT")
PROC ;
F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19)
.I APCLSEAT="" Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.I APCLSEAT]"" Q:'$D(^DIBT(APCLSEAT,1,DFN)) ;quit if not in Search Template
.S Y=DFN D ^AUPNPAT
.Q:AUPNSEX=""
.Q:AUPNSEX="U"
.Q:APCLSEX'="B"&(APCLSEX'=AUPNSEX) ;quit if want only one sex and this patient isn't that sex
.Q:AUPNDOB=""
.S APCLAGE=(AUPNDAYS\365.25)
.;I $D(APCLAGER),APCLAGE<$P(APCLAGER,"-") Q
.S APCLCLAS=$$BEN^AUPNPAT(DFN,"C")
.Q:APCLCLAS=""
.Q:APCLIBEN=1&(APCLCLAS'="01")
.;I $D(APCLAGER),APCLAGE>$P(APCLAGER,"-",2) Q
.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
.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
.I $D(APCLAGER),APCLAGE<$P(APCLAGER,"-") Q
.I $D(APCLAGER),APCLAGE>$P(APCLAGER,"-",2) Q
.D CALCBMI
.I $G(APCLBMIR)]"" Q:APCLBMI<$P(APCLBMIR,"-") Q:APCLBMI>$P(APCLBMIR,"-",2)
.I APCLRTYP'="S" D SRT
.I APCLRTYP="S" S (APCLOVR,APCLOBE)="N"
.;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,5) S APCLOBE="Y",APCLOVR="N" G 1
.I APCLBMI'<$P(^APCLBMI(APCLREF,0),U,4) S APCLOVR="Y",APCLOBE="N"
1 .I APCLBMI>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI<$P(^APCLBMI(APCLREF,0),U,6)) D:APCLRPT="E" SET Q
.Q:APCLRPT="E"
.I APCLRPT="V",APCLOVR="N" Q
.I APCLRPT="V",APCLOBE="Y" Q
.I APCLRPT="B",APCLOBE="N" Q
.I APCLRPT="C",APCLOBE="N",APCLOVR="N" Q
.D SET
.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
SRT ;
S APCLNAME=$P(^DPT(DFN,0),U)
S APCLHRN=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"NONE")
S APCLSRT=""
D @APCLSORT
S (APCLOVR,APCLOBE)="N"
Q
B ;
S APCLSRT=APCLBMI
Q
P ;
S APCLSRT=APCLNAME
Q
A ;
S APCLSRT=APCLAGE
Q
SET ;set for each age
I APCLRTYP="S" S ^DIBT(APCLSTMP,1,DFN)="",APCLGRAN=APCLGRAN+1 Q
S ^XTMP("APCLW2",APCLJOB,APCLBTH,"PATS",APCLSRT,DFN)=APCLNAME_U_APCLHRN_U_$P(APCLCHT,U)_U_$P(APCLCWT,U)_U_$P(APCLCWT,U,2)_U_APCLAGE_U_AUPNSEX_U_APCLBMI_U_APCLOVR_U_APCLOBE
S APCLGRAN=APCLGRAN+1
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)
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^AUPNVUTL(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^AUPNVUTL(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
APCLW21 ; IHS/CMI/LAB - CALC WEIGHT REPORT ;
+1 ;;2.0;IHS PCC SUITE;**8,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=DT
SET X2=-365
DO C^%DTC
SET Y=X
DO DD^%DT
SET APCL1YR=Y
+3 SET X1=DT
SET X2=-1095
DO C^%DTC
SET Y=X
DO DD^%DT
SET APCL3YR=Y
+4 SET Y=DT
DO DD^%DT
SET APCLDT=Y
+5 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
SET (DFN,APCLGRAN)=0
+6 DO XTMP^APCLOSUT("APCLW2","PCC OBESITY/PREVALANCE REPORT")
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 IF APCLSEAT=""
IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+5 ;quit if not in Search Template
IF APCLSEAT]""
IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+6 SET Y=DFN
DO ^AUPNPAT
+7 IF AUPNSEX=""
QUIT
+8 IF AUPNSEX="U"
QUIT
+9 ;quit if want only one sex and this patient isn't that sex
IF APCLSEX'="B"&(APCLSEX'=AUPNSEX)
QUIT
+10 IF AUPNDOB=""
QUIT
+11 SET APCLAGE=(AUPNDAYS\365.25)
+12 ;I $D(APCLAGER),APCLAGE<$P(APCLAGER,"-") Q
+13 SET APCLCLAS=$$BEN^AUPNPAT(DFN,"C")
+14 IF APCLCLAS=""
QUIT
+15 IF APCLIBEN=1&(APCLCLAS'="01")
QUIT
+16 ;I $D(APCLAGER),APCLAGE>$P(APCLAGER,"-",2) Q
+17 SET APCLHBD=$SELECT(APCLAGE>19:$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(^DPT(DFN,0),U,3),(19*365))),1:APCL1YR)
+18 SET APCLBD=$SELECT(APCLAGE>19:APCL3YR,1:APCL1YR)
DO GETWTHT
+19 ;quit if no weights
IF '$DATA(APCLGWT)
QUIT
+20 ;quit if no heights
IF '$DATA(APCLGHT)
QUIT
+21 KILL APCLCWT,APCLCHT
+22 IF APCLAGE>19
DO GETRECNT
+23 IF APCLAGE<20
DO GETWHSD
+24 IF '$DATA(APCLCWT)
QUIT
+25 IF '$DATA(APCLCHT)
QUIT
+26 ;recalculate age based on date of weight
SET X2=AUPNDOB
SET X1=$PIECE(APCLCWT,U,2)
DO ^%DTC
SET APCLAGE=(X\365.25)
+27 IF $DATA(APCLAGER)
IF APCLAGE<$PIECE(APCLAGER,"-")
QUIT
+28 IF $DATA(APCLAGER)
IF APCLAGE>$PIECE(APCLAGER,"-",2)
QUIT
+29 DO CALCBMI
+30 IF $GET(APCLBMIR)]""
IF APCLBMI<$PIECE(APCLBMIR,"-")
QUIT
IF APCLBMI>$PIECE(APCLBMIR,"-",2)
QUIT
+31 IF APCLRTYP'="S"
DO SRT
+32 IF APCLRTYP="S"
SET (APCLOVR,APCLOBE)="N"
+33 ;find entry in reference table
+34 ;S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLAGE)) Q:APCLREF="" S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,"")) Q:APCLREF=""
+35 SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLAGE,0))
+36 IF 'APCLREF
SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLAGE))
IF APCLREF
SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLREF,""))
+37 IF 'APCLREF
QUIT
+38 IF APCLBMI'<$PIECE(^APCLBMI(APCLREF,0),U,5)
SET APCLOBE="Y"
SET APCLOVR="N"
GOTO 1
+39 IF APCLBMI'<$PIECE(^APCLBMI(APCLREF,0),U,4)
SET APCLOVR="Y"
SET APCLOBE="N"
1 IF APCLBMI>$PIECE(^APCLBMI(APCLREF,0),U,7)!(APCLBMI<$PIECE(^APCLBMI(APCLREF,0),U,6))
IF APCLRPT="E"
DO SET
QUIT
+1 IF APCLRPT="E"
QUIT
+2 IF APCLRPT="V"
IF APCLOVR="N"
QUIT
+3 IF APCLRPT="V"
IF APCLOBE="Y"
QUIT
+4 IF APCLRPT="B"
IF APCLOBE="N"
QUIT
+5 IF APCLRPT="C"
IF APCLOBE="N"
IF APCLOVR="N"
QUIT
+6 DO SET
+7 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
SRT ;
+1 SET APCLNAME=$PIECE(^DPT(DFN,0),U)
+2 SET APCLHRN=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"NONE")
+3 SET APCLSRT=""
+4 DO @APCLSORT
+5 SET (APCLOVR,APCLOBE)="N"
+6 QUIT
B ;
+1 SET APCLSRT=APCLBMI
+2 QUIT
P ;
+1 SET APCLSRT=APCLNAME
+2 QUIT
A ;
+1 SET APCLSRT=APCLAGE
+2 QUIT
SET ;set for each age
+1 IF APCLRTYP="S"
SET ^DIBT(APCLSTMP,1,DFN)=""
SET APCLGRAN=APCLGRAN+1
QUIT
+2 SET ^XTMP("APCLW2",APCLJOB,APCLBTH,"PATS",APCLSRT,DFN)=APCLNAME_U_APCLHRN_U_$PIECE(APCLCHT,U)_U_$PIECE(APCLCWT,U)_U_$PIECE(APCLCWT,U,2)_U_APCLAGE_U_AUPNSEX_U_APCLBMI_U_APCLOVR_U_APCLOBE
+3 SET APCLGRAN=APCLGRAN+1
+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 SET X=0
FOR
SET X=$ORDER(APCLGWT(X))
IF X'=+X
QUIT
IF '$PIECE(APCLGWT(X),U,2)
KILL APCLGWT(X)
+4 SET APCLY="APCLGHT("
SET APCLX=DFN_"^ALL MEASUREMENT HT;DURING "_APCLHBD_"-"_APCLDT
SET APCLER=$$START1^APCLDF(APCLX,APCLY)
+5 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^AUPNVUTL(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^AUPNVUTL(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
