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 ---[H[J[2J[HVPRP16 1688 printed Dec 13, 2024@02:45:31 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
