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

TIULO.m

Go to the documentation of this file. 
  1. TIULO ;SLC/JER - Embedded Objects ;Mar 18, 2021@06:56:30
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**34,70,101,148,204,341,345**;Jun 20, 1997;Build 3
  1. DEM(DFN,VADM) ; Calls DEM^VADPT
  1.  N VAROOT
  1.  D DEM^VADPT
  1.  Q
  1. NAME(DFN) ; Patient NAME
  1.  I '$D(VADM(1)) D DEM(DFN,.VADM)
  1.  Q $S(VADM(1)]"":VADM(1),1:"NAME UNKNOWN")
  1. SSN(DFN) ; Patient SSN
  1.  I '$D(VADM(2)) D DEM(DFN,.VADM)
  1.  Q $S($P(VADM(2),U,2)]"":$P(VADM(2),U,2),1:"SSN UNKNOWN")
  1. AGE(DFN) ; Patient AGE
  1.  I '$D(VADM(4)) D DEM(DFN,.VADM)
  1.  Q $S(VADM(4)]"":VADM(4),1:"AGE UNKNOWN")
  1. DOB(DFN) ; Patient DATE OF BIRTH
  1.  I '$D(VADM(3)) D DEM(DFN,.VADM)
  1.  Q $S($P(VADM(3),U,2)]"":$P(VADM(3),U,2),1:"DOB UNKNOWN")
  1. DOD(DFN) ; Patient DATE OF DEATH
  1.  I '$D(VADM(6)) D DEM(DFN,.VADM)
  1.  Q $S($P(VADM(6),U,2)]"":$P(VADM(6),U,2),1:"DATE OF DEATH UNKNOWN")
  1. SEX(DFN) ; Patient SEX
  1.  I '$D(VADM(5)) D DEM(DFN,.VADM)
  1.  Q $S($P(VADM(5),U,2)]"":$P(VADM(5),U,2),1:"SEX UNKNOWN")
  1. RACE(DFN) ; Patient RACE TIU*148
  1.  N TIUI
  1.  I '$D(VADM(12)) D DEM(DFN,.VADM)
  1.  I +$G(VADM(12))=1 S X=$P($G(VADM(12,1)),U,2)
  1.  I +$G(VADM(12))>1 D
  1.  . S X=$P($G(VADM(12,1)),U,2) F TIUI=2:1:VADM(12) D
  1.  . . S X=X_", "_$P($G(VADM(12,TIUI)),U,2)
  1.  I +$G(VADM(12))=0,$P(VADM(8),U,2)="" S X="RACE UNKNOWN"
  1.  I +$G(VADM(12))=0,$P(VADM(8),U,2)]"" S X=$P(VADM(8),U,2)
  1.  Q X
  1. ETHNIC(DFN) ; Patient ETHNICITY  TIU*148
  1.  N TIUI
  1.  I '$D(VADM(11,1)) D DEM(DFN,.VADM)
  1.  I +$G(VADM(11))=0 S X="ETHNICITY UNKNOWN"
  1.  I +$G(VADM(11))=1 S X=$P($G(VADM(11,1)),U,2)
  1.  I +$G(VADM(11))>1 D
  1.  . S X=$P($G(VADM(11,1)),U,2) F TIUI=2:1:VADM(11) D
  1.  . . S X=X_", "_$P($G(VADM(11,TIUI)),U,2)
  1.  I +$G(VADM(11))=0 S X="ETHNICITY UNKNOWN"
  1.  Q X
  1. HEIGHT(DFN) ; Gets most recent Height from VITALS
  1.  Q $$DOVITALS(DFN,"HT")
  1. WEIGHT(DFN) ; Gets most recent Weight from VITALS
  1.  Q $$DOVITALS(DFN,"WT")
  1. TEMP(DFN) ; Gets most recent Temperature from VITALS
  1.  Q $$DOVITALS(DFN,"T")
  1. PULSE(DFN) ; Gets most recent Pulse from VITALS
  1.  Q $$DOVITALS(DFN,"P")
  1. PO2(DFN) ; Get most recent Pulse Oximeter from VITALS - ajb *341
  1.  Q $$DOVITALS(DFN,"PO2")
  1. RESP(DFN) ; Gets most recent Respiration from VITALS
  1.  Q $$DOVITALS(DFN,"R")
  1. BP(DFN) ; Gets most recent Blood Pressure from VITALS
  1.  Q $$DOVITALS(DFN,"BP")
  1. PAIN(DFN) ; Gets most recent Pain score from VITALS
  1.  Q $$DOVITALS(DFN,"PN")
  1. DOVITALS(DFN,TIUVITC) ; INTERNAL ROUTINE TO GET SPECIFIED VITALS (**34**)
  1.  N TIUVIT,TIUVT,TIUVDT,TIUVDA,TIUY,VDT,TIUI,TIUCWRAP,TIUMAXW
  1.  N TIUVCNT,TIUVCNT2,TIUVDONE,TIUVDATE,TIUY1,TIUVTEMP,CONV
  1.  D VITALS(.TIUVIT,DFN,TIUVITC)
  1.  S (TIUVDT,TIUVDONE,TIUVCNT)=0
  1.  F  S TIUVDT=$O(TIUVIT(TIUVITC,TIUVDT)) Q:+TIUVDT'>0!TIUVDONE  D
  1.  . S TIUVDA=0
  1.  . F  S TIUVDA=$O(TIUVIT(TIUVITC,TIUVDT,TIUVDA)) Q:+TIUVDA'>0!TIUVDONE  D
  1.  . . I $D(TIUVDATE),TIUVDATE'=TIUVDT S TIUVDONE=1
  1.  . . E  D
  1.  . . . S TIUVDATE=TIUVDT,TIUVCNT=TIUVCNT+1
  1.  . . . S TIUVTEMP=$G(TIUVIT(TIUVITC,TIUVDT,TIUVDA))
  1.  . . . S VDT=$$DATE^TIULS($P(TIUVTEMP,U,1),"MM/DD/CCYY HR:MIN")
  1.  . . . S TIUY=$P(TIUVTEMP,U,8)
  1.  . . . I TIUVITC="PO2" Q:+TIUY'>0  S TIUY=TIUY_"%" ; ajb *341
  1.  . . . I TIUVITC="WT" D
  1.  . . . . Q:+TIUY'>0
  1.  . . . . S CONV=$J((+TIUY/2.20462262),0,2)     ;P345
  1.  . . . . S TIUY=TIUY_" lb ["_CONV_" kg]"
  1.  . . . I TIUVITC="HT" D
  1.  . . . . Q:+TIUY'>0
  1.  . . . . S CONV=$J((+TIUY*2.54),3,1)
  1.  . . . . S TIUY=TIUY_" in ["_CONV_" cm]"
  1.  . . . I TIUVITC="T" D
  1.  . . . . Q:+TIUY'>0
  1.  . . . . S CONV=+TIUY-32
  1.  . . . . S CONV=$J((CONV*(5/9)),3,1)
  1.  . . . . S TIUY=TIUY_" F ["_CONV_" C]"
  1.  . . . S TIUY=TIUY_" ("_VDT
  1.  . . . S TIUCWRAP=$L(TIUY)+17
  1.  . . . I TIUVCNT=1 S TIUY1=TIUY_")",TIUMAXW=59
  1.  . . . E  S TIUY="               "_TIUY,TIUMAXW=74
  1.  . . . S TIUVTEMP=$P(TIUVTEMP,U,17)
  1.  . . . I $L(TIUVTEMP)>0  D
  1.  . . . . S TIUVTEMP=", "_TIUVTEMP
  1.  . . . . F  S TIUI=$F(TIUVTEMP,";") Q:TIUI'>0  D
  1.  . . . . . S TIUVTEMP=$E(TIUVTEMP,1,TIUI-2)_", "_$E(TIUVTEMP,TIUI,999)
  1.  . . . S TIUY=TIUY_TIUVTEMP_")"
  1.  . . . I $L(TIUY)<TIUMAXW S TIUVITMP(TIUVCNT,0)=TIUY
  1.  . . . E  D  ; Wrap the line if it's too long
  1.  . . . . S TIUVCNT2=0,TIUVTEMP="",$P(TIUVTEMP," ",TIUCWRAP)=" "
  1.  . . . . F  Q:$L(TIUY)'>0  D
  1.  . . . . . F TIUI=TIUMAXW:-1:1  Q:$E(TIUY,TIUI,TIUI+1)=", "
  1.  . . . . . I TIUI>1 D
  1.  . . . . . . S TIUVITMP(TIUVCNT+TIUVCNT2,0)=$E(TIUY,1,TIUI)
  1.  . . . . . . S TIUVCNT2=TIUVCNT2+.01
  1.  . . . . . . S TIUY=TIUVTEMP_$E(TIUY,TIUI+2,999)
  1.  . . . . . E  D
  1.  . . . . . . S TIUVITMP(TIUVCNT+TIUVCNT2,0)=TIUY
  1.  . . . . . . S TIUY=""
  1.  I TIUVCNT<2 D
  1.  . S TIUY=$G(TIUY1)
  1.  . K TIUVITMP
  1.  E  S TIUY="~@TIUVITMP"
  1.  Q $G(TIUY)
  1. VITALS(TIUY,DFN,GMRVSTR,TIUEDT,TIULDT,TIUOCC) ; Vital measurements
  1.  N TIUVT,TIUVDT,TIUVDA K ^UTILITY($J,"GMRVD")
  1.  S GMRVSTR(0)=$G(TIUEDT)_U_$G(TIULDT)_U_$G(TIUOCC,1)_"^0"
  1.  I $L($T(EN1^GMRVUT0)) D EN1^GMRVUT0
  1.  I +$D(^UTILITY($J,"GMRVD")) D
  1.  . S TIUVT=""
  1.  . F  S TIUVT=$O(^UTILITY($J,"GMRVD",TIUVT)) Q:TIUVT']""  D
  1.  . . S TIUVDT=0
  1.  . . F  S TIUVDT=$O(^UTILITY($J,"GMRVD",TIUVT,TIUVDT)) Q:+TIUVDT'>0  D
  1.  . . . S TIUVDA=0
  1.  . . . F  S TIUVDA=$O(^UTILITY($J,"GMRVD",TIUVT,TIUVDT,TIUVDA)) Q:+TIUVDA'>0  D
  1.  . . . . S TIUY(TIUVT,TIUVDT,TIUVDA)=$G(^UTILITY($J,"GMRVD",TIUVT,TIUVDT,TIUVDA))
  1.  K ^UTILITY($J,"GMRVD")
  1.  Q
  1. LIPIDS(TIUY,DFN,TIUEDT,TIULDT) ; Get LIPID profile
  1.  N TIUTST,TIUI,TIURY,TIUDT,TIULDT
  1.  S TIUTST=$O(^LAB(60,"B","LIPID PROFILE",0))
  1.  I '+$G(TIUTST) Q
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUTST)
  1.  I '$D(TIUY)!($G(TIUY(1))="No Lab Data") Q
  1.  S TIUI=0 F  S TIUI=$O(@TIUY@(TIUI)) Q:+TIUI'>0  D
  1.  . S TIUTST=$$MAPPER($P(@TIUY@(TIUI),U,17)),TIUDT=+@TIUY@(TIUI)
  1.  . S:TIUDT'=+$G(TIULDT) TIURY("BASELINE LIPID PROFILES",TIUDT)=$$DATE^TIULS(TIUDT,"MM/DD/YY")
  1.  . S TIURY(TIUTST,TIUDT)=$P(@TIUY@(TIUI),U,4)
  1.  F TIUI="CHYLOMI","TURBID","VLDL" K TIURY(TIUI)
  1.  K @TIUY
  1.  I $D(TIURY) M TIUY=TIURY
  1.  Q
  1. MAPPER(TIUX,TIUI) ; Remap test names
  1.  N TIUNM,Y S TIUNM("CHOL","TOTAL CHOLESTEROL")=""
  1.  S (TIUNM("HDL","HDL CHOLESTEROL"),TIUNM("LDL","LDL CHOLESTEROL"))=""
  1.  S TIUNM("TRIGLYC","TRIGLYCERIDES")=""
  1.  S Y=$O(TIUNM(TIUX,"")) I Y']"" S Y=TIUX
  1.  Q Y
  1. TSHT4(DFN,TIUEDT,TIULDT) ; Get TSH/T4
  1.  N TIUY,TIUTSH,TIUT4 S TIUTSH=+$O(^LAB(60,"B","TSH",0))
  1.  S TIUT4=+$O(^LAB(60,"B","T-4",0))
  1.  I '+$G(TIUTSH)!'+$G(TIUT4) G TSHX
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUTSH)
  1.  S TIUTSH=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUT4)
  1.  S TIUT4=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1.  S TIUY=TIUTSH_"/"_TIUT4
  1. TSHX Q $G(TIUY)
  1. SGOT(DFN,TIUEDT,TIULDT) ; Get SGOT
  1.  N TIUY,TIUSGOT S TIUSGOT=+$O(^LAB(60,"B","SGOT",0))
  1.  I '+$G(TIUSGOT) Q
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUSGOT)
  1.  S TIUSGOT=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1. SGOTX Q $G(TIUSGOT)
  1. HGBA1C(DFN,TIUEDT,TIULDT) ; Get Hemoglobin A1C
  1.  N TIUY,TIUHGB S TIUHGB=+$O(^LAB(60,"B","HEMOGLOBIN A1C",0))
  1.  I '+$G(TIUHGB) G HGBX
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUHGB)
  1.  S TIUHGB=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1. HGBX Q $G(TIUHGB)
  1. URICACID(DFN,TIUEDT,TIULDT) ; Get Uric Acid
  1.  N TIUY,TIUURIC S TIUURIC=+$O(^LAB(60,"B","URIC ACID",0))
  1.  I '+$G(TIUURIC) G URICX
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUURIC)
  1.  S TIUURIC=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1. URICX Q $G(TIUURIC)
  1. FBG(DFN,TIUEDT,TIULDT) ; Get FBG
  1.  N TIUY,TIUFBG S TIUFBG=+$O(^LAB(60,"B","FBS",0))
  1.  I '+$G(TIUFBG) G FBGX
  1.  D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUFBG)
  1.  S TIUFBG=$S($D(TIUY)#2:$P($G(@TIUY@(1)),U,4),1:"____")
  1.  I $D(TIUY)#2 K @TIUY
  1. FBGX Q $G(TIUFBG)
  1. ADM(DFN) ;Current Admission Date/Time
  1.  N VAIN,J
  1.  D INP^VADPT
  1.  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
  1. ADMX Q Y
  1. TODAY() ;Today's Date
  1.  N X,Y
  1.  S X=$G(DT) I X'="" S Y=X D DD^%DT
  1. TODAYX Q Y
  1. NOW() ;Current Date/Time
  1. NOWX Q $$DATE^TIULS($$NOW^TIULC,"AMTH DD, CCYY HR:MIN")