LRNODRAW ;SLC/CJS - PRINT LIST OF NON-DRAW ORDERS ;8/11/97 [ 04/14/2003 10:42 AM ]
;;5.2T9;LR;**1003,1004,1018**;Nov 17, 2004
;;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
;----- BEGIN IH SMODIFICATIONS LR*5.2*1018
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,HRCN Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
% 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)
;----- BEGIN IH SMODIFICATIONS LR*5.2*1018
W !!,PNM,?40,HRCN,!,"LOCATION: ",LRLLOC,?30,"NON-DRAW",?40,"Order: ",^LRO(69,LRODT,1,LRSN,.1) ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
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
LRNODRAW ;SLC/CJS - PRINT LIST OF NON-DRAW ORDERS ;8/11/97 [ 04/14/2003 10:42 AM ]
+1 ;;5.2T9;LR;**1003,1004,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
+3 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
+4 SET %ZIS="QN"
DO ^%ZIS
IF POP
GOTO END
IF IO=IO(0)
GOTO GO
+5 KILL IO("Q")
SET ZTRTN="GO^LRNODRAW"
SET ZTDTH=$HOROLOG
SET ZTSAVE("L*")=""
DO ^%ZTLOAD
KILL 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
+1 ;----- BEGIN IH SMODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
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,HRCN
QUIT
+3 ;----- END IHS MODIFICATIONS
% 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 ;W !!,PNM,?40,SSN,!,"LOCATION: ",LRLLOC,?30,"NON-DRAW",?40,"Order: ",^LRO(69,LRODT,1,LRSN,.1)
+3 ;----- BEGIN IH SMODIFICATIONS LR*5.2*1018
+4 ;IHS/ANMC/CLS 08/18/96
WRITE !!,PNM,?40,HRCN,!,"LOCATION: ",LRLLOC,?30,"NON-DRAW",?40,"Order: ",^LRO(69,LRODT,1,LRSN,.1)
+5 ;----- END IHS MODIFICATIONS
+6 WRITE !,"TESTS: "
SET I=0
+7 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
+8 IF '$DATA(^LAB(60,+X,0))#2
QUIT
+9 WRITE ?9,$PIECE(^LAB(60,+X,0),U)
+10 IF Y
DO DD^LRX
WRITE " Accessioned "_Y
+11 IF LRCOMB
WRITE !?9,"COMBINED WITH ORDER # "_LRCOMB
+12 IF $PIECE(X,"^",11)
WRITE !?9,"Canceled by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")
+13 WRITE !
End DoDot:1
+14 IF $LENGTH(LRBECAUS)
WRITE !,"REASON: ",LRBECAUS
+15 QUIT
EN IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO GO
