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