- 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
