- 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