VPRHSX1 ;SLC/MKB -- HS Mgt Options cont ;09/18/18 4:36pm
;;1.0;VIRTUAL PATIENT RECORD;**25,27,31**;Sep 01, 2011;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DDE 7014
; ^DPT 10035
; ^GMR(120.86 3449
; DIQ 2056
; DIR 10026
; MPIF001 2701
; ORQ12 5704
; VADPT 3744
; XLFDT 10103
; XUPROD 4440
;
GET ; -- Add patient/container/record to GET list [VPR HS PUSH]
N DFN,ICN,X
I '$P($G(^VPR(1,0)),U,2) W !,"WARNING: Data Monitoring is currently disabled!",!
;
W ! S DFN=+$$PATIENT^VPRHST Q:DFN<1
I '$$SUBS^VPRHS(DFN) D Q
. W !,$C(7),"WARNING: This patient is not currently in the Edge Cache Repository (ECR)!",!
. S ICN=$$ICN(DFN) I ICN<0 W !,$P(ICN,U,2),!,"Cannot add to ECR",! Q
. I $G(^VPR(1,2,DFN,"ANEW")) W !,"This patient already has a request for subscription.",! Q
. Q:'$$CONT D NEW^VPRHS(DFN,ICN)
. S X=$G(^VPR(1,2,DFN,"ANEW"))
. W !," ... request "_$S(X:"",1:"NOT ")_"added to update queue."
;
I $$MERGED^VPRHS(DFN) D Q
. S X=$G(^DPT(DFN,-9))
. W !,"Patient is being merged"_$S(X:" into DFN "_X,1:""),!
S ICN=$$GETICN^MPIF001(DFN) I ICN<0 W !,"ICN is required!",! Q
N TYPE,ENT,FN,ACT,VST,DLIST,VPRX,VPRI,VPRN,ID
G1 ;loop for prompting
S TYPE=$$CONTNR^VPRHST,ID="" Q:"^"[TYPE
I $G(^VPR(1,2,DFN,"AVPR",TYPE,"*")) W !,"This patient already has a container update request in the queue!",! G G1
I TYPE="Patient" D G G1
. W !,"Entire container must be updated."
. S ID=DFN_";2"
. D P1^VPRHS,OUT W !
I $$ALL D P1^VPRHS,OUT W ! G G1
;
; select source file, record(s)
S ENT=$$ENTITY(TYPE) G:"^"[ENT G1
S FN=$P(ENT,U,3),ACT="U"
D QUERY I '$D(DLIST) W !,"No records available to update.",! G G1
S VPRX=$$SELECT(FN) I "^"[VPRX W ! G G1
F VPRI=1:1 S VPRN=$P(VPRX,",",VPRI) Q:VPRN<1 D
. S ID=$G(DLIST(VPRN))_";"_FN
. D P1^VPRHS,OUT(VPRN)
;
W ! G G1
Q
;
ICN(DFN) ; -- return ICN or -1^Message
N ICN,X I $G(DFN)<1 S ICN="-1^INVALID PATIENT" G ICQ
S X=$G(^DPT(DFN,.35)) I X D G ICQ
. S ICN="-1^Patient DIED on "_$$FMTE^XLFDT(X)
I $$TESTPAT^VADPT(DFN),$$PROD^XUPROD S ICN="-1^TEST PATIENT" G ICQ
I $$MERGED^VPRHS(DFN) D G ICQ
. S ICN="-1^Patient is being MERGED",X=$G(^DPT(DFN,-9))
. I X S ICN=ICN_" into DFN "_X
S ICN=$$GETICN^MPIF001(DFN) ;-1^error or ICN
ICQ ;exit
Q ICN
;
OUT(N) ; -- write message
S:$G(ID)="" ID="*"
N SEQ S SEQ=+$G(^VPR(1,2,DFN,"AVPR",TYPE,ID))
I ID="*" W !,TYPE," container "_$S(SEQ:"",1:" NOT")_" added to update queue." Q
W !,TYPE_" "_$S($G(N):"#"_N,1:"")_$S(SEQ:"",1:" NOT")_" added to update queue."
Q
;
CONT() ; -- continue?
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Are you sure you want to continue with this patient? "
S DIR("?")="Enter YES to add this patient to the ECR and subscribe to VistA updates, or NO to exit."
D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
Q Y
;
ENTITY(TYPE) ; -- return array of selected Entity info
N C,X,Y,I,FN S TYPE=$G(TYPE,"ZZZ")
S C=+$O(^VPRC(560.1,"C",TYPE,0))
S X=+$P($G(^VPRC(560.1,C,1,0)),U,4),Y=0
I X<1 W !!,"This container has no source files." G ENTQ
I X=1 S I=+$O(^VPRC(560.1,C,1,0)),Y=+$P($G(^(I,0)),U,2) G ENTQ
;
W !!,"This container has multiple sources; please select one."
S FN=$$FILE^VPRHST(C) I FN>0 D
. S I=+$O(^VPRC(560.1,C,1,"B",FN,0))
. S Y=+$P($G(^VPRC(560.1,C,1,I,0)),U,2)
ENTQ ;exit
S:Y Y=Y_U_$G(^DDE(Y,0))
Q Y
;
ALL() ; -- return 1 or 0, for full container (all records) update
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Update the full container? "
S DIR("?")="Enter YES to send all available records in this container to the ECR, or NO to exit."
D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
Q Y
;
QUERY ; -- execute Query, return DLIST(#)=ID
; Expects DFN, ENT=ien^name^file#
N DSTRT,DSTOP,DMAX,QRTN
Q:'$G(DFN) S QRTN=$G(^DDE(+ENT,5)) Q:QRTN="" Q:'$L($T(@($P(QRTN,"("))))
S DSTRT=2222222,DSTOP=4444444,DMAX=99999 K DLIST
D @QRTN
Q
;
SELECT(FNUM) ; -- select ID(s) for update list
N X,Y,DIR
W !!,"Available "_TYPE_"s for "_$P($G(^DPT(DFN,0)),U)_": " D LIST
S DIR(0)="LAO^1:"_$O(DLIST("A"),-1),DIR("A")="Select ITEM(S): "
S DIR("?")="Select the number(s) of the records for updating."
S DIR("??")="^D LIST^VPRHSX"
D ^DIR
Q Y
;
LIST ; -- ??help for SELECT
N FLDS,LCNT,ID,X,DONE
S (LCNT,DONE)=0,FLDS=$$FIELDS(FNUM)
F S LCNT=$O(DLIST(LCNT)) Q:LCNT<1 D Q:DONE
. S ID=DLIST(LCNT) S:ID["^" ID=$P(ID,U) S:ID["~" ID=$P(ID,"~") ;IEN
. W !,LCNT,?5,$$DATE(FNUM,$P(FLDS,";"),ID)
. W @$S(TYPE="Problem":"?19",TYPE="MemberEnrollment":"?19",1:"?25")
. W $$NAME(FNUM,$P(FLDS,";",2,99),ID)
. Q:LCNT#22 W !,"Press <return> to continue..."
. R X:DTIME I '$T!(X["^") S DONE=1
Q
;
DATE(FN,FD,DA) ; -- return external date
N RES S RES=$$GET1^DIQ(FN,DA_",",FD)
I $P(RES,":",3) S RES=$P(RES,":",1,2) ;strip seconds
I RES="" S RES="<NO DATE>"
Q RES
;
NAME(FN,FD,DA) ; -- return name or description
N RES S RES=""
I FN=120.86 S RES=$S('$P($G(^GMR(120.86,DA,0)),U,2):"No ",1:"")_"Known Allergies" Q RES
I FN=100,TYPE="OtherOrder" D Q RES
. N VPRX,ORIGVIEW
. S ORIGVIEW=2 D TEXT^ORQ12(.VPRX,DA)
. S RES=$G(VPRX(1))
. I $L(RES)>50 S RES=$E(RES,1,50)_"..."
N IDX,VPRX,SP S IDX="VPRX",SP=""
D:FD GETS^DIQ(FN,DA_",",FD,"EN",IDX)
F S IDX=$Q(@IDX) Q:IDX'?1"VPRX(".E S RES=RES_SP_@IDX,SP=", "
Q RES
;
FIELDS(FN,IEN) ; -- DATE;NAME fields to display record
N Y,FLDS S Y=""
I FN=120.5 S Y=".01;.03"
I FN=120.8 S Y="4;.02"
I FN=120.86 S Y="3;1"
I FN=100 S Y="21;.1*"
I FN=9000010 S Y=".01;.07;.22"
I FN[".",$P(FN,".")=9000010 S Y=".03;.01"
; FN=790.05 S Y=".01;21"
I FN=9000011 S Y=".08;.05"
I FN=783 S Y=".1"
I FN=230 S Y=".01;.03"
I FN=405 S Y=".01;.02"
I FN=2.98 S Y=".001;.01"
I FN=41.1 S Y="2;9;10"
I FN=45 S Y="2;79"
I FN=8925 S Y="1301;.01"
I FN=74 S Y="3;102"
I $P(FN,".")=63 S Y=".01;.06"
I FN=702 S Y=".02;.04"
I FN=130 S Y=".09;26"
I FN=123 S Y="3;1;4"
I FN=26.13 S Y=".06;.02"
I FN=2.312 S Y="8;.18"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHSX1 6362 printed Sep 23, 2025@20:21:42 Page 2
VPRHSX1 ;SLC/MKB -- HS Mgt Options cont ;09/18/18 4:36pm
+1 ;;1.0;VIRTUAL PATIENT RECORD;**25,27,31**;Sep 01, 2011;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DDE 7014
+7 ; ^DPT 10035
+8 ; ^GMR(120.86 3449
+9 ; DIQ 2056
+10 ; DIR 10026
+11 ; MPIF001 2701
+12 ; ORQ12 5704
+13 ; VADPT 3744
+14 ; XLFDT 10103
+15 ; XUPROD 4440
+16 ;
GET ; -- Add patient/container/record to GET list [VPR HS PUSH]
+1 NEW DFN,ICN,X
+2 IF '$PIECE($GET(^VPR(1,0)),U,2)
WRITE !,"WARNING: Data Monitoring is currently disabled!",!
+3 ;
+4 WRITE !
SET DFN=+$$PATIENT^VPRHST
if DFN<1
QUIT
+5 IF '$$SUBS^VPRHS(DFN)
Begin DoDot:1
+6 WRITE !,$CHAR(7),"WARNING: This patient is not currently in the Edge Cache Repository (ECR)!",!
+7 SET ICN=$$ICN(DFN)
IF ICN<0
WRITE !,$PIECE(ICN,U,2),!,"Cannot add to ECR",!
QUIT
+8 IF $GET(^VPR(1,2,DFN,"ANEW"))
WRITE !,"This patient already has a request for subscription.",!
QUIT
+9 if '$$CONT
QUIT
DO NEW^VPRHS(DFN,ICN)
+10 SET X=$GET(^VPR(1,2,DFN,"ANEW"))
+11 WRITE !," ... request "_$SELECT(X:"",1:"NOT ")_"added to update queue."
End DoDot:1
QUIT
+12 ;
+13 IF $$MERGED^VPRHS(DFN)
Begin DoDot:1
+14 SET X=$GET(^DPT(DFN,-9))
+15 WRITE !,"Patient is being merged"_$SELECT(X:" into DFN "_X,1:""),!
End DoDot:1
QUIT
+16 SET ICN=$$GETICN^MPIF001(DFN)
IF ICN<0
WRITE !,"ICN is required!",!
QUIT
+17 NEW TYPE,ENT,FN,ACT,VST,DLIST,VPRX,VPRI,VPRN,ID
G1 ;loop for prompting
+1 SET TYPE=$$CONTNR^VPRHST
SET ID=""
if "^"[TYPE
QUIT
+2 IF $GET(^VPR(1,2,DFN,"AVPR",TYPE,"*"))
WRITE !,"This patient already has a container update request in the queue!",!
GOTO G1
+3 IF TYPE="Patient"
Begin DoDot:1
+4 WRITE !,"Entire container must be updated."
+5 SET ID=DFN_";2"
+6 DO P1^VPRHS
DO OUT
WRITE !
End DoDot:1
GOTO G1
+7 IF $$ALL
DO P1^VPRHS
DO OUT
WRITE !
GOTO G1
+8 ;
+9 ; select source file, record(s)
+10 SET ENT=$$ENTITY(TYPE)
if "^"[ENT
GOTO G1
+11 SET FN=$PIECE(ENT,U,3)
SET ACT="U"
+12 DO QUERY
IF '$DATA(DLIST)
WRITE !,"No records available to update.",!
GOTO G1
+13 SET VPRX=$$SELECT(FN)
IF "^"[VPRX
WRITE !
GOTO G1
+14 FOR VPRI=1:1
SET VPRN=$PIECE(VPRX,",",VPRI)
if VPRN<1
QUIT
Begin DoDot:1
+15 SET ID=$GET(DLIST(VPRN))_";"_FN
+16 DO P1^VPRHS
DO OUT(VPRN)
End DoDot:1
+17 ;
+18 WRITE !
GOTO G1
+19 QUIT
+20 ;
ICN(DFN) ; -- return ICN or -1^Message
+1 NEW ICN,X
IF $GET(DFN)<1
SET ICN="-1^INVALID PATIENT"
GOTO ICQ
+2 SET X=$GET(^DPT(DFN,.35))
IF X
Begin DoDot:1
+3 SET ICN="-1^Patient DIED on "_$$FMTE^XLFDT(X)
End DoDot:1
GOTO ICQ
+4 IF $$TESTPAT^VADPT(DFN)
IF $$PROD^XUPROD
SET ICN="-1^TEST PATIENT"
GOTO ICQ
+5 IF $$MERGED^VPRHS(DFN)
Begin DoDot:1
+6 SET ICN="-1^Patient is being MERGED"
SET X=$GET(^DPT(DFN,-9))
+7 IF X
SET ICN=ICN_" into DFN "_X
End DoDot:1
GOTO ICQ
+8 ;-1^error or ICN
SET ICN=$$GETICN^MPIF001(DFN)
ICQ ;exit
+1 QUIT ICN
+2 ;
OUT(N) ; -- write message
+1 if $GET(ID)=""
SET ID="*"
+2 NEW SEQ
SET SEQ=+$GET(^VPR(1,2,DFN,"AVPR",TYPE,ID))
+3 IF ID="*"
WRITE !,TYPE," container "_$SELECT(SEQ:"",1:" NOT")_" added to update queue."
QUIT
+4 WRITE !,TYPE_" "_$SELECT($GET(N):"#"_N,1:"")_$SELECT(SEQ:"",1:" NOT")_" added to update queue."
+5 QUIT
+6 ;
CONT() ; -- continue?
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="YA"
SET DIR("B")="NO"
+3 SET DIR("A")="Are you sure you want to continue with this patient? "
+4 SET DIR("?")="Enter YES to add this patient to the ECR and subscribe to VistA updates, or NO to exit."
+5 DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
ENTITY(TYPE) ; -- return array of selected Entity info
+1 NEW C,X,Y,I,FN
SET TYPE=$GET(TYPE,"ZZZ")
+2 SET C=+$ORDER(^VPRC(560.1,"C",TYPE,0))
+3 SET X=+$PIECE($GET(^VPRC(560.1,C,1,0)),U,4)
SET Y=0
+4 IF X<1
WRITE !!,"This container has no source files."
GOTO ENTQ
+5 IF X=1
SET I=+$ORDER(^VPRC(560.1,C,1,0))
SET Y=+$PIECE($GET(^(I,0)),U,2)
GOTO ENTQ
+6 ;
+7 WRITE !!,"This container has multiple sources; please select one."
+8 SET FN=$$FILE^VPRHST(C)
IF FN>0
Begin DoDot:1
+9 SET I=+$ORDER(^VPRC(560.1,C,1,"B",FN,0))
+10 SET Y=+$PIECE($GET(^VPRC(560.1,C,1,I,0)),U,2)
End DoDot:1
ENTQ ;exit
+1 if Y
SET Y=Y_U_$GET(^DDE(Y,0))
+2 QUIT Y
+3 ;
ALL() ; -- return 1 or 0, for full container (all records) update
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="YA"
SET DIR("B")="NO"
+3 SET DIR("A")="Update the full container? "
+4 SET DIR("?")="Enter YES to send all available records in this container to the ECR, or NO to exit."
+5 DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
QUERY ; -- execute Query, return DLIST(#)=ID
+1 ; Expects DFN, ENT=ien^name^file#
+2 NEW DSTRT,DSTOP,DMAX,QRTN
+3 if '$GET(DFN)
QUIT
SET QRTN=$GET(^DDE(+ENT,5))
if QRTN=""
QUIT
if '$LENGTH($TEXT(@($PIECE(QRTN,"("))))
QUIT
+4 SET DSTRT=2222222
SET DSTOP=4444444
SET DMAX=99999
KILL DLIST
+5 DO @QRTN
+6 QUIT
+7 ;
SELECT(FNUM) ; -- select ID(s) for update list
+1 NEW X,Y,DIR
+2 WRITE !!,"Available "_TYPE_"s for "_$PIECE($GET(^DPT(DFN,0)),U)_": "
DO LIST
+3 SET DIR(0)="LAO^1:"_$ORDER(DLIST("A"),-1)
SET DIR("A")="Select ITEM(S): "
+4 SET DIR("?")="Select the number(s) of the records for updating."
+5 SET DIR("??")="^D LIST^VPRHSX"
+6 DO ^DIR
+7 QUIT Y
+8 ;
LIST ; -- ??help for SELECT
+1 NEW FLDS,LCNT,ID,X,DONE
+2 SET (LCNT,DONE)=0
SET FLDS=$$FIELDS(FNUM)
+3 FOR
SET LCNT=$ORDER(DLIST(LCNT))
if LCNT<1
QUIT
Begin DoDot:1
+4 ;IEN
SET ID=DLIST(LCNT)
if ID["^"
SET ID=$PIECE(ID,U)
if ID["~"
SET ID=$PIECE(ID,"~")
+5 WRITE !,LCNT,?5,$$DATE(FNUM,$PIECE(FLDS,";"),ID)
+6 WRITE @$SELECT(TYPE="Problem":"?19",TYPE="MemberEnrollment":"?19",1:"?25")
+7 WRITE $$NAME(FNUM,$PIECE(FLDS,";",2,99),ID)
+8 if LCNT#22
QUIT
WRITE !,"Press <return> to continue..."
+9 READ X:DTIME
IF '$TEST!(X["^")
SET DONE=1
End DoDot:1
if DONE
QUIT
+10 QUIT
+11 ;
DATE(FN,FD,DA) ; -- return external date
+1 NEW RES
SET RES=$$GET1^DIQ(FN,DA_",",FD)
+2 ;strip seconds
IF $PIECE(RES,":",3)
SET RES=$PIECE(RES,":",1,2)
+3 IF RES=""
SET RES="<NO DATE>"
+4 QUIT RES
+5 ;
NAME(FN,FD,DA) ; -- return name or description
+1 NEW RES
SET RES=""
+2 IF FN=120.86
SET RES=$SELECT('$PIECE($GET(^GMR(120.86,DA,0)),U,2):"No ",1:"")_"Known Allergies"
QUIT RES
+3 IF FN=100
IF TYPE="OtherOrder"
Begin DoDot:1
+4 NEW VPRX,ORIGVIEW
+5 SET ORIGVIEW=2
DO TEXT^ORQ12(.VPRX,DA)
+6 SET RES=$GET(VPRX(1))
+7 IF $LENGTH(RES)>50
SET RES=$EXTRACT(RES,1,50)_"..."
End DoDot:1
QUIT RES
+8 NEW IDX,VPRX,SP
SET IDX="VPRX"
SET SP=""
+9 if FD
DO GETS^DIQ(FN,DA_",",FD,"EN",IDX)
+10 FOR
SET IDX=$QUERY(@IDX)
if IDX'?1"VPRX(".E
QUIT
SET RES=RES_SP_@IDX
SET SP=", "
+11 QUIT RES
+12 ;
FIELDS(FN,IEN) ; -- DATE;NAME fields to display record
+1 NEW Y,FLDS
SET Y=""
+2 IF FN=120.5
SET Y=".01;.03"
+3 IF FN=120.8
SET Y="4;.02"
+4 IF FN=120.86
SET Y="3;1"
+5 IF FN=100
SET Y="21;.1*"
+6 IF FN=9000010
SET Y=".01;.07;.22"
+7 IF FN["."
IF $PIECE(FN,".")=9000010
SET Y=".03;.01"
+8 ; FN=790.05 S Y=".01;21"
+9 IF FN=9000011
SET Y=".08;.05"
+10 IF FN=783
SET Y=".1"
+11 IF FN=230
SET Y=".01;.03"
+12 IF FN=405
SET Y=".01;.02"
+13 IF FN=2.98
SET Y=".001;.01"
+14 IF FN=41.1
SET Y="2;9;10"
+15 IF FN=45
SET Y="2;79"
+16 IF FN=8925
SET Y="1301;.01"
+17 IF FN=74
SET Y="3;102"
+18 IF $PIECE(FN,".")=63
SET Y=".01;.06"
+19 IF FN=702
SET Y=".02;.04"
+20 IF FN=130
SET Y=".09;26"
+21 IF FN=123
SET Y="3;1;4"
+22 IF FN=26.13
SET Y=".06;.02"
+23 IF FN=2.312
SET Y="8;.18"
+24 QUIT Y
