LRAPFICH.m

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 ---LRAPFICH   3116     printed  Feb 18, 2025@23:33:17                                                                                                                                                                                                    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