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

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

revised back to 6/30/08 version

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