source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m@ 613

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am ; 2/24/08 11:25am
2 ;;5.3;Scheduling;**290,333,349,376,491**;Aug 13,1993;Build 53
3 ;SD/491 - calling SRPA03 instead of SDRPA04 (dupl)
4 Q
5EN ;manual entry
6 N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC
7 I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q
8 S RUNID=$O(^SDWL(409.6,":"),-1)
9 I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q
10 K ZTSK N SDCON S SDCON=1
11 S %DT("A")="Queue to run: "
12 S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON
13 .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO=""
14 .S ZTDESC="PAIT"
15 .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D
16 ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and use SD-PAIT REPAIR to fix the run."
17 .Q:'SDCON
18 .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
19 .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!"
20 I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q
21 W !!,"Task number: ",ZTSK,!
22 Q
23START ;Tasked entry
24 N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN
25 I '$$RUNCK^SDRPA02() Q ;check scheduling
26 I $G(ZTSK)="" D Q
27 . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!!
28 S ZTSKN=ZTSK
29 S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run
30 I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running
31 .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished
32 .N ZTSK
33 .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1
34 .;send message
35 .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ
36 .S XMSUB="PAIT BACKGROUND JOB"
37 .S XMY("G.SD-PAIT")=""
38 .S XMTEXT="SDAMX("
39 .S XMDUZ="POSTMASTER"
40 .S SDAMX(1)="The PAIT requested task has been terminated."
41 .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed."
42 .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)=""
43 .E S SD1=2 D
44 ..S SDAMX(3)="The previous run errored out, not repaired!"
45 ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run."
46 .D ^XMD
47 S DIC=409.6,DIC(0)="X"
48 D NOW^%DTC S TODAY=X
49 K DO D FILE^DICN
50 S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE
51 ;send START message
52 D STMES
53 S (SDOUT,SDCNT)=0
54 K ^TMP("SDDPT",$J)
55 N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,""))
56 S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^")
57 I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run
58 E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ;
59 N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0
60 S SDDAM=SDPREV ;creation date
61 D NOW^%DTC S TODAY=X
62 F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D
63 .N DFN S DFN=0
64 .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D
65 ..N SDADT S SDADT=0 ;appt date/time
66 ..S SDADT=0
67 ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D
68 ...I SDADT'>3030000 Q ;only appointment scheduled for 2003 and later; sd/491
69 ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates
70 ...; Check for 'stop task' request
71 ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q
72 ....N DA,DIE,DR,SDD,SDLAST D
73 ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1
74 ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
75 ...N SDCL,SDSTAT,SDSTTY
76 ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
77 ...Q:SDCL="" ; If this happens, there's something wrong.
78 ...;
79 ...; Check status.
80 ...; Appoinment made only before Sep 1, 2003
81 ...; If it is not the first run, send but don't create a pending file
82 ...; Otherwise add to pending file.
83 ...D NOW^%DTC N STODAY S STODAY=X
84 ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1)
85 ...I $P(SDSTAT,"^")=0 Q
86 ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter
87 ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
88 ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days
89 ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired
90 ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U)
91 ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed.
92 ...N DIC,DA,X,SDRET D
93 ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
94 ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
95 ....K DO S X=DFN D FILE^DICN
96 ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
97 ....Q
98 ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
99 ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
100 ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
101 Q:SDOUT
102 N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day
103 S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
104 ; scan the previous runs
105 S RUNID=0
106 F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D
107 .N APPTID,SDADT,REC
108 .S APPTID=0
109 .;scanning only appointments that were sent as 'pending'
110 .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D
111 ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate
112 ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2)
113 ..;evaluate SDADT - appt date/time for possible removal from sending
114 ..I SDADT'>3030000 N DIK S DIK="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID,DA=APPTID D ^DIK ;delete entry; not to be sent; sd/491
115 ..; Check for 'stop task'
116 ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ;
117 ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO
118 ..S SDCLO=$P(REC,"^",10)
119 ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw
120 ..I SDDAMO="" D
121 ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q
122 ..Q:SDDAMO="" ;cannot determine what was original creation date
123 ..;evaluate if the same creation date
124 ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I")
125 ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
126 ..Q:SDCL="" ;
127 ..I SDCLO="" S SDCLO=SDCL
128 ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent
129 ..; Check status. If it is a termination, continue.
130 ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time
131 ..;anothercross reference entry will be created; do not need to quit
132 ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above
133 ..S SDSTAT=""
134 ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D
135 ...; create CT status; the current SDADT has different creation date
136 ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO
137 ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0)
138 ..I $P(SDSTAT,"^")=0 Q
139 ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
140 ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL
141 ..S SDSTTY=$P(SDSTAT,U,2)
142 ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw
143 ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed.
144 ..N DIC,DA,X D
145 ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
146 ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
147 ...K DO S X=DFN D FILE^DICN
148 ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
149 ..N DIC,DA D
150 ...; not rejected can be sent only as 'S'- sent as final
151 ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final
152 ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID
153 ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE
154 ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
155 ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
156 ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
157 .Q
158 Q:SDOUT
159 I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID)
160 K ^TMP("SDDPT",$J)
161 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN)
162 Q
163STMES ;generate start message
164 N SDS,SD870,SD87
165 S SD870=$O(^HLCS(870,"B","SD-PAIT",""))
166 N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY")
167 N SD87 S SD87=SD870_","
168 S SDSTAT=ARRAY(870,SD87,4,"I")
169 D NOW^%DTC
170 N SDDT,SDST S SDDT=%
171 S SDST=$P($$SITE^VASITE(),"^",3)
172 N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ
173 S XMSUB=$G(SDST)_" - PAIT START JOB"
174 S XMY("G.SD-PAIT")=""
175 S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
176 S XMTEXT="SDAMX("
177 S XMDUZ="POSTMASTER"
178 S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK
179 S SDAMX(2)="Site Started SD-PAIT status Task #"
180 S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK
181 ;
182 I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D
183 .S SDAMX(4)=" Please start a REMEDY ticket for station "_SDST
184 .S SDAMX(5)="SD-PAIT Logical Link has to be started."
185 .S SDAMX(6)="Refer the ticket to Scheduling PAIT."
186 .S SDAMX(7)=""
187 D ^XMD
188 Q
189 ;
190GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs.
191 ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called.
192 ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd
193 D ^%DTC
194 Q X>0 ;
195STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals
196 I SDSTTY="F" S SDFIN=SDFIN+1 Q
197 I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1
198 Q
Note: See TracBrowser for help on using the repository browser.