- 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 Jan 18, 2025@03:09:13 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