source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPQOR3.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1LRAPQOR3 ;AVAMC/REG - QA AUTOPSY DATA ;9/17/90 07:52
2 ;;5.2;LAB SERVICE;**234,242**;Sep 27, 1994
3 ;15-MAR-1999;WTY;Changes for HIN-1298-42595
4 ;
5 S (LRA,LRD)="",EXTOT=0,LRSDT=LRSDT(1) K LRC
6 S A=0 F B=0:0 S A=$O(^DG(405.2,"B",A)) Q:A="" D
7 .I A["DEATH"!(A="WHILE ASIH") S X=$O(^DG(405.2,"B",A,0)) D
8 ..I X S:A["DEATH" LRC(X)="" S:A["ASIH" LRJ(X)=""
9 S F=1 F A=LRSDT:0 S A=$O(^LR("AAU",A)) Q:'A!(A>LRLDT) D
10 .F LRDFN=0:0 S LRDFN=$O(^LR("AAU",A,LRDFN)) Q:'LRDFN D A
11 Q:LR("Q")
12 I IOST?1"C".E W !!,"Please hold, calculating Autopsy% ...",!
13 S F=0 F A=LRSDT:0 S A=$O(^DPT("AEXP1",A)) Q:'A!(A>LRLDT) D
14 .F DFN=0:0 S DFN=$O(^DPT("AEXP1",A,DFN)) Q:'DFN D
15 ..D P I $D(LRK) S LRD=LRD+1 D Q K LRK
16 S LRF=1 D H Q:LR("Q")
17 W !?35,$J(LRD,7),?45,$J(LRA,8),?60,$J(LRA/$S('LRD:1,1:LRD)*100,5,1)
18 F A=0:0 S A=$O(^TMP($J,"T",A)) Q:'A D
19 .S ^TMP($J,"T","B",$P(^DIC(45.7,A,0),"^"),A)=""
20 W ! S A=0
21 F S A=$O(^TMP($J,"T","B",A)) Q:A=""!(LR("Q")) D
22 .F B=0:0 S B=$O(^TMP($J,"T","B",A,B)) Q:'B!(LR("Q")) D
23 ..S X=^TMP($J,"T",B)
24 ..W !,A,?39,$J(X,3)
25 ..D:$Y>(IOSL-6) H Q:LR("Q")
26 ..S Y=$G(^TMP($J,"Z",B))
27 ..I Y,Y'>X W ?46,$J(Y,7),?60,$J(Y/X*100,5,1)
28PREXC ;Print Exceptions
29 Q:LR("Q")
30 W !!,"Treating Specialty Exceptions:",?46,$J(EXTOT,7)
31 Q:'EXTOT
32 D H2
33 S A="" F S A=$O(^TMP($J,"EXC",A)) Q:A=""!(LR("Q")) D
34 .S TSN=^TMP($J,"EXC",A)
35 .S TSA=$P(TSN,"^"),TSD=$P(TSN,"^",2)
36 .Q:TSD=""
37 .D:$Y>(IOSL-6) H1 Q:LR("Q")
38 .W !,A,?17,$E("("_TSD_") "_$P(^DIC(45.7,TSD,0),"^"),1,30)
39 .W ?49,$E("("_TSA_") "_$P(^DIC(45.7,TSA,0),"^"),1,30)
40 Q
41A ;
42 S LRG=0,LRX=^LR(LRDFN,"AU"),C=$P(LRX,"^",14),ACC=$P(LRX,"^",6)
43 I C D
44 .S:'$D(^TMP($J,"Z",C)) ^(C)=0
45 .S ^TMP($J,"Z",C)=^TMP($J,"Z",C)+1
46 .S ^TMP($J,"EXC",ACC)=C
47 S X=^LR(LRDFN,0),DFN=$P(X,"^",3) Q:$P(X,"^",2)'=2
48 D P
49 I '$D(LRK) D Q
50 .Q:C=""
51 .S:$D(^TMP($J,"Z",C)) ^TMP($J,"Z",C)=^TMP($J,"Z",C)-1
52 S LRA=LRA+1,LRG=1 D:'C Q K LRK
53 Q
54P ;
55 S Y=0,X=$O(^DGPM("ATID3",DFN,0)) Q:'X
56 S Y=$O(^DGPM("ATID3",DFN,X,0)) Q:'Y
57 S E=$G(^DGPM(Y,0)),Z=$P(E,"^",18) Q:'Z
58 I $D(LRC(Z)) S LRK=1 Q
59 Q:'$D(LRJ(Z))
60 S X=$O(^DGPM("ATID3",DFN,X)) Q:'X
61 S Y=$O(^DGPM("ATID3",DFN,X,Y)) Q:'Y
62 S E=$G(^DGPM(Y,0)),Z=+$P(E,"^",18)
63 S:$D(LRC(Z)) LRK=1
64 Q
65Q ;
66 S E=+$P(E,"^",14),E(1)=+$O(^DGPM("ATS",DFN,E,0))
67 S C=+$O(^DGPM("ATS",DFN,E,E(1),0))
68 I F D Q
69 .S:'$D(^TMP($J,"Z",C)) ^(C)=0
70 .S ^TMP($J,"Z",C)=^TMP($J,"Z",C)+1
71 D EXC
72 S:'$D(^TMP($J,"T",C)) ^(C)=0
73 S ^TMP($J,"T",C)=^TMP($J,"T",C)+1
74 Q
75H ;
76 I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
77 D F^LRU W !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
78 W !?35,"|----------In-patient-------------|"
79 W !,"Treating Specialty",?35,"| #Deaths",?45," #Autopsies"
80 W ?60,"Autopsy% |",!,LR("%")
81 Q
82H1 ;
83 I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
84 D F^LRU W !,"AUTOPSY DATA REVIEW (",LRSTR,"-",LRLST,")"
85 W !,"Treating Specialty Exceptions (Continued)"
86 W !,LR("%")
87H2 ;
88 W !!,"Autopsy #",?17,"PATIENT MOVEMENT File",?49,"LAB DATA File",!
89 Q
90EXC ;Check for treating specialty exceptions
91 S LRDFN=$$LRDFN^LR7OR1(DFN)
92 Q:'LRDFN
93 I $D(^LR(LRDFN,"AU")) D
94 .S AUREC=^LR(LRDFN,"AU")
95 .S ACC=$P(AUREC,"^",6)
96 .I $D(^TMP($J,"EXC",ACC)) D
97 ..Q:+^TMP($J,"EXC",ACC)=C
98 ..S $P(^TMP($J,"EXC",ACC),"^",2)=C,EXTOT=EXTOT+1
99 ..S TSA=$P(^TMP($J,"EXC",ACC),"^")
100 ..S ^TMP($J,"Z",TSA)=^TMP($J,"Z",TSA)-1
101 Q
Note: See TracBrowser for help on using the repository browser.