APCLW11.m

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