- 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
