- LRAPS2 ;AVAMC/REG - AUTOPSY PRT ;8/11/95 09:36 ;
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- S LR("M")=1,LRSS="AU" D ^LRAPU S X=$S($D(^LRO(69.2,+Y,0)):^(0),1:""),LRAU(3)=$P(X,"^",3),LRAU(4)=$P(X,"^",4)
- R:IOST["C-" !!,"Press RETURN key ",X:DTIME D ZZ I '$P(^LR(LRDFN,"AU"),U,15) W !!,"Report not verified." Q
- I $D(^LR(LRDFN,81)) W !,LRAU(3) S LRV=81 D F I $D(A("M")) K A("M") Q
- I $D(^LR(LRDFN,82)) W !,LRAU(4) S LRV=82 D F I $D(A("M")) K A("M") Q
- Q:'$D(^LR(LRDFN,"AW"))&('$D(^("AY")))&('$D(^("AWI")))
- D M I $D(A("M")) K A("M") Q
- D WT,M I $D(A("M")) K A("M") Q
- D ^LRAPT3,M I $D(A("M")) K A("M") Q
- I $D(^LR(LRDFN,"AY",0)),$P(^LR(LRDFN,"AY",0),"^",4)>0 D HD F O=0:0 S O=$O(^LR(LRDFN,"AY",O)) Q:'O!($D(A("M"))) D:$Y>(IOSL-3) M Q:$D(A("M")) W !,$P(^LAB(61,+^LR(LRDFN,"AY",O,0),0),"^") D D
- I $D(A("M")) K A("M") Q
- K A("M") Q
- F D EX S LR=0 F LRZ=0:1 S LR=$O(^LR(LRDFN,LRV,LR)) Q:'LR D:$Y>(IOSL-3) M Q:$D(A("M")) S X=^LR(LRDFN,LRV,LR,0) D ^DIWP
- Q:$D(A("M")) D:LRZ ^DIWW Q
- EX K ^TMP($J) S DIWR=75,DIWL=3,DIWF="W" Q
- D F LRB=0:0 S LRB=$O(^LR(LRDFN,"AY",O,1,LRB)) Q:'LRB D:$Y>(IOSL-3) M Q:$D(A("M")) W !?5,$P(^LAB(61.4,+^LR(LRDFN,"AY",O,1,LRB,0),0),"^")
- Q:$D(A("M"))
- F LRB=0:0 S LRB=$O(^LR(LRDFN,"AY",O,3,LRB)) Q:'LRB D:$Y>(IOSL-3) M Q:$D(A("M")) W !?5,$P(^LAB(61.3,+^LR(LRDFN,"AY",O,3,LRB,0),0),"^")
- Q:$D(A("M"))
- F LRB=0:0 S LRB=$O(^LR(LRDFN,"AY",O,4,LRB)) Q:'LRB D:$Y>(IOSL-3) M Q:$D(A("M")) W !?5,$P(^LAB(61.5,+^LR(LRDFN,"AY",O,4,LRB,0),0),"^")
- Q:$D(A("M"))
- S M=0 F C=1:1 S M=$O(^LR(LRDFN,"AY",O,2,M)) Q:'M D:$Y>(IOSL-3) M Q:$D(A("M")) W !?5,$P(^LAB(61.1,+^LR(LRDFN,"AY",O,2,M,0),0),"^") D E
- Q
- E S E=0 F F=1:1 S E=$O(^LR(LRDFN,"AY",O,2,M,1,E)) Q:'E W !?7,$P(^LAB(61.2,+^LR(LRDFN,"AY",O,2,M,1,E,0),0),"^")
- Q
- HD W !!,"Organ/tissue:",?33,"SNOMED CODING" Q
- M I IOST["C-" R !,"'^' TO STOP: ",X:DTIME S:'$T X="^" S:X["^" A("M")=1 I X]"",X'["^" W $C(7) G M
- Q:$D(A("M")) D ZZ Q
- WT K B I '$D(^LR(LRDFN,"AW")) W !!?20,"No organ weights entered.",! Q
- I $D(^LR(LRDFN,"AW")) S X=^("AW"),B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99) W !!,"Rt--Lung--Lt Liver Spleen R--Kidney--Lt Brain Body Wt(lb) Ht(in)"
- I $D(B) W !,$J($P(X,"^",3),4),?8,$J($P(X,"^",4),4),?14,$J($P(X,"^",5),5),?21,$J($P(X,"^",6),5),?28,$J($P(X,"^",7),4),?38,$J($P(X,"^",8),4),?45,$J($P(X,"^",10),4),?55,$P(X,"^",2),?68,$P(X,"^")
- W !! W:$D(B) "Heart(gm)" I $D(^LR(LRDFN,"AV")) S X=^("AV"),B(2)=$P(X,"^",7,99) W ?12,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)"
- W ! W:$D(B(9)) $J(B(9),5) I $D(B(2)) W ?12,$J($P(X,"^"),4),?20,$J($P(X,"^",2),4),?28,$J($P(X,"^",3),4),?36,$J($P(X,"^",4),4),?44,$J($P(X,"^",5),4),?52,$J($P(X,"^",6),4)
- I $D(B(2)) W !!,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal",!?14,$J($P(B(2),"^",2),4),?25,$J($P(B(2),"^"),4),?33,$J($P(B(2),"^",3),4),?45,$J($P(B(2),"^",4),4)
- I $D(B(1)) F B=1:1:8 I $P(B(1),"^",B) S X="25."_B W !,$P(^DD(63,X,0),"^"),": ",$P(B(1),"^",B)
- I $D(^LR(LRDFN,"AWI")) S Y=^("AWI") F B=1:1:5 I $P(Y,"^",B) S X=$S(B=1:25.9,1:25.9_(B-1)) W !,$P(^DD(63,X,0),"^"),": ",$P(Y,"^",B)
- Q
- ZZ W @IOF,"Acc #",?10,"Date/time Died",?32,"Age",?40,"AUTOPSY",?52,"Date/time of Autopsy"
- S X=^LR(LRDFN,"AU"),LRLLOC=$P(X,"^",8) S DA=LRDFN D D^LRAUAW S Y=LR(63,12) D D^LRU W !,$P(X,"^",6)," ",Y,?26,$J($P(X,"^",9),3),?35,LRP S Y=+X D D^LRU W:Y'[1700 ?52,Y
- W ! F X(1)=7,10 S Y=$P(X,"^",X(1)),Y=$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:Y) W:Y]"" $S(X(1)=7:"Resident:",1:" Senior:"),Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPS2 3446 printed Jan 18, 2025@03:08:56 Page 2
- LRAPS2 ;AVAMC/REG - AUTOPSY PRT ;8/11/95 09:36 ;
- +1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +2 SET LR("M")=1
- SET LRSS="AU"
- DO ^LRAPU
- SET X=$SELECT($DATA(^LRO(69.2,+Y,0)):^(0),1:"")
- SET LRAU(3)=$PIECE(X,"^",3)
- SET LRAU(4)=$PIECE(X,"^",4)
- +3 if IOST["C-"
- READ !!,"Press RETURN key ",X:DTIME
- DO ZZ
- IF '$PIECE(^LR(LRDFN,"AU"),U,15)
- WRITE !!,"Report not verified."
- QUIT
- +4 IF $DATA(^LR(LRDFN,81))
- WRITE !,LRAU(3)
- SET LRV=81
- DO F
- IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +5 IF $DATA(^LR(LRDFN,82))
- WRITE !,LRAU(4)
- SET LRV=82
- DO F
- IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +6 if '$DATA(^LR(LRDFN,"AW"))&('$DATA(^("AY")))&('$DATA(^("AWI")))
- QUIT
- +7 DO M
- IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +8 DO WT
- DO M
- IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +9 DO ^LRAPT3
- DO M
- IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +10 IF $DATA(^LR(LRDFN,"AY",0))
- IF $PIECE(^LR(LRDFN,"AY",0),"^",4)>0
- DO HD
- FOR O=0:0
- SET O=$ORDER(^LR(LRDFN,"AY",O))
- if 'O!($DATA(A("M")))
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- WRITE !,$PIECE(^LAB(61,+^LR(LRDFN,"AY",O,0),0),"^")
- DO D
- +11 IF $DATA(A("M"))
- KILL A("M")
- QUIT
- +12 KILL A("M")
- QUIT
- F DO EX
- SET LR=0
- FOR LRZ=0:1
- SET LR=$ORDER(^LR(LRDFN,LRV,LR))
- if 'LR
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- SET X=^LR(LRDFN,LRV,LR,0)
- DO ^DIWP
- +1 if $DATA(A("M"))
- QUIT
- if LRZ
- DO ^DIWW
- QUIT
- EX KILL ^TMP($JOB)
- SET DIWR=75
- SET DIWL=3
- SET DIWF="W"
- QUIT
- D FOR LRB=0:0
- SET LRB=$ORDER(^LR(LRDFN,"AY",O,1,LRB))
- if 'LRB
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- WRITE !?5,$PIECE(^LAB(61.4,+^LR(LRDFN,"AY",O,1,LRB,0),0),"^")
- +1 if $DATA(A("M"))
- QUIT
- +2 FOR LRB=0:0
- SET LRB=$ORDER(^LR(LRDFN,"AY",O,3,LRB))
- if 'LRB
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- WRITE !?5,$PIECE(^LAB(61.3,+^LR(LRDFN,"AY",O,3,LRB,0),0),"^")
- +3 if $DATA(A("M"))
- QUIT
- +4 FOR LRB=0:0
- SET LRB=$ORDER(^LR(LRDFN,"AY",O,4,LRB))
- if 'LRB
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- WRITE !?5,$PIECE(^LAB(61.5,+^LR(LRDFN,"AY",O,4,LRB,0),0),"^")
- +5 if $DATA(A("M"))
- QUIT
- +6 SET M=0
- FOR C=1:1
- SET M=$ORDER(^LR(LRDFN,"AY",O,2,M))
- if 'M
- QUIT
- if $Y>(IOSL-3)
- DO M
- if $DATA(A("M"))
- QUIT
- WRITE !?5,$PIECE(^LAB(61.1,+^LR(LRDFN,"AY",O,2,M,0),0),"^")
- DO E
- +7 QUIT
- E SET E=0
- FOR F=1:1
- SET E=$ORDER(^LR(LRDFN,"AY",O,2,M,1,E))
- if 'E
- QUIT
- WRITE !?7,$PIECE(^LAB(61.2,+^LR(LRDFN,"AY",O,2,M,1,E,0),0),"^")
- +1 QUIT
- HD WRITE !!,"Organ/tissue:",?33,"SNOMED CODING"
- QUIT
- M IF IOST["C-"
- READ !,"'^' TO STOP: ",X:DTIME
- if '$TEST
- SET X="^"
- if X["^"
- SET A("M")=1
- IF X]""
- IF X'["^"
- WRITE $CHAR(7)
- GOTO M
- +1 if $DATA(A("M"))
- QUIT
- DO ZZ
- QUIT
- WT KILL B
- IF '$DATA(^LR(LRDFN,"AW"))
- WRITE !!?20,"No organ weights entered.",!
- QUIT
- +1 IF $DATA(^LR(LRDFN,"AW"))
- SET X=^("AW")
- SET B(9)=$PIECE(X,"^",9)
- SET B(1)=$PIECE(X,"^",11,99)
- WRITE !!,"Rt--Lung--Lt Liver Spleen R--Kidney--Lt Brain Body Wt(lb) Ht(in)"
- +2 IF $DATA(B)
- WRITE !,$JUSTIFY($PIECE(X,"^",3),4),?8,$JUSTIFY($PIECE(X,"^",4),4),?14,$JUSTIFY($PIECE(X,"^",5),5),?21,$JUSTIFY($PIECE(X,"^",6),5),?28,$JUSTIFY($PIECE(X,"^",7),4),?38,$JUSTIFY($PIECE(X,"^",8),4),?45,$JUSTIFY(...
- ... $PIECE(X,"^",10),4),?55,$PIECE(X,"^",2),?68,$PIECE(X,"^")
- +3 WRITE !!
- if $DATA(B)
- WRITE "Heart(gm)"
- IF $DATA(^LR(LRDFN,"AV"))
- SET X=^("AV")
- SET B(2)=$PIECE(X,"^",7,99)
- WRITE ?12,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)"
- +4 WRITE !
- if $DATA(B(9))
- WRITE $JUSTIFY(B(9),5)
- IF $DATA(B(2))
- WRITE ?12,$JUSTIFY($PIECE(X,"^"),4),?20,$JUSTIFY($PIECE(X,"^",2),4),?28,$JUSTIFY($PIECE(X,"^",3),4),?36,$JUSTIFY($PIECE(X,"^",4),4),?44,$JUSTIFY($PIECE(X,"^",5),4),?52,$JUSTIFY($PIECE(X,"^",6),4)
- +5 IF $DATA(B(2))
- WRITE !!,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal",!?14,$JUSTIFY($PIECE(B(2),"^",2),4),?25,$JUSTIFY($PIECE(B(2),"^"),4),?33,$JUSTIFY($PIECE(B(2),"^",3),4),?45,$JUSTIFY($PIECE(B(2),"^",4),4)
- +6 IF $DATA(B(1))
- FOR B=1:1:8
- IF $PIECE(B(1),"^",B)
- SET X="25."_B
- WRITE !,$PIECE(^DD(63,X,0),"^"),": ",$PIECE(B(1),"^",B)
- +7 IF $DATA(^LR(LRDFN,"AWI"))
- SET Y=^("AWI")
- FOR B=1:1:5
- IF $PIECE(Y,"^",B)
- SET X=$SELECT(B=1:25.9,1:25.9_(B-1))
- WRITE !,$PIECE(^DD(63,X,0),"^"),": ",$PIECE(Y,"^",B)
- +8 QUIT
- ZZ WRITE @IOF,"Acc #",?10,"Date/time Died",?32,"Age",?40,"AUTOPSY",?52,"Date/time of Autopsy"
- +1 SET X=^LR(LRDFN,"AU")
- SET LRLLOC=$PIECE(X,"^",8)
- SET DA=LRDFN
- DO D^LRAUAW
- SET Y=LR(63,12)
- DO D^LRU
- WRITE !,$PIECE(X,"^",6)," ",Y,?26,$JUSTIFY($PIECE(X,"^",9),3),?35,LRP
- SET Y=+X
- DO D^LRU
- if Y'[1700
- WRITE ?52,Y
- +2 WRITE !
- FOR X(1)=7,10
- SET Y=$PIECE(X,"^",X(1))
- SET Y=$SELECT(Y="":Y,$DATA(^VA(200,Y,0)):$PIECE(^(0),"^"),1:Y)
- if Y]""
- WRITE $SELECT(X(1)=7:"Resident:",1:" Senior:"),Y
- +3 QUIT