source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OV4.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1LR7OV4 ;DALOI/DCM/RLM-Immediate Lab Collect Utilities ;12/18/97 08:35
2 ;;5.2;LAB SERVICE;**187,256,272**;Sep 27, 1994
3ON(DIV) ;Check Immediate Collect parameter is on
4 ;DIV=DUZ(2) division pointer
5 Q:'$G(DIV) 0
6 Q:'$L($G(^LAB(69.9,1,7,DIV,0))) 0
7 Q:'$L($O(^LAB(69.9,1,7,DIV,0))) 0
8 Q +$P($G(^LAB(69.9,1,7,DIV,0)),"^",6)
9SHOW(DIV,LIST) ;Show current settings in LIST array
10 ;DIV=DUZ(2) division pointer
11 ;LIST=where you want the text returned
12 Q:'$G(DIV)
13 N NODE,CTR,X,CTR,CCNT,I,X1,X2,X3,X4,SP,INC
14 Q:'$G(^LAB(69.9,1,7,DIV,0)) S NODE=^(0)
15 S CTR=0,CCNT=0
16 S X=$S('$P(NODE,"^",2):"NO ",1:"")_"COLLECTION ON HOLIDAYS "
17 S X=$$S^LR7OS(1,0,$J(X,48)),CTR=CTR+1,LIST(CTR)=X
18 S CTR=CTR+1,LIST(CTR)=""
19 F I="SUN","MON","TUE","WED","THU","FRI","SAT" D
20 . I $D(^LAB(69.9,1,7,DIV,I)) S X=^(I) D
21 .. S CTR=CTR+1,LIST(CTR)=$$S^LR7OS(1,0,I_" Collection Between: ")
22 .. S X1=$E("0000",($L(+$P(X,U,2))+1),4)_$P(X,U,2)
23 .. S X2=$E("0000",($L(+$P(X,U,3))+1),4)_$P(X,U,3)
24 .. S X3=$E(X1,1,2)_":"_$E(X1,3,4)
25 .. S X4=$E(X2,1,2)_":"_$E(X2,3,4)
26 .. S LIST(CTR)=LIST(CTR)_$$S^LR7OS(30,24,$J(X3_" and "_X4,17))
27 S CTR=CTR+1,LIST(CTR)=""
28 S CTR=CTR+1,LIST(CTR)="Laboratory Service requires at least "_$P(NODE,"^",4)_" minutes to collect this order."
29 S CTR=CTR+1,LIST(CTR)=""
30 Q
31VALID(DIV,TIME) ;Validate immediate collection time
32 ;Function returns 1 if TIME is valid, 0 if not ^ user feedback text
33 ;DIV=DUZ(2) division pointer
34 ;TIME=Date/time of collection
35 N MSG
36 I '$G(TIME) S MSG="Invalid Date/time" Q 0_"^"_MSG
37 I '$P(TIME,".",2) S MSG="Time must be entered" Q 0_"^"_MSG
38 I '$G(DIV) S MSG="Division unknown" Q 0_"^"_MSG
39 N NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1,X2
40 Q:'$G(^LAB(69.9,1,7,DIV,0)) 0 S NODE=^(0)
41 I '$P(NODE,"^",2),$$FIND1^DIC(40.5,,"QX",$P(TIME,".")) D Q 0_"^"_MSG
42 . D FIND^DIC(40.5,,"2","X","`"_$$FIND1^DIC(40.5,,"QX",$P(TIME,".")),,,,,"LRHLDY")
43 . S MSG="Sorry, service not offered on: "_$G(LRHLDY("DILIST","ID",1,2)) K LRHLDY
44 S X=TIME,M=$P(NODE,U,4),D=$$NOW^LRAFUNC1 D DATE^LRORDIM
45 I $$FMADD^XLFDT(TIME,,,2)'>NOW1 S MSG="MUST BE "_M_" MINUTES IN THE FUTURE" Q 0_"^"_MSG
46 S H=$S($P(NODE,U,5):$P(NODE,U,5),1:24) D DATE^LRORDIM
47 I TIME>NOW1 S MSG="MUST BE LESS THAN "_H_" HRS IN THE FUTURE" Q 0_"^"_MSG
48 S DAY=$E($$DOW^LRAFUNC1(TIME),1,3)
49 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)
50 ;TIME is given a buffer of 2 minutes for potential processing delays in the variable X2
51 ;This buffer also allows orders scheduled at midnight to be processed when lab parameter is set to 2359
52 ;Seconds are stripped off prior to final concatenation. This prevents
53 ;errors in later comparisons with times in file 69.9.
54 S:'$L(NODE1)!('$P(NODE1,"^")) NOP=1
55 I NOP=1 S MSG="SERVICE NOT OFFERED ON "_DAY Q 0_"^"_MSG
56 I NOP=0 D I NOP=2 Q 0_"^"_MSG
57 . S:X2<$P(NODE1,U,2)!(X2>$P(NODE1,U,3)) NOP=2
58 . 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 "
59 I 'NOP S MSG="DATE/TIME ACCEPTED" Q 1_"^"_MSG
60 Q 0
61PROMPT ;Prompt for Immediate Lab Collect time
62 N %DT,X
63 W !! S %DT("A")="Enter Collection Date/Time: ",%DT="AETS"
64 S X=$$DEFTIME($G(DUZ(2))) I +X S %DT("B")=$P(X,"^",2)
65 D ^%DT
66 Q
67DEFTIME(DIV) ;Get next valid immediate collect time
68 ;Function returns time if possible, "" if not ^message
69 ;Internal time^External time^Minimum response time^Maximum hours ahead allowed
70 ;DIV=division pointer
71 I '$G(DIV) S MSG="Division unknown" Q ""_"^"_MSG
72 N NODE,M,S,H,X,Y,DAY,NODE1,NOP,%A,%DT,%T,D,D1,I,NOW1
73 Q:'$G(^LAB(69.9,1,7,DIV,0)) "" S NODE=^(0)
74 Q:'$P(NODE,"^",6) ""
75 S M=$P(NODE,U,4)+1,D=$$NOW^LRAFUNC1 D DATE^LRORDIM
76 S:$P(NOW1,".",2) $P(NOW1,".",2)=$E($P(NOW1,".",2),1,4)
77 Q NOW1_"^"_$$FMTE^XLFDT(NOW1)_"^"_$P(NODE,U,4,5)
78TEST ;Test call
79 N X,DAVE,Y,I,TXT
80 S X=$$ON($G(DUZ(2)))
81 I 'X W !!,"Immediate Lab Collect parameter is not turned on" Q
82 D SHOW($G(DUZ(2)),.DAVE)
83 S I=0 F S I=$O(DAVE(I)) Q:'I W !,DAVE(I)
84 D PROMPT Q:'Y
85 S X=$$VALID($G(DUZ(2)),Y)
86 W !,$P(X,"^",2)
87 Q
Note: See TracBrowser for help on using the repository browser.