- 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 Jan 18, 2025@03:06:42 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