LRAPFICH ;DALOI/STAFF - MICROFICH PATH REPORTS ;04/10/12 11:58
;;5.2;LAB SERVICE;**72,173,248,259,350**;Sep 27, 1994;Build 230
;
; Final path reports by accession number
D END
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("LR*")="",ZTRTN="QUE^LRAPFICH",ZTREQ="@",ZTIO=ION
. D ^%ZTLOAD
. W:$D(ZTSK) !,"Report Queued to device ",ION
. K ZTIO,ZTSK,IO("Q"),ZTREQ
. D HOME^%ZIS
;
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
. . ;Check for and print unreleased supplementary reports
. . D UNRLSUP
. . I LRFND D WRUNSUP
. 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
;
;
UNRLSUP ;Check for unreleased supp reports and print them
S LRFND=0
I $O(^LR(LRDFN,LRSS,LRI,1.2,0)) D
.S LRV=0 F S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV!(LRFND) D
..I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",2)="" S LRFND=1
Q
;
;
WRUNSUP ;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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPFICH 3116 printed Dec 13, 2024@02:07:24 Page 2
LRAPFICH ;DALOI/STAFF - MICROFICH PATH REPORTS ;04/10/12 11:58
+1 ;;5.2;LAB SERVICE;**72,173,248,259,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; Final path reports by accession number
+4 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)
+13 ;
A ;
+1 READ !,"Start with accession #: ",X:DTIME
if X[U!(X="")
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!,"Enter a number."
GOTO A
+2 SET LR("B")=X
+3 ;
B ;
+1 READ !,"Go to accession #: ",X:DTIME
if X[U!(X="")
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!,"Enter a number."
GOTO B
+2 SET LR("E")=X
IF LR("E")<LR("B")
SET X=LR("B")
SET LR("B")=LR("E")
SET LR("E")=X
+3 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("LR*")=""
SET ZTRTN="QUE^LRAPFICH"
SET ZTREQ="@"
SET ZTIO=ION
+7 DO ^%ZTLOAD
+8 if $DATA(ZTSK)
WRITE !,"Report Queued to device ",ION
+9 KILL ZTIO,ZTSK,IO("Q"),ZTREQ
+10 DO HOME^%ZIS
End DoDot:1
QUIT
+11 ;
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
+19 ;Check for and print unreleased supplementary reports
+20 DO UNRLSUP
+21 IF LRFND
DO WRUNSUP
End DoDot:2
QUIT
+22 if IOST?1"C-".E
WRITE @IOF
+23 DO EN^LRSPRPT
+24 if IOST?1"P-".E
WRITE @IOF
+25 if IOST["BROWSER"
WRITE !!,LR("DVD")
+26 IF LRFOC
DO FOC^LRSPRPT
+27 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
End DoDot:1
+28 DO ^%ZISC
+29 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+30 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+31 DO END
+32 QUIT
+33 ;
+34 ;
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
+13 ;
+14 ;
UNRLSUP ;Check for unreleased supp reports and print them
+1 SET LRFND=0
+2 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))
Begin DoDot:1
+3 SET LRV=0
FOR
SET LRV=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV))
if 'LRV!(LRFND)
QUIT
Begin DoDot:2
+4 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",2)=""
SET LRFND=1
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
+7 ;
WRUNSUP ;W:IOST?1"C-".E @IOF
+1 DO EN^LRSPRPT
+2 ;W:IOST?1"P-".E @IOF
+3 if IOST["BROWSER"
WRITE !!,LR("DVD")
+4 ;I LRFOC D FOC^LRSPRPT
+5 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+6 QUIT
+7 ;
+8 ;
CONT ;
+1 KILL DIR
SET DIR(0)="E"
+2 DO ^DIR
WRITE !
+3 if $DATA(DTOUT)!(X[U)
SET LR("Q")=1
+4 QUIT
+5 ;
+6 ;
END ;
+1 DO V^LRU
+2 KILL LRSF515
+3 QUIT
