Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDBMI

APCDBMI.m

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