- LRAPQOR3 ;AVAMC/REG - QA AUTOPSY DATA ;9/17/90 07:52
- ;;5.2T9;LR;**234,242,1018**;Nov 17, 2004
- ;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
- LRAPQOR3 ;AVAMC/REG - QA AUTOPSY DATA ;9/17/90 07:52
- +1 ;;5.2T9;LR;**234,242,1018**;Nov 17, 2004
- +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
