LRAUAW ;AVAMC/REG/CKA - AUTOPSY DATA ENTRY ; 7/9/16 10:56pm
;;5.2;LAB SERVICE;**72,115,121,309,473**;Sep 27, 1994;Build 1
;Reference to DIC supported by IA #916
S:'$D(LRMD) LRMD=""
W !!,"Enter Weights & Measurements "
S %=2
D YN^LRU
I %<0 D END^LRAPLG1 Q
S DA=LRDFN,DIE="^LR(",LRSD=LREXP
S DR="11;S LRRC=X;14///"_LRAC_";14.1;S LRLLOC=X;14.5;14.6;S LRSVC=X;12.1;S LRMD=X;13.5:13.8"
I %=1 D SET
DIE W !
D ^DIE
I $D(Y) W $C(7),!!,"All Prompts were not answered <ENTRY DELETED>" K ^LR(LRDFN,"AU"),^("AX") D X^LRAPLG1,END^LRAPLG1 Q
I $D(@(LRPF_DFN_",0)")),$P(^(0),"^",3) S X2=$P(^(0),"^",3),X1=LRSD D ^%DTC S AGE=$S(X>365.24:X\365.25,X>7:X\7_"w",X>0:X_"d",1:""),DR="12.5///"_AGE D ^DIE
S (LRCS,LRC(5))="",LRI=9999999-$P(LRSD,".")
D ^LRUWLF
D:LRCAPA ^LRAPSWK
D OERR^LR7OB63D
Q
DEL ;from LRUDEL
W !,"DATE DIED ",Y
I $D(^LR(LRDFN,"AU")),$P(^("AU"),"^",3) W $C(7)," Cannot delete a completed autopsy." Q
L +^LR(LRDFN,"AU"):1
I '$T W !!?10,"Someone else is editing this entry ",!,$C(7) L -^LR(LRDFN,"AU") Q
W " OK to DELETE "
S %=2
D YN^LRU
Q:%'=1
D ACC^LR7OB1(LRAA,LRAD,LRAN,"OC") ;Cancel order
K ^LR(LRDFN,"AU"),^("AV"),^("AW"),^("AY"),^(33),^(80),^(81),^(82)
F A=0:0 S A=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A)) Q:'A K ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
K ^LRO(68,LRAA,1,LRAD,1,"E",+LRRC,LRAN)
D X^LRAPLG1
Q
SET S DR=DR_";16:24;26:31;25;31.1:31.4;25.1:25.9"
Q
D ;get date died- called by DD(63,11,0),LRAPED,LRAPBK,LRAPS2,LRAPT2,
; LRAPAUSR,LRAPPF1,LRAPAUL,LRAPLG2
S A=^LR(DA,0),B=+$P(A,U,2),C=+$P(A,U,3),A=^DIC(B,0,"GL")
S LR(63,12)=$S($D(@(A_C_",.35)")):+^(.35),1:"")
S LR(63,.02)=$P(^DIC(B,0),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAUAW 1754 printed Oct 16, 2024@18:10:25 Page 2
LRAUAW ;AVAMC/REG/CKA - AUTOPSY DATA ENTRY ; 7/9/16 10:56pm
+1 ;;5.2;LAB SERVICE;**72,115,121,309,473**;Sep 27, 1994;Build 1
+2 ;Reference to DIC supported by IA #916
+3 if '$DATA(LRMD)
SET LRMD=""
+4 WRITE !!,"Enter Weights & Measurements "
+5 SET %=2
+6 DO YN^LRU
+7 IF %<0
DO END^LRAPLG1
QUIT
+8 SET DA=LRDFN
SET DIE="^LR("
SET LRSD=LREXP
+9 SET DR="11;S LRRC=X;14///"_LRAC_";14.1;S LRLLOC=X;14.5;14.6;S LRSVC=X;12.1;S LRMD=X;13.5:13.8"
+10 IF %=1
DO SET
DIE WRITE !
+1 DO ^DIE
+2 IF $DATA(Y)
WRITE $CHAR(7),!!,"All Prompts were not answered <ENTRY DELETED>"
KILL ^LR(LRDFN,"AU"),^("AX")
DO X^LRAPLG1
DO END^LRAPLG1
QUIT
+3 IF $DATA(@(LRPF_DFN_",0)"))
IF $PIECE(^(0),"^",3)
SET X2=$PIECE(^(0),"^",3)
SET X1=LRSD
DO ^%DTC
SET AGE=$SELECT(X>365.24:X\365.25,X>7:X\7_"w",X>0:X_"d",1:"")
SET DR="12.5///"_AGE
DO ^DIE
+4 SET (LRCS,LRC(5))=""
SET LRI=9999999-$PIECE(LRSD,".")
+5 DO ^LRUWLF
+6 if LRCAPA
DO ^LRAPSWK
+7 DO OERR^LR7OB63D
+8 QUIT
DEL ;from LRUDEL
+1 WRITE !,"DATE DIED ",Y
+2 IF $DATA(^LR(LRDFN,"AU"))
IF $PIECE(^("AU"),"^",3)
WRITE $CHAR(7)," Cannot delete a completed autopsy."
QUIT
+3 LOCK +^LR(LRDFN,"AU"):1
+4 IF '$TEST
WRITE !!?10,"Someone else is editing this entry ",!,$CHAR(7)
LOCK -^LR(LRDFN,"AU")
QUIT
+5 WRITE " OK to DELETE "
+6 SET %=2
+7 DO YN^LRU
+8 if %'=1
QUIT
+9 ;Cancel order
DO ACC^LR7OB1(LRAA,LRAD,LRAN,"OC")
+10 KILL ^LR(LRDFN,"AU"),^("AV"),^("AW"),^("AY"),^(33),^(80),^(81),^(82)
+11 FOR A=0:0
SET A=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,A))
if 'A
QUIT
KILL ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_A)
+12 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
+13 KILL ^LRO(68,LRAA,1,LRAD,1,"E",+LRRC,LRAN)
+14 DO X^LRAPLG1
+15 QUIT
SET SET DR=DR_";16:24;26:31;25;31.1:31.4;25.1:25.9"
+1 QUIT
D ;get date died- called by DD(63,11,0),LRAPED,LRAPBK,LRAPS2,LRAPT2,
+1 ; LRAPAUSR,LRAPPF1,LRAPAUL,LRAPLG2
+2 SET A=^LR(DA,0)
SET B=+$PIECE(A,U,2)
SET C=+$PIECE(A,U,3)
SET A=^DIC(B,0,"GL")
+3 SET LR(63,12)=$SELECT($DATA(@(A_C_",.35)")):+^(.35),1:"")
+4 SET LR(63,.02)=$PIECE(^DIC(B,0),U)
+5 QUIT
