VPRP14 ;SLC/MKB -- Inits for patch 14 ;3/4/20 12:07
;;1.0;VIRTUAL PATIENT RECORD;**14**;Sep 01, 2011;Build 38
;;Per VHA Directive 6402, this routine should not be modified.
;
;
PRE ; -- preinit to remove unused Entities
N DIK,DA,VPRNM,X,DR,DIE,XQORM
; remove any old PLI patch entities
S DIK="^DDE(",VPRNM="VPR P14 A"
F S VPRNM=$O(^DDE("B",VPRNM)) Q:VPRNM'?1"VPR P"2N1" "1.E S DA=+$O(^(VPRNM,0)) I DA D ^DIK
; remove Social Hx items from test
; S DIK="^DDE(",VPRNM="VPR SHX A"
; F S VPRNM=$O(^DDE("B",VPRNM)) Q:VPRNM'?1"VPR SHX "1.E S DA=+$O(^(VPRNM,0)) I DA D ^DIK
P1 ; add Seq# to VPR item on PS event
S X=+$O(^ORD(101,"B","VPR XQOR EVENTS",0))
S DA(1)=+$O(^ORD(101,"B","PS EVSEND OR",0))
S DA=+$O(^ORD(101,DA(1),10,"B",X,0))
I DA,+$G(^ORD(101,DA(1),10,DA,0))=X,'$P(^(0),U,3) D
. S DR="3///2",DIE="^ORD(101,"_DA(1)_",10," D ^DIE
. S XQORM=DA(1)_";ORD(101," D XREF^XQORM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRP14 918 printed Dec 13, 2024@02:45:29 Page 2
VPRP14 ;SLC/MKB -- Inits for patch 14 ;3/4/20 12:07
+1 ;;1.0;VIRTUAL PATIENT RECORD;**14**;Sep 01, 2011;Build 38
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
PRE ; -- preinit to remove unused Entities
+1 NEW DIK,DA,VPRNM,X,DR,DIE,XQORM
+2 ; remove any old PLI patch entities
+3 SET DIK="^DDE("
SET VPRNM="VPR P14 A"
+4 FOR
SET VPRNM=$ORDER(^DDE("B",VPRNM))
if VPRNM'?1"VPR P"2N1" "1.E
QUIT
SET DA=+$ORDER(^(VPRNM,0))
IF DA
DO ^DIK
+5 ; remove Social Hx items from test
+6 ; S DIK="^DDE(",VPRNM="VPR SHX A"
+7 ; F S VPRNM=$O(^DDE("B",VPRNM)) Q:VPRNM'?1"VPR SHX "1.E S DA=+$O(^(VPRNM,0)) I DA D ^DIK
P1 ; add Seq# to VPR item on PS event
+1 SET X=+$ORDER(^ORD(101,"B","VPR XQOR EVENTS",0))
+2 SET DA(1)=+$ORDER(^ORD(101,"B","PS EVSEND OR",0))
+3 SET DA=+$ORDER(^ORD(101,DA(1),10,"B",X,0))
+4 IF DA
IF +$GET(^ORD(101,DA(1),10,DA,0))=X
IF '$PIECE(^(0),U,3)
Begin DoDot:1
+5 SET DR="3///2"
SET DIE="^ORD(101,"_DA(1)_",10,"
DO ^DIE
+6 SET XQORM=DA(1)_";ORD(101,"
DO XREF^XQORM
End DoDot:1
+7 QUIT
