LRNODRAW ;SLC/CJS - PRINT LIST OF NON-DRAW ORDERS ;8/11/97
;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
S %DT="AE" D ^%DT Q:Y<1 S U="^",LRODT=+Y,LRLLOC="",%ZIS="Q" W !!?10," You may enter 'ALL' as a response",! D FNDLOC^LRDRAW G END:LRLLOC["^"
S %ZIS="QN" D ^%ZIS G:POP END I IO=IO(0) G GO
K IO("Q") S ZTRTN="GO^LRNODRAW",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTIO,ZTDTH,ZTSAVE
END K J,%DT,%,A,I,K,LRDC,LRSN,X,Y,Z,DIC,%ZIS,LRBECAUS,LRCOMB,LRODT,LRLLOC,LRPGM,LRIO,LRTIME,%H,%X,%Y,DFN,LRDFN,LRDPF,LRIOZERO,LRLWC,PNM,POP,SSN Q
% R %:DTIME S:'$T DTOUT=1 Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
GO S Y=LRODT D DD^LRX W @IOF,!,"LIST OF PATIENT LAB ORDERS NOT DRAWN "_Y S LRDC=0 S %DT="T",X="N" D ^%DT,DD^%DT W ?60,Y
I LRLLOC="" F I=0:0 S LRLLOC=$O(^LRO(69,LRODT,1,"AC",LRLLOC)) Q:LRLLOC="" D ORD
I LRLLOC'="" D ORD
I 'LRDC W !,"REPORT EMPTY"
W !,"Finished",! D ^%ZISC,END Q
ORD S LRSN=0 F S LRSN=$O(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)) Q:LRSN<1 S LRDC=1 D PRNT
Q
PRNT ;
I $D(^LRO(69,LRODT,1,LRSN,1)),$P(^(1),U,4)="C" Q
I '$L($P(^LRO(69,LRODT,1,LRSN,0),U,4)) Q
I $D(^LRO(69,LRODT,1,LRSN,0)),$P(^(0),U,4)'="LC" Q
S LRDFN=+^LRO(69,LRODT,1,LRSN,0)
I '$D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",'$O(^LRO(69,LRODT,1,LRSN,2,0)) S LRBECAUS="ORDER DELETED" G PRN
I '$D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC" S LRBECAUS="NOT ON LIST YET ** " G PRN
S LRBECAUS=$S($L($P(^LRO(69,LRODT,1,LRSN,1),"^",6)):$P(^(1),U,6),1:"")
PRN ;
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
W !!,PNM,?40,SSN,!,"LOCATION: ",LRLLOC,?30,"NON-DRAW",?40,"Order: ",^LRO(69,LRODT,1,LRSN,.1)
W !,"TESTS: " S I=0
F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X=^(I,0),Y=$S($P(X,U,3):$P(X,U,3),1:0),LRCOMB=$P(X,U,6) D
. Q:'$D(^LAB(60,+X,0))#2
. W ?9,$P(^LAB(60,+X,0),U)
. I Y D DD^LRX W " Accessioned "_Y
. I LRCOMB W !?9,"COMBINED WITH ORDER # "_LRCOMB
. I $P(X,"^",11) W !?9,"Canceled by: "_$P(^VA(200,$P(X,"^",11),0),"^")
. W !
W:$L(LRBECAUS) !,"REASON: ",LRBECAUS
Q
EN S:$D(ZTQUEUED) ZTREQ="@" G GO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRNODRAW 2103 printed Apr 09, 2024@21:25:12 Page 2
LRNODRAW ;SLC/CJS - PRINT LIST OF NON-DRAW ORDERS ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
+2 SET %DT="AE"
DO ^%DT
if Y<1
QUIT
SET U="^"
SET LRODT=+Y
SET LRLLOC=""
SET %ZIS="Q"
WRITE !!?10," You may enter 'ALL' as a response",!
DO FNDLOC^LRDRAW
if LRLLOC["^"
GOTO END
+3 SET %ZIS="QN"
DO ^%ZIS
if POP
GOTO END
IF IO=IO(0)
GOTO GO
+4 KILL IO("Q")
SET ZTRTN="GO^LRNODRAW"
SET ZTDTH=$HOROLOG
SET ZTSAVE("L*")=""
DO ^%ZTLOAD
KILL ZTSK,ZTRTN,ZTIO,ZTDTH,ZTSAVE
END KILL J,%DT,%,A,I,K,LRDC,LRSN,X,Y,Z,DIC,%ZIS,LRBECAUS,LRCOMB,LRODT,LRLLOC,LRPGM,LRIO,LRTIME,%H,%X,%Y,DFN,LRDFN,LRDPF,LRIOZERO,LRLWC,PNM,POP,SSN
QUIT
% READ %:DTIME
if '$TEST
SET DTOUT=1
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
GO SET Y=LRODT
DO DD^LRX
WRITE @IOF,!,"LIST OF PATIENT LAB ORDERS NOT DRAWN "_Y
SET LRDC=0
SET %DT="T"
SET X="N"
DO ^%DT
DO DD^%DT
WRITE ?60,Y
+1 IF LRLLOC=""
FOR I=0:0
SET LRLLOC=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC))
if LRLLOC=""
QUIT
DO ORD
+2 IF LRLLOC'=""
DO ORD
+3 IF 'LRDC
WRITE !,"REPORT EMPTY"
+4 WRITE !,"Finished",!
DO ^%ZISC
DO END
QUIT
ORD SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))
if LRSN<1
QUIT
SET LRDC=1
DO PRNT
+1 QUIT
PRNT ;
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^(1),U,4)="C"
QUIT
+2 IF '$LENGTH($PIECE(^LRO(69,LRODT,1,LRSN,0),U,4))
QUIT
+3 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
IF $PIECE(^(0),U,4)'="LC"
QUIT
+4 SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
+5 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)="LC"
IF '$ORDER(^LRO(69,LRODT,1,LRSN,2,0))
SET LRBECAUS="ORDER DELETED"
GOTO PRN
+6 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)="LC"
SET LRBECAUS="NOT ON LIST YET ** "
GOTO PRN
+7 SET LRBECAUS=$SELECT($LENGTH($PIECE(^LRO(69,LRODT,1,LRSN,1),"^",6)):$PIECE(^(1),U,6),1:"")
PRN ;
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+2 WRITE !!,PNM,?40,SSN,!,"LOCATION: ",LRLLOC,?30,"NON-DRAW",?40,"Order: ",^LRO(69,LRODT,1,LRSN,.1)
+3 WRITE !,"TESTS: "
SET I=0
+4 FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
if I<1
QUIT
SET X=^(I,0)
SET Y=$SELECT($PIECE(X,U,3):$PIECE(X,U,3),1:0)
SET LRCOMB=$PIECE(X,U,6)
Begin DoDot:1
+5 if '$DATA(^LAB(60,+X,0))#2
QUIT
+6 WRITE ?9,$PIECE(^LAB(60,+X,0),U)
+7 IF Y
DO DD^LRX
WRITE " Accessioned "_Y
+8 IF LRCOMB
WRITE !?9,"COMBINED WITH ORDER # "_LRCOMB
+9 IF $PIECE(X,"^",11)
WRITE !?9,"Canceled by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")
+10 WRITE !
End DoDot:1
+11 if $LENGTH(LRBECAUS)
WRITE !,"REASON: ",LRBECAUS
+12 QUIT
EN if $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO GO
