BLRLRRP2 ; IHS/DIR/AAB - INTERIM REPORT 10/24/91 09:58 ; [ 07/01/1998 9:18 AM ]
;;5.2;BLR;**1001,1003**;JUN 01, 1998
;;5.2;LAB SERVICE;**106**;Sep 27, 1994
;from option LRRP2
BEGIN D INIT K DIC D ^LRDPA D:LRDFN>0 START G:LRDFN<0 END G BEGIN
END D ^LRRK
Q
START I $O(^LR(LRDFN,0))="" W !,"NO LAB DATA ON THIS PATIENT!",$C(7) Q
S LRLAB=$S($D(LRLABKY):1,1:0),LREDT="T-7" D ^LRWU3 Q:LREND S LRIDT=9999999-LRSDT,LREDT=9999999-LREDT
S %ZIS="Q" S ZTSAVE("DFN")="",ZTRTN="SDQ^BLRLRRP2" D IO^LRWU
Q
SDQ ;dequeued
S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX
F S LRCNIDT=+$O(^LR(LRDFN,"CH",LRIDT)),LRMNIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:'LRCNIDT&'LRMNIDT D SWITCH Q:LREND!LRSTOP!(LRIDT>LREDT)
D FOOT^LRRP1 Q
SWITCH ;I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH,MI Q
S LRMD=$G(LRMD) ;IHS/OIRM TUC/AAB
I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH,MI Q
I 'LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
I 'LRCNIDT S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI Q
I LRCNIDT<LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI
Q
GENP W !!,"Too many tests! Will use alternate format. May show extra tests.",!
S LREDT="T-7" D ^LRWU3 Q:LREND S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT
K ^TMP("LR",$J,"T"),LRORD,LRTSTS S ZTSAVE("^TMP(""LR"",$J,")="",ZTSAVE("DFN")="",ZTRTN="GDQ^BLRLRRP2" D IO^LRWU
Q
GDQ ;dequeued
S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX
S LRSUB="" F S LRSUB=$O(^TMP("LR",$J,"TMP",LRSUB)) Q:LRSUB="" S X=+$P(LRSUB,";",2),^TMP("LR",$J,"T",X)=""
S LRIDT=LRSDT F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LREDT) I $P(^LR(LRDFN,"CH",LRIDT,0),U,3) D GEN2 Q:LREND!LRSTOP
K ^TMP("LR",$J,"T"),^TMP("LR",$J,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT
Q
GEN2 S LRTN=0 F S LRTN=$O(^LR(LRDFN,"CH",LRIDT,LRTN)) Q:LRTN<1 I $D(^TMP("LR",$J,"T",LRTN)) D CH Q
Q
AIDQUE D INIT S LRLAB=$S($D(LRLABKY):1,1:0)
K ^TMP($J)
S LROCE=$S($D(LROC):LROC,1:""),LROC=$S(LROCE="":$O(^LAB(64.6,"AI","")),1:LROC) D:LROC'="" AI2 F S LROC=$O(^LAB(64.6,"AI",LROC)) Q:LROC=""!($L(LROCE)&(LROC'=LROCE)) D AI2
S LROC="UNKNOWN" D AI2
PRT ;Print sorted data
U IO K VA D KVAR^BLRDPT S LREND=0
I $O(^TMP($J,0))="" W !!?10,"No Interim report Patients to Print ",!?20,$$DTF^LRAFUNC1($$NOW^LRAFUNC1),!! G QUIT
S LROC="" F S LROC=$O(^TMP($J,LROC)) Q:LROC=""!($G(LREND)) S LRPHY="" F S LRPHY=$O(^TMP($J,LROC,LRPHY)) Q:LRPHY=""!($G(LREND)) D
. S LRSSN="" F S LRSSN=$O(^TMP($J,LROC,LRPHY,LRSSN)) Q:LRSSN=""!($G(LREND)) D
. . S LRDFN=0 F S LRHF=1,LRDFN=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN)) Q:LRDFN<1!($G(LREND)) D D:$G(LRSS)="CH" FOOT^LRRP1
. . . S LRIDT=0 F S LRIDT=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)) Q:LRIDT<1!($G(LREND)) D
. . . . ;S LRSS="",PNM=^(LRIDT),SSN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0
. . . . S LRSS="",PNM=^(LRIDT),HRCN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0 ;IHS/ANMC/CLS 08/18/96
. . . . D:$D(^LR(LRDFN,"CH",LRIDT,0))#2 CH
. . . . S LRFOOT=0 I $D(^LR(LRDFN,"MI",LRIDT,0))#2 D:$G(LRSS)="CH" FOOT^LRRP1 D MI
QUIT S:$D(ZTQUEUED) ZTREQ="@" W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC,^LRRK
Q
AI2 ;
Q:'$L($G(LROC))
F LRDFN=0:0 S LRDFN=$O(^LRO(69,"AN",LROC,LRDFN)) Q:LRDFN<1 I $D(^LR(LRDFN,0))#2 D
. S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX Q:LREND
. I '$G(VAERR) D AI3
Q
AI3 ;
Q:$G(LREND)
;S LRSSN=$P(PNM,",")_SSN(1)
S LRSSN=$P(PNM,",")_HRCN ;IHS/ANMC/CLS 08/18/96
F LRIDT=0:0 S LRIDT=$O(^LRO(69,"AN",LROC,LRDFN,LRIDT)) Q:LRIDT<1 D
. S LRND=$S($G(^LR(LRDFN,"CH",LRIDT,0)):^(0),$G(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"") I $P(LRND,U,3) D
. . S LRPHY=$P($G(^VA(200,+$P(LRND,U,10),0)),U) S:LRPHY="" LRPHY="UNKNOWN"
. . S ^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_HRCN_U_AGE_U_SEX ;IHS/ANMC/CLS 08/18/96
Q
CH ;Also used by DVBC Package
N LROC
;K ^TMP("LR",$J,"TP"),LRTP S LR0=^LR(LRDFN,"CH",LRIDT,0) Q:'$P(LR0,U,3) S LRCDT=+LR0,LRSS="CH",LROC=$P(LR0,U,11),LRAA="",LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5)
K ^TMP("LR",$J,"TP"),LRTP S LR0=^LR(LRDFN,"CH",LRIDT,0) Q:'$P(LR0,U,3) ;IHS/OIRM TUC/AAB 1/21/98
I LRSINGLE,LRMD="S" Q:LRPHY'=$E($P($G(^VA(200,+$P(LR0,U,10),0)),U),1,20) ;IHS/OIRM TUC/AAB 7/1/98
S LRCDT=+LR0,LRSS="CH",LROC=$P(LR0,U,11),LRAA="",LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5) ;IHS/OIRM TUC/AAB 1/21/98
D CH^LRRP
Q
MI ;Also used by DVBC package
;S BLRPHYS=$P($G(^VA(200,+$P(^LR(LRDFN,"MI",LRIDT,0),U,7),0)),U) Q:'$D(LRPHY(BLRPHYS)) ;IHS/OIRM TUC/AAB 1/21/98 FIX FOR A MORE THAN ONE SELECTED PROVIDER
I LRSINGLE,LRMD="S" Q:LRPHY'=$E($P($G(^VA(200,+$P(^LR(LRDFN,"MI",LRIDT,0),U,7),0)),U),1,20) ;IHS/DIR TUC/AAB 7/1/98
S LRCDT=9999999-LRIDT,^TMP("LR",$J,"TP",1)="^MI",^(1,LRCDT)="",^(LRCDT,-1)="",LRSS="MI",LRH=1 D:LRFOOT FOOT^LRRP1 Q:LRSTOP D EN1^LRMIPC S LRHF=1,LRFOOT=0 K A,Z,LRH S:LREND LREND=0,LRSTOP=1
Q
INIT D EN^LRPARAM D:'$D(LRDT0) DT^LRX S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)="" ;IHS/ANMC/CLS 08/18/96 LRDT0 <undef>
Q
EN69 ;entry point for surgery pkg
D START,^LRRK
Q
GEN ;from LRGEN test overflow
S LRLAB=$S($D(LRLABKY):1,1:0) D INIT,GENP,^LRRK
Q
DS ;from LRRD, LRRS
D INIT S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2) D SDQ
Q
AIDQ ;tasked from LRTASK DAILY INTERIM
S LRLAB=0,LRH="",LRWRDVEW="" D INIT,AIDQUE K LRH S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J)
Q
DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING
S:$D(ZTQUEUED) ZTREQ="@" D INIT S LRLAB=0,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX D CH D FOOT^LRRP1 W @IOF D ^%ZISC
Q
OR ;OE/RR entry point
Q:'$D(ORVP) S KILL=1 I '$D(LRPARAM) D EN^LRPARAM S KILL=0
S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""
D DT^LRX K DIC,LRTP S LRTP=0,DFN=+ORVP,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
D START,^LRRK
I 'KILL K LRBLOOD,LRDT0,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE
K KILL Q
BLRLRRP2 ; IHS/DIR/AAB - INTERIM REPORT 10/24/91 09:58 ; [ 07/01/1998 9:18 AM ]
+1 ;;5.2;BLR;**1001,1003**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**106**;Sep 27, 1994
+3 ;from option LRRP2
BEGIN DO INIT
KILL DIC
DO ^LRDPA
IF LRDFN>0
DO START
IF LRDFN<0
GOTO END
GOTO BEGIN
END DO ^LRRK
+1 QUIT
START IF $ORDER(^LR(LRDFN,0))=""
WRITE !,"NO LAB DATA ON THIS PATIENT!",$CHAR(7)
QUIT
+1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
SET LREDT="T-7"
DO ^LRWU3
IF LREND
QUIT
SET LRIDT=9999999-LRSDT
SET LREDT=9999999-LREDT
+2 SET %ZIS="Q"
SET ZTSAVE("DFN")=""
SET ZTRTN="SDQ^BLRLRRP2"
DO IO^LRWU
+3 QUIT
SDQ ;dequeued
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
DO PT^LRX
+2 FOR
SET LRCNIDT=+$ORDER(^LR(LRDFN,"CH",LRIDT))
SET LRMNIDT=+$ORDER(^LR(LRDFN,"MI",LRIDT))
IF 'LRCNIDT&'LRMNIDT
QUIT
DO SWITCH
IF LREND!LRSTOP!(LRIDT>LREDT)
QUIT
+3 DO FOOT^LRRP1
QUIT
SWITCH ;I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH,MI Q
+1 ;IHS/OIRM TUC/AAB
SET LRMD=$GET(LRMD)
+2 IF LRCNIDT=LRMNIDT
SET LRIDT=LRCNIDT
IF LRIDT>LREDT
QUIT
DO CH
DO MI
QUIT
+3 IF 'LRMNIDT
SET LRIDT=LRCNIDT
IF LRIDT>LREDT
QUIT
DO CH
QUIT
+4 IF 'LRCNIDT
SET LRIDT=LRMNIDT
IF LRIDT>LREDT
QUIT
DO MI
QUIT
+5 IF LRCNIDT<LRMNIDT
SET LRIDT=LRCNIDT
IF LRIDT>LREDT
QUIT
DO CH
QUIT
+6 SET LRIDT=LRMNIDT
IF LRIDT>LREDT
QUIT
DO MI
+7 QUIT
GENP WRITE !!,"Too many tests! Will use alternate format. May show extra tests.",!
+1 SET LREDT="T-7"
DO ^LRWU3
IF LREND
QUIT
SET LRSDT=9999999-LRSDT
SET LREDT=9999999-LREDT
+2 KILL ^TMP("LR",$JOB,"T"),LRORD,LRTSTS
SET ZTSAVE("^TMP(""LR"",$J,")=""
SET ZTSAVE("DFN")=""
SET ZTRTN="GDQ^BLRLRRP2"
DO IO^LRWU
+3 QUIT
GDQ ;dequeued
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
DO PT^LRX
+2 SET LRSUB=""
FOR
SET LRSUB=$ORDER(^TMP("LR",$JOB,"TMP",LRSUB))
IF LRSUB=""
QUIT
SET X=+$PIECE(LRSUB,";",2)
SET ^TMP("LR",$JOB,"T",X)=""
+3 SET LRIDT=LRSDT
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF LRIDT<1!(LRIDT>LREDT)
QUIT
IF $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)
DO GEN2
IF LREND!LRSTOP
QUIT
+4 KILL ^TMP("LR",$JOB,"T"),^TMP("LR",$JOB,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT
+5 QUIT
GEN2 SET LRTN=0
FOR
SET LRTN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRTN))
IF LRTN<1
QUIT
IF $DATA(^TMP("LR",$JOB,"T",LRTN))
DO CH
QUIT
+1 QUIT
AIDQUE DO INIT
SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
+1 KILL ^TMP($JOB)
+2 SET LROCE=$SELECT($DATA(LROC):LROC,1:"")
SET LROC=$SELECT(LROCE="":$ORDER(^LAB(64.6,"AI","")),1:LROC)
IF LROC'=""
DO AI2
FOR
SET LROC=$ORDER(^LAB(64.6,"AI",LROC))
IF LROC=""!($LENGTH(LROCE)&(LROC'=LROCE))
QUIT
DO AI2
+3 SET LROC="UNKNOWN"
DO AI2
PRT ;Print sorted data
+1 USE IO
KILL VA
DO KVAR^BLRDPT
SET LREND=0
+2 IF $ORDER(^TMP($JOB,0))=""
WRITE !!?10,"No Interim report Patients to Print ",!?20,$$DTF^LRAFUNC1($$NOW^LRAFUNC1),!!
GOTO QUIT
+3 SET LROC=""
FOR
SET LROC=$ORDER(^TMP($JOB,LROC))
IF LROC=""!($GET(LREND))
QUIT
SET LRPHY=""
FOR
SET LRPHY=$ORDER(^TMP($JOB,LROC,LRPHY))
IF LRPHY=""!($GET(LREND))
QUIT
Begin DoDot:1
+4 SET LRSSN=""
FOR
SET LRSSN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN))
IF LRSSN=""!($GET(LREND))
QUIT
Begin DoDot:2
+5 SET LRDFN=0
FOR
SET LRHF=1
SET LRDFN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN))
IF LRDFN<1!($GET(LREND))
QUIT
Begin DoDot:3
+6 SET LRIDT=0
FOR
SET LRIDT=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT))
IF LRIDT<1!($GET(LREND))
QUIT
Begin DoDot:4
+7 ;S LRSS="",PNM=^(LRIDT),SSN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0
+8 ;IHS/ANMC/CLS 08/18/96
SET LRSS=""
SET PNM=^(LRIDT)
SET HRCN=$PIECE(PNM,U,2)
SET AGE=$PIECE(PNM,U,3)
SET SEX=$PIECE(PNM,U,4)
SET PNM=$PIECE(PNM,U)
SET LRFOOT=0
+9 IF $DATA(^LR(LRDFN,"CH",LRIDT,0))#2
DO CH
+10 SET LRFOOT=0
IF $DATA(^LR(LRDFN,"MI",LRIDT,0))#2
IF $GET(LRSS)="CH"
DO FOOT^LRRP1
DO MI
End DoDot:4
End DoDot:3
IF $GET(LRSS)="CH"
DO FOOT^LRRP1
End DoDot:2
End DoDot:1
QUIT IF $DATA(ZTQUEUED)
SET ZTREQ="@"
WRITE !!
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
DO ^LRRK
+1 QUIT
AI2 ;
+1 IF '$LENGTH($GET(LROC))
QUIT
+2 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69,"AN",LROC,LRDFN))
IF LRDFN<1
QUIT
IF $DATA(^LR(LRDFN,0))#2
Begin DoDot:1
+3 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
IF LREND
QUIT
+4 IF '$GET(VAERR)
DO AI3
End DoDot:1
+5 QUIT
AI3 ;
+1 IF $GET(LREND)
QUIT
+2 ;S LRSSN=$P(PNM,",")_SSN(1)
+3 ;IHS/ANMC/CLS 08/18/96
SET LRSSN=$PIECE(PNM,",")_HRCN
+4 FOR LRIDT=0:0
SET LRIDT=$ORDER(^LRO(69,"AN",LROC,LRDFN,LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:1
+5 SET LRND=$SELECT($GET(^LR(LRDFN,"CH",LRIDT,0)):^(0),$GET(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"")
IF $PIECE(LRND,U,3)
Begin DoDot:2
+6 SET LRPHY=$PIECE($GET(^VA(200,+$PIECE(LRND,U,10),0)),U)
IF LRPHY=""
SET LRPHY="UNKNOWN"
+7 ;IHS/ANMC/CLS 08/18/96
SET ^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_HRCN_U_AGE_U_SEX
End DoDot:2
End DoDot:1
+8 QUIT
CH ;Also used by DVBC Package
+1 NEW LROC
+2 ;K ^TMP("LR",$J,"TP"),LRTP S LR0=^LR(LRDFN,"CH",LRIDT,0) Q:'$P(LR0,U,3) S LRCDT=+LR0,LRSS="CH",LROC=$P(LR0,U,11),LRAA="",LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5)
+3 ;IHS/OIRM TUC/AAB 1/21/98
KILL ^TMP("LR",$JOB,"TP"),LRTP
SET LR0=^LR(LRDFN,"CH",LRIDT,0)
IF '$PIECE(LR0,U,3)
QUIT
+4 ;IHS/OIRM TUC/AAB 7/1/98
IF LRSINGLE
IF LRMD="S"
IF LRPHY'=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(LR0,U,10),0)),U),1,20)
QUIT
+5 ;IHS/OIRM TUC/AAB 1/21/98
SET LRCDT=+LR0
SET LRSS="CH"
SET LROC=$PIECE(LR0,U,11)
SET LRAA=""
SET LRAAO=1
SET LRTC=0
SET LRSPEC=$PIECE(LR0,U,5)
+6 DO CH^LRRP
+7 QUIT
MI ;Also used by DVBC package
+1 ;S BLRPHYS=$P($G(^VA(200,+$P(^LR(LRDFN,"MI",LRIDT,0),U,7),0)),U) Q:'$D(LRPHY(BLRPHYS)) ;IHS/OIRM TUC/AAB 1/21/98 FIX FOR A MORE THAN ONE SELECTED PROVIDER
+2 ;IHS/DIR TUC/AAB 7/1/98
IF LRSINGLE
IF LRMD="S"
IF LRPHY'=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,7),0)),U),1,20)
QUIT
+3 SET LRCDT=9999999-LRIDT
SET ^TMP("LR",$JOB,"TP",1)="^MI"
SET ^(1,LRCDT)=""
SET ^(LRCDT,-1)=""
SET LRSS="MI"
SET LRH=1
IF LRFOOT
DO FOOT^LRRP1
IF LRSTOP
QUIT
DO EN1^LRMIPC
SET LRHF=1
SET LRFOOT=0
KILL A,Z,LRH
IF LREND
SET LREND=0
SET LRSTOP=1
+4 QUIT
INIT ;IHS/ANMC/CLS 08/18/96 LRDT0 <undef>
DO EN^LRPARAM
IF '$DATA(LRDT0)
DO DT^LRX
SET (LREND,LRSTOP)=0
SET LRCW=8
SET LRHF=1
SET LRFOOT=0
SET (LRONESPC,LRONETST)=""
+1 QUIT
EN69 ;entry point for surgery pkg
+1 DO START
DO ^LRRK
+2 QUIT
GEN ;from LRGEN test overflow
+1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
DO INIT
DO GENP
DO ^LRRK
+2 QUIT
DS ;from LRRD, LRRS
+1 DO INIT
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=$PIECE(^(0),U,2)
DO SDQ
+2 QUIT
AIDQ ;tasked from LRTASK DAILY INTERIM
+1 SET LRLAB=0
SET LRH=""
SET LRWRDVEW=""
DO INIT
DO AIDQUE
KILL LRH
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB)
+2 QUIT
DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
DO INIT
SET LRLAB=0
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
DO CH
DO FOOT^LRRP1
WRITE @IOF
DO ^%ZISC
+2 QUIT
OR ;OE/RR entry point
+1 IF '$DATA(ORVP)
QUIT
SET KILL=1
IF '$DATA(LRPARAM)
DO EN^LRPARAM
SET KILL=0
+2 SET (LREND,LRSTOP)=0
SET LRCW=8
SET LRHF=1
SET LRFOOT=0
SET (LRONESPC,LRONETST)=""
+3 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET DFN=+ORVP
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
IF LRDFN<1
QUIT
+4 DO START
DO ^LRRK
+5 IF 'KILL
KILL LRBLOOD,LRDT0,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE
+6 KILL KILL
QUIT
