LRAPQOR3 ;AVAMC/REG - QA AUTOPSY DATA ;9/17/90 07:52
;;5.2;LAB SERVICE;**234,242**;Sep 27, 1994
;15-MAR-1999;WTY;Changes for HIN-1298-42595
;
S (LRA,LRD)="",EXTOT=0,LRSDT=LRSDT(1) K LRC
S A=0 F B=0:0 S A=$O(^DG(405.2,"B",A)) Q:A="" D
.I A["DEATH"!(A="WHILE ASIH") S X=$O(^DG(405.2,"B",A,0)) D
..I X S:A["DEATH" LRC(X)="" S:A["ASIH" LRJ(X)=""
S F=1 F A=LRSDT:0 S A=$O(^LR("AAU",A)) Q:'A!(A>LRLDT) D
.F LRDFN=0:0 S LRDFN=$O(^LR("AAU",A,LRDFN)) Q:'LRDFN D A
Q:LR("Q")
I IOST?1"C".E W !!,"Please hold, calculating Autopsy% ...",!
S F=0 F A=LRSDT:0 S A=$O(^DPT("AEXP1",A)) Q:'A!(A>LRLDT) D
.F DFN=0:0 S DFN=$O(^DPT("AEXP1",A,DFN)) Q:'DFN D
..D P I $D(LRK) S LRD=LRD+1 D Q K LRK
S LRF=1 D H Q:LR("Q")
W !?35,$J(LRD,7),?45,$J(LRA,8),?60,$J(LRA/$S('LRD:1,1:LRD)*100,5,1)
F A=0:0 S A=$O(^TMP($J,"T",A)) Q:'A D
.S ^TMP($J,"T","B",$P(^DIC(45.7,A,0),"^"),A)=""
W ! S A=0
F S A=$O(^TMP($J,"T","B",A)) Q:A=""!(LR("Q")) D
.F B=0:0 S B=$O(^TMP($J,"T","B",A,B)) Q:'B!(LR("Q")) D
..S X=^TMP($J,"T",B)
..W !,A,?39,$J(X,3)
..D:$Y>(IOSL-6) H Q:LR("Q")
..S Y=$G(^TMP($J,"Z",B))
..I Y,Y'>X W ?46,$J(Y,7),?60,$J(Y/X*100,5,1)
PREXC ;Print Exceptions
Q:LR("Q")
W !!,"Treating Specialty Exceptions:",?46,$J(EXTOT,7)
Q:'EXTOT
D H2
S A="" F S A=$O(^TMP($J,"EXC",A)) Q:A=""!(LR("Q")) D
.S TSN=^TMP($J,"EXC",A)
.S TSA=$P(TSN,"^"),TSD=$P(TSN,"^",2)
.Q:TSD=""
.D:$Y>(IOSL-6) H1 Q:LR("Q")
.W !,A,?17,$E("("_TSD_") "_$P(^DIC(45.7,TSD,0),"^"),1,30)
.W ?49,$E("("_TSA_") "_$P(^DIC(45.7,TSA,0),"^"),1,30)
Q
A ;
S LRG=0,LRX=^LR(LRDFN,"AU"),C=$P(LRX,"^",14),ACC=$P(LRX,"^",6)
I C D
.S:'$D(^TMP($J,"Z",C)) ^(C)=0
.S ^TMP($J,"Z",C)=^TMP($J,"Z",C)+1
.S ^TMP($J,"EXC",ACC)=C
S X=^LR(LRDFN,0),DFN=$P(X,"^",3) Q:$P(X,"^",2)'=2
D P
I '$D(LRK) D Q
.Q:C=""
.S:$D(^TMP($J,"Z",C)) ^TMP($J,"Z",C)=^TMP($J,"Z",C)-1
S LRA=LRA+1,LRG=1 D:'C Q K LRK
Q
P ;
S Y=0,X=$O(^DGPM("ATID3",DFN,0)) Q:'X
S Y=$O(^DGPM("ATID3",DFN,X,0)) Q:'Y
S E=$G(^DGPM(Y,0)),Z=$P(E,"^",18) Q:'Z
I $D(LRC(Z)) S LRK=1 Q
Q:'$D(LRJ(Z))
S X=$O(^DGPM("ATID3",DFN,X)) Q:'X
S Y=$O(^DGPM("ATID3",DFN,X,Y)) Q:'Y
S E=$G(^DGPM(Y,0)),Z=+$P(E,"^",18)
S:$D(LRC(Z)) LRK=1
Q
Q ;
S E=+$P(E,"^",14),E(1)=+$O(^DGPM("ATS",DFN,E,0))
S C=+$O(^DGPM("ATS",DFN,E,E(1),0))
I F D Q
.S:'$D(^TMP($J,"Z",C)) ^(C)=0
.S ^TMP($J,"Z",C)=^TMP($J,"Z",C)+1
D EXC
S:'$D(^TMP($J,"T",C)) ^(C)=0
S ^TMP($J,"T",C)=^TMP($J,"T",C)+1
Q
H ;
I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
W !?35,"|----------In-patient-------------|"
W !,"Treating Specialty",?35,"| #Deaths",?45," #Autopsies"
W ?60,"Autopsy% |",!,LR("%")
Q
H1 ;
I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
W !,"Treating Specialty Exceptions (Continued)"
W !,LR("%")
H2 ;
W !!,"Autopsy #",?17,"PATIENT MOVEMENT File",?49,"LAB DATA File",!
Q
EXC ;Check for treating specialty exceptions
S LRDFN=$$LRDFN^LR7OR1(DFN)
Q:'LRDFN
I $D(^LR(LRDFN,"AU")) D
.S AUREC=^LR(LRDFN,"AU")
.S ACC=$P(AUREC,"^",6)
.I $D(^TMP($J,"EXC",ACC)) D
..Q:+^TMP($J,"EXC",ACC)=C
..S $P(^TMP($J,"EXC",ACC),"^",2)=C,EXTOT=EXTOT+1
..S TSA=$P(^TMP($J,"EXC",ACC),"^")
..S ^TMP($J,"Z",TSA)=^TMP($J,"Z",TSA)-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQOR3 3326 printed Sep 23, 2025@19:43:45 Page 2
LRAPQOR3 ;AVAMC/REG - QA AUTOPSY DATA ;9/17/90 07:52
+1 ;;5.2;LAB SERVICE;**234,242**;Sep 27, 1994
+2 ;15-MAR-1999;WTY;Changes for HIN-1298-42595
+3 ;
+4 SET (LRA,LRD)=""
SET EXTOT=0
SET LRSDT=LRSDT(1)
KILL LRC
+5 SET A=0
FOR B=0:0
SET A=$ORDER(^DG(405.2,"B",A))
if A=""
QUIT
Begin DoDot:1
+6 IF A["DEATH"!(A="WHILE ASIH")
SET X=$ORDER(^DG(405.2,"B",A,0))
Begin DoDot:2
+7 IF X
if A["DEATH"
SET LRC(X)=""
if A["ASIH"
SET LRJ(X)=""
End DoDot:2
End DoDot:1
+8 SET F=1
FOR A=LRSDT:0
SET A=$ORDER(^LR("AAU",A))
if 'A!(A>LRLDT)
QUIT
Begin DoDot:1
+9 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR("AAU",A,LRDFN))
if 'LRDFN
QUIT
DO A
End DoDot:1
+10 if LR("Q")
QUIT
+11 IF IOST?1"C".E
WRITE !!,"Please hold, calculating Autopsy% ...",!
+12 SET F=0
FOR A=LRSDT:0
SET A=$ORDER(^DPT("AEXP1",A))
if 'A!(A>LRLDT)
QUIT
Begin DoDot:1
+13 FOR DFN=0:0
SET DFN=$ORDER(^DPT("AEXP1",A,DFN))
if 'DFN
QUIT
Begin DoDot:2
+14 DO P
IF $DATA(LRK)
SET LRD=LRD+1
DO Q
KILL LRK
End DoDot:2
End DoDot:1
+15 SET LRF=1
DO H
if LR("Q")
QUIT
+16 WRITE !?35,$JUSTIFY(LRD,7),?45,$JUSTIFY(LRA,8),?60,$JUSTIFY(LRA/$SELECT('LRD:1,1:LRD)*100,5,1)
+17 FOR A=0:0
SET A=$ORDER(^TMP($JOB,"T",A))
if 'A
QUIT
Begin DoDot:1
+18 SET ^TMP($JOB,"T","B",$PIECE(^DIC(45.7,A,0),"^"),A)=""
End DoDot:1
+19 WRITE !
SET A=0
+20 FOR
SET A=$ORDER(^TMP($JOB,"T","B",A))
if A=""!(LR("Q"))
QUIT
Begin DoDot:1
+21 FOR B=0:0
SET B=$ORDER(^TMP($JOB,"T","B",A,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:2
+22 SET X=^TMP($JOB,"T",B)
+23 WRITE !,A,?39,$JUSTIFY(X,3)
+24 if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+25 SET Y=$GET(^TMP($JOB,"Z",B))
+26 IF Y
IF Y'>X
WRITE ?46,$JUSTIFY(Y,7),?60,$JUSTIFY(Y/X*100,5,1)
End DoDot:2
End DoDot:1
PREXC ;Print Exceptions
+1 if LR("Q")
QUIT
+2 WRITE !!,"Treating Specialty Exceptions:",?46,$JUSTIFY(EXTOT,7)
+3 if 'EXTOT
QUIT
+4 DO H2
+5 SET A=""
FOR
SET A=$ORDER(^TMP($JOB,"EXC",A))
if A=""!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET TSN=^TMP($JOB,"EXC",A)
+7 SET TSA=$PIECE(TSN,"^")
SET TSD=$PIECE(TSN,"^",2)
+8 if TSD=""
QUIT
+9 if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
+10 WRITE !,A,?17,$EXTRACT("("_TSD_") "_$PIECE(^DIC(45.7,TSD,0),"^"),1,30)
+11 WRITE ?49,$EXTRACT("("_TSA_") "_$PIECE(^DIC(45.7,TSA,0),"^"),1,30)
End DoDot:1
+12 QUIT
A ;
+1 SET LRG=0
SET LRX=^LR(LRDFN,"AU")
SET C=$PIECE(LRX,"^",14)
SET ACC=$PIECE(LRX,"^",6)
+2 IF C
Begin DoDot:1
+3 if '$DATA(^TMP($JOB,"Z",C))
SET ^(C)=0
+4 SET ^TMP($JOB,"Z",C)=^TMP($JOB,"Z",C)+1
+5 SET ^TMP($JOB,"EXC",ACC)=C
End DoDot:1
+6 SET X=^LR(LRDFN,0)
SET DFN=$PIECE(X,"^",3)
if $PIECE(X,"^",2)'=2
QUIT
+7 DO P
+8 IF '$DATA(LRK)
Begin DoDot:1
+9 if C=""
QUIT
+10 if $DATA(^TMP($JOB,"Z",C))
SET ^TMP($JOB,"Z",C)=^TMP($JOB,"Z",C)-1
End DoDot:1
QUIT
+11 SET LRA=LRA+1
SET LRG=1
if 'C
DO Q
KILL LRK
+12 QUIT
P ;
+1 SET Y=0
SET X=$ORDER(^DGPM("ATID3",DFN,0))
if 'X
QUIT
+2 SET Y=$ORDER(^DGPM("ATID3",DFN,X,0))
if 'Y
QUIT
+3 SET E=$GET(^DGPM(Y,0))
SET Z=$PIECE(E,"^",18)
if 'Z
QUIT
+4 IF $DATA(LRC(Z))
SET LRK=1
QUIT
+5 if '$DATA(LRJ(Z))
QUIT
+6 SET X=$ORDER(^DGPM("ATID3",DFN,X))
if 'X
QUIT
+7 SET Y=$ORDER(^DGPM("ATID3",DFN,X,Y))
if 'Y
QUIT
+8 SET E=$GET(^DGPM(Y,0))
SET Z=+$PIECE(E,"^",18)
+9 if $DATA(LRC(Z))
SET LRK=1
+10 QUIT
Q ;
+1 SET E=+$PIECE(E,"^",14)
SET E(1)=+$ORDER(^DGPM("ATS",DFN,E,0))
+2 SET C=+$ORDER(^DGPM("ATS",DFN,E,E(1),0))
+3 IF F
Begin DoDot:1
+4 if '$DATA(^TMP($JOB,"Z",C))
SET ^(C)=0
+5 SET ^TMP($JOB,"Z",C)=^TMP($JOB,"Z",C)+1
End DoDot:1
QUIT
+6 DO EXC
+7 if '$DATA(^TMP($JOB,"T",C))
SET ^(C)=0
+8 SET ^TMP($JOB,"T",C)=^TMP($JOB,"T",C)+1
+9 QUIT
H ;
+1 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
WRITE !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
+3 WRITE !?35,"|----------In-patient-------------|"
+4 WRITE !,"Treating Specialty",?35,"| #Deaths",?45," #Autopsies"
+5 WRITE ?60,"Autopsy% |",!,LR("%")
+6 QUIT
H1 ;
+1 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
WRITE !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
+3 WRITE !,"Treating Specialty Exceptions (Continued)"
+4 WRITE !,LR("%")
H2 ;
+1 WRITE !!,"Autopsy #",?17,"PATIENT MOVEMENT File",?49,"LAB DATA File",!
+2 QUIT
EXC ;Check for treating specialty exceptions
+1 SET LRDFN=$$LRDFN^LR7OR1(DFN)
+2 if 'LRDFN
QUIT
+3 IF $DATA(^LR(LRDFN,"AU"))
Begin DoDot:1
+4 SET AUREC=^LR(LRDFN,"AU")
+5 SET ACC=$PIECE(AUREC,"^",6)
+6 IF $DATA(^TMP($JOB,"EXC",ACC))
Begin DoDot:2
+7 if +^TMP($JOB,"EXC",ACC)=C
QUIT
+8 SET $PIECE(^TMP($JOB,"EXC",ACC),"^",2)=C
SET EXTOT=EXTOT+1
+9 SET TSA=$PIECE(^TMP($JOB,"EXC",ACC),"^")
+10 SET ^TMP($JOB,"Z",TSA)=^TMP($JOB,"Z",TSA)-1
End DoDot:2
End DoDot:1
+11 QUIT
