source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACMAIL0.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1QACMAIL0 ;ERC/WASHCIOFO-Send data to reposititory ;11/29/99
2 ;;2.0;Patient Representative;**4,14,15,17**;07/25/1995
3 ;
4 N QACREQUE
5 D ZTDTH
6 ;
7 Q
8 ;
9TASK ;Set up tasking for routine. Roll-up will be queued for
10 ; 01:30am, so that it doesn't run at a busy time of day.
11 S ZTRTN="START^QACMAIL0"
12 S ZTDESC="Routine collects data from local Patient Rep file for rollup"
13 S ZTDTH=QACSTART
14 S ZTSAVE("XMTXT")="",ZTSAVE("QACNOT")="",ZTSAVE("QACREQUE")=""
15 S ZTIO=""
16 F QAC1=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
17 I $G(ZTSK)']"" S QACERR=7 D ERROR
18 S DA=1,DR="754///^S X=ZTSK"
19 S DIE="^QA(740,"
20 D ^DIE K DIE
21 D EXIT
22 Q
23START ;
24 N QAC1,QACC,QACD,QACE,QACEE,QACF,QACHK,QACJ,QACK
25 N QA,QACBDAT,QACCONT,QACDOM,QACEDAT,QACELIG,QACEM,QACEMP
26 N QACERR,QACERROR,QACEXIT,QACINC,QACINTAP,QACLIN,QANLINE,QACLSAT,QACMADE
27 N QACMON,QACNO,QACNOCNT,QACNOT,QACQUIT,QACRST,QACSERV,QACSITE,QACSOR
28 N QACSR,QACSTA,QACST,QACTMP,QACVISN,QACVZ,QACYR,QACZERO
29 ;QACLCNT is message line count
30 ;QACRCNT is the number of records processed
31 ;QACCHCNT is a count of characters on the EMP line
32 ;QACTCNT is number of characters in message
33 ;QACNOCNT is the number of records not sent
34 N QACCHCNT,QACLCNT,QACNOCNT,QACRCNT,QACTCNT
35 S (QACCHCNT,QACLCNT,QACNOCNT,QACRCNT,QACTCNT)=0
36 ;set executable to cut down on keying
37 S QACINC="S QACTCNT=$G(QACTCNT)+$L($G(^TMP(""QAC MAIL"",$J,QACLCNT))),QACLCNT=$G(QACLCNT)+1"
38 K ^TMP("QAC MAIL",$J)
39 S QACEXIT=0
40 S QACZERO=$S($D(^QA(740,1,0))#2:^(0),1:0) I +QACZERO'>0 S QACERR=1 D ERROR G EXIT
41 S QACSITNO=+QACZERO
42 I $G(QACSITNO)]"" D VISN(QACSITNO)
43 S QACSTA="" D SITE^QACUTL0(+QACZERO,.QACSTA) I '$L(QACSTA) S QACERR=3 D ERROR G EXIT
44 ;reset ZTDTH, ^%ZTLOAD
45 I $G(QACREQUE)<1 D ZTDTH ;re-tasks job for next run
46 I $G(QACHK)=1 Q
47 ;
48 I $G(QACREQUE)'=1 D LOOP^QACMAIL1
49 I $G(QACREQUE)=1 D REQLOOP
50 I $D(^TMP("QAC MAIL",$J)) D SEND
51EXIT ;
52 K ^TMP("QAC MAIL",$J)
53 K DIROUT,DIRUT
54 K QACDUZ,QACINT,QACMSG,QACNO,QACNOCNT
55 N QACQBEG,QACQEND,QACRCNT,QACREQUE,QACST,QACTCNT,QACVISN,QACZTSK
56 K X,X1,X2
57 K XMSUB,XMTEXT,XMY
58 K ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO
59 Q
60ERROR ;
61 ; Need to send message with error codes if QACERR is set.
62 ; QACERR is set if site and domain information is missing
63 ; or if no task number assigned to queueing.
64 ; Then need to re-queue for next run.
65 D KILL^XM
66 S QACERROR(QACERR)=$P($T(ERR+QACERR),";;",2)
67 S XMTEXT="QACERROR("
68 S XMY("G.IRM")=""
69 S XMSUB="ERROR MSG FROM PATIENT REP DATABASE ROLLUP - PATCH QAC*2*4"
70 D ^XMD
71 D KILL^XM
72 K QACERROR(QACERR)
73 Q
74SEND ;Send message.
75 ;This message is the roll-up.
76 S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_"#"
77 D KILL^XM
78 S XMY("XXX@Q-PSS.MED.VA.GOV")=""
79 S XMSUB="QAC ROC LIST: "_^DD("SITE")_" ("_^DD("SITE",1)_")"
80 S XMTEXT="^TMP(""QAC MAIL"",$J,"
81 D ^XMD D KILL^XM
82 I $G(QACCONT)=1 S QACCONT=0 Q
83 D EXIT
84 Q
85ERR ;;Text for error messages to be included in mail message
86 ;;Site not found in QA Site Parameter file
87 ;;Site not found in Institute file
88 ;;Site number not found in Institution file
89 ;;Mail group not found in QA Site Parameter file
90 ;;Domain not found in QA Site Parameter file
91 ;;Domain not found in Domain file
92 ;;Message not sent - no task number
93 ;;No VISN number - primary VISN association not set up in Institution file
94 Q
95ZTDTH ;set the kernel ZTDTH variable for the first run and rescheduled runs.
96 ;
97 H 20
98 D CHKTSK
99 I $G(QACHK)=1 Q
100 N %Y,QACSTART
101 S (X,X1)=DT
102 D H^%DTC
103 S X2=$S(%Y=0:2,%Y=6:3,1:1)
104 D C^%DTC
105 S QACSTART=X_".013"
106 D TASK
107 S DA=1
108 S DR="754///^S X=ZTSK"
109 S DIE="^QA(740,"
110 D ^DIE K DIE
111 Q
112NEWMSG ;send message, set variables for continuation message.
113 ;S (QACCHCNT,QACLCNT,QACRCNT,QACTCNT)=0
114 ;flag for continuation message - don't go to EXIT at end of SEND
115 S QACCONT=1
116 D SEND
117 S (QACCHCNT,QACLCNT,QACRCNT,QACTCNT)=0
118 K ^TMP("QAC MAIL")
119 Q
120ROLL(QACODE) ;set new Roll-Up Status field
121 ;if record is not being rolled up set field to "1" (Rejected).
122 ;if record is has been rolled up and is closed, set field to "0".
123 ;if record was sent, but status is still open, set to "2".
124 ;not used after QAC*2*17
125 N DA,DIE,DR
126 S DIE="^QA(745.1,"
127 S DA=QACJ
128 S DR="41///^S X=QACODE"
129 D ^DIE K DIE
130 Q
131REQUE ;this subroutine will task this extract once, for one month or for
132 ;a portion of one month.
133 N QACREQUE
134 N QACCHCNT,QACLCNT,QACNOCNT,QACRCNT,QACTCNT
135 S (QACCHCNT,QACLCNT,QACNOCNT,QACRCNT,QACTCNT)=0
136 ;set re-queue flag so that task will not be re-tasked during this run
137 S QACREQUE=1
138 D START
139 Q
140VISN(QACSITNO) ;find VISN for this site
141 N QACV
142 I $D(^DIC(4,QACSITNO,7,0)) D PARENT^XUAF4("QACV",QACSITNO,"VISN")
143 I '$D(^DIC(4,QACSITNO,7,0)) S QACERR=8 S QACVISN=0 ;D ERROR Q
144 S QACVZ=$O(QACV("P",0))
145 I $G(QACVZ)]"" S QACVISN=$P(QACV("P",QACVZ),U)
146 I $G(QACVZ)']"" D
147 . S QACEE=0
148 . F S QACEE=$O(^DIC(4,QACSITNO,7,QACEE)) Q:QACEE'>0 D
149 . . I +^DIC(4,QACSITNO,7,QACEE,0)'=1 Q
150 . . S QACVISN=$P(^DIC(4,QACSITNO,7,QACEE,0),U,2)
151 . . S QACVISN=$P($G(^DIC(4,QACVISN,0)),U)
152 I $G(QACVISN)']"" S QACERR=8
153 I $G(QACERR)=8 S QACVISN=0 D ERROR Q
154 I $G(QACVISN)["VISN " S QACVISN=$E(QACVISN,6,9)
155 Q
156CHKTSK ;check to see if this job has already been tasked (i.e. on an earlier
157 ;installation, or if it has already started running).
158 S ZTSK=$P(^QA(740,1,"QAC"),U,5)
159 I $G(ZTSK)>0 D
160 . D STAT^%ZTLOAD
161 . I $G(ZTSK(1))=2 Q
162 . S QACZTSK=ZTSK K ZTSK S ZTSK=QACZTSK
163 . D ISQED^%ZTLOAD
164 . I $P($G(ZTSK("D")),",")>$P($H,",") S QACHK=1 Q
165 . I $P($G(ZTSK("D")),",")=$P($H,",") I $P(ZTSK("D"),",",2)>$P($H,",",2) S QACHK=1
166 Q
167REQLOOP ; this subroutine will run the rollup manually for a month or a part
168 ; of one month.
169 N Y
170 W !!,"This option will run the Patient Representative data roll-up"
171 W !,"for one month."
172 K %DT S %DT="AE",%DT("A")="Enter Month and Year: " D ^%DT
173 I Y'>0!(Y<2991000)!(Y>DT)!(+$E(Y,4,5)'>0) W !!,"Valid date not entered - exiting." Q
174 S QACQBEG=$E(Y,1,5)_"00"
175 S QACQEND=$E(Y,1,5)_"31"
176 S Y=QACQBEG D DD^%DT
177 I Y<0 W !!,"Invalid Date" Q
178 S QACMONTH=Y
179 S DIR(0)="Y"
180 S QACMONTH=Y
181 S DIR("A")="Would you like only a part of "_QACMONTH_"?"
182 S DIR("B")="NO"
183 S DIR("?")="Enter ""Y"" if to limit the date range, ""N"" if you want the whole month."
184 D ^DIR I $D(DIRUT)!($D(DIROUT)) Q
185 K QACFAIL
186REQLOOP1 I Y=1 D
187 . K DIR
188 . S DIR(0)="N^1:31"
189 . S DIR("A")="Enter the number of the earliest day."
190 . D ^DIR I $D(DIRUT)!($D(DIROUT)) Q
191 . S QACQBEG=$E(QACQBEG,1,5)_$S($L(+Y)<2:"0"_Y,1:Y)
192 . S DIR("A")="Enter the number of the last day."
193 . D ^DIR I $D(DIRUT)!($D(DIROUT)) Q
194 . S QACQEND=$E(QACQEND,1,5)_$S($L(+Y)<2:"0"_Y,1:Y)
195 . I QACQBEG>QACQEND S QACFAIL=1 W !!,"End date must be later than beginning date."
196 I $G(QACFAIL)=1 K QACFAIL S QACQBEG=$E(QACQBEG,1,5)_"00",QACQEND=$E(QACQEND,1,5)_"32" S Y=1 G REQLOOP1
197 N QACA,QACJ,QACOUNT
198 S QACOUNT=0
199 S QACQBEG=QACQBEG-.001
200 S QACA=QACQBEG
201 S QACQEND=QACQEND_.999
202 F S QACA=$O(^QA(745.1,"D",QACA)) Q:QACA'>0!($G(QACOUNT)>700)!(QACA>QACQEND) D
203 . S QACJ=""
204 . F S QACJ=$O(^QA(745.1,"D",QACA,QACJ)) Q:QACJ'>0 D
205 . . D NODE0^QACMAIL1
206 . . I $D(^QA(745.1,QACJ,3,0)),($P(^QA(745.1,QACJ,3,0),U,3)>0) S QACOUNT=QACOUNT+1
207 I $G(QACOUNT)=0 W !!,"No Contacts for this date range." Q
208 D SITEMSG(QACOUNT,QACMONTH)
209 I $G(QACOUNT)>0 W !!,"Number of records transmitted to the national database - "_QACOUNT
210 W !!,"End of Manual Rollup Option."
211 Q
212SITEMSG(QACOUNT,QACMONTH) ;sends a message with the number of records
213 ;sent from the manual option
214 D KILL^XM
215 S QACDUZ=$P(^VA(200,DUZ,0),U)
216 S XMY(QACDUZ)=""
217 S XMSUB="MANUAL ROLLUP STATUS"
218 S QACMSG(1)="Manual Rollup for "_QACMONTH_"."
219 S QACMSG(2)="Total number of records sent: "_QACOUNT
220 S XMTEXT="QACMSG("
221 D ^XMD D KILL^XM
222 Q
Note: See TracBrowser for help on using the repository browser.