[613] | 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
|
---|