ORWDPLM1 ;PBM/HINES/RMS - DISPLAY LAB DATA IN CPRS ORDERING DIALOG ; 21 Dec 2016 4:46 PM
;;3.0;ORDER ENTRY/RESULTS REPORTING;**420**;;Build 7
SL Q:'$$GET^XPAR("ALL","OR CPRS LAB DISPLAY ENABLED") ; param off? - skip
N DIC,X,Y,ORL50,ORL507,ORL2,ORLNODE,ORLRSLT,FOUND,ORLCRCL,REFRANGE
S ORL2=+$G(ORVP) I ORL2 G SL2
S X=$TR($G(VA("PID")),"-"),DIC=2,DIC(0)="M"
D ^DIC
Q:Y=-1
S ORL2=+Y
SL2 S ORL507=+$P($G(^ORD(101.43,OI,0)),U,2) Q:'+ORL507
S ORL50=0 F S ORL50=$O(^PSDRUG("ASP",ORL507,ORL50)) Q:'+ORL50!($G(FOUND)) D
. S ORLNODE=$G(^PSDRUG(ORL50,"CLOZ")) Q:'+ORLNODE
. I +ORLNODE,$$SCRTEST(+ORLNODE) S ORLRSLT=$$GETSCR(ORL2) S ILST=ILST+1,LST(ILST)="tLAST "_$$GET1^DIQ(60,+ORLNODE,.01)_": "_$P(ORLRSLT,U)
. I +ORLNODE,'$$SCRTEST(+ORLNODE) S ORLRSLT=$$GETLAB(ORL2,+ORLNODE,+$P(ORLNODE,U,3),$P(ORLNODE,U,2)) S ILST=ILST+1,LST(ILST)="tLAST "_$$GET1^DIQ(60,+ORLNODE,.01)_": "_$P(ORLRSLT,U)
. I +$P(ORLRSLT,U,2) S LST(ILST)=LST(ILST)_" "_$P(ORLRSLT,U,4)_" ("_$$FMTE^XLFDT($P(ORLRSLT,U,2))_")"
. I $P(ORLRSLT,U,5)]"" S ILST=ILST+1,LST(ILST)="tREFERENCE RANGE: "_$P(ORLRSLT,U,5)_" "_$P(ORLRSLT,U,4)
. I +$P(ORLRSLT,U,2) I $$SCRTEST(+ORLNODE) S ORLCRCL=$$CRCL^PSOORUT2(ORL2) I +$P(ORLCRCL,U,2) S ILST=ILST+1,LST(ILST)="tEstimated Creatinine Clearance: "_$P(ORLCRCL,U,2)_" mL/min"
. S FOUND=1
Q
;
GETSCR(DFN) ;New PBM/RMS 1-29-2016
;If lab test is CREATININE, get results using national term
N OCXTL,OCXTLS,SCR,OCXT,OCXTS,SCRD,PSCR,SCRV
S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") "No mapped creatinine lab test available"
S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") "No mapped serum specimen found"
S PSCR="^^^^^^0"
S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D
.S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D
..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 "NONE FOUND IN LAST "_$S(+$P(ORLNODE,U,2):$P(ORLNODE,U,2),1:365)_" DAYS"
S SCRD=$P(SCR,U,7) Q:'$L(SCRD) "NONE FOUND IN LAST "_$S(+$P(ORLNODE,U,2):$P(ORLNODE,U,2),1:365)_" DAYS"
I $$FMADD^XLFDT(DT,-$P(ORLNODE,U,2))>SCRD Q "NONE FOUND IN LAST "_$S(+$P(ORLNODE,U,2):$P(ORLNODE,U,2),1:365)_" DAYS" ;Result Before Max Days
Q $P(SCR,U,3)_U_$P(SCR,U,7)_U_$P(SCR,U,2)_U_$P(SCR,U,4)_U_$P(SCR,U,6)
;
SCRTEST(LAB60) ;New PBM/RMS 1-29-2016
;Function to check if drug-associated lab test is CREATININE
N TERM,IEN,OCXTL,ORLSCR
S TERM=$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE")
S IEN=0
F S IEN=$O(OCXTL(IEN)) Q:'+IEN S ORLSCR(+$G(OCXTL(IEN)))=""
Q $D(ORLSCR(LAB60))
;
GETLAB(DFN,TEST,SPEC,MDAYS) ;CUSTOM LAB LOOKUP API
N ORLBDT,TESTNAME,RESULT,LNAME,LDATE,UNITS
N X,X1,X2
Q:'+$G(TEST) ""
Q:'+$G(DFN) ""
S TESTNAME=$P($G(^LAB(60,TEST,0)),U)
S MDAYS=$G(MDAYS,365)
S X1=DT,X2=-$G(MDAYS) D C^%DTC
S ORLBDT=$S(X<DT:X,1:0)
D RR^LR7OR1(DFN,,ORLBDT,DT,,TEST,,1,$G(SPEC))
D FORMAT
I $G(RESULT)']"" Q "NONE FOUND IN LAST "_+$S(+MDAYS:MDAYS,1:365)_" DAYS"_U_U_TESTNAME
Q RESULT_U_LDATE_U_LNAME_U_UNITS_U_REFRANGE
FORMAT N IDT,LOC,NODE
S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'+IDT D
. S LOC=0 F S LOC=$O(^TMP("LRRR",$J,DFN,"CH",IDT,LOC)) Q:'+LOC D
.. S NODE=$G(^TMP("LRRR",$J,DFN,"CH",IDT,LOC))
.. S RESULT=$P(NODE,U,2)
.. S UNITS=$P(NODE,U,4)
.. S LNAME=$P(NODE,U,10)
.. S REFRANGE=$P(NODE,U,5)
.. I LNAME']"" S LNAME=$P(NODE,U,15)
.. S LDATE=9999999-IDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPLM1 3468 printed Nov 22, 2024@17:45:33 Page 2
ORWDPLM1 ;PBM/HINES/RMS - DISPLAY LAB DATA IN CPRS ORDERING DIALOG ; 21 Dec 2016 4:46 PM
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**420**;;Build 7
SL ; param off? - skip
if '$$GET^XPAR("ALL","OR CPRS LAB DISPLAY ENABLED")
QUIT
+1 NEW DIC,X,Y,ORL50,ORL507,ORL2,ORLNODE,ORLRSLT,FOUND,ORLCRCL,REFRANGE
+2 SET ORL2=+$GET(ORVP)
IF ORL2
GOTO SL2
+3 SET X=$TRANSLATE($GET(VA("PID")),"-")
SET DIC=2
SET DIC(0)="M"
+4 DO ^DIC
+5 if Y=-1
QUIT
+6 SET ORL2=+Y
SL2 SET ORL507=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
if '+ORL507
QUIT
+1 SET ORL50=0
FOR
SET ORL50=$ORDER(^PSDRUG("ASP",ORL507,ORL50))
if '+ORL50!($GET(FOUND))
QUIT
Begin DoDot:1
+2 SET ORLNODE=$GET(^PSDRUG(ORL50,"CLOZ"))
if '+ORLNODE
QUIT
+3 IF +ORLNODE
IF $$SCRTEST(+ORLNODE)
SET ORLRSLT=$$GETSCR(ORL2)
SET ILST=ILST+1
SET LST(ILST)="tLAST "_$$GET1^DIQ(60,+ORLNODE,.01)_": "_$PIECE(ORLRSLT,U)
+4 IF +ORLNODE
IF '$$SCRTEST(+ORLNODE)
SET ORLRSLT=$$GETLAB(ORL2,+ORLNODE,+$PIECE(ORLNODE,U,3),$PIECE(ORLNODE,U,2))
SET ILST=ILST+1
SET LST(ILST)="tLAST "_$$GET1^DIQ(60,+ORLNODE,.01)_": "_$PIECE(ORLRSLT,U)
+5 IF +$PIECE(ORLRSLT,U,2)
SET LST(ILST)=LST(ILST)_" "_$PIECE(ORLRSLT,U,4)_" ("_$$FMTE^XLFDT($PIECE(ORLRSLT,U,2))_")"
+6 IF $PIECE(ORLRSLT,U,5)]""
SET ILST=ILST+1
SET LST(ILST)="tREFERENCE RANGE: "_$PIECE(ORLRSLT,U,5)_" "_$PIECE(ORLRSLT,U,4)
+7 IF +$PIECE(ORLRSLT,U,2)
IF $$SCRTEST(+ORLNODE)
SET ORLCRCL=$$CRCL^PSOORUT2(ORL2)
IF +$PIECE(ORLCRCL,U,2)
SET ILST=ILST+1
SET LST(ILST)="tEstimated Creatinine Clearance: "_$PIECE(ORLCRCL,U,2)_" mL/min"
+8 SET FOUND=1
End DoDot:1
+9 QUIT
+10 ;
GETSCR(DFN) ;New PBM/RMS 1-29-2016
+1 ;If lab test is CREATININE, get results using national term
+2 NEW OCXTL,OCXTLS,SCR,OCXT,OCXTS,SCRD,PSCR,SCRV
+3 SET OCXTL=""
if '$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE")
QUIT "No mapped creatinine lab test available"
+4 SET OCXTLS=""
if '$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN")
QUIT "No mapped serum specimen found"
+5 SET PSCR="^^^^^^0"
+6 SET SCR=""
SET OCXT=0
FOR
SET OCXT=$ORDER(OCXTL(OCXT))
if 'OCXT
QUIT
Begin DoDot:1
+7 SET OCXTS=0
FOR
SET OCXTS=$ORDER(OCXTLS(OCXTS))
if 'OCXTS
QUIT
Begin DoDot:2
+8 SET SCR=$$LOCL^ORQQLR1(DFN,$PIECE(OCXTL(OCXT),U),$PIECE(OCXTLS(OCXTS),U))
+9 IF $PIECE(SCR,U,7)>$PIECE(PSCR,U,7)
SET PSCR=SCR
End DoDot:2
End DoDot:1
+10 SET SCR=PSCR
SET SCRV=$PIECE(SCR,U,3)
if +$GET(SCRV)<.01
QUIT "NONE FOUND IN LAST "_$SELECT(+$PIECE(ORLNODE,U,2):$PIECE(ORLNODE,U,2),1:365)_" DAYS"
+11 SET SCRD=$PIECE(SCR,U,7)
if '$LENGTH(SCRD)
QUIT "NONE FOUND IN LAST "_$SELECT(+$PIECE(ORLNODE,U,2):$PIECE(ORLNODE,U,2),1:365)_" DAYS"
+12 ;Result Before Max Days
IF $$FMADD^XLFDT(DT,-$PIECE(ORLNODE,U,2))>SCRD
QUIT "NONE FOUND IN LAST "_$SELECT(+$PIECE(ORLNODE,U,2):$PIECE(ORLNODE,U,2),1:365)_" DAYS"
+13 QUIT $PIECE(SCR,U,3)_U_$PIECE(SCR,U,7)_U_$PIECE(SCR,U,2)_U_$PIECE(SCR,U,4)_U_$PIECE(SCR,U,6)
+14 ;
SCRTEST(LAB60) ;New PBM/RMS 1-29-2016
+1 ;Function to check if drug-associated lab test is CREATININE
+2 NEW TERM,IEN,OCXTL,ORLSCR
+3 SET TERM=$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE")
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(OCXTL(IEN))
if '+IEN
QUIT
SET ORLSCR(+$GET(OCXTL(IEN)))=""
+6 QUIT $DATA(ORLSCR(LAB60))
+7 ;
GETLAB(DFN,TEST,SPEC,MDAYS) ;CUSTOM LAB LOOKUP API
+1 NEW ORLBDT,TESTNAME,RESULT,LNAME,LDATE,UNITS
+2 NEW X,X1,X2
+3 if '+$GET(TEST)
QUIT ""
+4 if '+$GET(DFN)
QUIT ""
+5 SET TESTNAME=$PIECE($GET(^LAB(60,TEST,0)),U)
+6 SET MDAYS=$GET(MDAYS,365)
+7 SET X1=DT
SET X2=-$GET(MDAYS)
DO C^%DTC
+8 SET ORLBDT=$SELECT(X<DT:X,1:0)
+9 DO RR^LR7OR1(DFN,,ORLBDT,DT,,TEST,,1,$GET(SPEC))
+10 DO FORMAT
+11 IF $GET(RESULT)']""
QUIT "NONE FOUND IN LAST "_+$SELECT(+MDAYS:MDAYS,1:365)_" DAYS"_U_U_TESTNAME
+12 QUIT RESULT_U_LDATE_U_LNAME_U_UNITS_U_REFRANGE
FORMAT NEW IDT,LOC,NODE
+1 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT))
if '+IDT
QUIT
Begin DoDot:1
+2 SET LOC=0
FOR
SET LOC=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT,LOC))
if '+LOC
QUIT
Begin DoDot:2
+3 SET NODE=$GET(^TMP("LRRR",$JOB,DFN,"CH",IDT,LOC))
+4 SET RESULT=$PIECE(NODE,U,2)
+5 SET UNITS=$PIECE(NODE,U,4)
+6 SET LNAME=$PIECE(NODE,U,10)
+7 SET REFRANGE=$PIECE(NODE,U,5)
+8 IF LNAME']""
SET LNAME=$PIECE(NODE,U,15)
+9 SET LDATE=9999999-IDT
End DoDot:2
End DoDot:1
+10 QUIT
