LRSPRPT ;DALOI/STAFF - CY/EM/SP PATIENT RPT ; 30 Aug 2016 5:20 PM
;;5.2;LAB SERVICE;**1,72,248,259,317,350,416,464**;Sep 27, 1994;Build 12
;
W !!?20,LRO(68)," FINAL PATIENT REPORTS"
K LRSAV,LRAP,LRS(99)
D EN2^LRUA
G END^LRSPRPT1:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
GETP ;
D EN1^LRUPS Q:LRAN=-1
G:$D(^LRO(69.2,LRAA,2,LRAN,0)) GETP
D LOCK^DILF("^LRO(69.2,LRAA,2)")
I '$T D G GETP
. N MSG
. S MSG(1)="The final reports queue is in use by another person.",MSG(1,"F")="!!"
. S MSG(2)="You will need to add this accession to the queue later."
. D EN^DDIOL(.MSG)
S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI
S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
L -^LRO(69.2,LRAA,2)
G GETP
;
;
CH ;
S LRAPX(1)=2 D EN^LRSPRPT2 Q:$G(%)<1
W !!,"Save final report list for reprinting "
S %=2 D YN^LRU S:%=1 LRSAV=1
; Variable LR("DVD") is used to divide reports displayed in the browser
K LR("DVD")
S $P(LR("DVD"),"|",IOM)=""
DEV ; from LRAPMOD
W !
S %ZIS="Q" D ^%ZIS
I POP W ! D END Q
I $D(IO("Q")) D Q
. N ZTDESC,ZTRTN,ZTSAVE,ZTSK
. S ZTDESC="ANAT PATH FINAL REPORT"
. S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPRPT"
. D ^%ZTLOAD,HOME^%ZIS
. D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
. D END
;
QUE ;
U IO
N LRFFF
; LRSF515=1 means generating an SF515
S:'$D(LRSF515) LRSF515=0
S:'$D(LRFOC) LRFOC=0
S:'$D(LRQUIT) LRQUIT=0
S LRFFF=1 ;Flag to perform final form feed
I LRFOC S LRFFF=0 ;If final office copy, don't perform final form feed
S LR(.21)=+$G(^LRO(69.2,LRAA,.2)),LR("DIWF")="W"
S LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1) S:LRA="" LRA=1
D L^LRU,S^LRU,L1^LRU,SET^LRUA
;
PSGL ; Single Report
I $D(LRAP) D G LST
. S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2)
. I +$G(LRPTR) D Q
. . D MAIN^LRAPTIUP(LRPTR,0)
. . S LRFFF=0 ;Don't do final form feed. It's done by LRAPTIUP.
. . I LRQUIT S LR("Q")=1 Q
. . K LRAP S LR("F")=1
. . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
. . Q:LR("Q")
. . I 'LRFOC S LR("Q")=1 Q
. . D FOC
. . I LRQUIT S LR("Q")=1 Q
. . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
. W:IOST?1"C-".E @IOF
. D EN
. K LRAP
. I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
. Q:LR("Q")
. I 'LRFOC S LR("Q")=1 Q
. W !
. W:IOST?1"P-".E @IOF
. D FOC
. I LRQUIT S LR("Q")=1 Q
. I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
;
PQUE ;Report from queue
S LRAN=0
F S LRAN=$O(^LRO(69.2,LRAA,2,LRAN)) Q:'LRAN!(LR("Q")) D
. S LRQUIT=0
. I 'LRFOC S LRFFF=1
. K LR("F")
. S X=^LRO(69.2,LRAA,2,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2)
. D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
. I +$G(LRPTR) D Q
. . D MAIN^LRAPTIUP(LRPTR,0)
. . S LRFFF=0
. . W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
. . K LRPTR
. . I LRQUIT S LR("Q")=1 Q
. . S LR("F")=1
. . I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
. . Q:LR("Q")!('LRFOC)
. . D FOC
. . W:IOST["BROWSER" !!,LR("DVD")
. . I LRQUIT S LR("Q")=1 Q
. . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
. W:IOST?1"C-".E @IOF
. D EN
. W:IOST?1"P-".E @IOF
. W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
. I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
. Q:LR("Q")
. Q:'LRFOC
. W !
. D FOC
. W:IOST["BROWSER" !!,LR("DVD")
. I LRQUIT S LR("Q")=1 Q
. I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
S LRFFF=0
;
LST ;
K LRRMD,LRPMD,LRAP
K:'$D(LRSAV) ^LRO(69.2,LRAA,2)
S ^LRO(69.2,LRAA,2,0)="^69.23A^^0"
K LRSAV,LRV,LRW,LRZ
I IOST?1"P-".E W:LRFFF @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
D END
Q
;
;
W ;
W !,LR("%")
Q
;
;
F ;
; N A,DIWF,DIWL,DIWR
D E
S A=0,DIWF=$TR(DIWF,"W","")
F S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A S X=^LR(LRDFN,LRSS,LRI,LRV,A,0) D:X["|TOP|" TOP D ^DIWP
S A=0
F S A=$O(^UTILITY($J,"W",DIWL,A)) Q:'A D:$Y>(IOSL-11) F^LRAPF,^LRAPF Q:LR("Q") W !,^UTILITY($J,"W",DIWL,A,0)
I $Y<(IOSL-11) W !
K ^UTILITY($J,"W")
Q
;
;
E ;
K ^UTILITY($J,"W")
S DIWR=IOM-5,DIWL=5,DIWF=""
;
; Set gross description field to value from file #69.2
;I LRV=1 S DIWF=LR("DIWF")
S DIWF=LR("DIWF")
;
Q
;
;
EN ; from LRSPT
; Moved to LRSPRPTA due to size limits on routine
D EN^LRSPRPTA
Q
;
;
S ;
S Y=+X,X=$P(X,U,2) D D^LRU
W !?3,"Date: ",Y
I $D(LR("R")),'X W " not verified" Q
D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
D:$P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) SUPA
D E S B=0
F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B)) Q:'B!(LR("Q")) D
. D:$Y>(IOSL-14) F^LRAPF,^LRAPF Q:LR("Q")
. ;S DIWF="W" ;LR*5.2*464
. S DIWF="WN" ;LR*5.2*464
. S X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0) D ^DIWP Q:LR("Q")
Q:LR("Q")
D:LRZ ^DIWW
Q
;
;
SGL ; Print Single Report
N LRPTR
S LRAPX(1)=""
D EN1^LRUPS Q:LRAN=-1
I '$P(^LR(LRDFN,LRSS,LRI,0),"^",11) D G SGL
. W $C(7)," Sorry, report not verified.",!
D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
S LRAP=LRDFN_"^"_LRI,LRSAV=1
D EN2^LRUA
G DEV
;
;
A ;
S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A!(LR("Q")) D
. D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
. W !,$P(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")
Q
;
;
TOP ;
S Z=$P(X,"|TOP|",1)_$P(X,"|TOP|",2) D F^LRAPF,^LRAPF S X=Z
Q
;
;
SUPA ; Print supplementary report audit information
W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
W !,"(Added/Last modified: "
S (A,B)=0 F S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q")) D
. S B=A
Q:LR("Q")
Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))
S A=^(0),Y=+A,LRSGN=" typed by ",A=$P(A,"^",2)
I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3) D
. S A=^(0),LRSGN=" signed by ",A2=$P(A,"^",3),Y=$P(A,"^",4)
. S A=A2
S A=$S($D(^VA(200,A,0)):$P(^(0),"^"),1:A)
; If supp rpt is released, display 'signed by' instead of 'typed by'
D D^LRU W Y,LRSGN,A,")"
; If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3) W !,?25,"**-* NOT VERIFIED *-**"
D:$D(LRQ(9)) SUPM
Q
;
;
SUPM ; Print previous versions of supplementary reports
; This is used by menu option 'Print path modifications [LRAPMOD]'
;
S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q")) D
. S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)
. D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
. S Y=+LRT,Y2=" modified: ",X=$P(LRT,"^",2),LRSGN=" typed by "
. ; If supp rpt is released, display 'signed by' instead of 'typed by'
. I $P(LRT,"^",3) S LRSGN=" signed by ",X=$P(LRT,"^",3),Y=$P(LRT,"^",4),Y2=" released: "
. S X=$S($D(^VA(200,X,0)):$P(^(0),"^"),1:X)
. D D^LRU W !,"Date ",Y2,Y,LRSGN,X
. K ^UTILITY($J)
. S DIWR=IOM-5,DIWL=5,DIWF="W"
. S B=0
. F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B)) Q:'B!(LR("Q")) D
. . S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)
. . D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
. . S X=LRT D ^DIWP
. Q:LR("Q") D:LRZ ^DIWW
Q:LR("Q")
W !?13,"==========Text below appears on final report=========="
Q
;
;
CONT ;
K DIR S DIR(0)="E"
D ^DIR W !
S:$D(DTOUT)!(X[U) LR("Q")=1
Q
;
;
FOC ; Print final office copy page (SNOMEDS)
N LRADC,LRCTR
I '$D(LRAP) D
. D:LRSS'="AU" ^LRUA
. I LRSS="AU" S X=^LR(LRDFN,0) D ^LRUP
I LRSS="AU" D
. S LRADC=$E($P(^LR(LRDFN,LRSS),"^"),1,3)_"0000"
. S:+$G(LRDPF)=2 LRDEM("DTH")=$P(VADM(6),"^",2)
. ; Get DATE DIED from Referral File for Referral Patients
. S:+$G(LRDPF)'=2 LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)
. S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
. S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
. S LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)
I LRSS'="AU" D
. S LRADC=$E($P(^LR(LRDFN,LRSS,LRI,0),"^",10),1,3)_"0000"
. S LRDEM("PRO")=LRMD
S LRDEM("PNM")=LRP,LRDEM("SSN")=SSN
S LRDEM("SEX")=SEX,LRDEM("AGE")=AGE,LRDEM("DOB")=DOB
D INIT^LRAPSNMD(LRDFN,LRSS,$G(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)
Q
;
;
END ;
D V^LRU
K LRSF515
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPT 7897 printed Apr 09, 2024@21:20:13 Page 2
LRSPRPT ;DALOI/STAFF - CY/EM/SP PATIENT RPT ; 30 Aug 2016 5:20 PM
+1 ;;5.2;LAB SERVICE;**1,72,248,259,317,350,416,464**;Sep 27, 1994;Build 12
+2 ;
+3 WRITE !!?20,LRO(68)," FINAL PATIENT REPORTS"
+4 KILL LRSAV,LRAP,LRS(99)
+5 DO EN2^LRUA
+6 if LRAPX=2
GOTO END^LRSPRPT1
if LRAPX=3
GOTO SGL
if LRAPX=4
GOTO CH
GETP ;
+1 DO EN1^LRUPS
if LRAN=-1
QUIT
+2 if $DATA(^LRO(69.2,LRAA,2,LRAN,0))
GOTO GETP
+3 DO LOCK^DILF("^LRO(69.2,LRAA,2)")
+4 IF '$TEST
Begin DoDot:1
+5 NEW MSG
+6 SET MSG(1)="The final reports queue is in use by another person."
SET MSG(1,"F")="!!"
+7 SET MSG(2)="You will need to add this accession to the queue later."
+8 DO EN^DDIOL(.MSG)
End DoDot:1
GOTO GETP
+9 SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI
+10 SET X=^LRO(69.2,LRAA,2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+11 LOCK -^LRO(69.2,LRAA,2)
+12 GOTO GETP
+13 ;
+14 ;
CH ;
+1 SET LRAPX(1)=2
DO EN^LRSPRPT2
if $GET(%)<1
QUIT
+2 WRITE !!,"Save final report list for reprinting "
+3 SET %=2
DO YN^LRU
if %=1
SET LRSAV=1
+4 ; Variable LR("DVD") is used to divide reports displayed in the browser
+5 KILL LR("DVD")
+6 SET $PIECE(LR("DVD"),"|",IOM)=""
DEV ; from LRAPMOD
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
DO END
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+6 SET ZTDESC="ANAT PATH FINAL REPORT"
+7 SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRSPRPT"
+8 DO ^%ZTLOAD
DO HOME^%ZIS
+9 DO EN^DDIOL("Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
+10 DO END
End DoDot:1
QUIT
+11 ;
QUE ;
+1 USE IO
+2 NEW LRFFF
+3 ; LRSF515=1 means generating an SF515
+4 if '$DATA(LRSF515)
SET LRSF515=0
+5 if '$DATA(LRFOC)
SET LRFOC=0
+6 if '$DATA(LRQUIT)
SET LRQUIT=0
+7 ;Flag to perform final form feed
SET LRFFF=1
+8 ;If final office copy, don't perform final form feed
IF LRFOC
SET LRFFF=0
+9 SET LR(.21)=+$GET(^LRO(69.2,LRAA,.2))
SET LR("DIWF")="W"
+10 SET LRA=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,9),1:1)
if LRA=""
SET LRA=1
+11 DO L^LRU
DO S^LRU
DO L1^LRU
DO SET^LRUA
+12 ;
PSGL ; Single Report
+1 IF $DATA(LRAP)
Begin DoDot:1
+2 SET LRDFN=$PIECE(LRAP,"^")
SET LRI=$PIECE(LRAP,"^",2)
+3 IF +$GET(LRPTR)
Begin DoDot:2
+4 DO MAIN^LRAPTIUP(LRPTR,0)
+5 ;Don't do final form feed. It's done by LRAPTIUP.
SET LRFFF=0
+6 IF LRQUIT
SET LR("Q")=1
QUIT
+7 KILL LRAP
SET LR("F")=1
+8 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
+9 if LR("Q")
QUIT
+10 IF 'LRFOC
SET LR("Q")=1
QUIT
+11 DO FOC
+12 IF LRQUIT
SET LR("Q")=1
QUIT
+13 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:2
QUIT
+14 if IOST?1"C-".E
WRITE @IOF
+15 DO EN
+16 KILL LRAP
+17 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
+18 if LR("Q")
QUIT
+19 IF 'LRFOC
SET LR("Q")=1
QUIT
+20 WRITE !
+21 if IOST?1"P-".E
WRITE @IOF
+22 DO FOC
+23 IF LRQUIT
SET LR("Q")=1
QUIT
+24 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:1
GOTO LST
+25 ;
PQUE ;Report from queue
+1 SET LRAN=0
+2 FOR
SET LRAN=$ORDER(^LRO(69.2,LRAA,2,LRAN))
if 'LRAN!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET LRQUIT=0
+4 IF 'LRFOC
SET LRFFF=1
+5 KILL LR("F")
+6 SET X=^LRO(69.2,LRAA,2,LRAN,0)
SET LRDFN=+X
SET LRI=$PIECE(X,"^",2)
+7 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
+8 IF +$GET(LRPTR)
Begin DoDot:2
+9 DO MAIN^LRAPTIUP(LRPTR,0)
+10 SET LRFFF=0
+11 if IOST["BROWSER"&('LRFOC)
WRITE !!,LR("DVD")
+12 KILL LRPTR
+13 IF LRQUIT
SET LR("Q")=1
QUIT
+14 SET LR("F")=1
+15 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+16 if LR("Q")!('LRFOC)
QUIT
+17 DO FOC
+18 if IOST["BROWSER"
WRITE !!,LR("DVD")
+19 IF LRQUIT
SET LR("Q")=1
QUIT
+20 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:2
QUIT
+21 if IOST?1"C-".E
WRITE @IOF
+22 DO EN
+23 if IOST?1"P-".E
WRITE @IOF
+24 if IOST["BROWSER"&('LRFOC)
WRITE !!,LR("DVD")
+25 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+26 if LR("Q")
QUIT
+27 if 'LRFOC
QUIT
+28 WRITE !
+29 DO FOC
+30 if IOST["BROWSER"
WRITE !!,LR("DVD")
+31 IF LRQUIT
SET LR("Q")=1
QUIT
+32 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:1
+33 SET LRFFF=0
+34 ;
LST ;
+1 KILL LRRMD,LRPMD,LRAP
+2 if '$DATA(LRSAV)
KILL ^LRO(69.2,LRAA,2)
+3 SET ^LRO(69.2,LRAA,2,0)="^69.23A^^0"
+4 KILL LRSAV,LRV,LRW,LRZ
+5 IF IOST?1"P-".E
if LRFFF
WRITE @IOF
+6 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+8 DO END
+9 QUIT
+10 ;
+11 ;
W ;
+1 WRITE !,LR("%")
+2 QUIT
+3 ;
+4 ;
F ;
+1 ; N A,DIWF,DIWL,DIWR
+2 DO E
+3 SET A=0
SET DIWF=$TRANSLATE(DIWF,"W","")
+4 FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))
if 'A
QUIT
SET X=^LR(LRDFN,LRSS,LRI,LRV,A,0)
if X["|TOP|"
DO TOP
DO ^DIWP
+5 SET A=0
+6 FOR
SET A=$ORDER(^UTILITY($JOB,"W",DIWL,A))
if 'A
QUIT
if $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
WRITE !,^UTILITY($JOB,"W",DIWL,A,0)
+7 IF $Y<(IOSL-11)
WRITE !
+8 KILL ^UTILITY($JOB,"W")
+9 QUIT
+10 ;
+11 ;
E ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET DIWR=IOM-5
SET DIWL=5
SET DIWF=""
+3 ;
+4 ; Set gross description field to value from file #69.2
+5 ;I LRV=1 S DIWF=LR("DIWF")
+6 SET DIWF=LR("DIWF")
+7 ;
+8 QUIT
+9 ;
+10 ;
EN ; from LRSPT
+1 ; Moved to LRSPRPTA due to size limits on routine
+2 DO EN^LRSPRPTA
+3 QUIT
+4 ;
+5 ;
S ;
+1 SET Y=+X
SET X=$PIECE(X,U,2)
DO D^LRU
+2 WRITE !?3,"Date: ",Y
+3 IF $DATA(LR("R"))
IF 'X
WRITE " not verified"
QUIT
+4 if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+5 if $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4)
DO SUPA
+6 DO E
SET B=0
+7 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+8 if $Y>(IOSL-14)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+9 ;S DIWF="W" ;LR*5.2*464
+10 ;LR*5.2*464
SET DIWF="WN"
+11 SET X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0)
DO ^DIWP
if LR("Q")
QUIT
End DoDot:1
+12 if LR("Q")
QUIT
+13 if LRZ
DO ^DIWW
+14 QUIT
+15 ;
+16 ;
SGL ; Print Single Report
+1 NEW LRPTR
+2 SET LRAPX(1)=""
+3 DO EN1^LRUPS
if LRAN=-1
QUIT
+4 IF '$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)
Begin DoDot:1
+5 WRITE $CHAR(7)," Sorry, report not verified.",!
End DoDot:1
GOTO SGL
+6 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
+7 SET LRAP=LRDFN_"^"_LRI
SET LRSAV=1
+8 DO EN2^LRUA
+9 GOTO DEV
+10 ;
+11 ;
A ;
+1 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+2 if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+3 WRITE !,$PIECE(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")
End DoDot:1
+4 QUIT
+5 ;
+6 ;
TOP ;
+1 SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
DO F^LRAPF
DO ^LRAPF
SET X=Z
+2 QUIT
+3 ;
+4 ;
SUPA ; Print supplementary report audit information
+1 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+2 WRITE !,"(Added/Last modified: "
+3 SET (A,B)=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET B=A
End DoDot:1
+5 if LR("Q")
QUIT
+6 if '$DATA(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))
QUIT
+7 SET A=^(0)
SET Y=+A
SET LRSGN=" typed by "
SET A=$PIECE(A,"^",2)
+8 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3)
Begin DoDot:1
+9 SET A=^(0)
SET LRSGN=" signed by "
SET A2=$PIECE(A,"^",3)
SET Y=$PIECE(A,"^",4)
+10 SET A=A2
End DoDot:1
+11 SET A=$SELECT($DATA(^VA(200,A,0)):$PIECE(^(0),"^"),1:A)
+12 ; If supp rpt is released, display 'signed by' instead of 'typed by'
+13 DO D^LRU
WRITE Y,LRSGN,A,")"
+14 ; If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+15 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3)
WRITE !,?25,"**-* NOT VERIFIED *-**"
+16 if $DATA(LRQ(9))
DO SUPM
+17 QUIT
+18 ;
+19 ;
SUPM ; Print previous versions of supplementary reports
+1 ; This is used by menu option 'Print path modifications [LRAPMOD]'
+2 ;
+3 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)
+5 if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+6 SET Y=+LRT
SET Y2=" modified: "
SET X=$PIECE(LRT,"^",2)
SET LRSGN=" typed by "
+7 ; If supp rpt is released, display 'signed by' instead of 'typed by'
+8 IF $PIECE(LRT,"^",3)
SET LRSGN=" signed by "
SET X=$PIECE(LRT,"^",3)
SET Y=$PIECE(LRT,"^",4)
SET Y2=" released: "
+9 SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),"^"),1:X)
+10 DO D^LRU
WRITE !,"Date ",Y2,Y,LRSGN,X
+11 KILL ^UTILITY($JOB)
+12 SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
+13 SET B=0
+14 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:2
+15 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)
+16 if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+17 SET X=LRT
DO ^DIWP
End DoDot:2
+18 if LR("Q")
QUIT
if LRZ
DO ^DIWW
End DoDot:1
+19 if LR("Q")
QUIT
+20 WRITE !?13,"==========Text below appears on final report=========="
+21 QUIT
+22 ;
+23 ;
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 ;
FOC ; Print final office copy page (SNOMEDS)
+1 NEW LRADC,LRCTR
+2 IF '$DATA(LRAP)
Begin DoDot:1
+3 if LRSS'="AU"
DO ^LRUA
+4 IF LRSS="AU"
SET X=^LR(LRDFN,0)
DO ^LRUP
End DoDot:1
+5 IF LRSS="AU"
Begin DoDot:1
+6 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS),"^"),1,3)_"0000"
+7 if +$GET(LRDPF)=2
SET LRDEM("DTH")=$PIECE(VADM(6),"^",2)
+8 ; Get DATE DIED from Referral File for Referral Patients
+9 if +$GET(LRDPF)'=2
SET LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)
+10 SET LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
+11 SET LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
+12 SET LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)
End DoDot:1
+13 IF LRSS'="AU"
Begin DoDot:1
+14 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",10),1,3)_"0000"
+15 SET LRDEM("PRO")=LRMD
End DoDot:1
+16 SET LRDEM("PNM")=LRP
SET LRDEM("SSN")=SSN
+17 SET LRDEM("SEX")=SEX
SET LRDEM("AGE")=AGE
SET LRDEM("DOB")=DOB
+18 DO INIT^LRAPSNMD(LRDFN,LRSS,$GET(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)
+19 QUIT
+20 ;
+21 ;
END ;
+1 DO V^LRU
+2 KILL LRSF515
+3 QUIT
