LRDRAW ;DALOI/CJS/RLM-WARD COLLECTION SUMMARY ;8/11/97
;;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
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,""),!
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 !,"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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDRAW 3239 printed Oct 16, 2024@18:14:51 Page 2
LRDRAW ;DALOI/CJS/RLM-WARD COLLECTION SUMMARY ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,190,272,369**;Sep 27, 1994;Build 2
+2 ; Reference to ^%DT supported by DBIA #10003
+3 ; Reference to $$FMTE^XLFDT supported by IA #10103
+4 ; Reference to $$NOW^XLFDT supported by IA #10103
+5 ; Reference to ^DIC supported by IA #10007
+6 ; Reference to ^SC( supported by DBIA #908
+7 ; 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 QUIT
GO if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
SET LRDC=0
WRITE @IOF,!,"List of Patients with Lab Orders",?40,"Order Date: "_$$FMTE^XLFDT(LRODT,""),!
+1 WRITE ?2,"Date/Time Printed: "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
+2 IF LRLLOC=""
FOR I=0:0
SET LRLLOC=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC))
if LRLLOC=""
QUIT
DO ORD
+3 IF LRLLOC'=""
DO ORD
+4 IF 'LRDC
WRITE !!,"REPORT EMPTY."
+5 WRITE !,"Report Completed",!
+6 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 WRITE !!,PNM,?30,SSN,?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:"")
+3 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 !
+4 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
