source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD3.m@ 975

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1QACSPRD3 ;HINES/CEW - Spreadsheet report selections ;7/17/95 11:22
2 ;;2.0;Patient Representative;**3,5,9,17**;07/25/1995
3SEX ;
4 ;Sub-routine to count total number of issues for each sex
5 S QACRTN="SEXTSK^QACSPRD3",QACTITLE="Sex "
6 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
7 I $G(QACXFLG) G EXIT
8SEXTSK ;
9 ;Tasked entry point for SEX
10 U IO
11 S QACROU="SEXTSK1^QACSPRD3"
12 S QACPCE(1)="M",QACLABEL(1)="Male"
13 S QACPCE(3)="",QACCNT=2
14 S QACPCE(2)="F",QACLABEL(2)="Female"
15 D SET1^QACSPRD1
16 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
17 D WRIT^QACSPRD1
18 D EXIT
19 Q
20SEXTSK1 ;
21 Q:'$D(^QA(745.1,QACD0,3))
22 D ICLOOP^QACSPRD2
23 S QACPN=$P(^QA(745.1,QACD0,0),U,3) Q:QACPN=""
24 S QACSEX=$P($G(^DPT(QACPN,0)),U,2) Q:QACSEX=""
25 S QACEE=0 F S QACEE=$O(^QA(745.1,QACD0,3,QACEE)) Q:QACEE'>0 D
26 . D TALL^QACSPRD1(QACSEX)
27 Q
28HEAD ;
29 ;Sub-routine to count total number of issues for each Issue Code Heading
30 S QACTITLE="Issue Code Heading "
31 S QACRTN="HEADTSK^QACSPRD3"
32 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
33 I $G(QACXFLG) G EXIT
34HEADTSK ;
35 ;Tasked entry point for HEAD
36 U IO
37 S QACROU="HEADTSK1^QACSPRD3"
38 S QACPCE(1)="CA",QACLABEL(1)="Patient Care"
39 S QACPCE(2)="CC",QACLABEL(2)="Courtesy" ;/Communication"
40 S QACPCE(3)="CM",QACLABEL(3)="Compliments"
41 S QACPCE(4)="ED",QACLABEL(4)="Patient Education"
42 S QACPCE(5)="EL",QACLABEL(5)="Eligibility"
43 S QACPCE(6)="EN",QACLABEL(6)="Environment"
44 S QACPCE(7)="IN",QACLABEL(7)="Information/Assistance"
45 S QACPCE(8)="MR",QACLABEL(8)="Medical Records"
46 S QACPCE(9)="PP",QACLABEL(9)="Personal Property"
47 S QACPCE(10)="TI",QACLABEL(10)="Access/Timeliness" ;"Timeliness"
48 S QACPCE(11)="SC",QACLABEL(11)="Courtesy" ;"Staff courtesy"
49 S QACPCE(12)="AC",QACLABEL(12)="Access/Timeliness"
50 S QACPCE(13)="OP",QACLABEL(13)="One Provider"
51 S QACPCE(14)="PR",QACLABEL(14)="Decisions/Preferences"
52 S QACPCE(15)="EM",QACLABEL(15)="Emotional Needs"
53 S QACPCE(16)="PC",QACLABEL(16)="Physical Comfort"
54 S QACPCE(17)="CO",QACLABEL(17)="Coordination of Care"
55 S QACPCE(18)="TR",QACLABEL(18)="Transitions"
56 ;S QACPCE(19)="ED",QACLABEL(19)="Patient Education"
57 S QACPCE(20)="FI",QACLABEL(20)="Family Involvement"
58 S QACPCE(21)="RI",QACLABEL(21)="Risk Management Complaints"
59 S QACPCE(22)="RE",QACLABEL(22)="Medical Records"
60 S QACPCE(23)="LL",QACLABEL(23)="Eligibility" ; Issues"
61 S QACPCE(24)="EV",QACLABEL(24)="Environment" ;al Issues"
62 S QACPCE(25)="RG",QACLABEL(25)="Regulation Issues"
63 S QACPCE(26)="IF",QACLABEL(26)="Requests for Information"
64 S QACPCE(27)="CP",QACLABEL(27)="Compliments"
65 S QACPCE(28)=""
66 S QACCNT=27
67 D SET1^QACSPRD1
68 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
69 D NEWHEAD
70 D WRIT^QACSPRD1
71 D EXIT
72 Q
73HEADTSK1 ;
74 Q:'$D(^QA(745.1,QACD0,3,0))
75 D ICLOOP^QACSPRD2
76 S QACEE=0
77 F S QACEE=$O(QACODE(QACEE)) Q:QACEE']"" D
78 . S QACHEAD=$E(QACODE(QACEE),1,2)
79 . D TALL^QACSPRD1(QACHEAD)
80 Q
81NEWHEAD ;combine some of the new and old headers
82 N QAC1,QAC2,QACE,QACX
83 S QACE=""
84 F S QACE=$O(COUNT(QACE)) Q:QACE']"" D
85 . I $G(COUNT(QACE,"SC"))>0 S QAC1="CC",QAC2="SC" D NEW2
86 . I $G(COUNT(QACE,"CP"))>0 S QAC1="CM",QAC2="CP" D NEW2
87 . I $G(COUNT(QACE,"LL"))>0 S QAC1="EL",QAC2="LL" D NEW2
88 . I $G(COUNT(QACE,"EV"))>0 S QAC1="EN",QAC2="EV" D NEW2
89 . I $G(COUNT(QACE,"RE"))>0 S QAC1="MR",QAC2="RE" D NEW2
90 . I $G(COUNT(QACE,"AC"))>0 S QAC1="TI",QAC2="AC" D NEW2
91 . I $G(COUNT(QACE,"IF"))>0 S QAC1="IN",QAC2="IF" D NEW2
92 Q
93NEW2 ;
94 S COUNT(QACE,QAC1)=COUNT(QACE,QAC1)+$G(COUNT(QACE,QAC2)) ;K COUNT(QACE,QAC2)
95 F QACX=11,12,22,23,24,27 K QACLABEL(QACX)
96 Q
97DIVC ; Sub-routine counts total number of contacts by Division
98 S QACRTN="DIVCTSK^QACSPRD3",QACTITLE="Contacts "
99 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
100 I $G(QACXFLG) G EXIT
101DIVCTSK ;
102 S QACROU="DIVC1^QACSPRD3"
103 D DVTSK(QACROU)
104 Q
105DIVC1 ;for each entry from #745.1 in the date range, check for the division
106 S QACDIV=$P($G(^QA(745.1,QACD0,0)),U,16) ;Q:$G(QACDIV)']""
107 I $G(QACDIV)']"" S QACDIV=0
108 S QACEE=""
109 ;I $O(^QA(740,1,"QAC2","B",QACDIV,QACEE))']"" S QACDIV=0
110 S COUNT(QACDIV)=$G(COUNT(QACDIV))+1
111 Q
112WRITEDIV ;display or print the final tally
113 W @IOF
114 S Y=QAQNBEG D DD^%DT S QACBEG=Y
115 S Y=QAQNEND D DD^%DT S QACEND=Y
116 W !!?12,"Patient Rep "_QACTITLE_"by Division Spreadsheet Report"
117 W !?20,"Date Range: "_QACBEG_" to "_QACEND
118 S QACEE=""
119 F S QACEE=$O(COUNT(QACEE)) Q:QACEE']"" D
120 . I QACEE>0 D INST^QACUTL0(QACEE,.QACDV)
121 . W !,$S(QACEE=0:"Unknown",1:QACDV),", ",COUNT(QACEE)
122 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^QACGEN S QACPFLG=1 D WRIT^QACSPRD1
123 . K QACPFLG
124 Q
125DIVI ;
126 ; Sub-routine to count total issues by Division
127 S QACRTN="DIVITSK^QACSPRD3",QACTITLE="Issues "
128 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
129 I $G(QACXFLG) G EXIT
130DIVITSK ;
131 S QACROU="DIVI1^QACSPRD3"
132 D DVTSK(QACROU)
133 Q
134DIVI1 ;for each entry in 745.1 loop through Issue code and count by code/div
135 S QACDIV=$P($G(^QA(745.1,QACD0,0)),U,16)
136 I $G(QACDIV)']"" S QACDIV=0
137 S QACEE=""
138 ;I $O(^QA(740,1,"QAC2","B",QACDIV,QACEE))']"" S QACDIV=0
139 S QACISS=0 F S QACISS=$O(^QA(745.1,QACD0,3,QACISS)) Q:QACISS'>0 D
140 . I $G(^QA(745.1,QACD0,3,QACISS,0))]"" D
141 . . S COUNT(QACDIV)=$G(COUNT(QACDIV))+1
142 Q
143DVTSK(QACROU) ;
144 U IO
145 I $P($G(^QA(740,1,"QAC")),U,3)<1 W !!,"Site is not multi-divisional for Patient Representative - no report created." Q
146 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
147 D WRITEDIV
148 D EXIT
149 Q
150SRVDS ;Sub-routine gives total issues by Service/Discipline
151 S QACIFLG=1
152 S QACTITLE="Service/Discipline "
153 S QACRTN="SVDSTSK^QACSPRD3"
154 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
155 I $G(QACXFLG) G EXIT
156SVDSTSK ; Tasked entry point for Service/Discipline
157 S QACROU="SVDSTSK1^QACSPRD3"
158 D TSK^QACSPRD2
159 Q
160SVDSTSK1 ;
161 D ICLOOP^QACSPRD2
162 S QACRR=0
163 F S QACRR=$O(QACODE(QACRR)) Q:QACRR'>0 D
164 . S QACWW=0
165 . F S QACWW=$O(^QA(745.1,QACD0,3,QACCODE(QACRR),3,"B",QACWW)) Q:QACWW'>0 D
166 . . S QACDISC=$$EN8^QACUTIL(+QACWW)
167 . . S ^TMP("QACSPRD2",$J,QACDIV,QACDISC,QACODE(QACRR),QACD0)=""
168 . . Q
169 . Q
170 Q
171EXIT ;
172 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
173 K ^TMP("QACSPRD2",$J),COUNT,ZTRTN,ZTSAVE,ZTDESC,%ZIS,IOP,POP
174 K QAC1DIV,QACBEG,QACCIEN,QACCNT,QACCODE,QACD0,QACDISC,QACDIV,QACDT
175 K QACDV,QACEE,QACEND,QACHEAD,QACICODE,QACIFLG,QACISS,QACISSUE,QACLABEL
176 K QACODE,QACPCE,QACPN,QACPOP,QACRR,QACRTN,QACSEX,QACTITLE,QACWW,QACXFLG
177 K QAQNBEG,QAQNEND
178 Q
Note: See TracBrowser for help on using the repository browser.