VPRP16.m

VPRP16 ;SLC/MKB -- SDA utilities for patch 16 ;11/8/18  14:11

 ;;1.0;VIRTUAL PATIENT RECORD;**16**;Sep 01, 2011;Build 3

 ;;Per VHA Directive 6402, this routine should not be modified.

 ;

 ; External References          DBIA#

 ; -------------------          -----

 ; %ZTLOAD                      10063

 ; XLFDT                        10103

 ; XPDUTL                       10141

 ; XUPROD                        4440

 ;

 ;

POST ; -- postinit tasks

 D TASK

 Q

 ;

TASK ; -- task job to clean up ^VPR

 I '$$PROD^XUPROD D MES^XPDUTL("No task queued: not a production system") Q

 I '$D(^VPR("AVPR")),'$D(^VPR("ANEW")) D MES^XPDUTL("No task queued: no entries in update lists.") Q

 ;

 N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK

 S ZTRTN="LIST^VPRP16",ZTDTH=$$NOW^XLFDT,ZTIO=""

 S ZTDESC="Remove test patients from VPR update lists"

 D ^%ZTLOAD I '$G(ZTSK) D MES^XPDUTL("Unable to queue clean up task.") Q

 D MES^XPDUTL("Task #"_ZTSK_" was queued to clean up ^VPR")

 Q

 ;

LIST ; -- clean up ^VPR update lists for TEST and MERGED patients

 N DFN,SEQ,TYPE,ID

 ;

 S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:DFN<1  D

 . I '$D(^VPR(1,2,DFN)) Q  ;not subscribed

 . I '$$TESTPAT^VADPT(DFN),'$$MERGED^VPRHS(DFN) Q  ;ok

 . ; remove entries for test or merged patients

 . D ANEW,AVPR

 Q

 ;

ANEW ; ANEW = new subscribe

 S SEQ=$G(^VPR(1,2,DFN,"ANEW"))

 I SEQ K ^VPR("ANEW",SEQ,DFN),^VPR(1,2,DFN,"ANEW")

 Q

 ;

AVPR ; AVPR = data updates

 S TYPE="" F  S TYPE=$O(^VPR(1,2,DFN,"AVPR",TYPE)) Q:TYPE=""  D

 . S ID="" F  S ID=$O(^VPR(1,2,DFN,"AVPR",TYPE,ID)) Q:ID=""  S SEQ=+$G(^(ID)) D

 .. K ^VPR("AVPR",SEQ,DFN)

 .. K ^VPR(1,2,DFN,"AVPR",TYPE,ID)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VPRP16   1688     printed  Mar 13, 2025@21:50:33                                                                                                                                                                                                      Page 2

VPRP16    ;SLC/MKB -- SDA utilities for patch 16 ;11/8/18  14:11

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**16**;Sep 01, 2011;Build 3

 +2       ;;Per VHA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; %ZTLOAD                      10063

 +7       ; XLFDT                        10103

 +8       ; XPDUTL                       10141

 +9       ; XUPROD                        4440

 +10      ;

 +11      ;

POST      ; -- postinit tasks

 +1        DO TASK

 +2        QUIT 

 +3       ;

TASK      ; -- task job to clean up ^VPR

 +1        IF '$$PROD^XUPROD

               DO MES^XPDUTL("No task queued: not a production system")

               QUIT 

 +2        IF '$DATA(^VPR("AVPR"))

               IF '$DATA(^VPR("ANEW"))

                   DO MES^XPDUTL("No task queued: no entries in update lists.")

                   QUIT 

 +3       ;

 +4        NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK

 +5        SET ZTRTN="LIST^VPRP16"

           SET ZTDTH=$$NOW^XLFDT

           SET ZTIO=""

 +6        SET ZTDESC="Remove test patients from VPR update lists"

 +7        DO ^%ZTLOAD

           IF '$GET(ZTSK)

               DO MES^XPDUTL("Unable to queue clean up task.")

               QUIT 

 +8        DO MES^XPDUTL("Task #"_ZTSK_" was queued to clean up ^VPR")

 +9        QUIT 

 +10      ;

LIST      ; -- clean up ^VPR update lists for TEST and MERGED patients

 +1        NEW DFN,SEQ,TYPE,ID

 +2       ;

 +3        SET DFN=0

           FOR 

               SET DFN=$ORDER(^DPT(DFN))

               if DFN<1

                   QUIT 

               Begin DoDot:1

 +4       ;not subscribed

                   IF '$DATA(^VPR(1,2,DFN))

                       QUIT 

 +5       ;ok

                   IF '$$TESTPAT^VADPT(DFN)

                       IF '$$MERGED^VPRHS(DFN)

                           QUIT 

 +6       ; remove entries for test or merged patients

 +7                DO ANEW

                   DO AVPR

               End DoDot:1

 +8        QUIT 

 +9       ;

ANEW      ; ANEW = new subscribe

 +1        SET SEQ=$GET(^VPR(1,2,DFN,"ANEW"))

 +2        IF SEQ

               KILL ^VPR("ANEW",SEQ,DFN),^VPR(1,2,DFN,"ANEW")

 +3        QUIT 

 +4       ;

AVPR      ; AVPR = data updates

 +1        SET TYPE=""

           FOR 

               SET TYPE=$ORDER(^VPR(1,2,DFN,"AVPR",TYPE))

               if TYPE=""

                   QUIT 

               Begin DoDot:1

 +2                SET ID=""

                   FOR 

                       SET ID=$ORDER(^VPR(1,2,DFN,"AVPR",TYPE,ID))

                       if ID=""

                           QUIT 

                       SET SEQ=+$GET(^(ID))

                       Begin DoDot:2

 +3                        KILL ^VPR("AVPR",SEQ,DFN)

 +4                        KILL ^VPR(1,2,DFN,"AVPR",TYPE,ID)

                       End DoDot:2

               End DoDot:1

 +5        QUIT