| 1 | LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ;10/18/01
|
|---|
| 2 | ;;5.2;LAB SERVICE;**1,259**;Sep 27, 1994
|
|---|
| 3 | ;
|
|---|
| 4 | S:'$D(LRSF515) LRSF515=0
|
|---|
| 5 | S A=0 F S A=$O(^LR(LRDFN,"AY",A)) Q:'A!(LR("Q")) D
|
|---|
| 6 | .S C=0 F F=0:1 S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C!(LR("Q")) D
|
|---|
| 7 | ..S X=^LR(LRDFN,"AY",A,5,C,0)
|
|---|
| 8 | ..S T=+^LR(LRDFN,"AY",A,0)
|
|---|
| 9 | ..S T(1)=$S($D(^LAB(61,T,0)):$P(^(0),"^"),1:"")
|
|---|
| 10 | ..D SP
|
|---|
| 11 | Q:LR("Q")
|
|---|
| 12 | W !
|
|---|
| 13 | Q:LRSF515 ;Don't print diagnosis codes on the SF515
|
|---|
| 14 | S A=0 F S A=$O(^LR(LRDFN,80,A)) Q:'A!(LR("Q")) D
|
|---|
| 15 | .D:$Y>(IOSL-6) FF Q:LR("Q")
|
|---|
| 16 | .Q:LR("Q")
|
|---|
| 17 | .S X=+^LR(LRDFN,80,A,0),X=^ICD9(X,0)
|
|---|
| 18 | .W !,"ICD code: ",$P(X,"^"),?20
|
|---|
| 19 | .S X=$P(X,"^",3) D:LRS(5) C^LRUA W X
|
|---|
| 20 | Q
|
|---|
| 21 | SP S Y=$P(X,"^",2),E=$P(X,"^",3),X=$P(X,"^")_":"
|
|---|
| 22 | S A1=$P($P(LRAU("S"),X,2),";",1) D D^LRU S T(2)=Y
|
|---|
| 23 | I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q")
|
|---|
| 24 | I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q")
|
|---|
| 25 | Q:LR("Q")
|
|---|
| 26 | W:'F !!,T(1)
|
|---|
| 27 | W !,A1," ",E," Date: ",T(2)
|
|---|
| 28 | D E
|
|---|
| 29 | S B=0 F LRZ=0:1 S B=$O(^LR(LRDFN,"AY",A,5,C,1,B)) Q:'B!(LR("Q")) D
|
|---|
| 30 | .I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q")
|
|---|
| 31 | .I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q")
|
|---|
| 32 | .Q:LR("Q")
|
|---|
| 33 | .S X=^LR(LRDFN,"AY",A,5,C,1,B,0) D ^DIWP
|
|---|
| 34 | Q:LR("Q") D:LRZ ^DIWW Q
|
|---|
| 35 | E K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W" Q
|
|---|
| 36 | ;
|
|---|
| 37 | FF D H^LRAPT
|
|---|
| 38 | Q
|
|---|
