APSQLAB ;IHS/ITSC/ENM/POC - PRINT MOST RECENT LAB VALUE ON PROFILE ; 5/6/94 [ 11/13/2003 4:13 PM ]
;;6.0;OUTPATIENT PHARMACY;**4,5**;09/03/97
;;6.0;OUTPATIENT PHARMACY;**100,118,133**;09/03/97;
PRINT ;EP - Prints most recent lab test value on profile.
;
N ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
N MDAYS,TSTSP,TST,INFOPCC,INFOLR,DATEPCC,DATELR,HI,LO
;I EXPECT PSODFN TO BE DEFINED BUT..IHS/OKCAO/POC 9/7/2003 MAKE SURE IT IS DEFINED
S:'$G(PSODFN) PSODFN=$S($G(PSORENW("PSODFN")):PSORENW("PSODFN"),$G(PSOREF("PSODFN")):PSOREF("PSODFN"),1:0)
I 'PSODFN W !,"I CAN'T FIND A PSODFN SO I'M QUITTING THIS SUBROUTINE...CONTACT YOUR SYSTEMS ADMINISTRATOR" Q
;END OF CHANGES IHS/OKCAO/POC 9/7/2003
;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
S MDRUG=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSOREF("DRUG IEN"))]"":PSOREF("DRUG IEN"),$G(PSORENW("DRUG IEN"))]"":PSORENW("DRUG IEN"),1:0),TST=+$P($G(^PSDRUG(MDRUG,"CLOZ")),"^"),MDAYS=+$P($G(^("CLOZ")),"^",2),TSTSP=+$P($G(^("CLOZ")),"^",3)
I 'TST!('MDAYS)!('TSTSP) D CLEAN Q
D TWO,ONE
I $G(DATEPCC)>$G(DATELR) W !,INFOPCC
E W !,INFOLR
D CLEAN
Q
;
ONE ;
S DTBACK=$$FMADD^XLFDT(DT,-MDAYS)
S ARRAY="RETURN("
;I EXPECT DFN TO BE DEFINED! BUT WELL SO I'LL USE PSODFN AND MAKE SURE IT IS DEFINED IHS/OKCAO/POC 9/8/2003
;S INFO=DFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
;S:'$G(MDAYS) INFO=DFN_"^LAST LAB `"_MDRUG
S INFO=PSODFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
S:'$G(MDAYS) INFO=PSODFN_"^LAST LAB `"_MDRUG
;END OF CHANGES IHS/OKCAO/POC 9/7/2003
S ERR=$$START1^APCLDF(INFO,ARRAY)
I $G(RETURN(1))]"" D
.S DATEPCC=$P(RETURN(1),"^",1)
.S DATE=$$FMTE^XLFDT(DATEPCC,2)
.S VALUE=$P(RETURN(1),"^",2)
.S:$G(TST)]"" TEST=$P(^LAB(60,TST,0),"^",1)
.S VLABIEN=+$P(RETURN(1),"^",4)
.S:VLABIEN SITE=$$GET1^DIQ(9000010.09,VLABIEN_",",1103,"I","","ERR")
.S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_VALUE_"***(PCC)"
.I 'SITE!(SITE'=TSTSP) Q ;QUIT IF SITE OF SPECIMEN NOT SAME AS 60
.S INFOPCC="W !,""***MOST RECENT ""_$G(TEST)_"" PERFORMED ""_DATE_"" = ""_VALUE_STUFF_""***(PCC)"""
.S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_VALUE_$$HILO(TST,TSTSP)_"***(PCC)"
.I (($G(LO)]"")&(VALUE<$G(LO)))!(($G(HI)]"")&(VALUE>$G(HI))) D ;IHS
..S X="IORVON;IORVOFF"
..D ENDR^%ZISS
..S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_IORVON_VALUE_IORVOFF_$$HILO(TST,TSTSP)_"***(PCC)"
E S DATEPCC=0
Q
;
TWO ;
;CHANGE TO PSODFN IHS/OKCAO/POC 9/7/2003
;I '$D(^DPT(DFN,"LR")) S INFOLR="*** NO LAB DATA ON FILE ***(LAB)",DATELR=0 Q
;S LRDFN=+$P(^DPT(DFN,"LR"),"^") Q:'LRDFN
I '$D(^DPT(PSODFN,"LR")) S INFOLR="*** NO LAB DATA ON FILE ***(LAB)",DATELR=0 Q
S LRDFN=+$P(^DPT(PSODFN,"LR"),"^") Q:'LRDFN
;END OF CHANGES IHS/OKCAO/POC 9/7/2003
;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
S MDRUG=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSOREF("DRUG IEN"))]"":PSOREF("DRUG IEN"),$G(PSORENW("DRUG IEN"))]"":PSORENW("DRUG IEN"),1:0),TST=+$P(^PSDRUG(MDRUG,"CLOZ"),"^"),MDAYS=+$P(^("CLOZ"),"^",2),TSTSP=+$P(^("CLOZ"),"^",3)
Q:'TST!('MDAYS)!('TSTSP)
S TSTN=$P($G(^LAB(60,TST,0)),"^"),LDN=$S($D(^(.2)):+^(.2),1:+$P($P($G(^(0)),"^",5),";",2))
;I $G(^LAB(60,TST,.2))=""&($P($P($G(^LAB(60,TST,0)),"^",5),";",2)="") W !,"*** RESULTS FOR A PANEL CANNOT BE PRINTED! ONLY A LAB TEST RESULT CAN BE PRINTED FOR MARKED DRUGS." G CLEAN
I $G(^LAB(60,TST,.2))=""&($P($P($G(^LAB(60,TST,0)),"^",5),";",2)="") S INFOLR="W !,""*** RESULTS FOR A PANEL CANNOT BE PRINTED! ONLY A LAB TEST RESULT CAN BE PRINTED FOR MARKED DRUGS.***(LAB)""" Q
EDATE S X="T-"_MDAYS K %DT D ^%DT S EDT=Y,EDL=(9999999-EDT)_".999999",INDIC=0
BEG F BDL=0:0 S BDL=$O(^LR(LRDFN,"CH",BDL)) Q:BDL=""!(BDL>EDL) D Q:INDIC=1
.Q:'$D(^LR(LRDFN,"CH",BDL,LDN))!('$D(^(0)))
.;NOTE IT WILL QUIT IF YOUR SITE IS NOT THE SAME AS WHAT IS IN LAB
.Q:$P(^LR(LRDFN,"CH",BDL,0),"^",3)=""!($P(^(0),"^",5)'=TSTSP)
.S Y=$S(+$P($P(^LR(LRDFN,"CH",BDL,0),"^"),"."):+$P($P(^(0),"^"),"."),1:$P(^(0),"^",3))
.S VALUE=$P($G(^LR(LRDFN,"CH",BDL,LDN)),"^") ;FOR HILO
.S INFOLR="*** MOST RECENT "_$G(TSTN)_" PERF0RMED "_$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_$E(Y,2,3)_" = "_$P($G(^LR(LRDFN,"CH",BDL,LDN)),"^")_" "_$P($G(^LAB(60,TST,1,TSTSP,0)),"^",7)_$$HILO(TST,TSTSP)_"***(LAB)" S INDIC=1
.I (($G(LO)]"")&(VALUE<$G(LO)))!(($G(HI)]"")&(VALUE>$G(HI))) D ;IHS
..S X="IORVON;IORVOFF"
..D ENDR^%ZISS
..S INFOLR="*** MOST RECENT "_$G(TSTN)_" PERF0RMED "_$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_$E(Y,2,3)_" = "_IORVON_$P($G(^LR(LRDFN,"CH",BDL,LDN)),"^")_" "_$P($G(^LAB(60,TST,1,TSTSP,0)),"^",7)_IORVOFF_$$HILO(TST,TSTSP)_"***(LAB)" S INDIC=1
.S DATELR=$G(Y)
I INDIC=0 S INFOLR="*** NO RESULTS FOR "_TSTN_" SINCE "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_$E(EDT,2,3)_"***(LAB)"
Q
;
HILO(TST,TSTSP) ;CALCULATE LOW AND HIGH REFERENCE VALUES
S LO=$P($G(^LAB(60,TST,1,TSTSP,0)),"^",2),HI=$P($G(^(0)),"^",3)
S:'LO LO="X"
S:'HI HI="X"
Q " ("_LO_"-"_HI_")"
;
CLEAN K BDL,EDL,EDT,INDIC,LDN,LRDFN,MDAYS,MDRUG,TST,TSTN,TSTSP,X,Y
K DATELR,DATEPCC,INFOLR,INFOPCC
K ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
K LO,HI
Q
APSQLAB ;IHS/ITSC/ENM/POC - PRINT MOST RECENT LAB VALUE ON PROFILE ; 5/6/94 [ 11/13/2003 4:13 PM ]
+1 ;;6.0;OUTPATIENT PHARMACY;**4,5**;09/03/97
+2 ;;6.0;OUTPATIENT PHARMACY;**100,118,133**;09/03/97;
PRINT ;EP - Prints most recent lab test value on profile.
+1 ;
+2 NEW ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
+3 NEW MDAYS,TSTSP,TST,INFOPCC,INFOLR,DATEPCC,DATELR,HI,LO
+4 ;I EXPECT PSODFN TO BE DEFINED BUT..IHS/OKCAO/POC 9/7/2003 MAKE SURE IT IS DEFINED
+5 IF '$GET(PSODFN)
SET PSODFN=$SELECT($GET(PSORENW("PSODFN")):PSORENW("PSODFN"),$GET(PSOREF("PSODFN")):PSOREF("PSODFN"),1:0)
+6 IF 'PSODFN
WRITE !,"I CAN'T FIND A PSODFN SO I'M QUITTING THIS SUBROUTINE...CONTACT YOUR SYSTEMS ADMINISTRATOR"
QUIT
+7 ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
+8 ;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
+9 SET MDRUG=$SELECT($GET(PSODRUG("IEN"))]"":PSODRUG("IEN"),$GET(PSOREF("DRUG IEN"))]"":PSOREF("DRUG IEN"),$GET(PSORENW("DRUG IEN"))]"":PSORENW("DRUG IEN"),1:0)
SET TST=+$PIECE($GET(^PSDRUG(MDRUG,"CLOZ")),"^")
SET MDAYS=+$PIECE($GET(^("CLOZ")),"^",2)
SET TSTSP=+$PIECE($GET(^("CLOZ")),"^",3)
+10 IF 'TST!('MDAYS)!('TSTSP)
DO CLEAN
QUIT
+11 DO TWO
DO ONE
+12 IF $GET(DATEPCC)>$GET(DATELR)
WRITE !,INFOPCC
+13 IF '$TEST
WRITE !,INFOLR
+14 DO CLEAN
+15 QUIT
+16 ;
ONE ;
+1 SET DTBACK=$$FMADD^XLFDT(DT,-MDAYS)
+2 SET ARRAY="RETURN("
+3 ;I EXPECT DFN TO BE DEFINED! BUT WELL SO I'LL USE PSODFN AND MAKE SURE IT IS DEFINED IHS/OKCAO/POC 9/8/2003
+4 ;S INFO=DFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
+5 ;S:'$G(MDAYS) INFO=DFN_"^LAST LAB `"_MDRUG
+6 SET INFO=PSODFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
+7 IF '$GET(MDAYS)
SET INFO=PSODFN_"^LAST LAB `"_MDRUG
+8 ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
+9 SET ERR=$$START1^APCLDF(INFO,ARRAY)
+10 IF $GET(RETURN(1))]""
Begin DoDot:1
+11 SET DATEPCC=$PIECE(RETURN(1),"^",1)
+12 SET DATE=$$FMTE^XLFDT(DATEPCC,2)
+13 SET VALUE=$PIECE(RETURN(1),"^",2)
+14 IF $GET(TST)]""
SET TEST=$PIECE(^LAB(60,TST,0),"^",1)
+15 SET VLABIEN=+$PIECE(RETURN(1),"^",4)
+16 IF VLABIEN
SET SITE=$$GET1^DIQ(9000010.09,VLABIEN_",",1103,"I","","ERR")
+17 SET INFOPCC="***MOST RECENT "_$GET(TEST)_" PERFORMED "_DATE_" = "_VALUE_"***(PCC)"
+18 ;QUIT IF SITE OF SPECIMEN NOT SAME AS 60
IF 'SITE!(SITE'=TSTSP)
QUIT
+19 SET INFOPCC="W !,""***MOST RECENT ""_$G(TEST)_"" PERFORMED ""_DATE_"" = ""_VALUE_STUFF_""***(PCC)"""
+20 SET INFOPCC="***MOST RECENT "_$GET(TEST)_" PERFORMED "_DATE_" = "_VALUE_$$HILO(TST,TSTSP)_"***(PCC)"
+21 ;IHS
IF (($GET(LO)]"")&(VALUE<$GET(LO)))!(($GET(HI)]"")&(VALUE>$GET(HI)))
Begin DoDot:2
+22 SET X="IORVON;IORVOFF"
+23 DO ENDR^%ZISS
+24 SET INFOPCC="***MOST RECENT "_$GET(TEST)_" PERFORMED "_DATE_" = "_IORVON_VALUE_IORVOFF_$$HILO(TST,TSTSP)_"***(PCC)"
End DoDot:2
End DoDot:1
+25 IF '$TEST
SET DATEPCC=0
+26 QUIT
+27 ;
TWO ;
+1 ;CHANGE TO PSODFN IHS/OKCAO/POC 9/7/2003
+2 ;I '$D(^DPT(DFN,"LR")) S INFOLR="*** NO LAB DATA ON FILE ***(LAB)",DATELR=0 Q
+3 ;S LRDFN=+$P(^DPT(DFN,"LR"),"^") Q:'LRDFN
+4 IF '$DATA(^DPT(PSODFN,"LR"))
SET INFOLR="*** NO LAB DATA ON FILE ***(LAB)"
SET DATELR=0
QUIT
+5 SET LRDFN=+$PIECE(^DPT(PSODFN,"LR"),"^")
IF 'LRDFN
QUIT
+6 ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
+7 ;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
+8 SET MDRUG=$SELECT($GET(PSODRUG("IEN"))]"":PSODRUG("IEN"),$GET(PSOREF("DRUG IEN"))]"":PSOREF("DRUG IEN"),$GET(PSORENW("DRUG IEN"))]"":PSORENW("DRUG IEN"),1:0)
SET TST=+$PIECE(^PSDRUG(MDRUG,"CLOZ"),"^")
SET MDAYS=+$PIECE(^("CLOZ"),"^",2)
SET TSTSP=+$PIECE(^("CLOZ"),"^",3)
+9 IF 'TST!('MDAYS)!('TSTSP)
QUIT
+10 SET TSTN=$PIECE($GET(^LAB(60,TST,0)),"^")
SET LDN=$SELECT($DATA(^(.2)):+^(.2),1:+$PIECE($PIECE($GET(^(0)),"^",5),";",2))
+11 ;I $G(^LAB(60,TST,.2))=""&($P($P($G(^LAB(60,TST,0)),"^",5),";",2)="") W !,"*** RESULTS FOR A PANEL CANNOT BE PRINTED! ONLY A LAB TEST RESULT CAN BE PRINTED FOR MARKED DRUGS." G CLEAN
+12 IF $GET(^LAB(60,TST,.2))=""&($PIECE($PIECE($GET(^LAB(60,TST,0)),"^",5),";",2)="")
SET INFOLR="W !,""*** RESULTS FOR A PANEL CANNOT BE PRINTED! ONLY A LAB TEST RESULT CAN BE PRINTED FOR MARKED DRUGS.***(LAB)"""
QUIT
EDATE SET X="T-"_MDAYS
KILL %DT
DO ^%DT
SET EDT=Y
SET EDL=(9999999-EDT)_".999999"
SET INDIC=0
BEG FOR BDL=0:0
SET BDL=$ORDER(^LR(LRDFN,"CH",BDL))
IF BDL=""!(BDL>EDL)
QUIT
Begin DoDot:1
+1 IF '$DATA(^LR(LRDFN,"CH",BDL,LDN))!('$DATA(^(0)))
QUIT
+2 ;NOTE IT WILL QUIT IF YOUR SITE IS NOT THE SAME AS WHAT IS IN LAB
+3 IF $PIECE(^LR(LRDFN,"CH",BDL,0),"^",3)=""!($PIECE(^(0),"^",5)'=TSTSP)
QUIT
+4 SET Y=$SELECT(+$PIECE($PIECE(^LR(LRDFN,"CH",BDL,0),"^"),"."):+$PIECE($PIECE(^(0),"^"),"."),1:$PIECE(^(0),"^",3))
+5 ;FOR HILO
SET VALUE=$PIECE($GET(^LR(LRDFN,"CH",BDL,LDN)),"^")
+6 SET INFOLR="*** MOST RECENT "_$GET(TSTN)_" PERF0RMED "_$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_$EXTRACT(Y,2,3)_" = "_$PIECE($GET(^LR(LRDFN,"CH",BDL,LDN)),"^")_" "_$PIECE($GET(^LAB(60,TST,1,TSTSP,0)),"^",7)_$$HILO(TST,TSTSP)_"***(LAB)"
SET INDIC=1
+7 ;IHS
IF (($GET(LO)]"")&(VALUE<$GET(LO)))!(($GET(HI)]"")&(VALUE>$GET(HI)))
Begin DoDot:2
+8 SET X="IORVON;IORVOFF"
+9 DO ENDR^%ZISS
+10 SET INFOLR="*** MOST RECENT "_$GET(TSTN)_" PERF0RMED "_$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_$EXTRACT(Y,2,3)_" = "_IORVON_$PIECE($GET(^LR(LRDFN,"CH",BDL,LDN)),"^")_" "_$PIECE($GET(^LAB(60,TST,1,TSTSP,0)),"^",7)_IORVOFF_$$HILO(
TST,TSTSP)_"***(LAB)"
SET INDIC=1
End DoDot:2
+11 SET DATELR=$GET(Y)
End DoDot:1
IF INDIC=1
QUIT
+12 IF INDIC=0
SET INFOLR="*** NO RESULTS FOR "_TSTN_" SINCE "_$EXTRACT(EDT,4,5)_"-"_$EXTRACT(EDT,6,7)_"-"_$EXTRACT(EDT,2,3)_"***(LAB)"
+13 QUIT
+14 ;
HILO(TST,TSTSP) ;CALCULATE LOW AND HIGH REFERENCE VALUES
+1 SET LO=$PIECE($GET(^LAB(60,TST,1,TSTSP,0)),"^",2)
SET HI=$PIECE($GET(^(0)),"^",3)
+2 IF 'LO
SET LO="X"
+3 IF 'HI
SET HI="X"
+4 QUIT " ("_LO_"-"_HI_")"
+5 ;
CLEAN KILL BDL,EDL,EDT,INDIC,LDN,LRDFN,MDAYS,MDRUG,TST,TSTN,TSTSP,X,Y
+1 KILL DATELR,DATEPCC,INFOLR,INFOPCC
+2 KILL ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
+3 KILL LO,HI
+4 QUIT
