LRSPRPTA ;DALOI/STAFF - CY/EM/SP PATIENT RPT (cont'd) ;03/21/13 15:29
;;5.2;LAB SERVICE;**350,427,464**;Sep 27, 1994;Build 12
;
; Continuation of LRSPRPT.
;
EN ; from LRSPRPT
; Suppress SNOMED codes except on Preliminary
S LR("SPSM")=$S($G(LRPRE):0,1:1)
S LR(.21)=+$G(^LRO(69.2,+$G(LRAA),.2))
K LRO Q:'$D(^LR(LRDFN,LRSS,LRI,0))
S LRQ=0
D ^LRUA
;
D GETPCP^LRAPUTL(.LRPRAC,LRDFN,LRSS,LRI)
;
D ^LRAPF Q:LR("Q")
S LR("F")=1 W !,"Submitted by: ",LRW(5),?44,"Date obtained: ",LRTK
D:LRA W^LRSPRPT
W !,"Specimen (Received ",LRTK(1),"):" S LRV=.1 D A^LRSPRPT Q:LR("Q")
I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) D
. W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
. W !?19,"*+* REFER TO BOTTOM OF REPORT *+*",!
;
; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
;I $O(^LR(LRDFN,LRSS,LRI,99,0)) W !,"Comment:"
;S LRB=0
;F S LRB=$O(^LR(LRDFN,LRSS,LRI,99,LRB)) Q:'LRB!(LR("Q")) D
;. W !,^LR(LRDFN,LRSS,LRI,99,LRB,0)
;. I $G(LRSF515),$Y>(IOSL-11) D F^LRAPF,^LRAPF
;
S LR("DIWF","X")=$G(LR("DIWF")),LR("DIWF")="N" ;LR*5.S*464
D:LRA W^LRSPRPT W !,"Brief Clinical History:" S LRV=.2 D F^LRSPRPT Q:LR("Q")
D:LRA W^LRSPRPT W !,"Preoperative Diagnosis:" S LRV=.3 D F^LRSPRPT Q:LR("Q")
D:LRA W^LRSPRPT W !,"Operative Findings:" S LRV=.4 D F^LRSPRPT Q:LR("Q")
D:LRA W^LRSPRPT W !,"Postoperative Diagnosis:" S LRV=.5 D F^LRSPRPT Q:LR("Q")
S LR("DIWF")=LR("DIWF","X") K LR("DIWF","X") ;LR*5.2*464
;
;
; Retrieve surgeon/attending
D ATTEND^LRAPBR1(.LRMD)
I LRMD'="" W !?27,"Surgeon/physician: ",LRMD
I LRMD("SR-SURGEON")'="" w !,?28,LRMD("SR-SURGEON")
I LRMD("SR-ATTEND")'="" W !,?26,LRMD("SR-ATTEND")
;I +$G(LRMD("ERR"))=601 W !,?26,$P(LRMD("ERR"),"^",2)
;
I LRA W !,LR("%1")
;
I $Y>(IOSL-14) D Q:LR("Q")
. D F^LRAPF,^LRAPF
E D P^LRAPF
;I $Y>(IOSL-8) D F^LRAPF,^LRAPF Q:LR("Q")
D:LRA W^LRSPRPT
W:LRRC="" !?20,"+*+* REPORT INCOMPLETE *+*+",!
I $Y>(IOSL-11) D F^LRAPF,^LRAPF Q:LR("Q")
;
W !
I LRRMD'="" W ?31,$S(LRSS="SP":"Pathology Resident: ",LRSS="CY":"Screened by: ",LRSS="EM":"Prepared by: ",1:" "),LRRMD
I $O(^LR(LRDFN,LRSS,LRI,1.3,0)) D Q:LR("Q")
. I $Y>(IOSL-11) D F^LRAPF,^LRAPF Q:LR("Q")
. W !,LR(69.2,.13)
. I $P($G(^LR(LRDFN,LRSS,LRI,6,0)),U,4) S LR(0)=6 D ^LRSPRPTM
;
S LR("DIWF")="N" ;LR*5.2*464 Setting default WP flag to NoWrap
S LRV=1.3 D F^LRSPRPT Q:LR("Q")
I $O(^LR(LRDFN,LRSS,LRI,1,0)) D Q:LR("Q")
. I $Y>(IOSL-11) D F^LRAPF,^LRAPF Q:LR("Q")
. W !,LR(69.2,.03)
. I $P($G(^LR(LRDFN,LRSS,LRI,7,0)),U,4) S LR(0)=7 D ^LRSPRPTM
;
S LRV=1,LR("DIWF")="N" D F^LRSPRPT Q:LR("Q") ;LR*5.2*464
I $O(^LR(LRDFN,LRSS,LRI,1.1,0)) D Q:LR("Q")
. I $Y>(IOSL-11) D F^LRAPF,^LRAPF Q:LR("Q")
. W !,LR(69.2,.04)
. I $P($G(^LR(LRDFN,LRSS,LRI,4,0)),"^",4) S LR(0)=4 D ^LRSPRPTM
;
S LRV=1.1 D F^LRSPRPT Q:LR("Q")
I $O(^LR(LRDFN,LRSS,LRI,1.4,0)) D Q:LR("Q")
. I $Y>(IOSL-11) D F^LRAPF,^LRAPF Q:LR("Q")
. W !,LR(69.2,.14)
. I $P($G(^LR(LRDFN,LRSS,LRI,5,0)),U,4) S LR(0)=5 D ^LRSPRPTM
;
S LRV=1.4 D F^LRSPRPT Q:LR("Q")
;
; Supplementary Report
I $O(^LR(LRDFN,LRSS,LRI,1.2,0)) D:LR(.21) F^LRAPF,^LRAPF Q:LR("Q") D
. D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
. W !,"Supplementary Report:"
. S LRV=0 F S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV!(LR("Q")) D
. . S X=^LR(LRDFN,LRSS,LRI,1.2,LRV,0) D S^LRSPRPT
D ^LRSPRPT1 Q:LR("Q")
;
; Print performing laboratory if designated
D PPL
;
; Don't set the final flag and print the footer if prelim
Q:+$G(LRPRE)
S LRO=1 D F^LRAPF
Q
;
;
PPL ; Print any performing laboratories
;
N LRPL,LRJ,LRX
;
D RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRI,0)
I $G(LRPL)<1 Q
;
; Start new page if space on existing page too small to display a significant portion of labs
I $Y>(IOSL-15) D F^LRAPF,^LRAPF Q:LR("Q")
;
W !!,$$REPEAT^XLFSTR("=",IOM)
W !,"Performing Laboratory:",!
S LRJ=0
F S LRJ=$O(LRPL(LRJ)) Q:'LRJ D Q:LR("Q")
. I $Y>(IOSL-12) D F^LRAPF,^LRAPF Q:LR("Q") W !,"Performing Laboratory (cont'd):",!
. W !,LRPL(LRJ)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPTA 4101 printed Apr 09, 2024@21:25:43 Page 2
LRSPRPTA ;DALOI/STAFF - CY/EM/SP PATIENT RPT (cont'd) ;03/21/13 15:29
+1 ;;5.2;LAB SERVICE;**350,427,464**;Sep 27, 1994;Build 12
+2 ;
+3 ; Continuation of LRSPRPT.
+4 ;
EN ; from LRSPRPT
+1 ; Suppress SNOMED codes except on Preliminary
+2 SET LR("SPSM")=$SELECT($GET(LRPRE):0,1:1)
+3 SET LR(.21)=+$GET(^LRO(69.2,+$GET(LRAA),.2))
+4 KILL LRO
if '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
+5 SET LRQ=0
+6 DO ^LRUA
+7 ;
+8 DO GETPCP^LRAPUTL(.LRPRAC,LRDFN,LRSS,LRI)
+9 ;
+10 DO ^LRAPF
if LR("Q")
QUIT
+11 SET LR("F")=1
WRITE !,"Submitted by: ",LRW(5),?44,"Date obtained: ",LRTK
+12 if LRA
DO W^LRSPRPT
+13 WRITE !,"Specimen (Received ",LRTK(1),"):"
SET LRV=.1
DO A^LRSPRPT
if LR("Q")
QUIT
+14 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4)
Begin DoDot:1
+15 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+16 WRITE !?19,"*+* REFER TO BOTTOM OF REPORT *+*",!
End DoDot:1
+17 ;
+18 ; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
+19 ;I $O(^LR(LRDFN,LRSS,LRI,99,0)) W !,"Comment:"
+20 ;S LRB=0
+21 ;F S LRB=$O(^LR(LRDFN,LRSS,LRI,99,LRB)) Q:'LRB!(LR("Q")) D
+22 ;. W !,^LR(LRDFN,LRSS,LRI,99,LRB,0)
+23 ;. I $G(LRSF515),$Y>(IOSL-11) D F^LRAPF,^LRAPF
+24 ;
+25 ;LR*5.S*464
SET LR("DIWF","X")=$GET(LR("DIWF"))
SET LR("DIWF")="N"
+26 if LRA
DO W^LRSPRPT
WRITE !,"Brief Clinical History:"
SET LRV=.2
DO F^LRSPRPT
if LR("Q")
QUIT
+27 if LRA
DO W^LRSPRPT
WRITE !,"Preoperative Diagnosis:"
SET LRV=.3
DO F^LRSPRPT
if LR("Q")
QUIT
+28 if LRA
DO W^LRSPRPT
WRITE !,"Operative Findings:"
SET LRV=.4
DO F^LRSPRPT
if LR("Q")
QUIT
+29 if LRA
DO W^LRSPRPT
WRITE !,"Postoperative Diagnosis:"
SET LRV=.5
DO F^LRSPRPT
if LR("Q")
QUIT
+30 ;LR*5.2*464
SET LR("DIWF")=LR("DIWF","X")
KILL LR("DIWF","X")
+31 ;
+32 ;
+33 ; Retrieve surgeon/attending
+34 DO ATTEND^LRAPBR1(.LRMD)
+35 IF LRMD'=""
WRITE !?27,"Surgeon/physician: ",LRMD
+36 IF LRMD("SR-SURGEON")'=""
WRITE !,?28,LRMD("SR-SURGEON")
+37 IF LRMD("SR-ATTEND")'=""
WRITE !,?26,LRMD("SR-ATTEND")
+38 ;I +$G(LRMD("ERR"))=601 W !,?26,$P(LRMD("ERR"),"^",2)
+39 ;
+40 IF LRA
WRITE !,LR("%1")
+41 ;
+42 IF $Y>(IOSL-14)
Begin DoDot:1
+43 DO F^LRAPF
DO ^LRAPF
End DoDot:1
if LR("Q")
QUIT
+44 IF '$TEST
DO P^LRAPF
+45 ;I $Y>(IOSL-8) D F^LRAPF,^LRAPF Q:LR("Q")
+46 if LRA
DO W^LRSPRPT
+47 if LRRC=""
WRITE !?20,"+*+* REPORT INCOMPLETE *+*+",!
+48 IF $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+49 ;
+50 WRITE !
+51 IF LRRMD'=""
WRITE ?31,$SELECT(LRSS="SP":"Pathology Resident: ",LRSS="CY":"Screened by: ",LRSS="EM":"Prepared by: ",1:" "),LRRMD
+52 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))
Begin DoDot:1
+53 IF $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+54 WRITE !,LR(69.2,.13)
+55 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,6,0)),U,4)
SET LR(0)=6
DO ^LRSPRPTM
End DoDot:1
if LR("Q")
QUIT
+56 ;
+57 ;LR*5.2*464 Setting default WP flag to NoWrap
SET LR("DIWF")="N"
+58 SET LRV=1.3
DO F^LRSPRPT
if LR("Q")
QUIT
+59 IF $ORDER(^LR(LRDFN,LRSS,LRI,1,0))
Begin DoDot:1
+60 IF $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+61 WRITE !,LR(69.2,.03)
+62 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,7,0)),U,4)
SET LR(0)=7
DO ^LRSPRPTM
End DoDot:1
if LR("Q")
QUIT
+63 ;
+64 ;LR*5.2*464
SET LRV=1
SET LR("DIWF")="N"
DO F^LRSPRPT
if LR("Q")
QUIT
+65 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.1,0))
Begin DoDot:1
+66 IF $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+67 WRITE !,LR(69.2,.04)
+68 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,4,0)),"^",4)
SET LR(0)=4
DO ^LRSPRPTM
End DoDot:1
if LR("Q")
QUIT
+69 ;
+70 SET LRV=1.1
DO F^LRSPRPT
if LR("Q")
QUIT
+71 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.4,0))
Begin DoDot:1
+72 IF $Y>(IOSL-11)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+73 WRITE !,LR(69.2,.14)
+74 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,5,0)),U,4)
SET LR(0)=5
DO ^LRSPRPTM
End DoDot:1
if LR("Q")
QUIT
+75 ;
+76 SET LRV=1.4
DO F^LRSPRPT
if LR("Q")
QUIT
+77 ;
+78 ; Supplementary Report
+79 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))
if LR(.21)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
Begin DoDot:1
+80 if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+81 WRITE !,"Supplementary Report:"
+82 SET LRV=0
FOR
SET LRV=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV))
if 'LRV!(LR("Q"))
QUIT
Begin DoDot:2
+83 SET X=^LR(LRDFN,LRSS,LRI,1.2,LRV,0)
DO S^LRSPRPT
End DoDot:2
End DoDot:1
+84 DO ^LRSPRPT1
if LR("Q")
QUIT
+85 ;
+86 ; Print performing laboratory if designated
+87 DO PPL
+88 ;
+89 ; Don't set the final flag and print the footer if prelim
+90 if +$GET(LRPRE)
QUIT
+91 SET LRO=1
DO F^LRAPF
+92 QUIT
+93 ;
+94 ;
PPL ; Print any performing laboratories
+1 ;
+2 NEW LRPL,LRJ,LRX
+3 ;
+4 DO RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRI,0)
+5 IF $GET(LRPL)<1
QUIT
+6 ;
+7 ; Start new page if space on existing page too small to display a significant portion of labs
+8 IF $Y>(IOSL-15)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
+9 ;
+10 WRITE !!,$$REPEAT^XLFSTR("=",IOM)
+11 WRITE !,"Performing Laboratory:",!
+12 SET LRJ=0
+13 FOR
SET LRJ=$ORDER(LRPL(LRJ))
if 'LRJ
QUIT
Begin DoDot:1
+14 IF $Y>(IOSL-12)
DO F^LRAPF
DO ^LRAPF
if LR("Q")
QUIT
WRITE !,"Performing Laboratory (cont'd):",!
+15 WRITE !,LRPL(LRJ)
End DoDot:1
if LR("Q")
QUIT
+16 ;
+17 QUIT
