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

BEHOVM2.m

Go to the documentation of this file. 
  1. BEHOVM2 ;IHS/MSC/MGH - Triage: Vital Measurements ;23-Sep-2014 15:22;DU
  1.  ;;1.1;BEH COMPONENTS;**001004,001005,001007,001009,001010**;Sep 18, 2007
  1.  ;=================================================================
  1. QUAL(RESULT,IEN,QUALS) ;EP Store the vitals qualifiers
  1.  ;Entry data is the IEN of the measurment and the qualifiers separated by ~
  1.  N BEHCNT,BEHERR,BEHFDA,BEHOKAY,BEHVIEN,BEHQUAL,VMSR,FNUM,F2NUM,QUALNAME
  1.  S VMSR=$$VMSR
  1.  S BEHCNT=0
  1.  S FNUM=$S(VMSR:9000010.01,1:120.5)
  1.  S F2NUM=$S(VMSR:9000010.015,1:120.505)
  1.  I VMSR,'$D(^AUPNVMSR(+IEN,0))#2 S RESULT="-1^Vital entry Not Found" Q
  1.  I 'VMSR,'$D(^GMR(120.5,+IEN,0))#2 S RESULT="-1^Vital entry Not Found" Q
  1.  S QUALNAME="" F  S QUALNAME=$O(QUALS(QUALNAME)) Q:QUALNAME=""!(+$G(RESULT)<0)  D
  1.  .;Find the qualifier
  1.  .I +QUALNAME S BEHQUAL=QUALNAME
  1.  .E  S BEHQUAL="" S BEHQUAL=$O(^GMRD(120.52,"B",QUALNAME,BEHQUAL)) I BEHQUAL="" S RESULT="-1^Cannot find qualifier" Q
  1.  .; Is the qualifier already stored?
  1.  .I 'VMSR,$O(^GMR(120.5,IEN,5,"B",BEHQUAL,0))>0 S RESULT="-1"  Q
  1.  .I VMSR,$O(^AUPNVSMR(IEN,5,"B",BEHQUAL,0))>0 S RESULT="-1"  Q
  1.  .; Legitimate Qualifier?
  1.  .I '$D(^GMRD(120.52,BEHQUAL,0)) D  S RESULT=""  Q
  1.  .S BEHCNT=BEHCNT+1
  1.  .; Store the  qualifier
  1.  .K BEHFDA,BEHOKAY,BEHERR
  1.  .S BEHFDA(F2NUM,"+1,"_IEN_",",.01)=BEHQUAL
  1.  .D UPDATE^DIE("","BEHFDA","BEHOKAY","BEHERR")
  1.  .I $D(BEHERR) S RESULT="-1^Unable to store qualifier"
  1.  .E  S RESULT=+$G(BEHOKAY(1))
  1.  Q
  1. PO2(RESULT,IEN,QUALS) ;Store data for O2 Saturation
  1.  N QUAL,QUALNAME,VAL,O2,RESULT,FDA,FNUM,I
  1.  S VAL=""
  1.  S QUALNAME=$P(QUALS,"~",1)
  1.  S QUAL(QUALNAME)=""
  1.  D QUAL^BEHOVM2(.RESULT,IEN,.QUAL)
  1.  S O2=""
  1.  F I=2:1:3 D
  1.  .S VAL=$P(QUALS,"~",I)
  1.  .I VAL'="" S O2=$S(O2="":$P(VAL,";",1)_" "_$P(VAL,";",2),1:O2_" "_$P(VAL,";",1)_" "_$P(VAL,";",2))
  1.  I VAL'="" D
  1.  .S FNUM=9000010.01
  1.  .S FDA=$NA(FDA(FNUM,IEN_","))
  1.  .S @FDA@(1.4)=O2
  1.  .S RESULT=$$UPDATE^BGOUTL(.FDA,"E")
  1.  Q
  1. EIE(RESULT,BEHDATA,TYPE) ; EP Store entered in error data
  1.  ;BEHDATA CONSISTS OF THE FOLLOWING DATA:
  1.  ;FILE IEN^DUZ^REASON
  1.  ;If type=0 it is delete only, if type=1 its an edit
  1.  N BEHFDA,BEHIEN,BEHIENS,BEHERR,FNUM,F2NUM,VMSR,TYPE
  1.  S VMSR=$$VMSR
  1.  S FNUM=$S(VMSR:9000010.01,1:120.5)
  1.  S F2NUM=$S(VMSR:9000010.014,1:120.506)
  1.  I VMSR,'$D(^AUPNVMSR(+BEHDATA,0))#2 S RESULT="ERROR: Record Not Found" Q
  1.  I 'VMSR,'$D(^GMR(120.5,+BEHDATA,0))#2 S RESULT="ERROR: Record Not Found" Q
  1.  S BEHIENS=(+BEHDATA)_","
  1.  S BEHFDA(FNUM,BEHIENS,2)=1
  1.  S BEHFDA(FNUM,BEHIENS,3)=$P(BEHDATA,"^",2)
  1.  S BEHFDA(F2NUM,"+1,"_BEHIENS,.01)=$P(BEHDATA,"^",3)
  1.  D UPDATE^DIE("","BEHFDA","BEHIEN","BEHERR")
  1.  I $D(BEHIEN(1)) S RESULT="OK"
  1.  D VFEVT^BEHOENPC(FNUM,+BEHDATA,1)
  1.  I $D(BEHERR)>0 S RESULT="Unable to process entered in error"
  1.  ;IHS/MSC/MGH EHR 13 See if it is a weight, If so check for BMI on same date and delete
  1.  S CHK=$$GET1^DIQ(9000010.01,+BEHDATA,.01,"I")
  1.  I $$GET1^DIQ(9999999.07,CHK,.01)="WT" D EIE^BEHOVM5(+BEHDATA)
  1.  I $$GET1^DIQ(9999999.07,CHK,.01)="HT" D EIE^BEHOVM5(+BEHDATA)
  1.  Q
  1. GETCATS(RESULTS,VIT,LONG) ;EP Given a vital sign, return the categories for this VM and the default
  1.  N BEHCAT,BEHQUAL,ID,ABB,VMSR,Y,CNT
  1.  S RESULTS=$$TMPGBL
  1.  S LONG=$G(LONG,0)
  1.  S CNT=0
  1.  S VMSR=$$VMSR
  1.  S FNUM=$S(VMSR:9999999.07,1:120.51)
  1.  S ID="" S ID=$O(^BEHOVM(90460.01,"B",VIT,ID))
  1.  I ID="" S @RESULTS@(1)="No vital in BEH MEASUREMENT CONTROL FILE" Q
  1.  S ABB=$P($G(^BEHOVM(90460.01,ID,0)),U,7) I ABB="" S @RESULTS@(1)="No abbreviation for vital in BEH MEASURMENT CONTROL FILE" Q
  1.  I VMSR S IEN="" S IEN=$O(^AUTTMSR("B",ABB,IEN)) I IEN="" S @RESULTS@(1)="Unable to find MEASUREMENT TYPE in file" Q
  1.  I 'VMSR S IEN="" S IEN=$O(^GMRD(120.51,"C",ABB,IEN)) I IEN="" S @RESULTS@(1)="Unable to find MEASUREMENT TYPE in file" Q
  1.  ;Get all the qualifiers for this category
  1.  I LONG D
  1.  .F BEHCAT=0:0 S BEHCAT=$O(^GMRD(120.52,"AA",IEN,BEHCAT)) Q:'BEHCAT  D
  1.  ..S CNT=CNT+1,@RESULTS@(CNT)="C"_U_BEHCAT_U_$P(^GMRD(120.53,BEHCAT,0),U)
  1.  ..S BEHQUAL="",X="" F  S X=$O(^GMRD(120.52,"AA",IEN,BEHCAT,X)) Q:X=""  D
  1.  ...S CNT=CNT+1
  1.  ...S @RESULTS@(CNT)="Q"_U_$O(^GMRD(120.52,"AA",IEN,BEHCAT,X,0))_U_X
  1.  ..;S Y=$O(@RESULTS@("").-1)+1
  1.  ..;S @RESULTS@(Y)=BEHCAT
  1.  E  D
  1.  .F BEHCAT=0:0 S BEHCAT=$O(^GMRD(120.52,"AA",IEN,BEHCAT)) Q:'BEHCAT  D
  1.  ..S BEHQUAL="",X="" F  S X=$O(^GMRD(120.52,"AA",IEN,BEHCAT,X)) Q:X=""  D
  1.  ...S BEHQUAL=BEHQUAL_$S(BEHQUAL]"":"~",1:"")_X
  1.  ..S Y=$O(@RESULTS@(""),-1)+1
  1.  ..S @RESULTS@(Y)=BEHCAT_U_$P(^GMRD(120.53,BEHCAT,0),U)_U_BEHQUAL
  1.  Q
  1. QRYBMI(PCTILE) ;Moved from BEHOVM for space
  1.  N VTWT,VTHT,RSWT,RSHT,BMI,WTDT
  1.  S VTWT=$$VTYPE^BEHOVM("WT"),VTHT=$$VTYPE^BEHOVM("HT"),PCTILE=+$G(PCTILE)
  1.  I 'VMSR D GMRBMI(PCTILE) Q
  1.  D BLDXRF^BEHOVM(VTWT),BLDXRF^BEHOVM(VTHT)
  1.  F  Q:'IDT!(RCNT=RMAX)  D
  1.  .S VIEN=$C(1)
  1.  .F  S VIEN=$O(^TMP("BEHOVM",$J,VTWT,IDT,VIEN),-1) Q:'VIEN  D  Q:RCNT=RMAX
  1.  ..D GETMSR^BEHOVM(VIEN,.RSWT,.DATE,.LOC,.ENTERBY)
  1.  ..;IHS/MSC/MGH Save the wt date to use if the ht isn't too old patch 4
  1.  ..S QUALIF=""
  1.  ..S WTDT=DATE
  1.  ..S RSHT=$$FNDHT(IDT)
  1.  ..Q:'RSHT
  1.  ..S QUALIF=""
  1.  ..S RSWT=RSWT*.45359,RSHT=RSHT*.0254,RSHT=RSHT*RSHT,BMI=+$J(RSWT/RSHT,0,2)
  1.  ..S:PCTILE BMI=$$BMIPCT(BMI,DFN,DATE)
  1.  ..Q:'BMI
  1.  ..S RESULT(VUNT)=BMI,RCNT=RCNT+1
  1.  ..S DATE=WTDT
  1.  ..D CALLBCK^BEHOVM
  1.  .S IDT=$O(^TMP("BEHOVM",$J,VTWT,IDT))
  1.  K ^TMP("BEHOVM",$J)
  1.  Q
  1. FNDHT(IDT) ;Find closest height before weight
  1.  N VIEN,RESULT,DOB,SEX,TAGE,X,X2,X1,SX,APCHMDT,IDT2
  1.  S VIEN=$O(^TMP("BEHOVM",$J,VTHT,IDT,""))
  1.  I 'VIEN D
  1.  .;IHS/MSC/MGH Added in HS logic for lookback days for ht. Patch 4
  1.  .;Only allowed to look forward for the same date as the wt. Otherwise,
  1.  .N ID1,ID2
  1.  .S IDT2=9999999-IDT
  1.  .S TAGE=$$PTAGE^BGOUTL(DFN,IDT2)
  1.  .S DOB=$P(^DPT(DFN,0),U,3),SEX=$P(^DPT(DFN,0),U,2),SX=$S(SEX="M":2,SEX="F":3,1:"")
  1.  .;X2=DOB,X1=DT D ^%DTC S TAGE=X
  1.  .S ID1=$O(^TMP("BEHOVM",$J,VTHT,IDT),-1),ID2=$O(^TMP("BEHOVM",$J,VTHT,IDT))
  1.  .I ID1 D
  1.  ..S X1=$P(ID1,".",1),X2=$P(IDT,".",1)
  1.  ..I X1=X2 S ID2=ID1
  1.  .I ID2 D
  1.  ..S X1=9999999-(ID2\1)
  1.  ..S APCHMDT=$$FMDIFF^XLFDT(X1,DOB,1)
  1.  ..S X1=9999999-(IDT\1),X2=9999999-ID2
  1.  ..S X=$$FMDIFF^XLFDT(X1,X2,1)
  1.  ..I ((X>90)&(APCHMDT<1096))!((X>180)&(APCHMDT<4381))!((X>365)&(APCHMDT<6571))!((APCHMDT<6571)&(TAGE>6571)) S ID2=""
  1.  ..S:ID2 VIEN=$O(^TMP("BEHOVM",$J,VTHT,ID2,""))
  1.  D:VIEN GETMSR^BEHOVM(VIEN,.RESULT)
  1.  Q $G(RESULT)
  1.  ; Compute BMI percentile
  1. BMIPCT(BMI,DFN,DATE) ;
  1.  N PCT,VAL,LP,DIF,DAT,X1,X2
  1.  D PCTILE^BEHOVM("PCT",$$VCTL^BEHOVM("BMI"),DFN,DATE,DATE)
  1.  S DIF=9999999
  1.  F LP=0:0 S LP=$O(PCT(LP)) Q:'LP  D
  1.  .S X1=PCT(LP),DAT=$P(X1,U,2),VAL(DAT,$P(X1,U,3))=$P(X1,U)
  1. DD .S X1=$$FMDIFF^XLFDT(DATE,DAT),X1=$S(X1<0:-X1,1:X1)
  1.  .S:X1<DIF DIF=X1,DIF(0)=DAT
  1.  Q:DIF>30 0
  1.  S DAT=DIF(0)
  1.  Q:$D(VAL(DAT,BMI)) VAL(DAT,BMI)
  1.  S X1=$O(VAL(DAT,BMI),-1),X2=$O(VAL(DAT,BMI))
  1.  Q +$J($S('X1:1,'X2:100,1:(BMI-X1)/(X2-X1)*(VAL(DAT,X2)-VAL(DAT,X1))+VAL(DAT,X1)),0,1)
  1.  ;RPC entry point to get units for a vital
  1.  ;Input=vital measurement by name
  1.  ;Return value = US unit^LO^HI^Metric unit^LO^HI
  1. VUNITS(RET,VIT) ;EP
  1.  Q:VIT=""
  1.  S RET=""
  1.  N VCTL
  1.  S VCTL="" S VCTL=$O(^BEHOVM(90460.01,"B",VIT,VCTL))
  1.  I VCTL="" Q "Unable to find vital "_VIT
  1.  S RET=$$UNITS^BEHOVM(.VUNT)
  1.  Q RET
  1. TMPGBL(X) ;EP
  1.  K ^TMP("BEHV"_$G(X),$J) Q $NA(^($J))
  1.  ; Returns true if V file is used for vital measurements
  1. VMSR() Q ''$$GET^XPAR("ALL","BEHOVM USE VMSR")
  1. GMRBMI(PCTILE) ;Get BMI for sites using GMRV vitals
  1.  N GBMI,QUALIFY,BMI
  1.  S IDT=START,XREF="AA",VTYP=VTWT,QUALIFY=""
  1.  F  S IDT=$O(^GMR(120.5,XREF,DFN,VTYP,IDT)) Q:'IDT!(RCNT=RMAX)  D
  1.  .S VIEN=$C(1)
  1.  .F  S VIEN=$O(^GMR(120.5,XREF,DFN,VTYP,IDT,VIEN),-1) Q:'VIEN  D  Q:RCNT=RMAX
  1.  ..Q:$P($G(^GMR(120.5,VIEN,2)),U)  S X=$G(^(0))
  1.  ..Q:$P(X,U,2)'=DFN
  1.  ..Q:$P(X,U,3)'=VTYP
  1.  ..I VSIT,+$G(^GMR(120.5,VIEN,9000010))'=VSIT Q
  1.  ..S GBMI(2)=$$TRIM^XLFSTR($P(X,U,8)),DATE=+X,LOC=+$P(X,U,5)
  1.  ..S GBMI(1)=DATE
  1.  ..S WTDT=DATE,DATE(0)=DATE*10000\1/10000
  1.  ..D CALBMI^GMRVBMI(.GBMI)
  1.  ..I $D(GBMI)>10 D
  1.  ...S BMI=GBMI
  1.  ...S:PCTILE BMI=$$BMIPCT(BMI,DFN,DATE)
  1.  ..E  S BMI=0
  1.  ..Q:'BMI
  1.  ..S RESULT(VUNT)=BMI,RCNT=RCNT+1
  1.  ..S DATE=WTDT
  1.  ..D CALLBCK^BEHOVM
  1.  Q
  1. GETCATP(RESULTS,VIEN) ;EP Given a vital sign and an IEN, return the categories for this VM and the default
  1.  N BEHCAT,BEHQUAL,ID,ABB,VMSR,Y,CNT,FNUM2,CHK,QUALIEN
  1.  S RESULTS=$$TMPGBL
  1.  S CNT=0
  1.  S VMSR=$$VMSR
  1.  ;Get results for this IEN
  1.  I VMSR D
  1.  .S IEN=$P($G(^AUPNVMSR(VIEN,0)),U,1)
  1.  .S QUALS=0 F  S QUALS=$O(^AUPNVMSR(VIEN,5,QUALS)) Q:'+QUALS  D
  1.  ..S QUALIEN($P($G(^AUPNVMSR(VIEN,5,QUALS,0)),U,1))=""
  1.  I 'VMSR D
  1.  .S IEN=$P($G(^GMR(120.5,VIEN,0)),U,3)
  1.  .S QUALS=0 F  S QUALS=$O(^GMR(120.5,VIEN,5,QUALS)) Q:QUALS=""  D
  1.  ..S QUALIEN($P($G(^GMR(120.5,VIEN,5,QUALS,0)),U,1))=""
  1.  ;Get all the qualifiers for this category
  1.  F BEHCAT=0:0 S BEHCAT=$O(^GMRD(120.52,"AA",IEN,BEHCAT)) Q:'BEHCAT  D
  1.  .S CNT=CNT+1,@RESULTS@(CNT)="C"_U_BEHCAT_U_$P(^GMRD(120.53,BEHCAT,0),U)
  1.  .S BEHQUAL="",X="" F  S X=$O(^GMRD(120.52,"AA",IEN,BEHCAT,X)) Q:X=""  D
  1.  ..S CNT=CNT+1
  1.  ..S CHK=$O(^GMRD(120.52,"AA",IEN,BEHCAT,X,0))
  1.  ..S @RESULTS@(CNT)="Q"_U_CHK_U_X
  1.  ..I $D(QUALIEN(CHK)) S @RESULTS@(CNT)="Q"_U_CHK_U_X_U_1
  1.  Q
  1. PCTILE(DATA,VCTL,DFN,START,END,METRIC) ;EP  Moved from BEHOVM
  1.  N I,X,DOB,SEX,AGE,L,M,S,P,D,Z,ID,V,C
  1.  S METRIC=+$G(METRIC),X=$G(^DPT(+DFN,0)),SEX=$P(X,U,2),DOB=$P(X,U,3)
  1.  Q:'$L(SEX)!'DOB
  1.  S:METRIC<0 METRIC=$$DEFUNIT^BEHOVM(VCTL)
  1.  S START=$$FMDIFF^XLFDT(START,DOB)/30-1
  1.  S END=$$FMDIFF^XLFDT(END,DOB)/30+1
  1.  S (I,C)=0
  1.  F  S I=$O(^BEHOVM(90460.01,VCTL,3,I)) Q:'I  S X=^(I,0) D
  1.  .S AGE=+$P(X,";",2)
  1.  .Q:AGE<START!(AGE>END)!($P(X,";")'=SEX)
  1.  .S L=$P(X,";",3),M=$P(X,";",4),S=$P(X,";",5),D=$$FMADD^XLFDT(DOB,AGE*30)
  1.  .F P=2:1:10 D
  1.  ..S ID=$P("3^5^10^25^50^75^85^90^95^97",U,P)  ;Added 85 in p11
  1.  ..S Z=$P("-1.881^-1.645^-1.282^-0.674^0^0.674^1.036^1.282^1.645^1.881",U,P)
  1.  ..I L S V=L*S*Z+1**(1/L)*M
  1.  ..E  S V=2.71828183**(S*Z)*M
  1.  ..S C=C+1,@DATA@(C)=ID_U_D_U_$S(METRIC:V,1:$$CONVERT^BEHOVM(V,1,0))
  1.  Q