source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACEMPE.m@ 1569

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1QACEMPE ;WCIOFO/VAD-Report By Employee ;02/10/1999
2 ;;2.0;Patient Representative;**9**;07/25/1995
3 ;
4MAIN ;
5 D INIT
6 D DATDIV^QACUTL0 G:QAQPOP EXIT
7 I +$G(QAC1DIV) D INST^QACUTL0(QAC1DIV,.QACDVNAM) ; If reporting for one division get the division name to be reported.
8 ;
9 D GTEMP G:QAQPOP EXIT
10 ;
11 K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS I POP D EXIT Q
12 ;
13 I $D(IO("Q")) D Q
14 . S ZTDESC=QACDESC
15 . S ZTRTN="PROCESS^QACEMPE"
16 . S ZTSAVE("QACALL")="",ZTSAVE("QACDESC")=""
17 . S ZTSAVE("QAC1DIV")="",ZTSAVE("QACDVNAM")=""
18 . S ZTSAVE("QACESEL")="",ZTSAVE("QACINFO")="",ZTSAVE("QACRTN")=""
19 . S ZTSAVE("QAQRANG")=""
20 . D TASK^QACUTL0
21 ;
22 D PROCESS
23 Q
24 ;
25INIT ;
26 S (QACINFO,QAQPOP)=0,QACDVNAM=""
27 S QACRTN="QACEMPE"
28 S QACDESC="Report by Employee"
29 Q
30 ;
31GTEMP ; Get the Employee Selection.
32 S QACESEL="",QACALL=0
33 W !!,"Enter an Employee Name or <CR> for ALL: " R QACESEL:DTIME
34 I QACESEL="^" S QAQPOP=1 Q
35 I QACESEL="" S QACALL=1 Q
36 I QACESEL'?.AP W !,$C(7),"INVALID NAME...RE-ENTER NAME!" G GTEMP
37 S QACESEL=$$TRANS(QACESEL)
38 ;
39 ; Select one Employee.
40 S QACFIL=200,QACFLDS=.01,QACFLGS="O",QACDATA="^TMP(QACRTN,$J,""DATA"")",QACERR="^TMP(QACRTN,$J,""ERR"")"
41 D FIND^DIC(QACFIL,,.QACFLDS,QACFLGS,QACESEL,,,,,QACDATA,QACERR)
42 S QACFOUND=+$G(^TMP(QACRTN,$J,"DATA","DILIST",0))
43 I 'QACFOUND D G GTEMP
44 . W !!,$C(7),"EMPLOYEE SELECTION NOT FOUND...<CR> to Continue" R R:DTIME
45 ;
46 S QACOK=0
47 I QACFOUND=1 D GTEMP1 Q:QACOK G GTEMP
48 D GTEMP2 Q:QACOK G GTEMP
49 Q
50 ;
51GTEMP1 ;
52 S QACREC=^TMP(QACRTN,$J,"DATA","DILIST",1,1)
53 W !!?5,QACREC
54 W !!?5,"Is the above Employee the correct one? <Y> " R R:DTIME
55 S R=$$TRANS(R)
56 I R="" S R="Y"
57 I R="Y" S QACESEL=QACREC,QACOK=1 Q
58 I R'="N" D G GTEMP1
59 . W !!,"PLEASE ENTER 'Y' or 'N'...<CR> to Continue" R R:DTIME
60 Q
61 ;
62GTEMP2 ;
63 F I=1:1:QACFOUND D
64 . S QACREC=^TMP(QACRTN,$J,"DATA","DILIST",1,I)
65 . W !?5,I,".) ",QACREC
66 ;
67 W !!?5,"Select one of the above: " R QACNUM:DTIME
68 I '$L(QACNUM) Q
69 I QACNUM>QACFOUND D G GTEMP2
70 . W !!,"MUST SELECT A NUMBER FROM 1-",QACFOUND,"...<CR> to Continue" R R:DTIME
71 S QACESEL=^TMP(QACRTN,$J,"DATA","DILIST",1,QACNUM)
72 S QACOK=1
73 Q
74 ;
75PROCESS ;
76 D SETUP,SORT,RPT
77 I 'QACINFO D HEADER W !!?26,"* * * NO DATA TO PRINT * * *",!!
78 D EXIT
79 Q
80 ;
81SETUP ;
82 K ^TMP(QACRTN,$J)
83 K QACEMPNM
84 S (QACQUIT,QACPAGE)=0
85 S QACHDR2="Date "_QAQRANG
86 S $P(QACUNDL,"-",78)="-"
87 S QACDTIM=$$HTE^XLFDT($H,1)
88 S QACTIME=$P(QACDTIM,"@",2)
89 S QACTODAY=$P(QACDTIM,"@")_" "_$E(QACTIME,1,5)
90 Q
91 ;
92SORT ; Sort thru the data to accumulate results based upon selection criteria
93 S QACDATE1=QAQNBEG-1 ; Initialize the starting point for the Date of Contacts.
94 I '$D(QAC1DIV) S QACDVNAM="NON-DIVISIONAL"
95 ;
96 ; Loop thru ROCs by "Date of Contact"
97 F S QACDATE1=$O(^QA(745.1,"D",QACDATE1)) Q:(QACDATE1>QAQNEND)!('$L(QACDATE1)) D
98 . S QACD0=""
99 . F S QACD0=$O(^QA(745.1,"D",QACDATE1,QACD0)) Q:'$L(QACD0) D
100 . . K QACOUT
101 . . D GETS^DIQ(745.1,QACD0,".01;1;2;37","NIE","QACOUT")
102 . . S QACD0X=QACD0_","
103 . . S QACROCNO=$G(QACOUT(745.1,QACD0X,.01,"E")) ; Contact Number
104 . . S QACROCDT=$G(QACOUT(745.1,QACD0X,1,"E")) ; Date of Contact - External
105 . . S QACPTNO=$G(QACOUT(745.1,QACD0X,2,"I")) ; Patient #
106 . . S QACPTNAM=$G(QACOUT(745.1,QACD0X,2,"E")) ; Patient Name
107 . . S QACDOK=1
108 . . ;
109 . . ; If site is Multi-divisional set up for the division name.
110 . . I $D(QAC1DIV) D Q:'QACDOK
111 . . . S QACDVNO=$G(QACOUT(745.1,QACD0X,37,"I")) ; Division #
112 . . . I +QAC1DIV,+QAC1DIV'=+QACDVNO S QACDOK=0 Q ; Not the selected Division
113 . . . S QACDVNAM=$G(QACOUT(745.1,QACD0X,37,"E")) ; Division Name
114 . . . I '$L(QACDVNAM) S QACDVNAM=" EMPTY"
115 . . ;
116 . . ; Get array of Service/Disciplines for an ROC.
117 . . K QAC3ARAY
118 . . S QACD1=0
119 . . F S QACD1=$O(^QA(745.1,QACD0,3,QACD1)) Q:'$L(QACD1) D
120 . . . I '$D(^QA(745.1,QACD0,3,QACD1,3,"B")) Q
121 . . . S QACD2=""
122 . . . F S QACD2=$O(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2)) Q:'$L(QACD2) D
123 . . . . S QACSVDP=$P($G(^QA(745.55,QACD2,0)),U,1) ; Serv/Disp Name
124 . . . . S QACD3=""
125 . . . . F S QACD3=$O(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2,QACD3)) Q:'$L(QACD3) D
126 . . . . . S QACSEQ=0 F QACSEQ=QACSEQ:1 I '$D(QAC3ARAY(QACSVDP,QACSEQ)) Q
127 . . . . . S QAC3ARAY(QACSVDP,QACSEQ)=""
128 . . ;
129 . . ; Get each Employee for an ROC.
130 . . S QACD1=0
131 . . F S QACD1=$O(^QA(745.1,QACD0,8,QACD1)) Q:'$L(QACD1)!(QACD1'?.N) D
132 . . . S QACENO=$G(^QA(745.1,QACD0,8,QACD1,0)) ; Employee Internal #
133 . . . S QACENOX=QACENO_","
134 . . . I '$D(QACEMPNM(200,QACENOX)) D ; If Employee Name not previously accessed get the name.
135 . . . . D GETS^DIQ(200,QACENO,".01","NE","QACEMPNM")
136 . . . . I $G(QACEMPNM(200,QACENOX,.01,"E"))="" S ^("E")="Unknown Employee"
137 . . . S QACENAM=QACEMPNM(200,QACENOX,.01,"E") ; Employee Name
138 . . . D STORIT
139 Q
140 ;
141STORIT ; Store sorted ROC data in the ^TMP global for reporting purposes.
142 I 'QACALL,(QACENAM'=QACESEL) Q ; Not selected Employee.
143 I '$D(^TMP(QACRTN,$J,"ROC",QACROCNO)) D
144 . S ^TMP(QACRTN,$J,"ROC",QACROCNO)=QACD0_U_QACROCDT_U_QACPTNAM
145 ; Store record for reporting purposes
146 S (QACSVDP,QACSEQ)=""
147 F S QACSVDP=$O(QAC3ARAY(QACSVDP)) Q:'$L(QACSVDP) D
148 . F S QACSEQ=$O(QAC3ARAY(QACSVDP,QACSEQ)) Q:'$L(QACSEQ) D
149 . . S ^TMP(QACRTN,$J,"RPT",QACDVNAM,QACENAM,QACSVDP,QACROCNO,QACSEQ)=""
150 Q
151 ;
152RPT ; Print the report
153 U IO
154 ;
155 ; Loop through the Sorted data.
156 S (QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ)=""
157 F S QACDVNAM=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM)) Q:QACDVNAM="" D Q:QACQUIT
158 . F S QACEMPNM=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM)) Q:QACEMPNM="" D Q:QACQUIT
159 . . ;
160 . . ; New Employee
161 . . D HEADER Q:QACQUIT
162 . . F S QACSVDP=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP)) Q:QACSVDP="" D Q:QACQUIT
163 . . . F S QACROCNO=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO)) Q:QACROCNO="" D Q:QACQUIT
164 . . . . ;
165 . . . . ; Get an array of Issue Text for an ROC.
166 . . . . K QACITXT
167 . . . . S QACREC=^TMP(QACRTN,$J,"ROC",QACROCNO)
168 . . . . S QACD0=$P(QACREC,U),QACROCDT=$P(QACREC,U,2),QACPTNAM=$P(QACREC,U,3)
169 . . . . I $D(^QA(745.1,QACD0,4,0)) D
170 . . . . . S DIC=745.1,DA=QACD0,DR=22,DIQ="QACITXT"
171 . . . . . D EN^DIQ1
172 . . . . ;
173 . . . . ; Print the Contact #, Date of Contact and Patient Name
174 . . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
175 . . . . W !!,QACROCNO,?25,QACROCDT,?45,QACPTNAM
176 . . . . ;
177 . . . . ; Print the Issue Text if there is any.
178 . . . . I $D(QACITXT) D Q:QACQUIT
179 . . . . . S QACD1=""
180 . . . . . F S QACD1=$O(QACITXT(745.1,QACD0,DR,QACD1)) Q:'$L(QACD1) D Q:QACQUIT
181 . . . . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
182 . . . . . . W !?3,QACITXT(745.1,QACD0,DR,QACD1)
183 . . . . ;
184 . . . . F S QACSEQ=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ)) Q:QACSEQ="" D Q:QACQUIT
185 . . . . . ;
186 . . . . . ; Print a Serv/Sect or Discipline line.
187 . . . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
188 . . . . . W !?6,QACSVDP
189 Q
190 ;
191HEADER ;
192 S QACPAGE=QACPAGE+1
193 I QACPAGE>1 D Q:QACQUIT
194 . W $C(7)
195 . I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S QACQUIT=$S(Y'>0:1,1:0)
196 ;
197 W:$E(IOST)="C"!(QACPAGE>1) @IOF
198 W !,QACDESC,?48,QACTODAY,?70,"PAGE ",QACPAGE
199 W !?(80-$L(QACHDR2))/2,QACHDR2
200 W !,"Contact #",?25,"Date of Contact",?45,"Patient Name"
201 W !?3,"Issue Text",!?6,"Serv/Sect or Discipline"
202 W !,QACUNDL
203 ;
204 I $D(QAC1DIV) D ; Print the division if site is Multi-divisional.
205 . S QACDVTXT="Division: "_$S(QACDVNAM=" EMPTY":"EMPTY",1:QACDVNAM)
206 . I $L(QACDVNAM) W !?(80-$L(QACDVTXT))/2,QACDVTXT S QACINFO=1
207 ;
208 S QACEMTXT="Employee: "_QACEMPNM
209 I $L(QACEMPNM) W !?(80-$L(QACEMTXT))/2,QACEMTXT,! S QACINFO=1
210 Q
211 ;
212TRANS(X) ; Module to transform lower-case into uppercase.
213 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
214 Q X
215 ;
216EXIT ;
217 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
218 D K^QAQDATE
219 K ^TMP(QACRTN,$J)
220 K DA,DIC,DIQ,DIR,DR
221 K QAC1DIV,QAC3ARAY,QAC4ARAY,QACALL,QACCONT,QACCREC0,QACD0,QACD0X
222 K QACD1,QACD2,QACD3,QACDATA,QACDATE1,QACDESC,QACDOK,QACDTIM,QACDV
223 K QACDVNAM,QACDVNO,QACDVTXT,QACEMPNM,QACEMTXT,QACENAM,QACENO,QACENOX
224 K QACERR,QACESEL,QACFIL,QACFLDS,QACFLGS,QACFOUND,QACHDR2,QACINFO,QACITXT
225 K QACNUM,QACOK,QACOUT,QACPAGE,QACPTNAM,QACPTNO,QACQUIT,QACREC
226 K QACROCNO,QACROCDT,QACRTN,QACSEQ,QACSNO,QACSVDP,QACTIME,QACTODAY
227 K QACUNDL,QAQDTOUT,QAQNBEG,QAQNEND,QAQPOP,QAQRANG
228 K I,POP,R,X,Y,ZTDESC,ZTRTN,ZTSAVE
229 Q
Note: See TracBrowser for help on using the repository browser.