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