SD53P859 ;BAH/DF,GN - SD*5.3*859 Post Init Routine ;Aug 8, 2023
;;5.3;Scheduling;**859**;Aug 13, 1993;Build 10
;
; load new Stop codes to the SD TELE HEALTH STOP CODE FILE #40.6.
; cleanup of the SDEC APPT REQUEST file (#409.85).
; *** post install can be rerun with no harm ***
;
Q
EN ; entry point
N ERRCNT,FDA,SDIEN,ERR,STP,DA,DIK
S ERRCNT=0
D MES^XPDUTL("")
D MES^XPDUTL("Updating of SD TELE HEALTH STOP CODE FILE...")
;Add new codes
D MES^XPDUTL("") H 1
F STP=129,569 D
. I $O(^SD(40.6,"B",STP,"")) D MES^XPDUTL(STP_" already on file") Q
. I '$$CHKSTOP^SDTMPEDT(STP) D MES^XPDUTL(STP_" ** Not added, invalid stop code") Q
. S FDA(40.6,"+1,",.01)=STP D UPDATE^DIE("","FDA","SDIEN","ERR")
. D:'$D(ERR) MES^XPDUTL(STP_" added stop code")
. I $D(ERR) D MES^XPDUTL(STP_" failed an attempt to add to the file.") S ERRCNT=ERRCNT+1
. K FDA,SDIEN,ERR
;Delete removed codes
S DIK="^SD(40.6,"
F STP=290:1:293,296,297,573 D
. S DA=$O(^SD(40.6,"B",STP,""))
. I 'DA D MES^XPDUTL(STP_" already deleted") Q
. D ^DIK
. D MES^XPDUTL(STP_" deleted")
D MES^XPDUTL("")
D MES^XPDUTL("Stop Code Update completed. "_ERRCNT_" error(s) found.")
D MES^XPDUTL("") H 2
D CLEANUP
Q
;
CLEANUP ; *** Begin cleanup utility ***
; TMP had stored in an IEN in the PARENT REQUEST field (#43.8) and this field is reserved for MRTC appts made by VSE.
; This utility will follow the logic below to find and erase erroneous Parent ptr fields, so VSE can once again Cancel those appointments normally.
N DFN,PARENT,CHILD,MRTC,FIX,TOT,QQ,RR
S (FIX,TOT)=0
D MES^XPDUTL("")
D MES^XPDUTL("Correcting the SDEC APPT REQUEST file...")
D MES^XPDUTL("")
D MES^XPDUTL(" An email with the results of this cleanup will be sent to the installer ")
D MES^XPDUTL(" Please forward this email to the Schedulers for their awareness.")
D MES^XPDUTL("") H 4
;
S QQ=$$FMADD^XLFDT(DT,-730) ;start look back 2 years
F S QQ=$O(^SDEC(409.85,"AC",QQ)) Q:'QQ D
. F RR=0:0 S RR=$O(^SDEC(409.85,"AC",QQ,RR)) Q:'RR D
.. F CHILD=0:0 S CHILD=$O(^SDEC(409.85,"AC",QQ,RR,CHILD)) Q:'CHILD D
... S TOT=TOT+1
... S MRTC=$P($G(^SDEC(409.85,CHILD,3)),U) ;mrtc ind
... S PARENT=$P($G(^SDEC(409.85,CHILD,3)),U,5) ;parent ptr
... I 'MRTC,PARENT D ;child mrtc ind is 0 and child had parent ptr ?Rec in error?
.... S DFN=$$GET1^DIQ(409.85,CHILD,.01,"I")
.... I '$D(^SDEC(409.85,PARENT)) D ERASE ;error if child points to non-existent parent, erase parent ptr
.... I $D(^SDEC(409.85,PARENT)) D
..... I '$D(^SDEC(409.85,PARENT,2,"B",CHILD)) D ERASE ;error if child points to an existing parent & parent does not reference child, erase parent ptr
S ^TMP("SDTMP",$J)=FIX
D SNDMAIL
D MES^XPDUTL("")
D MES^XPDUTL("Update completed. Records examined: "_TOT)
D MES^XPDUTL(" Records fixed: "_FIX)
D MES^XPDUTL("") H 1
Q
;
ERASE ;erase parent ptr field from this rec
N FDA,LSTNAM1,SSN4,APPDT,CIDDT
S FIX=FIX+1
S FDA(409.85,CHILD_",",43.8)="@" D UPDATE^DIE("","FDA","ERR") ;erase parent field data
;build text line for mailman msg
S LSTNAM1=$E($$GET1^DIQ(2,DFN,"NAME"),1,1)
S SSN4=$E($$GET1^DIQ(2,DFN,"SSN"),6,9)
S APPDT=$$GET1^DIQ(409.85,CHILD,"SCHEDULED DATE OF APPT","I")
S CIDDT=$$GET1^DIQ(409.85,CHILD,"CID/PREFERRED DATE OF APPT","I")
W !,CHILD,?20,CIDDT
S ^TMP("SDTMP",$J,FIX+3)="Patient: "_LSTNAM1_SSN4_$S('APPDT:" Req CID: "_$$FMTE^XLFDT(CIDDT),1:" Appt: "_$$FMTE^XLFDT(APPDT))_" has been fixed."
Q
;
SNDMAIL ;send mailman to installer
N XMSUB,XMY,XMTEXT,XMDUZ
S ^TMP("SDTMP",$J,1)="Patient appointment date/times that were fixed are now accessible by VSE."
S ^TMP("SDTMP",$J,3)=""
I ^TMP("SDTMP",$J)=0 S ^TMP("SDTMP",$J,4)="** No Appointment Request Records found that needed repair."
S XMSUB="SD TMP cleanup of MRTC parent field in SDEC APPT REQUEST file #409.85"
S XMDUZ=.5
S XMTEXT="^TMP(""SDTMP"",$J,"
S XMY(DUZ)=""
N DIFROM D ^XMD K ^TMP("SDTMP",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53P859 4052 printed Dec 13, 2024@02:46:46 Page 2
SD53P859 ;BAH/DF,GN - SD*5.3*859 Post Init Routine ;Aug 8, 2023
+1 ;;5.3;Scheduling;**859**;Aug 13, 1993;Build 10
+2 ;
+3 ; load new Stop codes to the SD TELE HEALTH STOP CODE FILE #40.6.
+4 ; cleanup of the SDEC APPT REQUEST file (#409.85).
+5 ; *** post install can be rerun with no harm ***
+6 ;
+7 QUIT
EN ; entry point
+1 NEW ERRCNT,FDA,SDIEN,ERR,STP,DA,DIK
+2 SET ERRCNT=0
+3 DO MES^XPDUTL("")
+4 DO MES^XPDUTL("Updating of SD TELE HEALTH STOP CODE FILE...")
+5 ;Add new codes
+6 DO MES^XPDUTL("")
HANG 1
+7 FOR STP=129,569
Begin DoDot:1
+8 IF $ORDER(^SD(40.6,"B",STP,""))
DO MES^XPDUTL(STP_" already on file")
QUIT
+9 IF '$$CHKSTOP^SDTMPEDT(STP)
DO MES^XPDUTL(STP_" ** Not added, invalid stop code")
QUIT
+10 SET FDA(40.6,"+1,",.01)=STP
DO UPDATE^DIE("","FDA","SDIEN","ERR")
+11 if '$DATA(ERR)
DO MES^XPDUTL(STP_" added stop code")
+12 IF $DATA(ERR)
DO MES^XPDUTL(STP_" failed an attempt to add to the file.")
SET ERRCNT=ERRCNT+1
+13 KILL FDA,SDIEN,ERR
End DoDot:1
+14 ;Delete removed codes
+15 SET DIK="^SD(40.6,"
+16 FOR STP=290:1:293,296,297,573
Begin DoDot:1
+17 SET DA=$ORDER(^SD(40.6,"B",STP,""))
+18 IF 'DA
DO MES^XPDUTL(STP_" already deleted")
QUIT
+19 DO ^DIK
+20 DO MES^XPDUTL(STP_" deleted")
End DoDot:1
+21 DO MES^XPDUTL("")
+22 DO MES^XPDUTL("Stop Code Update completed. "_ERRCNT_" error(s) found.")
+23 DO MES^XPDUTL("")
HANG 2
+24 DO CLEANUP
+25 QUIT
+26 ;
CLEANUP ; *** Begin cleanup utility ***
+1 ; TMP had stored in an IEN in the PARENT REQUEST field (#43.8) and this field is reserved for MRTC appts made by VSE.
+2 ; This utility will follow the logic below to find and erase erroneous Parent ptr fields, so VSE can once again Cancel those appointments normally.
+3 NEW DFN,PARENT,CHILD,MRTC,FIX,TOT,QQ,RR
+4 SET (FIX,TOT)=0
+5 DO MES^XPDUTL("")
+6 DO MES^XPDUTL("Correcting the SDEC APPT REQUEST file...")
+7 DO MES^XPDUTL("")
+8 DO MES^XPDUTL(" An email with the results of this cleanup will be sent to the installer ")
+9 DO MES^XPDUTL(" Please forward this email to the Schedulers for their awareness.")
+10 DO MES^XPDUTL("")
HANG 4
+11 ;
+12 ;start look back 2 years
SET QQ=$$FMADD^XLFDT(DT,-730)
+13 FOR
SET QQ=$ORDER(^SDEC(409.85,"AC",QQ))
if 'QQ
QUIT
Begin DoDot:1
+14 FOR RR=0:0
SET RR=$ORDER(^SDEC(409.85,"AC",QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+15 FOR CHILD=0:0
SET CHILD=$ORDER(^SDEC(409.85,"AC",QQ,RR,CHILD))
if 'CHILD
QUIT
Begin DoDot:3
+16 SET TOT=TOT+1
+17 ;mrtc ind
SET MRTC=$PIECE($GET(^SDEC(409.85,CHILD,3)),U)
+18 ;parent ptr
SET PARENT=$PIECE($GET(^SDEC(409.85,CHILD,3)),U,5)
+19 ;child mrtc ind is 0 and child had parent ptr ?Rec in error?
IF 'MRTC
IF PARENT
Begin DoDot:4
+20 SET DFN=$$GET1^DIQ(409.85,CHILD,.01,"I")
+21 ;error if child points to non-existent parent, erase parent ptr
IF '$DATA(^SDEC(409.85,PARENT))
DO ERASE
+22 IF $DATA(^SDEC(409.85,PARENT))
Begin DoDot:5
+23 ;error if child points to an existing parent & parent does not reference child, erase parent ptr
IF '$DATA(^SDEC(409.85,PARENT,2,"B",CHILD))
DO ERASE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET ^TMP("SDTMP",$JOB)=FIX
+25 DO SNDMAIL
+26 DO MES^XPDUTL("")
+27 DO MES^XPDUTL("Update completed. Records examined: "_TOT)
+28 DO MES^XPDUTL(" Records fixed: "_FIX)
+29 DO MES^XPDUTL("")
HANG 1
+30 QUIT
+31 ;
ERASE ;erase parent ptr field from this rec
+1 NEW FDA,LSTNAM1,SSN4,APPDT,CIDDT
+2 SET FIX=FIX+1
+3 ;erase parent field data
SET FDA(409.85,CHILD_",",43.8)="@"
DO UPDATE^DIE("","FDA","ERR")
+4 ;build text line for mailman msg
+5 SET LSTNAM1=$EXTRACT($$GET1^DIQ(2,DFN,"NAME"),1,1)
+6 SET SSN4=$EXTRACT($$GET1^DIQ(2,DFN,"SSN"),6,9)
+7 SET APPDT=$$GET1^DIQ(409.85,CHILD,"SCHEDULED DATE OF APPT","I")
+8 SET CIDDT=$$GET1^DIQ(409.85,CHILD,"CID/PREFERRED DATE OF APPT","I")
+9 WRITE !,CHILD,?20,CIDDT
+10 SET ^TMP("SDTMP",$JOB,FIX+3)="Patient: "_LSTNAM1_SSN4_$SELECT('APPDT:" Req CID: "_$$FMTE^XLFDT(CIDDT),1:" Appt: "_$$FMTE^XLFDT(APPDT))_" has been fixed."
+11 QUIT
+12 ;
SNDMAIL ;send mailman to installer
+1 NEW XMSUB,XMY,XMTEXT,XMDUZ
+2 SET ^TMP("SDTMP",$JOB,1)="Patient appointment date/times that were fixed are now accessible by VSE."
+3 SET ^TMP("SDTMP",$JOB,3)=""
+4 IF ^TMP("SDTMP",$JOB)=0
SET ^TMP("SDTMP",$JOB,4)="** No Appointment Request Records found that needed repair."
+5 SET XMSUB="SD TMP cleanup of MRTC parent field in SDEC APPT REQUEST file #409.85"
+6 SET XMDUZ=.5
+7 SET XMTEXT="^TMP(""SDTMP"",$J,"
+8 SET XMY(DUZ)=""
+9 NEW DIFROM
DO ^XMD
KILL ^TMP("SDTMP",$JOB)
+10 QUIT
