LR7OV4 ;DALOI/DCM/RLM-Immediate Lab Collect Utilities ;12/18/97 08:35
;;5.2;LAB SERVICE;**187,256,272**;Sep 27, 1994
ON(DIV) ;Check Immediate Collect parameter is on
;DIV=DUZ(2) division pointer
Q:'$G(DIV) 0
Q:'$L($G(^LAB(69.9,1,7,DIV,0))) 0
Q:'$L($O(^LAB(69.9,1,7,DIV,0))) 0
Q +$P($G(^LAB(69.9,1,7,DIV,0)),"^",6)
SHOW(DIV,LIST) ;Show current settings in LIST array
;DIV=DUZ(2) division pointer
;LIST=where you want the text returned
Q:'$G(DIV)
N NODE,CTR,X,CTR,CCNT,I,X1,X2,X3,X4,SP,INC
Q:'$G(^LAB(69.9,1,7,DIV,0)) S NODE=^(0)
S CTR=0,CCNT=0
S X=$S('$P(NODE,"^",2):"NO ",1:"")_"COLLECTION ON HOLIDAYS "
S X=$$S^LR7OS(1,0,$J(X,48)),CTR=CTR+1,LIST(CTR)=X
S CTR=CTR+1,LIST(CTR)=""
F I="SUN","MON","TUE","WED","THU","FRI","SAT" D
. I $D(^LAB(69.9,1,7,DIV,I)) S X=^(I) D
.. S CTR=CTR+1,LIST(CTR)=$$S^LR7OS(1,0,I_" Collection Between: ")
.. S X1=$E("0000",($L(+$P(X,U,2))+1),4)_$P(X,U,2)
.. S X2=$E("0000",($L(+$P(X,U,3))+1),4)_$P(X,U,3)
.. S X3=$E(X1,1,2)_":"_$E(X1,3,4)
.. S X4=$E(X2,1,2)_":"_$E(X2,3,4)
.. S LIST(CTR)=LIST(CTR)_$$S^LR7OS(30,24,$J(X3_" and "_X4,17))
S CTR=CTR+1,LIST(CTR)=""
S CTR=CTR+1,LIST(CTR)="Laboratory Service requires at least "_$P(NODE,"^",4)_" minutes to collect this order."
S CTR=CTR+1,LIST(CTR)=""
Q
VALID(DIV,TIME) ;Validate immediate collection time
;Function returns 1 if TIME is valid, 0 if not ^ user feedback text
;DIV=DUZ(2) division pointer
;TIME=Date/time of collection
N MSG
I '$G(TIME) S MSG="Invalid Date/time" Q 0_"^"_MSG
I '$P(TIME,".",2) S MSG="Time must be entered" Q 0_"^"_MSG
I '$G(DIV) S MSG="Division unknown" Q 0_"^"_MSG
N NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1,X2
Q:'$G(^LAB(69.9,1,7,DIV,0)) 0 S NODE=^(0)
I '$P(NODE,"^",2),$$FIND1^DIC(40.5,,"QX",$P(TIME,".")) D Q 0_"^"_MSG
. D FIND^DIC(40.5,,"2","X","`"_$$FIND1^DIC(40.5,,"QX",$P(TIME,".")),,,,,"LRHLDY")
. S MSG="Sorry, service not offered on: "_$G(LRHLDY("DILIST","ID",1,2)) K LRHLDY
S X=TIME,M=$P(NODE,U,4),D=$$NOW^LRAFUNC1 D DATE^LRORDIM
I $$FMADD^XLFDT(TIME,,,2)'>NOW1 S MSG="MUST BE "_M_" MINUTES IN THE FUTURE" Q 0_"^"_MSG
S H=$S($P(NODE,U,5):$P(NODE,U,5),1:24) D DATE^LRORDIM
I TIME>NOW1 S MSG="MUST BE LESS THAN "_H_" HRS IN THE FUTURE" Q 0_"^"_MSG
S DAY=$E($$DOW^LRAFUNC1(TIME),1,3)
S NODE1=$G(^LAB(69.9,1,7,DUZ(2),DAY)),NOP=0,X2=$P($$FMADD^XLFDT(TIME,,,2),".",2),X2=$E(X2,1,4)_$E("0000",($L(X2)+1),4)
;TIME is given a buffer of 2 minutes for potential processing delays in the variable X2
;This buffer also allows orders scheduled at midnight to be processed when lab parameter is set to 2359
;Seconds are stripped off prior to final concatenation. This prevents
;errors in later comparisons with times in file 69.9.
S:'$L(NODE1)!('$P(NODE1,"^")) NOP=1
I NOP=1 S MSG="SERVICE NOT OFFERED ON "_DAY Q 0_"^"_MSG
I NOP=0 D I NOP=2 Q 0_"^"_MSG
. S:X2<$P(NODE1,U,2)!(X2>$P(NODE1,U,3)) NOP=2
. I NOP=2 S MSG="SERVICE FOR ["_DAY_"] OFFERED BETWEEN "_$E("0000",($L(+$P(NODE1,U,2))+1),4)_$P(NODE1,U,2)_" AND "_$E("0000",($L(+$P(NODE1,U,3))+1),4)_$P(NODE1,U,3)_" Hrs "
I 'NOP S MSG="DATE/TIME ACCEPTED" Q 1_"^"_MSG
Q 0
PROMPT ;Prompt for Immediate Lab Collect time
N %DT,X
W !! S %DT("A")="Enter Collection Date/Time: ",%DT="AETS"
S X=$$DEFTIME($G(DUZ(2))) I +X S %DT("B")=$P(X,"^",2)
D ^%DT
Q
DEFTIME(DIV) ;Get next valid immediate collect time
;Function returns time if possible, "" if not ^message
;Internal time^External time^Minimum response time^Maximum hours ahead allowed
;DIV=division pointer
I '$G(DIV) S MSG="Division unknown" Q ""_"^"_MSG
N NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1
Q:'$G(^LAB(69.9,1,7,DIV,0)) "" S NODE=^(0)
Q:'$P(NODE,"^",6) ""
S M=$P(NODE,U,4)+1,D=$$NOW^LRAFUNC1 D DATE^LRORDIM
S:$P(NOW1,".",2) $P(NOW1,".",2)=$E($P(NOW1,".",2),1,4)
Q NOW1_"^"_$$FMTE^XLFDT(NOW1)_"^"_$P(NODE,U,4,5)
TEST ;Test call
N X,DAVE,Y,I,TXT
S X=$$ON($G(DUZ(2)))
I 'X W !!,"Immediate Lab Collect parameter is not turned on" Q
D SHOW($G(DUZ(2)),.DAVE)
S I=0 F S I=$O(DAVE(I)) Q:'I W !,DAVE(I)
D PROMPT Q:'Y
S X=$$VALID($G(DUZ(2)),Y)
W !,$P(X,"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OV4 4154 printed Dec 13, 2024@02:05:58 Page 2
LR7OV4 ;DALOI/DCM/RLM-Immediate Lab Collect Utilities ;12/18/97 08:35
+1 ;;5.2;LAB SERVICE;**187,256,272**;Sep 27, 1994
ON(DIV) ;Check Immediate Collect parameter is on
+1 ;DIV=DUZ(2) division pointer
+2 if '$GET(DIV)
QUIT 0
+3 if '$LENGTH($GET(^LAB(69.9,1,7,DIV,0)))
QUIT 0
+4 if '$LENGTH($ORDER(^LAB(69.9,1,7,DIV,0)))
QUIT 0
+5 QUIT +$PIECE($GET(^LAB(69.9,1,7,DIV,0)),"^",6)
SHOW(DIV,LIST) ;Show current settings in LIST array
+1 ;DIV=DUZ(2) division pointer
+2 ;LIST=where you want the text returned
+3 if '$GET(DIV)
QUIT
+4 NEW NODE,CTR,X,CTR,CCNT,I,X1,X2,X3,X4,SP,INC
+5 if '$GET(^LAB(69.9,1,7,DIV,0))
QUIT
SET NODE=^(0)
+6 SET CTR=0
SET CCNT=0
+7 SET X=$SELECT('$PIECE(NODE,"^",2):"NO ",1:"")_"COLLECTION ON HOLIDAYS "
+8 SET X=$$S^LR7OS(1,0,$JUSTIFY(X,48))
SET CTR=CTR+1
SET LIST(CTR)=X
+9 SET CTR=CTR+1
SET LIST(CTR)=""
+10 FOR I="SUN","MON","TUE","WED","THU","FRI","SAT"
Begin DoDot:1
+11 IF $DATA(^LAB(69.9,1,7,DIV,I))
SET X=^(I)
Begin DoDot:2
+12 SET CTR=CTR+1
SET LIST(CTR)=$$S^LR7OS(1,0,I_" Collection Between: ")
+13 SET X1=$EXTRACT("0000",($LENGTH(+$PIECE(X,U,2))+1),4)_$PIECE(X,U,2)
+14 SET X2=$EXTRACT("0000",($LENGTH(+$PIECE(X,U,3))+1),4)_$PIECE(X,U,3)
+15 SET X3=$EXTRACT(X1,1,2)_":"_$EXTRACT(X1,3,4)
+16 SET X4=$EXTRACT(X2,1,2)_":"_$EXTRACT(X2,3,4)
+17 SET LIST(CTR)=LIST(CTR)_$$S^LR7OS(30,24,$JUSTIFY(X3_" and "_X4,17))
End DoDot:2
End DoDot:1
+18 SET CTR=CTR+1
SET LIST(CTR)=""
+19 SET CTR=CTR+1
SET LIST(CTR)="Laboratory Service requires at least "_$PIECE(NODE,"^",4)_" minutes to collect this order."
+20 SET CTR=CTR+1
SET LIST(CTR)=""
+21 QUIT
VALID(DIV,TIME) ;Validate immediate collection time
+1 ;Function returns 1 if TIME is valid, 0 if not ^ user feedback text
+2 ;DIV=DUZ(2) division pointer
+3 ;TIME=Date/time of collection
+4 NEW MSG
+5 IF '$GET(TIME)
SET MSG="Invalid Date/time"
QUIT 0_"^"_MSG
+6 IF '$PIECE(TIME,".",2)
SET MSG="Time must be entered"
QUIT 0_"^"_MSG
+7 IF '$GET(DIV)
SET MSG="Division unknown"
QUIT 0_"^"_MSG
+8 NEW NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1,X2
+9 if '$GET(^LAB(69.9,1,7,DIV,0))
QUIT 0
SET NODE=^(0)
+10 IF '$PIECE(NODE,"^",2)
IF $$FIND1^DIC(40.5,,"QX",$PIECE(TIME,"."))
Begin DoDot:1
+11 DO FIND^DIC(40.5,,"2","X","`"_$$FIND1^DIC(40.5,,"QX",$PIECE(TIME,".")),,,,,"LRHLDY")
+12 SET MSG="Sorry, service not offered on: "_$GET(LRHLDY("DILIST","ID",1,2))
KILL LRHLDY
End DoDot:1
QUIT 0_"^"_MSG
+13 SET X=TIME
SET M=$PIECE(NODE,U,4)
SET D=$$NOW^LRAFUNC1
DO DATE^LRORDIM
+14 IF $$FMADD^XLFDT(TIME,,,2)'>NOW1
SET MSG="MUST BE "_M_" MINUTES IN THE FUTURE"
QUIT 0_"^"_MSG
+15 SET H=$SELECT($PIECE(NODE,U,5):$PIECE(NODE,U,5),1:24)
DO DATE^LRORDIM
+16 IF TIME>NOW1
SET MSG="MUST BE LESS THAN "_H_" HRS IN THE FUTURE"
QUIT 0_"^"_MSG
+17 SET DAY=$EXTRACT($$DOW^LRAFUNC1(TIME),1,3)
+18 SET NODE1=$GET(^LAB(69.9,1,7,DUZ(2),DAY))
SET NOP=0
SET X2=$PIECE($$FMADD^XLFDT(TIME,,,2),".",2)
SET X2=$EXTRACT(X2,1,4)_$EXTRACT("0000",($LENGTH(X2)+1),4)
+19 ;TIME is given a buffer of 2 minutes for potential processing delays in the variable X2
+20 ;This buffer also allows orders scheduled at midnight to be processed when lab parameter is set to 2359
+21 ;Seconds are stripped off prior to final concatenation. This prevents
+22 ;errors in later comparisons with times in file 69.9.
+23 if '$LENGTH(NODE1)!('$PIECE(NODE1,"^"))
SET NOP=1
+24 IF NOP=1
SET MSG="SERVICE NOT OFFERED ON "_DAY
QUIT 0_"^"_MSG
+25 IF NOP=0
Begin DoDot:1
+26 if X2<$PIECE(NODE1,U,2)!(X2>$PIECE(NODE1,U,3))
SET NOP=2
+27 IF NOP=2
SET MSG="SERVICE FOR ["_DAY_"] OFFERED BETWEEN "_$EXTRACT("0000",($LENGTH(+$PIECE(NODE1,U,2))+1),4)_$PIECE(NODE1,U,2)_" AND "_$EXTRACT("0000",($LENGTH(+$PIECE(NODE1,U,3))+1),4)_$PIECE(NODE1,U,3)_" Hrs "
End DoDot:1
IF NOP=2
QUIT 0_"^"_MSG
+28 IF 'NOP
SET MSG="DATE/TIME ACCEPTED"
QUIT 1_"^"_MSG
+29 QUIT 0
PROMPT ;Prompt for Immediate Lab Collect time
+1 NEW %DT,X
+2 WRITE !!
SET %DT("A")="Enter Collection Date/Time: "
SET %DT="AETS"
+3 SET X=$$DEFTIME($GET(DUZ(2)))
IF +X
SET %DT("B")=$PIECE(X,"^",2)
+4 DO ^%DT
+5 QUIT
DEFTIME(DIV) ;Get next valid immediate collect time
+1 ;Function returns time if possible, "" if not ^message
+2 ;Internal time^External time^Minimum response time^Maximum hours ahead allowed
+3 ;DIV=division pointer
+4 IF '$GET(DIV)
SET MSG="Division unknown"
QUIT ""_"^"_MSG
+5 NEW NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1
+6 if '$GET(^LAB(69.9,1,7,DIV,0))
QUIT ""
SET NODE=^(0)
+7 if '$PIECE(NODE,"^",6)
QUIT ""
+8 SET M=$PIECE(NODE,U,4)+1
SET D=$$NOW^LRAFUNC1
DO DATE^LRORDIM
+9 if $PIECE(NOW1,".",2)
SET $PIECE(NOW1,".",2)=$EXTRACT($PIECE(NOW1,".",2),1,4)
+10 QUIT NOW1_"^"_$$FMTE^XLFDT(NOW1)_"^"_$PIECE(NODE,U,4,5)
TEST ;Test call
+1 NEW X,DAVE,Y,I,TXT
+2 SET X=$$ON($GET(DUZ(2)))
+3 IF 'X
WRITE !!,"Immediate Lab Collect parameter is not turned on"
QUIT
+4 DO SHOW($GET(DUZ(2)),.DAVE)
+5 SET I=0
FOR
SET I=$ORDER(DAVE(I))
if 'I
QUIT
WRITE !,DAVE(I)
+6 DO PROMPT
if 'Y
QUIT
+7 SET X=$$VALID($GET(DUZ(2)),Y)
+8 WRITE !,$PIECE(X,"^",2)
+9 QUIT
