LROW5 ;SLC/CJS - LAB ORDER ENTRY, WARD ;2/6/91 13:59 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
NEXTCOL ;return LRODT, from LRORD, LROW
S E=$D(^LAB(69.9,1,2,"AC",LRLLOC)),LRTXP=$S(E:"1^1^1^1^1^1^1",1:^LAB(69.9,1,5)),LRTX=$S(LRLWC="WC"!(LRLWC="SP"):"T",1:"T+"_$P(LRTXP,U,$H#7+1))
S LRCOL=$O(^LAB(69.9,1,4,$P($H,",",2))) I LRCOL,LRLWC="LC" S LRTX="T"
I LRLWC="LC",'$O(^LAB(69.9,1,4,0)) W !!?7,$C(7),"Routine Lab Collect is not available ",! Q
S LRTXD=DT G W5:LRLWC'="LC" I 'E S X=LRTX,%DT="" D ^%DT S LRTXD=Y I '$P(LRPARAM,"^",10),$D(^HOLIDAY(Y,0)) S D=$P(X,"+",2),LRTX="T+"_(D+$P(^LAB(69.9,1,5),U,(D+$H)#7+1))
W4 I LRCOL>0&(LRLWC["LC") D OTHER W !,"Next collection order cut-off time at " S Y=$P(^LAB(69.9,1,4,LRCOL,0),U),LRTX="T" D TIME^LROW S %DT("B")=LRTX_"@"_$P(^LAB(69.9,1,4,LRCOL,0),"^",2)
I 'LRCOL D OTHER W !,"Next collection order cut-off ",LRTX," at " S Y=$P(^LAB(69.9,1,4,$O(^LAB(69.9,1,4,0)),0),U) D TIME^LROW S %DT("B")=LRTX_"@"_$P(^LAB(69.9,1,4,$O(^LAB(69.9,1,4,0)),0),"^",2)
W5 S %DT("A")="SPECIMEN COLLECTION DATE/TIME: ",%DT("B")=$S(LRLWC="WC":"N",LRLWC="LC":$S($D(%DT("B")):%DT("B"),1:LRTX),1:LRTX)
S %DT=$S(LRLWC="LC":"ETRX",1:"ET") D DATE^LRWU K %DT G LEND^LROW:Y<1 S LRORDTIM=$P(Y,".",2),Y=$P(Y,".",1)
I $L(Y)=7,Y?7N,'+$E(Y,6,7) W !!?7,$C(7),"Please enter a date, ie. 4/1/90",!! G W5
S X1=Y,X2=DT D ^%DTC I LRLWC="LC",$P(LRTXP,U,X+$H-1#7+1)'=1 W !,"Can't order for that date.",$C(7) G W4
I 'E,LRLWC="LC",'$P(LRPARAM,"^",10),$D(^HOLIDAY(Y,0)) W !,"That's ",$P(^HOLIDAY(Y,0),U,2),"!",$C(7) S LRTX="" G W4
I X>$S(LRLWC="LC":7,1:370) W !,"Can't order more than ",$S(LRLWC="LC":"one week",1:"12 months")," ahead!!",$C(7) G W4
IF DT>Y W !,"Can't order in the past!!",$C(7) G:LRLWC="LC" W4 G W5
I LRLWC="LC" S Z=LRORDTIM S Z=$E(Z_"00",1,2)*3600+(60*$E(Z_"0000",3,4)) I DT=Y,Z<$P($H,",",2) W !,"Can't order in the past!!",$C(7) G W4
I LRLWC="LC" S J="",I=0 F S I=$O(^LAB(69.9,1,4,"AC",I)) Q:I<1 S J=$O(^LAB(69.9,1,4,"AC",I,J)) I DT=Y,$P($H,",",2)<I,$P($H,",",2)>J,Z'>I W !,"Order cut-off time is expired." G W4
I LRLWC="LC",$P($G(^LAB(69.9,1,4,+J,0)),U,3)<($E(LRORDTIM_"00",1,2)*3600+($E(LRORDTIM_"0000",3,4)*60)) W !,"Too late to make collection." G W4
S LRODT=Y I LRLWC="LC",LRORDTIM>0 S X=3600*$E(LRORDTIM_"00",1,2)+(60*$E(LRORDTIM_"0000",3,4)) S Y=$S($D(^LAB(69.9,1,4,"AC",X)):$O(^(X,0)),1:0) I Y=0,$O(^LAB(69.9,1,4,"AC",X)) S X=$O(^LAB(69.9,1,4,"AC",X)),Y=$O(^(X,0))
I LRLWC="LC",Y>0,LRORDTIM>0 W !,"Routinely collected at approximately: " S Y=$P(^LAB(69.9,1,4,Y,0),U,2) D TIME^LROW
Q
OTHER W !!,?5,"Collection order cut-off times: " S I=0 F S I=$O(^LAB(69.9,1,4,I)) Q:I<1 S Y=$P(^(I,0),U,2) W ?38 D TIME^LROW S Y=$P(^LAB(69.9,1,4,I,0),U) W " collection, cutoff time is " D TIME^LROW W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROW5 2746 printed Oct 16, 2024@18:19:59 Page 2
LROW5 ;SLC/CJS - LAB ORDER ENTRY, WARD ;2/6/91 13:59 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
NEXTCOL ;return LRODT, from LRORD, LROW
+1 SET E=$DATA(^LAB(69.9,1,2,"AC",LRLLOC))
SET LRTXP=$SELECT(E:"1^1^1^1^1^1^1",1:^LAB(69.9,1,5))
SET LRTX=$SELECT(LRLWC="WC"!(LRLWC="SP"):"T",1:"T+"_$PIECE(LRTXP,U,$HOROLOG#7+1))
+2 SET LRCOL=$ORDER(^LAB(69.9,1,4,$PIECE($HOROLOG,",",2)))
IF LRCOL
IF LRLWC="LC"
SET LRTX="T"
+3 IF LRLWC="LC"
IF '$ORDER(^LAB(69.9,1,4,0))
WRITE !!?7,$CHAR(7),"Routine Lab Collect is not available ",!
QUIT
+4 SET LRTXD=DT
if LRLWC'="LC"
GOTO W5
IF 'E
SET X=LRTX
SET %DT=""
DO ^%DT
SET LRTXD=Y
IF '$PIECE(LRPARAM,"^",10)
IF $DATA(^HOLIDAY(Y,0))
SET D=$PIECE(X,"+",2)
SET LRTX="T+"_(D+$PIECE(^LAB(69.9,1,5),U,(D+$HOROLOG)#7+1))
W4 IF LRCOL>0&(LRLWC["LC")
DO OTHER
WRITE !,"Next collection order cut-off time at "
SET Y=$PIECE(^LAB(69.9,1,4,LRCOL,0),U)
SET LRTX="T"
DO TIME^LROW
SET %DT("B")=LRTX_"@"_$PIECE(^LAB(69.9,1,4,LRCOL,0),"^",2)
+1 IF 'LRCOL
DO OTHER
WRITE !,"Next collection order cut-off ",LRTX," at "
SET Y=$PIECE(^LAB(69.9,1,4,$ORDER(^LAB(69.9,1,4,0)),0),U)
DO TIME^LROW
SET %DT("B")=LRTX_"@"_$PIECE(^LAB(69.9,1,4,$ORDER(^LAB(69.9,1,4,0)),0),"^",2)
W5 SET %DT("A")="SPECIMEN COLLECTION DATE/TIME: "
SET %DT("B")=$SELECT(LRLWC="WC":"N",LRLWC="LC":$SELECT($DATA(%DT("B")):%DT("B"),1:LRTX),1:LRTX)
+1 SET %DT=$SELECT(LRLWC="LC":"ETRX",1:"ET")
DO DATE^LRWU
KILL %DT
if Y<1
GOTO LEND^LROW
SET LRORDTIM=$PIECE(Y,".",2)
SET Y=$PIECE(Y,".",1)
+2 IF $LENGTH(Y)=7
IF Y?7N
IF '+$EXTRACT(Y,6,7)
WRITE !!?7,$CHAR(7),"Please enter a date, ie. 4/1/90",!!
GOTO W5
+3 SET X1=Y
SET X2=DT
DO ^%DTC
IF LRLWC="LC"
IF $PIECE(LRTXP,U,X+$HOROLOG-1#7+1)'=1
WRITE !,"Can't order for that date.",$CHAR(7)
GOTO W4
+4 IF 'E
IF LRLWC="LC"
IF '$PIECE(LRPARAM,"^",10)
IF $DATA(^HOLIDAY(Y,0))
WRITE !,"That's ",$PIECE(^HOLIDAY(Y,0),U,2),"!",$CHAR(7)
SET LRTX=""
GOTO W4
+5 IF X>$SELECT(LRLWC="LC":7,1:370)
WRITE !,"Can't order more than ",$SELECT(LRLWC="LC":"one week",1:"12 months")," ahead!!",$CHAR(7)
GOTO W4
+6 IF DT>Y
WRITE !,"Can't order in the past!!",$CHAR(7)
if LRLWC="LC"
GOTO W4
GOTO W5
+7 IF LRLWC="LC"
SET Z=LRORDTIM
SET Z=$EXTRACT(Z_"00",1,2)*3600+(60*$EXTRACT(Z_"0000",3,4))
IF DT=Y
IF Z<$PIECE($HOROLOG,",",2)
WRITE !,"Can't order in the past!!",$CHAR(7)
GOTO W4
+8 IF LRLWC="LC"
SET J=""
SET I=0
FOR
SET I=$ORDER(^LAB(69.9,1,4,"AC",I))
if I<1
QUIT
SET J=$ORDER(^LAB(69.9,1,4,"AC",I,J))
IF DT=Y
IF $PIECE($HOROLOG,",",2)<I
IF $PIECE($HOROLOG,",",2)>J
IF Z'>I
WRITE !,"Order cut-off time is expired."
GOTO W4
+9 IF LRLWC="LC"
IF $PIECE($GET(^LAB(69.9,1,4,+J,0)),U,3)<($EXTRACT(LRORDTIM_"00",1,2)*3600+($EXTRACT(LRORDTIM_"0000",3,4)*60))
WRITE !,"Too late to make collection."
GOTO W4
+10 SET LRODT=Y
IF LRLWC="LC"
IF LRORDTIM>0
SET X=3600*$EXTRACT(LRORDTIM_"00",1,2)+(60*$EXTRACT(LRORDTIM_"0000",3,4))
SET Y=$SELECT($DATA(^LAB(69.9,1,4,"AC",X)):$ORDER(^(X,0)),1:0)
IF Y=0
IF $ORDER(^LAB(69.9,1,4,"AC",X))
SET X=$ORDER(^LAB(69.9,1,4,"AC",X))
SET Y=$ORDER(^(X,0))
+11 IF LRLWC="LC"
IF Y>0
IF LRORDTIM>0
WRITE !,"Routinely collected at approximately: "
SET Y=$PIECE(^LAB(69.9,1,4,Y,0),U,2)
DO TIME^LROW
+12 QUIT
OTHER WRITE !!,?5,"Collection order cut-off times: "
SET I=0
FOR
SET I=$ORDER(^LAB(69.9,1,4,I))
if I<1
QUIT
SET Y=$PIECE(^(I,0),U,2)
WRITE ?38
DO TIME^LROW
SET Y=$PIECE(^LAB(69.9,1,4,I,0),U)
WRITE " collection, cutoff time is "
DO TIME^LROW
WRITE !
+1 QUIT
