VPRP30 ;SLC/MKB -- SDA utilities for patch 30 ;8/18/21 14:21
;;1.0;VIRTUAL PATIENT RECORD;**30**;Aug 18, 2021;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
Q
;
POST ; -- Post install for VPR*1.0*30
D PTF
Q
;
PTF ; -- Add new source to Container file for PTF
N PROC,DA,DR,DIE,DIC,X,X0,MSG,OK
S PROC=+$O(^VPRC(560.1,"B","PROCEDURE",0)) Q:PROC<1
S DA=+$O(^VPRC(560.1,"F",45.05,PROC,0)),OK=0
I DA D Q:OK ;already done
. S X0=$G(^VPRC(560.1,PROC,1,DA,0))
. I $P(X0,U,2)>0,$P(X0,U,3)>0 S OK=1 Q ;ok
; update, add message to Install log
S DIE="^VPRC(560.1,"_PROC_",1,",DA(1)=PROC
S MSG="VPR CONTAINER file source for #45.05"
I 'DA D Q:DA'>0
. S DIC=DIE,DIC(0)="LX",X=45.05
. K DA S DA(1)=PROC D FILE^DICN
. I DA'>0 D BMES^XPDUTL("UNABLE to create "_MSG)
S DR=".02///VPR PTF 601;.03///VPR DEL PTF 601" D ^DIE
S X0=$G(^VPRC(560.1,DA(1),1,DA,0))
S MSG=MSG_" "_$S($P(X0,U,2)<1:"UN",$P(X0,U,3)<1:"UN",1:"")_"SUCCESSFUL."
D BMES^XPDUTL(MSG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRP30 1017 printed Sep 23, 2025@20:22 Page 2
VPRP30 ;SLC/MKB -- SDA utilities for patch 30 ;8/18/21 14:21
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30**;Aug 18, 2021;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
POST ; -- Post install for VPR*1.0*30
+1 DO PTF
+2 QUIT
+3 ;
PTF ; -- Add new source to Container file for PTF
+1 NEW PROC,DA,DR,DIE,DIC,X,X0,MSG,OK
+2 SET PROC=+$ORDER(^VPRC(560.1,"B","PROCEDURE",0))
if PROC<1
QUIT
+3 SET DA=+$ORDER(^VPRC(560.1,"F",45.05,PROC,0))
SET OK=0
+4 ;already done
IF DA
Begin DoDot:1
+5 SET X0=$GET(^VPRC(560.1,PROC,1,DA,0))
+6 ;ok
IF $PIECE(X0,U,2)>0
IF $PIECE(X0,U,3)>0
SET OK=1
QUIT
End DoDot:1
if OK
QUIT
+7 ; update, add message to Install log
+8 SET DIE="^VPRC(560.1,"_PROC_",1,"
SET DA(1)=PROC
+9 SET MSG="VPR CONTAINER file source for #45.05"
+10 IF 'DA
Begin DoDot:1
+11 SET DIC=DIE
SET DIC(0)="LX"
SET X=45.05
+12 KILL DA
SET DA(1)=PROC
DO FILE^DICN
+13 IF DA'>0
DO BMES^XPDUTL("UNABLE to create "_MSG)
End DoDot:1
if DA'>0
QUIT
+14 SET DR=".02///VPR PTF 601;.03///VPR DEL PTF 601"
DO ^DIE
+15 SET X0=$GET(^VPRC(560.1,DA(1),1,DA,0))
+16 SET MSG=MSG_" "_$SELECT($PIECE(X0,U,2)<1:"UN",$PIECE(X0,U,3)<1:"UN",1:"")_"SUCCESSFUL."
+17 DO BMES^XPDUTL(MSG)
+18 QUIT
