Routine: SD686PST

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

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")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD686PST   3892     printed  Apr 23, 2025@19:01:23                                                                                                                                                                                                    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       ;

SD686PST.m