LRAPFICH ;AVAMC/REG/WTY/KLL - MICROFICH PATH REPORTS ;03/21/2002
;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**72,173,248,259**;Sep 27, 1994
;
D END ;Final path reports by accession number
N LRQUIT
W ! S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END
;KLL - Final Office Copy prints SNOMED codes on a separate page
D FOC
;Variable LR("DVD") is used to divide reports displayed in the browser
K LR("DVD")
S $P(LR("DVD"),"|",IOM)=""
S %DT("A")="Select Accession YEAR: ",%DT="AEQ" D ^%DT K %DT G:Y<1 END S LR("Y")=$E(Y,1,3)
A R !,"Start with accession #: ",X:DTIME G:X[U!(X="") END I X'?1N.N W $C(7),!,"Enter a number." G A
S LR("B")=X
B R !,"Go to accession #: ",X:DTIME G:X[U!(X="") END I X'?1N.N W $C(7),!,"Enter a number." G B
S LR("E")=X I LR("E")<LR("B") S X=LR("B"),LR("B")=LR("E"),LR("E")=X
S LR("B")=LR("B")-1
SETUP ;
W !
S %ZIS="Q" D ^%ZIS
I POP W ! D END Q
I $D(IO("Q")) D Q
.S ZTDESC="Final path reports by accession #"
.S ZTSAVE("*")="",ZTRTN="QUE^LRAPFICH",ZTREQ="@",ZTIO=ION
.D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to device ",ION K ZTIO
.D HOME^%ZIS K ZTSK,IO("Q"),ZTREQ
QUE ;
U IO S LR("DIWF")="W",(LR,LR("A"),LR(1),LR(2),LR(3))=0
S (LRA,LRQ(3))=1
D L^LRU,S^LRU,XR^LRU,L1^LRU,EN2^LRUA,SET^LRUA
S LRAN=LR("B")
F S LRAN=$O(^LR(LRXREF,LR("Y"),LRABV,LRAN)) Q:'LRAN!(LRAN>LR("E"))!(LR("Q")) D
.S LRDFN=$O(^LR(LRXREF,LR("Y"),LRABV,LRAN,0)),LRI=$O(^(LRDFN,0))
.S LRSF515=1,LRQUIT=0
.K LR("F")
.D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
.I +$G(LRPTR) D Q
..D MAIN^LRAPTIUP(LRPTR,0)
..W:IOST["BROWSER" !!,LR("DVD")
..K LRPTR
..;KLL-Print SNOMED Codes if Final Office Copy selected
..I LRFOC D FOC^LRSPRPT
..I LRQUIT S LR("Q")=1 Q
..S LR("F")=1
..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
.W:IOST?1"C-".E @IOF
.D EN^LRSPRPT
.W:IOST?1"P-".E @IOF
.W:IOST["BROWSER" !!,LR("DVD")
.I LRFOC D FOC^LRSPRPT
.I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
D END
Q
FOC ;Final Office Copy
W !
K DIR
S LRFOC=0
S DIR(0)="Y",DIR("A")="Is this a final office copy"
S DIR("B")="YES"
S DIR("?",1)="SNOMED codes no longer appear on the report. The final"
S DIR("?",1)=DIR("?",1)_" office copy prints"
S DIR("?")="these codes on a separate page. Enter 'Yes' to include "
S DIR("?")=DIR("?")_"this page."
D ^DIR
I Y S LRFOC=1
Q
CONT ;
K DIR S DIR(0)="E"
D ^DIR W !
S:$D(DTOUT)!(X[U) LR("Q")=1
Q
END D V^LRU
K LRSF515
Q
LRAPFICH ;AVAMC/REG/WTY/KLL - MICROFICH PATH REPORTS ;03/21/2002
+1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**72,173,248,259**;Sep 27, 1994
+3 ;
+4 ;Final path reports by accession number
DO END
+5 NEW LRQUIT
+6 WRITE !
SET LRDICS="SPCYEM"
DO ^LRAP
IF '$DATA(Y)
GOTO END
+7 ;KLL - Final Office Copy prints SNOMED codes on a separate page
+8 DO FOC
+9 ;Variable LR("DVD") is used to divide reports displayed in the browser
+10 KILL LR("DVD")
+11 SET $PIECE(LR("DVD"),"|",IOM)=""
+12 SET %DT("A")="Select Accession YEAR: "
SET %DT="AEQ"
DO ^%DT
KILL %DT
IF Y<1
GOTO END
SET LR("Y")=$EXTRACT(Y,1,3)
A READ !,"Start with accession #: ",X:DTIME
IF X[U!(X="")
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!,"Enter a number."
GOTO A
+1 SET LR("B")=X
B READ !,"Go to accession #: ",X:DTIME
IF X[U!(X="")
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!,"Enter a number."
GOTO B
+1 SET LR("E")=X
IF LR("E")<LR("B")
SET X=LR("B")
SET LR("B")=LR("E")
SET LR("E")=X
+2 SET LR("B")=LR("B")-1
SETUP ;
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
DO END
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Final path reports by accession #"
+6 SET ZTSAVE("*")=""
SET ZTRTN="QUE^LRAPFICH"
SET ZTREQ="@"
SET ZTIO=ION
+7 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Report Queued to device ",ION
KILL ZTIO
+8 DO HOME^%ZIS
KILL ZTSK,IO("Q"),ZTREQ
End DoDot:1
QUIT
QUE ;
+1 USE IO
SET LR("DIWF")="W"
SET (LR,LR("A"),LR(1),LR(2),LR(3))=0
+2 SET (LRA,LRQ(3))=1
+3 DO L^LRU
DO S^LRU
DO XR^LRU
DO L1^LRU
DO EN2^LRUA
DO SET^LRUA
+4 SET LRAN=LR("B")
+5 FOR
SET LRAN=$ORDER(^LR(LRXREF,LR("Y"),LRABV,LRAN))
IF 'LRAN!(LRAN>LR("E"))!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET LRDFN=$ORDER(^LR(LRXREF,LR("Y"),LRABV,LRAN,0))
SET LRI=$ORDER(^(LRDFN,0))
+7 SET LRSF515=1
SET LRQUIT=0
+8 KILL LR("F")
+9 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
+10 IF +$GET(LRPTR)
Begin DoDot:2
+11 DO MAIN^LRAPTIUP(LRPTR,0)
+12 IF IOST["BROWSER"
WRITE !!,LR("DVD")
+13 KILL LRPTR
+14 ;KLL-Print SNOMED Codes if Final Office Copy selected
+15 IF LRFOC
DO FOC^LRSPRPT
+16 IF LRQUIT
SET LR("Q")=1
QUIT
+17 SET LR("F")=1
+18 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
End DoDot:2
QUIT
+19 IF IOST?1"C-".E
WRITE @IOF
+20 DO EN^LRSPRPT
+21 IF IOST?1"P-".E
WRITE @IOF
+22 IF IOST["BROWSER"
WRITE !!,LR("DVD")
+23 IF LRFOC
DO FOC^LRSPRPT
+24 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
End DoDot:1
+25 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+26 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+27 DO END
+28 QUIT
FOC ;Final Office Copy
+1 WRITE !
+2 KILL DIR
+3 SET LRFOC=0
+4 SET DIR(0)="Y"
SET DIR("A")="Is this a final office copy"
+5 SET DIR("B")="YES"
+6 SET DIR("?",1)="SNOMED codes no longer appear on the report. The final"
+7 SET DIR("?",1)=DIR("?",1)_" office copy prints"
+8 SET DIR("?")="these codes on a separate page. Enter 'Yes' to include "
+9 SET DIR("?")=DIR("?")_"this page."
+10 DO ^DIR
+11 IF Y
SET LRFOC=1
+12 QUIT
CONT ;
+1 KILL DIR
SET DIR(0)="E"
+2 DO ^DIR
WRITE !
+3 IF $DATA(DTOUT)!(X[U)
SET LR("Q")=1
+4 QUIT
END DO V^LRU
+1 KILL LRSF515
+2 QUIT
