VPRHSX ;SLC/MKB -- HS Mgt Options ;09/18/18 4:36pm
;;1.0;VIRTUAL PATIENT RECORD;**8,15,25,27**;Sep 01, 2011;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; DIE 10018
; DIR 10026
; MPIF001 2701
; VADPT 3744
; XLFDT 10103
; XLFSTR 10104
; XUPROD 4440
;
ON ; -- Turn monitoring on/off [VPR HS ENABLE]
N X0,DA,DR,DIE,X,Y
S X0=$G(^VPR(1,0)) I '$P(X0,U,2) D Q ;off -- turn on
. S DA=1,DR=".02",DIE="^VPR(" D ^DIE
. I $P($G(^VPR(1,0)),U,2) S $P(^VPR(1,0),U,4)=$$NOW^XLFDT
;
I $$PROD^XUPROD D Q:'$$SURE
. W !,$C(7) ;On in production
. W !,"WARNING: Turning off data monitoring will cause the Regional Health Connect"
. W !," server to become out of synch with VistA!!",!
. W !," *** Do NOT proceed unless directed to do so by Health Product Support"
. W !," or VPR development staff!",!
W ! S DA=1,DR=".02",DIE="^VPR(" D ^DIE
I '$P($G(^VPR(1,0)),U,2) S $P(^VPR(1,0),U,3,4)=$$NOW^XLFDT_U
Q
;
SURE() ; -- are you sure?
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="ARE YOU SURE? ",DIR("?")="Enter YES to continue with disabling data monitoring for HealthShare"
D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
Q Y
;
;
PATS ; -- Inquire if patient is subscribed [VPR HS PATIENTS]
N PAT,DFN,SUB,ICN,X
P1 W ! S PAT=$$PATIENT^VPRHST,ICN="" Q:PAT<1
S SUB=$$SUBS^VPRHS(+PAT),ICN=$$GETICN^MPIF001(+PAT)
W !!,$P(PAT,U,2)_" is "_$S('SUB:"NOT ",1:"")_"subscribed in HealthShare"
W !,"DFN: "_+PAT
W !,"ICN: "_$S(ICN>0:ICN,1:$P(ICN,U,2))
; show other validity checks
S X=+$G(^DPT(+PAT,.35)) I X W !,">> Patient DIED on "_$$FMTE^XLFDT(X)
I $$TESTPAT^VADPT(+PAT),$$PROD^XUPROD W !,">> TEST PATIENT"
I $$MERGED^VPRHS(+PAT) D
. N X S X=$G(^DPT(+PAT,-9))
. W !,">> Patient is being MERGED"_$S(X:" into DFN "_X,1:"")
W ! G P1
Q
;
;
GET ; -- Add patient/container/record to GET list [VPR HS PUSH]
G GET^VPRHSX1
Q
;
LAST ; -- Reset last seq# [VPR HS CLEAR LIST]
W !!,"OUT OF ORDER",$C(7) ;option removed
Q
;
;
LOG ; -- Turn update logging on/off for debugging [VPR HS LOG]
N X0,ACT S X0=$G(^VPR(1,0))
I '$P(X0,U,2) W !,"NOTE: Data monitoring is not running!!"
;
I '$P(X0,U,5) D Q ;off -- turn on logging?
. N X,Y,DIR
. W !!,"Upload list logging is currently OFF",!
. S DIR(0)="YA",DIR("B")="NO"
. S DIR("A")="Would you like to turn it ON? "
. S DIR("?",1)="Enter YES to begin saving a copy of the upload list nodes in ^XTMP;"
. S DIR("?")="logged data will be kept for three days."
. D ^DIR I Y>0 S $P(^VPR(1,0),U,5)=1
. D KILL
;
; on -- turn off logging?
W !!,"Upload list logging is currently ON",!
F S ACT=$$ACTION Q:ACT="^" D @ACT W !
Q
;
ACTION() ; -- select log action
N X,Y,Z,DIR,DUOUT,DTOUT
S DIR(0)="SA^V:VIEW;O:OFF;Q:QUIT;",DIR("A")="Select log action: "
S DIR("B")=$S($O(^XTMP("VPRHS-0"))?1"VPRHS-"1.N:"VIEW",1:"QUIT")
S DIR("?")=" Enter QUIT to exit this option."
S DIR("L",1)=" Enter VIEW to select a date to view data."
S DIR("L")=" Enter OFF to turn logging of the Upload List off."
D ^DIR S Z=$G(Y(0)) S:$D(DUOUT)!$D(DTOUT)!(Y="Q") Z="^"
Q Z
;
OFF ; -- turn off logging?
K DIR S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Would you like to turn logging OFF? "
S DIR("?")="Enter YES to stop saving a copy of the update list nodes in ^XTMP"
D ^DIR Q:Y'>0 S $P(^VPR(1,0),U,5)=0
D KILL
Q
;
KILL ; remove log too?
N I,X,Y,DIR
S I=$O(^XTMP("VPRHS-0")),X=+$O(^(I,0)) Q:X<1 ;no data
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Would you like to remove existing logs? "
S DIR("?",1)="Enter YES to kill any existing logs in ^XTMP; NO will keep the logs"
S DIR("?")="available until "_$$FMTE^XLFDT(X,2)_"."
D ^DIR Q:Y<1
S I="VPRHS-0" F S I=$O(^XTMP(I)) Q:I'?1"VPRHS-"5N K ^XTMP(I)
Q
;
VIEW ; -- display ^XTMP log
N VPRH,PAT,SEQ,LCNT,DFN,STR,DONE
V1 S VPRH=$$DATE Q:"^"[VPRH
S SEQ=$$NUM(VPRH) Q:"^"[SEQ
S PAT=$$PATIENT^VPRHST Q:$D(DUOUT)!$D(DTOUT) S:+PAT<0 PAT=""
D HDR S LCNT=2 K DONE
F S SEQ=$O(^XTMP("VPRHS-"_VPRH,SEQ)) Q:SEQ<1 D I $G(DONE) W ! Q
. S DFN=+$O(^XTMP("VPRHS-"_VPRH,SEQ,0)),STR=$G(^(DFN))
. I PAT,DFN'=+PAT Q
. S LCNT=LCNT+1 I LCNT>(IOSL-2) D READ Q:$G(DONE) D HDR S LCNT=3
. W !,SEQ,?10,DFN,?20,STR
I '$G(DONE) D READ W !
G V1
Q
;
HDR ; -- write captions
W !!,"SEQ",?10,"DFN",?20,$$HTE^XLFDT(VPRH) W:PAT " for ",$P(PAT,U,2)
W !,$$REPEAT^XLFSTR("-",79)
Q
;
DATE() ; -- select a date from ^XTMP("VPRHS",date)
N X1,X2,X,Y,DIR,DUOUT,DTOUT,Z
S X1=$O(^XTMP("VPRHS-0")),X1=+$P(X1,"-",2)
I 'X1 W !,"There are no log entries to display." Q "^"
S X2=$O(^XTMP("VPRHS-AAAAA"),-1),X2=+$P(X2,"-",2),DIR("A")="Select a date: "
S DIR(0)="DAO^"_$$HTFM^XLFDT(X1)_":"_$$HTFM^XLFDT(X2)_":EX"
S Z=$$HTE^XLFDT(X2),DIR("B")=Z ;latest date available
I X1=X2 S DIR("?")="Available date is "_Z
E S DIR("?")="Available dates are "_$$HTE^XLFDT(X1)_" to "_Z
S DIR("?")=DIR("?")_", or enter ^ to exit"
D ^DIR S Z="" S:$D(DUOUT)!$D(DUOUT) Z="^"
I Y>0 S Z=$P($$FMTH^XLFDT(Y),",")
Q Z
;
NUM(DAY) ; -- select a starting seq#
N A,Z,X,Y
S A=+$O(^XTMP("VPRHS-"_DAY,0)),Z=+$O(^XTMP("VPRHS-"_DAY,"A"),-1)
N1 W !,"Starting sequence#: FIRST// "
R X:DTIME I '$T!(X["^") Q "^"
I "FIRST"[$$UP^XLFSTR(X) Q 0
I +X=X,X'<A,X'>Z Q (X-1)
W !!,"Sequence numbers for this date are "_A_"-"_Z,!
G N1
Q
;
READ ; -- continue?
N X K DONE
W !!,"Press <return> to continue ..." R X:DTIME
S:X["^" DONE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHSX 5790 printed Sep 23, 2025@20:21:41 Page 2
VPRHSX ;SLC/MKB -- HS Mgt Options ;09/18/18 4:36pm
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,15,25,27**;Sep 01, 2011;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; DIE 10018
+8 ; DIR 10026
+9 ; MPIF001 2701
+10 ; VADPT 3744
+11 ; XLFDT 10103
+12 ; XLFSTR 10104
+13 ; XUPROD 4440
+14 ;
ON ; -- Turn monitoring on/off [VPR HS ENABLE]
+1 NEW X0,DA,DR,DIE,X,Y
+2 ;off -- turn on
SET X0=$GET(^VPR(1,0))
IF '$PIECE(X0,U,2)
Begin DoDot:1
+3 SET DA=1
SET DR=".02"
SET DIE="^VPR("
DO ^DIE
+4 IF $PIECE($GET(^VPR(1,0)),U,2)
SET $PIECE(^VPR(1,0),U,4)=$$NOW^XLFDT
End DoDot:1
QUIT
+5 ;
+6 IF $$PROD^XUPROD
Begin DoDot:1
+7 ;On in production
WRITE !,$CHAR(7)
+8 WRITE !,"WARNING: Turning off data monitoring will cause the Regional Health Connect"
+9 WRITE !," server to become out of synch with VistA!!",!
+10 WRITE !," *** Do NOT proceed unless directed to do so by Health Product Support"
+11 WRITE !," or VPR development staff!",!
End DoDot:1
if '$$SURE
QUIT
+12 WRITE !
SET DA=1
SET DR=".02"
SET DIE="^VPR("
DO ^DIE
+13 IF '$PIECE($GET(^VPR(1,0)),U,2)
SET $PIECE(^VPR(1,0),U,3,4)=$$NOW^XLFDT_U
+14 QUIT
+15 ;
SURE() ; -- are you sure?
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="YA"
SET DIR("B")="NO"
+3 SET DIR("A")="ARE YOU SURE? "
SET DIR("?")="Enter YES to continue with disabling data monitoring for HealthShare"
+4 DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
+7 ;
PATS ; -- Inquire if patient is subscribed [VPR HS PATIENTS]
+1 NEW PAT,DFN,SUB,ICN,X
P1 WRITE !
SET PAT=$$PATIENT^VPRHST
SET ICN=""
if PAT<1
QUIT
+1 SET SUB=$$SUBS^VPRHS(+PAT)
SET ICN=$$GETICN^MPIF001(+PAT)
+2 WRITE !!,$PIECE(PAT,U,2)_" is "_$SELECT('SUB:"NOT ",1:"")_"subscribed in HealthShare"
+3 WRITE !,"DFN: "_+PAT
+4 WRITE !,"ICN: "_$SELECT(ICN>0:ICN,1:$PIECE(ICN,U,2))
+5 ; show other validity checks
+6 SET X=+$GET(^DPT(+PAT,.35))
IF X
WRITE !,">> Patient DIED on "_$$FMTE^XLFDT(X)
+7 IF $$TESTPAT^VADPT(+PAT)
IF $$PROD^XUPROD
WRITE !,">> TEST PATIENT"
+8 IF $$MERGED^VPRHS(+PAT)
Begin DoDot:1
+9 NEW X
SET X=$GET(^DPT(+PAT,-9))
+10 WRITE !,">> Patient is being MERGED"_$SELECT(X:" into DFN "_X,1:"")
End DoDot:1
+11 WRITE !
GOTO P1
+12 QUIT
+13 ;
+14 ;
GET ; -- Add patient/container/record to GET list [VPR HS PUSH]
+1 GOTO GET^VPRHSX1
+2 QUIT
+3 ;
LAST ; -- Reset last seq# [VPR HS CLEAR LIST]
+1 ;option removed
WRITE !!,"OUT OF ORDER",$CHAR(7)
+2 QUIT
+3 ;
+4 ;
LOG ; -- Turn update logging on/off for debugging [VPR HS LOG]
+1 NEW X0,ACT
SET X0=$GET(^VPR(1,0))
+2 IF '$PIECE(X0,U,2)
WRITE !,"NOTE: Data monitoring is not running!!"
+3 ;
+4 ;off -- turn on logging?
IF '$PIECE(X0,U,5)
Begin DoDot:1
+5 NEW X,Y,DIR
+6 WRITE !!,"Upload list logging is currently OFF",!
+7 SET DIR(0)="YA"
SET DIR("B")="NO"
+8 SET DIR("A")="Would you like to turn it ON? "
+9 SET DIR("?",1)="Enter YES to begin saving a copy of the upload list nodes in ^XTMP;"
+10 SET DIR("?")="logged data will be kept for three days."
+11 DO ^DIR
IF Y>0
SET $PIECE(^VPR(1,0),U,5)=1
+12 DO KILL
End DoDot:1
QUIT
+13 ;
+14 ; on -- turn off logging?
+15 WRITE !!,"Upload list logging is currently ON",!
+16 FOR
SET ACT=$$ACTION
if ACT="^"
QUIT
DO @ACT
WRITE !
+17 QUIT
+18 ;
ACTION() ; -- select log action
+1 NEW X,Y,Z,DIR,DUOUT,DTOUT
+2 SET DIR(0)="SA^V:VIEW;O:OFF;Q:QUIT;"
SET DIR("A")="Select log action: "
+3 SET DIR("B")=$SELECT($ORDER(^XTMP("VPRHS-0"))?1"VPRHS-"1.N:"VIEW",1:"QUIT")
+4 SET DIR("?")=" Enter QUIT to exit this option."
+5 SET DIR("L",1)=" Enter VIEW to select a date to view data."
+6 SET DIR("L")=" Enter OFF to turn logging of the Upload List off."
+7 DO ^DIR
SET Z=$GET(Y(0))
if $DATA(DUOUT)!$DATA(DTOUT)!(Y="Q")
SET Z="^"
+8 QUIT Z
+9 ;
OFF ; -- turn off logging?
+1 KILL DIR
SET DIR(0)="YA"
SET DIR("B")="NO"
+2 SET DIR("A")="Would you like to turn logging OFF? "
+3 SET DIR("?")="Enter YES to stop saving a copy of the update list nodes in ^XTMP"
+4 DO ^DIR
if Y'>0
QUIT
SET $PIECE(^VPR(1,0),U,5)=0
+5 DO KILL
+6 QUIT
+7 ;
KILL ; remove log too?
+1 NEW I,X,Y,DIR
+2 ;no data
SET I=$ORDER(^XTMP("VPRHS-0"))
SET X=+$ORDER(^(I,0))
if X<1
QUIT
+3 SET DIR(0)="YA"
SET DIR("B")="NO"
+4 SET DIR("A")="Would you like to remove existing logs? "
+5 SET DIR("?",1)="Enter YES to kill any existing logs in ^XTMP; NO will keep the logs"
+6 SET DIR("?")="available until "_$$FMTE^XLFDT(X,2)_"."
+7 DO ^DIR
if Y<1
QUIT
+8 SET I="VPRHS-0"
FOR
SET I=$ORDER(^XTMP(I))
if I'?1"VPRHS-"5N
QUIT
KILL ^XTMP(I)
+9 QUIT
+10 ;
VIEW ; -- display ^XTMP log
+1 NEW VPRH,PAT,SEQ,LCNT,DFN,STR,DONE
V1 SET VPRH=$$DATE
if "^"[VPRH
QUIT
+1 SET SEQ=$$NUM(VPRH)
if "^"[SEQ
QUIT
+2 SET PAT=$$PATIENT^VPRHST
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
if +PAT<0
SET PAT=""
+3 DO HDR
SET LCNT=2
KILL DONE
+4 FOR
SET SEQ=$ORDER(^XTMP("VPRHS-"_VPRH,SEQ))
if SEQ<1
QUIT
Begin DoDot:1
+5 SET DFN=+$ORDER(^XTMP("VPRHS-"_VPRH,SEQ,0))
SET STR=$GET(^(DFN))
+6 IF PAT
IF DFN'=+PAT
QUIT
+7 SET LCNT=LCNT+1
IF LCNT>(IOSL-2)
DO READ
if $GET(DONE)
QUIT
DO HDR
SET LCNT=3
+8 WRITE !,SEQ,?10,DFN,?20,STR
End DoDot:1
IF $GET(DONE)
WRITE !
QUIT
+9 IF '$GET(DONE)
DO READ
WRITE !
+10 GOTO V1
+11 QUIT
+12 ;
HDR ; -- write captions
+1 WRITE !!,"SEQ",?10,"DFN",?20,$$HTE^XLFDT(VPRH)
if PAT
WRITE " for ",$PIECE(PAT,U,2)
+2 WRITE !,$$REPEAT^XLFSTR("-",79)
+3 QUIT
+4 ;
DATE() ; -- select a date from ^XTMP("VPRHS",date)
+1 NEW X1,X2,X,Y,DIR,DUOUT,DTOUT,Z
+2 SET X1=$ORDER(^XTMP("VPRHS-0"))
SET X1=+$PIECE(X1,"-",2)
+3 IF 'X1
WRITE !,"There are no log entries to display."
QUIT "^"
+4 SET X2=$ORDER(^XTMP("VPRHS-AAAAA"),-1)
SET X2=+$PIECE(X2,"-",2)
SET DIR("A")="Select a date: "
+5 SET DIR(0)="DAO^"_$$HTFM^XLFDT(X1)_":"_$$HTFM^XLFDT(X2)_":EX"
+6 ;latest date available
SET Z=$$HTE^XLFDT(X2)
SET DIR("B")=Z
+7 IF X1=X2
SET DIR("?")="Available date is "_Z
+8 IF '$TEST
SET DIR("?")="Available dates are "_$$HTE^XLFDT(X1)_" to "_Z
+9 SET DIR("?")=DIR("?")_", or enter ^ to exit"
+10 DO ^DIR
SET Z=""
if $DATA(DUOUT)!$DATA(DUOUT)
SET Z="^"
+11 IF Y>0
SET Z=$PIECE($$FMTH^XLFDT(Y),",")
+12 QUIT Z
+13 ;
NUM(DAY) ; -- select a starting seq#
+1 NEW A,Z,X,Y
+2 SET A=+$ORDER(^XTMP("VPRHS-"_DAY,0))
SET Z=+$ORDER(^XTMP("VPRHS-"_DAY,"A"),-1)
N1 WRITE !,"Starting sequence#: FIRST// "
+1 READ X:DTIME
IF '$TEST!(X["^")
QUIT "^"
+2 IF "FIRST"[$$UP^XLFSTR(X)
QUIT 0
+3 IF +X=X
IF X'<A
IF X'>Z
QUIT (X-1)
+4 WRITE !!,"Sequence numbers for this date are "_A_"-"_Z,!
+5 GOTO N1
+6 QUIT
+7 ;
READ ; -- continue?
+1 NEW X
KILL DONE
+2 WRITE !!,"Press <return> to continue ..."
READ X:DTIME
+3 if X["^"
SET DONE=1
+4 QUIT
