source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD1.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.8 KB
Line 
1QACSPRD1 ;HINES/CEW - Spreadsheet report selections ;1/12/99
2 ;;2.0;Patient Representative;**3,9,17**;07/25/1995
3CONTACT ;
4 ;Sub-routine to count total number of contacts for Contact Made By
5 S QACRTN="CONTSK^QACSPRD1",QACTITLE="Contact Made by "
6 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
7 I $G(QACXFLG) G EXIT
8CONTSK ;
9 S QACROU="CONTSK1^QACSPRD1"
10 S QACFLD=12
11 D TSK
12 Q
13CONTSK1 ;
14 K QACENTRY
15 S QACENTRY=$P(^QA(745.1,QACD0,0),U,10) Q:$G(QACENTRY)']""
16 D TALL(QACENTRY)
17 Q
18SOURCE ;
19 ;Sub-routine to count total number of contacts for Source
20 S QACRTN="SOURTSK^QACSPRD1",QACTITLE="Source of Contact "
21 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
22 I $G(QACXFLG) G EXIT
23SOURTSK ;
24 S QACROU="SOURTSK1^QACSPRD1"
25 S QACFLD=13 D QACSET(QACFLD)
26 D TSK
27 Q
28SOURTSK1 ;
29 K QACENTRY
30 S QACENTRY=$P(^QA(745.1,QACD0,0),U,11)
31 I $G(QACENTRY)]"" D TALL(QACENTRY)
32 I $G(QACENTRY)']"" D
33 . S QACEE=0
34 . F S QACEE=$O(^QA(745.1,QACD0,12,QACEE)) Q:QACEE'>0 D
35 . . S QACENTRY=$G(^QA(745.1,QACD0,12,QACEE,0))
36 . . I $G(QACENTRY)]"" D TALL(QACENTRY)
37 Q
38TREATC ;
39 ;Sub-routine to count total number of contacts for Treatment Status
40 S QACRTN="TRTCTSK^QACSPRD1",QACTITLE="Contact Numbers by Treatment Status "
41 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
42 I $G(QACXFLG) G EXIT
43TRTCTSK ;
44 S QACROU="TRTCTSK1^QACSPRD1"
45 S QACFLD=16.5
46 D TSK
47 Q
48TRTCTSK1 ;
49 K QACENTRY
50 I $G(^QA(745.1,QACD0,2))]"" S QACENTRY=$P(^QA(745.1,QACD0,2),U,2) Q:$G(QACENTRY)']""
51 I $G(QACENTRY)]"" D TALL(QACENTRY)
52 Q
53TREATI ;
54 ;Sub-routine to count total number of issues for Treatment Status
55 S QACRTN="TRTITSK^QACSPRD1",QACTITLE="Issue Code by Treatment Status "
56 S ZTSAVE("QACENTRY")=""
57 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACD0) G:$G(QACPOP) EXIT
58 I $G(QACXFLG) G EXIT
59TRTITSK ;
60 S QACROU="TRTITSK1^QACSPRD1"
61 S QACFLD=16.5
62 D TSK
63 Q
64TRTITSK1 ;
65 K QACENTRY
66 I $G(^QA(745.1,QACD0,2))]"" S QACENTRY=$P(^QA(745.1,QACD0,2),U,2) Q:$G(QACENTRY)']""
67 S QACEE=0
68 F S QACEE=$O(^QA(745.1,QACD0,3,QACEE)) Q:QACEE'>0 D
69 . I $G(QACENTRY)]"" D TALL(QACENTRY)
70 Q
71EXIT ;
72 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
73 K %ZIS,IOP,POP,ZTSAVE,ZTDESC,ZTRTN,ZTSK,QACSOUR
74 K BB,COUNT,DDD,EE,MM,RR
75 K QAC1DIV,QAC,QACAA,QACBEG,QACCMB,QACCNT,QACD0,QACDT,QACDIV,QACDV
76 K QACEE,QACEND,QACIFLG,QACISSUE,QACLABEL,QACNODE,QACPCE,QACPOP,QACROU
77 K QACRTN,QACTR,QACXFLG,QACY7E,QACYES
78 K QAQNBEG,QAQNEND
79 Q
80QACSET(QACFLD,QACENTRY,QACTITLE) ;subroutines to set up counters for
81 ; fields that are sets of codes
82 S QACCNT=0
83 S QACNODE=$P(^DD(745.1,QACFLD,0),U,3)
84 F QACEE=1:1 S QACPCE(QACEE)=$P(QACNODE,";",QACEE) Q:$G(QACPCE(QACEE))']"" S QACCNT=QACCNT+1
85 F QACEE=1:1:QACCNT D
86 . S QACLABEL(QACEE)=$P(QACPCE(QACEE),":",2)
87 . S QACPCE(QACEE)=$P(QACPCE(QACEE),":",1)
88 ;I '$D(QAC1DIV) D SET2 Q
89SET1 ;multidivisional
90 N RR,RRR
91 I $G(QAC1DIV)']"" D
92 . ;S RR=0 F S RR=$O(^QA(740,1,"QAC2",RR)) Q:RR'>0 D
93 . ;. S QACDIV(RR)=^QA(740,1,"QAC2",RR,0)
94 . ;. D SET2
95 . S (RRR,QACDIV(0))=0 D SET2
96 . S RRR=0,RR=1
97 . F S RRR=$O(^DG(40.8,"AD",RRR)) Q:RRR'>0 D
98 . . Q:'$D(^DIC(4,RRR,0))
99 . . S QACDIV(RRR)=RRR
100 . . S RR=RR+1
101 . . D SET2
102 I $G(QAC1DIV)]"" D
103 . ;S RR=1,QACDIV(RR)=QAC1DIV
104 . S QACDIV(1)=QAC1DIV
105 . S RRR=1
106 . D SET2
107 Q
108SET2 ;for each division or not multi-divisional, initialize counts
109 S EE=0 F S EE=$O(QACPCE(EE)) Q:$G(QACPCE(EE))']"" D
110 . S QAC=QACPCE(EE)
111 . ;I S COUNT(QAC)=0
112 . S COUNT(QACDIV(RRR),QACPCE(EE))=0
113 Q
114SET3 ;multi-divisional, but entry has no division, initialize counts
115 S MM="" I $O(QACDIV(MM))>0 D
116 . S QACDIV(0)=0
117 . S BB=0 F S BB=$O(QACPCE(BB)) Q:BB>QACCNT D
118 . . S COUNT(0,QACPCE(BB))=0
119 S EE=0 F S EE=$O(QACPCE(EE)) Q:$G(QACPCE(EE))']"" I QACENTRY=QACPCE(EE) D
120 . ;S COUNT(QACDIV,QACPCE(EE))=$G(COUNT(QACDIV,QACPCE(EE)))+1
121 . S EE=QACCNT
122 Q
123TALL(QACENTRY) ;tally the entry
124 S (QACAA,QACYES)=0
125 F S QACAA=$O(QACDIV(QACAA)) Q:QACAA'>0 D
126 . I QACDIV=QACDIV(QACAA) S QACYES=1
127 ;I $G(QACYES)'=1 S QACDIV=0
128 I $G(QAC1DIV)']"" S RR=0 D SET3
129 S EE=0 F S EE=$O(QACPCE(EE)) Q:EE>QACCNT I QACENTRY=QACPCE(EE) D
130 . ;I '$D(QAC1DIV) S COUNT(QACPCE(EE))=COUNT(QACPCE(EE))+1
131 . S COUNT(QACDIV,QACPCE(EE))=$G(COUNT(QACDIV,QACPCE(EE)))+1
132 . S EE=QACCNT
133 Q
134WRIT ;output
135 W:($E(IOST)="C")!($G(QACPFLG)=1) @IOF
136 W !!?15,$G(QACTITLE)_"Spreadsheet Report"
137 S Y=QAQNBEG D DD^%DT S QACBEG=Y
138 S Y=QAQNEND D DD^%DT S QACEND=Y
139 W !?20,"Date Range: "_QACBEG_" to "_QACEND
140 W !
141 I $G(QACIFLG)=1!($G(QACPFLG)=1) Q
142 ;I '$D(QAC1DIV) D WRIT2 Q
143 S DDD=""
144 F S DDD=$O(QACDIV(DDD)) Q:DDD']"" D
145 . I $G(DDD)>0 D INST^QACUTL0(QACDIV(DDD),.QACDV)
146 . W !!,"Division: "_$S(DDD=0:"Unknown",1:QACDV)
147 . D WRIT2
148 Q
149WRIT2 ;
150 N EE
151 S EE=0
152 F S EE=$O(QACLABEL(EE)) Q:EE'>0 D
153 . W !,QACLABEL(EE)_", "_COUNT(QACDIV(DDD),QACPCE(EE))
154 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^QACGEN S QACPFLG=1 D WRIT
155 . K QACPFLG
156 W !!
157 Q
158TSK ;
159 U IO
160 D QACSET(QACFLD)
161 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
162 D WRIT
163 D EXIT
164 Q
Note: See TracBrowser for help on using the repository browser.