LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;9/16/2000
;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 31
;
TEST ;
S DIC=2 S DIC(0)="AEMQZ" D ^DIC
Q:Y=-1
S LRDFN=$G(^DPT(+Y,"LR"))
;
;
;
ORDCHK ; Here is where the search for an order number starts
K LRHYT654
; The Howdy site file will help determine which orders the site
; will accept. Once an order has been selected it is handed off
; to LRORDST to start the accessioning process.
;
K LRWCZZZ,LRDTF
K LRHYCS33
K ^TMP("LRHYDY",$J,"KILL")
;
;
K ^TMP("LRHYDY",$J,"MULTD")
K ^TMP("LRHYDY",$J,"DUPTEST")
K LRHYCS
K ^TMP("LRHYDY",$J,"MT")
S LRHOWDY=1
S LREND=0
S LRORD=""
Q:'LRDFN
;
K ^TMP("LRHYDY",$J,"LRSN"),LRNPZZX
S LRHYOK=0
;
; 18 days ahead
; 20 days back
;
S X2=0 K LRNPZZX
S LRAHEAD=$G(^LRHY(69.86,LRHYSITE,18))
S LRPAST=$G(^LRHY(69.86,LRHYSITE,20))
K LRWCZZZ
F LRI=-LRPAST:1:LRAHEAD D ;Search window set by site file.
. S X1=DT S X2=LRI D C^%DTC S LR3DTN=X
. I $D(^LRO(69,LR3DTN,1,"AA",LRDFN)) S LRHYOK=1 D
.. S LR3SN=0
.. F S LR3SN=$O(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN)) Q:+LR3SN'>0 D
... Q:$P($G(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C" ;collected
... K LRWCZZZ
... ;
... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
... K LRCSTAT S LRCSTAT=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
... D CSTATUS^LRHYA Q:LRHYHOK ;Check collection status
... ;
... D OLT^LRHYA ;print order label tests
... Q:LRHYHOK
... ;
... ;
... K LRNOTST
... S LRNODUP=0 D LTE^LRHYA Q:LRHYHOK ;check for excluded lab tests
... ;
... S LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
... S LRLLOC66=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
... D EXLOC^LRHYA Q:LRHYHOK ;check for locations to exclude
... ;
... S LRLLOC=$G(LRLLOC66)
... S LRORD24=0
... D OLT^LRHYA Q:LRHYHOK ;print order label tests
... ;
... D URG^LRHYA Q:LRHYHOK ;; CHECK URGENCY
... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
... D CSE^LRHYA Q:LRHYHOK ;check for excluded collection samples
... ;
... I $O(^TMP("LRHYDY",$J,"EXLOC",LRORD,0))=$G(LRLLOC66) I $O(^LRO(69,"C",LRORD,0))'=DT QUIT
... ; CHECK URGENCY
... S LRTST6=0 ; micro test
... F S LRTST6=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTST6)) Q:+LRTST6'>0 D
.... S LRTSTZ99(LRTST6)=""
.... I LRTST6 S LRSUB1=$P(^LAB(60,LRTST6,0),U,4) ; subscript
.... Q:$D(LRNPZZX(^LRO(69,LR3DTN,1,LR3SN,.1),LR3SN,LRTST6))
.... S LRORD=$G(^LRO(69,LR3DTN,1,LR3SN,.1))
.... I $G(LRORD) I $D(^TMP("LRHYDY",$J,"STATUS",LRORD)) QUIT
.... I $D(LRNOTST) I $D(LRNOTST(LRTST6)) K LRORD QUIT
.... S ^TMP("LRHYDY",$J,"LRSN",LR3DTN,^LRO(69,LR3DTN,1,LR3SN,.1))=""
.... S LRDTX=""
.... S LRDTX=$O(^LRO(69,"C",^LRO(69,LR3DTN,1,LR3SN,.1),0))
.... I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I $G(LRDTX) S ^TMP("LRHYDY",$J,"MT",LRDTX)=""
;
;
K LRMULT
I $G(LRWCMULT) W !!!!,"Multple Orders Present" S LRMULT=1 D LOG1^LRHY0 K LRWCMULT QUIT
; per Libba 1/14/2002
I $D(^TMP("LRHYDY",$J,"LRSN",DT)) S LR3DTN=DT ; I prefer today's orders but...
E S LR3DTN=$O(^TMP("LRHYDY",$J,"LRSN",0)) ; I'll take whatever ya got
I 'LR3DTN K LRORD QUIT
;
I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I $O(^TMP("LRHYDY",$J,"LRSN",LR3DTN)) W !,"MULTIPLE DAYS WITH ORDERS" S LRMULT=1 D LOG1^LRHY0 QUIT
;
S LRTIC=0
S LRMULT=0
;
F S LRTIC=$O(^TMP("LRHYDY",$J,"LRSN",LRTIC)) Q:+LRTIC'>0 S LRMULT=LRMULT+1
I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I LRMULT>1 W !,"MULTIPLE DAYS WITH ORDERS" S LRMULT=0 D LOG1^LRHY0 QUIT
;MODIFIED BY HOAK to flag when wc and sp are on same visit
;
;
MOVE ;
I $D(LRNOTST) I $G(LRHYT654) I $D(LRNOTST(LRHYT654)) K LRORD QUIT
S LRHY3SN3=0
S LRHY3DT3=0
I $D(^TMP("LRHYDY",$J,"URG",LRORD)) K LRORD QUIT
I $D(^LRHY(69.86,LRHYSITE,30,"B",LRURGZ19)) K LRORD QUIT
S LRTIC=0
S LRMULT=0
F S LRTIC=$O(^TMP("LRHYDY",$J,"MT",LRTIC)) Q:+LRTIC'>0 S LRMULT=LRMULT+1
S LR3MULT=LRMULT
I LRMULT>1 W !,"MULTIPLE DAYS WITH ORDERS" S LRORD=0 QUIT
E S LRMULT=0
; may be accessioned.
; Setting up task to continue based on the specimen.
K LR3ZTST
MOVE1 ;
S LRORD=0
F S LRORD=$O(^TMP("LRHYDY",$J,"LRSN",LR3DTN,LRORD)) Q:+LRORD'>0 D
. S:'$G(LR3ORD) LR3ORD=LRORD
. I $D(^TMP("LRHYDY",$J,"URG",LRORD)) QUIT
. S LRHYORDZ=LRORD
. ;
. S ZTSAVE("^TMP(""LRHYDY"",$J,")=""
. S ZTRTN="PAST^LRHYPH0",ZTSAVE("L*")="",ZTDTH=$H,ZTDESC="HOWDY"
. S ZTIO="NULL"
. S ZTSAVE("L*")=""
. S:$D(ZTQUEUED) ZTREQ="@" D ^%ZTLOAD
. S LRGOTIT=1
. S LRORD=LRHYORDZ
. K LRSTOPZ(LRORD)
K ^TMP("LRHYDY",$J,"MULTD")
S LRORD=$G(LR3ORD) K LR3ORD
K LRHOWDY,LR3SN24,LR3DTN24,LR3ZTST
; Remove collection info on order label tests
S LR3DTN=0
F S LR3DTN=$O(LROLT1(LR3DTN)) Q:+LR3DTN'>0 D
. S LR3SN=0
. F S LR3SN=$O(LROLT1(LR3DTN,LR3SN)) Q:+LR3SN'>0 D
.. S ^LRO(69,LR3DTN,1,LR3SN,1)=""
K LROLT1
I $G(LRORD) I $D(LRSTOPZ(LRORD)) K LRORD,LRSTOPZ QUIT
;
QUIT
;
MMM ;
N LRI S LRI=0
N LR3DTN,LR3SN,LRIENZZ,LRTSTX
K LRHYMORD
K LRHYMULT
F LRI=-LRPAST:1:LRAHEAD D
. S X1=DT S X2=LRI D C^%DTC S LR3DTN=X
. ;
. I $D(^LRO(69,LR3DTN,1,"AA",LRDFN)) D
.. S LR3SN=0
.. F S LR3SN=$O(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN)) Q:+LR3SN'>0 D
... ;
... Q:$P($G(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C" ;collected
... S LRTSTX=0
... F S LRTSTX=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX)) Q:+LRTSTX'>0 D
.... S LRIENZZ=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX,0))
.... ;
.... Q:$G(^LRO(69,LR3DTN,1,LR3SN,2,LRIENZZ,1.1,1,0))'=""
.... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
.... S LRHYHOK=0 D CSE^LRHYA Q:LRHYHOK
.... S LRCSTAT=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
.... S LRHYHOK=0 D CSTATUS^LRHYA Q:LRHYHOK
.... S LRLLOC66=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
.... S LRHYHOK=0 D EXLOC^LRHYA Q:LRHYHOK
.... S LRHYMULT(LR3DTN,LR3SN,LRIENZZ)=LRTSTX
N CNT
S CNT=0
S LR3DTN=0
F S LR3DTN=$O(LRHYMULT(LR3DTN)) Q:+LR3DTN'>0 S CNT=CNT+1
I CNT>1 S LRHYMORD=1
LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;9/16/2000
+1 ;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 31
+2 ;
TEST ;
+1 SET DIC=2
SET DIC(0)="AEMQZ"
DO ^DIC
+2 IF Y=-1
QUIT
+3 SET LRDFN=$GET(^DPT(+Y,"LR"))
+4 ;
+5 ;
+6 ;
ORDCHK ; Here is where the search for an order number starts
+1 KILL LRHYT654
+2 ; The Howdy site file will help determine which orders the site
+3 ; will accept. Once an order has been selected it is handed off
+4 ; to LRORDST to start the accessioning process.
+5 ;
+6 KILL LRWCZZZ,LRDTF
+7 KILL LRHYCS33
+8 KILL ^TMP("LRHYDY",$JOB,"KILL")
+9 ;
+10 ;
+11 KILL ^TMP("LRHYDY",$JOB,"MULTD")
+12 KILL ^TMP("LRHYDY",$JOB,"DUPTEST")
+13 KILL LRHYCS
+14 KILL ^TMP("LRHYDY",$JOB,"MT")
+15 SET LRHOWDY=1
+16 SET LREND=0
+17 SET LRORD=""
+18 IF 'LRDFN
QUIT
+19 ;
+20 KILL ^TMP("LRHYDY",$JOB,"LRSN"),LRNPZZX
+21 SET LRHYOK=0
+22 ;
+23 ; 18 days ahead
+24 ; 20 days back
+25 ;
+26 SET X2=0
KILL LRNPZZX
+27 SET LRAHEAD=$GET(^LRHY(69.86,LRHYSITE,18))
+28 SET LRPAST=$GET(^LRHY(69.86,LRHYSITE,20))
+29 KILL LRWCZZZ
+30 ;Search window set by site file.
FOR LRI=-LRPAST:1:LRAHEAD
Begin DoDot:1
+31 SET X1=DT
SET X2=LRI
DO C^%DTC
SET LR3DTN=X
+32 IF $DATA(^LRO(69,LR3DTN,1,"AA",LRDFN))
SET LRHYOK=1
Begin DoDot:2
+33 SET LR3SN=0
+34 FOR
SET LR3SN=$ORDER(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN))
IF +LR3SN'>0
QUIT
Begin DoDot:3
+35 ;collected
IF $PIECE($GET(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C"
QUIT
+36 KILL LRWCZZZ
+37 ;
+38 KILL LRCOL99
SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
+39 KILL LRCSTAT
SET LRCSTAT=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
+40 ;Check collection status
DO CSTATUS^LRHYA
IF LRHYHOK
QUIT
+41 ;
+42 ;print order label tests
DO OLT^LRHYA
+43 IF LRHYHOK
QUIT
+44 ;
+45 ;
+46 KILL LRNOTST
+47 ;check for excluded lab tests
SET LRNODUP=0
DO LTE^LRHYA
IF LRHYHOK
QUIT
+48 ;
+49 SET LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
+50 SET LRLLOC66=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
+51 ;check for locations to exclude
DO EXLOC^LRHYA
IF LRHYHOK
QUIT
+52 ;
+53 SET LRLLOC=$GET(LRLLOC66)
+54 SET LRORD24=0
+55 ;print order label tests
DO OLT^LRHYA
IF LRHYHOK
QUIT
+56 ;
+57 ;; CHECK URGENCY
DO URG^LRHYA
IF LRHYHOK
QUIT
+58 KILL LRCOL99
SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
+59 ;check for excluded collection samples
DO CSE^LRHYA
IF LRHYHOK
QUIT
+60 ;
+61 IF $ORDER(^TMP("LRHYDY",$JOB,"EXLOC",LRORD,0))=$GET(LRLLOC66)
IF $ORDER(^LRO(69,"C",LRORD,0))'=DT
QUIT
+62 ; CHECK URGENCY
+63 ; micro test
SET LRTST6=0
+64 FOR
SET LRTST6=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTST6))
IF +LRTST6'>0
QUIT
Begin DoDot:4
+65 SET LRTSTZ99(LRTST6)=""
+66 ; subscript
IF LRTST6
SET LRSUB1=$PIECE(^LAB(60,LRTST6,0),U,4)
+67 IF $DATA(LRNPZZX(^LRO(69,LR3DTN,1,LR3SN,.1),LR3SN,LRTST6))
QUIT
+68 SET LRORD=$GET(^LRO(69,LR3DTN,1,LR3SN,.1))
+69 IF $GET(LRORD)
IF $DATA(^TMP("LRHYDY",$JOB,"STATUS",LRORD))
QUIT
+70 IF $DATA(LRNOTST)
IF $DATA(LRNOTST(LRTST6))
KILL LRORD
QUIT
+71 SET ^TMP("LRHYDY",$JOB,"LRSN",LR3DTN,^LRO(69,LR3DTN,1,LR3SN,.1))=""
+72 SET LRDTX=""
+73 SET LRDTX=$ORDER(^LRO(69,"C",^LRO(69,LR3DTN,1,LR3SN,.1),0))
+74 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF $GET(LRDTX)
SET ^TMP("LRHYDY",$JOB,"MT",LRDTX)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+75 ;
+76 ;
+77 KILL LRMULT
+78 IF $GET(LRWCMULT)
WRITE !!!!,"Multple Orders Present"
SET LRMULT=1
DO LOG1^LRHY0
KILL LRWCMULT
QUIT
+79 ; per Libba 1/14/2002
+80 ; I prefer today's orders but...
IF $DATA(^TMP("LRHYDY",$JOB,"LRSN",DT))
SET LR3DTN=DT
+81 ; I'll take whatever ya got
IF '$TEST
SET LR3DTN=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",0))
+82 IF 'LR3DTN
KILL LRORD
QUIT
+83 ;
+84 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF $ORDER(^TMP("LRHYDY",$JOB,"LRSN",LR3DTN))
WRITE !,"MULTIPLE DAYS WITH ORDERS"
SET LRMULT=1
DO LOG1^LRHY0
QUIT
+85 ;
+86 SET LRTIC=0
+87 SET LRMULT=0
+88 ;
+89 FOR
SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",LRTIC))
IF +LRTIC'>0
QUIT
SET LRMULT=LRMULT+1
+90 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF LRMULT>1
WRITE !,"MULTIPLE DAYS WITH ORDERS"
SET LRMULT=0
DO LOG1^LRHY0
QUIT
+91 ;MODIFIED BY HOAK to flag when wc and sp are on same visit
+92 ;
+93 ;
MOVE ;
+1 IF $DATA(LRNOTST)
IF $GET(LRHYT654)
IF $DATA(LRNOTST(LRHYT654))
KILL LRORD
QUIT
+2 SET LRHY3SN3=0
+3 SET LRHY3DT3=0
+4 IF $DATA(^TMP("LRHYDY",$JOB,"URG",LRORD))
KILL LRORD
QUIT
+5 IF $DATA(^LRHY(69.86,LRHYSITE,30,"B",LRURGZ19))
KILL LRORD
QUIT
+6 SET LRTIC=0
+7 SET LRMULT=0
+8 FOR
SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"MT",LRTIC))
IF +LRTIC'>0
QUIT
SET LRMULT=LRMULT+1
+9 SET LR3MULT=LRMULT
+10 IF LRMULT>1
WRITE !,"MULTIPLE DAYS WITH ORDERS"
SET LRORD=0
QUIT
+11 IF '$TEST
SET LRMULT=0
+12 ; may be accessioned.
+13 ; Setting up task to continue based on the specimen.
+14 KILL LR3ZTST
MOVE1 ;
+1 SET LRORD=0
+2 FOR
SET LRORD=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",LR3DTN,LRORD))
IF +LRORD'>0
QUIT
Begin DoDot:1
+3 IF '$GET(LR3ORD)
SET LR3ORD=LRORD
+4 IF $DATA(^TMP("LRHYDY",$JOB,"URG",LRORD))
QUIT
+5 SET LRHYORDZ=LRORD
+6 ;
+7 SET ZTSAVE("^TMP(""LRHYDY"",$J,")=""
+8 SET ZTRTN="PAST^LRHYPH0"
SET ZTSAVE("L*")=""
SET ZTDTH=$HOROLOG
SET ZTDESC="HOWDY"
+9 SET ZTIO="NULL"
+10 SET ZTSAVE("L*")=""
+11 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ^%ZTLOAD
+12 SET LRGOTIT=1
+13 SET LRORD=LRHYORDZ
+14 KILL LRSTOPZ(LRORD)
End DoDot:1
+15 KILL ^TMP("LRHYDY",$JOB,"MULTD")
+16 SET LRORD=$GET(LR3ORD)
KILL LR3ORD
+17 KILL LRHOWDY,LR3SN24,LR3DTN24,LR3ZTST
+18 ; Remove collection info on order label tests
+19 SET LR3DTN=0
+20 FOR
SET LR3DTN=$ORDER(LROLT1(LR3DTN))
IF +LR3DTN'>0
QUIT
Begin DoDot:1
+21 SET LR3SN=0
+22 FOR
SET LR3SN=$ORDER(LROLT1(LR3DTN,LR3SN))
IF +LR3SN'>0
QUIT
Begin DoDot:2
+23 SET ^LRO(69,LR3DTN,1,LR3SN,1)=""
End DoDot:2
End DoDot:1
+24 KILL LROLT1
+25 IF $GET(LRORD)
IF $DATA(LRSTOPZ(LRORD))
KILL LRORD,LRSTOPZ
QUIT
+26 ;
+27 QUIT
+28 ;
MMM ;
+1 NEW LRI
SET LRI=0
+2 NEW LR3DTN,LR3SN,LRIENZZ,LRTSTX
+3 KILL LRHYMORD
+4 KILL LRHYMULT
+5 FOR LRI=-LRPAST:1:LRAHEAD
Begin DoDot:1
+6 SET X1=DT
SET X2=LRI
DO C^%DTC
SET LR3DTN=X
+7 ;
+8 IF $DATA(^LRO(69,LR3DTN,1,"AA",LRDFN))
Begin DoDot:2
+9 SET LR3SN=0
+10 FOR
SET LR3SN=$ORDER(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN))
IF +LR3SN'>0
QUIT
Begin DoDot:3
+11 ;
+12 ;collected
IF $PIECE($GET(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C"
QUIT
+13 SET LRTSTX=0
+14 FOR
SET LRTSTX=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX))
IF +LRTSTX'>0
QUIT
Begin DoDot:4
+15 SET LRIENZZ=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX,0))
+16 ;
+17 IF $GET(^LRO(69,LR3DTN,1,LR3SN,2,LRIENZZ,1.1,1,0))'=""
QUIT
+18 KILL LRCOL99
SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
+19 SET LRHYHOK=0
DO CSE^LRHYA
IF LRHYHOK
QUIT
+20 SET LRCSTAT=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
+21 SET LRHYHOK=0
DO CSTATUS^LRHYA
IF LRHYHOK
QUIT
+22 SET LRLLOC66=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
+23 SET LRHYHOK=0
DO EXLOC^LRHYA
IF LRHYHOK
QUIT
+24 SET LRHYMULT(LR3DTN,LR3SN,LRIENZZ)=LRTSTX
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 NEW CNT
+26 SET CNT=0
+27 SET LR3DTN=0
+28 FOR
SET LR3DTN=$ORDER(LRHYMULT(LR3DTN))
IF +LR3DTN'>0
QUIT
SET CNT=CNT+1
+29 IF CNT>1
SET LRHYMORD=1
