LRDRAW ;DALOI/CJS/RLM-WARD COLLECTION SUMMARY ;8/11/97
;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**121,190,272,369**;Sep 27, 1994;Build 2
; Reference to ^%DT supported by DBIA #10003
; Reference to $$FMTE^XLFDT supported by IA #10103
; Reference to $$NOW^XLFDT supported by IA #10103
; Reference to ^DIC supported by IA #10007
; Reference to ^SC( supported by DBIA #908
; Reference to ^VA(200 supported by DBIA #10060
BEGIN S %DT="AE" D ^%DT Q:Y<1 S U="^",%ZIS="Q",LRODT=+Y D FNDLOC Q:LRLLOC[U S ZTRTN="GO^LRDRAW" D IO^LRWU
END K DIC,%ZIS,LRODT,LRLLOC,LRPGM,LRIO,LRTIME,LRDC,LRDFN,LRDPF,LRIOZERO,LRLWC,LRSN,PNM,SSN,Z
K HRCN ; IHS/OIT/MKK - LR*5.2*1030
Q
GO ; S:$D(ZTQUEUED) ZTREQ="@" U IO S LRDC=0 W @IOF,!,"List of Patients with Lab Orders",?40,"Order Date: "_$$FMTE^XLFDT(LRODT,""),!
; W ?2,"Date/Time Printed: "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 - Putting back IHS mods
S Y=LRODT D DD^LRX S LRDDT=Y ;IHS/ANMC/CLS 11/1/95
S:$D(ZTQUEUED) ZTREQ="@" U IO S LRDC=0 W @IOF,!,"LIST OF PATIENTS WITH LAB ORDERS ON",! D STAMP^LRX W ! ;IHS/ANMC/CLS 11/1/95
; ----- END IHS/OIT/MKK - LR*5.2*1030
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 !,"Report Completed",!
Q
ORD S LRSN=0 F S LRSN=$O(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)) Q:LRSN<1 D:'$D(^LRO(69,LRODT,1,LRSN,1))&$D(^LRO(69,LRODT,1,LRSN,0)) PRNT
Q
PRNT S LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRLWC=$P(^(0),U,4),LRDC=1
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
; W !!,PNM,?30,SSN,?50,"ORDER NUMBER: ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):+^(.1),1:"?"),!,"LOCATION: ",LRLLOC,?50,$S(LRLWC="SP":"SEND PATIENT",LRLWC="WC":"WARD COLLECT",LRLWC="LC":"LAB COLLECT",1:"")
W !!,PNM,?30,HRCN,?50,"ORDER NUMBER: ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):+^(.1),1:"?"),!,"LOCATION: ",LRLLOC,?50,$S(LRLWC="SP":"SEND PATIENT",LRLWC="WC":"WARD COLLECT",LRLWC="LC":"LAB COLLECT",1:"") ; IHS/OIT/MKK LR*5.2*1030
W !,"TESTS: " S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) W ?9,$P(^LAB(60,+X,0),U,1) W:$P(X,"^",11) ?30," Canceled by: "_$P(^VA(200,$P(X,"^",11),0),"^") W !
Q
FNDLOC ;return a location from ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN), from LRNODRQW, LRPHEXPT, LRPHITEM
LOOP S LRLLOC="" W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT LOCATION: ")
R "ALL// ",X:DTIME G:'$T LEND S:X="" X="ALL" S:X="ALL"!(X="all") X="" S LRLLOC=X Q:X="" I $L(X) G LEND:X["^",LALL:X["?"!(X'?.ANP)
I $L(X)<2!($L(X)>30) W " Enter 2 - 30 alpha-numeric name" G LOOP
I $D(^LRO(69,LRODT,1,"AC",X)) S LRLLOC=X K %,X,Y Q
S DIC=44,DIC(0)="EMOZ",DIC("S")="I $L($P(^(0),U,2)),$D(^LRO(69,LRODT,1,""AC"",$P(^(0),U,2)))" D ^DIC K DIC
I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G LOOP
I Y>0 S LRLLOC=$P(Y(0),U,2) I $D(^LRO(69,LRODT,1,"AC",LRLLOC)) K %,X,Y Q
I '$D(^LRO(69,LRODT,1,"AC",LRLLOC)) W !,"["_LRLLOC_"] is not a valid entry",$C(7),! G LOOP
SOME S Y=$O(^LRO(69,LRODT,1,"AC",X)) G LALL:Y=""!($E(Y,1,$L(LRLLOC))'=LRLLOC)
S %=$O(^LRO(69,LRODT,1,"AC",Y)) I $E(%,1,$L(LRLLOC))'=LRLLOC W $E(Y,$L(LRLLOC)+1,$L(Y)) S LRLLOC=Y K %,Y,X Q
K % S Y=X F %=1:1 S Y=$O(^LRO(69,LRODT,1,"AC",Y)) Q:Y=""!($E(Y,1,$L(LRLLOC))'=LRLLOC) S %(%)=Y W !,?5,%,?9,Y I '(%#10) R !,"Press ""^"" to quit ",X:DTIME S:'$T X="^" Q:X["^"
S %=%-1 W !,"CHOOSE 1-",%,": " R X:DTIME G:'$T LOOP G LALL:X["?" G LOOP:X["^"!(X="")
I X\1'=+X!(X<1)!(X>%) W " ??",$C(7),! G LOOP
S LRLLOC=%(X) K %,X,Y Q
LALL S X="?",DIC=44,DIC(0)="EMOQ",DIC("S")="I $L($P(^(0),U,2)),$D(^LRO(69,LRODT,1,""AC"",$P(^(0),U,2)))" D ^DIC K DIC
S Y="" W !,"YOU MAY ALSO CHOOSE FROM:" F %=1:1 S Y=$O(^LRO(69,LRODT,1,"AC",Y)) Q:Y="" D
. I '$D(^SC("C",Y)) W !,?3,Y I '(%#10) R !,"Press ""^"" to quit ",X:DTIME S:'$T X="^" Q:X["^"
G LOOP
LEND K %,X,Y S LRLLOC="^" Q
LRDRAW ;DALOI/CJS/RLM-WARD COLLECTION SUMMARY ;8/11/97
+1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**121,190,272,369**;Sep 27, 1994;Build 2
+3 ; Reference to ^%DT supported by DBIA #10003
+4 ; Reference to $$FMTE^XLFDT supported by IA #10103
+5 ; Reference to $$NOW^XLFDT supported by IA #10103
+6 ; Reference to ^DIC supported by IA #10007
+7 ; Reference to ^SC( supported by DBIA #908
+8 ; Reference to ^VA(200 supported by DBIA #10060
BEGIN SET %DT="AE"
DO ^%DT
IF Y<1
QUIT
SET U="^"
SET %ZIS="Q"
SET LRODT=+Y
DO FNDLOC
IF LRLLOC[U
QUIT
SET ZTRTN="GO^LRDRAW"
DO IO^LRWU
END KILL DIC,%ZIS,LRODT,LRLLOC,LRPGM,LRIO,LRTIME,LRDC,LRDFN,LRDPF,LRIOZERO,LRLWC,LRSN,PNM,SSN,Z
+1 ; IHS/OIT/MKK - LR*5.2*1030
KILL HRCN
+2 QUIT
GO ; S:$D(ZTQUEUED) ZTREQ="@" U IO S LRDC=0 W @IOF,!,"List of Patients with Lab Orders",?40,"Order Date: "_$$FMTE^XLFDT(LRODT,""),!
+1 ; W ?2,"Date/Time Printed: "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
+2 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 - Putting back IHS mods
+3 ;IHS/ANMC/CLS 11/1/95
SET Y=LRODT
DO DD^LRX
SET LRDDT=Y
+4 ;IHS/ANMC/CLS 11/1/95
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
SET LRDC=0
WRITE @IOF,!,"LIST OF PATIENTS WITH LAB ORDERS ON",!
DO STAMP^LRX
WRITE !
+5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+6 IF LRLLOC=""
FOR I=0:0
SET LRLLOC=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC))
IF LRLLOC=""
QUIT
DO ORD
+7 IF LRLLOC'=""
DO ORD
+8 IF 'LRDC
WRITE !!,"REPORT EMPTY."
+9 WRITE !,"Report Completed",!
+10 QUIT
ORD SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))
IF LRSN<1
QUIT
IF '$DATA(^LRO(69,LRODT,1,LRSN,1))&$DATA(^LRO(69,LRODT,1,LRSN,0))
DO PRNT
+1 QUIT
PRNT SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
SET LRLWC=$PIECE(^(0),U,4)
SET LRDC=1
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+2 ; W !!,PNM,?30,SSN,?50,"ORDER NUMBER: ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):+^(.1),1:"?"),!,"LOCATION: ",LRLLOC,?50,$S(LRLWC="SP":"SEND PATIENT",LRLWC="WC":"WARD COLLECT",LRLWC="LC":"LAB COLLECT",1:"")
+3 ; IHS/OIT/MKK LR*5.2*1030
WRITE !!,PNM,?30,HRCN,?50,"ORDER NUMBER: ",$SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):+^(.1),1:"?"),!,"LOCATION: ",LRLLOC,?50,$SELECT(LRLWC="SP":"SEND PATIENT",LRLWC="WC":"WARD COLLECT",LRLWC="LC":"LAB COLLECT",1:"")
+4 WRITE !,"TESTS: "
SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
IF I<1
QUIT
SET X=^(I,0)
WRITE ?9,$PIECE(^LAB(60,+X,0),U,1)
IF $PIECE(X,"^",11)
WRITE ?30," Canceled by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")
WRITE !
+5 QUIT
FNDLOC ;return a location from ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN), from LRNODRQW, LRPHEXPT, LRPHITEM
LOOP SET LRLLOC=""
WRITE !,$SELECT($DATA(DIC("A")):DIC("A"),1:"Select PATIENT LOCATION: ")
+1 READ "ALL// ",X:DTIME
IF '$TEST
GOTO LEND
IF X=""
SET X="ALL"
IF X="ALL"!(X="all")
SET X=""
SET LRLLOC=X
IF X=""
QUIT
IF $LENGTH(X)
IF X["^"
GOTO LEND
IF X["?"!(X'?.ANP)
GOTO LALL
+2 IF $LENGTH(X)<2!($LENGTH(X)>30)
WRITE " Enter 2 - 30 alpha-numeric name"
GOTO LOOP
+3 IF $DATA(^LRO(69,LRODT,1,"AC",X))
SET LRLLOC=X
KILL %,X,Y
QUIT
+4 SET DIC=44
SET DIC(0)="EMOZ"
SET DIC("S")="I $L($P(^(0),U,2)),$D(^LRO(69,LRODT,1,""AC"",$P(^(0),U,2)))"
DO ^DIC
KILL DIC
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL DTOUT,DUOUT
GOTO LOOP
+6 IF Y>0
SET LRLLOC=$PIECE(Y(0),U,2)
IF $DATA(^LRO(69,LRODT,1,"AC",LRLLOC))
KILL %,X,Y
QUIT
+7 IF '$DATA(^LRO(69,LRODT,1,"AC",LRLLOC))
WRITE !,"["_LRLLOC_"] is not a valid entry",$CHAR(7),!
GOTO LOOP
SOME SET Y=$ORDER(^LRO(69,LRODT,1,"AC",X))
IF Y=""!($EXTRACT(Y,1,$LENGTH(LRLLOC))'=LRLLOC)
GOTO LALL
+1 SET %=$ORDER(^LRO(69,LRODT,1,"AC",Y))
IF $EXTRACT(%,1,$LENGTH(LRLLOC))'=LRLLOC
WRITE $EXTRACT(Y,$LENGTH(LRLLOC)+1,$LENGTH(Y))
SET LRLLOC=Y
KILL %,Y,X
QUIT
+2 KILL %
SET Y=X
FOR %=1:1
SET Y=$ORDER(^LRO(69,LRODT,1,"AC",Y))
IF Y=""!($EXTRACT(Y,1,$LENGTH(LRLLOC))'=LRLLOC)
QUIT
SET %(%)=Y
WRITE !,?5,%,?9,Y
IF '(%#10)
READ !,"Press ""^"" to quit ",X:DTIME
IF '$TEST
SET X="^"
IF X["^"
QUIT
+3 SET %=%-1
WRITE !,"CHOOSE 1-",%,": "
READ X:DTIME
IF '$TEST
GOTO LOOP
IF X["?"
GOTO LALL
IF X["^"!(X="")
GOTO LOOP
+4 IF X\1'=+X!(X<1)!(X>%)
WRITE " ??",$CHAR(7),!
GOTO LOOP
+5 SET LRLLOC=%(X)
KILL %,X,Y
QUIT
LALL SET X="?"
SET DIC=44
SET DIC(0)="EMOQ"
SET DIC("S")="I $L($P(^(0),U,2)),$D(^LRO(69,LRODT,1,""AC"",$P(^(0),U,2)))"
DO ^DIC
KILL DIC
+1 SET Y=""
WRITE !,"YOU MAY ALSO CHOOSE FROM:"
FOR %=1:1
SET Y=$ORDER(^LRO(69,LRODT,1,"AC",Y))
IF Y=""
QUIT
Begin DoDot:1
+2 IF '$DATA(^SC("C",Y))
WRITE !,?3,Y
IF '(%#10)
READ !,"Press ""^"" to quit ",X:DTIME
IF '$TEST
SET X="^"
IF X["^"
QUIT
End DoDot:1
+3 GOTO LOOP
LEND KILL %,X,Y
SET LRLLOC="^"
QUIT
