VPRHS ;SLC/MKB -- HealthShare utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,16,17,19,25,27,33**;Sep 01, 2011;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; %ZTLOAD 10063
; DDE 7008
; DICN 10009
; DIK 10013
; MPIF001 2701
; VADPT 3744
; XLFDT 10103
; XUPROD 4440
;
Q
;
ON() ; -- return 1 or 0, if monitoring is on
Q $P($G(^VPR(1,0)),U,2)
;
EN(DFN) ; -- subscribe a patient for data event monitoring
Q:'$G(DFN) Q:$D(^VPR(1,2,+DFN,0))
;S ^VPR(1,2,+DFN,0)=+DFN,^VPR(1,2,"B",+DFN,+DFN)=""
N X,Y,DA,DIC,DINUM
S DIC="^VPR(1,2,",DIC(0)="ULFNX",DA(1)=1,(DINUM,X)=+DFN
D FILE^DICN
Q
;
UN(DFN) ; -- unsubscribe
Q:'$G(DFN) Q:'$D(^VPR(1,2,+DFN,0))
;K ^VPR(1,2,+DFN,0),^VPR(1,2,"B",+DFN,+DFN)
N DA,DIK
S DA(1)=1,DA=+DFN,DIK="^VPR(1,2,"
D ^DIK
Q
;
SUBS(DFN) ; -- return 1 or 0, if patient is subscribed or not
Q $D(^VPR(1,2,+$G(DFN),0))
;
QUE(DFN) ; -- create task to POST a Patient update
Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
Q:$G(DFN)<1 Q:'$$SUBS(DFN) ;not subscribed
Q:$P($G(^VPR(1,2,+DFN,0)),U,2) ;task exists
; create task
N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
S ZTRTN="PAT^VPRHS",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,10)
S ZTDESC="Task single VPR SDA Patient Container update"
S ZTIO="",ZTSAVE("DFN")="" D ^%ZTLOAD
S:$G(ZTSK)>0 $P(^VPR(1,2,DFN,0),U,2)=ZTSK
Q
;
PAT ; -- post Patient update [TASK]
Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
S DFN=+$G(DFN) Q:DFN<1 Q:'$D(^DPT(DFN,0)) ;not valid
;if in merged state, unsubscribe and use 'into' DFN
I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))
I '$$SUBS(DFN) Q ;not subscribed
D POST(DFN,"Patient",DFN_";2")
S $P(^VPR(1,2,DFN,0),U,2)="",ZTREQ="@" ;clear task
Q
;
PX ; -- post an encounter update
G TASK^VPRENC ;moved in VPR*1*19
;
VALID(PAT) ; -- return 1 or 0, if valid patient for HealthShare
S PAT=+$G(PAT) I PAT<1 Q 0 ;invalid pointer
I '$D(^DPT(DFN,0)) Q 0 ;invalid entry
I $G(^DPT(PAT,.35)) Q 0 ;death date
I $$TESTPAT^VADPT(PAT),$$PROD^XUPROD Q 0 ;no test pats in prod
I $$MERGED(PAT) Q 0 ;no merged-from pats
I '$G(^DPT(PAT,"MPI")) Q 0 ;no ICN
Q 1
;
MERGED(DFN) ; -- return 1 or 0, if patient is being merged
I $P($G(^DPT(+$G(DFN),0)),U)["MERGING INTO" Q 1
I $G(^DPT(+$G(DFN),-9)) Q 1
Q 0
;
POST(DFN,TYPE,ID,ACT,VST,RES) ; -- post an update to
; ^VPR(1,2,DFN,"AVPR",TYPE,ID) = seq#
; ^VPR("AVPR",seq#,DFN) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT#
Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
S DFN=+$G(DFN),TYPE=$G(TYPE),ID=$G(ID)
Q:DFN<1 Q:TYPE="" ;incomplete request
;if in merged state, unsubscribe and use 'into' DFN
I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))
N ICN S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0 ;ICN required
; add to ^VPR if not subscribed
I '$$SUBS(DFN) D:$$VALID(DFN) NEW(DFN,ICN) Q
S ACT=$S($G(ACT)="@":"D",1:"U")
P1 ;may enter here from VPRHSX1 manual update option
N SEQ,STR S SEQ=$$NUM
S STR=$G(ICN)_U_$G(TYPE)_U_$G(ID)_U_$G(ACT)_U_$G(VST)
S ^VPR("AVPR",SEQ,DFN)=STR
; use * for subscript (whole container) if ID is null
S ^VPR(1,2,DFN,"AVPR",TYPE,$S($G(ID)="":"*",1:ID))=SEQ ;_U_$G(ACT)_U_$G(VST)
I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,STR) ;tracking option
S RES=SEQ
Q
;
NUM() ; -- return existing SEQ of record, or increment
; SAC EXEMPTION 2019-04-29 : Use of $I
N X,Y S X=$S(ID="":"*",1:ID)
S Y=+$G(^VPR(1,2,DFN,"AVPR",TYPE,X)) I '$D(^VPR("AVPR",Y,DFN)) S Y=0
I Y'>0 S Y=$I(^VPR(1,1))
Q Y
;
NEW(DFN,ICN) ; -- post a new $$VALID patient to
; ^VPR(1,2,DFN,"ANEW") = seq#
; ^VPR("ANEW",seq#,DFN) = ICN
Q:$G(DFN)<1 Q:$G(^VPR(1,2,DFN,"ANEW"))
I $G(ICN)<1 S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0
N SEQ S SEQ=$I(^VPR(1,1))
S ^VPR("ANEW",SEQ,DFN)=ICN,^VPR(1,2,DFN,"ANEW")=SEQ
I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,(ICN_"^ANEW")) ;tracking option
Q
;
DEL(LIST,SEQ) ; -- remove ^VPR(LIST,SEQ) nodes
N DFN,DATA,TYPE,ID
S LIST=$G(LIST),SEQ=+$G(SEQ) Q:LIST="" Q:SEQ<1
S DFN=+$O(^VPR(LIST,SEQ,0)) I DFN<1 Q
I LIST="ANEW" K ^VPR("ANEW",SEQ,DFN),^VPR(1,2,DFN,"ANEW") Q
S DATA=$G(^VPR(LIST,SEQ,DFN)) K ^VPR("AVPR",SEQ,DFN)
S TYPE=$P(DATA,U,2) Q:TYPE="" ;error
S ID=$P(DATA,U,3) S:ID="" ID="*"
K ^VPR(1,2,DFN,"AVPR",TYPE,ID)
Q
;
XTMP(SEQ,DFN,X) ; -- save data for 3 days for debugging
N D S D=$P($H,",")
I '$D(^XTMP("VPRHS-"_D,0)) D
. L +^XTMP("VPRHS-"_D,0):3
. S ^XTMP("VPRHS-"_D,0)=$$FMADD^XLFDT(DT,4)_U_DT_"^VPR update log for HealthShare"
. L -^XTMP("VPRHS-"_D,0)
S ^XTMP("VPRHS-"_D,SEQ,DFN)=X
Q
;
GET(DFN,NAME,ID,VPRQ,MTYPE,VPRY,VPRR) ; -- return VistA data in @VPRY@(#)
N VPRNM,VPRFN,VPRE,VPRX,VPRZ,VPRMAX,VPRSRC,VPRCTR,VPRC0
N VPRI,VPRJ,VPRK,VPRN
;
; define default return arrays
S VPRY=$G(VPRY,$NA(^TMP("VPR GET",$J))),VPRI=0 K @VPRY
S VPRR=$G(VPRR,$NA(^TMP("VPR ERR",$J))),VPRJ=0 K @VPRR
;
; validate Patient
S DFN=+$G(DFN),VPRQ("patient")=DFN
I DFN<1!'$D(^DPT(DFN,0)) G GTQ
;
; validate/find Container
S VPRNM=$G(NAME),VPRSRC=$G(VPRQ("source"))
I $L(VPRNM,";")>1 S VPRSRC=$P(VPRNM,";",2),VPRNM=$P(VPRNM,";") G:VPRNM="" GTQ
S VPRCTR=+$O(^VPRC(560.1,"C",VPRNM,0)) G:VPRCTR<1 GTQ
S ID=$G(ID) I VPRNM="Patient",'ID&DFN S ID=DFN_";2"
I $G(VPRQ("max")) S VPRMAX=+VPRQ("max")
;
GT1 ; update one record for ECR
I ID'="",ID'="*" D G GTQ
. S VPRFN=+$P(ID,";",2),ID=$P(ID,";")
. I 'VPRFN!(ID="") Q ;D ERROR("Invalid ID: "_ID_";"_VPRFN) Q
. S VPRK=+$O(^VPRC(560.1,"F",VPRFN,VPRCTR,0))
. S VPRC0=$G(^VPRC(560.1,VPRCTR,1,VPRK,0)),VPRE=$P(VPRC0,U,2)
. ; if deleting a record saved in XTMP, switch entities
. N SEQ S SEQ=$G(VPRQ("sequence"))
. I $G(SEQ),$P($G(^XTMP("VPR-"_+SEQ,ID)),U,4)="D",$P(VPRC0,U,3) S VPRE=$P(VPRC0,U,3)
. I 'VPRE Q ;D ERROR("Missing Entity: "_VPRNM_" file #"_VPRFN) Q
. S VPRI=VPRI+1,@VPRY@(VPRI)=$$GET1^DDE(+VPRE,ID,.VPRQ,1,.VPRR)
. S VPRJ=+$O(@VPRR@("A"),-1) ;#errors
;
GTA ; retrieve whole container for patient re/load
I 'VPRSRC,$P($G(^VPRC(560.1,VPRCTR,0)),U,3) D Q
. S VPRE=$P($G(^VPRC(560.1,VPRCTR,0)),U,3)
. D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRY,.VPRR)
. S VPRJ=+$O(@VPRR@("A"),-1) S:VPRJ @VPRR@(0)=VPRJ ;#errors
;
S VPRX=$NA(^TMP("VPRHS",$J)),VPRZ=$NA(^TMP("VPRHS ERR",$J))
S VPRK=0 F S VPRK=$O(^VPRC(560.1,VPRCTR,1,VPRK)) Q:VPRK<1 S VPRC0=$G(^(VPRK,0)) D
. S VPRFN=+VPRC0 Q:'VPRFN I VPRSRC,VPRFN'=VPRSRC Q
. S VPRE=+$P(VPRC0,U,2) Q:VPRE<1 K @VPRX,@VPRZ
. ;I 'VPRE D ERROR("Missing Entity for "_VPRNM_" file #"_VPRFN) Q
. D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRX,.VPRZ)
. S VPRN=0 F S VPRN=$O(@VPRX@(VPRN)) Q:VPRN<1 S VPRI=VPRI+1,@VPRY@(VPRI)=@VPRX@(VPRN)
. S VPRN=0 F S VPRN=$O(@VPRZ@(VPRN)) Q:VPRN<1 S VPRJ=VPRJ+1,@VPRR@(VPRJ)=@VPRZ@(VPRN)
K @VPRX,@VPRZ
;
GTQ ; return data and exit
S @VPRY@(0)=VPRI,@VPRR@(0)=VPRJ
Q
;
ERROR(MSG) ; -- return error MSG
S VPRJ=+$G(VPRJ)+1
S @VPRR@(VPRJ)=$G(MSG)
Q
;
ENTITY(CONT,FN,ACT) ; -- find Entity
N Y,C,I,C0 S Y=""
S CONT=$G(CONT),FN=+$G(FN),ACT=$G(ACT)
S C=$S(CONT:CONT,$L(CONT):+$O(^VPRC(560.1,"C",CONT,0)),1:0)
S I=+$O(^VPRC(560.1,C,1,"B",FN,0)),C0=$G(^VPRC(560.1,C,1,I,0))
S Y=$P(C0,U,$S(ACT="D":3,1:2))
Q Y
;
TEST(ENTITY,ID,DFN,SEQ) ; -- test and display a single record
N Z,IN,ERR,DONE
S ENTITY=$G(ENTITY),ID=$G(ID)
S:$G(DFN) IN("patient")=DFN
S:$G(SEQ) IN("sequence")=SEQ
S Z=$$GET1^DDE(ENTITY,ID,.IN,1,.ERR)
I $O(ERR(0)) W !,$G(ERR(1))
I $L(Z) D XML^VPRHST1(Z)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHS 7979 printed Oct 16, 2024@18:45:50 Page 2
VPRHS ;SLC/MKB -- HealthShare utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,16,17,19,25,27,33**;Sep 01, 2011;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; %ZTLOAD 10063
+8 ; DDE 7008
+9 ; DICN 10009
+10 ; DIK 10013
+11 ; MPIF001 2701
+12 ; VADPT 3744
+13 ; XLFDT 10103
+14 ; XUPROD 4440
+15 ;
+16 QUIT
+17 ;
ON() ; -- return 1 or 0, if monitoring is on
+1 QUIT $PIECE($GET(^VPR(1,0)),U,2)
+2 ;
EN(DFN) ; -- subscribe a patient for data event monitoring
+1 if '$GET(DFN)
QUIT
if $DATA(^VPR(1,2,+DFN,0))
QUIT
+2 ;S ^VPR(1,2,+DFN,0)=+DFN,^VPR(1,2,"B",+DFN,+DFN)=""
+3 NEW X,Y,DA,DIC,DINUM
+4 SET DIC="^VPR(1,2,"
SET DIC(0)="ULFNX"
SET DA(1)=1
SET (DINUM,X)=+DFN
+5 DO FILE^DICN
+6 QUIT
+7 ;
UN(DFN) ; -- unsubscribe
+1 if '$GET(DFN)
QUIT
if '$DATA(^VPR(1,2,+DFN,0))
QUIT
+2 ;K ^VPR(1,2,+DFN,0),^VPR(1,2,"B",+DFN,+DFN)
+3 NEW DA,DIK
+4 SET DA(1)=1
SET DA=+DFN
SET DIK="^VPR(1,2,"
+5 DO ^DIK
+6 QUIT
+7 ;
SUBS(DFN) ; -- return 1 or 0, if patient is subscribed or not
+1 QUIT $DATA(^VPR(1,2,+$GET(DFN),0))
+2 ;
QUE(DFN) ; -- create task to POST a Patient update
+1 ;monitoring disabled
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+2 ;not subscribed
if $GET(DFN)<1
QUIT
if '$$SUBS(DFN)
QUIT
+3 ;task exists
if $PIECE($GET(^VPR(1,2,+DFN,0)),U,2)
QUIT
+4 ; create task
+5 NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
+6 SET ZTRTN="PAT^VPRHS"
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,10)
+7 SET ZTDESC="Task single VPR SDA Patient Container update"
+8 SET ZTIO=""
SET ZTSAVE("DFN")=""
DO ^%ZTLOAD
+9 if $GET(ZTSK)>0
SET $PIECE(^VPR(1,2,DFN,0),U,2)=ZTSK
+10 QUIT
+11 ;
PAT ; -- post Patient update [TASK]
+1 ;monitoring disabled
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+2 ;not valid
SET DFN=+$GET(DFN)
if DFN<1
QUIT
if '$DATA(^DPT(DFN,0))
QUIT
+3 ;if in merged state, unsubscribe and use 'into' DFN
+4 IF $$MERGED(DFN)
DO UN(DFN)
SET DFN=+$GET(^DPT(DFN,-9))
+5 ;not subscribed
IF '$$SUBS(DFN)
QUIT
+6 DO POST(DFN,"Patient",DFN_";2")
+7 ;clear task
SET $PIECE(^VPR(1,2,DFN,0),U,2)=""
SET ZTREQ="@"
+8 QUIT
+9 ;
PX ; -- post an encounter update
+1 ;moved in VPR*1*19
GOTO TASK^VPRENC
+2 ;
VALID(PAT) ; -- return 1 or 0, if valid patient for HealthShare
+1 ;invalid pointer
SET PAT=+$GET(PAT)
IF PAT<1
QUIT 0
+2 ;invalid entry
IF '$DATA(^DPT(DFN,0))
QUIT 0
+3 ;death date
IF $GET(^DPT(PAT,.35))
QUIT 0
+4 ;no test pats in prod
IF $$TESTPAT^VADPT(PAT)
IF $$PROD^XUPROD
QUIT 0
+5 ;no merged-from pats
IF $$MERGED(PAT)
QUIT 0
+6 ;no ICN
IF '$GET(^DPT(PAT,"MPI"))
QUIT 0
+7 QUIT 1
+8 ;
MERGED(DFN) ; -- return 1 or 0, if patient is being merged
+1 IF $PIECE($GET(^DPT(+$GET(DFN),0)),U)["MERGING INTO"
QUIT 1
+2 IF $GET(^DPT(+$GET(DFN),-9))
QUIT 1
+3 QUIT 0
+4 ;
POST(DFN,TYPE,ID,ACT,VST,RES) ; -- post an update to
+1 ; ^VPR(1,2,DFN,"AVPR",TYPE,ID) = seq#
+2 ; ^VPR("AVPR",seq#,DFN) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT#
+3 ;monitoring disabled
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+4 SET DFN=+$GET(DFN)
SET TYPE=$GET(TYPE)
SET ID=$GET(ID)
+5 ;incomplete request
if DFN<1
QUIT
if TYPE=""
QUIT
+6 ;if in merged state, unsubscribe and use 'into' DFN
+7 IF $$MERGED(DFN)
DO UN(DFN)
SET DFN=+$GET(^DPT(DFN,-9))
+8 ;ICN required
NEW ICN
SET ICN=$$GETICN^MPIF001(DFN)
if ICN<0
QUIT
+9 ; add to ^VPR if not subscribed
+10 IF '$$SUBS(DFN)
if $$VALID(DFN)
DO NEW(DFN,ICN)
QUIT
+11 SET ACT=$SELECT($GET(ACT)="@":"D",1:"U")
P1 ;may enter here from VPRHSX1 manual update option
+1 NEW SEQ,STR
SET SEQ=$$NUM
+2 SET STR=$GET(ICN)_U_$GET(TYPE)_U_$GET(ID)_U_$GET(ACT)_U_$GET(VST)
+3 SET ^VPR("AVPR",SEQ,DFN)=STR
+4 ; use * for subscript (whole container) if ID is null
+5 ;_U_$G(ACT)_U_$G(VST)
SET ^VPR(1,2,DFN,"AVPR",TYPE,$SELECT($GET(ID)="":"*",1:ID))=SEQ
+6 ;tracking option
IF $PIECE($GET(^VPR(1,0)),U,5)
DO XTMP(SEQ,DFN,STR)
+7 SET RES=SEQ
+8 QUIT
+9 ;
NUM() ; -- return existing SEQ of record, or increment
+1 ; SAC EXEMPTION 2019-04-29 : Use of $I
+2 NEW X,Y
SET X=$SELECT(ID="":"*",1:ID)
+3 SET Y=+$GET(^VPR(1,2,DFN,"AVPR",TYPE,X))
IF '$DATA(^VPR("AVPR",Y,DFN))
SET Y=0
+4 IF Y'>0
