Routine: APCLW61

APCLW61 ; IHS/CMI/LAB - CALC WEIGHT REPORT ;

 ;;2.0;IHS PCC SUITE;**4,10,11**;MAY 14, 2009;Build 58

 ;cmi/anch/maw 9/12/2007 code set versioning PREGDX

START ;EP

 ;calculate 365 days ago and 1095 days ago

 S APCLJ=$J,APCLH=$H

 S APCLGRAN=0

 D XTMP^APCLOSUT("APCLW6","PCC BMI REPORT")

PROC ;

 S DFN=0 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))

 .I APCLTYPE="P" Q:'$$AGEAP(DFN,APCLBD,APCLED,APCLLOWA,APCLHGHA,APCLBEG)

 .S APCLAGE=$$AGE^AUPNPAT(DFN,$S($G(APCLBEG)="":APCLBD,APCLBEG="B":APCLBD,1:APCLED))

 .I APCLTYPE="P" Q:APCLAGE<APCLLOWA  Q:APCLAGE>APCLHGHA

 .S Y=DFN D ^AUPNPAT

 .Q:AUPNSEX=""

 .Q:AUPNSEX="U"

 .Q:APCLSEX'="B"&(APCLSEX'=AUPNSEX)

 .D GETBMI1

 .I APCLBMI1="" Q  ;no beginning BMI

 .I APCLOB1="" Q  ;no beginning ob/ow

 .D GETBMI2

 .K ^TMP($J,"A")

 .I APCLBMI2="" Q  ;no ending BMI

 .I APCLOB2="" Q  ;no ending ob/ow value

 .I APCLOB1=APCLOB2 Q  ;same beg and end

 .S APCLMOVE=""

 .I APCLOB1<APCLOB2 S APCLMOVE="UP"

 .I APCLOB1>APCLOB2 S APCLMOVE="DOWN"

 .S ^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,$P(^DPT(DFN,0),U),DFN)=APCLWT1_U_APCLHT1_U_APCLBMI1_U_APCLOB1_U_APCLWT2_U_APCLHT2_U_APCLBMI2_U_APCLOB2

 .S APCLGRAN=APCLGRAN+1

.Q

GETBMI1 ;

 ;TABLE ALL VISITS CHRONOLOGICALLY FROM BEGINNING DATE

 S APCLBMI1="",APCLOB1=""

 K ^TMP($J,"A")

 S A="^TMP($J,""A"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q

 S (APCLX,G)=0 F  S APCLX=$O(^TMP($J,"A",APCLX)) Q:APCLX'=+APCLX!(APCLBMI1]"")  S APCLV=$P(^TMP($J,"A",APCLX),U,5) D

 .Q:'$D(^AUPNVSIT(APCLV,0))

 .Q:'$P(^AUPNVSIT(APCLV,0),U,9)

 .Q:$P(^AUPNVSIT(APCLV,0),U,11)

 .Q:$$PREGDX(APCLV)  ;quit if pregnant on this visit

 .S APCLWT1=$$WT(APCLV)

 .Q:$P(APCLWT1,U)=""  ;no weight on this visit

 .;got a weight so get a height

 .S APCLHT1=$$HT(DFN,APCLV,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")),$P(APCLWT1,U,2))

 .Q:$P(APCLHT1,U)=""

 .Q:$P(APCLHT1,U)="?"

 .S APCLCHT=$P(APCLHT1,U),APCLCWT=$P(APCLWT1,U) D CALCBMI

 .S APCLBMI1=APCLBMI

 .S APCLOB1=""

 .;find entry in reference table

 .S APCLREF=$O(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")),0))

 .I 'APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")))) I APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,""))

 .Q:'APCLREF

 .;I APCLBMI1>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI1<$P(^APCLBMI(APCLREF,0),U,6)) S APCLOB1="" Q

 .I APCLBMI1'<$P(^APCLBMI(APCLREF,0),U,4),APCLBMI1<$P(^APCLBMI(APCLREF,0),U,5) S APCLOB1=2 Q

 .I APCLBMI1'<$P(^APCLBMI(APCLREF,0),U,5) S APCLOB1=3 Q

 .S APCLOB1=1

.Q

GETBMI2 ;

 ;TABLE ALL VISITS CHRONOLOGICALLY FROM BEGINNING DATE

 S APCLBMI2="",APCLOB2=""

 ;K ^TMP($J,"A")

 ;S A="^TMP($J,""A"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),E=$$START1^APCLDF(B,A)

 ;I '$D(^TMP($J,"A",1)) Q

 S G=0,APCLX="A" F  S APCLX=$O(^TMP($J,"A",APCLX),-1) Q:APCLX'=+APCLX!(APCLBMI2]"")  S APCLV=$P(^TMP($J,"A",APCLX),U,5) D

 .Q:'$D(^AUPNVSIT(APCLV,0))

 .Q:'$P(^AUPNVSIT(APCLV,0),U,9)

 .Q:$P(^AUPNVSIT(APCLV,0),U,11)

 .Q:$$PREGDX(APCLV)  ;quit if pregnant on this visit

 .S APCLWT2=$$WT(APCLV)

 .Q:$P(APCLWT2,U)=""  ;no weight on this visit

 .;got a weight so get a height

 .S APCLHT2=$$HT(DFN,APCLV,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")),$P(APCLWT2,U,2))

 .Q:$P(APCLHT2,U)=""

 .Q:$P(APCLHT2,U)="?"

 .S APCLCHT=$P(APCLHT2,U),APCLCWT=$P(APCLWT2,U) D CALCBMI

 .S APCLBMI2=APCLBMI

 .S APCLOB2=""

 .;find entry in reference table

 .S APCLREF=$O(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")),0))

 .I 'APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(APCLV,0),U),".")))) I APCLREF S APCLREF=$O(^APCLBMI("H",AUPNSEX,APCLREF,""))

 .Q:'APCLREF

 .;I APCLBMI2>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI2<$P(^APCLBMI(APCLREF,0),U,6)) S APCLOB2="" Q

 .I APCLBMI2'<$P(^APCLBMI(APCLREF,0),U,4),APCLBMI2<$P(^APCLBMI(APCLREF,0),U,5) S APCLOB2=2 Q

 .I APCLBMI2'<$P(^APCLBMI(APCLREF,0),U,5) S APCLOB2=3 Q

 .S APCLOB2=1

.Q

WT(V) ;return wt on this visit

 NEW X,M,W

 S W="",D=""

 S M=$O(^AUTTMSR("B","WT",0))

 S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  I '$P($G(^AUPNVMSR(X,2)),U,1) S Z=$P(^AUPNVMSR(X,0),U) I Z=M S W=$P(^AUPNVMSR(X,0),U,4),D=$P($P(^AUPNVSIT(V,0),U),".")

 Q W_U_D

HT(P,V,AGE,DATE) ;return wt on this visit

 NEW X,M,W,APCLY,APCLX,BD,ED

 S W="",D=""

 S M=$O(^AUTTMSR("B","HT",0))

 I AGE<19 D  Q W_U_D

 .S W=""

 .;call data fetcher to get ht on DATE-DATE

 .K APCLG S (W,D)=""

 .S APCLY="APCLG(",APCLX=P_"^LAST MEASUREMENT HT;DURING "_DATE_"-"_DATE S APCLER=$$START1^APCLDF(APCLX,APCLY)

 .I $D(APCLG(1)) S W=$P(APCLG(1),U,2),D=$P(APCLG(1),U)

.Q

 K APCLG S (W,D)=""

 I AGE>18,AGE<50 D  Q W_U_D

 .S BD=$$FMADD^XLFDT(DATE,-(3*365))

 .S ED=DATE

 .S APCLY="APCLG(",APCLX=P_"^LAST MEASUREMENT HT;DURING "_BD_"-"_ED S APCLER=$$START1^APCLDF(APCLX,APCLY)

 .I $D(APCLG(1)) S W=$P(APCLG(1),U,2),D=$P(APCLG(1),U)

.Q

 K APCLG S (W,D)=""

 S BD=$$FMADD^XLFDT(DATE,-365)

 S ED=DATE

 S APCLY="APCLG(",APCLX=P_"^LAST MEASUREMENT HT;DURING "_BD_"-"_ED S APCLER=$$START1^APCLDF(APCLX,APCLY)

 I $D(APCLG(1)) S W=$P(APCLG(1),U,2),D=$P(APCLG(1),U)

 Q W_U_D

PREGDX(V) ;

 NEW P,D,G

 S G=0

 S P=0 F  S P=$O(^AUPNVPOV("AD",V,P)) Q:P'=+P!(G)  S D=$P(^AUPNVPOV(P,0),U) D  ;cmi/anch/maw 9/12/2007 csv

 .I $$ICD^AUPNVUTL(D,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) S G=1

.Q

Q G

CALCBMI ;calculate BMI value

 S APCLMWT=APCLCWT*.45359,APCLMHT=APCLCHT*.0254,APCLBMI=APCLMWT/(APCLMHT*APCLMHT)

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

AGEAP(P,BD,ED,LOW,HIGH,TP) ;

 I '$G(P) Q ""

 S A=$$AGE^AUPNPAT(P,$S(TP="B":BD,1:ED))

 I A<LOW Q 0

 I A>HIGH Q 0

Q 1

APCLW61   ; IHS/CMI/LAB - CALC WEIGHT REPORT ;

 +1       ;;2.0;IHS PCC SUITE;**4,10,11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;cmi/anch/maw 9/12/2007 code set versioning PREGDX

 +4       ;

START     ;EP

 +1       ;calculate 365 days ago and 1095 days ago

 +2        SET APCLJ=$JOB

           SET APCLH=$HOROLOG

 +3        SET APCLGRAN=0

 +4        DO XTMP^APCLOSUT("APCLW6","PCC BMI REPORT")

 +5       ;

PROC      ;

 +1        SET DFN=0

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                IF APCLSEAT]""

                       IF '$DATA(^DIBT(APCLSEAT,1,DFN))

                           QUIT

 +6                IF APCLTYPE="P"

                       IF '$$AGEAP(DFN,APCLBD,APCLED,APCLLOWA,APCLHGHA,APCLBEG)

                           QUIT

 +7                SET APCLAGE=$$AGE^AUPNPAT(DFN,$SELECT($GET(APCLBEG)="":APCLBD,APCLBEG="B":APCLBD,1:APCLED))

 +8                IF APCLTYPE="P"

                       IF APCLAGE<APCLLOWA

                           QUIT

                       IF APCLAGE>APCLHGHA

                           QUIT

 +9                SET Y=DFN

                   DO ^AUPNPAT

 +10               IF AUPNSEX=""

                       QUIT

 +11               IF AUPNSEX="U"

                       QUIT

 +12               IF APCLSEX'="B"&(APCLSEX'=AUPNSEX)

                       QUIT

 +13               DO GETBMI1

 +14      ;no beginning BMI

                   IF APCLBMI1=""

                       QUIT

 +15      ;no beginning ob/ow

                   IF APCLOB1=""

                       QUIT

 +16               DO GETBMI2

 +17               KILL ^TMP($JOB,"A")

 +18      ;no ending BMI

                   IF APCLBMI2=""

                       QUIT

 +19      ;no ending ob/ow value

                   IF APCLOB2=""

                       QUIT

 +20      ;same beg and end

                   IF APCLOB1=APCLOB2

                       QUIT

 +21               SET APCLMOVE=""

 +22               IF APCLOB1<APCLOB2

                       SET APCLMOVE="UP"

 +23               IF APCLOB1>APCLOB2

                       SET APCLMOVE="DOWN"

 +24               SET ^XTMP("APCLW6",APCLJ,APCLH,"PATIENTS",APCLMOVE,APCLAGE,$PIECE(^DPT(DFN,0),U),DFN)=APCLWT1_U_APCLHT1_U_APCLBMI1_U_APCLOB1_U_APCLWT2_U_APCLHT2_U_APCLBMI2_U_APCLOB2

 +25               SET APCLGRAN=APCLGRAN+1

 +26               QUIT

               End DoDot:1

 +27       QUIT

GETBMI1   ;

 +1       ;TABLE ALL VISITS CHRONOLOGICALLY FROM BEGINNING DATE

 +2        SET APCLBMI1=""

           SET APCLOB1=""

 +3        KILL ^TMP($JOB,"A")

 +4        SET A="^TMP($J,""A"","

           SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED)

           SET E=$$START1^APCLDF(B,A)

 +5        IF '$DATA(^TMP($JOB,"A",1))

               QUIT

 +6        SET (APCLX,G)=0

FOR

               SET APCLX=$ORDER(^TMP($JOB,"A",APCLX))

               IF APCLX'=+APCLX!(APCLBMI1]"")

                   QUIT

               SET APCLV=$PIECE(^TMP($JOB,"A",APCLX),U,5)

               Begin DoDot:1

 +7                IF '$DATA(^AUPNVSIT(APCLV,0))

                       QUIT

 +8                IF '$PIECE(^AUPNVSIT(APCLV,0),U,9)

                       QUIT

 +9                IF $PIECE(^AUPNVSIT(APCLV,0),U,11)

                       QUIT

 +10      ;quit if pregnant on this visit

                   IF $$PREGDX(APCLV)

                       QUIT

 +11               SET APCLWT1=$$WT(APCLV)

 +12      ;no weight on this visit

                   IF $PIECE(APCLWT1,U)=""

                       QUIT

 +13      ;got a weight so get a height

 +14               SET APCLHT1=$$HT(DFN,APCLV,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")),$PIECE(APCLWT1,U,2))

 +15               IF $PIECE(APCLHT1,U)=""

                       QUIT

 +16               IF $PIECE(APCLHT1,U)="?"

                       QUIT

 +17               SET APCLCHT=$PIECE(APCLHT1,U)

                   SET APCLCWT=$PIECE(APCLWT1,U)

                   DO CALCBMI

 +18               SET APCLBMI1=APCLBMI

 +19               SET APCLOB1=""

 +20      ;find entry in reference table

 +21               SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")),0))

 +22               IF 'APCLREF

                       SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),"."))))

                       IF APCLREF

                           SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLREF,""))

 +23               IF 'APCLREF

                       QUIT

 +24      ;I APCLBMI1>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI1<$P(^APCLBMI(APCLREF,0),U,6)) S APCLOB1="" Q

 +25               IF APCLBMI1'<$PIECE(^APCLBMI(APCLREF,0),U,4)

                       IF APCLBMI1<$PIECE(^APCLBMI(APCLREF,0),U,5)

                           SET APCLOB1=2

                           QUIT

 +26               IF APCLBMI1'<$PIECE(^APCLBMI(APCLREF,0),U,5)

                       SET APCLOB1=3

                       QUIT

 +27               SET APCLOB1=1

 +28               QUIT

               End DoDot:1

 +29       QUIT

GETBMI2   ;

 +1       ;TABLE ALL VISITS CHRONOLOGICALLY FROM BEGINNING DATE

 +2        SET APCLBMI2=""

           SET APCLOB2=""

 +3       ;K ^TMP($J,"A")

 +4       ;S A="^TMP($J,""A"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),E=$$START1^APCLDF(B,A)

 +5       ;I '$D(^TMP($J,"A",1)) Q

 +6        SET G=0

           SET APCLX="A"

FOR

               SET APCLX=$ORDER(^TMP($JOB,"A",APCLX),-1)

               IF APCLX'=+APCLX!(APCLBMI2]"")

                   QUIT

               SET APCLV=$PIECE(^TMP($JOB,"A",APCLX),U,5)

               Begin DoDot:1

 +7                IF '$DATA(^AUPNVSIT(APCLV,0))

                       QUIT

 +8                IF '$PIECE(^AUPNVSIT(APCLV,0),U,9)

                       QUIT

 +9                IF $PIECE(^AUPNVSIT(APCLV,0),U,11)

                       QUIT

 +10      ;quit if pregnant on this visit

                   IF $$PREGDX(APCLV)

                       QUIT

 +11               SET APCLWT2=$$WT(APCLV)

 +12      ;no weight on this visit

                   IF $PIECE(APCLWT2,U)=""

                       QUIT

 +13      ;got a weight so get a height

 +14               SET APCLHT2=$$HT(DFN,APCLV,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")),$PIECE(APCLWT2,U,2))

 +15               IF $PIECE(APCLHT2,U)=""

                       QUIT

 +16               IF $PIECE(APCLHT2,U)="?"

                       QUIT

 +17               SET APCLCHT=$PIECE(APCLHT2,U)

                   SET APCLCWT=$PIECE(APCLWT2,U)

                   DO CALCBMI

 +18               SET APCLBMI2=APCLBMI

 +19               SET APCLOB2=""

 +20      ;find entry in reference table

 +21               SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")),0))

 +22               IF 'APCLREF

                       SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,$$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),"."))))

                       IF APCLREF

                           SET APCLREF=$ORDER(^APCLBMI("H",AUPNSEX,APCLREF,""))

 +23               IF 'APCLREF

                       QUIT

 +24      ;I APCLBMI2>$P(^APCLBMI(APCLREF,0),U,7)!(APCLBMI2<$P(^APCLBMI(APCLREF,0),U,6)) S APCLOB2="" Q

 +25               IF APCLBMI2'<$PIECE(^APCLBMI(APCLREF,0),U,4)

                       IF APCLBMI2<$PIECE(^APCLBMI(APCLREF,0),U,5)

                           SET APCLOB2=2

                           QUIT

 +26               IF APCLBMI2'<$PIECE(^APCLBMI(APCLREF,0),U,5)

                       SET APCLOB2=3

                       QUIT

 +27               SET APCLOB2=1

 +28               QUIT

               End DoDot:1

 +29       QUIT

WT(V)     ;return wt on this visit

 +1        NEW X,M,W

 +2        SET W=""

           SET D=""

 +3        SET M=$ORDER(^AUTTMSR("B","WT",0))

 +4        SET X=0

FOR

               SET X=$ORDER(^AUPNVMSR("AD",V,X))

               IF X'=+X

                   QUIT

               IF '$PIECE($GET(^AUPNVMSR(X,2)),U,1)

                   SET Z=$PIECE(^AUPNVMSR(X,0),U)

                   IF Z=M

                       SET W=$PIECE(^AUPNVMSR(X,0),U,4)

                       SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")

 +5        QUIT W_U_D

HT(P,V,AGE,DATE) ;return wt on this visit

 +1        NEW X,M,W,APCLY,APCLX,BD,ED

 +2        SET W=""

           SET D=""

 +3        SET M=$ORDER(^AUTTMSR("B","HT",0))

 +4        IF AGE<19

               Begin DoDot:1

 +5                SET W=""

 +6       ;call data fetcher to get ht on DATE-DATE

 +7                KILL APCLG

                   SET (W,D)=""

 +8                SET APCLY="APCLG("

                   SET APCLX=P_"^LAST MEASUREMENT HT;DURING "_DATE_"-"_DATE

                   SET APCLER=$$START1^APCLDF(APCLX,APCLY)

 +9                IF $DATA(APCLG(1))

                       SET W=$PIECE(APCLG(1),U,2)

                       SET D=$PIECE(APCLG(1),U)

 +10               QUIT

               End DoDot:1

               QUIT W_U_D

 +11       KILL APCLG

           SET (W,D)=""

 +12       IF AGE>18

               IF AGE<50

                   Begin DoDot:1

 +13                   SET BD=$$FMADD^XLFDT(DATE,-(3*365))

 +14                   SET ED=DATE

 +15                   SET APCLY="APCLG("

                       SET APCLX=P_"^LAST MEASUREMENT HT;DURING "_BD_"-"_ED

                       SET APCLER=$$START1^APCLDF(APCLX,APCLY)

 +16                   IF $DATA(APCLG(1))

                           SET W=$PIECE(APCLG(1),U,2)

                           SET D=$PIECE(APCLG(1),U)

 +17                   QUIT

                   End DoDot:1

                   QUIT W_U_D

 +18       KILL APCLG

           SET (W,D)=""

 +19       SET BD=$$FMADD^XLFDT(DATE,-365)

 +20       SET ED=DATE

 +21       SET APCLY="APCLG("

           SET APCLX=P_"^LAST MEASUREMENT HT;DURING "_BD_"-"_ED

           SET APCLER=$$START1^APCLDF(APCLX,APCLY)

 +22       IF $DATA(APCLG(1))

               SET W=$PIECE(APCLG(1),U,2)

               SET D=$PIECE(APCLG(1),U)

 +23       QUIT W_U_D

PREGDX(V) ;

 +1        NEW P,D,G

 +2        SET G=0

 +3       ;cmi/anch/maw 9/12/2007 csv

           SET P=0

FOR

               SET P=$ORDER(^AUPNVPOV("AD",V,P))

               IF P'=+P!(G)

                   QUIT

               SET D=$PIECE(^AUPNVPOV(P,0),U)

               Begin DoDot:1

 +4                IF $$ICD^AUPNVUTL(D,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)

                       SET G=1

 +5                QUIT

               End DoDot:1

 +6        QUIT G

CALCBMI   ;calculate BMI value

 +1        SET APCLMWT=APCLCWT*.45359

           SET APCLMHT=APCLCHT*.0254

           SET APCLBMI=APCLMWT/(APCLMHT*APCLMHT)

 +2        QUIT

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

AGEAP(P,BD,ED,LOW,HIGH,TP) ;

 +1        IF '$GET(P)

               QUIT ""

 +2        SET A=$$AGE^AUPNPAT(P,$SELECT(TP="B":BD,1:ED))

 +3        IF A<LOW

               QUIT 0

 +4        IF A>HIGH

               QUIT 0

 +5        QUIT 1

APCLW61.m