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