source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RALWKL2.m@ 1420

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1RALWKL2 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:15
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3DIVCHK ; Output statistics within division.
4 N RA1,RAIMG,RASUM,RATTL0,RATTL1,RAWWU1
5 S (RA1,RAIMG,RADIVSUM)="",RASUM=1
6 S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
7 S RATTL0=$G(^TMP($J,"RA",RADIV)),RAWWU1=+$P(RATTL0,"^",5)
8 F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
9 F S RA1=$O(^TMP($J,"RA1",RADIV,RA1)) Q:RA1']"" D Q:RAXIT
10 . I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
11 . S (RATTL2,RATTL3,RAWWU2)=0
12 . S RATTL2=$G(^TMP($J,"RA1",RADIV,RA1)),RAWWU2=$P(RATTL2,"^",5)
13 . F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
14 . W !,$E(RA1,1,28),?30,$J(+$P(RATTL2,"^"),5)
15 . W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
16 . W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
17 . W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
18 . W ?68,$J(RAWWU2,5)
19 . W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
20 . Q
21 Q:RAXIT
22 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
23 K RADIVSUM
24 W !,RALN,!!,"Division Total",?30,$J(+$P(RATTL0,"^"),5)
25 W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
26 W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5) W:$D(RAFL) ?68,$J(RAWWU1,5)
27 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
28 W !!?2,"Imaging Type(s): "
29 S RAITHLD=""
30 F S RAITHLD=$O(^TMP($J,"RA",RADIV,RAITHLD)) Q:RAXIT!(RAITHLD="") W:$X>(80-25) !?($X+$L("Imaging Type(s):")+3) D
31 .I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
32 .W $S($D(^RA(79.2,+$P(RAITHLD,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN"),?($X+3)
33 K RAITHLD Q:RAXIT
34 W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
35 S RA1=$O(^TMP($J,"RA",RADIV))
36 I RA1]"" N RADIV,RAIMG,RAFLD S RADIV=RA1,RASUM=0 D
37 . S RA11=$O(^TMP($J,"RA",RADIV,"")) S:RA11]"" RAIMG=RA11
38 . I $G(RAIMG)]"" S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,"")) S:RA111]"" RAFLD=RA111 I $G(RAFLD)]"" S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
39 . Q
40 Q
41IMGCHK ; Check for EOS on I-Type
42 N RA1,RA11,RA111,RASUM,RATTL0,RATTL1,RATTL2,RATTL3,RAWWU1,RAWWU2
43 S (RA111,RAIMGSUM)="",RASUM=1
44 I RAPG S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
45 D:'RAPG HD^RALWKL1 Q:RAXIT
46 S RATTL0=$G(^TMP($J,"RA",RADIV,RAIMG)),RAWWU1=+$P(RATTL0,"^",5)
47 F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
48 F S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RA111)) Q:RA111']"" D Q:RAXIT
49 . I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
50 . S (RATTL2,RATTL3,RAWWU2)=0
51 . S RATTL2=$G(^TMP($J,"RA",RADIV,RAIMG,RA111)),RAWWU2=+$P(RATTL2,"^",5)
52 . F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
53 . W !,$E(RA111,1,28),?30,$J(+$P(RATTL2,"^"),5)
54 . W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
55 . W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
56 . W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
57 . W ?68,$J(RAWWU2,5)
58 . W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
59 . Q
60 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
61 K RAIMGSUM
62 W !,RALN,!!,"Imaging Type Total",?30,$J(+$P(RATTL0,"^"),5)
63 W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
64 W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5),?68,$J(RAWWU1,5)
65 W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
66 S RA1=$O(^TMP($J,"RA",RADIV,RAIMG))
67 I RA1]"" N RAFLD,RAIMG S RAIMG=RA1,RASUM=0 D
68 . S RA11=$O(^TMP($J,"RA",RADIV,RAIMG,"")) Q:RA11']"" S RAFLD=RA11
69 . S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,"")) Q:RA111']""
70 . S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
71 . Q
72 Q
73PURGE ; Kill & Quit
74 K %DT,A,A1,B,B1,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,J,RA1,RA11
75 K RA111,RABEG,RACNI,RACRT,RAD0,RADFN,RADIV,RADIFLG
76 K RADIVNME,RADIVSUM,RADTE,RADTI,RAEND,RAFILE,RAFL,RAFL1,RAFLD,RAFLDCNT,RAIMG,RAIMGSUM
77 K RAINPUT,RALN,RALN1,RAMES,RAMIS,RANUM,RAP0,RAPCE,RAPG,RAPOP,RAPRC
78 K RAPRI,RAQI,RAQUIT,RASUM,RASV,RATDY,RATITLE,RATTL0,RATTL1,RATTL2
79 K RATTL3,RAWWU1,RAWWU2,RAXIT,X,Y,ZTDESC,ZTRTN,ZTSAVE
80 K ^TMP($J,"RA"),^TMP($J,"RA1"),^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
81 K ^TMP($J,"RAFLD") K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL K POP
82 Q
83ZEROUT ; Zero out the data globals.
84 N A,A1,B,B1
85 S A="" F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
86 . Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0)) Q:A1'>0 S RADIFLG(A1)=0
87 . S ^TMP($J,"RA",A1)="0^0^0^0^0",B=""
88 . F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
89 .. Q:'$D(^TMP($J,"RA I-TYPE",B)) D IT Q:B1'?3AP1"-".N S RADIFLG(A1)=RADIFLG(A1)+1
90 .. S ^TMP($J,"RA",A1,B1)="0^0^0^0^0"
91 .. Q
92 . Q
93 K RACCESS(DUZ,"DIV-IMG")
94 Q
95IT ; calculate imaging type subscript
96 S B1=$O(^RA(79.2,"B",B,0)) Q:B1'>0
97 S B1=$E($P($G(^RA(79.2,+B1,0)),U,1),1,3)_"-"_B1
98 Q
Note: See TracBrowser for help on using the repository browser.