LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1,259,1030,315,1031,1034**;NOV 1, 1997;Build 188
;
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)
.S LRX=+^LR(LRDFN,80,A,0),LRX=$$ICDDX^ICDEX(LRX,,,"I",1) ; IHS/MSC/MKK - LR*5.2*1034
.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
LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1,259,1030,315,1031,1034**;NOV 1, 1997;Build 188
+2 ;
+3 IF '$DATA(LRSF515)
SET LRSF515=0
+4 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,"AY",A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+5 SET C=0
FOR F=0:1
SET C=$ORDER(^LR(LRDFN,"AY",A,5,C))
IF 'C!(LR("Q"))
QUIT
Begin DoDot:2
+6 SET X=^LR(LRDFN,"AY",A,5,C,0)
+7 SET T=+^LR(LRDFN,"AY",A,0)
+8 SET T(1)=$SELECT($DATA(^LAB(61,T,0)):$PIECE(^(0),"^"),1:"")
+9 DO SP
End DoDot:2
End DoDot:1
+10 IF LR("Q")
QUIT
+11 WRITE !
+12 ;Don't print diagnosis codes on the SF515
IF LRSF515
QUIT
+13 NEW LRX
+14 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,80,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+15 IF $Y>(IOSL-6)
DO FF
IF LR("Q")
QUIT
+16 IF LR("Q")
QUIT
+17 ;S LRX=+^LR(LRDFN,80,A,0),LRX=$$ICDDX^ICDCODE(LRX,,,1)
+18 ; IHS/MSC/MKK - LR*5.2*1034
SET LRX=+^LR(LRDFN,80,A,0)
SET LRX=$$ICDDX^ICDEX(LRX,,,"I",1)
+19 WRITE !,"ICD code: ",$PIECE(LRX,"^",2),?20
+20 SET X=$PIECE(LRX,"^",4)
IF LRS(5)
DO C^LRUA
WRITE X
End DoDot:1
+21 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
