LRAPF ;DALOI/STAFF - CY/EM/SP RPT ;11/14/11 13:04
;;5.2;LAB SERVICE;**173,201,248,259,350**;Sep 27, 1994;Build 230
;
; 23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
;
; From LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
I $D(LR("F")),IOST?1"C".E D Q:LR("Q")
. K DIR S DIR(0)="E"
. D ^DIR W !
. S:$D(DTOUT)!(X[U) LR("Q")=1
;
W:($D(LR("F"))) @IOF
S LRQ=LRQ+1
;
; Print printing and reporting facility
I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D
. N A
. D PFAC^LRRP1(DUZ(2),0,1,.A)
. S A=0
. F S A=$O(A(A)) Q:'A W !,A(A)
;
I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
. N B,LRX
. S LRX=+$G(^LR(LRDFN,LRSS,LRI,"RF"))
. I LRX<1 Q
. D RL^LRRP1(LRX,1,.B)
. W ! S B=0
. F S B=$O(B(B)) Q:'B W !,B(B)
;
D W
W !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
D:LRQ>1 P
D W
Q
;
;
F ; from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
Q:LR("Q")
I IOSL'>66 F Q:$Y>(IOSL-11) W !
D W W !,$S('$D(LR("W")):"",1:"See signed copy in chart")
W ?57,"(",$S($D(LRO):"End of report",1:"See next page"),")"
W !,$G(LRPMD),?52,LRW(9),?55,"| Date ",$G(LRRC)
D W
W !,LRP,?50,$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
W !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
I AGE W $S($G(VADM(6))'="":" AGE AT DEATH: ",1:" AGE: "),AGE
W " LOC:",$E(LRLLOC,1,20)
W ! W:LRADM'="" "ADM:",$P(LRADM,"@")
W:LRADX'="" ?17,"DX:",$E(LRADX,1,26)
W ?46,"PCP: "
W:LRPRAC ?51,$E(LRPRAC(1),1,28)
Q
;
;
P ;
; Handle printing footer after printing prior cases on end of report and LRI now null.
I $G(LRI)<1 N LRI S LRI=+$P($G(LRAP),"^",2)
;
D:LRQ>1 W
;
S ADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
S LENG1=$L(LRQ(1)),LENG2=$L(ADESC),LNSPCE=IOM-LENG2-14
S:LENG1>LNSPCE LRQ(1)=$E(LRQ(1),1,LNSPCE)
;
W !?30,"PATHOLOGY REPORT",!
;
I '$G(^LR(LRDFN,LRSS,+LRI,"RF")) W "Laboratory: ",LRQ(1)
W ?(IOM-LENG2-1),ADESC
;
K ADESC,LENG1,LENG2,LNSPCE
Q
;
;
W ;
W !,LR("%")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPF 2041 printed Dec 13, 2024@02:07:23 Page 2
LRAPF ;DALOI/STAFF - CY/EM/SP RPT ;11/14/11 13:04
+1 ;;5.2;LAB SERVICE;**173,201,248,259,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; 23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
+4 ;
+5 ; From LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
+6 IF $DATA(LR("F"))
IF IOST?1"C".E
Begin DoDot:1
+7 KILL DIR
SET DIR(0)="E"
+8 DO ^DIR
WRITE !
+9 if $DATA(DTOUT)!(X[U)
SET LR("Q")=1
End DoDot:1
if LR("Q")
QUIT
+10 ;
+11 if ($DATA(LR("F")))
WRITE @IOF
+12 SET LRQ=LRQ+1
+13 ;
+14 ; Print printing and reporting facility
+15 IF LRQ=1
IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
Begin DoDot:1
+16 NEW A
+17 DO PFAC^LRRP1(DUZ(2),0,1,.A)
+18 SET A=0
+19 FOR
SET A=$ORDER(A(A))
if 'A
QUIT
WRITE !,A(A)
End DoDot:1
+20 ;
+21 IF LRQ=1
IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
Begin DoDot:1
+22 NEW B,LRX
+23 SET LRX=+$GET(^LR(LRDFN,LRSS,LRI,"RF"))
+24 IF LRX<1
QUIT
+25 DO RL^LRRP1(LRX,1,.B)
+26 WRITE !
SET B=0
+27 FOR
SET B=$ORDER(B(B))
if 'B
QUIT
WRITE !,B(B)
End DoDot:1
+28 ;
+29 DO W
+30 WRITE !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
+31 if LRQ>1
DO P
+32 DO W
+33 QUIT
+34 ;
+35 ;
F ; from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
+1 if LR("Q")
QUIT
+2 IF IOSL'>66
FOR
if $Y>(IOSL-11)
QUIT
WRITE !
+3 DO W
WRITE !,$SELECT('$DATA(LR("W")):"",1:"See signed copy in chart")
+4 WRITE ?57,"(",$SELECT($DATA(LRO):"End of report",1:"See next page"),")"
+5 WRITE !,$GET(LRPMD),?52,LRW(9),?55,"| Date ",$GET(LRRC)
+6 DO W
+7 WRITE !,LRP,?50,$SELECT('$DATA(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
+8 WRITE !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
+9 IF AGE
WRITE $SELECT($GET(VADM(6))'="":" AGE AT DEATH: ",1:" AGE: "),AGE
+10 WRITE " LOC:",$EXTRACT(LRLLOC,1,20)
+11 WRITE !
if LRADM'=""
WRITE "ADM:",$PIECE(LRADM,"@")
+12 if LRADX'=""
WRITE ?17,"DX:",$EXTRACT(LRADX,1,26)
+13 WRITE ?46,"PCP: "
+14 if LRPRAC
WRITE ?51,$EXTRACT(LRPRAC(1),1,28)
+15 QUIT
+16 ;
+17 ;
P ;
+1 ; Handle printing footer after printing prior cases on end of report and LRI now null.
+2 IF $GET(LRI)<1
NEW LRI
SET LRI=+$PIECE($GET(LRAP),"^",2)
+3 ;
+4 if LRQ>1
DO W
+5 ;
+6 SET ADESC="Accession No. "_$SELECT(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
+7 SET LENG1=$LENGTH(LRQ(1))
SET LENG2=$LENGTH(ADESC)
SET LNSPCE=IOM-LENG2-14
+8 if LENG1>LNSPCE
SET LRQ(1)=$EXTRACT(LRQ(1),1,LNSPCE)
+9 ;
+10 WRITE !?30,"PATHOLOGY REPORT",!
+11 ;
+12 IF '$GET(^LR(LRDFN,LRSS,+LRI,"RF"))
WRITE "Laboratory: ",LRQ(1)
+13 WRITE ?(IOM-LENG2-1),ADESC
+14 ;
+15 KILL ADESC,LENG1,LENG2,LNSPCE
+16 QUIT
+17 ;
+18 ;
W ;
+1 WRITE !,LR("%")
+2 QUIT
