LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;9/16/2000
;;5.2;LAB SERVICE;**405,417,446,457,467,491**;Sep 27, 1994;Build 2
;
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,LREXORD
S LRLOCS=0 ; flag for non-EXLOC and EXLOC on same specimen number
F LRI=-LRPAST:1:LRAHEAD D Q:$G(LRLOCS) ;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:$G(LRLOCS)
... 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)),LR3DTN=DT,$G(LRDTX) S ^TMP("LRHYDY",$J,"MT",LRDTX)=""
.... 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
I $G(LRORD),$D(LREXORD(LRORD)) K LRORD QUIT
S LRHY3SN3=0
S LRHY3DT3=0
I $G(LRORD),$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,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYB 6074 printed Mar 13, 2024@23:15:29 Page 2
LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;9/16/2000
+1 ;;5.2;LAB SERVICE;**405,417,446,457,467,491**;Sep 27, 1994;Build 2
+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,LREXORD
+30 ; flag for non-EXLOC and EXLOC on same specimen number
SET LRLOCS=0
+31 ;Search window set by site file.
FOR LRI=-LRPAST:1:LRAHEAD
Begin DoDot:1
+32 SET X1=DT
SET X2=LRI
DO C^%DTC
SET LR3DTN=X
+33 IF $DATA(^LRO(69,LR3DTN,1,"AA",LRDFN))
SET LRHYOK=1
Begin DoDot:2
+34 SET LR3SN=0
+35 FOR
SET LR3SN=$ORDER(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN))
if +LR3SN'>0
QUIT
Begin DoDot:3
+36 ;collected
if $PIECE($GET(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C"
QUIT
+37 KILL LRWCZZZ
+38 ;
+39 KILL LRCOL99
SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
+40 KILL LRCSTAT
SET LRCSTAT=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
+41 ;Check collection status
DO CSTATUS^LRHYA
if LRHYHOK
QUIT
+42 ;
+43 ;print order label tests
DO OLT^LRHYA
+44 if LRHYHOK
QUIT
+45 ;
+46 ;
+47 KILL LRNOTST
+48 ;check for excluded lab tests
SET LRNODUP=0
DO LTE^LRHYA
if LRHYHOK
QUIT
+49 ;
+50 SET LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
+51 SET LRLLOC66=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
+52 ;check for locations to exclude
DO EXLOC^LRHYA
if LRHYHOK
QUIT
+53 ;
+54 SET LRLLOC=$GET(LRLLOC66)
+55 SET LRORD24=0
+56 ;print order label tests
DO OLT^LRHYA
if LRHYHOK
QUIT
+57 ;
+58 ;; CHECK URGENCY
DO URG^LRHYA
if LRHYHOK
QUIT
+59 KILL LRCOL99
SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
+60 ;check for excluded collection samples
DO CSE^LRHYA
if LRHYHOK
QUIT
+61 ;
+62 IF $ORDER(^TMP("LRHYDY",$JOB,"EXLOC",LRORD,0))=$GET(LRLLOC66)
IF $ORDER(^LRO(69,"C",LRORD,0))'=DT
QUIT
+63 ; CHECK URGENCY
+64 ; micro test
SET LRTST6=0
+65 FOR
SET LRTST6=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTST6))
if +LRTST6'>0
QUIT
Begin DoDot:4
+66 SET LRTSTZ99(LRTST6)=""
+67 ; subscript
IF LRTST6
SET LRSUB1=$PIECE(^LAB(60,LRTST6,0),U,4)
+68 if $DATA(LRNPZZX(^LRO(69,LR3DTN,1,LR3SN,.1),LR3SN,LRTST6))
QUIT
+69 SET LRORD=$GET(^LRO(69,LR3DTN,1,LR3SN,.1))
+70 IF $GET(LRORD)
IF $DATA(^TMP("LRHYDY",$JOB,"STATUS",LRORD))
QUIT
+71 IF $DATA(LRNOTST)
IF $DATA(LRNOTST(LRTST6))
KILL LRORD
QUIT
+72 SET ^TMP("LRHYDY",$JOB,"LRSN",LR3DTN,^LRO(69,LR3DTN,1,LR3SN,.1))=""
+73 SET LRDTX=""
+74 SET LRDTX=$ORDER(^LRO(69,"C",^LRO(69,LR3DTN,1,LR3SN,.1),0))
+75 IF $DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF LR3DTN=DT
IF $GET(LRDTX)
SET ^TMP("LRHYDY",$JOB,"MT",LRDTX)=""
+76 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF $GET(LRDTX)
SET ^TMP("LRHYDY",$JOB,"MT",LRDTX)=""
End DoDot:4
End DoDot:3
if $GET(LRLOCS)
QUIT
End DoDot:2
End DoDot:1
if $GET(LRLOCS)
QUIT
+77 ;
+78 ;
+79 KILL LRMULT
+80 IF $GET(LRWCMULT)
WRITE !!!!,"Multple Orders Present"
SET LRMULT=1
DO LOG1^LRHY0
KILL LRWCMULT
QUIT
+81 ; per Libba 1/14/2002
+82 ; I prefer today's orders but...
IF $DATA(^TMP("LRHYDY",$JOB,"LRSN",DT))
SET LR3DTN=DT
+83 ; I'll take whatever ya got
IF '$TEST
SET LR3DTN=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",0))
+84 IF 'LR3DTN
KILL LRORD
QUIT
+85 ;
+86 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
+87 ;
+88 SET LRTIC=0
+89 SET LRMULT=0
+90 ;
+91 FOR
SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",LRTIC))
if +LRTIC'>0
QUIT
SET LRMULT=LRMULT+1
+92 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
IF LRMULT>1
WRITE !,"MULTIPLE DAYS WITH ORDERS"
SET LRMULT=0
DO LOG1^LRHY0
QUIT
+93 ;MODIFIED BY HOAK to flag when wc and sp are on same visit
+94 ;
+95 ;
MOVE ;
+1 IF $DATA(LRNOTST)
IF $GET(LRHYT654)
IF $DATA(LRNOTST(LRHYT654))
KILL LRORD
QUIT
+2 IF $GET(LRORD)
IF $DATA(LREXORD(LRORD))
KILL LRORD
QUIT
+3 SET LRHY3SN3=0
+4 SET LRHY3DT3=0
+5 IF $GET(LRORD)
IF $DATA(^TMP("LRHYDY",$JOB,"URG",LRORD))
KILL LRORD
QUIT
+6 IF $DATA(^LRHY(69.86,LRHYSITE,30,"B",LRURGZ19))
KILL LRORD
QUIT
+7 SET LRTIC=0
+8 SET LRMULT=0
+9 FOR
SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"MT",LRTIC))
if +LRTIC'>0
QUIT
SET LRMULT=LRMULT+1
+10 SET LR3MULT=LRMULT
+11 IF LRMULT>1
WRITE !,"MULTIPLE DAYS WITH ORDERS"
SET LRORD=0
QUIT
+12 IF '$TEST
SET LRMULT=0
+13 ; may be accessioned.
+14 ; Setting up task to continue based on the specimen.
+15 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,LROLT1
+18 IF $GET(LRORD)
IF $DATA(LRSTOPZ(LRORD))
KILL LRORD,LRSTOPZ
QUIT
+19 ;
+20 QUIT
+21 ;
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