source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RALWKL3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1RALWKL3 ;HISC/GJC-Workload Reports By Functional Area ;9/23/96 09:00
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3CHK ; Does the data meet the sort criteria?
4 S C=$P(RAP0,"^",4),C=$S(C="I":1,C="O":2,C="R":3,1:4)
5 Q:'$P(RAP0,"^",RAPCE) S RAFLD=$S($D(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$P(^(0),"^"),1:"Unknown")
6 I 'RAINPUT Q:'$D(^TMP($J,"RAFLD",RAFLD)) ; not all and not a user selected entry
7 S RAFLD=$E(RAFLD,1,30)
8 I RAFILE="SC(" Q:C=1
9 I (RAFILE="DIC(42,"!(RAFILE="DIC(42.4,")!(RAFILE="DIC(49,")) Q:13'[C
10 F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^(I,0)) S RAQI=+$G(^(0)) D EXTRA^RAUTL12(RAQI)
11 Q:'$D(^RAMIS(71,+$P(RAP0,"^",2),0)) S RAPRI=$G(^(0)),RAPRC=$E($P(RAPRI,"^"),1,40) Q:'$D(^(2)) F I=0:0 S I=$O(^RAMIS(71,+$P(RAP0,"^",2),2,I)) Q:I'>0 I $D(^(I,0)) S RAZ=$G(^(0)),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D PRC^RALWKL
12 Q:'$D(RAMIS(1))
13 I J=1 S RAMIS=RAMIS(1),RAWT=RAWT(1),RAMUL=RAMUL(1),RAWT=RAWT*RAMUL,RANUM=RAMUL
14 I J>1 S RANUM=1,RAWT=0,RAMIS=RAMIS(1) F J=1:1 Q:'$D(RAMIS(J)) S I=RAWT(J),RAMUL=RAMUL(J),RAWT=RAWT+(RAMUL*I)
15 D STORE K RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RABILAT,RAOR,RAPORT
16 Q
17STORE ; Store off data into ^TMP global.
18 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
19 I $D(RAOR) S A=25 D AUX^RALWKL
20 I $D(RAPORT) S A=26 D AUX^RALWKL
21 I $D(RAMULP) S A="MULP" D AUX^RALWKL
22 ;----------- Tabulation over all divisions -----------------------------
23 S X=$G(^TMP($J,"RA",RADIV))
24 S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
25 S ^TMP($J,"RA",RADIV)=X
26 ;----------- Tabulation over all divisions/imaging types ---------------
27 S X=$G(^TMP($J,"RA",RADIV,RAIMG))
28 S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
29 S ^TMP($J,"RA",RADIV,RAIMG)=X
30 ;------------Tabulation over division/i-type/option parameter ----------
31 I '$D(^TMP($J,"RA",RADIV,RAIMG,RAFLD))#2 D
32 . S ^TMP($J,"RA",RADIV,RAIMG,RAFLD)="0^0^0^0^0"
33 S X=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD))
34 S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
35 S ^TMP($J,"RA",RADIV,RAIMG,RAFLD)=X
36 ;------------Tabulation over division/option parameter ----------
37 ; ***** Note new '^TMP($J' subscript (RA1) *****
38 I '$D(^TMP($J,"RA1",RADIV,RAFLD))#2 D
39 . S ^TMP($J,"RA1",RADIV,RAFLD)="0^0^0^0^0"
40 S X=$G(^TMP($J,"RA1",RADIV,RAFLD))
41 S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
42 S ^TMP($J,"RA1",RADIV,RAFLD)=X
43 ;----------- Tabulation over division/i-types/option parameter/proc ----
44 I '$D(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)) D
45 . S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)="0^0^0^0^0"
46 S X=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
47 S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
48 S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)=X
49 Q
50ALLNOTH() ; Do you want access to all entries in the file or just a subset
51 ; of entries?
52 ; 'RAPRIM' will be defined if accessing this subroutine through the
53 ; Options: RA WKLRES (Resident Report) & RA WKLSTAFF (Staff Report)
54 N RAINPUT K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes"
55 S DIR("A")="Do you wish to include all "_$S($G(RAPRIM)=1:"Primary ",1:"")_$G(RATITLE)_"s? "
56 I $G(RATITLE)="Interpreting Staff" S DIR("A")="Do you wish to include all"_$S($G(RAPRIM)=1:" Primary",1:"")_" Interpreting Staff? "
57 S DIR("?",1)="Enter 'Yes' to select all entries in the file."
58 S DIR("?")="Enter 'No' to select a subset of entries in the file."
59 W ! D ^DIR K DIR Q:$D(DIRUT) ""
60 S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y
61 Q RAINPUT
62ONE(Z) ; Check if only one entry in the file. (File specs passed in.)
63 N RAXREF,RAZERO,X,X1,Y,Y1
64 S RAXREF="^"_Z_"""B"",",RAZERO="^"_Z
65 S X=$O(@(RAXREF_""""")")) Q:X']""
66 S Y=$O(@(RAXREF_""""_X_""")")) Q:Y]""
67 S X1=+$O(@(RAXREF_""""_X_""",0)")) Q:'X1
68 S:Z="SC(" Y1=$P($G(@(RAZERO_X1_",0)")),"^")
69 S:Z'="SC(" Y1=$P($G(@(RAZERO_X1_",0)")),"^")
70 S ^TMP($J,"RAFLD",Y1,X1)="",RAINPUT=0
71 Q
72SELECT ; Select one-many-all entries from a specific file.
73 Q:$D(^TMP($J,"RAFLD")) ; Only one entry in the file
74 N RADIC,RAUTIL S RADIC="^"_RAFILE,RADIC(0)="QEAMZ"
75 S RADIC("A")="Select "_$G(RATITLE)_": "
76 S RAUTIL="RAFLD",RAINPUT=$$ALLNOTH()
77 S:RAINPUT="" RAXIT=1 Q:RAXIT
78 D:'RAINPUT EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
79 S RAXIT=RAQUIT K:RAXIT RAINPUT Q:RAXIT
80 Q
Note: See TracBrowser for help on using the repository browser.