LRHYPH0 ;VA/DALOI/HOAK - HOWDY ORDER NUMBER SELECTOR PRIME ; 13-Aug-2013 09:16 ; MKK
;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
;
K LRORIFN,LRNATURE,LREND,LRORDRR
S LRLWC="WC"
D ^LRPARAM
I $G(LREND) S LREND=0 Q
L5 ;
NEXT ;
K DIR
I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
I $D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D
. W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
. S DIR("A")=" Are you sure you want to continue",DIR(0)="Y",DIR("B")="No"
I $T D ^DIR G END:$D(DIRUT) I Y'=1 W !,"OK, try later." Q
S X="T-7",%DT="" D ^%DT S LRTM7=+Y
K DIC,LRSND,LRSN
W !!,"Select Order number: " R LRORD:DTIME W ! Q:LRORD["^"!(LRORD[".")!($D(LRLONG)&(LRORD=""))
PAST ; HOWDY IN HERE
W @IOF S M9=0 G QUICK^LROE1:LRORD=""
S:LRORD?.N LRORD=+LRORD IF LRORD'?.N D QMSG QUIT
I '$D(^LRO(69,"C",LRORD)) W !!?10,"No order exist with that number ",$C(7),! QUIT
S (LRCHK,LRNONE)=1,(M9,LRODT)=0
F S LRODT=+$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S DA=0 F S DA=$O(^LRO(69,"C",LRORD,LRODT,DA)) Q:DA<1 S LRCHK=LRCHK-1 S:LRNONE'=2 LRNONE=0 D LROE2
I LRNONE=2 W !,"The order has already been",$S(LRCHK<1:" partially",1:"")," accessioned." H 1
I LRNONE=1 W !,"No order exists with that number." H 1 QUIT
I '$$GOT(LRORD,LRODT) QUIT
K DIR S DIR("A")="Is this the correct order",DIR(0)="Y"
S DIR("B")="Yes"
K DIR S Y=1
I $D(DIRUT)!(Y'=1) K LRSN QUIT
L +^LRO(69,"C",LRORD):$G(DILOCKTM,3)
I '$T W !?5,"Someone else is editing this Order",!!,$C(7) QUIT
K %DT
S LRSTATUS="",%DT("B")=""
D TIME K %DT
D:$G(LRCDT)<1 UNL69 QUIT:LRCDT<1
S LRTIM=+LRCDT
S LRUN=$P(LRCDT,U,2) K LRCDT,LRSN
MORE ;
S M9=0
S (LRODT,LRSND)=0
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S LRSND=0
. F S LRSND=$O(^LRO(69,"C",LRORD,LRODT,LRSND)) Q:LRSND<1 D
. . S LRSN(LRSND)=LRSND,LRSN=LRSND
. . K LRAA D Q15^LRHYPH2 K LRSN
D TASK,UNL69
QUIT
;
;
LROE2 ;
I $D(^LRO(69,LRODT,1,DA,1)),$P(^(1),U,4)="" S LRNONE=2,LRCHK=LRCHK+1
K LRSN
S (LRSN,LRSN(DA))=+DA
I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
S M9=$G(M9)+1,LR3X=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LR3X,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
Q
;
;
QMSG W !,"Enter the order entry number assigned when the test was ordered."
W:'$D(LRLONG) !,"If the test has not been ordered, type the RETURN key to order the test."
W !,"To exit, type the ""^"" key and RETURN key."
Q
;
;
YN R X:DTIME W ! S:'$T DTOUT=1 Q:X=""!(X["N")!(X["Y")
W !,"Answer 'Y' or 'N': " G YN
;
;
EN ;
LROEN S LRNCWL=1
D LROE,END K LRNCWL
Q
;
LROE ;
QUIT
;
EN01 ; ENTER ORDER # THEN ENTER DATA
STAT ;
D ^LRPARAM
I '$D(LRLABKY) W !!?10,"You do not have the proper security Keys",! Q
;
; Select peforming laboratory
S X=$$SELPL^LRVERA(DUZ(2))
I X<1 D END Q
I X'=DUZ(2) N LRPL S LRPL=X
;
S LRLONG="",LRPANEL=0,LROESTAT=""
S %H=$H-60 D YMD^LRX S LRTM60=9999999-X
D LROE K LRTM60,LRLONG,LREND,LROESTAT
D END
Q
;
;
TIME ;from LROE1, LRORD1
D NOW^%DTC S LRCDT=% QUIT ;STUFFED FOR HOWDY
S %DT="SET" W !,"Collection Date@Time: ",$S($D(%DT("B")):%DT("B"),1:"NOW"),"//" R X:DTIME W ! I '$T!(X="^") S LRCDT=-1 Q
S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
W:X["?" !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
I X["@U",$P(X,"@U",2)="" S X=$P(X,"@U",1) D ^%DT G TIME:Y<1 S LRCDT=+Y_"^1" Q
S:X="U" LRCDT=DT_"^1"
I X'="U" D ^%DT D:X'["?" TIME1 G TIME:X["?" S LRCDT=+Y_"^" G TIME:Y'["."
Q
;
TIME1 S X1=X,Y1=Y D TIME2 S X=X1,Y=Y1 K X1,Y1
Q
;
TIME2 S X="N",%DT="ST" D ^%DT Q:Y1'>Y F W !,"You have specified a collection time in the future. Are you sure" S %=2 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o."
S:%'=1 X="?" S X1=X
Q
;
;
TASK ;
; If traditional Howdy is used this is where labels print-control passes to GT549
; If alternative Howdy is used label printing is delayed.
I $G(^%ZIS(1,LRDEV,0))'["NUL" G T549
N LRAD S LRAD=0
N LRX,LRY
D NOW^%DTC
S LR3T=%
S LRX=0
F S LRX=$O(LRLBL(LRX)) Q:+LRX'>0 D
. S LRY=0
. F S LRY=$O(LRLBL(LRX,LRY)) Q:+LRY'>0 D
.. I $P(^LRO(68,LRX,0),U,3)="M" S LRAD=$E(DT,1,5)_"00"
.. I $P(^LRO(68,LRX,0),U,3)="Y" S LRAD=$E(DT,1,3)_"0000"
.. I '$G(LRAD) S LRAD=DT
.. S LRUID=$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U) I $L(LRUID)<10 D
... S $P(LRLBL(LRX,LRY),U,7)=LRORD
... S LRUID=$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U)
.. S ^XTMP("LRHY LABELS",LRDFN,LR3T,LRUID)=LRLBL(LRX,LRY)
.. K LRAD
I $G(^%ZIS(1,LRDEV,0))["NUL" QUIT
;
T549 ; ADDED FOR PPOC APPROACH
S LRCE=LRORD
S LRX=0
F S LRX=$O(LRLBL(LRX)) Q:+LRX'>0 D
. S LRY=0
. F S LRY=$O(LRLBL(LRX,LRY)) Q:+LRY'>0 D
.. S $P(LRLBL(LRX,LRY),U,7)=LRCE
S ZTSAVE("L*")=""
I $D(LRLABLIO) S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")="" S:$D(ZTQUEUED) ZTREQ="@" D ^%ZTLOAD
K LRLBL
I $D(LRCSQ),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
Q
;
;
END K DIR,DIRUT,LRHYGOT
D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
Q
;
;
GOT(ORD,ODT) ;See if all tests have been canceled
N LRHYI,SN,ODT
S (LRHYGOT,ODT,SN)=0
F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 D
. S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(LRHYGOT) D
. . Q:'$D(^LRO(69,ODT,1,SN,0))
. . S LRHYI=0 F S LRHYI=$O(^LRO(69,ODT,1,SN,2,LRHYI)) Q:LRHYI<1 I $D(^(LRHYI,0)),'$P(^(0),"^",11) S LRHYGOT=1 Q
Q LRHYGOT
;
;
UNL69 ;
L -^LRO(69,"C",+$G(LRORD))
Q
BCE ;
S LRCE=$G(LRORD)
Q:'$D(LRLABLIO)
S ZTSAVE("L*")=""
S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS"
S ZTIO=LRLABLIO
S LRDEV=LRLABLIO
S IO=LRDEV S ZTSAVE("IO*")=""
S ZTIO=$P(^%ZIS(1,+LRDEV,0),U)
D ^%ZTLOAD
K LRLBL
I $D(LRCSQ),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
LRHYPH0 ;VA/DALOI/HOAK - HOWDY ORDER NUMBER SELECTOR PRIME ; 13-Aug-2013 09:16 ; MKK
+1 ;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
+2 ;
+3 KILL LRORIFN,LRNATURE,LREND,LRORDRR
+4 SET LRLWC="WC"
+5 DO ^LRPARAM
+6 IF $GET(LREND)
SET LREND=0
QUIT
L5 ;
NEXT ;
+1 KILL DIR
+2 IF $DATA(LROESTAT)
IF $PIECE(LRPARAM,U,14)
DO ^LRCAPV
IF $GET(LREND)
KILL LRLONG,LRPANEL
QUIT
+3 SET (LRODT,X,DT)=$$DT^XLFDT()
SET LRODT0=$$FMTE^XLFDT(DT,5)
+4 IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=+$PIECE(^("RO"),U)
Begin DoDot:1
+5 WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!
+6 SET DIR("A")=" Are you sure you want to continue"
SET DIR(0)="Y"
SET DIR("B")="No"
End DoDot:1
+7 IF $TEST
DO ^DIR
IF $DATA(DIRUT)
GOTO END
IF Y'=1
WRITE !,"OK, try later."
QUIT
+8 SET X="T-7"
SET %DT=""
DO ^%DT
SET LRTM7=+Y
+9 KILL DIC,LRSND,LRSN
+10 WRITE !!,"Select Order number: "
READ LRORD:DTIME
WRITE !
IF LRORD["^"!(LRORD[".")!($DATA(LRLONG)&(LRORD=""))
QUIT
PAST ; HOWDY IN HERE
+1 WRITE @IOF
SET M9=0
IF LRORD=""
GOTO QUICK^LROE1
+2 IF LRORD?.N
SET LRORD=+LRORD
IF LRORD'?.N
DO QMSG
QUIT
+3 IF '$DATA(^LRO(69,"C",LRORD))
WRITE !!?10,"No order exist with that number ",$CHAR(7),!
QUIT
+4 SET (LRCHK,LRNONE)=1
SET (M9,LRODT)=0
+5 FOR
SET LRODT=+$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+6 SET DA=0
FOR
SET DA=$ORDER(^LRO(69,"C",LRORD,LRODT,DA))
IF DA<1
QUIT
SET LRCHK=LRCHK-1
IF LRNONE'=2
SET LRNONE=0
DO LROE2
End DoDot:1
+7 IF LRNONE=2
WRITE !,"The order has already been",$SELECT(LRCHK<1:" partially",1:"")," accessioned."
HANG 1
+8 IF LRNONE=1
WRITE !,"No order exists with that number."
HANG 1
QUIT
+9 IF '$$GOT(LRORD,LRODT)
QUIT
+10 KILL DIR
SET DIR("A")="Is this the correct order"
SET DIR(0)="Y"
+11 SET DIR("B")="Yes"
+12 KILL DIR
SET Y=1
+13 IF $DATA(DIRUT)!(Y'=1)
KILL LRSN
QUIT
+14 LOCK +^LRO(69,"C",LRORD):$GET(DILOCKTM,3)
+15 IF '$TEST
WRITE !?5,"Someone else is editing this Order",!!,$CHAR(7)
QUIT
+16 KILL %DT
+17 SET LRSTATUS=""
SET %DT("B")=""
+18 DO TIME
KILL %DT
+19 IF $GET(LRCDT)<1
DO UNL69
IF LRCDT<1
QUIT
+20 SET LRTIM=+LRCDT
+21 SET LRUN=$PIECE(LRCDT,U,2)
KILL LRCDT,LRSN
MORE ;
+1 SET M9=0
+2 SET (LRODT,LRSND)=0
+3 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+4 SET LRSND=0
+5 FOR
SET LRSND=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSND))
IF LRSND<1
QUIT
Begin DoDot:2
+6 SET LRSN(LRSND)=LRSND
SET LRSN=LRSND
+7 KILL LRAA
DO Q15^LRHYPH2
KILL LRSN
End DoDot:2
End DoDot:1
+8 DO TASK
DO UNL69
+9 QUIT
+10 ;
+11 ;
LROE2 ;
+1 IF $DATA(^LRO(69,LRODT,1,DA,1))
IF $PIECE(^(1),U,4)=""
SET LRNONE=2
SET LRCHK=LRCHK+1
+2 KILL LRSN
+3 SET (LRSN,LRSN(DA))=+DA
+4 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+5 SET M9=$GET(M9)+1
SET LR3X=^LRO(69,LRODT,1,LRSN,0)
SET LRDFN=+LR3X
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+6 QUIT
+7 ;
+8 ;
QMSG WRITE !,"Enter the order entry number assigned when the test was ordered."
+1 IF '$DATA(LRLONG)
WRITE !,"If the test has not been ordered, type the RETURN key to order the test."
+2 WRITE !,"To exit, type the ""^"" key and RETURN key."
+3 QUIT
+4 ;
+5 ;
YN READ X:DTIME
WRITE !
IF '$TEST
SET DTOUT=1
IF X=""!(X["N")!(X["Y")
QUIT
+1 WRITE !,"Answer 'Y' or 'N': "
GOTO YN
+2 ;
+3 ;
EN ;
LROEN SET LRNCWL=1
+1 DO LROE
DO END
KILL LRNCWL
+2 QUIT
+3 ;
LROE ;
+1 QUIT
+2 ;
EN01 ; ENTER ORDER # THEN ENTER DATA
STAT ;
+1 DO ^LRPARAM
+2 IF '$DATA(LRLABKY)
WRITE !!?10,"You do not have the proper security Keys",!
QUIT
+3 ;
+4 ; Select peforming laboratory
+5 SET X=$$SELPL^LRVERA(DUZ(2))
+6 IF X<1
DO END
QUIT
+7 IF X'=DUZ(2)
NEW LRPL
SET LRPL=X
+8 ;
+9 SET LRLONG=""
SET LRPANEL=0
SET LROESTAT=""
+10 SET %H=$HOROLOG-60
DO YMD^LRX
SET LRTM60=9999999-X
+11 DO LROE
KILL LRTM60,LRLONG,LREND,LROESTAT
+12 DO END
+13 QUIT
+14 ;
+15 ;
TIME ;from LROE1, LRORD1
+1 ;STUFFED FOR HOWDY
DO NOW^%DTC
SET LRCDT=%
QUIT
+2 SET %DT="SET"
WRITE !,"Collection Date@Time: ",$SELECT($DATA(%DT("B")):%DT("B"),1:"NOW"),"//"
READ X:DTIME
WRITE !
IF '$TEST!(X="^")
SET LRCDT=-1
QUIT
+3 IF X=""
SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"N")
+4 IF X["?"
WRITE !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
+5 IF X["@U"
IF $PIECE(X,"@U",2)=""
SET X=$PIECE(X,"@U",1)
DO ^%DT
IF Y<1
GOTO TIME
SET LRCDT=+Y_"^1"
QUIT
+6 IF X="U"
SET LRCDT=DT_"^1"
+7 IF X'="U"
DO ^%DT
IF X'["?"
DO TIME1
IF X["?"
GOTO TIME
SET LRCDT=+Y_"^"
IF Y'["."
GOTO TIME
+8 QUIT
+9 ;
TIME1 SET X1=X
SET Y1=Y
DO TIME2
SET X=X1
SET Y=Y1
KILL X1,Y1
+1 QUIT
+2 ;
TIME2 SET X="N"
SET %DT="ST"
DO ^%DT
IF Y1'>Y
QUIT
FOR
WRITE !,"You have specified a collection time in the future. Are you sure"
SET %=2
DO YN^DICN
IF %
QUIT
WRITE !,"Answer 'Y'es or 'N'o."
+1 IF %'=1
SET X="?"
SET X1=X
+2 QUIT
+3 ;
+4 ;
TASK ;
+1 ; If traditional Howdy is used this is where labels print-control passes to GT549
+2 ; If alternative Howdy is used label printing is delayed.
+3 IF $GET(^%ZIS(1,LRDEV,0))'["NUL"
GOTO T549
+4 NEW LRAD
SET LRAD=0
+5 NEW LRX,LRY
+6 DO NOW^%DTC
+7 SET LR3T=%
+8 SET LRX=0
+9 FOR
SET LRX=$ORDER(LRLBL(LRX))
IF +LRX'>0
QUIT
Begin DoDot:1
+10 SET LRY=0
+11 FOR
SET LRY=$ORDER(LRLBL(LRX,LRY))
IF +LRY'>0
QUIT
Begin DoDot:2
+12 IF $PIECE(^LRO(68,LRX,0),U,3)="M"
SET LRAD=$EXTRACT(DT,1,5)_"00"
+13 IF $PIECE(^LRO(68,LRX,0),U,3)="Y"
SET LRAD=$EXTRACT(DT,1,3)_"0000"
+14 IF '$GET(LRAD)
SET LRAD=DT
+15 SET LRUID=$PIECE($GET(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U)
IF $LENGTH(LRUID)<10
Begin DoDot:3
+16 SET $PIECE(LRLBL(LRX,LRY),U,7)=LRORD
+17 SET LRUID=$PIECE($GET(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U)
End DoDot:3
+18 SET ^XTMP("LRHY LABELS",LRDFN,LR3T,LRUID)=LRLBL(LRX,LRY)
+19 KILL LRAD
End DoDot:2
End DoDot:1
+20 IF $GET(^%ZIS(1,LRDEV,0))["NUL"
QUIT
+21 ;
T549 ; ADDED FOR PPOC APPROACH
+1 SET LRCE=LRORD
+2 SET LRX=0
+3 FOR
SET LRX=$ORDER(LRLBL(LRX))
IF +LRX'>0
QUIT
Begin DoDot:1
+4 SET LRY=0
+5 FOR
SET LRY=$ORDER(LRLBL(LRX,LRY))
IF +LRY'>0
QUIT
Begin DoDot:2
+6 SET $PIECE(LRLBL(LRX,LRY),U,7)=LRCE
End DoDot:2
End DoDot:1
+7 SET ZTSAVE("L*")=""
+8 IF $DATA(LRLABLIO)
SET ZTRTN="ENT^LRLABLD"
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB LABELS"
SET ZTIO=LRLABLIO
SET ZTSAVE("LRLBL(")=""
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ^%ZTLOAD
+9 KILL LRLBL
+10 IF $DATA(LRCSQ)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
DO STD^LRCAPV
+11 DO STOP^LRCAPV
KILL LRCOM,LRSPCDSC,LRCCOM,LRTCOM
+12 QUIT
+13 ;
+14 ;
END KILL DIR,DIRUT,LRHYGOT
+1 DO ^LRORDK
DO LROEND^LRORDK
DO STOP^LRCAPV
+2 QUIT
+3 ;
+4 ;
GOT(ORD,ODT) ;See if all tests have been canceled
+1 NEW LRHYI,SN,ODT
+2 SET (LRHYGOT,ODT,SN)=0
+3 FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
IF ODT<1
QUIT
Begin DoDot:1
+4 SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
IF SN<1!(LRHYGOT)
QUIT
Begin DoDot:2
+5 IF '$DATA(^LRO(69,ODT,1,SN,0))
QUIT
+6 SET LRHYI=0
FOR
SET LRHYI=$ORDER(^LRO(69,ODT,1,SN,2,LRHYI))
IF LRHYI<1
QUIT
IF $DATA(^(LRHYI,0))
IF '$PIECE(^(0),"^",11)
SET LRHYGOT=1
QUIT
End DoDot:2
End DoDot:1
+7 QUIT LRHYGOT
+8 ;
+9 ;
UNL69 ;
+1 LOCK -^LRO(69,"C",+$GET(LRORD))
+2 QUIT
BCE ;
+1 SET LRCE=$GET(LRORD)
+2 IF '$DATA(LRLABLIO)
QUIT
+3 SET ZTSAVE("L*")=""
+4 SET ZTRTN="ENT^LRLABLD"
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB LABELS"
+5 SET ZTIO=LRLABLIO
+6 SET LRDEV=LRLABLIO
+7 SET IO=LRDEV
SET ZTSAVE("IO*")=""
+8 SET ZTIO=$PIECE(^%ZIS(1,+LRDEV,0),U)
+9 DO ^%ZTLOAD
+10 KILL LRLBL
+11 IF $DATA(LRCSQ)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
DO STD^LRCAPV
+12 DO STOP^LRCAPV
KILL LRCOM,LRSPCDSC,LRCCOM,LRTCOM
