Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m
r613 r623 1 SDRPA00 ;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 5 EN ;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 23 START ;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 163 STMES ;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 ; 190 GT90DAYS(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 ; 195 STAT(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 1 SDRPA00 ;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 4 EN ;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 22 START ;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 162 STMES ;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 ; 188 GT90DAYS(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 ; 193 STAT(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 TracChangeset
for help on using the changeset viewer.
