APCLW21.m

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