LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ;10/18/01
;;5.2;LAB SERVICE;**1,259,315**;Sep 27, 1994;Build 25
S:'$D(LRSF515) LRSF515=0
S A=0 F S A=$O(^LR(LRDFN,"AY",A)) Q:'A!(LR("Q")) D
.S C=0 F F=0:1 S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C!(LR("Q")) D
..S X=^LR(LRDFN,"AY",A,5,C,0)
..S T=+^LR(LRDFN,"AY",A,0)
..S T(1)=$S($D(^LAB(61,T,0)):$P(^(0),"^"),1:"")
..D SP
Q:LR("Q")
W !
Q:LRSF515 ;Don't print diagnosis codes on the SF515
N LRX
S A=0 F S A=$O(^LR(LRDFN,80,A)) Q:'A!(LR("Q")) D
.D:$Y>(IOSL-6) FF Q:LR("Q")
.Q:LR("Q")
.S LRX=+^LR(LRDFN,80,A,0),LRX=$$ICDDX^ICDCODE(LRX,,,1)
.W !,"ICD code: ",$P(LRX,"^",2),?20
.S X=$P(LRX,"^",4) D:LRS(5) C^LRUA W X
Q
SP S Y=$P(X,"^",2),E=$P(X,"^",3),X=$P(X,"^")_":"
S A1=$P($P(LRAU("S"),X,2),";",1) D D^LRU S T(2)=Y
I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q")
I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q")
Q:LR("Q")
W:'F !!,T(1)
W !,A1," ",E," Date: ",T(2)
D E
S B=0 F LRZ=0:1 S B=$O(^LR(LRDFN,"AY",A,5,C,1,B)) Q:'B!(LR("Q")) D
.I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q")
.I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q")
.Q:LR("Q")
.S X=^LR(LRDFN,"AY",A,5,C,1,B,0) D ^DIWP
Q:LR("Q") D:LRZ ^DIWW Q
E K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W" Q
;
FF D H^LRAPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPT3 1292 printed Nov 22, 2024@17:18:35 Page 2
LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ;10/18/01
+1 ;;5.2;LAB SERVICE;**1,259,315**;Sep 27, 1994;Build 25
+2 if '$DATA(LRSF515)
SET LRSF515=0
+3 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,"AY",A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET C=0
FOR F=0:1
SET C=$ORDER(^LR(LRDFN,"AY",A,5,C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:2
+5 SET X=^LR(LRDFN,"AY",A,5,C,0)
+6 SET T=+^LR(LRDFN,"AY",A,0)
+7 SET T(1)=$SELECT($DATA(^LAB(61,T,0)):$PIECE(^(0),"^"),1:"")
+8 DO SP
End DoDot:2
End DoDot:1
+9 if LR("Q")
QUIT
+10 WRITE !
+11 ;Don't print diagnosis codes on the SF515
if LRSF515
QUIT
+12 NEW LRX
+13 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,80,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+14 if $Y>(IOSL-6)
DO FF
if LR("Q")
QUIT
+15 if LR("Q")
QUIT
+16 SET LRX=+^LR(LRDFN,80,A,0)
SET LRX=$$ICDDX^ICDCODE(LRX,,,1)
+17 WRITE !,"ICD code: ",$PIECE(LRX,"^",2),?20
+18 SET X=$PIECE(LRX,"^",4)
if LRS(5)
DO C^LRUA
WRITE X
End DoDot:1
+19 QUIT
SP SET Y=$PIECE(X,"^",2)
SET E=$PIECE(X,"^",3)
SET X=$PIECE(X,"^")_":"
+1 SET A1=$PIECE($PIECE(LRAU("S"),X,2),";",1)
DO D^LRU
SET T(2)=Y
+2 IF 'LRSF515
if $Y>(IOSL-6)
DO FF
if LR("Q")
QUIT
+3 IF LRSF515
if $Y>(IOSL-12)
DO FT^LRAURPT
DO H^LRAURPT
if LR("Q")
QUIT
+4 if LR("Q")
QUIT
+5 if 'F
WRITE !!,T(1)
+6 WRITE !,A1," ",E," Date: ",T(2)
+7 DO E
+8 SET B=0
FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,"AY",A,5,C,1,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+9 IF 'LRSF515
if $Y>(IOSL-6)
DO FF
if LR("Q")
QUIT
+10 IF LRSF515
if $Y>(IOSL-12)
DO FT^LRAURPT
DO H^LRAURPT
if LR("Q")
QUIT
+11 if LR("Q")
QUIT
+12 SET X=^LR(LRDFN,"AY",A,5,C,1,B,0)
DO ^DIWP
End DoDot:1
+13 if LR("Q")
QUIT
if LRZ
DO ^DIWW
QUIT
E KILL ^UTILITY($JOB)
SET DIWR=IOM-10
SET DIWL=10
SET DIWF="W"
QUIT
+1 ;
FF DO H^LRAPT
+1 QUIT
