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

ORWDLR.m

Go to the documentation of this file. 
  1. ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96  8:47 PM ]
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242
  1.  ;
  1. DEF(LST,ALOC) ; procedure
  1.  ; get dialog definition specific to lab
  1.  S ILST=0
  1.  S LST($$NXT)="~Collection Times" D COLLTM
  1.  S LST($$NXT)="~Send Patient Times" D SENDTM
  1.  S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3
  1.  ; S LST($$NXT)="~Urgencies Map" D URGMAP
  1.  S LST($$NXT)="~Schedules" D SCHED
  1.  S LST($$NXT)="~Common" D COMMON
  1.  Q
  1. COLLTM ; get collection times
  1.  N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT
  1.  S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H
  1.  M TMRW=TDAY D INCDATE(.TMRW)
  1.  I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
  1.  . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
  1.  . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
  1.  . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
  1.  . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
  1.  . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
  1.  . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
  1.  . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
  1.  . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
  1.  . S CNT=0 F  Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0))))  D  Q:CNT>6
  1.  . . D INCDATE(.TDAY) S CNT=CNT+1
  1.  . S CNT=0 F  Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0))))  D  Q:CNT>6
  1.  . . D INCDATE(.TMRW) S CNT=CNT+1
  1.  D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
  1.  S ICTM=0 F  S ICTM=$O(CTM(ICTM)) Q:'ICTM  D
  1.  . I $P(CTM(ICTM),U)>$P($H,",",2) D
  1.  . . S FMDT=TDAY
  1.  . . I +TDAY("H")=+$H S DAY="Today"
  1.  . . I TDAY("H")-$H=1 S DAY="Tomorrow"
  1.  . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
  1.  . E  D
  1.  . . S FMDT=TMRW
  1.  . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
  1.  . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM")
  1.  . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2)
  1.  . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
  1.  . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
  1.  D NOW^%DTC
  1.  S LST($$NXT)="iW"_%_"^Now (Collect on ward)"
  1.  Q
  1. SENDTM ; get send patient times
  1.  N X,X1,X2
  1.  S LST($$NXT)="iL"_DT_"^Today"
  1.  S X1=DT,X2=1 D C^%DTC
  1.  S LST($$NXT)="iL"_X_"^Tomorrow"
  1.  Q
  1. INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
  1.  N X,X1,X2,%H
  1.  S X1=ADATE,X2=1 D C^%DTC S ADATE=X
  1.  S ADATE("H")=ADATE("H")+1
  1.  S ADATE("DOW")=ADATE("H")#7
  1.  Q
  1. DOWNAME(DOW) ; function
  1.  ; Returns Day of Week name (DOW should be $H#7)
  1.  I DOW=0 Q "Thursday"
  1.  I DOW=1 Q "Friday"
  1.  I DOW=2 Q "Saturday"
  1.  I DOW=3 Q "Sunday"
  1.  I DOW=4 Q "Monday"
  1.  I DOW=5 Q "Tuesday"
  1.  I DOW=6 Q "Wednesday"
  1.  Q ""
  1. URGMAP ; return list of lab urgencies mapped to OE/RR urgencies
  1.  Q
  1.  N I,X
  1.  S I=0 F  S I=$O(^LAB(62.05,I)) Q:'I  S X=^(I,0) I '$P(X,U,3) D
  1.  . S LST($$NXT)="i"_I_"="_I_U_$P(X,U)
  1.  ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N")
  1.  ; S URG=0 F  S URG=$O(Y(URG)) Q:'URG  S LST($$NXT)="i"_URG_"="_Y(URG)
  1.  Q
  1. SCHED ; return list of schedules available for lab tests
  1.  N X,IEN
  1.  K ^TMP($J,"ORWDLR APLR")
  1.  D AP^PSS51P1("LR",,,,"ORWDLR APLR")
  1.  S X="" F  S X=$O(^TMP($J,"ORWDLR APLR","APLR",X)) Q:X=""  D
  1.  . S IEN=$O(^TMP($J,"ORWDLR APLR","APLR",X,"")) I IEN'>0 Q
  1.  . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^TMP($J,"ORWDLR APLR",IEN,5)),U)
  1.  . I X="ONE TIME" S LST($$NXT)="d"_X
  1.  K ^TMP($J,"ORWDLR APLR")
  1.  Q
  1. COMMON ; return list of commonly ordered lab tests
  1.  N TMPLST,IEN,I
  1.  D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT")
  1.  S I=0 F  S I=$O(TMPLST(I)) Q:'I  D
  1.  . S IEN=$P(TMPLST(I),U,2)
  1.  . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
  1.  Q
  1. LOAD(LST,TESTID) ; procedure
  1.  ; Return sample, specimen, & urgency info about a lab test
  1.  N X,Y,ILST,PARAM S ILST=0
  1.  S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1)
  1.  I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
  1.  S I=0 F  S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I  S LST($$NXT)="t"_^(I,0)
  1.  S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
  1.  D TEST^LR7OR3(TESTID,.Y)
  1.  S PARAM="" F  S PARAM=$O(Y(PARAM)) Q:PARAM=""  D
  1.  . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM)))
  1.  . I $D(Y(PARAM))>1 S I=0 F  S I=$O(Y(PARAM,I)) Q:'I  D
  1.  . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q
  1.  . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q
  1.  . . S LST($$NXT)="i"_I_U_Y(PARAM,I)
  1.  . . I PARAM="CollSamp" D
  1.  . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1
  1.  . . . S X=+$P(Y(PARAM,I),U,3)
  1.  . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
  1.  . . I $D(Y(PARAM,I,"WP")) S J=0 F  S J=$O(Y(PARAM,I,"WP",J)) Q:'J  D
  1.  . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0)
  1.  Q
  1. ALLSAMP(LST) ; procedure
  1.  ; returns all collection samples
  1.  ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
  1.  N SMP,SPC,ILST,IEN,X,X0
  1.  S ILST=0,LST($$NXT)="~CollSamp"
  1.  S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
  1.  . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
  1.  . . S X0=^LAB(62,IEN,0)
  1.  . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
  1.  . . I $P(X0,U,2) D
  1.  . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
  1.  . . . S SPC($P(X,U,4))=$P(X,U,10)
  1.  . . S LST($$NXT)=X
  1.  S LST($$NXT)="~Specimens"
  1.  S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S LST($$NXT)=SPC_U_SPC(SPC)
  1.  Q
  1. ABBSPEC(LST) ; procedure
  1.  ; returns specimens with abbreviation (uses 'E' xref)
  1.  N X,IEN,ILST S ILST=0
  1.  S X="" F  S X=$O(^LAB(61,"E",X)) Q:X=""  S IEN=$O(^(X,0)) D
  1.  . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
  1.  Q
  1. NXT() ; called by TESTINFO, increments ILST
  1.  S ILST=ILST+1
  1.  Q ILST
  1. STOP(VAL,X2)       ; return a calculated stop date
  1.  N X1,X
  1.  S X1=DT D C^%DTC S VAL=X
  1.  Q