- 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
