BTIULO7 ;IHS/ITSC/LJF - IHS OBJECTS ADDED IN PATCHES;06-Aug-2018 15:33;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**1001,1002,1003,1004,1005,1006,1007,1009,1010,1012,1013,1020**;NOV 04, 2004;Build 7
;IHS/CIA/MGH line up number of labs and only display test name
;Made changes to call ehr 1.1 visit creation
;Patch 1005 Changed lookup for dates without times
;Patch 1006 changed lookup for LAST #VITALS for multiple vitals on one day
;Patch 1006 incorporated reproductive history field changes
;Patch 1007 fixed total time for visit selection
;Patch 1009 fixed reproductive history again and last # measurements
;Patch 1010 added qualifiers
LASTHFC(PAT,CTG,CAP) ;EP - return last factor in category CTG for patient PAT; PATCH 1001
; CAP = 1 if want caption to be returned; = 0 otherwise
NEW CTGN,HF,HFDT,LIST,RESULT,X
I '$G(PAT)!($G(CTG)="") Q ""
S CTGN=$O(^AUTTHF("B",CTG,0)) I 'CTGN Q "" ;ien of category passed
;
S HF=0
F S HF=$O(^AUTTHF("AC",CTGN,HF)) Q:'+HF D ;find health factors in category
. Q:'$D(^AUPNVHF("AA",PAT,HF)) ;quit if patient doesn't have health factor
. S HFDT=$O(^AUPNVHF("AA",PAT,HF,"")) Q:'HFDT ;get visit date for health factor
. S LIST(HFDT)=$O(^AUPNVHF("AA",PAT,HF,HFDT,"")) ;store iens by date
;
I '$O(LIST(0)) Q $S($G(CAP)=1:"No "_CTG_" health factors found for patient",1:"")
S HFDT=$O(LIST(0)) ;find latest date (inverse dates)
S RESULT=$S($G(CAP)=1:"Last "_CTG_" HF: ",1:"")
S RESULT=RESULT_$$GET1^DIQ(9000010.23,LIST(HFDT),.01)
S X=$$GET1^DIQ(9000010.23,LIST(HFDT),.04) ;severity level
S RESULT=RESULT_$S(X]"":" ( "_X_")",1:"")
S RESULT=RESULT_" - "_$$FMTE^XLFDT(9999999-HFDT)
Q RESULT
;
VINS(TARGET) ; returns insurance coverage for current vuecentric visit context; PATCH 1001
; assumes DFN is set
I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
NEW VST,I,X,CNT,RESULT
S CNT=0
S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
D GETINS(.RESULT,VST)
;
K @TARGET
S I=0 F S I=$O(RESULT(I)) Q:'I D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=RESULT(I)
I 'CNT S @TARGET@(1,0)="No Insurance Coverage Found"
Q "~@"_$NA(@TARGET)
;
GETINS(RETURN,VISIT) ;return insurance coverage at time of visit
; VISIT=Visit IEN
;
NEW VDT,LINE,CNT,SEL,IEN,MEDCARE,SEL,INS,PVT,RR,RRE
K RETURN
;
S VDT=+$G(^AUPNVSIT(VISIT,0)) I 'VDT Q
S LINE="",CNT=0
I $$MCR^AUPNPAT(DFN,VDT)=1 D
.S MEDCARE=$$MCR2^BTIULO2(DFN)
.I MEDCARE="" D
..S IEN=$O(^AUPNMCR("B",DFN,0))
..S MEDCARE=$P($G(^AUPNMCR(IEN,0)),U,3)
.F SEL=1:1 S INS=$P(MEDCARE,";",SEL) Q:INS="" D
..S CNT=CNT+1
..S RETURN(CNT)="MEDICARE ("_INS_")"
I $$MCD^AUPNPAT(DFN,VDT)=1 S CNT=CNT+1 S RETURN(CNT)="MEDICAID #"_$$MCD^BTIULO2(DFN)
I $$PI^AUPNPAT(DFN,VDT)=1 D
.S PVT=$$THIRD^BTIULO2(DFN)
.F SEL=1:1 S INS=$P(PVT,";",SEL) Q:INS="" D
..S CNT=CNT+1
..S RETURN(CNT)="PVT INS ("_INS_")"
I $$RR^AUPNPAT(DFN,VDT)=1 D
.S RR=$$RRE^BTIULO2(DFN)
.I RR="" D
..S IEN=$O(^AUPNRRE("B",DFN,0))
..S RR=$P($G(^AUPNRRE(IEN,0)),U,3)
.F SEL=1:1 S INS=$P(RR,";",SEL) Q:INS="" D
..S CNT=CNT+1
..S RETURN(CNT)="RAILROAD ("_INS_")"
Q
;
NLAB(DFN,TIUTST,TIUCNT,BRIEF) ;EP; -- returns last # of current lab result for single test;PATCH 1001
; TIUTST = lab test name; TIUCNT = # of test results to return
;Brief is set to remove caption and only insert test name PATCH 1003
;IHS/CIA/MGH Modified to only display the test name and line up labs better
;UPDATED 1009 FOR MULTIPLE RESULTS ON SAME VISIT
NEW LAB,CAPTION,VDT,IEN,X,TIU,LINE,CNT,DATA,LGTH,ARR,DATE,DATE2,LCNT
K ^TMP("BTIULO",$J)
S LAB=$O(^LAB(60,"B",TIUTST,0)) I LAB="" Q ""
I $G(BRIEF) S CAPTION=$E(TIUTST,1,30)_":" ;PATCH 1003
E S CAPTION="Last "_TIUCNT_" "_$E(TIUTST,1,30)_": "
S (VDT,CNT)=0
F S VDT=$O(^AUPNVLAB("AA",DFN,LAB,VDT)) Q:('VDT)!(CNT=TIUCNT) D
. S IEN=0
. F S IEN=$O(^AUPNVLAB("AA",DFN,LAB,VDT,IEN)) Q:'IEN!(CNT=TIUCNT) D
.. K TIU D ENP^XBDIQ1(9000010.09,IEN,".03:.05;1109;1201","TIU(")
.. Q:TIU(.04)="" ;skip if not resulted
.. S DATE=$$GET1^DIQ(9000010.09,IEN,1201,"I")
.. I DATE="" S DATE=$$GET1^DIQ(9000010.09,IEN,.03,"I")
.. S DATE2=$S(TIU(1201)]"":TIU(1201),1:TIU(.03))
.. S CNT=CNT+1 ;increment counter
.. S LGTH=$L(TIU(.05)) ;PATCH 1003
.. S DATA=$S(LGTH=1:" "_DATE2,LGTH=2:" "_DATE2,1:" "_DATE2) ;PATCH 1003
.. S ARR(DATE,IEN)=$J(TIU(.04),8)_" "_TIU(.05)_" "_DATA
S CNT=0,LCNT=0,DATE=""
;IHS/MSC/MGH patch 1006 and 1010 change to check for CNT inside a date
N VFILENUM,ARRAY
F S DATE=$O(ARR(DATE),-1) Q:DATE=""!(CNT>=TIUCNT) D
. S IEN="" F S IEN=$O(ARR(DATE,IEN),-1) Q:'IEN!(CNT>=TIUCNT) D
.. S LINE=$G(ARR(DATE,IEN)),CNT=CNT+1,LCNT=LCNT+1
.. S Y=$S(CNT=1:CAPTION,1:$$SP($L(CAPTION)))
.. S ^TMP("BTIULO",$J,LCNT,0)=Y_LINE
I '$D(^TMP("BTIULO",$J)) S ^TMP("BTIULO",$J,1,0)=CAPTION_"No Results Found"
Q "~@^TMP(""BTIULO"",$J)"
;
NVIT(DFN,TIUMSR,TIUCNT,TIUDATE,BRIEF) ;EP; returns last # of of a specific vital sign; PATCH 1002 new code
; TIUMSR = measurement name
; TIUCNT = # of results to return
; TIUDATE=1 return date measurement taken
;IHS/CIA/MGH Parameter BRIEF added to remove caption from display PATCH 1003
;
NEW LAB,CAPTION,VDT,IEN,X,TIU,LINE,CNT,STOP,DATE,ARR,MSR,TT,QUALIF
K ^TMP("BTIULO",$J)
S MSR=$O(^AUTTMSR("B",TIUMSR,0)) I MSR="" S ^TMP("BTIULO",$J,1,0)="No measurements" Q "~@^TMP(""BTIULO"",$J)"
I $G(BRIEF) S CAPTION=TIUMSR_": " ;PATCH 1003
E S CAPTION="Last "_TIUCNT_" "_TIUMSR_": "
;
S (VDT,CNT)=0
F S VDT=$O(^AUPNVMSR("AA",DFN,MSR,VDT)) Q:('VDT)!(CNT>TIUCNT) D
. S IEN=0
. F S IEN=$O(^AUPNVMSR("AA",DFN,MSR,VDT,IEN)) Q:'IEN D
. . K TIU D ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","TIU(","I")
. . Q:TIU(2,"I")=1
. . S TT=$G(TIU(1201,"I"))
. . S LINE=$G(TIU(.04))_U_$G(TIU(.03,"I"))_U_TT
. . NEW Y
. . I TIUMSR="TMP" S Y=$P(LINE,U),Y=Y_" F ["_$J(((Y-32)/1.8),5,2)_" C]",$P(LINE,U)=Y
. . I ((TIUMSR="HT")!(TIUMSR="HC")!(TIUMSR="WC")!(TIUMSR="AG")) S Y=$P(LINE,U),Y=$J(Y,5,2)_" in ["_$J((Y*2.54),5,2)_" cm]",$P(LINE,U)=Y
. . I TIUMSR="WT" S Y=$P(LINE,U),Y=$J(Y,5,2)_" lb ["_$J((Y*.454),5,2)_" kg]",$P(LINE,U)=Y
. . I TIUMSR="BMI" D
. . . S Y=$P(LINE,U),Y=$J(Y,5,2)
. . . I $$PREG^BTIUPCC6(DFN,"",IEN)=1 S Y=Y_"*"
. . . S $P(LINE,U)=Y
. . S QUALIF=$$QUAL^BTIULO7A(IEN)
. . I QUALIF'="" S LINE=LINE_U_QUALIF
. . ;
. . ; set it array by date/time to find most recent
. . ;IHS/MSC/MGH 1009 Changed lookup to not add a . if there is no time
. . S DATE=$S($G(TIU(1201,"I"))]"":+TIU(1201,"I"),1:(9999999-VDT))
. . ;S DATE=$S($G(TIU(.07,"I"))]"":TIU(.07,"I"),$G(TIU(1201,"I"))]"":TIU(1201,"I"),1:(9999999-$P(VDT,"."))_$S($P(VDT,".",2)'="":"."_$P(VDT,".",2),1:""))
. . S ARR(DATE,IEN)=LINE,CNT=CNT+1
;
; loop thru array backwards to display most recent first
S CNT=0,DATE=""
;IHS/MSC/MGH patch 1006 change to check for CNT inside a date
F S DATE=$O(ARR(DATE),-1) Q:'DATE!(CNT>=TIUCNT) D
. S IEN="" F S IEN=$O(ARR(DATE,IEN),-1) Q:'IEN!(CNT>=TIUCNT) D
. . S LINE=ARR(DATE,IEN),CNT=CNT+1
. . S X=$S(CNT=1:CAPTION,1:$$SP($L(CAPTION))) ;either caption if first one or spaces to line up under first one
. . I $P(LINE,U,4)="" S ^TMP("BTIULO",$J,CNT,0)=X_$P(LINE,U)_$$LSTDATE^BTIUPCC1($P(LINE,U,2),$P(LINE,U,3),$G(TIUDATE))
. . I $P(LINE,U,4)'="" S ^TMP("BTIULO",$J,CNT,0)=X_$P(LINE,U)_$$LSTDATE^BTIUPCC1($P(LINE,U,2),$P(LINE,U,3),$G(TIUDATE))_" Qualifiers: "_$P(LINE,U,4)
;
I '$D(^TMP("BTIULO",$J)) S ^TMP("BTIULO",$J,1,0)=CAPTION_"No "_TIUMSR_" Found"
Q "~@^TMP(""BTIULO"",$J)"
;
LMP(DFN,MODE) ;EP; LMP-BRIEF and LMP-EXPANDED objects
;MODE="B" or "E"
NEW X
I '$D(MODE) S @TARGET@(1,0)="Please see your CAC to upgrade this object" Q "~@"_$NA(@TARGET)
I $P(^DPT(DFN,0),U,2)="M" Q "Patient is male"
S X=$$GET1^DIQ(9000017,+$G(DFN),2)
I (MODE="B")!(X="") Q "LMP: "_$S(X="":"None Recorded",1:X)
Q "LMP: "_X_" (recorded on "_$$GET1^DIQ(9000017,+$G(DFN),2.1)_")"
;
EDC(DFN,MODE) ;EP; EDC-BRIEF and EDC-EXPANDED objects
;MODE="B" or "E"
NEW X,HOW,EDCDT
I '$D(MODE) S @TARGET@(1,0)="Please see your CAC to upgrade this object" Q "~@"_$NA(@TARGET)
I $P(^DPT(DFN,0),U,2)="M" Q "Patient is male"
S X=$$GET1^DIQ(9000017,+$G(DFN),1311)
I (MODE="B")!(X="") Q "EDC: "_$S(X="":"None Recorded",1:X)
S HOW=$$GET1^DIQ(9000017,+DFN,1313),EDCDT=$$GET1^DIQ(9000017,DFN,1312)
Q "EDC: "_X_" (determined by "_$S(HOW="":"UNKNOWN METHOD",1:HOW)_" on "_EDCDT_")"
;
RHX(DFN,TARGET,MODE) ;EP; REPRODUCTIVE HX-BRIEF and REPRODUCTIVE HX-EXPANDED objects
;MODE="B" or "E"
;Patch 1006 updated to get data from new fields
NEW X,GRAV,OTHER,PARA,LC,SA,TA,TOT,G,MB,FT,PRE,EC,LAC,LAC1,LACDATE
K @TARGET
I '$D(MODE) S @TARGET@(1,0)="Please see your CAC to upgrade this object" Q "~@"_$NA(@TARGET)
;I '$D(MODE)!(MODE="") S MODE="B"
I $P(^DPT(DFN,0),U,2)="M" S @TARGET@(1,0)="Patient is male" Q "~@"_$NA(@TARGET)
I '$D(^AUPNREP(DFN,0)) S @TARGET@(1,0)="No history on file" Q "~@"_$NA(@TARGET)
S X=$$GET1^DIQ(9000017,+$G(DFN),1103)
I X="" D OLD^BTIULO7A(DFN,TARGET,MODE) Q "~@"_$NA(@TARGET)
S G=X
I MODE="E" S G=G_" ("_$$GET1^DIQ(9000017,+$G(DFN),1104,"E")_")"
S MB=$$GET1^DIQ(9000017,+$G(DFN),1105)
I MODE="E" S MB=MB_" ("_$$GET1^DIQ(9000017,+$G(DFN),1106)_")"
S FT=$$GET1^DIQ(9000017,+$G(DFN),1107)
I MODE="E" S FT=FT_" ("_$$GET1^DIQ(9000017,+$G(DFN),1108)_")"
S PRE=$$GET1^DIQ(9000017,+$G(DFN),1109)
I MODE="E" S PRE=PRE_" ("_$$GET1^DIQ(9000017,+$G(DFN),1110)_")"
S EC=$$GET1^DIQ(9000017,+$G(DFN),1111)
I MODE="E" S EC=EC_" ("_$$GET1^DIQ(9000017,+$G(DFN),1112)_")"
S LC=$$GET1^DIQ(9000017,+$G(DFN),1113)
I MODE="E" S LC=LC_" ("_$$GET1^DIQ(9000017,+$G(DFN),1114)_")"
S TA=$$GET1^DIQ(9000017,+$G(DFN),1131)
I MODE="E" S TA=TA_" ("_$$GET1^DIQ(9000017,+$G(DFN),1132)_")"
S SA=$$GET1^DIQ(9000017,+$G(DFN),1133)
I MODE="E" S SA=SA_" ("_$$GET1^DIQ(9000017,+$G(DFN),1106)_")"
S LAC1=""
S LAC=$G(^AUPNREP(DFN,2))
;IHS/MSC/MGH patch 1010 check for blank lactation status
I LAC'="" D
.S LAC1=$$GET1^DIQ(9000017,DFN,2.01)
.S LACDATE=$$GET1^DIQ(9000017,DFN,2.02)
.I MODE="E" S LAC1=LAC1_" ("_LACDATE_")"
;IHS/MSC/MGH patch 1009 changed order of display
S CNT=1
S @TARGET@(CNT,0)="Gravida: "_G
S CNT=CNT+1
S @TARGET@(CNT,0)="Full Term: "_FT
S CNT=CNT+1
S @TARGET@(CNT,0)="Premature Births: "_PRE
S CNT=CNT+1
S @TARGET@(CNT,0)="Theraputic Abortions: "_TA
S CNT=CNT+1
S @TARGET@(CNT,0)="Spontaneous Abortions: "_SA
S CNT=CNT+1
S @TARGET@(CNT,0)="Ectopics: "_EC
S CNT=CNT+1
S @TARGET@(CNT,0)="Living Children: "_LC
S CNT=CNT+1
S @TARGET@(CNT,0)="Multiple Births: "_MB
S CNT=CNT+1
S @TARGET@(CNT,0)="Lactation Status: "_LAC1
Q "~@"_$NA(@TARGET)
;
FPM(DFN,TARGET,MODE) ;EP; CONTRACEPTION-BRIEF object
;MODE="B" or "E"
NEW X,FPBEGIN,FPDATE,BHX,TYP,START,END,CNT,LINE,LIN1,BHC
K @TARGET
S CNT=0
I $P(^DPT(DFN,0),U,2)="M" Q "Patient is male"
S BHX=0 F S BHX=$O(^AUPNREP(DFN,2101,BHX)) Q:BHX'=+BHX D
.Q:$D(^AUPNREP(DFN,2101,BHX,1))>0
.S BHC=$P(^AUPNREP(DFN,2101,BHX,0),U,1) I BHC D
..S TYP=$P(^AUTTCM(BHC,0),U)
..S START=$P(^AUPNREP(DFN,2101,BHX,0),U,2) I START]"" S START=$$FIXDT^BHSFAM1(START)
..S END=$P(^AUPNREP(DFN,2101,BHX,0),U,3) I END]"" S END=$$FIXDT^BHSFAM1(END)
..I CNT=0 D
...S CNT=CNT+1 S @TARGET@(CNT,0)=""
...S CNT=CNT+1 S @TARGET@(CNT,0)="FP METHOD: "
..S LINE=$S(TYP="":"None Recorded",1:TYP)
..I MODE="B"&(END="") D
...S CNT=CNT+1
...S LINE=" "_LINE_" Start Dt: "_START
...S @TARGET@(CNT,0)=LINE
..I MODE="E" D
...S CNT=CNT+1
...S LINE=" "_LINE_" Start Dt: "_START
...S @TARGET@(CNT,0)=LINE
...I END'="" D
....S CNT=CNT+1
....S LIN1=""
....I $P(^AUPNREP(DFN,2101,BHX,0),U,5)]"" S LIN1=" Reason Discontinued: "_$P(^AUPNREP(DFN,2101,BHX,0),U,5)
....S @TARGET@(CNT,0)=" End Dt: "_END_LIN1
Q "~@"_$NA(@TARGET)
;
TODAYVIT(PAT) ;EP; returns all vitals taken today
NEW MEAS,VST,VDT,END,APCLV,ERR,TYPE,VALUE
;
; for each visit patient had today, find all measurements taken
S VDT=9999999-DT,END=VDT_".2359"
F S VDT=$O(^AUPNVSIT("AA",PAT,VDT)) Q:'VDT Q:VDT>END D
. S VST=$O(^AUPNVSIT("AA",PAT,VDT,0)) Q:'VST
. S ERR=$$PCCVF^APCLV(VST,"MEASUREMENT","7;8") I ERR Q
. S X=0 F S X=$O(APCLV(X)) Q:'X D
. . S MEAS($P(APCLV(X),U),VDT)=$P(APCLV(X),U,2)
;
; loop through all measurements found for patient and date; pick most recent ones
S RESULT=""
S TYPE=0 F S TYPE=$O(MEAS(TYPE)) Q:TYPE="" D
. S DATE=$O(MEAS(TYPE,""),-1) ;get latest date/time
. S VALUE=MEAS(TYPE,DATE) ;get value for this measurement & date/time
. I TYPE="WT" S VALUE=$J(VALUE,5,2)_" ("_$J((VALUE*.454),5,2)_" kg)"
. I ((TYPE="HT")!(TYPE="HC")!(TYPE="WC")!(TYPE="AG")) S VALUE=$J(VALUE,5,2)_" ("_$J((VALUE*2.54),5,2)_" cm)"
. I TYPE="TMP" S VALUE=VALUE_" ("_(((10*((VALUE-32)/1.8))\1)/10)_" C)"
. I TYPE="BMI" D
. . S VALUE=$J(VALUE,5,2)
. . I $$PNM^APCLSIL1(DFN,DT)="Y" S VALUE=VALUE_"*"
. S RESULT=RESULT_TYPE_":"_VALUE_", "
S RESULT=$E(RESULT,1,$L(RESULT)-2) ;remove last comma
Q RESULT
;
TODAYLAB(PAT) ;EP; returns all labs taken today;PATCH 1002 new code
NEW VDT,END,VISIT,COUNT,TIUX,LINE,TIUA
K ^TMP("BTIULO",$J)
;
; for each visit patient had today, find all labs
S VDT=9999999-DT,END=VDT_".2359"
F S VDT=$O(^AUPNVSIT("AA",PAT,VDT)) Q:'VDT Q:VDT>END D
. S VISIT=0 F S VISIT=$O(^AUPNVSIT("AA",PAT,VDT,VISIT)) Q:'VISIT D
. . S TIUX=0,LINE="" F S TIUX=$O(^AUPNVLAB("AD",VISIT,TIUX)) Q:'TIUX D
. . . K TIUA D ENP^XBDIQ1(9000010.09,TIUX,".01;.04;.05;1109","TIUA(")
. . . I TIUA(.04)="",TIUA(1109)="RESULTED" Q
. . . S LINE=" "_$$PAD(TIUA(.01),25)_" " ;lab test
. . . S LINE=LINE_$$PAD(TIUA(.04),10)_TIUA(.05) ;result
. . . I TIUA(.04)="" S LINE=LINE_TIUA(1109)
. . . S COUNT=$G(COUNT)+1 S ^TMP("BTIULO",$J,COUNT,0)=LINE
;
I '$D(^TMP("BTIULO",$J)) Q "No Labs Found for Today"
Q "~@^TMP(""BTIULO"",$J)"
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(NUM) ; -- SUBRTN to pad spaces
Q $$PAD(" ",NUM)
BTIULO7 ;IHS/ITSC/LJF - IHS OBJECTS ADDED IN PATCHES;06-Aug-2018 15:33;MGH
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1001,1002,1003,1004,1005,1006,1007,1009,1010,1012,1013,1020**;NOV 04, 2004;Build 7
+2 ;IHS/CIA/MGH line up number of labs and only display test name
+3 ;Made changes to call ehr 1.1 visit creation
+4 ;Patch 1005 Changed lookup for dates without times
+5 ;Patch 1006 changed lookup for LAST #VITALS for multiple vitals on one day
+6 ;Patch 1006 incorporated reproductive history field changes
+7 ;Patch 1007 fixed total time for visit selection
+8 ;Patch 1009 fixed reproductive history again and last # measurements
+9 ;Patch 1010 added qualifiers
LASTHFC(PAT,CTG,CAP) ;EP - return last factor in category CTG for patient PAT; PATCH 1001
+1 ; CAP = 1 if want caption to be returned; = 0 otherwise
+2 NEW CTGN,HF,HFDT,LIST,RESULT,X
+3 IF '$GET(PAT)!($GET(CTG)="")
QUIT ""
+4 ;ien of category passed
SET CTGN=$ORDER(^AUTTHF("B",CTG,0))
IF 'CTGN
QUIT ""
+5 ;
+6 SET HF=0
+7 ;find health factors in category
FOR
SET HF=$ORDER(^AUTTHF("AC",CTGN,HF))
IF '+HF
QUIT
Begin DoDot:1
+8 ;quit if patient doesn't have health factor
IF '$DATA(^AUPNVHF("AA",PAT,HF))
QUIT
+9 ;get visit date for health factor
SET HFDT=$ORDER(^AUPNVHF("AA",PAT,HF,""))
IF 'HFDT
QUIT
+10 ;store iens by date
SET LIST(HFDT)=$ORDER(^AUPNVHF("AA",PAT,HF,HFDT,""))
End DoDot:1
+11 ;
+12 IF '$ORDER(LIST(0))
QUIT $SELECT($GET(CAP)=1:"No "_CTG_" health factors found for patient",1:"")
+13 ;find latest date (inverse dates)
SET HFDT=$ORDER(LIST(0))
+14 SET RESULT=$SELECT($GET(CAP)=1:"Last "_CTG_" HF: ",1:"")
+15 SET RESULT=RESULT_$$GET1^DIQ(9000010.23,LIST(HFDT),.01)
+16 ;severity level
SET X=$$GET1^DIQ(9000010.23,LIST(HFDT),.04)
+17 SET RESULT=RESULT_$SELECT(X]"":" ( "_X_")",1:"")
+18 SET RESULT=RESULT_" - "_$$FMTE^XLFDT(9999999-HFDT)
+19 QUIT RESULT
+20 ;
VINS(TARGET) ; returns insurance coverage for current vuecentric visit context; PATCH 1001
+1 ; assumes DFN is set
+2 IF $TEXT(GETVAR^CIAVMEVT)=""
SET @TARGET@(1,0)="Invalid context variables"
QUIT "~@"_$NAME(@TARGET)
+3 NEW VST,I,X,CNT,RESULT
+4 SET CNT=0
+5 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+6 IF VST=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+7 SET X="BEHOENCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET @TARGET@(1,0)="Invalid context variables"
QUIT "~@"_$NAME(@TARGET)
+8 DO GETINS(.RESULT,VST)
+9 ;
+10 KILL @TARGET
+11 SET I=0
FOR
SET I=$ORDER(RESULT(I))
IF 'I
QUIT
Begin DoDot:1
+12 SET CNT=CNT+1
+13 SET @TARGET@(CNT,0)=RESULT(I)
End DoDot:1
+14 IF 'CNT
SET @TARGET@(1,0)="No Insurance Coverage Found"
+15 QUIT "~@"_$NAME(@TARGET)
+16 ;
GETINS(RETURN,VISIT) ;return insurance coverage at time of visit
+1 ; VISIT=Visit IEN
+2 ;
+3 NEW VDT,LINE,CNT,SEL,IEN,MEDCARE,SEL,INS,PVT,RR,RRE
+4 KILL RETURN
+5 ;
+6 SET VDT=+$GET(^AUPNVSIT(VISIT,0))
IF 'VDT
QUIT
+7 SET LINE=""
SET CNT=0
+8 IF $$MCR^AUPNPAT(DFN,VDT)=1
Begin DoDot:1
+9 SET MEDCARE=$$MCR2^BTIULO2(DFN)
+10 IF MEDCARE=""
Begin DoDot:2
+11 SET IEN=$ORDER(^AUPNMCR("B",DFN,0))
+12 SET MEDCARE=$PIECE($GET(^AUPNMCR(IEN,0)),U,3)
End DoDot:2
+13 FOR SEL=1:1
SET INS=$PIECE(MEDCARE,";",SEL)
IF INS=""
QUIT
Begin DoDot:2
+14 SET CNT=CNT+1
+15 SET RETURN(CNT)="MEDICARE ("_INS_")"
End DoDot:2
End DoDot:1
+16 IF $$MCD^AUPNPAT(DFN,VDT)=1
SET CNT=CNT+1
SET RETURN(CNT)="MEDICAID #"_$$MCD^BTIULO2(DFN)
+17 IF $$PI^AUPNPAT(DFN,VDT)=1
Begin DoDot:1
+18 SET PVT=$$THIRD^BTIULO2(DFN)
+19 FOR SEL=1:1
SET INS=$PIECE(PVT,";",SEL)
IF INS=""
QUIT
Begin DoDot:2
+20 SET CNT=CNT+1
+21 SET RETURN(CNT)="PVT INS ("_INS_")"
End DoDot:2
End DoDot:1
+22 IF $$RR^AUPNPAT(DFN,VDT)=1
Begin DoDot:1
+23 SET RR=$$RRE^BTIULO2(DFN)
+24 IF RR=""
Begin DoDot:2
+25 SET IEN=$ORDER(^AUPNRRE("B",DFN,0))
+26 SET RR=$PIECE($GET(^AUPNRRE(IEN,0)),U,3)
End DoDot:2
+27 FOR SEL=1:1
SET INS=$PIECE(RR,";",SEL)
IF INS=""
QUIT
Begin DoDot:2
+28 SET CNT=CNT+1
+29 SET RETURN(CNT)="RAILROAD ("_INS_")"
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
NLAB(DFN,TIUTST,TIUCNT,BRIEF) ;EP; -- returns last # of current lab result for single test;PATCH 1001
+1 ; TIUTST = lab test name; TIUCNT = # of test results to return
+2 ;Brief is set to remove caption and only insert test name PATCH 1003
+3 ;IHS/CIA/MGH Modified to only display the test name and line up labs better
+4 ;UPDATED 1009 FOR MULTIPLE RESULTS ON SAME VISIT
+5 NEW LAB,CAPTION,VDT,IEN,X,TIU,LINE,CNT,DATA,LGTH,ARR,DATE,DATE2,LCNT
+6 KILL ^TMP("BTIULO",$JOB)
+7 SET LAB=$ORDER(^LAB(60,"B",TIUTST,0))
IF LAB=""
QUIT ""
+8 ;PATCH 1003
IF $GET(BRIEF)
SET CAPTION=$EXTRACT(TIUTST,1,30)_":"
+9 IF '$TEST
SET CAPTION="Last "_TIUCNT_" "_$EXTRACT(TIUTST,1,30)_": "
+10 SET (VDT,CNT)=0
+11 FOR
SET VDT=$ORDER(^AUPNVLAB("AA",DFN,LAB,VDT))
IF ('VDT)!(CNT=TIUCNT)
QUIT
Begin DoDot:1
+12 SET IEN=0
+13 FOR
SET IEN=$ORDER(^AUPNVLAB("AA",DFN,LAB,VDT,IEN))
IF 'IEN!(CNT=TIUCNT)
QUIT
Begin DoDot:2
+14 KILL TIU
DO ENP^XBDIQ1(9000010.09,IEN,".03:.05;1109;1201","TIU(")
+15 ;skip if not resulted
IF TIU(.04)=""
QUIT
+16 SET DATE=$$GET1^DIQ(9000010.09,IEN,1201,"I")
+17 IF DATE=""
SET DATE=$$GET1^DIQ(9000010.09,IEN,.03,"I")
+18 SET DATE2=$SELECT(TIU(1201)]"":TIU(1201),1:TIU(.03))
+19 ;increment counter
SET CNT=CNT+1
+20 ;PATCH 1003
SET LGTH=$LENGTH(TIU(.05))
+21 ;PATCH 1003
SET DATA=$SELECT(LGTH=1:" "_DATE2,LGTH=2:" "_DATE2,1:" "_DATE2)
+22 SET ARR(DATE,IEN)=$JUSTIFY(TIU(.04),8)_" "_TIU(.05)_" "_DATA
End DoDot:2
End DoDot:1
+23 SET CNT=0
SET LCNT=0
SET DATE=""
+24 ;IHS/MSC/MGH patch 1006 and 1010 change to check for CNT inside a date
+25 NEW VFILENUM,ARRAY
+26 FOR
SET DATE=$ORDER(ARR(DATE),-1)
IF DATE=""!(CNT>=TIUCNT)
QUIT
Begin DoDot:1
+27 SET IEN=""
FOR
SET IEN=$ORDER(ARR(DATE,IEN),-1)
IF 'IEN!(CNT>=TIUCNT)
QUIT
Begin DoDot:2
+28 SET LINE=$GET(ARR(DATE,IEN))
SET CNT=CNT+1
SET LCNT=LCNT+1
+29 SET Y=$SELECT(CNT=1:CAPTION,1:$$SP($LENGTH(CAPTION)))
+30 SET ^TMP("BTIULO",$JOB,LCNT,0)=Y_LINE
End DoDot:2
End DoDot:1
+31 IF '$DATA(^TMP("BTIULO",$JOB))
SET ^TMP("BTIULO",$JOB,1,0)=CAPTION_"No Results Found"
+32 QUIT "~@^TMP(""BTIULO"",$J)"
+33 ;
NVIT(DFN,TIUMSR,TIUCNT,TIUDATE,BRIEF) ;EP; returns last # of of a specific vital sign; PATCH 1002 new code
+1 ; TIUMSR = measurement name
+2 ; TIUCNT = # of results to return
+3 ; TIUDATE=1 return date measurement taken
+4 ;IHS/CIA/MGH Parameter BRIEF added to remove caption from display PATCH 1003
+5 ;
+6 NEW LAB,CAPTION,VDT,IEN,X,TIU,LINE,CNT,STOP,DATE,ARR,MSR,TT,QUALIF
+7 KILL ^TMP("BTIULO",$JOB)
+8 SET MSR=$ORDER(^AUTTMSR("B",TIUMSR,0))
IF MSR=""
SET ^TMP("BTIULO",$JOB,1,0)="No measurements"
QUIT "~@^TMP(""BTIULO"",$J)"
+9 ;PATCH 1003
IF $GET(BRIEF)
SET CAPTION=TIUMSR_": "
+10 IF '$TEST
SET CAPTION="Last "_TIUCNT_" "_TIUMSR_": "
+11 ;
+12 SET (VDT,CNT)=0
+13 FOR
SET VDT=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT))
IF ('VDT)!(CNT>TIUCNT)
QUIT
Begin DoDot:1
+14 SET IEN=0
+15 FOR
SET IEN=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+16 KILL TIU
DO ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","TIU(","I")
+17 IF TIU(2,"I")=1
QUIT
+18 SET TT=$GET(TIU(1201,"I"))
+19 SET LINE=$GET(TIU(.04))_U_$GET(TIU(.03,"I"))_U_TT
+20 NEW Y
+21 IF TIUMSR="TMP"
SET Y=$PIECE(LINE,U)
SET Y=Y_" F ["_$JUSTIFY(((Y-32)/1.8),5,2)_" C]"
SET $PIECE(LINE,U)=Y
+22 IF ((TIUMSR="HT")!(TIUMSR="HC")!(TIUMSR="WC")!(TIUMSR="AG"))
SET Y=$PIECE(LINE,U)
SET Y=$JUSTIFY(Y,5,2)_" in ["_$JUSTIFY((Y*2.54),5,2)_" cm]"
SET $PIECE(LINE,U)=Y
+23 IF TIUMSR="WT"
SET Y=$PIECE(LINE,U)
SET Y=$JUSTIFY(Y,5,2)_" lb ["_$JUSTIFY((Y*.454),5,2)_" kg]"
SET $PIECE(LINE,U)=Y
+24 IF TIUMSR="BMI"
Begin DoDot:3
+25 SET Y=$PIECE(LINE,U)
SET Y=$JUSTIFY(Y,5,2)
+26 IF $$PREG^BTIUPCC6(DFN,"",IEN)=1
SET Y=Y_"*"
+27 SET $PIECE(LINE,U)=Y
End DoDot:3
+28 SET QUALIF=$$QUAL^BTIULO7A(IEN)
+29 IF QUALIF'=""
SET LINE=LINE_U_QUALIF
+30 ;
+31 ; set it array by date/time to find most recent
+32 ;IHS/MSC/MGH 1009 Changed lookup to not add a . if there is no time
+33 SET DATE=$SELECT($GET(TIU(1201,"I"))]"":+TIU(1201,"I"),1:(9999999-VDT))
+34 ;S DATE=$S($G(TIU(.07,"I"))]"":TIU(.07,"I"),$G(TIU(1201,"I"))]"":TIU(1201,"I"),1:(9999999-$P(VDT,"."))_$S($P(VDT,".",2)'="":"."_$P(VDT,".",2),1:""))
+35 SET ARR(DATE,IEN)=LINE
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+36 ;
+37 ; loop thru array backwards to display most recent first
+38 SET CNT=0
SET DATE=""
+39 ;IHS/MSC/MGH patch 1006 change to check for CNT inside a date
+40 FOR
SET DATE=$ORDER(ARR(DATE),-1)
IF 'DATE!(CNT>=TIUCNT)
QUIT
Begin DoDot:1
+41 SET IEN=""
FOR
SET IEN=$ORDER(ARR(DATE,IEN),-1)
IF 'IEN!(CNT>=TIUCNT)
QUIT
Begin DoDot:2
+42 SET LINE=ARR(DATE,IEN)
SET CNT=CNT+1
+43 ;either caption if first one or spaces to line up under first one
SET X=$SELECT(CNT=1:CAPTION,1:$$SP($LENGTH(CAPTION)))
+44 IF $PIECE(LINE,U,4)=""
SET ^TMP("BTIULO",$JOB,CNT,0)=X_$PIECE(LINE,U)_$$LSTDATE^BTIUPCC1($PIECE(LINE,U,2),$PIECE(LINE,U,3),$GET(TIUDATE))
+45 IF $PIECE(LINE,U,4)'=""
SET ^TMP("BTIULO",$JOB,CNT,0)=X_$PIECE(LINE,U)_$$LSTDATE^BTIUPCC1($PIECE(LINE,U,2),$PIECE(LINE,U,3),$GET(TIUDATE))_" Qualifiers: "_$PIECE(LINE,U,4)
End DoDot:2
End DoDot:1
+46 ;
+47 IF '$DATA(^TMP("BTIULO",$JOB))
SET ^TMP("BTIULO",$JOB,1,0)=CAPTION_"No "_TIUMSR_" Found"
+48 QUIT "~@^TMP(""BTIULO"",$J)"
+49 ;
LMP(DFN,MODE) ;EP; LMP-BRIEF and LMP-EXPANDED objects
+1 ;MODE="B" or "E"
+2 NEW X
+3 IF '$DATA(MODE)
SET @TARGET@(1,0)="Please see your CAC to upgrade this object"
QUIT "~@"_$NAME(@TARGET)
+4 IF $PIECE(^DPT(DFN,0),U,2)="M"
QUIT "Patient is male"
+5 SET X=$$GET1^DIQ(9000017,+$GET(DFN),2)
+6 IF (MODE="B")!(X="")
QUIT "LMP: "_$SELECT(X="":"None Recorded",1:X)
+7 QUIT "LMP: "_X_" (recorded on "_$$GET1^DIQ(9000017,+$GET(DFN),2.1)_")"
+8 ;
EDC(DFN,MODE) ;EP; EDC-BRIEF and EDC-EXPANDED objects
+1 ;MODE="B" or "E"
+2 NEW X,HOW,EDCDT
+3 IF '$DATA(MODE)
SET @TARGET@(1,0)="Please see your CAC to upgrade this object"
QUIT "~@"_$NAME(@TARGET)
+4 IF $PIECE(^DPT(DFN,0),U,2)="M"
QUIT "Patient is male"
+5 SET X=$$GET1^DIQ(9000017,+$GET(DFN),1311)
+6 IF (MODE="B")!(X="")
QUIT "EDC: "_$SELECT(X="":"None Recorded",1:X)
+7 SET HOW=$$GET1^DIQ(9000017,+DFN,1313)
SET EDCDT=$$GET1^DIQ(9000017,DFN,1312)
+8 QUIT "EDC: "_X_" (determined by "_$SELECT(HOW="":"UNKNOWN METHOD",1:HOW)_" on "_EDCDT_")"
+9 ;
RHX(DFN,TARGET,MODE) ;EP; REPRODUCTIVE HX-BRIEF and REPRODUCTIVE HX-EXPANDED objects
+1 ;MODE="B" or "E"
+2 ;Patch 1006 updated to get data from new fields
+3 NEW X,GRAV,OTHER,PARA,LC,SA,TA,TOT,G,MB,FT,PRE,EC,LAC,LAC1,LACDATE
+4 KILL @TARGET
+5 IF '$DATA(MODE)
SET @TARGET@(1,0)="Please see your CAC to upgrade this object"
QUIT "~@"_$NAME(@TARGET)
+6 ;I '$D(MODE)!(MODE="") S MODE="B"
+7 IF $PIECE(^DPT(DFN,0),U,2)="M"
SET @TARGET@(1,0)="Patient is male"
QUIT "~@"_$NAME(@TARGET)
+8 IF '$DATA(^AUPNREP(DFN,0))
SET @TARGET@(1,0)="No history on file"
QUIT "~@"_$NAME(@TARGET)
+9 SET X=$$GET1^DIQ(9000017,+$GET(DFN),1103)
+10 IF X=""
DO OLD^BTIULO7A(DFN,TARGET,MODE)
QUIT "~@"_$NAME(@TARGET)
+11 SET G=X
+12 IF MODE="E"
SET G=G_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1104,"E")_")"
+13 SET MB=$$GET1^DIQ(9000017,+$GET(DFN),1105)
+14 IF MODE="E"
SET MB=MB_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1106)_")"
+15 SET FT=$$GET1^DIQ(9000017,+$GET(DFN),1107)
+16 IF MODE="E"
SET FT=FT_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1108)_")"
+17 SET PRE=$$GET1^DIQ(9000017,+$GET(DFN),1109)
+18 IF MODE="E"
SET PRE=PRE_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1110)_")"
+19 SET EC=$$GET1^DIQ(9000017,+$GET(DFN),1111)
+20 IF MODE="E"
SET EC=EC_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1112)_")"
+21 SET LC=$$GET1^DIQ(9000017,+$GET(DFN),1113)
+22 IF MODE="E"
SET LC=LC_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1114)_")"
+23 SET TA=$$GET1^DIQ(9000017,+$GET(DFN),1131)
+24 IF MODE="E"
SET TA=TA_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1132)_")"
+25 SET SA=$$GET1^DIQ(9000017,+$GET(DFN),1133)
+26 IF MODE="E"
SET SA=SA_" ("_$$GET1^DIQ(9000017,+$GET(DFN),1106)_")"
+27 SET LAC1=""
+28 SET LAC=$GET(^AUPNREP(DFN,2))
+29 ;IHS/MSC/MGH patch 1010 check for blank lactation status
+30 IF LAC'=""
Begin DoDot:1
+31 SET LAC1=$$GET1^DIQ(9000017,DFN,2.01)
+32 SET LACDATE=$$GET1^DIQ(9000017,DFN,2.02)
+33 IF MODE="E"
SET LAC1=LAC1_" ("_LACDATE_")"
End DoDot:1
+34 ;IHS/MSC/MGH patch 1009 changed order of display
+35 SET CNT=1
+36 SET @TARGET@(CNT,0)="Gravida: "_G
+37 SET CNT=CNT+1
+38 SET @TARGET@(CNT,0)="Full Term: "_FT
+39 SET CNT=CNT+1
+40 SET @TARGET@(CNT,0)="Premature Births: "_PRE
+41 SET CNT=CNT+1
+42 SET @TARGET@(CNT,0)="Theraputic Abortions: "_TA
+43 SET CNT=CNT+1
+44 SET @TARGET@(CNT,0)="Spontaneous Abortions: "_SA
+45 SET CNT=CNT+1
+46 SET @TARGET@(CNT,0)="Ectopics: "_EC
+47 SET CNT=CNT+1
+48 SET @TARGET@(CNT,0)="Living Children: "_LC
+49 SET CNT=CNT+1
+50 SET @TARGET@(CNT,0)="Multiple Births: "_MB
+51 SET CNT=CNT+1
+52 SET @TARGET@(CNT,0)="Lactation Status: "_LAC1
+53 QUIT "~@"_$NAME(@TARGET)
+54 ;
FPM(DFN,TARGET,MODE) ;EP; CONTRACEPTION-BRIEF object
+1 ;MODE="B" or "E"
+2 NEW X,FPBEGIN,FPDATE,BHX,TYP,START,END,CNT,LINE,LIN1,BHC
+3 KILL @TARGET
+4 SET CNT=0
+5 IF $PIECE(^DPT(DFN,0),U,2)="M"
QUIT "Patient is male"
+6 SET BHX=0
FOR
SET BHX=$ORDER(^AUPNREP(DFN,2101,BHX))
IF BHX'=+BHX
QUIT
Begin DoDot:1
+7 IF $DATA(^AUPNREP(DFN,2101,BHX,1))>0
QUIT
+8 SET BHC=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,1)
IF BHC
Begin DoDot:2
+9 SET TYP=$PIECE(^AUTTCM(BHC,0),U)
+10 SET START=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,2)
IF START]""
SET START=$$FIXDT^BHSFAM1(START)
+11 SET END=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,3)
IF END]""
SET END=$$FIXDT^BHSFAM1(END)
+12 IF CNT=0
Begin DoDot:3
+13 SET CNT=CNT+1
SET @TARGET@(CNT,0)=""
+14 SET CNT=CNT+1
SET @TARGET@(CNT,0)="FP METHOD: "
End DoDot:3
+15 SET LINE=$SELECT(TYP="":"None Recorded",1:TYP)
+16 IF MODE="B"&(END="")
Begin DoDot:3
+17 SET CNT=CNT+1
+18 SET LINE=" "_LINE_" Start Dt: "_START
+19 SET @TARGET@(CNT,0)=LINE
End DoDot:3
+20 IF MODE="E"
Begin DoDot:3
+21 SET CNT=CNT+1
+22 SET LINE=" "_LINE_" Start Dt: "_START
+23 SET @TARGET@(CNT,0)=LINE
+24 IF END'=""
Begin DoDot:4
+25 SET CNT=CNT+1
+26 SET LIN1=""
+27 IF $PIECE(^AUPNREP(DFN,2101,BHX,0),U,5)]""
SET LIN1=" Reason Discontinued: "_$PIECE(^AUPNREP(DFN,2101,BHX,0),U,5)
+28 SET @TARGET@(CNT,0)=" End Dt: "_END_LIN1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT "~@"_$NAME(@TARGET)
+30 ;
TODAYVIT(PAT) ;EP; returns all vitals taken today
+1 NEW MEAS,VST,VDT,END,APCLV,ERR,TYPE,VALUE
+2 ;
+3 ; for each visit patient had today, find all measurements taken
+4 SET VDT=9999999-DT
SET END=VDT_".2359"
+5 FOR
SET VDT=$ORDER(^AUPNVSIT("AA",PAT,VDT))
IF 'VDT
QUIT
IF VDT>END
QUIT
Begin DoDot:1
+6 SET VST=$ORDER(^AUPNVSIT("AA",PAT,VDT,0))
IF 'VST
QUIT
+7 SET ERR=$$PCCVF^APCLV(VST,"MEASUREMENT","7;8")
IF ERR
QUIT
+8 SET X=0
FOR
SET X=$ORDER(APCLV(X))
IF 'X
QUIT
Begin DoDot:2
+9 SET MEAS($PIECE(APCLV(X),U),VDT)=$PIECE(APCLV(X),U,2)
End DoDot:2
End DoDot:1
+10 ;
+11 ; loop through all measurements found for patient and date; pick most recent ones
+12 SET RESULT=""
+13 SET TYPE=0
FOR
SET TYPE=$ORDER(MEAS(TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+14 ;get latest date/time
SET DATE=$ORDER(MEAS(TYPE,""),-1)
+15 ;get value for this measurement & date/time
SET VALUE=MEAS(TYPE,DATE)
+16 IF TYPE="WT"
SET VALUE=$JUSTIFY(VALUE,5,2)_" ("_$JUSTIFY((VALUE*.454),5,2)_" kg)"
+17 IF ((TYPE="HT")!(TYPE="HC")!(TYPE="WC")!(TYPE="AG"))
SET VALUE=$JUSTIFY(VALUE,5,2)_" ("_$JUSTIFY((VALUE*2.54),5,2)_" cm)"
+18 IF TYPE="TMP"
SET VALUE=VALUE_" ("_(((10*((VALUE-32)/1.8))\1)/10)_" C)"
+19 IF TYPE="BMI"
Begin DoDot:2
+20 SET VALUE=$JUSTIFY(VALUE,5,2)
+21 IF $$PNM^APCLSIL1(DFN,DT)="Y"
SET VALUE=VALUE_"*"
End DoDot:2
+22 SET RESULT=RESULT_TYPE_":"_VALUE_", "
End DoDot:1
+23 ;remove last comma
SET RESULT=$EXTRACT(RESULT,1,$LENGTH(RESULT)-2)
+24 QUIT RESULT
+25 ;
TODAYLAB(PAT) ;EP; returns all labs taken today;PATCH 1002 new code
+1 NEW VDT,END,VISIT,COUNT,TIUX,LINE,TIUA
+2 KILL ^TMP("BTIULO",$JOB)
+3 ;
+4 ; for each visit patient had today, find all labs
+5 SET VDT=9999999-DT
SET END=VDT_".2359"
+6 FOR
SET VDT=$ORDER(^AUPNVSIT("AA",PAT,VDT))
IF 'VDT
QUIT
IF VDT>END
QUIT
Begin DoDot:1
+7 SET VISIT=0
FOR
SET VISIT=$ORDER(^AUPNVSIT("AA",PAT,VDT,VISIT))
IF 'VISIT
QUIT
Begin DoDot:2
+8 SET TIUX=0
SET LINE=""
FOR
SET TIUX=$ORDER(^AUPNVLAB("AD",VISIT,TIUX))
IF 'TIUX
QUIT
Begin DoDot:3
+9 KILL TIUA
DO ENP^XBDIQ1(9000010.09,TIUX,".01;.04;.05;1109","TIUA(")
+10 IF TIUA(.04)=""
IF TIUA(1109)="RESULTED"
QUIT
+11 ;lab test
SET LINE=" "_$$PAD(TIUA(.01),25)_" "
+12 ;result
SET LINE=LINE_$$PAD(TIUA(.04),10)_TIUA(.05)
+13 IF TIUA(.04)=""
SET LINE=LINE_TIUA(1109)
+14 SET COUNT=$GET(COUNT)+1
SET ^TMP("BTIULO",$JOB,COUNT,0)=LINE
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "No Labs Found for Today"
+17 QUIT "~@^TMP(""BTIULO"",$J)"
+18 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(NUM) ; -- SUBRTN to pad spaces
+1 QUIT $$PAD(" ",NUM)
