SDES846P ;ALB/MGD,LAB - SD*5.3*846 Post Init Routine ; June 27, 2023
;;5.3;SCHEDULING;**846**;AUG 13, 1993;Build 12
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
EN ; Update the VS GUI version in #409.98
D FIND,TASK,TASK2,TASK3,TASK^SDES846PENC
Q
;
FIND ;FIND THE IEN FOR "VS GUI NATIONAL"
N SDECDA,SDECDA1
D MES^XPDUTL("")
D MES^XPDUTL(" Updating SDEC SETTINGS file (#409.98)")
S SDECDA=0,SDECDA=$O(^SDEC(409.98,"B","VS GUI NATIONAL",SDECDA)) G:$G(SDECDA)="" NOFIND
D VERSION ;update GUI version number and date
Q
VERSION ;SET THE NEW VERSION UPDATE IN SDEC SETTING FILE #409.98 TO 1.7.44
S DA=SDECDA,DIE=409.98,DR="2///1.7.44;3///"_DT D ^DIE ;update VS GUI NATIONAL
K DIE,DR,DA
S SDECDA1=0,SDECDA1=$O(^SDEC(409.98,"B","VS GUI LOCAL",SDECDA1)) Q:$G(SDECDA1)="" ;get DA for the VS GUI LOCAL
S DA=SDECDA1,DIE=409.98,DR="2///1.7.44;3///"_DT D ^DIE ;update VS GUI LOCAL
K DIE,DR,DA
Q
;
NOFIND ;"VS GUI NATIONAL" NOT FOUND
D MES^XPDUTL(" VS GUI NATIONAL not found in the SDEC SETTINGS file (#409.98)")
Q
;
TASK ;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*846 Post-Install to fix improper DINUMed records")
D MES^XPDUTL(" in the HOSPITAL LOCATION (#44) file is being queued to")
D MES^XPDUTL(" run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*846 Post Install Routine"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="PRIVUSERSFIX^SDES846P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
PRIVUSERSFIX ; Clean up Privileged Users whose entries are no DINUMed correctly
N CLINIEN,CLINNAME,DATA0,FIRSTPRIV,PRIVUSERIEN,PRIVUSER200,PRIVUSERNAME,ELGRETURN
S CLINIEN=0
F S CLINIEN=$O(^SC(CLINIEN)) Q:'CLINIEN D
.S DATA0=$G(^SC(CLINIEN,0))
.Q:DATA0=""
.S FIRSTPRIV=1
.S CLINNAME=$P(DATA0,U,1)
.; Don't update ZZ Clinics
.Q:$E(CLINNAME,1,2)="ZZ"
.; Quit if no Priv Users
.Q:'$D(^SC(CLINIEN,"SDPRIV"))
.S PRIVUSERIEN=0
.F S PRIVUSERIEN=$O(^SC(CLINIEN,"SDPRIV",PRIVUSERIEN)) Q:'PRIVUSERIEN D
..S PRIVUSER200=$G(^SC(CLINIEN,"SDPRIV",PRIVUSERIEN,0))
..S PRIVUSERNAME=$P($G(^VA(200,PRIVUSERIEN,0)),U,1)
..; Quit if DINUMed correctly
..Q:PRIVUSERIEN=PRIVUSER200
..; Delete Bad Entry
..D UPDPRIV^SDESLOC(.ELGRETURN,0,CLINIEN,PRIVUSERIEN)
..; Add DINUMed Entry
..D UPDPRIV^SDESLOC(.ELGRETURN,1,CLINIEN,PRIVUSER200)
Q
;
TASK2 ;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*846 Post-Install is being queued to run in the background.")
D MES^XPDUTL(" This Post-install will fix a data issue where appointments were ")
D MES^XPDUTL(" created with a different patients request. The post-install will ")
D MES^XPDUTL(" create a new request for the appointment. The request will be ")
D MES^XPDUTL(" reopened if there is not appointment made for the request patient.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*846 Post Install Routine - Appointment mismatch cleanup"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="SELECTDATA^SDES846P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
MAIL2 ;
; Appointment vs request data report
;
N STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
S STANUM=$$KSP^XUPARAM("INST")_","
S STANUM=$$GET1^DIQ(4,STANUM,99)
S MESS1="Station: "_STANUM_" - "
;
; Send MailMan message
S XMDUZ=DUZ
S XMTEXT="^XTMP(""SDES846P"","
S XMSUB=MESS1_"SD*5.3*846 - Post Install Data Report"
S XMDUZ=.5,XMY(DUZ)="",XMY(XMDUZ)=""
S XMY("BARBER.LORI@DOMAIN.EXT")=""
S XMY("DILL.MATT@DOMAIN.EXT")=""
S XMY("REESE,DARRYL M@DOMAIN.EXT")=""
S XMY("DUNNAM.DAVID W@DOMAIN.EXT")=""
D ^XMD
K TEXT
Q
SELECTDATA ;Select appointments where the request is not for the appointment patient
N APPTIEN,CHECKIN,CANCELDTTM,STARTTM,POP,CNT,PURGEDT,TEXTCNT
N APPTREQINFO,APPTDFN,APPTREQTYP,REQPATDFN,REOPEN,NEWREQIEN
S PURGEDT=$$FMADD^XLFDT(DT,5)
K ^XTMP("SDES846P")
S ^XTMP("SDES846P",0)=PURGEDT_"^"_DT_"^846 Post Install Data report"
S CNT=0
S TEXTCNT=1
S ^XTMP("SDES846P",TEXTCNT)="REQTYPE^REQIEN^REOPENED^APPTIEN^APPT DT/TM^APPT MADE^NEW REQIEN"
S STARTTM=$$FMADD^XLFDT(DT,-180)
F S STARTTM=$O(^SDEC(409.84,"B",STARTTM)) Q:(STARTTM="") D
. S APPTIEN=""
. S POP=0
. F S APPTIEN=$O(^SDEC(409.84,"B",STARTTM,APPTIEN)) Q:(APPTIEN="") D
.. S CHECKIN=$$GET1^DIQ(409.84,APPTIEN_",",.03)
.. S CANCELDTTM=$$GET1^DIQ(409.84,APPTIEN_",",.12)
.. S POP=(CHECKIN'="")!(CANCELDTTM'="")
.. Q:POP
.. ;Continue checking
.. S APPTDFN=$$GET1^DIQ(409.84,APPTIEN_",",.05,"I")
.. S APPTREQTYP=$$GET1^DIQ(409.84,APPTIEN_",",.22,"E")
.. S APPTREQINFO=$$GET1^DIQ(409.84,APPTIEN_",",.22,"I")
.. D:(APPTREQTYP="APPT") APPT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,.CNT,.NEWREQIEN)
.. D:(APPTREQTYP="CONSULT") CONSULT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,.CNT,.CONSULTIEN,.NEWREQIEN)
S TEXTCNT=TEXTCNT+1
S ^XTMP("SDES846P",TEXTCNT)="TOTAL = "_CNT
S ^XTMP("SDES846P",(TEXTCNT+1))="NOTE: -1 NEW REQIEN indicates no update made"
D MAIL2
Q
;
APPT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,CNT,NEWREQIEN) ;gather information for appt request
N REQIEN
S REQIEN=$P(APPTREQINFO,";",1)
S REQPATDFN=$$GET1^DIQ(409.85,REQIEN_",",.01,"I")
Q:APPTDFN=REQPATDFN
S REOPEN=""
D DATACLEANUP(APPTDFN,APPTIEN,REQIEN,REQPATDFN,APPTREQTYP,"",.NEWREQIEN,.REOPEN)
D REPORT(REQIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,.CNT)
;
Q
DATACLEANUP(APPTDFN,APPTIEN,REQIEN,REQPATDFN,APPTREQTYP,CONSULTIEN,NEWREQIEN,REOPEN) ;create appt request for patient on appointment and attach
N SDDEMO,ARRAY,TODAY,REQSTAT,DISPOSITION,FDA,CONSTAT,RESCHED
K FDA,SDDEMO,PRFLIST
D PDEMO^SDECU3(.SDDEMO,APPTDFN)
S ARRAY(2)=APPTDFN
S ARRAY(3)=$P($$FMTONET^SDECDATE($$NOW^XLFDT),":")_":"_$P($$FMTONET^SDECDATE($$NOW^XLFDT),":",2)
S ARRAY(5)="APPT"
S ARRAY(6)=$$GET1^DIQ(409.831,$$GET1^DIQ(409.84,APPTIEN_",",.07,"I")_",",.04,"I")
S ARRAY(7)=.5
S ARRAY(8)="ASAP"
S ARRAY(9)="PATIENT"
S ARRAY(11)=$$FMTE^XLFDT($$GET1^DIQ(409.84,APPTIEN_",",.2,"I"),"5D")
S ARRAY(12)="AUTO CREATED VIA SD*5.3*846 POST INSTALL TO CORRECT DATA ISSUE"
S ARRAY(13)=$G(SDDEMO("PRIGRP"))
S ARRAY(14)="NO"
S ARRAY(15)=0
S ARRAY(16)=0
S ARRAY(18)=$G(SDDEMO("SVCCONN"))
S ARRAY(19)=$G(SDDEMO("SVCCONNP"))
D ARSET^SDECAR2(.RETN,.ARRAY)
S NEWREQIEN=$TR($P($P(RETN,"^",2),"ERRORTEXT",2),$C(30)_"_")
Q:NEWREQIEN=-1
S FDA(409.84,APPTIEN_",",.22)=NEWREQIEN_";SDEC(409.85,"
D FILE^DIE("","FDA") ;update the appointment with the new request ien
S TODAY=$$FMTE^XLFDT(DT,"5D")
K ARRAY
S ARRAY(1)=NEWREQIEN
S ARRAY(2)="REMOVED/SCHEDULED-ASSIGNED"
S ARRAY(3)=.5
S ARRAY(4)=TODAY
S ARRAY(5)=TODAY
K RETN
D ARCLOSE^SDECAR(.RETN,.ARRAY) ;Close the request that was just attached to the appointment.
K ARRAY,RETN
I APPTREQTYP="APPT" D
. S REQSTAT=$$GET1^DIQ(409.85,REQIEN_",",23,"E")
. S DISPOSITION=$$GET1^DIQ(409.85,REQIEN_",",21,"E")
. Q:(DISPOSITION'="REMOVED/SCHEDULED-ASSIGNED")&(DISPOSITION'="") ;if request is open or dispositioned other than scheduled quit
. S RESCHED=$$RESCHEDULED(REQPATDFN,REQIEN)
. Q:RESCHED ;quit and do not reopen if already attached to the patient
. I (REQSTAT="CLOSED") D
.. S REOPEN="*"
.. D AROPEN^SDECAR(.RETN,"",REQIEN,"") ;open the other patients request back up
I APPTREQTYP="CONSULT" D
. S CONSTAT=$$GET1^DIQ(123,CONSULTIEN,8,"E")
. I CONSTAT="SCHEDULED"!(CONSTAT="COMPLETE") D
.. S RESCHED=$$RESCHEDULED(REQPATDFN,CONSULTIEN)
.. I 'RESCHED D
... S REOPEN="*"
... D OPENCONSULT(CONSULTIEN)
Q
;
OPENCONSULT(CONSULTIEN) ;reopen consult if not already attached to appointment with correct patient
; SETUP REQUIRED VARIABLES THEN CALL THE FOLLOWING
N PROVIEN,COMMENT,ORMSG
S COMMENT(1)="Auto reopened via SD*5.3*846 Post Install - consult originally attached to incorrect patient appointment."
S PROVIEN=$$GET1^DIQ(123,CONSULTIEN_",",10,"I")
N SDERR S SDERR=$$STATUS^GMRCGUIS(CONSULTIEN,6,3,PROVIEN,"","",.COMMENT)
Q
;
CONSULT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,CNT,CONSULTIEN,NEWREQIEN) ;gather consult information
N CONSULTIEN,CONSULTPATDFN,CONSULTPATIENT
S CONSULTIEN=$P(APPTREQINFO,";",1)
S CONSULTPATDFN=$$GET1^DIQ(123,CONSULTIEN_",",.02,"I")
Q:APPTDFN=CONSULTPATDFN
S CONSULTPATIENT=$$GET1^DIQ(123,CONSULTIEN_",",.02,"E")
;
S REOPEN=""
D DATACLEANUP(APPTDFN,APPTIEN,"",CONSULTPATDFN,APPTREQTYP,CONSULTIEN,.NEWREQIEN,.REOPEN)
D REPORT(CONSULTIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,.CNT)
Q
;
REPORT(REQIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,CNT) ;report of data cleanup
S CNT=CNT+1
S TEXTCNT=TEXTCNT+1
S ^XTMP("SDES846P",TEXTCNT)=APPTREQTYP_"^`"_REQIEN_"^"_REOPEN_"^`"_APPTIEN_"^"_$$GET1^DIQ(409.84,APPTIEN_",",.01,"E")_"^"_$$GET1^DIQ(409.84,APPTIEN_",",.09,"E")_"^"_NEWREQIEN
Q
;
RESCHEDULED(DFN,APPTREQINFO) ;check to see if the request is already attached to another appointment
N DTLOOP,CHECKAPTIEN,CHKREQ,RESCHED,DATECANCELLED,DATENOSHOWED
Q:DFN="" 0
S RESCHED=0
S DTLOOP=0 F S DTLOOP=$O(^SDEC(409.84,"APTDT",DFN,DTLOOP)) Q:'DTLOOP D
.S CHECKAPTIEN=0 F S CHECKAPTIEN=$O(^SDEC(409.84,"APTDT",DFN,DTLOOP,CHECKAPTIEN)) Q:'CHECKAPTIEN D
..; only records that point to the same request
..S CHKREQ=$P($$GET1^DIQ(409.84,CHECKAPTIEN,.22,"I"),";")
..I CHKREQ'=APPTREQINFO Q
..; cancellation date/time
..S DATECANCELLED=$$GET1^DIQ(409.84,CHECKAPTIEN,.12,"I")
..; no-show date/time
..S DATENOSHOWED=$$GET1^DIQ(409.84,CHECKAPTIEN,.1,"I")
..I 'DATECANCELLED&'DATENOSHOWED S RESCHED=CHECKAPTIEN
Q:('RESCHED) 0
Q 1
;
TASK3 ; Disposition old Appointment Requests
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*846 Post-Install to fix Disposition records")
D MES^XPDUTL(" in the SDEC APPT REQUEST (#409.85) file is being")
D MES^XPDUTL(" queued to run in the background. Once it finishes")
D MES^XPDUTL(" a MailMan message will be sent to the installer to")
D MES^XPDUTL(" provide them a job completion status and data summary.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*846 Post Install Routine"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="DISP^SDES846P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
DISP ; Disposition old Appointment Requests
N APPTIEN,ARIEN,CANCREAS,DATA0,DATA2,DISP,DISPIEN,FDA,IEN627,REOPEN,STARTTIME,TCNT
S TCNT=0
S IEN627=$$FIND1^DIC(9.7,"","X","SD*5.3*627","B","","ERROR")
; Quit if this site had the 627 install record and has already run this logic
I IEN627 D Q
.S TEXT(1)="This sites Disposition records were reviewed and fixed by the"
.S TEXT(2)="SD*5.3*842 post install routine."
.S TEXT(3)="Nothing else needs to be done."
.D MAIL
;
S DISPIEN=$$FIND1^DIC(409.853,"","X","CANCELLED NOT RE-OPENED","B","","ERROR")
I 'DISPIEN D Q
.S TEXT(1)="The CANCELLED NOT RE-OPENED Disposition Reason could not be found"
.S TEXT(2)="in the SDEC DISPOSITION REASON (#409.853) file. Please contact the"
.S TEXT(3)="National Help Desk to report this issue."
.D MAIL
;
S STARTTIME=3170505 ;Compliance Date for SD*5.3*627 = MAY 05, 2017
S STARTTIME=STARTTIME-.000001
F S STARTTIME=$O(^SDEC(409.84,"B",STARTTIME)) Q:'STARTTIME D
.S APPTIEN=""
.F S APPTIEN=$O(^SDEC(409.84,"B",STARTTIME,APPTIEN)) Q:'APPTIEN D
..S DATA0=$G(^SDEC(409.84,APPTIEN,0))
..; Quit is this appt is NOT cancelled
..S CANCREAS=$P(DATA0,U,22)
..Q:'CANCREAS
..; Quit it Appt Req should NOT be re-opened
..S REOPEN=$$GET1^DIQ(409.2,CANCREAS,5,"I")
..Q:REOPEN ; 1=re-open 0=don't re-open
..; Quit if this appointment doesn't point back to #409.85
..S DATA2=$P($G(^SDEC(409.84,APPTIEN,2)),"^",1)
..Q:DATA2'["409.85"
..S ARIEN=$P(DATA2,";",1)
..Q:'ARIEN
..Q:'$D(^SDEC(409.85,ARIEN))
..; Quit if this Appt Req has already been Dispositioned
..Q:$P($G(^SDEC(409.85,ARIEN,"DIS")),U,3)
..; Set Disposition fields for update
..S FDA(409.85,ARIEN_",",19)=$P($$GET1^DIQ(409.84,APPTIEN,.12,"I"),".",1) ; FIX TO JUST BE A DATE
..S FDA(409.85,ARIEN_",",20)=$$GET1^DIQ(409.84,APPTIEN,.121,"I")
..S FDA(409.85,ARIEN_",",21)=DISPIEN
..D FILE^DIE("","FDA","ERR84")
..I '$D(ERR84) S TCNT=TCNT+1
..K FDA,ERR84
S TEXT(1)="The SD*5.3*846 post install has run to completion."
S TEXT(2)="The data was reviewed and updated without any issues."
S TEXT(3)="Total Appoint Requests updated: "_TCNT
D MAIL
Q
;
MAIL ;
; Get Station Number
;
N STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
S STANUM=$$KSP^XUPARAM("INST")_","
S STANUM=$$GET1^DIQ(4,STANUM,99)
S MESS1="Station: "_STANUM_" - "
;
; Send MailMan message
S XMDUZ=DUZ
S XMTEXT="TEXT("
S XMSUB=MESS1_"SD*5.3*846 - Post Install Update"
S XMDUZ=.5,XMY(DUZ)="",XMY(XMDUZ)=""
D ^XMD
K TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES846P 13372 printed Apr 09, 2024@22:00:16 Page 2
SDES846P ;ALB/MGD,LAB - SD*5.3*846 Post Init Routine ; June 27, 2023
+1 ;;5.3;SCHEDULING;**846**;AUG 13, 1993;Build 12
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
EN ; Update the VS GUI version in #409.98
+1 DO FIND
DO TASK
DO TASK2
DO TASK3
DO TASK^SDES846PENC
+2 QUIT
+3 ;
FIND ;FIND THE IEN FOR "VS GUI NATIONAL"
+1 NEW SDECDA,SDECDA1
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL(" Updating SDEC SETTINGS file (#409.98)")
+4 SET SDECDA=0
SET SDECDA=$ORDER(^SDEC(409.98,"B","VS GUI NATIONAL",SDECDA))
if $GET(SDECDA)=""
GOTO NOFIND
+5 ;update GUI version number and date
DO VERSION
+6 QUIT
VERSION ;SET THE NEW VERSION UPDATE IN SDEC SETTING FILE #409.98 TO 1.7.44
+1 ;update VS GUI NATIONAL
SET DA=SDECDA
SET DIE=409.98
SET DR="2///1.7.44;3///"_DT
DO ^DIE
+2 KILL DIE,DR,DA
+3 ;get DA for the VS GUI LOCAL
SET SDECDA1=0
SET SDECDA1=$ORDER(^SDEC(409.98,"B","VS GUI LOCAL",SDECDA1))
if $GET(SDECDA1)=""
QUIT
+4 ;update VS GUI LOCAL
SET DA=SDECDA1
SET DIE=409.98
SET DR="2///1.7.44;3///"_DT
DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
NOFIND ;"VS GUI NATIONAL" NOT FOUND
+1 DO MES^XPDUTL(" VS GUI NATIONAL not found in the SDEC SETTINGS file (#409.98)")
+2 QUIT
+3 ;
TASK ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*846 Post-Install to fix improper DINUMed records")
+3 DO MES^XPDUTL(" in the HOSPITAL LOCATION (#44) file is being queued to")
+4 DO MES^XPDUTL(" run in the background.")
+5 DO MES^XPDUTL("")
+6 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+7 SET ZTDESC="SD*5.3*846 Post Install Routine"
+8 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="PRIVUSERSFIX^SDES846P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
Begin DoDot:1
+10 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+11 DO MES^XPDUTL("")
End DoDot:1
+12 IF '$DATA(ZTSK)
Begin DoDot:1
+13 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+14 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+15 QUIT
+16 ;
PRIVUSERSFIX ; Clean up Privileged Users whose entries are no DINUMed correctly
+1 NEW CLINIEN,CLINNAME,DATA0,FIRSTPRIV,PRIVUSERIEN,PRIVUSER200,PRIVUSERNAME,ELGRETURN
+2 SET CLINIEN=0
+3 FOR
SET CLINIEN=$ORDER(^SC(CLINIEN))
if 'CLINIEN
QUIT
Begin DoDot:1
+4 SET DATA0=$GET(^SC(CLINIEN,0))
+5 if DATA0=""
QUIT
+6 SET FIRSTPRIV=1
+7 SET CLINNAME=$PIECE(DATA0,U,1)
+8 ; Don't update ZZ Clinics
+9 if $EXTRACT(CLINNAME,1,2)="ZZ"
QUIT
+10 ; Quit if no Priv Users
+11 if '$DATA(^SC(CLINIEN,"SDPRIV"))
QUIT
+12 SET PRIVUSERIEN=0
+13 FOR
SET PRIVUSERIEN=$ORDER(^SC(CLINIEN,"SDPRIV",PRIVUSERIEN))
if 'PRIVUSERIEN
QUIT
Begin DoDot:2
+14 SET PRIVUSER200=$GET(^SC(CLINIEN,"SDPRIV",PRIVUSERIEN,0))
+15 SET PRIVUSERNAME=$PIECE($GET(^VA(200,PRIVUSERIEN,0)),U,1)
+16 ; Quit if DINUMed correctly
+17 if PRIVUSERIEN=PRIVUSER200
QUIT
+18 ; Delete Bad Entry
+19 DO UPDPRIV^SDESLOC(.ELGRETURN,0,CLINIEN,PRIVUSERIEN)
+20 ; Add DINUMed Entry
+21 DO UPDPRIV^SDESLOC(.ELGRETURN,1,CLINIEN,PRIVUSER200)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
TASK2 ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*846 Post-Install is being queued to run in the background.")
+3 DO MES^XPDUTL(" This Post-install will fix a data issue where appointments were ")
+4 DO MES^XPDUTL(" created with a different patients request. The post-install will ")
+5 DO MES^XPDUTL(" create a new request for the appointment. The request will be ")
+6 DO MES^XPDUTL(" reopened if there is not appointment made for the request patient.")
+7 DO MES^XPDUTL("")
+8 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+9 SET ZTDESC="SD*5.3*846 Post Install Routine - Appointment mismatch cleanup"
+10 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="SELECTDATA^SDES846P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+11 IF $DATA(ZTSK)
Begin DoDot:1
+12 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+13 DO MES^XPDUTL("")
End DoDot:1
+14 IF '$DATA(ZTSK)
Begin DoDot:1
+15 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+16 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+17 QUIT
+18 ;
MAIL2 ;
+1 ; Appointment vs request data report
+2 ;
+3 NEW STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
+4 SET STANUM=$$KSP^XUPARAM("INST")_","
+5 SET STANUM=$$GET1^DIQ(4,STANUM,99)
+6 SET MESS1="Station: "_STANUM_" - "
+7 ;
+8 ; Send MailMan message
+9 SET XMDUZ=DUZ
+10 SET XMTEXT="^XTMP(""SDES846P"","
+11 SET XMSUB=MESS1_"SD*5.3*846 - Post Install Data Report"
+12 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(XMDUZ)=""
+13 SET XMY("BARBER.LORI@DOMAIN.EXT")=""
+14 SET XMY("DILL.MATT@DOMAIN.EXT")=""
+15 SET XMY("REESE,DARRYL M@DOMAIN.EXT")=""
+16 SET XMY("DUNNAM.DAVID W@DOMAIN.EXT")=""
+17 DO ^XMD
+18 KILL TEXT
+19 QUIT
SELECTDATA ;Select appointments where the request is not for the appointment patient
+1 NEW APPTIEN,CHECKIN,CANCELDTTM,STARTTM,POP,CNT,PURGEDT,TEXTCNT
+2 NEW APPTREQINFO,APPTDFN,APPTREQTYP,REQPATDFN,REOPEN,NEWREQIEN
+3 SET PURGEDT=$$FMADD^XLFDT(DT,5)
+4 KILL ^XTMP("SDES846P")
+5 SET ^XTMP("SDES846P",0)=PURGEDT_"^"_DT_"^846 Post Install Data report"
+6 SET CNT=0
+7 SET TEXTCNT=1
+8 SET ^XTMP("SDES846P",TEXTCNT)="REQTYPE^REQIEN^REOPENED^APPTIEN^APPT DT/TM^APPT MADE^NEW REQIEN"
+9 SET STARTTM=$$FMADD^XLFDT(DT,-180)
+10 FOR
SET STARTTM=$ORDER(^SDEC(409.84,"B",STARTTM))
if (STARTTM="")
QUIT
Begin DoDot:1
+11 SET APPTIEN=""
+12 SET POP=0
+13 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"B",STARTTM,APPTIEN))
if (APPTIEN="")
QUIT
Begin DoDot:2
+14 SET CHECKIN=$$GET1^DIQ(409.84,APPTIEN_",",.03)
+15 SET CANCELDTTM=$$GET1^DIQ(409.84,APPTIEN_",",.12)
+16 SET POP=(CHECKIN'="")!(CANCELDTTM'="")
+17 if POP
QUIT
+18 ;Continue checking
+19 SET APPTDFN=$$GET1^DIQ(409.84,APPTIEN_",",.05,"I")
+20 SET APPTREQTYP=$$GET1^DIQ(409.84,APPTIEN_",",.22,"E")
+21 SET APPTREQINFO=$$GET1^DIQ(409.84,APPTIEN_",",.22,"I")
+22 if (APPTREQTYP="APPT")
DO APPT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,.CNT,.NEWREQIEN)
+23 if (APPTREQTYP="CONSULT")
DO CONSULT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,.CNT,.CONSULTIEN,.NEWREQIEN)
End DoDot:2
End DoDot:1
+24 SET TEXTCNT=TEXTCNT+1
+25 SET ^XTMP("SDES846P",TEXTCNT)="TOTAL = "_CNT
+26 SET ^XTMP("SDES846P",(TEXTCNT+1))="NOTE: -1 NEW REQIEN indicates no update made"
+27 DO MAIL2
+28 QUIT
+29 ;
APPT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,CNT,NEWREQIEN) ;gather information for appt request
+1 NEW REQIEN
+2 SET REQIEN=$PIECE(APPTREQINFO,";",1)
+3 SET REQPATDFN=$$GET1^DIQ(409.85,REQIEN_",",.01,"I")
+4 if APPTDFN=REQPATDFN
QUIT
+5 SET REOPEN=""
+6 DO DATACLEANUP(APPTDFN,APPTIEN,REQIEN,REQPATDFN,APPTREQTYP,"",.NEWREQIEN,.REOPEN)
+7 DO REPORT(REQIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,.CNT)
+8 ;
+9 QUIT
DATACLEANUP(APPTDFN,APPTIEN,REQIEN,REQPATDFN,APPTREQTYP,CONSULTIEN,NEWREQIEN,REOPEN) ;create appt request for patient on appointment and attach
+1 NEW SDDEMO,ARRAY,TODAY,REQSTAT,DISPOSITION,FDA,CONSTAT,RESCHED
+2 KILL FDA,SDDEMO,PRFLIST
+3 DO PDEMO^SDECU3(.SDDEMO,APPTDFN)
+4 SET ARRAY(2)=APPTDFN
+5 SET ARRAY(3)=$PIECE($$FMTONET^SDECDATE($$NOW^XLFDT),":")_":"_$PIECE($$FMTONET^SDECDATE($$NOW^XLFDT),":",2)
+6 SET ARRAY(5)="APPT"
+7 SET ARRAY(6)=$$GET1^DIQ(409.831,$$GET1^DIQ(409.84,APPTIEN_",",.07,"I")_",",.04,"I")
+8 SET ARRAY(7)=.5
+9 SET ARRAY(8)="ASAP"
+10 SET ARRAY(9)="PATIENT"
+11 SET ARRAY(11)=$$FMTE^XLFDT($$GET1^DIQ(409.84,APPTIEN_",",.2,"I"),"5D")
+12 SET ARRAY(12)="AUTO CREATED VIA SD*5.3*846 POST INSTALL TO CORRECT DATA ISSUE"
+13 SET ARRAY(13)=$GET(SDDEMO("PRIGRP"))
+14 SET ARRAY(14)="NO"
+15 SET ARRAY(15)=0
+16 SET ARRAY(16)=0
+17 SET ARRAY(18)=$GET(SDDEMO("SVCCONN"))
+18 SET ARRAY(19)=$GET(SDDEMO("SVCCONNP"))
+19 DO ARSET^SDECAR2(.RETN,.ARRAY)
+20 SET NEWREQIEN=$TRANSLATE($PIECE($PIECE(RETN,"^",2),"ERRORTEXT",2),$CHAR(30)_"_")
+21 if NEWREQIEN=-1
QUIT
+22 SET FDA(409.84,APPTIEN_",",.22)=NEWREQIEN_";SDEC(409.85,"
+23 ;update the appointment with the new request ien
DO FILE^DIE("","FDA")
+24 SET TODAY=$$FMTE^XLFDT(DT,"5D")
+25 KILL ARRAY
+26 SET ARRAY(1)=NEWREQIEN
+27 SET ARRAY(2)="REMOVED/SCHEDULED-ASSIGNED"
+28 SET ARRAY(3)=.5
+29 SET ARRAY(4)=TODAY
+30 SET ARRAY(5)=TODAY
+31 KILL RETN
+32 ;Close the request that was just attached to the appointment.
DO ARCLOSE^SDECAR(.RETN,.ARRAY)
+33 KILL ARRAY,RETN
+34 IF APPTREQTYP="APPT"
Begin DoDot:1
+35 SET REQSTAT=$$GET1^DIQ(409.85,REQIEN_",",23,"E")
+36 SET DISPOSITION=$$GET1^DIQ(409.85,REQIEN_",",21,"E")
+37 ;if request is open or dispositioned other than scheduled quit
if (DISPOSITION'="REMOVED/SCHEDULED-ASSIGNED")&(DISPOSITION'="")
QUIT
+38 SET RESCHED=$$RESCHEDULED(REQPATDFN,REQIEN)
+39 ;quit and do not reopen if already attached to the patient
if RESCHED
QUIT
+40 IF (REQSTAT="CLOSED")
Begin DoDot:2
+41 SET REOPEN="*"
+42 ;open the other patients request back up
DO AROPEN^SDECAR(.RETN,"",REQIEN,"")
End DoDot:2
End DoDot:1
+43 IF APPTREQTYP="CONSULT"
Begin DoDot:1
+44 SET CONSTAT=$$GET1^DIQ(123,CONSULTIEN,8,"E")
+45 IF CONSTAT="SCHEDULED"!(CONSTAT="COMPLETE")
Begin DoDot:2
+46 SET RESCHED=$$RESCHEDULED(REQPATDFN,CONSULTIEN)
+47 IF 'RESCHED
Begin DoDot:3
+48 SET REOPEN="*"
+49 DO OPENCONSULT(CONSULTIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
OPENCONSULT(CONSULTIEN) ;reopen consult if not already attached to appointment with correct patient
+1 ; SETUP REQUIRED VARIABLES THEN CALL THE FOLLOWING
+2 NEW PROVIEN,COMMENT,ORMSG
+3 SET COMMENT(1)="Auto reopened via SD*5.3*846 Post Install - consult originally attached to incorrect patient appointment."
+4 SET PROVIEN=$$GET1^DIQ(123,CONSULTIEN_",",10,"I")
+5 NEW SDERR
SET SDERR=$$STATUS^GMRCGUIS(CONSULTIEN,6,3,PROVIEN,"","",.COMMENT)
+6 QUIT
+7 ;
CONSULT(APPTREQINFO,APPTIEN,APPTDFN,APPTREQTYP,CNT,CONSULTIEN,NEWREQIEN) ;gather consult information
+1 NEW CONSULTIEN,CONSULTPATDFN,CONSULTPATIENT
+2 SET CONSULTIEN=$PIECE(APPTREQINFO,";",1)
+3 SET CONSULTPATDFN=$$GET1^DIQ(123,CONSULTIEN_",",.02,"I")
+4 if APPTDFN=CONSULTPATDFN
QUIT
+5 SET CONSULTPATIENT=$$GET1^DIQ(123,CONSULTIEN_",",.02,"E")
+6 ;
+7 SET REOPEN=""
+8 DO DATACLEANUP(APPTDFN,APPTIEN,"",CONSULTPATDFN,APPTREQTYP,CONSULTIEN,.NEWREQIEN,.REOPEN)
+9 DO REPORT(CONSULTIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,.CNT)
+10 QUIT
+11 ;
REPORT(REQIEN,APPTIEN,APPTREQTYP,NEWREQIEN,REOPEN,CNT) ;report of data cleanup
+1 SET CNT=CNT+1
+2 SET TEXTCNT=TEXTCNT+1
+3 SET ^XTMP("SDES846P",TEXTCNT)=APPTREQTYP_"^`"_REQIEN_"^"_REOPEN_"^`"_APPTIEN_"^"_$$GET1^DIQ(409.84,APPTIEN_",",.01,"E")_"^"_$$GET1^DIQ(409.84,APPTIEN_",",.09,"E")_"^"_NEWREQIEN
+4 QUIT
+5 ;
RESCHEDULED(DFN,APPTREQINFO) ;check to see if the request is already attached to another appointment
+1 NEW DTLOOP,CHECKAPTIEN,CHKREQ,RESCHED,DATECANCELLED,DATENOSHOWED
+2 if DFN=""
QUIT 0
+3 SET RESCHED=0
+4 SET DTLOOP=0
FOR
SET DTLOOP=$ORDER(^SDEC(409.84,"APTDT",DFN,DTLOOP))
if 'DTLOOP
QUIT
Begin DoDot:1
+5 SET CHECKAPTIEN=0
FOR
SET CHECKAPTIEN=$ORDER(^SDEC(409.84,"APTDT",DFN,DTLOOP,CHECKAPTIEN))
if 'CHECKAPTIEN
QUIT
Begin DoDot:2
+6 ; only records that point to the same request
+7 SET CHKREQ=$PIECE($$GET1^DIQ(409.84,CHECKAPTIEN,.22,"I"),";")
+8 IF CHKREQ'=APPTREQINFO
QUIT
+9 ; cancellation date/time
+10 SET DATECANCELLED=$$GET1^DIQ(409.84,CHECKAPTIEN,.12,"I")
+11 ; no-show date/time
+12 SET DATENOSHOWED=$$GET1^DIQ(409.84,CHECKAPTIEN,.1,"I")
+13 IF 'DATECANCELLED&'DATENOSHOWED
SET RESCHED=CHECKAPTIEN
End DoDot:2
End DoDot:1
+14 if ('RESCHED)
QUIT 0
+15 QUIT 1
+16 ;
TASK3 ; Disposition old Appointment Requests
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*846 Post-Install to fix Disposition records")
+3 DO MES^XPDUTL(" in the SDEC APPT REQUEST (#409.85) file is being")
+4 DO MES^XPDUTL(" queued to run in the background. Once it finishes")
+5 DO MES^XPDUTL(" a MailMan message will be sent to the installer to")
+6 DO MES^XPDUTL(" provide them a job completion status and data summary.")
+7 DO MES^XPDUTL("")
+8 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+9 SET ZTDESC="SD*5.3*846 Post Install Routine"
+10 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="DISP^SDES846P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+11 IF $DATA(ZTSK)
Begin DoDot:1
+12 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+13 DO MES^XPDUTL("")
End DoDot:1
+14 IF '$DATA(ZTSK)
Begin DoDot:1
+15 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+16 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+17 QUIT
+18 ;
DISP ; Disposition old Appointment Requests
+1 NEW APPTIEN,ARIEN,CANCREAS,DATA0,DATA2,DISP,DISPIEN,FDA,IEN627,REOPEN,STARTTIME,TCNT
+2 SET TCNT=0
+3 SET IEN627=$$FIND1^DIC(9.7,"","X","SD*5.3*627","B","","ERROR")
+4 ; Quit if this site had the 627 install record and has already run this logic
+5 IF IEN627
Begin DoDot:1
+6 SET TEXT(1)="This sites Disposition records were reviewed and fixed by the"
+7 SET TEXT(2)="SD*5.3*842 post install routine."
+8 SET TEXT(3)="Nothing else needs to be done."
+9 DO MAIL
End DoDot:1
QUIT
+10 ;
+11 SET DISPIEN=$$FIND1^DIC(409.853,"","X","CANCELLED NOT RE-OPENED","B","","ERROR")
+12 IF 'DISPIEN
Begin DoDot:1
+13 SET TEXT(1)="The CANCELLED NOT RE-OPENED Disposition Reason could not be found"
+14 SET TEXT(2)="in the SDEC DISPOSITION REASON (#409.853) file. Please contact the"
+15 SET TEXT(3)="National Help Desk to report this issue."
+16 DO MAIL
End DoDot:1
QUIT
+17 ;
+18 ;Compliance Date for SD*5.3*627 = MAY 05, 2017
SET STARTTIME=3170505
+19 SET STARTTIME=STARTTIME-.000001
+20 FOR
SET STARTTIME=$ORDER(^SDEC(409.84,"B",STARTTIME))
if 'STARTTIME
QUIT
Begin DoDot:1
+21 SET APPTIEN=""
+22 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"B",STARTTIME,APPTIEN))
if 'APPTIEN
QUIT
Begin DoDot:2
+23 SET DATA0=$GET(^SDEC(409.84,APPTIEN,0))
+24 ; Quit is this appt is NOT cancelled
+25 SET CANCREAS=$PIECE(DATA0,U,22)
+26 if 'CANCREAS
QUIT
+27 ; Quit it Appt Req should NOT be re-opened
+28 SET REOPEN=$$GET1^DIQ(409.2,CANCREAS,5,"I")
+29 ; 1=re-open 0=don't re-open
if REOPEN
QUIT
+30 ; Quit if this appointment doesn't point back to #409.85
+31 SET DATA2=$PIECE($GET(^SDEC(409.84,APPTIEN,2)),"^",1)
+32 if DATA2'["409.85"
QUIT
+33 SET ARIEN=$PIECE(DATA2,";",1)
+34 if 'ARIEN
QUIT
+35 if '$DATA(^SDEC(409.85,ARIEN))
QUIT
+36 ; Quit if this Appt Req has already been Dispositioned
+37 if $PIECE($GET(^SDEC(409.85,ARIEN,"DIS")),U,3)
QUIT
+38 ; Set Disposition fields for update
+39 ; FIX TO JUST BE A DATE
SET FDA(409.85,ARIEN_",",19)=$PIECE($$GET1^DIQ(409.84,APPTIEN,.12,"I"),".",1)
+40 SET FDA(409.85,ARIEN_",",20)=$$GET1^DIQ(409.84,APPTIEN,.121,"I")
+41 SET FDA(409.85,ARIEN_",",21)=DISPIEN
+42 DO FILE^DIE("","FDA","ERR84")
+43 IF '$DATA(ERR84)
SET TCNT=TCNT+1
+44 KILL FDA,ERR84
End DoDot:2
End DoDot:1
+45 SET TEXT(1)="The SD*5.3*846 post install has run to completion."
+46 SET TEXT(2)="The data was reviewed and updated without any issues."
+47 SET TEXT(3)="Total Appoint Requests updated: "_TCNT
+48 DO MAIL
+49 QUIT
+50 ;
MAIL ;
+1 ; Get Station Number
+2 ;
+3 NEW STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
+4 SET STANUM=$$KSP^XUPARAM("INST")_","
+5 SET STANUM=$$GET1^DIQ(4,STANUM,99)
+6 SET MESS1="Station: "_STANUM_" - "
+7 ;
+8 ; Send MailMan message
+9 SET XMDUZ=DUZ
+10 SET XMTEXT="TEXT("
+11 SET XMSUB=MESS1_"SD*5.3*846 - Post Install Update"
+12 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(XMDUZ)=""
+13 DO ^XMD
+14 KILL TEXT
+15 QUIT
