TIULO ; SLC/JER - Embedded Objects ;29-Aug-2014 11:06;DU
;;1.0;TEXT INTEGRATION UTILITIES;**34,70,101,148,204,1013**;Jun 20, 1997;Build 33
DEM(DFN,VADM) ; Calls DEM^VADPT
D DEM^VADPT
Q
NAME(DFN) ; Patient NAME
I '$D(VADM(1)) D DEM(DFN,.VADM)
Q $S(VADM(1)]"":VADM(1),1:"NAME UNKNOWN")
SSN(DFN) ; Patient SSN
N SSN
I '$D(VADM(2)) D DEM(DFN,.VADM)
;IHS/MSC/MGH Updated to block out SSN patch 1013
S SSN=$P(VADM(2),U,2)
I SSN'="" S SSN="XXX-XX-"_$P(SSN,"-",3)
Q $S(SSN]"":SSN,1:"SSN UNKNOWN")
AGE(DFN) ; Patient AGE
I '$D(VADM(4)) D DEM(DFN,.VADM)
Q $S(VADM(4)]"":VADM(4),1:"AGE UNKNOWN")
DOB(DFN) ; Patient DATE OF BIRTH
I '$D(VADM(3)) D DEM(DFN,.VADM)
Q $S($P(VADM(3),U,2)]"":$P(VADM(3),U,2),1:"DOB UNKNOWN")
DOD(DFN) ; Patient DATE OF DEATH
I '$D(VADM(6)) D DEM(DFN,.VADM)
Q $S($P(VADM(6),U,2)]"":$P(VADM(6),U,2),1:"DATE OF DEATH UNKNOWN")
SEX(DFN) ; Patient SEX
I '$D(VADM(5)) D DEM(DFN,.VADM)
Q $S($P(VADM(5),U,2)]"":$P(VADM(5),U,2),1:"SEX UNKNOWN")
RACE(DFN) ; Patient RACE TIU*148
N TIUI
I '$D(VADM(12)) D DEM(DFN,.VADM)
I +$G(VADM(12))=1 S X=$P($G(VADM(12,1)),U,2)
I +$G(VADM(12))>1 D
. S X=$P($G(VADM(12,1)),U,2) F TIUI=2:1:VADM(12) D
. . S X=X_", "_$P($G(VADM(12,TIUI)),U,2)
I +$G(VADM(12))=0,$P(VADM(8),U,2)="" S X="RACE UNKNOWN"
I +$G(VADM(12))=0,$P(VADM(8),U,2)]"" S X=$P(VADM(8),U,2)
Q X
ETHNIC(DFN) ; Patient ETHNICITY TIU*148
N TIUI
I '$D(VADM(11,1)) D DEM(DFN,.VADM)
I +$G(VADM(11))=0 S X="ETHNICITY UNKNOWN"
I +$G(VADM(11))=1 S X=$P($G(VADM(11,1)),U,2)
I +$G(VADM(11))>1 D
. S X=$P($G(VADM(11,1)),U,2) F TIUI=2:1:VADM(11) D
. . S X=X_", "_$P($G(VADM(11,TIUI)),U,2)
I +$G(VADM(11))=0 S X="ETHNICITY UNKNOWN"
Q X
HEIGHT(DFN) ; Gets most recent Height from VITALS
Q $$DOVITALS(DFN,"HT")
WEIGHT(DFN) ; Gets most recent Weight from VITALS
Q $$DOVITALS(DFN,"WT")
TEMP(DFN) ; Gets most recent Temperature from VITALS
Q $$DOVITALS(DFN,"T")
PULSE(DFN) ; Gets most recent Pulse from VITALS
Q $$DOVITALS(DFN,"P")
RESP(DFN) ; Gets most recent Respiration from VITALS
Q $$DOVITALS(DFN,"R")
BP(DFN) ; Gets most recent Blood Pressure from VITALS
Q $$DOVITALS(DFN,"BP")
PAIN(DFN) ; Gets most recent Pain score from VITALS
Q $$DOVITALS(DFN,"PN")
DOVITALS(DFN,TIUVITC) ; INTERNAL ROUTINE TO GET SPECIFIED VITALS (**34**)
N TIUVIT,TIUVT,TIUVDT,TIUVDA,TIUY,VDT,TIUI,TIUCWRAP,TIUMAXW
N TIUVCNT,TIUVCNT2,TIUVDONE,TIUVDATE,TIUY1,TIUVTEMP,CONV
D VITALS(.TIUVIT,DFN,TIUVITC)
S (TIUVDT,TIUVDONE,TIUVCNT)=0
F S TIUVDT=$O(TIUVIT(TIUVITC,TIUVDT)) Q:+TIUVDT'>0!TIUVDONE D
. S TIUVDA=0
. F S TIUVDA=$O(TIUVIT(TIUVITC,TIUVDT,TIUVDA)) Q:+TIUVDA'>0!TIUVDONE D
. . I $D(TIUVDATE),TIUVDATE'=TIUVDT S TIUVDONE=1
. . E D
. . . S TIUVDATE=TIUVDT,TIUVCNT=TIUVCNT+1
. . . S TIUVTEMP=$G(TIUVIT(TIUVITC,TIUVDT,TIUVDA))
. . . S VDT=$$DATE^TIULS($P(TIUVTEMP,U,1),"MM/DD/CCYY HR:MIN")
. . . S TIUY=$P(TIUVTEMP,U,8)
. . . I TIUVITC="WT" D
. . . . Q:+TIUY'>0
. . . . S CONV=$J((+TIUY/2.2),3,1)
. . . . S TIUY=TIUY_" lb ["_CONV_" kg]"
. . . I TIUVITC="HT" D
. . . . Q:+TIUY'>0
. . . . S CONV=$J((+TIUY*2.54),3,1)
. . . . S TIUY=TIUY_" in ["_CONV_" cm]"
. . . I TIUVITC="T" D
. . . . Q:+TIUY'>0
. . . . S CONV=+TIUY-32
. . . . S CONV=$J((CONV*(5/9)),3,1)
. . . . S TIUY=TIUY_" F ["_CONV_" C]"
. . . S TIUY=TIUY_" ("_VDT
. . . S TIUCWRAP=$L(TIUY)+17
. . . I TIUVCNT=1 S TIUY1=TIUY_")",TIUMAXW=59
. . . E S TIUY=" "_TIUY,TIUMAXW=74
. . . S TIUVTEMP=$P(TIUVTEMP,U,17)
. . . I $L(TIUVTEMP)>0 D
. . . . S TIUVTEMP=", "_TIUVTEMP
. . . . F S TIUI=$F(TIUVTEMP,";") Q:TIUI'>0 D
. . . . . S TIUVTEMP=$E(TIUVTEMP,1,TIUI-2)_", "_$E(TIUVTEMP,TIUI,999)
. . . S TIUY=TIUY_TIUVTEMP_")"
. . . I $L(TIUY)<TIUMAXW S TIUVITMP(TIUVCNT,0)=TIUY
. . . E D ; Wrap the line if it's too long
. . . . S TIUVCNT2=0,TIUVTEMP="",$P(TIUVTEMP," ",TIUCWRAP)=" "
. . . . F Q:$L(TIUY)'>0 D
. . . . . F TIUI=TIUMAXW:-1:1 Q:$E(TIUY,TIUI,TIUI+1)=", "
. . . . . I TIUI>1 D
. . . . . . S TIUVITMP(TIUVCNT+TIUVCNT2,0)=$E(TIUY,1,TIUI)
. . . . . . S TIUVCNT2=TIUVCNT2+.01
. . . . . . S TIUY=TIUVTEMP_$E(TIUY,TIUI+2,999)
. . . . . E D
. . . . . . S TIUVITMP(TIUVCNT+TIUVCNT2,0)=TIUY
. . . . . . S TIUY=""
I TIUVCNT<2 D
. S TIUY=$G(TIUY1)
. K TIUVITMP
E S TIUY="~@TIUVITMP"
Q $G(TIUY)
VITALS(TIUY,DFN,GMRVSTR,TIUEDT,TIULDT,TIUOCC) ; Vital measurements
N TIUVT,TIUVDT,TIUVDA K ^UTILITY($J,"GMRVD")
S GMRVSTR(0)=$G(TIUEDT)_U_$G(TIULDT)_U_$G(TIUOCC,1)_"^0"
I $L($T(EN1^GMRVUT0)) D EN1^GMRVUT0
I +$D(^UTILITY($J,"GMRVD")) D
. S TIUVT=""
. F S TIUVT=$O(^UTILITY($J,"GMRVD",TIUVT)) Q:TIUVT']"" D
. . S TIUVDT=0
. . F S TIUVDT=$O(^UTILITY($J,"GMRVD",TIUVT,TIUVDT)) Q:+TIUVDT'>0 D
. . . S TIUVDA=0
. . . F S TIUVDA=$O(^UTILITY($J,"GMRVD",TIUVT,TIUVDT,TIUVDA)) Q:+TIUVDA'>0 D
. . . . S TIUY(TIUVT,TIUVDT,TIUVDA)=$G(^UTILITY($J,"GMRVD",TIUVT,TIUVDT,TIUVDA))
K ^UTILITY($J,"GMRVD")
Q
LIPIDS(TIUY,DFN,TIUEDT,TIULDT) ; Get LIPID profile
N TIUTST,TIUI,TIURY,TIUDT,TIULDT
S TIUTST=$O(^LAB(60,"B","LIPID PROFILE",0))
I '+$G(TIUTST) Q
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUTST)
I '$D(TIUY)!($G(TIUY(1))="No Lab Data") Q
S TIUI=0 F S TIUI=$O(@TIUY@(TIUI)) Q:+TIUI'>0 D
. S TIUTST=$$MAPPER($P(@TIUY@(TIUI),U,17)),TIUDT=+@TIUY@(TIUI)
. S:TIUDT'=+$G(TIULDT) TIURY("BASELINE LIPID PROFILES",TIUDT)=$$DATE^TIULS(TIUDT,"MM/DD/YY")
. S TIURY(TIUTST,TIUDT)=$P(@TIUY@(TIUI),U,4)
F TIUI="CHYLOMI","TURBID","VLDL" K TIURY(TIUI)
K @TIUY
I $D(TIURY) M TIUY=TIURY
Q
MAPPER(TIUX,TIUI) ; Remap test names
N TIUNM,Y S TIUNM("CHOL","TOTAL CHOLESTEROL")=""
S (TIUNM("HDL","HDL CHOLESTEROL"),TIUNM("LDL","LDL CHOLESTEROL"))=""
S TIUNM("TRIGLYC","TRIGLYCERIDES")=""
S Y=$O(TIUNM(TIUX,"")) I Y']"" S Y=TIUX
Q Y
TSHT4(DFN,TIUEDT,TIULDT) ; Get TSH/T4
N TIUY,TIUTSH,TIUT4 S TIUTSH=+$O(^LAB(60,"B","TSH",0))
S TIUT4=+$O(^LAB(60,"B","T-4",0))
I '+$G(TIUTSH)!'+$G(TIUT4) G TSHX
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUTSH)
S TIUTSH=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUT4)
S TIUT4=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
S TIUY=TIUTSH_"/"_TIUT4
TSHX Q $G(TIUY)
SGOT(DFN,TIUEDT,TIULDT) ; Get SGOT
N TIUY,TIUSGOT S TIUSGOT=+$O(^LAB(60,"B","SGOT",0))
I '+$G(TIUSGOT) Q
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUSGOT)
S TIUSGOT=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
SGOTX Q $G(TIUSGOT)
HGBA1C(DFN,TIUEDT,TIULDT) ; Get Hemoglobin A1C
N TIUY,TIUHGB S TIUHGB=+$O(^LAB(60,"B","HEMOGLOBIN A1C",0))
I '+$G(TIUHGB) G HGBX
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUHGB)
S TIUHGB=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
HGBX Q $G(TIUHGB)
URICACID(DFN,TIUEDT,TIULDT) ; Get Uric Acid
N TIUY,TIUURIC S TIUURIC=+$O(^LAB(60,"B","URIC ACID",0))
I '+$G(TIUURIC) G URICX
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUURIC)
S TIUURIC=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
URICX Q $G(TIUURIC)
FBG(DFN,TIUEDT,TIULDT) ; Get FBG
N TIUY,TIUFBG S TIUFBG=+$O(^LAB(60,"B","FBS",0))
I '+$G(TIUFBG) G FBGX
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUFBG)
S TIUFBG=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
I $D(TIUY)#2 K @TIUY
FBGX Q $G(TIUFBG)
ADM(DFN) ;Current Admission Date/Time
N VAIN,J
D INP^VADPT
S J=$P(VAIN(7),U,2),J(1)=$P(J,"@",1),J(2)=$P(J,"@",2),J(3)=$E(J(2),1,5),Y=J(1)_" "_J(3) K J
ADMX Q Y
TODAY() ;Today's Date
N X,Y
S X=$G(DT) I X'="" S Y=X D DD^%DT
TODAYX Q Y
NOW() ;Current Date/Time
NOWX Q $$DATE^TIULS($$NOW^TIULC,"AMTH DD, CCYY HR:MIN")
TIULO ; SLC/JER - Embedded Objects ;29-Aug-2014 11:06;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**34,70,101,148,204,1013**;Jun 20, 1997;Build 33
DEM(DFN,VADM) ; Calls DEM^VADPT
+1 DO DEM^VADPT
+2 QUIT
NAME(DFN) ; Patient NAME
+1 IF '$DATA(VADM(1))
DO DEM(DFN,.VADM)
+2 QUIT $SELECT(VADM(1)]"":VADM(1),1:"NAME UNKNOWN")
SSN(DFN) ; Patient SSN
+1 NEW SSN
+2 IF '$DATA(VADM(2))
DO DEM(DFN,.VADM)
+3 ;IHS/MSC/MGH Updated to block out SSN patch 1013
+4 SET SSN=$PIECE(VADM(2),U,2)
+5 IF SSN'=""
SET SSN="XXX-XX-"_$PIECE(SSN,"-",3)
+6 QUIT $SELECT(SSN]"":SSN,1:"SSN UNKNOWN")
AGE(DFN) ; Patient AGE
+1 IF '$DATA(VADM(4))
DO DEM(DFN,.VADM)
+2 QUIT $SELECT(VADM(4)]"":VADM(4),1:"AGE UNKNOWN")
DOB(DFN) ; Patient DATE OF BIRTH
+1 IF '$DATA(VADM(3))
DO DEM(DFN,.VADM)
+2 QUIT $SELECT($PIECE(VADM(3),U,2)]"":$PIECE(VADM(3),U,2),1:"DOB UNKNOWN")
DOD(DFN) ; Patient DATE OF DEATH
+1 IF '$DATA(VADM(6))
DO DEM(DFN,.VADM)
+2 QUIT $SELECT($PIECE(VADM(6),U,2)]"":$PIECE(VADM(6),U,2),1:"DATE OF DEATH UNKNOWN")
SEX(DFN) ; Patient SEX
+1 IF '$DATA(VADM(5))
DO DEM(DFN,.VADM)
+2 QUIT $SELECT($PIECE(VADM(5),U,2)]"":$PIECE(VADM(5),U,2),1:"SEX UNKNOWN")
RACE(DFN) ; Patient RACE TIU*148
+1 NEW TIUI
+2 IF '$DATA(VADM(12))
DO DEM(DFN,.VADM)
+3 IF +$GET(VADM(12))=1
SET X=$PIECE($GET(VADM(12,1)),U,2)
+4 IF +$GET(VADM(12))>1
Begin DoDot:1
+5 SET X=$PIECE($GET(VADM(12,1)),U,2)
FOR TIUI=2:1:VADM(12)
Begin DoDot:2
+6 SET X=X_", "_$PIECE($GET(VADM(12,TIUI)),U,2)
End DoDot:2
End DoDot:1
+7 IF +$GET(VADM(12))=0
IF $PIECE(VADM(8),U,2)=""
SET X="RACE UNKNOWN"
+8 IF +$GET(VADM(12))=0
IF $PIECE(VADM(8),U,2)]""
SET X=$PIECE(VADM(8),U,2)
+9 QUIT X
ETHNIC(DFN) ; Patient ETHNICITY TIU*148
+1 NEW TIUI
+2 IF '$DATA(VADM(11,1))
DO DEM(DFN,.VADM)
+3 IF +$GET(VADM(11))=0
SET X="ETHNICITY UNKNOWN"
+4 IF +$GET(VADM(11))=1
SET X=$PIECE($GET(VADM(11,1)),U,2)
+5 IF +$GET(VADM(11))>1
Begin DoDot:1
+6 SET X=$PIECE($GET(VADM(11,1)),U,2)
FOR TIUI=2:1:VADM(11)
Begin DoDot:2
+7 SET X=X_", "_$PIECE($GET(VADM(11,TIUI)),U,2)
End DoDot:2
End DoDot:1
+8 IF +$GET(VADM(11))=0
SET X="ETHNICITY UNKNOWN"
+9 QUIT X
HEIGHT(DFN) ; Gets most recent Height from VITALS
+1 QUIT $$DOVITALS(DFN,"HT")
WEIGHT(DFN) ; Gets most recent Weight from VITALS
+1 QUIT $$DOVITALS(DFN,"WT")
TEMP(DFN) ; Gets most recent Temperature from VITALS
+1 QUIT $$DOVITALS(DFN,"T")
PULSE(DFN) ; Gets most recent Pulse from VITALS
+1 QUIT $$DOVITALS(DFN,"P")
RESP(DFN) ; Gets most recent Respiration from VITALS
+1 QUIT $$DOVITALS(DFN,"R")
BP(DFN) ; Gets most recent Blood Pressure from VITALS
+1 QUIT $$DOVITALS(DFN,"BP")
PAIN(DFN) ; Gets most recent Pain score from VITALS
+1 QUIT $$DOVITALS(DFN,"PN")
DOVITALS(DFN,TIUVITC) ; INTERNAL ROUTINE TO GET SPECIFIED VITALS (**34**)
+1 NEW TIUVIT,TIUVT,TIUVDT,TIUVDA,TIUY,VDT,TIUI,TIUCWRAP,TIUMAXW
+2 NEW TIUVCNT,TIUVCNT2,TIUVDONE,TIUVDATE,TIUY1,TIUVTEMP,CONV
+3 DO VITALS(.TIUVIT,DFN,TIUVITC)
+4 SET (TIUVDT,TIUVDONE,TIUVCNT)=0
+5 FOR
SET TIUVDT=$ORDER(TIUVIT(TIUVITC,TIUVDT))
IF +TIUVDT'>0!TIUVDONE
QUIT
Begin DoDot:1
+6 SET TIUVDA=0
+7 FOR
SET TIUVDA=$ORDER(TIUVIT(TIUVITC,TIUVDT,TIUVDA))
IF +TIUVDA'>0!TIUVDONE
QUIT
Begin DoDot:2
+8 IF $DATA(TIUVDATE)
IF TIUVDATE'=TIUVDT
SET TIUVDONE=1
+9 IF '$TEST
Begin DoDot:3
+10 SET TIUVDATE=TIUVDT
SET TIUVCNT=TIUVCNT+1
+11 SET TIUVTEMP=$GET(TIUVIT(TIUVITC,TIUVDT,TIUVDA))
+12 SET VDT=$$DATE^TIULS($PIECE(TIUVTEMP,U,1),"MM/DD/CCYY HR:MIN")
+13 SET TIUY=$PIECE(TIUVTEMP,U,8)
+14 IF TIUVITC="WT"
Begin DoDot:4
+15 IF +TIUY'>0
QUIT
+16 SET CONV=$JUSTIFY((+TIUY/2.2),3,1)
+17 SET TIUY=TIUY_" lb ["_CONV_" kg]"
End DoDot:4
+18 IF TIUVITC="HT"
Begin DoDot:4
+19 IF +TIUY'>0
QUIT
+20 SET CONV=$JUSTIFY((+TIUY*2.54),3,1)
+21 SET TIUY=TIUY_" in ["_CONV_" cm]"
End DoDot:4
+22 IF TIUVITC="T"
Begin DoDot:4
+23 IF +TIUY'>0
QUIT
+24 SET CONV=+TIUY-32
+25 SET CONV=$JUSTIFY((CONV*(5/9)),3,1)
+26 SET TIUY=TIUY_" F ["_CONV_" C]"
End DoDot:4
+27 SET TIUY=TIUY_" ("_VDT
+28 SET TIUCWRAP=$LENGTH(TIUY)+17
+29 IF TIUVCNT=1
SET TIUY1=TIUY_")"
SET TIUMAXW=59
+30 IF '$TEST
SET TIUY=" "_TIUY
SET TIUMAXW=74
+31 SET TIUVTEMP=$PIECE(TIUVTEMP,U,17)
+32 IF $LENGTH(TIUVTEMP)>0
Begin DoDot:4
+33 SET TIUVTEMP=", "_TIUVTEMP
+34 FOR
SET TIUI=$FIND(TIUVTEMP,";")
IF TIUI'>0
QUIT
Begin DoDot:5
+35 SET TIUVTEMP=$EXTRACT(TIUVTEMP,1,TIUI-2)_", "_$EXTRACT(TIUVTEMP,TIUI,999)
End DoDot:5
End DoDot:4
+36 SET TIUY=TIUY_TIUVTEMP_")"
+37 IF $LENGTH(TIUY)<TIUMAXW
SET TIUVITMP(TIUVCNT,0)=TIUY
+38 ; Wrap the line if it's too long
IF '$TEST
Begin DoDot:4
+39 SET TIUVCNT2=0
SET TIUVTEMP=""
SET $PIECE(TIUVTEMP," ",TIUCWRAP)=" "
+40 FOR
IF $LENGTH(TIUY)'>0
QUIT
Begin DoDot:5
+41 FOR TIUI=TIUMAXW:-1:1
IF $EXTRACT(TIUY,TIUI,TIUI+1)=", "
QUIT
+42 IF TIUI>1
Begin DoDot:6
+43 SET TIUVITMP(TIUVCNT+TIUVCNT2,0)=$EXTRACT(TIUY,1,TIUI)
+44 SET TIUVCNT2=TIUVCNT2+.01
+45 SET TIUY=TIUVTEMP_$EXTRACT(TIUY,TIUI+2,999)
End DoDot:6
+46 IF '$TEST
Begin DoDot:6
+47 SET TIUVITMP(TIUVCNT+TIUVCNT2,0)=TIUY
+48 SET TIUY=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 IF TIUVCNT<2
Begin DoDot:1
+50 SET TIUY=$GET(TIUY1)
+51 KILL TIUVITMP
End DoDot:1
+52 IF '$TEST
SET TIUY="~@TIUVITMP"
+53 QUIT $GET(TIUY)
VITALS(TIUY,DFN,GMRVSTR,TIUEDT,TIULDT,TIUOCC) ; Vital measurements
+1 NEW TIUVT,TIUVDT,TIUVDA
KILL ^UTILITY($JOB,"GMRVD")
+2 SET GMRVSTR(0)=$GET(TIUEDT)_U_$GET(TIULDT)_U_$GET(TIUOCC,1)_"^0"
+3 IF $LENGTH($TEXT(EN1^GMRVUT0))
DO EN1^GMRVUT0
+4 IF +$DATA(^UTILITY($JOB,"GMRVD"))
Begin DoDot:1
+5 SET TIUVT=""
+6 FOR
SET TIUVT=$ORDER(^UTILITY($JOB,"GMRVD",TIUVT))
IF TIUVT']""
QUIT
Begin DoDot:2
+7 SET TIUVDT=0
+8 FOR
SET TIUVDT=$ORDER(^UTILITY($JOB,"GMRVD",TIUVT,TIUVDT))
IF +TIUVDT'>0
QUIT
Begin DoDot:3
+9 SET TIUVDA=0
+10 FOR
SET TIUVDA=$ORDER(^UTILITY($JOB,"GMRVD",TIUVT,TIUVDT,TIUVDA))
IF +TIUVDA'>0
QUIT
Begin DoDot:4
+11 SET TIUY(TIUVT,TIUVDT,TIUVDA)=$GET(^UTILITY($JOB,"GMRVD",TIUVT,TIUVDT,TIUVDA))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL ^UTILITY($JOB,"GMRVD")
+13 QUIT
LIPIDS(TIUY,DFN,TIUEDT,TIULDT) ; Get LIPID profile
+1 NEW TIUTST,TIUI,TIURY,TIUDT,TIULDT
+2 SET TIUTST=$ORDER(^LAB(60,"B","LIPID PROFILE",0))
+3 IF '+$GET(TIUTST)
QUIT
+4 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUTST)
+5 IF '$DATA(TIUY)!($GET(TIUY(1))="No Lab Data")
QUIT
+6 SET TIUI=0
FOR
SET TIUI=$ORDER(@TIUY@(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+7 SET TIUTST=$$MAPPER($PIECE(@TIUY@(TIUI),U,17))
SET TIUDT=+@TIUY@(TIUI)
+8 IF TIUDT'=+$GET(TIULDT)
SET TIURY("BASELINE LIPID PROFILES",TIUDT)=$$DATE^TIULS(TIUDT,"MM/DD/YY")
+9 SET TIURY(TIUTST,TIUDT)=$PIECE(@TIUY@(TIUI),U,4)
End DoDot:1
+10 FOR TIUI="CHYLOMI","TURBID","VLDL"
KILL TIURY(TIUI)
+11 KILL @TIUY
+12 IF $DATA(TIURY)
MERGE TIUY=TIURY
+13 QUIT
MAPPER(TIUX,TIUI) ; Remap test names
+1 NEW TIUNM,Y
SET TIUNM("CHOL","TOTAL CHOLESTEROL")=""
+2 SET (TIUNM("HDL","HDL CHOLESTEROL"),TIUNM("LDL","LDL CHOLESTEROL"))=""
+3 SET TIUNM("TRIGLYC","TRIGLYCERIDES")=""
+4 SET Y=$ORDER(TIUNM(TIUX,""))
IF Y']""
SET Y=TIUX
+5 QUIT Y
TSHT4(DFN,TIUEDT,TIULDT) ; Get TSH/T4
+1 NEW TIUY,TIUTSH,TIUT4
SET TIUTSH=+$ORDER(^LAB(60,"B","TSH",0))
+2 SET TIUT4=+$ORDER(^LAB(60,"B","T-4",0))
+3 IF '+$GET(TIUTSH)!'+$GET(TIUT4)
GOTO TSHX
+4 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUTSH)
+5 SET TIUTSH=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+6 IF $DATA(TIUY)#2
KILL @TIUY
+7 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUT4)
+8 SET TIUT4=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+9 IF $DATA(TIUY)#2
KILL @TIUY
+10 SET TIUY=TIUTSH_"/"_TIUT4
TSHX QUIT $GET(TIUY)
SGOT(DFN,TIUEDT,TIULDT) ; Get SGOT
+1 NEW TIUY,TIUSGOT
SET TIUSGOT=+$ORDER(^LAB(60,"B","SGOT",0))
+2 IF '+$GET(TIUSGOT)
QUIT
+3 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUSGOT)
+4 SET TIUSGOT=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+5 IF $DATA(TIUY)#2
KILL @TIUY
SGOTX QUIT $GET(TIUSGOT)
HGBA1C(DFN,TIUEDT,TIULDT) ; Get Hemoglobin A1C
+1 NEW TIUY,TIUHGB
SET TIUHGB=+$ORDER(^LAB(60,"B","HEMOGLOBIN A1C",0))
+2 IF '+$GET(TIUHGB)
GOTO HGBX
+3 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUHGB)
+4 SET TIUHGB=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+5 IF $DATA(TIUY)#2
KILL @TIUY
HGBX QUIT $GET(TIUHGB)
URICACID(DFN,TIUEDT,TIULDT) ; Get Uric Acid
+1 NEW TIUY,TIUURIC
SET TIUURIC=+$ORDER(^LAB(60,"B","URIC ACID",0))
+2 IF '+$GET(TIUURIC)
GOTO URICX
+3 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUURIC)
+4 SET TIUURIC=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+5 IF $DATA(TIUY)#2
KILL @TIUY
URICX QUIT $GET(TIUURIC)
FBG(DFN,TIUEDT,TIULDT) ; Get FBG
+1 NEW TIUY,TIUFBG
SET TIUFBG=+$ORDER(^LAB(60,"B","FBS",0))
+2 IF '+$GET(TIUFBG)
GOTO FBGX
+3 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUFBG)
+4 SET TIUFBG=$SELECT($DATA(TIUY)#2:$PIECE($GET(@TIUY@(1)),U,4),1:"____")
+5 IF $DATA(TIUY)#2
KILL @TIUY
FBGX QUIT $GET(TIUFBG)
ADM(DFN) ;Current Admission Date/Time
+1 NEW VAIN,J
+2 DO INP^VADPT
+3 SET J=$PIECE(VAIN(7),U,2)
SET J(1)=$PIECE(J,"@",1)
SET J(2)=$PIECE(J,"@",2)
SET J(3)=$EXTRACT(J(2),1,5)
SET Y=J(1)_" "_J(3)
KILL J
ADMX QUIT Y
TODAY() ;Today's Date
+1 NEW X,Y
+2 SET X=$GET(DT)
IF X'=""
SET Y=X
DO DD^%DT
TODAYX QUIT Y
NOW() ;Current Date/Time
NOWX QUIT $$DATE^TIULS($$NOW^TIULC,"AMTH DD, CCYY HR:MIN")
