VPRP15 ;SLC/MKB -- SDA utilities for patch 15 ;11/8/18 14:11
;;1.0;VIRTUAL PATIENT RECORD;**15**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; XUSAP 4677
;
;
POST ; -- postinit tasks
D PRXY,TASK
Q
;
PRXY ; -- create proxy user
I '$O(^VA(200,"B","VPRVDIF,APPLICATION PROXY",0)) D
. N X S X=$$CREATE^XUSAP("VPRVDIF,APPLICATION PROXY","")
Q
;
TASK ; -- task job to clean up ^VPR
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^VPRP15",ZTDTH=$$NOW^XLFDT,ZTIO=""
S ZTDESC="Remove duplicate nodes 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
N SEQ,DFN,TYPE,ID,X,XREF
;
; ANEW = patients to subscribe
S SEQ=0 F S SEQ=+$O(^VPR("ANEW",SEQ)) Q:SEQ<1 S DFN=+$O(^(SEQ,0)) D
. S X=$G(^VPR(1,2,DFN,"ANEW"))
. I X'>0 S ^VPR(1,2,DFN,"ANEW")=SEQ Q ;create
. I X,X'=SEQ K ^VPR("ANEW",SEQ,DFN) Q ;duplicate, remove
. I X,X=SEQ Q ;ok (if re-run)
;
; AVPR = data updates
S SEQ=0 F S SEQ=+$O(^VPR("AVPR",SEQ)) Q:SEQ<1 S DFN=+$O(^(SEQ,0)),XREF=$G(^(DFN)) D
. S TYPE=$P(XREF,U,2) Q:TYPE=""
. S ID=$P(XREF,U,3) S:ID="" ID="*"
. ;
. ; look for bad nodes
. I TYPE="OtherOrder",ID,$$BADORD K ^VPR(1,2,DFN,"AVPR",TYPE,ID),^VPR("AVPR",SEQ,DFN) Q
. I TYPE="Referral",ID,$$BADREF K ^VPR(1,2,DFN,"AVPR",TYPE,ID),^VPR("AVPR",SEQ,DFN) Q
. ;
. ; create patient node, or Q if exists (re-run)
. S X=$G(^VPR(1,2,DFN,"AVPR",TYPE,ID))
. I X'>0 S ^VPR(1,2,DFN,"AVPR",TYPE,ID)=SEQ_U_$P(XREF,U,4,5) Q
. I X,+X=SEQ Q
. ;
. ; duplicate - keep first SEQ (+X) but update action^visit to latest
. S ^VPR(1,2,DFN,"AVPR",TYPE,ID)=+X_U_$P(XREF,U,4,5)
. S $P(^VPR("AVPR",+X,DFN),U,4,5)=$P(XREF,U,4,5)
. K ^VPR("AVPR",SEQ,DFN)
Q
;
BADORD() ; -- return 1 or 0, if not truly an Other order
N X,Y,PKG
S X=+$P($G(^OR(100,+$G(ID),0)),U,14),PKG=$$GET1^DIQ(9.4,X,1)
S Y=$S($E(PKG,1,2)="LR":1,$E(PKG,1,2)="PS":1,$E(PKG,1,2)="RA":1,1:0)
Q Y
;
BADREF() ; -- return 1 or 0, if bad Referral reference
I $P(ID,";",2)=100 Q 1
I '$D(^GMR(123,+ID,0)) Q 1
I $P(^GMR(123,+ID,0),U,2)'=DFN Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRP15 2510 printed Sep 23, 2025@20:21:52 Page 2
VPRP15 ;SLC/MKB -- SDA utilities for patch 15 ;11/8/18 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**15**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; XUSAP 4677
+7 ;
+8 ;
POST ; -- postinit tasks
+1 DO PRXY
DO TASK
+2 QUIT
+3 ;
PRXY ; -- create proxy user
+1 IF '$ORDER(^VA(200,"B","VPRVDIF,APPLICATION PROXY",0))
Begin DoDot:1
+2 NEW X
SET X=$$CREATE^XUSAP("VPRVDIF,APPLICATION PROXY","")
End DoDot:1
+3 QUIT
+4 ;
TASK ; -- task job to clean up ^VPR
+1 IF '$DATA(^VPR("AVPR"))
IF '$DATA(^VPR("ANEW"))
DO MES^XPDUTL("No task queued; no entries in update lists.")
QUIT
+2 NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
+3 SET ZTRTN="LIST^VPRP15"
SET ZTDTH=$$NOW^XLFDT
SET ZTIO=""
+4 SET ZTDESC="Remove duplicate nodes from VPR update lists"
+5 DO ^%ZTLOAD
IF '$GET(ZTSK)
DO MES^XPDUTL("Unable to queue clean up task.")
QUIT
+6 DO MES^XPDUTL("Task #"_ZTSK_" was queued to clean up ^VPR")
+7 QUIT
+8 ;
LIST ; -- clean up ^VPR update lists
+1 NEW SEQ,DFN,TYPE,ID,X,XREF
+2 ;
+3 ; ANEW = patients to subscribe
+4 SET SEQ=0
FOR
SET SEQ=+$ORDER(^VPR("ANEW",SEQ))
if SEQ<1
QUIT
SET DFN=+$ORDER(^(SEQ,0))
Begin DoDot:1
+5 SET X=$GET(^VPR(1,2,DFN,"ANEW"))
+6 ;create
IF X'>0
SET ^VPR(1,2,DFN,"ANEW")=SEQ
QUIT
+7 ;duplicate, remove
IF X
IF X'=SEQ
KILL ^VPR("ANEW",SEQ,DFN)
QUIT
+8 ;ok (if re-run)
IF X
IF X=SEQ
QUIT
End DoDot:1
+9 ;
+10 ; AVPR = data updates
+11 SET SEQ=0
FOR
SET SEQ=+$ORDER(^VPR("AVPR",SEQ))
if SEQ<1
QUIT
SET DFN=+$ORDER(^(SEQ,0))
SET XREF=$GET(^(DFN))
Begin DoDot:1
+12 SET TYPE=$PIECE(XREF,U,2)
if TYPE=""
QUIT
+13 SET ID=$PIECE(XREF,U,3)
if ID=""
SET ID="*"
+14 ;
+15 ; look for bad nodes
+16 IF TYPE="OtherOrder"
IF ID
IF $$BADORD
KILL ^VPR(1,2,DFN,"AVPR",TYPE,ID),^VPR("AVPR",SEQ,DFN)
QUIT
+17 IF TYPE="Referral"
IF ID
IF $$BADREF
KILL ^VPR(1,2,DFN,"AVPR",TYPE,ID),^VPR("AVPR",SEQ,DFN)
QUIT
+18 ;
+19 ; create patient node, or Q if exists (re-run)
+20 SET X=$GET(^VPR(1,2,DFN,"AVPR",TYPE,ID))
+21 IF X'>0
SET ^VPR(1,2,DFN,"AVPR",TYPE,ID)=SEQ_U_$PIECE(XREF,U,4,5)
QUIT
+22 IF X
IF +X=SEQ
QUIT
+23 ;
+24 ; duplicate - keep first SEQ (+X) but update action^visit to latest
+25 SET ^VPR(1,2,DFN,"AVPR",TYPE,ID)=+X_U_$PIECE(XREF,U,4,5)
+26 SET $PIECE(^VPR("AVPR",+X,DFN),U,4,5)=$PIECE(XREF,U,4,5)
+27 KILL ^VPR("AVPR",SEQ,DFN)
End DoDot:1
+28 QUIT
+29 ;
BADORD() ; -- return 1 or 0, if not truly an Other order
+1 NEW X,Y,PKG
+2 SET X=+$PIECE($GET(^OR(100,+$GET(ID),0)),U,14)
SET PKG=$$GET1^DIQ(9.4,X,1)
+3 SET Y=$SELECT($EXTRACT(PKG,1,2)="LR":1,$EXTRACT(PKG,1,2)="PS":1,$EXTRACT(PKG,1,2)="RA":1,1:0)
+4 QUIT Y
+5 ;
BADREF() ; -- return 1 or 0, if bad Referral reference
+1 IF $PIECE(ID,";",2)=100
QUIT 1
+2 IF '$DATA(^GMR(123,+ID,0))
QUIT 1
+3 IF $PIECE(^GMR(123,+ID,0),U,2)'=DFN
QUIT 1
+4 QUIT 0
