LRBEPRPT ;VA/DALOI/FHS - PRINT CPT CODES FOR TESTS AND PANELS ;03/30/2005
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
;
;;VA LR Patche(s): 291,359
;
BEBA ;Individual test CPT code look-up
K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
S (LRBEPSY,LRBECPT)="" K DIR,X,Y,LRSTOP,LRPG
S LRBECDT=DT
S DIR(0)="PO^60:AQEZNM"
S DIR("S")="I $S('$L($P(^(0),U,3)):0,$P(^(0),U,3)=""N"":0,1:1)"
D ^DIR K DIR
I $G(Y)<1 D CLEAN Q
W @IOF
S LRBELOP=1,LRBEBY=Y,LRPRT=0
D LOOP
I $G(OUT) D Q
. W !,+LRBEBY_" = "_$P(^LAB(60,+LRBEBY,0),U)
. W !,"********** ","Invalid data prevents display.",!
D:'$G(OUT) T1
D CLEAN
G BEBA
LOOP ;
Q:$G(LRBEPSY)!($G(LRSTOP))
S:'$G(LRSPEC) LRSPEC=99999999 S:'$G(LRBECDT) LRBECDT=DT
K DIC,LRTEST,LRNAME,LRNLT,T1,LRY,LRBECPT,LRORD
K LRM,LRMX
K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
S LRBECPT=""
S X=+LRBEBY_U_+LRBEBY,LRNLT=+LRBEBY,LRTEST(1,"P")=LRNLT_U_$$NLT^LRVER1(LRNLT)
S T1=1,LRTEST(T1)=+LRBEBY_U_^LAB(60,+LRBEBY,0)
S OUT=0,XX=$P(LRTEST(T1),U,6) D Q:OUT
. I XX'="",+$P(XX,";",2)=0 S OUT=1 Q
. I XX'="" S LRBEY(+LRBEBY,+$P(XX,";",2))=""
. I $D(^LAB(60,+LRBEBY,2)) D
. . S I=0 F S I=$O(^LAB(60,+LRBEBY,2,I)) Q:'I D
. . . S K=$P(^LAB(60,+LRBEBY,2,I,0),U,1)
. . . S XX=$P(^LAB(60,K,0),U,5) I XX'="",+$P(XX,";",2)=0 S OUT=1 Q
. . . S LRBEY(+LRBEBY,+$P(XX,";",2))=""
K LRBECPT
S LRBETST=0,(LRPANEL,LRBEPYS)=""
S LRBETST=$O(LRBEY(LRBETST)) Q:LRBETST<1!($G(LRSTOP)) D
. Q:'$G(^LAB(60,LRBETST,12))
. Q:$L($P(^LAB(60,LRBETST,0),U,5))
. D PANEL^LRBEBA4
. I '$O(LRBECPT(LRBETST,0)) Q
. S LRPANEL="*"
. S LRBEPSY=1 D DISPLAY
. S (LRPANEL)=""
. W !
PANEL ;Display panel test CPT
I $G(LRBEPSY) K LRBECPT Q
I $O(LRBECPT(0)) D Q:$G(LRBELOP)!($G(LRSTOP))
. S LRBEPYS=1 D DISPLAY
Q:$S($G(LRBEPO):1,$G(LRBEPYS):1,1:0)
K LRBECPT
S LRTST=0,LRBETST=+LRBEBY
NLT ;
S LRBECDT=DT D PANEL^LRBEBA4
Q:'$O(LRBECPT(0))
S LRI=0 F S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1!($G(LRSTOP)) D
. D LN Q:$G(LRSTOP)
. ;W !,"{"_LRBETST_"="_$P(^LAB(60,LRBETST,0),U)_"} "_$P($G(LRBEBY),U,2)
. ;W:$D(^LAB(61,LRSPEC,0))#2 " (SPEC) = "_$E($P(^(0),U),1,30)
. S LRREQ=$S($P($G(^LAB(60,LRBETST,0)),U,17):"r ",1:" ")
. W !,LRBETST_" = "_LRREQ_$P($G(LRBEBY),U,2)_" " ;_$P(^LAB(60,LRBETST,0),U)
. W:$D(^LAB(61,LRSPEC,0))#2 " (SPEC) = "_$E($P(^(0),U),1,30)
. D WRT
Q
;
DISPLAY ;
Q:$G(LRSTOP) K LRREQ
I $O(LRBECPT(0)),'$G(LRPRT) W ! S LRPRT=1
S LRBETST=0 F S LRBETST=$O(LRBECPT(LRBETST)) Q:LRBETST<1!($G(LRSTOP)) D
. D LN Q:$G(LRSTOP)
. S LRREQ=$S($P($G(^LAB(60,LRBETST,0)),U,17):"r ",1:"")
. W !,LRBETST_" = "_LRREQ_$P(^LAB(60,LRBETST,0),U) I $D(^LAB(61,LRSPEC,0))#2 W " / "_$P(^(0),U)
. S LRI=0 F S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1 D WRT
Q
WRT ;
D LN Q:$G(LRSTOP)
S LRPRT=1
S LRCPT=$O(LRBECPT(LRBETST,LRI,0)) Q:'LRCPT!($G(LRSTOP)) D
. D LN Q:$G(LRSTOP)
. S XCODE=$$CPT^ICPTCOD(LRCPT)
. W !?6,$P(XCODE,U,2)_" "_$P(XCODE,U,3)_" ["_LRBECPT(LRBETST,LRI,LRCPT)_"]"_$G(LRPANEL)
. K LRBECPT(LRBETST,LRI,LRCPT),XCODE
Q
;
LN ;Check line spacing
Q:$Y<(IOSL-4)!($G(LRSTOP))
I $E(IOST,1)="C" D Q:LRSTOP
. N DIR S DIR(0)="E" D ^DIR S LRSTOP=$G(DIRUT)
HDR ;Report header
W @IOF,! S LRPG=$G(LRPG)+1
W $$CJ^XLFSTR($G(LRHDR)_" "_$$FMTE^XLFDT(DT,5)_" Pg "_LRPG,IOM),!
Q
;
TEST ;List all test with CPT codes
;logic follows the Billing Aware CPT logic Hierarchy
U IO
I '$G(LRPG) D HDR
S LRBELOP=1,LRBECDT=DT
S LRTN="^LAB(60,""B"")"
F Q:$G(LRSTOP) S LRTN=$Q(@LRTN) Q:$QS(LRTN,2)'="B" D
. Q:$G(@LRTN)
. S LRSPEC=999999,LRBEBY=$QS(LRTN,4)
. Q:$S('$D(^LAB(60,LRBEBY,0))#2:1,'$L($P(^(0),U,3)):1,$P(^(0),U,3)="N":1,1:0)
. Q:$G(LRSTOP)
. S LRPRT=0,LRBEPSY=""
. S LRBEBY=LRBEBY_U_$P(^LAB(60,+LRBEBY,0),U)
. D LOOP
. Q:$G(OUT)
. Q:$G(LRSTOP)
. D T1
. K LRBEY,LRBEBY
. Q:$G(LRSTOP)
D CLEAN
Q
;
T1 ;
S LRSPEC=0 F S LRSPEC=$O(^LAB(60,+LRBEBY,1,LRSPEC)) Q:LRSPEC<1!($G(LRSTOP)) D
. D LOOP
. K LRBECPT
Q:$G(OUT)
Q:$G(LRSTOP)
D ATOMIC
I $G(LRPRT) W !
K LRBEPSY
Q
;
ATOMIC ; Print Atomic test of panel
Q:'$O(^LAB(60,+LRBEBY,2,0))
W !,+LRBEBY_" = "_$P(^LAB(60,+LRBEBY,0),U),!,"**********"
N LRBEBSY,LRII,LRREQ
S LRBEBSY=+LRBEBY N LRII S LRII=0
F S LRII=$O(^LAB(60,LRBEBSY,2,LRII)) Q:LRII<1!($G(LRSTOP)) D
. S LRBEBY=+$G(^LAB(60,LRBEBSY,2,LRII,0)) Q:'LRBEBY!($G(LRSTOP)) D
. . S LRREQ=$S($P($G(^LAB(60,LRBEBY,0)),U,17):"r",1:" ")
. . I $D(^LAB(60,LRBEBY,0)) S LRBEBY=LRREQ_"["_LRBEBY_"] "_$P(^(0),U) D
. . . W ?15,LRBEBY,! D LN
Q
;
ASK ;Present user with a selection of options
K DIR,Y,LRSTOP,POP,ZTRTN,OUT,OPT,XX
K LRDEV,ZTDTH,ZTDESC,ZTIO,ZTSAVE
S OUT=0
S LRBECDT=DT
S DIR(0)="SO^1:Single Test Look-up;2:List Panels Only;3:List All Test"
D ^DIR K DIR
I Y<1 G CLEAN
S OPT=Y
I OPT=1 D G ASK
. S LRHDR="*** Single Test code listing (CPT) ***"
. D BEBA
I OPT=2 D G ASK
. S LRHDR="*** Panel Tests Only (CPT) ***",LRBEPO=1
. D DEV I $G(POP) D ^%ZISC Q
. I IO'=IO(0) D Q
. . S ZTSAVE("LRBEPO")=""
. . S ZTRTN="TEST^LRBEPRPT"
. . D LOAD
. D TEST
I OPT=3 D G ASK
. D DEV I $G(POP) D ^%ZISC Q
. S LRHDR="*** All Lab Tests (CPT) ***"
. I IO'=IO(0) D Q
. . S ZTRTN="TEST^LRBEPRPT"
. . D LOAD
. D TEST
Q
;
DEV ;Select print device
N %ZIS,LRMSG,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
S %ZIS="NQ",%ZIS("A")=" Select Print Device: "
S (LRDEV,%ZIS("B"))="Home" D ^%ZIS
Q
LOAD ;%ZTLOAD section
S ZTDTH=$H
S ZTDESC=$G(LRHDR)
S (LRDEV,ZTIO)=ION,ZTSAVE("LRHDR")=""
D ^%ZTLOAD W @IOF,!,$S($G(ZTSK):"Queued to device "_LRDEV,1:"Not Queued"),!
D ^%ZISC
D HOME^%ZIS
Q
;
CLEAN ;Clean-up
W:$D(ZTQUEUED) @IOF
K DIC,DIR,DIRUT,DTOUT,DUOUT
K LRBEBY,LRBECPT,LRBECDT,LRBEDT,LRBELOP,LRBEPYS,LRBEYS,LRBENLT,LRBETST,LRBEY,LRCFL
K LRCPT,LRI,LRIEN,LRM,LRMX,LRNAME,LRNLT,LRNX,LRORD,LRBEPO,LRPANEL,LRPRT
K LRSPEC,LRSTOP,LRSUB,LRTEST,LRTN,LRTST,LRXX,LRY,S2,T1,X,Y,YY
K LRHDR,LRDEV,LRPG,POP
K ^TMP("LR",$J,"VTO"),^TMP("LR",$J,"TMP")
D ^%ZISC
Q
LRBEPRPT ;VA/DALOI/FHS - PRINT CPT CODES FOR TESTS AND PANELS ;03/30/2005
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 291,359
+4 ;
BEBA ;Individual test CPT code look-up
+1 KILL ^TMP("LR",$JOB,"VTO"),^TMP("LR",$JOB,"TMP")
+2 SET (LRBEPSY,LRBECPT)=""
KILL DIR,X,Y,LRSTOP,LRPG
+3 SET LRBECDT=DT
+4 SET DIR(0)="PO^60:AQEZNM"
+5 SET DIR("S")="I $S('$L($P(^(0),U,3)):0,$P(^(0),U,3)=""N"":0,1:1)"
+6 DO ^DIR
KILL DIR
+7 IF $GET(Y)<1
DO CLEAN
QUIT
+8 WRITE @IOF
+9 SET LRBELOP=1
SET LRBEBY=Y
SET LRPRT=0
+10 DO LOOP
+11 IF $GET(OUT)
Begin DoDot:1
+12 WRITE !,+LRBEBY_" = "_$PIECE(^LAB(60,+LRBEBY,0),U)
+13 WRITE !,"********** ","Invalid data prevents display.",!
End DoDot:1
QUIT
+14 IF '$GET(OUT)
DO T1
+15 DO CLEAN
+16 GOTO BEBA
LOOP ;
+1 IF $GET(LRBEPSY)!($GET(LRSTOP))
QUIT
+2 IF '$GET(LRSPEC)
SET LRSPEC=99999999
IF '$GET(LRBECDT)
SET LRBECDT=DT
+3 KILL DIC,LRTEST,LRNAME,LRNLT,T1,LRY,LRBECPT,LRORD
+4 KILL LRM,LRMX
+5 KILL ^TMP("LR",$JOB,"VTO"),^TMP("LR",$JOB,"TMP")
+6 SET LRBECPT=""
+7 SET X=+LRBEBY_U_+LRBEBY
SET LRNLT=+LRBEBY
SET LRTEST(1,"P")=LRNLT_U_$$NLT^LRVER1(LRNLT)
+8 SET T1=1
SET LRTEST(T1)=+LRBEBY_U_^LAB(60,+LRBEBY,0)
+9 SET OUT=0
SET XX=$PIECE(LRTEST(T1),U,6)
Begin DoDot:1
+10 IF XX'=""
IF +$PIECE(XX,";",2)=0
SET OUT=1
QUIT
+11 IF XX'=""
SET LRBEY(+LRBEBY,+$PIECE(XX,";",2))=""
+12 IF $DATA(^LAB(60,+LRBEBY,2))
Begin DoDot:2
+13 SET I=0
FOR
SET I=$ORDER(^LAB(60,+LRBEBY,2,I))
IF 'I
QUIT
Begin DoDot:3
+14 SET K=$PIECE(^LAB(60,+LRBEBY,2,I,0),U,1)
+15 SET XX=$PIECE(^LAB(60,K,0),U,5)
IF XX'=""
IF +$PIECE(XX,";",2)=0
SET OUT=1
QUIT
+16 SET LRBEY(+LRBEBY,+$PIECE(XX,";",2))=""
End DoDot:3
End DoDot:2
End DoDot:1
IF OUT
QUIT
+17 KILL LRBECPT
+18 SET LRBETST=0
SET (LRPANEL,LRBEPYS)=""
+19 SET LRBETST=$ORDER(LRBEY(LRBETST))
IF LRBETST<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+20 IF '$GET(^LAB(60,LRBETST,12))
QUIT
+21 IF $LENGTH($PIECE(^LAB(60,LRBETST,0),U,5))
QUIT
+22 DO PANEL^LRBEBA4
+23 IF '$ORDER(LRBECPT(LRBETST,0))
QUIT
+24 SET LRPANEL="*"
+25 SET LRBEPSY=1
DO DISPLAY
+26 SET (LRPANEL)=""
+27 WRITE !
End DoDot:1
PANEL ;Display panel test CPT
+1 IF $GET(LRBEPSY)
KILL LRBECPT
QUIT
+2 IF $ORDER(LRBECPT(0))
Begin DoDot:1
+3 SET LRBEPYS=1
DO DISPLAY
End DoDot:1
IF $GET(LRBELOP)!($GET(LRSTOP))
QUIT
+4 IF $SELECT($GET(LRBEPO)
QUIT
+5 KILL LRBECPT
+6 SET LRTST=0
SET LRBETST=+LRBEBY
NLT ;
+1 SET LRBECDT=DT
DO PANEL^LRBEBA4
+2 IF '$ORDER(LRBECPT(0))
QUIT
+3 SET LRI=0
FOR
SET LRI=$ORDER(LRBECPT(LRBETST,LRI))
IF LRI<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+4 DO LN
IF $GET(LRSTOP)
QUIT
+5 ;W !,"{"_LRBETST_"="_$P(^LAB(60,LRBETST,0),U)_"} "_$P($G(LRBEBY),U,2)
+6 ;W:$D(^LAB(61,LRSPEC,0))#2 " (SPEC) = "_$E($P(^(0),U),1,30)
+7 SET LRREQ=$SELECT($PIECE($GET(^LAB(60,LRBETST,0)),U,17):"r ",1:" ")
+8 ;_$P(^LAB(60,LRBETST,0),U)
WRITE !,LRBETST_" = "_LRREQ_$PIECE($GET(LRBEBY),U,2)_" "
+9 IF $DATA(^LAB(61,LRSPEC,0))#2
WRITE " (SPEC) = "_$EXTRACT($PIECE(^(0),U),1,30)
+10 DO WRT
End DoDot:1
+11 QUIT
+12 ;
DISPLAY ;
+1 IF $GET(LRSTOP)
QUIT
KILL LRREQ
+2 IF $ORDER(LRBECPT(0))
IF '$GET(LRPRT)
WRITE !
SET LRPRT=1
+3 SET LRBETST=0
FOR
SET LRBETST=$ORDER(LRBECPT(LRBETST))
IF LRBETST<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+4 DO LN
IF $GET(LRSTOP)
QUIT
+5 SET LRREQ=$SELECT($PIECE($GET(^LAB(60,LRBETST,0)),U,17):"r ",1:"")
+6 WRITE !,LRBETST_" = "_LRREQ_$PIECE(^LAB(60,LRBETST,0),U)
IF $DATA(^LAB(61,LRSPEC,0))#2
WRITE " / "_$PIECE(^(0),U)
+7 SET LRI=0
FOR
SET LRI=$ORDER(LRBECPT(LRBETST,LRI))
IF LRI<1
QUIT
DO WRT
End DoDot:1
+8 QUIT
WRT ;
+1 DO LN
IF $GET(LRSTOP)
QUIT
+2 SET LRPRT=1
+3 SET LRCPT=$ORDER(LRBECPT(LRBETST,LRI,0))
IF 'LRCPT!($GET(LRSTOP))
QUIT
Begin DoDot:1
+4 DO LN
IF $GET(LRSTOP)
QUIT
+5 SET XCODE=$$CPT^ICPTCOD(LRCPT)
+6 WRITE !?6,$PIECE(XCODE,U,2)_" "_$PIECE(XCODE,U,3)_" ["_LRBECPT(LRBETST,LRI,LRCPT)_"]"_$GET(LRPANEL)
+7 KILL LRBECPT(LRBETST,LRI,LRCPT),XCODE
End DoDot:1
+8 QUIT
+9 ;
LN ;Check line spacing
+1 IF $Y<(IOSL-4)!($GET(LRSTOP))
QUIT
+2 IF $EXTRACT(IOST,1)="C"
Begin DoDot:1
+3 NEW DIR
SET DIR(0)="E"
DO ^DIR
SET LRSTOP=$GET(DIRUT)
End DoDot:1
IF LRSTOP
QUIT
HDR ;Report header
+1 WRITE @IOF,!
SET LRPG=$GET(LRPG)+1
+2 WRITE $$CJ^XLFSTR($GET(LRHDR)_" "_$$FMTE^XLFDT(DT,5)_" Pg "_LRPG,IOM),!
+3 QUIT
+4 ;
TEST ;List all test with CPT codes
+1 ;logic follows the Billing Aware CPT logic Hierarchy
+2 USE IO
+3 IF '$GET(LRPG)
DO HDR
+4 SET LRBELOP=1
SET LRBECDT=DT
+5 SET LRTN="^LAB(60,""B"")"
+6 FOR
IF $GET(LRSTOP)
QUIT
SET LRTN=$QUERY(@LRTN)
IF $QSUBSCRIPT(LRTN,2)'="B"
QUIT
Begin DoDot:1
+7 IF $GET(@LRTN)
QUIT
+8 SET LRSPEC=999999
SET LRBEBY=$QSUBSCRIPT(LRTN,4)
+9 IF $SELECT('$DATA(^LAB(60,LRBEBY,0))#2
QUIT
+10 IF $GET(LRSTOP)
QUIT
+11 SET LRPRT=0
SET LRBEPSY=""
+12 SET LRBEBY=LRBEBY_U_$PIECE(^LAB(60,+LRBEBY,0),U)
+13 DO LOOP
+14 IF $GET(OUT)
QUIT
+15 IF $GET(LRSTOP)
QUIT
+16 DO T1
+17 KILL LRBEY,LRBEBY
+18 IF $GET(LRSTOP)
QUIT
End DoDot:1
+19 DO CLEAN
+20 QUIT
+21 ;
T1 ;
+1 SET LRSPEC=0
FOR
SET LRSPEC=$ORDER(^LAB(60,+LRBEBY,1,LRSPEC))
IF LRSPEC<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+2 DO LOOP
+3 KILL LRBECPT
End DoDot:1
+4 IF $GET(OUT)
QUIT
+5 IF $GET(LRSTOP)
QUIT
+6 DO ATOMIC
+7 IF $GET(LRPRT)
WRITE !
+8 KILL LRBEPSY
+9 QUIT
+10 ;
ATOMIC ; Print Atomic test of panel
+1 IF '$ORDER(^LAB(60,+LRBEBY,2,0))
QUIT
+2 WRITE !,+LRBEBY_" = "_$PIECE(^LAB(60,+LRBEBY,0),U),!,"**********"
+3 NEW LRBEBSY,LRII,LRREQ
+4 SET LRBEBSY=+LRBEBY
NEW LRII
SET LRII=0
+5 FOR
SET LRII=$ORDER(^LAB(60,LRBEBSY,2,LRII))
IF LRII<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+6 SET LRBEBY=+$GET(^LAB(60,LRBEBSY,2,LRII,0))
IF 'LRBEBY!($GET(LRSTOP))
QUIT
Begin DoDot:2
+7 SET LRREQ=$SELECT($PIECE($GET(^LAB(60,LRBEBY,0)),U,17):"r",1:" ")
+8 IF $DATA(^LAB(60,LRBEBY,0))
SET LRBEBY=LRREQ_"["_LRBEBY_"] "_$PIECE(^(0),U)
Begin DoDot:3
+9 WRITE ?15,LRBEBY,!
DO LN
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
ASK ;Present user with a selection of options
+1 KILL DIR,Y,LRSTOP,POP,ZTRTN,OUT,OPT,XX
+2 KILL LRDEV,ZTDTH,ZTDESC,ZTIO,ZTSAVE
+3 SET OUT=0
+4 SET LRBECDT=DT
+5 SET DIR(0)="SO^1:Single Test Look-up;2:List Panels Only;3:List All Test"
+6 DO ^DIR
KILL DIR
+7 IF Y<1
GOTO CLEAN
+8 SET OPT=Y
+9 IF OPT=1
Begin DoDot:1
+10 SET LRHDR="*** Single Test code listing (CPT) ***"
+11 DO BEBA
End DoDot:1
GOTO ASK
+12 IF OPT=2
Begin DoDot:1
+13 SET LRHDR="*** Panel Tests Only (CPT) ***"
SET LRBEPO=1
+14 DO DEV
IF $GET(POP)
DO ^%ZISC
QUIT
+15 IF IO'=IO(0)
Begin DoDot:2
+16 SET ZTSAVE("LRBEPO")=""
+17 SET ZTRTN="TEST^LRBEPRPT"
+18 DO LOAD
End DoDot:2
QUIT
+19 DO TEST
End DoDot:1
GOTO ASK
+20 IF OPT=3
Begin DoDot:1
+21 DO DEV
IF $GET(POP)
DO ^%ZISC
QUIT
+22 SET LRHDR="*** All Lab Tests (CPT) ***"
+23 IF IO'=IO(0)
Begin DoDot:2
+24 SET ZTRTN="TEST^LRBEPRPT"
+25 DO LOAD
End DoDot:2
QUIT
+26 DO TEST
End DoDot:1
GOTO ASK
+27 QUIT
+28 ;
DEV ;Select print device
+1 NEW %ZIS,LRMSG,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
+2 SET %ZIS="NQ"
SET %ZIS("A")=" Select Print Device: "
+3 SET (LRDEV,%ZIS("B"))="Home"
DO ^%ZIS
+4 QUIT
LOAD ;%ZTLOAD section
+1 SET ZTDTH=$HOROLOG
+2 SET ZTDESC=$GET(LRHDR)
+3 SET (LRDEV,ZTIO)=ION
SET ZTSAVE("LRHDR")=""
+4 DO ^%ZTLOAD
WRITE @IOF,!,$SELECT($GET(ZTSK):"Queued to device "_LRDEV,1:"Not Queued"),!
+5 DO ^%ZISC
+6 DO HOME^%ZIS
+7 QUIT
+8 ;
CLEAN ;Clean-up
+1 IF $DATA(ZTQUEUED)
WRITE @IOF
+2 KILL DIC,DIR,DIRUT,DTOUT,DUOUT
+3 KILL LRBEBY,LRBECPT,LRBECDT,LRBEDT,LRBELOP,LRBEPYS,LRBEYS,LRBENLT,LRBETST,LRBEY,LRCFL
+4 KILL LRCPT,LRI,LRIEN,LRM,LRMX,LRNAME,LRNLT,LRNX,LRORD,LRBEPO,LRPANEL,LRPRT
+5 KILL LRSPEC,LRSTOP,LRSUB,LRTEST,LRTN,LRTST,LRXX,LRY,S2,T1,X,Y,YY
+6 KILL LRHDR,LRDEV,LRPG,POP
+7 KILL ^TMP("LR",$JOB,"VTO"),^TMP("LR",$JOB,"TMP")
+8 DO ^%ZISC
+9 QUIT
