VPRSDAOB ;SLC/MKB/CMF -- SDA Observation utilities ;7/28/23 14:11
;;1.0;VIRTUAL PATIENT RECORD;**33**;Sep 01, 2011;Build 8
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^PXRMINDX 4290
; DIQ 2056
; GMRVUT0, ^UTILITY($J 1446
; GMVBMI 7437
; GMVGETVT 5047
; GMVUTL 5046
; ^MDC(704.117 5810
;
VITALS ; -- GMR Vital Measurements query [main]
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N GMRVSTR,VPRIDT,VPRTYP,ID,VPRN,X0,TYP,GUID
S GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN" ;CPRS vitals data set
S GMRVSTR(0)=DSTRT_U_DSTOP_U_DMAX_"^1"
D EN1^GMRVUT0 S VPRN=0
S VPRIDT=0 F S VPRIDT=$O(^UTILITY($J,"GMRVD",VPRIDT)) Q:VPRIDT<1 D Q:VPRN'<DMAX
. S VPRTYP="" F S VPRTYP=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP)) Q:VPRTYP="" D
.. S ID=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,0)) Q:'ID
.. ; check ^PXRM for 704.117 GUID instead of 120.5 ien
.. S X0=$G(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,ID)),TYP=$P(X0,U,3)
.. S GUID=$O(^PXRMINDX(120.5,"PI",DFN,TYP,+X0,"")) S:GUID="" GUID=ID
.. S VPRN=VPRN+1,DLIST(VPRN)=GUID
.. S ^TMP("VPRGMV",$J,GUID)=$G(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,ID))
K ^UTILITY($J,"GMRVD")
Q
;
VIT1(IEN) ; -- get info for one Vital measurement
; Accepts IEN = #120.5 ien or #704.117 GUID
; Returns VPRV array, VPRGMV=VPRV(0), VPRANGE, VPRTYPE to entity
S IEN=$G(IEN) I IEN="" S DDEOUT=1 Q
D GETREC^GMVUTL(.VPRV,IEN,1)
S VPRGMV=$G(VPRV(0)) I '$G(VPRV(0)) S DDEOUT=1 Q
I $$ISGUID($P(VPRGMV,U,8)) S DDEOUT=1 Q ;don't pass rare but potential GUID strings as actual values
S VPRTYPE=$$FIELD^GMVGETVT(+$P(VPRGMV,U,3),2)
I VPRTYPE="WT" D ;get BMI for weight record
. I $G(^TMP("VPRGMV",$J,IEN)) S $P(VPRGMV,U,14)=$P(^(IEN),U,14) Q
. ; get BMI from query array if available, else call GMVBMI
. N VPRBMI,DFN
. S VPRBMI(1)=+VPRGMV,VPRBMI(2)=$P(VPRGMV,U,8),DFN=+$P(VPRGMV,U,2)
. D CALBMI^GMVBMI(.VPRBMI,0)
. S:$G(VPRBMI)'="" $P(VPRGMV,U,14)=VPRBMI
S VPRANGE=$S($L(VPRTYPE):$$RANGE^VPRDGMV(VPRTYPE),1:"")
Q
;
VITQUAL ; -- build DLIST(#)=Qualifiers [code^name]
N I,X,QUALS
S QUALS=$G(VPRV(5))
F I=1:1 S X=$P(QUALS,U,I) Q:X="" S DLIST(I)=X
Q
;
VITCODE(IEN,SFN) ; -- return [first] code for vital type
; SubFileNumber = 120.518 for Vital Type
; 120.522 for Vital Qualifier
N VPRC,IENS,Y
D GETS^DIQ(SFN,"1,"_IEN_",","**",,"VPRC")
S IENS=$O(VPRC(SFN_1,""))
S Y=$S($L(IENS):$G(VPRC(SFN_1,IENS,.01,"I")),1:"")
Q Y
;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener
N DFN,ID,ACT,VPROBS
M VPROBS=OBS
D:'$D(VPROBS) NOOBS ;currently not provided by MDC event
Q:$G(VPROBS("ERROR"))'=""
Q:$G(VPROBS("DOMAIN","VITALS"))'=1
S DFN=+$G(VPROBS("PATIENT_ID","I")) Q:DFN<1
S ID=$G(VPROBS("OBS_ID","I")) Q:'$L(ID)
S ACT=$S('$G(VPROBS("STATUS","I")):"@",1:"")
D POST^VPRHS(DFN,"Observation",ID_";120.5",ACT)
Q
;
NOOBS ; -- called if OBS array was not created by MDCPROTD
; MDC event called from ASTATUS index, so expects FM variables (DA, X1, X2)
N IEN,VPRERR,VPRGUID,Y
S IEN=$G(DA) I '+IEN S VPROBS("ERROR")="Invalid DA value passed to entry point." Q
D GETS^DIQ(704.117,IEN_",",".01;.08;.09","INR","^TMP(""VPROBS"",$J)","VPRERR")
I $D(VPRERR) D Q
. S VPROBS("ERROR")=$G(VPRERR("DIERR",1))_U_$G(VPRERR("DIERR",1,"TEXT",1))
M VPROBS=^TMP("VPROBS",$J,704.117,IEN_",") K ^TMP("VPROBS",$J)
S VPROBS("DOMAIN","VITALS")=0
S VPRGUID=$$GET1^DIQ(704.117,IEN_",",.07)
F Y=1:1 Q:$T(MAP+Y)="" I $P($T(MAP+Y),";",4)=VPRGUID S VPROBS("DOMAIN","VITALS")=1 Q
Q
;
ISGUID(MDX) ; Returns true if MDX is in the format of a GUID. Copied from MDCLIO1
N X,Y
Q:$L(MDX)'=38 0
Q:MDX'?1"{"8UN1"-"4UN1"-"4UN1"-"4UN1"-"12UN1"}" 0
; Scan for Uppercase character above F
S X=1 F Y=71:1:90 I MDX[$C(Y) S X=0 Q
Q X
;
MAP ;Contains the CLiO terms paired with a vital sign - vital;term_guid. Copied from MDCLIO1
;;ABDOMINAL GIRTH;{F70E6642-2719-22BE-BE87-DEF0A884F177}
;;AUDIOMETRY;{FFD29134-8BB2-248E-0412-93C2C08B076F}
;;BLOOD PRESSURE;{B15F2DF6-CE99-B847-FE6B-3D5F174A2BCD}
;;CENTRAL VENOUS PRESSURE;{D30F98A7-4C5D-12E8-AB4D-9C85A4332EC3}
;;CIRCUMFERENCE/GIRTH;{92A124D4-B75F-9FD9-1A51-605887BCEA79};
;;FETAL HEART TONES;{A2E22A44-E924-ADDE-2B8E-0251666B4DE6}
;;FUNDAL HEIGHT;{EEAB8762-624F-7BA3-4001-114FD229BA69}
;;HEAD CIRCUMFERENCE;{33827E3C-5DBB-083C-D8BE-4DFD7D42071F}
;;HEARING;{813CCC94-3D64-5093-BC6C-053EFD9948F9}
;;HEIGHT;{B440216B-0FB3-1950-7859-7C1BE398FE4A}
;;PAIN;{47A83DEA-BA95-38AD-DF2E-1F209122E684}
;;PULSE;{FCA63B76-EF4C-EBE5-33C1-F1EEBD7A7BC4}
;;PULSE OXIMETRY;{5F84DD55-3CCF-094C-2536-B51EB7FAD999}
;;RESPIRATION;{973ED2C0-0625-7DF9-17DC-8FFF7E376F23}
;;TEMPERATURE;{0F33223E-DF2C-6B8B-5201-5E091C5F9065}
;;TONOMETRY;{C06989EF-4B0F-4941-B1A7-FA9D81A480FF}
;;VISION CORRECTED;{ED022AC1-EBE4-E708-684D-63D00628A94C}
;;VISION UNCORRECTED;{BEA5E565-D728-F5B3-0A3A-0528C42A45C4}
;;WEIGHT;{CD2D8263-6B71-0E1C-0AFE-87B4B2C12632}
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAOB 5189 printed Nov 22, 2024@17:55:47 Page 2
VPRSDAOB ;SLC/MKB/CMF -- SDA Observation utilities ;7/28/23 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^PXRMINDX 4290
+7 ; DIQ 2056
+8 ; GMRVUT0, ^UTILITY($J 1446
+9 ; GMVBMI 7437
+10 ; GMVGETVT 5047
+11 ; GMVUTL 5046
+12 ; ^MDC(704.117 5810
+13 ;
VITALS ; -- GMR Vital Measurements query [main]
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW GMRVSTR,VPRIDT,VPRTYP,ID,VPRN,X0,TYP,GUID
+3 ;CPRS vitals data set
SET GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
+4 SET GMRVSTR(0)=DSTRT_U_DSTOP_U_DMAX_"^1"
+5 DO EN1^GMRVUT0
SET VPRN=0
+6 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+7 SET VPRTYP=""
FOR
SET VPRTYP=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP))
if VPRTYP=""
QUIT
Begin DoDot:2
+8 SET ID=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,0))
if 'ID
QUIT
+9 ; check ^PXRM for 704.117 GUID instead of 120.5 ien
+10 SET X0=$GET(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,ID))
SET TYP=$PIECE(X0,U,3)
+11 SET GUID=$ORDER(^PXRMINDX(120.5,"PI",DFN,TYP,+X0,""))
if GUID=""
SET GUID=ID
+12 SET VPRN=VPRN+1
SET DLIST(VPRN)=GUID
+13 SET ^TMP("VPRGMV",$JOB,GUID)=$GET(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,ID))
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+14 KILL ^UTILITY($JOB,"GMRVD")
+15 QUIT
+16 ;
VIT1(IEN) ; -- get info for one Vital measurement
+1 ; Accepts IEN = #120.5 ien or #704.117 GUID
+2 ; Returns VPRV array, VPRGMV=VPRV(0), VPRANGE, VPRTYPE to entity
+3 SET IEN=$GET(IEN)
IF IEN=""
SET DDEOUT=1
QUIT
+4 DO GETREC^GMVUTL(.VPRV,IEN,1)
+5 SET VPRGMV=$GET(VPRV(0))
IF '$GET(VPRV(0))
SET DDEOUT=1
QUIT
+6 ;don't pass rare but potential GUID strings as actual values
IF $$ISGUID($PIECE(VPRGMV,U,8))
SET DDEOUT=1
QUIT
+7 SET VPRTYPE=$$FIELD^GMVGETVT(+$PIECE(VPRGMV,U,3),2)
+8 ;get BMI for weight record
IF VPRTYPE="WT"
Begin DoDot:1
+9 IF $GET(^TMP("VPRGMV",$JOB,IEN))
SET $PIECE(VPRGMV,U,14)=$PIECE(^(IEN),U,14)
QUIT
+10 ; get BMI from query array if available, else call GMVBMI
+11 NEW VPRBMI,DFN
+12 SET VPRBMI(1)=+VPRGMV
SET VPRBMI(2)=$PIECE(VPRGMV,U,8)
SET DFN=+$PIECE(VPRGMV,U,2)
+13 DO CALBMI^GMVBMI(.VPRBMI,0)
+14 if $GET(VPRBMI)'=""
SET $PIECE(VPRGMV,U,14)=VPRBMI
End DoDot:1
+15 SET VPRANGE=$SELECT($LENGTH(VPRTYPE):$$RANGE^VPRDGMV(VPRTYPE),1:"")
+16 QUIT
+17 ;
VITQUAL ; -- build DLIST(#)=Qualifiers [code^name]
+1 NEW I,X,QUALS
+2 SET QUALS=$GET(VPRV(5))
+3 FOR I=1:1
SET X=$PIECE(QUALS,U,I)
if X=""
QUIT
SET DLIST(I)=X
+4 QUIT
+5 ;
VITCODE(IEN,SFN) ; -- return [first] code for vital type
+1 ; SubFileNumber = 120.518 for Vital Type
+2 ; 120.522 for Vital Qualifier
+3 NEW VPRC,IENS,Y
+4 DO GETS^DIQ(SFN,"1,"_IEN_",","**",,"VPRC")
+5 SET IENS=$ORDER(VPRC(SFN_1,""))
+6 SET Y=$SELECT($LENGTH(IENS):$GET(VPRC(SFN_1,IENS,.01,"I")),1:"")
+7 QUIT Y
+8 ;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener
+1 NEW DFN,ID,ACT,VPROBS
+2 MERGE VPROBS=OBS
+3 ;currently not provided by MDC event
if '$DATA(VPROBS)
DO NOOBS
+4 if $GET(VPROBS("ERROR"))'=""
QUIT
+5 if $GET(VPROBS("DOMAIN","VITALS"))'=1
QUIT
+6 SET DFN=+$GET(VPROBS("PATIENT_ID","I"))
if DFN<1
QUIT
+7 SET ID=$GET(VPROBS("OBS_ID","I"))
if '$LENGTH(ID)
QUIT
+8 SET ACT=$SELECT('$GET(VPROBS("STATUS","I")):"@",1:"")
+9 DO POST^VPRHS(DFN,"Observation",ID_";120.5",ACT)
+10 QUIT
+11 ;
NOOBS ; -- called if OBS array was not created by MDCPROTD
+1 ; MDC event called from ASTATUS index, so expects FM variables (DA, X1, X2)
+2 NEW IEN,VPRERR,VPRGUID,Y
+3 SET IEN=$GET(DA)
IF '+IEN
SET VPROBS("ERROR")="Invalid DA value passed to entry point."
QUIT
+4 DO GETS^DIQ(704.117,IEN_",",".01;.08;.09","INR","^TMP(""VPROBS"",$J)","VPRERR")
+5 IF $DATA(VPRERR)
Begin DoDot:1
+6 SET VPROBS("ERROR")=$GET(VPRERR("DIERR",1))_U_$GET(VPRERR("DIERR",1,"TEXT",1))
End DoDot:1
QUIT
+7 MERGE VPROBS=^TMP("VPROBS",$JOB,704.117,IEN_",")
KILL ^TMP("VPROBS",$JOB)
+8 SET VPROBS("DOMAIN","VITALS")=0
+9 SET VPRGUID=$$GET1^DIQ(704.117,IEN_",",.07)
+10 FOR Y=1:1
if $TEXT(MAP+Y)=""
QUIT
IF $PIECE($TEXT(MAP+Y),";",4)=VPRGUID
SET VPROBS("DOMAIN","VITALS")=1
QUIT
+11 QUIT
+12 ;
ISGUID(MDX) ; Returns true if MDX is in the format of a GUID. Copied from MDCLIO1
+1 NEW X,Y
+2 if $LENGTH(MDX)'=38
QUIT 0
+3 if MDX'?1"{"8UN1"-"4UN1"-"4UN1"-"4UN1"-"12UN1"}"
QUIT 0
+4 ; Scan for Uppercase character above F
+5 SET X=1
FOR Y=71:1:90
IF MDX[$CHAR(Y)
SET X=0
QUIT
+6 QUIT X
+7 ;
MAP ;Contains the CLiO terms paired with a vital sign - vital;term_guid. Copied from MDCLIO1
+1 ;;ABDOMINAL GIRTH;{F70E6642-2719-22BE-BE87-DEF0A884F177}
+2 ;;AUDIOMETRY;{FFD29134-8BB2-248E-0412-93C2C08B076F}
+3 ;;BLOOD PRESSURE;{B15F2DF6-CE99-B847-FE6B-3D5F174A2BCD}
+4 ;;CENTRAL VENOUS PRESSURE;{D30F98A7-4C5D-12E8-AB4D-9C85A4332EC3}
+5 ;;CIRCUMFERENCE/GIRTH;{92A124D4-B75F-9FD9-1A51-605887BCEA79};
+6 ;;FETAL HEART TONES;{A2E22A44-E924-ADDE-2B8E-0251666B4DE6}
+7 ;;FUNDAL HEIGHT;{EEAB8762-624F-7BA3-4001-114FD229BA69}
+8 ;;HEAD CIRCUMFERENCE;{33827E3C-5DBB-083C-D8BE-4DFD7D42071F}
+9 ;;HEARING;{813CCC94-3D64-5093-BC6C-053EFD9948F9}
+10 ;;HEIGHT;{B440216B-0FB3-1950-7859-7C1BE398FE4A}
+11 ;;PAIN;{47A83DEA-BA95-38AD-DF2E-1F209122E684}
+12 ;;PULSE;{FCA63B76-EF4C-EBE5-33C1-F1EEBD7A7BC4}
+13 ;;PULSE OXIMETRY;{5F84DD55-3CCF-094C-2536-B51EB7FAD999}
+14 ;;RESPIRATION;{973ED2C0-0625-7DF9-17DC-8FFF7E376F23}
+15 ;;TEMPERATURE;{0F33223E-DF2C-6B8B-5201-5E091C5F9065}
+16 ;;TONOMETRY;{C06989EF-4B0F-4941-B1A7-FA9D81A480FF}
+17 ;;VISION CORRECTED;{ED022AC1-EBE4-E708-684D-63D00628A94C}
+18 ;;VISION UNCORRECTED;{BEA5E565-D728-F5B3-0A3A-0528C42A45C4}
+19 ;;WEIGHT;{CD2D8263-6B71-0E1C-0AFE-87B4B2C12632}
+20 QUIT
