APCDBMI ; IHS/CMI/LAB -BMI ;
;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
BMICALC(APCDX) ;EP - called from input templates to calculate and store BMI
I '$G(APCDX) Q
D EN^XBNEW("CALCBMI1^APCDBMI","APCDX")
K APCDX
Q
CALCBMI1 ;
;NEW A,B,C,D,E,P,V,VD,W,H,BMI,HD,ERR,APCLFDA,BIEN,X,Y,DA
S A=$$GET1^DIQ(9000010.01,APCDX,.01)
I A'="HT",A'="WT" Q ;only ht/wt
I A="WT" D CALCBMIW Q
I A="HT" D CALCBMIH Q
Q
CALCBMIW ;
S BMI=""
;weight was just entered so calculate and store a bmi and bmip
S W=$$GET1^DIQ(9000010.01,APCDX,.04) ;wt value is in W
Q:W=""
S DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I") ;patient dfn
Q:DFN=""
S V=$$GET1^DIQ(9000010.01,APCDX,.03,"I") ;visit ien is in V
Q:V=""
S VD=$$VD^APCLV(V) ;visit date
S AGE=$$AGE^AUPNPAT(DFN,VD) ;age of patient on visit date
S H=$$LASTHT(DFN,VD) ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
I H="" Q ;no ht so don't calculate anything
S HD=$P(H,U,2)
S H=$P(H,U)
;calc bmi
S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
;
I $$HASVM(V,"BMI",BMI) G BMIP ;already has this bmi value on this visit so don't store it again, go do BMIP
D STORE(V,DFN,"BMI",BMI,APCDX,HD)
;NOW STORE BMIP
D BMIP
Q
STORE(V,DFN,TYPE,VALUE,APCDX,HD) ;
;store BMI as v meas
K APCDALVR
S APCDALVR("APCDVSIT")=V
S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
S APCDALVR("APCDTTYP")="`"_$O(^AUTTMSR("B",TYPE,0))
S APCDALVR("APCDPAT")=DFN
S APCDALVR("APCDTVAL")=VALUE
S APCDALVR("APCDTEPR")="`"_DUZ
S APCDALVR("APCDTCDT")=$$GET1^DIQ(9000010.01,APCDX,1201)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) D EN^DDIOL("UNABLE TO STORE "_TYPE_" VALUE OF "_VALUE_" HT DATE "_$$FMTE^XLFDT(HD))
Q
CALCBMIH ;
;ht added, calculate bmi for this date and forward till find another ht
;first delete all bmis and bmips from this date/time forward
;table all visits from this date/time forward that have a WT or BMI or BMIP
;Quit when another HT is found
S BMI=""
;HEIGHT was just entered so RE-calculate and store a bmi and bmip FROM THIS VISIT
;FORWARD UNTIL WE FIND ANOTHER HT
S HT=$$GET1^DIQ(9000010.01,APCDX,.04) ;wt value is in B
Q:HT=""
S DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I") ;patient dfn is in P
Q:DFN=""
S V=$$GET1^DIQ(9000010.01,APCDX,.03,"I") ;visit ien is in V
Q:V=""
S HD=$$VD^APCLV(V)
S AGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(V))
K APCDVAR
I AGE>18,AGE<50 S E=$$FMADD^XLFDT($$VD^APCLV(V),(5*365))
I AGE>49 S E=$$FMADD^XLFDT($$VD^APCLV(V),(2*365))
I AGE<19 S E=$$VD^APCLV(V)
D ALLV^APCLAPIU(DFN,$$VD^APCLV(V),E,"APCDVAR")
;REORDER BY DATE LOWEST TO HIGHEST
S APCDSTOP=""
S X=0 F S X=$O(APCDVAR(X)) Q:X'=+X D
.S N=$P(APCDVAR(X),U,5)
.S APCDVAR("LH",$$VDTM^APCLV(N),X)=APCDVAR(X)
S D=0 F S D=$O(APCDVAR("LH",D)) Q:D'=+D D
.S X=0 F S X=$O(APCDVAR("LH",D,X)) Q:X'=+X D
..S N=$P(APCDVAR("LH",D,X),U,5)
..I $$VDTM^APCLV(N)<$$VDTM^APCLV(V) K APCDVAR("LH",D,X) ;BEFORE MY VISIT, DON'T DEAL WITH IT
..I '$$HASAVM(N,"WT") K APCDVAR("LH",D,X) ;no wts so don't bother, can't calculate bmi
..I $$HASAVM(N,"HT"),N'=V S A=D,B=X D ;KILL OFF ALL REMAINING
...F S A=$O(APCDVAR("LH",A)) Q:A'=+A F S B=$O(APCDVAR("LH",A,B)) Q:B'=+B K APCDVAR("LH",A,B)
;now calculate bmi on this array of visits
S D=0 F S D=$O(APCDVAR("LH",D)) Q:D="" D
.S X=0 F S X=$O(APCDVAR("LH",D,X)) Q:X="" D
..S N=$P(APCDVAR(X),U,5) ;visit ien
..S APCDAGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(N))
..;delete all bmis and bmips
..F S APCDZ=$$HASVM(N,"BMI",BMI) Q:'APCDZ D FILEEIE(APCDZ)
..F S APCDZ=$$HASVM(N,"BMIP",BMI) Q:'APCDZ D FILEEIE(APCDZ)
..;NOW ADD NEW BMI/BMIP
..S APCDA=0 F S APCDA=$O(^AUPNVMSR("AD",N,APCDA)) Q:APCDA'=+APCDA D
...Q:$P($G(^AUPNVMSR(APCDA,2)),U,1)
...Q:$$VAL^XBDIQ1(9000010.01,APCDA,.01)'="WT"
...S W=$$VAL^XBDIQ1(9000010.01,APCDA,.04)
...S H=$$LASTHT(DFN,$$VD^APCLV(N)) ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
...I H="" Q ;no ht so don't calculate anything
...S HD=$P(H,U,2)
...S H=$P(H,U)
...;calc bmi
...S W=W*.45359,H=(HT*.0254),H=(H*H),BMI=(W/H)
...I '$$HASVM(V,"BMI",BMI) D STORE(N,DFN,"BMI",BMI,APCDX,HD)
...Q:$T(BMIPCT^BEHOVM2)="" ;no routine to calculate
...Q:APCDAGE<2
...Q:APCDAGE>18
...S BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,$$VD^APCLV(N))
...I BMIPCT'>0 Q
...;store bmip
...I $$HASVM(N,"BMIP",BMIPCT) Q ;already has this bmiP value on this visit so don't store it again, Q
...;store BMIP as v meas
...D STORE(N,DFN,"BMIP",BMIPCT,APCDX,HD)
Q
LASTHT(P,VD) ;get last allowable ht for patient's age to calculate BMI
I '$G(P) Q ""
I '$G(VD) Q ""
NEW A,CD,VALUE,%
S VALUE=""
S A=$$AGE^AUPNPAT(P,VD) ;age of patient on visit date
I A<2 Q VALUE
I A>18,A<50 D Q VALUE ;get last ht in past 5 years
.S CD=$$FMADD^XLFDT(VD,-(5*365)) ;5 yrs
.S %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",CD,VD,"A")
.Q:%=""
.S VALUE=$P(%,U,3)_U_$P(%,U,1) ;send back ht value^ht date
;NOW DO OVER 49
I A>49 D Q VALUE
.S CD=$$FMADD^XLFDT(VD,-(2*365))
.S %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",CD,VD,"A")
.Q:%=""
.S VALUE=$P(%,U,3)_U_$P(%,U,1) ;send back ht value^ht date
;UNDER 19 MUST BE ON SAME DATE AS WT
S %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",VD,VD,"A")
I %="" Q ""
S VALUE=$P(%,U,3)_U_$P(%,U,1) ;send back ht value^ht date
Q VALUE
;
HASVM(V,T,B) ;
NEW Y,G
S Y=0,G=0 F S Y=$O(^AUPNVMSR("AD",V,Y)) Q:Y'=+Y!(G) D
.Q:$$GET1^DIQ(9000010.01,Y,.01)'=T
.Q:$$GET1^DIQ(9000010.01,Y,.04)'=B
.Q:$P($G(^AUPNVMSR(Y,2)),U,1) ;EIE
.S G=Y
Q G
BMIP ;
Q:$T(BMIPCT^BEHOVM2)="" ;no routine to calculate
Q:AGE<2
Q:AGE>18
S BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,VD)
I BMIPCT'>0 Q
;store bmip
I $$HASVM(V,"BMIP",BMIPCT) Q ;already has this bmiP value on this visit so don't store it again, Q
;store BMIP as v meas
D STORE(V,DFN,"BMIP",BMIPCT,APCDX,HD)
Q
EIE(APCDX) ;EP - wt or ht entered in error, bmi eie
I '$G(APCDX) Q
D EN^XBNEW("EIE1^APCDBMI","APCDX")
K APCDX
Q
EIE1 ;
;NEW A,B,C,D,E,P,V,VD,W,H,BMI,HD,ERR,APCLFDA,BIEN,X,Y,DA
S A=$$GET1^DIQ(9000010.01,APCDX,.01)
I A'="HT",A'="WT" Q ;only ht/wt
I A="WT" D EIEW Q
I A="HT" D EIEH Q
Q
EIEW ;WT ENTERED IN ERROR
;if no other wts deleted all bmi, bmip on this visit
;
S V=$$GET1^DIQ(9000010.01,APCDX,.03,"I") ;visit ien is in V
Q:V=""
I '$$HASAVM(V,"WT") D Q
.;find all bmi's and bmip's and mark them EIE
.S APCDY=0 F S APCDY=$O(^AUPNVMSR("AD",V,APCDY)) Q:APCDY'=+APCDY D
..Q:$P($G(^AUPNVMSR(APCDY,2)),U,1) ;ALREADY EIE
..S T=$$GET1^DIQ(9000010.01,APCDY,.01)
..I T'="BMI",T'="BMIP" Q
..;mark as EIE
..D FILEEIE(APCDY)
;WHAT IF THERE IS ALREADY A WT SO NEED TO DELETE THE CORRECT BMI SO FIND BMI/BMIP AND DELETE
S W=$$GET1^DIQ(9000010.01,APCDX,.04) ;wt value is in B
Q:W=""
S DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I") ;patient dfn is in P
Q:DFN=""
S V=$$GET1^DIQ(9000010.01,APCDX,.03,"I") ;visit ien is in V
Q:V=""
S VD=$$VD^APCLV(V) ;visit date
S AGE=$$AGE^AUPNPAT(DFN,VD) ;age of patient on visit date
S H=$$LASTHT(DFN,VD) ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
I H="" Q ;no ht so don't calculate anything
S HD=$P(H,U,2)
S H=$P(H,U)
;calc bmi
S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
;find bmi with this value and mark as EIE
F S APCDZ=$$HASVM(V,"BMI",BMI) Q:'APCDZ D FILEEIE(APCDZ)
;now find bmip
Q:$T(BMIPCT^BEHOVM2)="" ;no routine to calculate
Q:AGE<2
Q:AGE>18
S BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,VD)
I BMIPCT'>0 Q
F S APCDZ=$$HASVM(V,"BMIP",BMIPCT) Q:'APCDZ D FILEEIE(APCDZ)
Q
EIEH ;
;IF HT ENTERED IN ERROR, DELETE ALL BMIS AND BMIPS UNTIL FIND ANOTHER HT, MARK THEM ALL EIE
S DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I") ;patient dfn is in P
Q:DFN=""
S V=$$GET1^DIQ(9000010.01,APCDX,.03,"I") ;visit ien is in V
Q:V=""
S HD=$$VD^APCLV(V)
S AGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(V))
K APCDVAR
I AGE>18,AGE<50 S E=$$FMADD^XLFDT($$VD^APCLV(V),(5*365))
I AGE>49 S E=$$FMADD^XLFDT($$VD^APCLV(V),(2*365))
I AGE<19 S E=$$VD^APCLV(V)
D ALLV^APCLAPIU(DFN,$$VD^APCLV(V),E,"APCDVAR")
;REORDER BY DATE LOWEST TO HIGHEST
S APCDSTOP=""
S X=0 F S X=$O(APCDVAR(X)) Q:X'=+X D
.S N=$P(APCDVAR(X),U,5)
.S APCDVAR("LH",$$VDTM^APCLV(N),X)=APCDVAR(X)
S D=0 F S D=$O(APCDVAR("LH",D)) Q:D'=+D D
.S X=0 F S X=$O(APCDVAR("LH",D,X)) Q:X'=+X D
..S N=$P(APCDVAR("LH",D,X),U,5)
..I $$VDTM^APCLV(N)<$$VDTM^APCLV(V) K APCDVAR("LH",D,X) ;BEFORE MY VISIT, DON'T DEAL WITH IT
..I '$$HASAVM(N,"WT") K APCDVAR("LH",D,X) ;no wts so don't bother, can't calculate bmi
..I $$HASAVM(N,"HT"),N'=V S A=D,B=X D ;KILL OFF ALL REMAINING
...F S A=$O(APCDVAR("LH",A)) Q:A'=+A F S B=$O(APCDVAR("LH",A,B)) Q:B'=+B K APCDVAR("LH",A,B)
;nowDELETE bmi/BMIP on this array of visits
S D=0 F S D=$O(APCDVAR("LH",D)) Q:D="" D
.S X=0 F S X=$O(APCDVAR("LH",D,X)) Q:X="" D
..S N=$P(APCDVAR(X),U,5) ;visit ien
..S APCDAGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(N))
..;delete all bmis and bmips
..F S APCDZ=$$HASAVM(N,"BMI") Q:'APCDZ D FILEEIE(APCDZ)
..F S APCDZ=$$HASAVM(N,"BMIP") Q:'APCDZ D FILEEIE(APCDZ)
..;NOW ADD NEW BMI/BMIP WITH HT PREVIOUS TO THE ONE DELETED, IF WE CAN
..S APCDA=0 F S APCDA=$O(^AUPNVMSR("AD",N,APCDA)) Q:APCDA'=+APCDA D
...Q:$P($G(^AUPNVMSR(APCDA,2)),U,1)
...Q:$$VAL^XBDIQ1(9000010.01,APCDA,.01)'="WT"
...S W=$$VAL^XBDIQ1(9000010.01,APCDA,.04)
...;calc bmi
...S H=$$LASTHT(DFN,$$VD^APCLV(N)) ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
...I H="" Q ;no ht so don't calculate anything
...S HD=$P(H,U,2)
...S H=$P(H,U)
...;calc bmi
...S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
...I '$$HASVM(V,"BMI",BMI) D STORE(N,DFN,"BMI",BMI,APCDA,HD)
...Q:$T(BMIPCT^BEHOVM2)="" ;no routine to calculate
...Q:APCDAGE<2
...Q:APCDAGE>18
...S BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,$$VD^APCLV(N))
...I BMIPCT'>0 Q
...;store bmip
...I $$HASVM(N,"BMIP",BMIPCT) Q ;already has this bmiP value on this visit so don't store it again, Q
...;store BMIP as v meas
...D STORE(N,DFN,"BMIP",BMIPCT,APCDA,HD)
Q
FILEEIE(APCDY) ;
I '$G(APCDY) Q
I '$D(^AUPNVMSR(APCDY)) Q
NEW APCDIENS,APCDFDA,APCDERR,DA,DIK
S APCDIENS=APCDY_","
S APCDFDA(9000010.01,APCDIENS,2)=1
S APCDFDA(9000010.01,APCDIENS,3)=DUZ
;S APCDFDA(9000010.014,"+1,"_APCDIENS,.01)=$P(BEHDATA,"^",3)
D UPDATE^DIE("","APCDFDA","APCDIEN","APCDERR")
;NOW MERGE OVER THE RESONS FROM THE OTHER ENTRY
M ^AUPNVMSR(APCDY,2.1)=^AUPNVMSR(APCDX,2.1)
;REINDEX
S DA=APCDY,DIK="^AUPNVMSR(" D IX^DIK K DA,DIK
Q
;
HASAVM(V,T) ;
NEW Y,G
S Y=0,G=0 F S Y=$O(^AUPNVMSR("AD",V,Y)) Q:Y'=+Y!(G) D
.Q:$$GET1^DIQ(9000010.01,Y,.01)'=T
.Q:$P($G(^AUPNVMSR(Y,2)),U,1) ;EIE
.S G=Y
Q G
APCDBMI ; IHS/CMI/LAB -BMI ;
+1 ;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
BMICALC(APCDX) ;EP - called from input templates to calculate and store BMI
+1 IF '$GET(APCDX)
QUIT
+2 DO EN^XBNEW("CALCBMI1^APCDBMI","APCDX")
+3 KILL APCDX
+4 QUIT
CALCBMI1 ;
+1 ;NEW A,B,C,D,E,P,V,VD,W,H,BMI,HD,ERR,APCLFDA,BIEN,X,Y,DA
+2 SET A=$$GET1^DIQ(9000010.01,APCDX,.01)
+3 ;only ht/wt
IF A'="HT"
IF A'="WT"
QUIT
+4 IF A="WT"
DO CALCBMIW
QUIT
+5 IF A="HT"
DO CALCBMIH
QUIT
+6 QUIT
CALCBMIW ;
+1 SET BMI=""
+2 ;weight was just entered so calculate and store a bmi and bmip
+3 ;wt value is in W
SET W=$$GET1^DIQ(9000010.01,APCDX,.04)
+4 IF W=""
QUIT
+5 ;patient dfn
SET DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I")
+6 IF DFN=""
QUIT
+7 ;visit ien is in V
SET V=$$GET1^DIQ(9000010.01,APCDX,.03,"I")
+8 IF V=""
QUIT
+9 ;visit date
SET VD=$$VD^APCLV(V)
+10 ;age of patient on visit date
SET AGE=$$AGE^AUPNPAT(DFN,VD)
+11 ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
SET H=$$LASTHT(DFN,VD)
+12 ;no ht so don't calculate anything
IF H=""
QUIT
+13 SET HD=$PIECE(H,U,2)
+14 SET H=$PIECE(H,U)
+15 ;calc bmi
+16 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+17 ;
+18 ;already has this bmi value on this visit so don't store it again, go do BMIP
IF $$HASVM(V,"BMI",BMI)
GOTO BMIP
+19 DO STORE(V,DFN,"BMI",BMI,APCDX,HD)
+20 ;NOW STORE BMIP
+21 DO BMIP
+22 QUIT
STORE(V,DFN,TYPE,VALUE,APCDX,HD) ;
+1 ;store BMI as v meas
+2 KILL APCDALVR
+3 SET APCDALVR("APCDVSIT")=V
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+5 SET APCDALVR("APCDTTYP")="`"_$ORDER(^AUTTMSR("B",TYPE,0))
+6 SET APCDALVR("APCDPAT")=DFN
+7 SET APCDALVR("APCDTVAL")=VALUE
+8 SET APCDALVR("APCDTEPR")="`"_DUZ
+9 SET APCDALVR("APCDTCDT")=$$GET1^DIQ(9000010.01,APCDX,1201)
+10 DO ^APCDALVR
+11 IF $DATA(APCDALVR("APCDAFLG"))
DO EN^DDIOL("UNABLE TO STORE "_TYPE_" VALUE OF "_VALUE_" HT DATE "_$$FMTE^XLFDT(HD))
+12 QUIT
CALCBMIH ;
+1 ;ht added, calculate bmi for this date and forward till find another ht
+2 ;first delete all bmis and bmips from this date/time forward
+3 ;table all visits from this date/time forward that have a WT or BMI or BMIP
+4 ;Quit when another HT is found
+5 SET BMI=""
+6 ;HEIGHT was just entered so RE-calculate and store a bmi and bmip FROM THIS VISIT
+7 ;FORWARD UNTIL WE FIND ANOTHER HT
+8 ;wt value is in B
SET HT=$$GET1^DIQ(9000010.01,APCDX,.04)
+9 IF HT=""
QUIT
+10 ;patient dfn is in P
SET DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I")
+11 IF DFN=""
QUIT
+12 ;visit ien is in V
SET V=$$GET1^DIQ(9000010.01,APCDX,.03,"I")
+13 IF V=""
QUIT
+14 SET HD=$$VD^APCLV(V)
+15 SET AGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(V))
+16 KILL APCDVAR
+17 IF AGE>18
IF AGE<50
SET E=$$FMADD^XLFDT($$VD^APCLV(V),(5*365))
+18 IF AGE>49
SET E=$$FMADD^XLFDT($$VD^APCLV(V),(2*365))
+19 IF AGE<19
SET E=$$VD^APCLV(V)
+20 DO ALLV^APCLAPIU(DFN,$$VD^APCLV(V),E,"APCDVAR")
+21 ;REORDER BY DATE LOWEST TO HIGHEST
+22 SET APCDSTOP=""
+23 SET X=0
FOR
SET X=$ORDER(APCDVAR(X))
IF X'=+X
QUIT
Begin DoDot:1
+24 SET N=$PIECE(APCDVAR(X),U,5)
+25 SET APCDVAR("LH",$$VDTM^APCLV(N),X)=APCDVAR(X)
End DoDot:1
+26 SET D=0
FOR
SET D=$ORDER(APCDVAR("LH",D))
IF D'=+D
QUIT
Begin DoDot:1
+27 SET X=0
FOR
SET X=$ORDER(APCDVAR("LH",D,X))
IF X'=+X
QUIT
Begin DoDot:2
+28 SET N=$PIECE(APCDVAR("LH",D,X),U,5)
+29 ;BEFORE MY VISIT, DON'T DEAL WITH IT
IF $$VDTM^APCLV(N)<$$VDTM^APCLV(V)
KILL APCDVAR("LH",D,X)
+30 ;no wts so don't bother, can't calculate bmi
IF '$$HASAVM(N,"WT")
KILL APCDVAR("LH",D,X)
+31 ;KILL OFF ALL REMAINING
IF $$HASAVM(N,"HT")
IF N'=V
SET A=D
SET B=X
Begin DoDot:3
+32 FOR
SET A=$ORDER(APCDVAR("LH",A))
IF A'=+A
QUIT
FOR
SET B=$ORDER(APCDVAR("LH",A,B))
IF B'=+B
QUIT
KILL APCDVAR("LH",A,B)
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;now calculate bmi on this array of visits
+34 SET D=0
FOR
SET D=$ORDER(APCDVAR("LH",D))
IF D=""
QUIT
Begin DoDot:1
+35 SET X=0
FOR
SET X=$ORDER(APCDVAR("LH",D,X))
IF X=""
QUIT
Begin DoDot:2
+36 ;visit ien
SET N=$PIECE(APCDVAR(X),U,5)
+37 SET APCDAGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(N))
+38 ;delete all bmis and bmips
+39 FOR
SET APCDZ=$$HASVM(N,"BMI",BMI)
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+40 FOR
SET APCDZ=$$HASVM(N,"BMIP",BMI)
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+41 ;NOW ADD NEW BMI/BMIP
+42 SET APCDA=0
FOR
SET APCDA=$ORDER(^AUPNVMSR("AD",N,APCDA))
IF APCDA'=+APCDA
QUIT
Begin DoDot:3
+43 IF $PIECE($GET(^AUPNVMSR(APCDA,2)),U,1)
QUIT
+44 IF $$VAL^XBDIQ1(9000010.01,APCDA,.01)'="WT"
QUIT
+45 SET W=$$VAL^XBDIQ1(9000010.01,APCDA,.04)
+46 ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
SET H=$$LASTHT(DFN,$$VD^APCLV(N))
+47 ;no ht so don't calculate anything
IF H=""
QUIT
+48 SET HD=$PIECE(H,U,2)
+49 SET H=$PIECE(H,U)
+50 ;calc bmi
+51 SET W=W*.45359
SET H=(HT*.0254)
SET H=(H*H)
SET BMI=(W/H)
+52 IF '$$HASVM(V,"BMI",BMI)
DO STORE(N,DFN,"BMI",BMI,APCDX,HD)
+53 ;no routine to calculate
IF $TEXT(BMIPCT^BEHOVM2)=""
QUIT
+54 IF APCDAGE<2
QUIT
+55 IF APCDAGE>18
QUIT
+56 SET BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,$$VD^APCLV(N))
+57 IF BMIPCT'>0
QUIT
+58 ;store bmip
+59 ;already has this bmiP value on this visit so don't store it again, Q
IF $$HASVM(N,"BMIP",BMIPCT)
QUIT
+60 ;store BMIP as v meas
+61 DO STORE(N,DFN,"BMIP",BMIPCT,APCDX,HD)
End DoDot:3
End DoDot:2
End DoDot:1
+62 QUIT
LASTHT(P,VD) ;get last allowable ht for patient's age to calculate BMI
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(VD)
QUIT ""
+3 NEW A,CD,VALUE,%
+4 SET VALUE=""
+5 ;age of patient on visit date
SET A=$$AGE^AUPNPAT(P,VD)
+6 IF A<2
QUIT VALUE
+7 ;get last ht in past 5 years
IF A>18
IF A<50
Begin DoDot:1
+8 ;5 yrs
SET CD=$$FMADD^XLFDT(VD,-(5*365))
+9 SET %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",CD,VD,"A")
+10 IF %=""
QUIT
+11 ;send back ht value^ht date
SET VALUE=$PIECE(%,U,3)_U_$PIECE(%,U,1)
End DoDot:1
QUIT VALUE
+12 ;NOW DO OVER 49
+13 IF A>49
Begin DoDot:1
+14 SET CD=$$FMADD^XLFDT(VD,-(2*365))
+15 SET %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",CD,VD,"A")
+16 IF %=""
QUIT
+17 ;send back ht value^ht date
SET VALUE=$PIECE(%,U,3)_U_$PIECE(%,U,1)
End DoDot:1
QUIT VALUE
+18 ;UNDER 19 MUST BE ON SAME DATE AS WT
+19 SET %=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",VD,VD,"A")
+20 IF %=""
QUIT ""
+21 ;send back ht value^ht date
SET VALUE=$PIECE(%,U,3)_U_$PIECE(%,U,1)
+22 QUIT VALUE
+23 ;
HASVM(V,T,B) ;
+1 NEW Y,G
+2 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVMSR("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+3 IF $$GET1^DIQ(9000010.01,Y,.01)'=T
QUIT
+4 IF $$GET1^DIQ(9000010.01,Y,.04)'=B
QUIT
+5 ;EIE
IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+6 SET G=Y
End DoDot:1
+7 QUIT G
BMIP ;
+1 ;no routine to calculate
IF $TEXT(BMIPCT^BEHOVM2)=""
QUIT
+2 IF AGE<2
QUIT
+3 IF AGE>18
QUIT
+4 SET BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,VD)
+5 IF BMIPCT'>0
QUIT
+6 ;store bmip
+7 ;already has this bmiP value on this visit so don't store it again, Q
IF $$HASVM(V,"BMIP",BMIPCT)
QUIT
+8 ;store BMIP as v meas
+9 DO STORE(V,DFN,"BMIP",BMIPCT,APCDX,HD)
+10 QUIT
EIE(APCDX) ;EP - wt or ht entered in error, bmi eie
+1 IF '$GET(APCDX)
QUIT
+2 DO EN^XBNEW("EIE1^APCDBMI","APCDX")
+3 KILL APCDX
+4 QUIT
EIE1 ;
+1 ;NEW A,B,C,D,E,P,V,VD,W,H,BMI,HD,ERR,APCLFDA,BIEN,X,Y,DA
+2 SET A=$$GET1^DIQ(9000010.01,APCDX,.01)
+3 ;only ht/wt
IF A'="HT"
IF A'="WT"
QUIT
+4 IF A="WT"
DO EIEW
QUIT
+5 IF A="HT"
DO EIEH
QUIT
+6 QUIT
EIEW ;WT ENTERED IN ERROR
+1 ;if no other wts deleted all bmi, bmip on this visit
+2 ;
+3 ;visit ien is in V
SET V=$$GET1^DIQ(9000010.01,APCDX,.03,"I")
+4 IF V=""
QUIT
+5 IF '$$HASAVM(V,"WT")
Begin DoDot:1
+6 ;find all bmi's and bmip's and mark them EIE
+7 SET APCDY=0
FOR
SET APCDY=$ORDER(^AUPNVMSR("AD",V,APCDY))
IF APCDY'=+APCDY
QUIT
Begin DoDot:2
+8 ;ALREADY EIE
IF $PIECE($GET(^AUPNVMSR(APCDY,2)),U,1)
QUIT
+9 SET T=$$GET1^DIQ(9000010.01,APCDY,.01)
+10 IF T'="BMI"
IF T'="BMIP"
QUIT
+11 ;mark as EIE
+12 DO FILEEIE(APCDY)
End DoDot:2
End DoDot:1
QUIT
+13 ;WHAT IF THERE IS ALREADY A WT SO NEED TO DELETE THE CORRECT BMI SO FIND BMI/BMIP AND DELETE
+14 ;wt value is in B
SET W=$$GET1^DIQ(9000010.01,APCDX,.04)
+15 IF W=""
QUIT
+16 ;patient dfn is in P
SET DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I")
+17 IF DFN=""
QUIT
+18 ;visit ien is in V
SET V=$$GET1^DIQ(9000010.01,APCDX,.03,"I")
+19 IF V=""
QUIT
+20 ;visit date
SET VD=$$VD^APCLV(V)
+21 ;age of patient on visit date
SET AGE=$$AGE^AUPNPAT(DFN,VD)
+22 ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
SET H=$$LASTHT(DFN,VD)
+23 ;no ht so don't calculate anything
IF H=""
QUIT
+24 SET HD=$PIECE(H,U,2)
+25 SET H=$PIECE(H,U)
+26 ;calc bmi
+27 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+28 ;find bmi with this value and mark as EIE
+29 FOR
SET APCDZ=$$HASVM(V,"BMI",BMI)
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+30 ;now find bmip
+31 ;no routine to calculate
IF $TEXT(BMIPCT^BEHOVM2)=""
QUIT
+32 IF AGE<2
QUIT
+33 IF AGE>18
QUIT
+34 SET BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,VD)
+35 IF BMIPCT'>0
QUIT
+36 FOR
SET APCDZ=$$HASVM(V,"BMIP",BMIPCT)
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+37 QUIT
EIEH ;
+1 ;IF HT ENTERED IN ERROR, DELETE ALL BMIS AND BMIPS UNTIL FIND ANOTHER HT, MARK THEM ALL EIE
+2 ;patient dfn is in P
SET DFN=$$GET1^DIQ(9000010.01,APCDX,.02,"I")
+3 IF DFN=""
QUIT
+4 ;visit ien is in V
SET V=$$GET1^DIQ(9000010.01,APCDX,.03,"I")
+5 IF V=""
QUIT
+6 SET HD=$$VD^APCLV(V)
+7 SET AGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(V))
+8 KILL APCDVAR
+9 IF AGE>18
IF AGE<50
SET E=$$FMADD^XLFDT($$VD^APCLV(V),(5*365))
+10 IF AGE>49
SET E=$$FMADD^XLFDT($$VD^APCLV(V),(2*365))
+11 IF AGE<19
SET E=$$VD^APCLV(V)
+12 DO ALLV^APCLAPIU(DFN,$$VD^APCLV(V),E,"APCDVAR")
+13 ;REORDER BY DATE LOWEST TO HIGHEST
+14 SET APCDSTOP=""
+15 SET X=0
FOR
SET X=$ORDER(APCDVAR(X))
IF X'=+X
QUIT
Begin DoDot:1
+16 SET N=$PIECE(APCDVAR(X),U,5)
+17 SET APCDVAR("LH",$$VDTM^APCLV(N),X)=APCDVAR(X)
End DoDot:1
+18 SET D=0
FOR
SET D=$ORDER(APCDVAR("LH",D))
IF D'=+D
QUIT
Begin DoDot:1
+19 SET X=0
FOR
SET X=$ORDER(APCDVAR("LH",D,X))
IF X'=+X
QUIT
Begin DoDot:2
+20 SET N=$PIECE(APCDVAR("LH",D,X),U,5)
+21 ;BEFORE MY VISIT, DON'T DEAL WITH IT
IF $$VDTM^APCLV(N)<$$VDTM^APCLV(V)
KILL APCDVAR("LH",D,X)
+22 ;no wts so don't bother, can't calculate bmi
IF '$$HASAVM(N,"WT")
KILL APCDVAR("LH",D,X)
+23 ;KILL OFF ALL REMAINING
IF $$HASAVM(N,"HT")
IF N'=V
SET A=D
SET B=X
Begin DoDot:3
+24 FOR
SET A=$ORDER(APCDVAR("LH",A))
IF A'=+A
QUIT
FOR
SET B=$ORDER(APCDVAR("LH",A,B))
IF B'=+B
QUIT
KILL APCDVAR("LH",A,B)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;nowDELETE bmi/BMIP on this array of visits
+26 SET D=0
FOR
SET D=$ORDER(APCDVAR("LH",D))
IF D=""
QUIT
Begin DoDot:1
+27 SET X=0
FOR
SET X=$ORDER(APCDVAR("LH",D,X))
IF X=""
QUIT
Begin DoDot:2
+28 ;visit ien
SET N=$PIECE(APCDVAR(X),U,5)
+29 SET APCDAGE=$$AGE^AUPNPAT(DFN,$$VD^APCLV(N))
+30 ;delete all bmis and bmips
+31 FOR
SET APCDZ=$$HASAVM(N,"BMI")
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+32 FOR
SET APCDZ=$$HASAVM(N,"BMIP")
IF 'APCDZ
QUIT
DO FILEEIE(APCDZ)
+33 ;NOW ADD NEW BMI/BMIP WITH HT PREVIOUS TO THE ONE DELETED, IF WE CAN
+34 SET APCDA=0
FOR
SET APCDA=$ORDER(^AUPNVMSR("AD",N,APCDA))
IF APCDA'=+APCDA
QUIT
Begin DoDot:3
+35 IF $PIECE($GET(^AUPNVMSR(APCDA,2)),U,1)
QUIT
+36 IF $$VAL^XBDIQ1(9000010.01,APCDA,.01)'="WT"
QUIT
+37 SET W=$$VAL^XBDIQ1(9000010.01,APCDA,.04)
+38 ;calc bmi
+39 ;get last height entered that is allowable for age (same day for <18, last 5 YRS for 19-49, last 2 years for 50 AND OVER)
SET H=$$LASTHT(DFN,$$VD^APCLV(N))
+40 ;no ht so don't calculate anything
IF H=""
QUIT
+41 SET HD=$PIECE(H,U,2)
+42 SET H=$PIECE(H,U)
+43 ;calc bmi
+44 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+45 IF '$$HASVM(V,"BMI",BMI)
DO STORE(N,DFN,"BMI",BMI,APCDA,HD)
+46 ;no routine to calculate
IF $TEXT(BMIPCT^BEHOVM2)=""
QUIT
+47 IF APCDAGE<2
QUIT
+48 IF APCDAGE>18
QUIT
+49 SET BMIPCT=$$BMIPCT^BEHOVM2(BMI,DFN,$$VD^APCLV(N))
+50 IF BMIPCT'>0
QUIT
+51 ;store bmip
+52 ;already has this bmiP value on this visit so don't store it again, Q
IF $$HASVM(N,"BMIP",BMIPCT)
QUIT
+53 ;store BMIP as v meas
+54 DO STORE(N,DFN,"BMIP",BMIPCT,APCDA,HD)
End DoDot:3
End DoDot:2
End DoDot:1
+55 QUIT
FILEEIE(APCDY) ;
+1 IF '$GET(APCDY)
QUIT
+2 IF '$DATA(^AUPNVMSR(APCDY))
QUIT
+3 NEW APCDIENS,APCDFDA,APCDERR,DA,DIK
+4 SET APCDIENS=APCDY_","
+5 SET APCDFDA(9000010.01,APCDIENS,2)=1
+6 SET APCDFDA(9000010.01,APCDIENS,3)=DUZ
+7 ;S APCDFDA(9000010.014,"+1,"_APCDIENS,.01)=$P(BEHDATA,"^",3)
+8 DO UPDATE^DIE("","APCDFDA","APCDIEN","APCDERR")
+9 ;NOW MERGE OVER THE RESONS FROM THE OTHER ENTRY
+10 MERGE ^AUPNVMSR(APCDY,2.1)=^AUPNVMSR(APCDX,2.1)
+11 ;REINDEX
+12 SET DA=APCDY
SET DIK="^AUPNVMSR("
DO IX^DIK
KILL DA,DIK
+13 QUIT
+14 ;
HASAVM(V,T) ;
+1 NEW Y,G
+2 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVMSR("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+3 IF $$GET1^DIQ(9000010.01,Y,.01)'=T
QUIT
+4 ;EIE
IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+5 SET G=Y
End DoDot:1
+6 QUIT G
