SD686PST ; ALB/SAT - SD*5.3*686 POST-INSTALL ;
;;5.3;Scheduling;**686**;Aug 13, 1993;Build 53
;;Per VHA Directive 2004-038, this routine should not be modified
;
; Post-install routine for patch 686. Identifies data errors in scheduling request files (#403.5, 409.3, 123, 409.85).
;
D EXECUTE ;
D AD
Q
;
EXECUTE ;
;
K ^TMP($J) ;
;
N DA,I,FND,XMZ,LINE,X,SENDMSG ;
S SENDMSG=0 ;
W !,"Checking for data errors",! ;
;
; Check for missing patient pointers in Request/Consultation (#123) file
;
W !,"Consults..." ;
S LINE=1,^TMP($J,"SDEC",LINE)="Records in consult file (#123) with null patient pointers (field #.02)" ;
S DA=0,FND=0 F I=1:1 S DA=$O(^GMR(123,DA)) Q:'DA W:I#1000=0 "." S X=$G(^(DA,0)) D ;
. I $P(X,"^",2)="" S FND=1,LINE=LINE+1,^TMP($J,"SDEC",LINE)="Null patient pointer (field #.02) in record "_DA ;
;
I 'FND S LINE=LINE+1,^TMP($J,"SDEC",LINE)="NONE FOUND" ;
E S SENDMSG=1 ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
;
; Check for bad dates in Recall Reminders file (#403.5)
;
W !,"Recall Reminders..." ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)="Records in recall reminders file (#403.5) with imprecise dates (fields #5 and #5.5)" ;
S DA=0,FND=0 F I=1:1 S DA=$O(^SD(403.5,DA)) Q:'DA W:I#1000=0 "." S X=$G(^(DA,0)) D ;
. I $P(X,"^",6)?5N1"00" S FND=1,LINE=LINE+1,^TMP($J,"SDEC",LINE)="Recall Date (#5) incorrect in record "_DA ;
. I $P(X,"^",12)?5N1"00" S FND=1,LINE=LINE+1,^TMP($J,"SDEC",LINE)="Recall Date Per Patient (#5.5) incorrect in record "_DA ;
;
I 'FND S LINE=LINE+1,^TMP($J,"SDEC",LINE)="NONE FOUND" ;
E S SENDMSG=1 ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
;
; Check for bad dates in Wait List file (#409.3)
;
W !,"Wait List..." ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)="Records in wait list file (#409.3) with imprecise dates (field #22)" ;
S DA=0,FND=0 F I=1:1 S DA=$O(^SDWL(409.3,DA)) Q:'DA W:I#1000=0 "." S X=$G(^(DA,0)) D ;
. I $P(X,"^",16)?5N1"00" S FND=1,LINE=LINE+1,^TMP($J,"SDEC",LINE)="Desired Date of Appointment (#22) incorrect in record "_DA ;
;
I 'FND S LINE=LINE+1,^TMP($J,"SDEC",LINE)="NONE FOUND" ;
E S SENDMSG=1 ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
;
; Check for bad dates in Appointment Request file (#409.85)
;
W !,"Appointment Request..." ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)="Records in appointment request file (#409.85) with imprecise dates" ;
S DA=0,FND=0 F I=1:1 S DA=$O(^SDEC(409.85,DA)) Q:'DA W:I#1000=0 "." S X=$G(^(DA,0)) D ;
. I $P(X,"^",16)?5N1"00" S FND=1,LINE=LINE+1,^TMP($J,"SDEC",LINE)="CID/Preferred Date of Appointment (#22) incorrect in record "_DA ;
;
I 'FND S LINE=LINE+1,^TMP($J,"SDEC",LINE)="NONE FOUND" ;
E S SENDMSG=1 ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
S LINE=LINE+1,^TMP($J,"SDEC",LINE)=" " ;
;
; Send e-mail message with database errors listed.
;
I SENDMSG D ;
. ;
. N XMTO ;
. S XMTO(DUZ)="" ; ,XMTO("Outlook e-mail address")="" ; <<== Tested with Outlook e-mail address (e.g., xxx.yyy@domain.ext). Add e-mail address of Outlook group if needed. wtc 9/6/2019
. D SENDMSG^XMXAPI(DUZ,"Patch #686 - Database errors","^TMP($J,""SDEC"")",.XMTO,,.XMZ) ;
. ;
. W !,"A MailMan message has been sent to you containing a list of the database errors found. Please forward the message to your IRM representative.",! ;
;
K ^TMP($J) ;
Q ;
;
AD ;build AD cross-reference for patient contacts
W !,"Building AD cross-reference for SDEC CONTACT file (#409.86)..."
I $D(^SDEC(409.86,"AD")) W !,"Cross-reference data already exists, aborting." Q
N SDXREF
S SDXREF=$O(^DD("IX","BB",409.86,"AD",""))
I SDXREF="" W !,"Cross-reference definition missing, aborting." Q
D INDEX^DIKC(409.86,"","",SDXREF,"KSW409.863")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD686PST 3892 printed Apr 09, 2024@21:41:37 Page 2
SD686PST ; ALB/SAT - SD*5.3*686 POST-INSTALL ;
+1 ;;5.3;Scheduling;**686**;Aug 13, 1993;Build 53
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; Post-install routine for patch 686. Identifies data errors in scheduling request files (#403.5, 409.3, 123, 409.85).
+5 ;
+6 ;
DO EXECUTE
+7 DO AD
+8 QUIT
+9 ;
EXECUTE ;
+1 ;
+2 ;
KILL ^TMP($JOB)
+3 ;
+4 ;
NEW DA,I,FND,XMZ,LINE,X,SENDMSG
+5 ;
SET SENDMSG=0
+6 ;
WRITE !,"Checking for data errors",!
+7 ;
+8 ; Check for missing patient pointers in Request/Consultation (#123) file
+9 ;
+10 ;
WRITE !,"Consults..."
+11 ;
SET LINE=1
SET ^TMP($JOB,"SDEC",LINE)="Records in consult file (#123) with null patient pointers (field #.02)"
+12 ;
SET DA=0
SET FND=0
FOR I=1:1
SET DA=$ORDER(^GMR(123,DA))
if 'DA
QUIT
if I#1000=0
WRITE "."
SET X=$GET(^(DA,0))
Begin DoDot:1
+13 ;
IF $PIECE(X,"^",2)=""
SET FND=1
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Null patient pointer (field #.02) in record "_DA
End DoDot:1
+14 ;
+15 ;
IF 'FND
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="NONE FOUND"
+16 ;
IF '$TEST
SET SENDMSG=1
+17 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+18 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+19 ;
+20 ; Check for bad dates in Recall Reminders file (#403.5)
+21 ;
+22 ;
WRITE !,"Recall Reminders..."
+23 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Records in recall reminders file (#403.5) with imprecise dates (fields #5 and #5.5)"
+24 ;
SET DA=0
SET FND=0
FOR I=1:1
SET DA=$ORDER(^SD(403.5,DA))
if 'DA
QUIT
if I#1000=0
WRITE "."
SET X=$GET(^(DA,0))
Begin DoDot:1
+25 ;
IF $PIECE(X,"^",6)?5N1"00"
SET FND=1
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Recall Date (#5) incorrect in record "_DA
+26 ;
IF $PIECE(X,"^",12)?5N1"00"
SET FND=1
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Recall Date Per Patient (#5.5) incorrect in record "_DA
End DoDot:1
+27 ;
+28 ;
IF 'FND
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="NONE FOUND"
+29 ;
IF '$TEST
SET SENDMSG=1
+30 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+31 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+32 ;
+33 ; Check for bad dates in Wait List file (#409.3)
+34 ;
+35 ;
WRITE !,"Wait List..."
+36 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Records in wait list file (#409.3) with imprecise dates (field #22)"
+37 ;
SET DA=0
SET FND=0
FOR I=1:1
SET DA=$ORDER(^SDWL(409.3,DA))
if 'DA
QUIT
if I#1000=0
WRITE "."
SET X=$GET(^(DA,0))
Begin DoDot:1
+38 ;
IF $PIECE(X,"^",16)?5N1"00"
SET FND=1
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Desired Date of Appointment (#22) incorrect in record "_DA
End DoDot:1
+39 ;
+40 ;
IF 'FND
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="NONE FOUND"
+41 ;
IF '$TEST
SET SENDMSG=1
+42 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+43 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+44 ;
+45 ; Check for bad dates in Appointment Request file (#409.85)
+46 ;
+47 ;
WRITE !,"Appointment Request..."
+48 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="Records in appointment request file (#409.85) with imprecise dates"
+49 ;
SET DA=0
SET FND=0
FOR I=1:1
SET DA=$ORDER(^SDEC(409.85,DA))
if 'DA
QUIT
if I#1000=0
WRITE "."
SET X=$GET(^(DA,0))
Begin DoDot:1
+50 ;
IF $PIECE(X,"^",16)?5N1"00"
SET FND=1
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="CID/Preferred Date of Appointment (#22) incorrect in record "_DA
End DoDot:1
+51 ;
+52 ;
IF 'FND
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)="NONE FOUND"
+53 ;
IF '$TEST
SET SENDMSG=1
+54 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+55 ;
SET LINE=LINE+1
SET ^TMP($JOB,"SDEC",LINE)=" "
+56 ;
+57 ; Send e-mail message with database errors listed.
+58 ;
+59 ;
IF SENDMSG
Begin DoDot:1
+60 ;
+61 ;
NEW XMTO
+62 ; ,XMTO("Outlook e-mail address")="" ; <<== Tested with Outlook e-mail address (e.g., xxx.yyy@domain.ext). Add e-mail address of Outlook group if needed. wtc 9/6/2019
SET XMTO(DUZ)=""
+63 ;
DO SENDMSG^XMXAPI(DUZ,"Patch #686 - Database errors","^TMP($J,""SDEC"")",.XMTO,,.XMZ)
+64 ;
+65 ;
WRITE !,"A MailMan message has been sent to you containing a list of the database errors found. Please forward the message to your IRM representative.",!
End DoDot:1
+66 ;
+67 ;
KILL ^TMP($JOB)
+68 ;
QUIT
+69 ;
AD ;build AD cross-reference for patient contacts
+1 WRITE !,"Building AD cross-reference for SDEC CONTACT file (#409.86)..."
+2 IF $DATA(^SDEC(409.86,"AD"))
WRITE !,"Cross-reference data already exists, aborting."
QUIT
+3 NEW SDXREF
+4 SET SDXREF=$ORDER(^DD("IX","BB",409.86,"AD",""))
+5 IF SDXREF=""
WRITE !,"Cross-reference definition missing, aborting."
QUIT
+6 DO INDEX^DIKC(409.86,"","",SDXREF,"KSW409.863")
+7 QUIT
+8 ;
