- 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 Feb 19, 2025@00:26:42 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