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

APSQLAB.m

Go to the documentation of this file. 
  1. 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
  1.  ;;6.0;OUTPATIENT PHARMACY;**100,118,133**;09/03/97;
  1. PRINT ;EP - Prints most recent lab test value on profile.
  1.  ;
  1.  N ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
  1.  N MDAYS,TSTSP,TST,INFOPCC,INFOLR,DATEPCC,DATELR,HI,LO
  1.  ;I EXPECT PSODFN TO BE DEFINED BUT..IHS/OKCAO/POC 9/7/2003 MAKE SURE IT IS DEFINED
  1.  S:'$G(PSODFN) PSODFN=$S($G(PSORENW("PSODFN")):PSORENW("PSODFN"),$G(PSOREF("PSODFN")):PSOREF("PSODFN"),1:0)
  1.  I 'PSODFN W !,"I CAN'T FIND A PSODFN SO I'M QUITTING THIS SUBROUTINE...CONTACT YOUR SYSTEMS ADMINISTRATOR" Q
  1.  ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
  1.  ;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
  1.  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)
  1.  I 'TST!('MDAYS)!('TSTSP) D CLEAN Q
  1.  D TWO,ONE
  1.  I $G(DATEPCC)>$G(DATELR) W !,INFOPCC
  1.  E  W !,INFOLR
  1.  D CLEAN
  1.  Q
  1.  ;
  1. ONE ;
  1.  S DTBACK=$$FMADD^XLFDT(DT,-MDAYS)
  1.  S ARRAY="RETURN("
  1.  ;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
  1.  ;S INFO=DFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
  1.  ;S:'$G(MDAYS) INFO=DFN_"^LAST LAB `"_MDRUG
  1.  S INFO=PSODFN_"^LAST LAB `"_TST_";DURING "_DTBACK_"-"_DT
  1.  S:'$G(MDAYS) INFO=PSODFN_"^LAST LAB `"_MDRUG
  1.  ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
  1.  S ERR=$$START1^APCLDF(INFO,ARRAY)
  1.  I $G(RETURN(1))]"" D
  1.  .S DATEPCC=$P(RETURN(1),"^",1)
  1.  .S DATE=$$FMTE^XLFDT(DATEPCC,2)
  1.  .S VALUE=$P(RETURN(1),"^",2)
  1.  .S:$G(TST)]"" TEST=$P(^LAB(60,TST,0),"^",1)
  1.  .S VLABIEN=+$P(RETURN(1),"^",4)
  1.  .S:VLABIEN SITE=$$GET1^DIQ(9000010.09,VLABIEN_",",1103,"I","","ERR")
  1.  .S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_VALUE_"***(PCC)"
  1.  .I 'SITE!(SITE'=TSTSP) Q  ;QUIT IF SITE OF SPECIMEN NOT SAME AS 60
  1.  .S INFOPCC="W !,""***MOST RECENT ""_$G(TEST)_"" PERFORMED ""_DATE_"" = ""_VALUE_STUFF_""***(PCC)"""
  1.  .S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_VALUE_$$HILO(TST,TSTSP)_"***(PCC)"
  1.  .I (($G(LO)]"")&(VALUE<$G(LO)))!(($G(HI)]"")&(VALUE>$G(HI))) D  ;IHS
  1.  ..S X="IORVON;IORVOFF"
  1.  ..D ENDR^%ZISS
  1.  ..S INFOPCC="***MOST RECENT "_$G(TEST)_" PERFORMED "_DATE_" = "_IORVON_VALUE_IORVOFF_$$HILO(TST,TSTSP)_"***(PCC)"
  1.  E  S DATEPCC=0
  1.  Q
  1.  ;
  1. TWO ;
  1.  ;CHANGE TO PSODFN IHS/OKCAO/POC 9/7/2003
  1.  ;I '$D(^DPT(DFN,"LR")) S INFOLR="*** NO LAB DATA ON FILE ***(LAB)",DATELR=0 Q
  1.  ;S LRDFN=+$P(^DPT(DFN,"LR"),"^") Q:'LRDFN
  1.  I '$D(^DPT(PSODFN,"LR")) S INFOLR="*** NO LAB DATA ON FILE ***(LAB)",DATELR=0 Q
  1.  S LRDFN=+$P(^DPT(PSODFN,"LR"),"^") Q:'LRDFN
  1.  ;END OF CHANGES IHS/OKCAO/POC 9/7/2003
  1.  ;CHANGE WHERE MDRUG COMES FROM IHS/OKCAO/POC 11/5/2002
  1.  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)
  1.  Q:'TST!('MDAYS)!('TSTSP)
  1.  S TSTN=$P($G(^LAB(60,TST,0)),"^"),LDN=$S($D(^(.2)):+^(.2),1:+$P($P($G(^(0)),"^",5),";",2))
  1.  ;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
  1.  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
  1. EDATE S X="T-"_MDAYS K %DT D ^%DT S EDT=Y,EDL=(9999999-EDT)_".999999",INDIC=0
  1. BEG F BDL=0:0 S BDL=$O(^LR(LRDFN,"CH",BDL)) Q:BDL=""!(BDL>EDL)  D  Q:INDIC=1
  1.  .Q:'$D(^LR(LRDFN,"CH",BDL,LDN))!('$D(^(0)))
  1.  .;NOTE IT WILL QUIT IF YOUR SITE IS NOT THE SAME AS WHAT IS IN LAB
  1.  .Q:$P(^LR(LRDFN,"CH",BDL,0),"^",3)=""!($P(^(0),"^",5)'=TSTSP)
  1.  .S Y=$S(+$P($P(^LR(LRDFN,"CH",BDL,0),"^"),"."):+$P($P(^(0),"^"),"."),1:$P(^(0),"^",3))
  1.  .S VALUE=$P($G(^LR(LRDFN,"CH",BDL,LDN)),"^")  ;FOR HILO
  1.  .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
  1.  .I (($G(LO)]"")&(VALUE<$G(LO)))!(($G(HI)]"")&(VALUE>$G(HI))) D  ;IHS
  1.  ..S X="IORVON;IORVOFF"
  1.  ..D ENDR^%ZISS
  1.  ..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
  1.  .S DATELR=$G(Y)
  1.  I INDIC=0 S INFOLR="*** NO RESULTS FOR "_TSTN_" SINCE "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_$E(EDT,2,3)_"***(LAB)"
  1.  Q
  1.  ;
  1. HILO(TST,TSTSP)  ;CALCULATE LOW AND HIGH REFERENCE VALUES
  1.  S LO=$P($G(^LAB(60,TST,1,TSTSP,0)),"^",2),HI=$P($G(^(0)),"^",3)
  1.  S:'LO LO="X"
  1.  S:'HI HI="X"
  1.  Q " ("_LO_"-"_HI_")"
  1.  ;
  1. CLEAN K BDL,EDL,EDT,INDIC,LDN,LRDFN,MDAYS,MDRUG,TST,TSTN,TSTSP,X,Y
  1.  K DATELR,DATEPCC,INFOLR,INFOPCC
  1.  K ARRAY,RETURN,ERR,DATE,VALUE,TEST,INFO,DTBACK
  1.  K LO,HI
  1.  Q