VPRENC ;SLC/MKB -- VistA Encounter updates ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**19,20,26,25,27,28,29**;Sep 01, 2011;Build 11
;;Per VA Directive 6402, this routine should not be modified.
;
; Collect all visit changes in (NOW = time last modified):
;^XTMP("VPRPX",0) = DT+2 ^ DT ^ VPR ENCOUNTERS
;^XTMP("VPRPX", visit~dfn) = NOW ^ ID ^ NEW ^ VTYP
;^XTMP("VPRPX", visit~dfn, "SUB", ien) = NEW
;^XTMP("VPRPX", visit~dfn, "SUB", ien, 0) = BEFORE 0-node, if deleted
;^XTMP("VPRPX", "DOC", ien) = NOW ^ id [^ visit ^ @/1, if amended]
;^XTMP("VPRPX", "DOC", ien, 0) = BEFORE 0-node, if deleted
;^XTMP("VPRPX", "AVST"/"ADOC", NOW, ien) = ""
;
; where:
; NOW = time last modified
; ID = record id as 'ien;file#'
; NEW = 1 if new during session
; VTYP = 1 if visit type in V CPT was deleted (else null)
;
PX ; -- PXK VISIT DATA EVENT protocol listener
Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
N VST,PX0A,PX0B,DFN,VSTX,VPRPX,X,NOW,NEW,ID,SUB,DA,ACT,VTYP
S VST=+$O(^TMP("PXKCO",$J,0)) Q:VST<1
S PX0A=$G(^TMP("PXKCO",$J,VST,"VST",VST,0,"AFTER")),PX0B=$G(^("BEFORE"))
S DFN=$S($L(PX0A):+$P(PX0A,U,5),1:+$P(PX0B,U,5)) Q:DFN<1
S VSTX=VST_"~"_DFN ;visit id for XTMP
;
; get or set up ^XTMP
S VPRPX=$NA(^XTMP("VPRPX"))
L +@VPRPX@(VSTX):5 ;I'$T
;
; Visit file
S X=$G(@VPRPX@(VSTX)),NOW=+X,ID=$P(X,U,2),NEW=$P(X,U,3),VTYP=$P(X,U,4)
K:NOW @VPRPX@("AVST",NOW,VSTX) ;reset clock
I ID="" S ID=VST_";9000010"
S NOW=$$NOW^XLFDT,@VPRPX@("AVST",NOW,VSTX)=""
S:PX0B="" NEW=1
S @VPRPX@(VSTX)=NOW_U_ID_U_NEW_U_VTYP
;
; V-files
F SUB="IMM","ICR","XAM","POV","HF","CPT" D ;"PED","SK"
. S DA=0 F S DA=$O(^TMP("PXKCO",$J,VST,SUB,DA)) Q:DA<1 D
.. S ACT=$$DIFF(SUB,DA) Q:'ACT ;not changed
.. I SUB="HF" Q:$$NAME(SUB,DA)="" ;not Hx
.. I SUB="CPT" D Q:$$DUP(DA) ;duplicate code
... Q:$P($G(^TMP("PXKCO",$J,VST,SUB,DA,0,"BEFORE")),U)'?1"992"2N
... S:ACT<1 $P(@VPRPX@(VSTX),U,4)=1 ;visit type deleted
.. S NEW=$G(@VPRPX@(VSTX,SUB,DA)) S:ACT=2 NEW=1
.. S @VPRPX@(VSTX,SUB,DA)=NEW ;new flag
.. S X=$G(^TMP("PXKCO",$J,VST,SUB,DA,0,"AFTER")) S:'X X=$G(^("BEFORE"))
.. S:$L(X) @VPRPX@(VSTX,SUB,DA,0)=X
PXQ ; done
L -@VPRPX@(VSTX)
I '$G(@VPRPX@("ZTSK")) D NEWTSK
Q
;
DIFF(NM,IEN) ; -- returns 0/1 if un/changed, 2 if new, -1 if deleted
N NODE,AFTER,BEFORE,DIFF
S DIFF=0 F NODE=0,12,13,811 D Q:DIFF
. S AFTER=$G(^TMP("PXKCO",$J,VST,NM,IEN,NODE,"AFTER")),BEFORE=$G(^("BEFORE"))
. Q:BEFORE=AFTER S DIFF=1
. S:(NODE=0)&(BEFORE="") DIFF=2 ;new
. S:(NODE=0)&(AFTER="") DIFF=-1 ;deleted
Q DIFF
;
EDP(IEN) ; -- EDP Log file #230 AVPR index
Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
N EDP0,VST,DFN,VSTX,VPRPX,X,NOW,ID,NEW
S IEN=+$G(IEN) Q:IEN<1
S EDP0=$G(^EDP(230,IEN,0)),VST=+$P(EDP0,U,12) Q:VST<1
S DFN=+$P(EDP0,U,6) Q:DFN<1
; non-PCE event so post immediately for BMS
D POST^VPRHS(DFN,"Encounter",VST_";9000010")
Q
; get or set up ^XTMP [old]
S VSTX=VST_"~"_DFN ;visit id for XTMP
S VPRPX=$NA(^XTMP("VPRPX"))
L +@VPRPX@(VSTX):5 ;I'$T
;
; Visit file
S X=$G(@VPRPX@(VSTX)),NOW=+X,ID=$P(X,U,2),NEW=$P(X,U,3)
K:NOW @VPRPX@("AVST",NOW,VSTX) ;reset clock
I ID="" S ID=VST_";9000010"
S NOW=$$NOW^XLFDT,@VPRPX@("AVST",NOW,VSTX)=""
S @VPRPX@(VSTX)=NOW_U_ID_U_NEW
;
L -@VPRPX@(VSTX)
I '$G(@VPRPX@("ZTSK")) D NEWTSK
Q
;
TIU(IEN,ACT,VST) ; -- TIU Document file #8925 [from TIU/R^VPREVNT]
; add to ^XTMP("VPRPX") list w/encounters
N VPRPX,X0,NOW,NEW
S VPRPX=$NA(^XTMP("VPRPX")),IEN=+$G(IEN)
L +@VPRPX@("DOC",IEN):5 ;I'$T
;
S X0=$G(@VPRPX@("DOC",IEN)),NOW=+X0 K:NOW @VPRPX@("ADOC",NOW,IEN)
S VST=$G(VST,$P(X0,U,3)),NEW=$P(X0,U,4) ;VST passed in if retracted
; ACT=1 for new amendment, if aborted (@) kill XTMP and quit
I NEW,$G(ACT)="@" K @VPRPX@("DOC",IEN) L -@VPRPX@("DOC",IEN) Q
;
S NOW=$$NOW^XLFDT,@VPRPX@("ADOC",NOW,IEN)="" S:$L($G(ACT)) NEW=ACT
S @VPRPX@("DOC",IEN)=NOW_U_IEN_";8925"_U_VST_U_NEW
S:NEW="@" @VPRPX@("DOC",IEN,0)=$$NODE("TIU(8925,",IEN,0)
L -@VPRPX@("DOC",IEN)
I '$G(@VPRPX@("ZTSK")) D NEWTSK
Q
;
NEWTSK ; -- start new task
L +^XTMP("VPRPX","ZTSK"):3 Q:'$T ;will try again
; if no competing process got there first, create task
I '$G(^XTMP("VPRPX","ZTSK")) D QUE(5)
L -^XTMP("VPRPX","ZTSK")
Q
;
QUE(M) ; -- create task to post encounters, documents to HS
N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
S ZTRTN="TASK^VPRENC",ZTDESC="VPR Encounters",ZTIO=""
S M=+$G(M,5),ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,M)
D ^%ZTLOAD
S ^XTMP("VPRPX","ZTSK")=$G(ZTSK)
S ^XTMP("VPRPX",0)=$$FMADD^XLFDT(DT,2)_U_DT_"^Encounters for HealthShare"
Q
;
TASK ; -- post an encounter update
S ZTREQ="@" Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
N VPRPX,VPRDT,VPRI,VSTX,VST,X0,DFN,V0,VNM,VFL,VDA,VID,ACT,X,VPRD14,VPRSQ
S VPRPX=$NA(^XTMP("VPRPX")),VPRDT=$$FMADD^XLFDT($$NOW^XLFDT,,,-2)
S VPRD14=$$FMADD^XLFDT(DT,14)
; post visits that have been stable for at least 5 minutes
S VPRI=0 F S VPRI=$O(@VPRPX@("AVST",VPRI)) Q:VPRI<1 Q:VPRI>VPRDT D
. S VSTX="" F S VSTX=$O(@VPRPX@("AVST",VPRI,VSTX)) Q:VSTX="" D
.. I '$D(@VPRPX@(VSTX)) K @VPRPX@("AVST",VPRI,VSTX) Q
.. L +@VPRPX@(VSTX):5 Q:'$T ;will requeue
.. S X0=$G(@VPRPX@(VSTX)),VST=+VSTX,DFN=+$P(VSTX,"~",2)
.. S V0=$G(^AUPNVSIT(VST,0))
.. I V0=""!($P(V0,U,5)'=DFN) D Q ;deleted or replaced:
... I $P(X0,U,3) D KILL Q ; not in HS, just kill XTMP
... D DELALL ; else send delete to HS
.. ; post Encounter to HS
.. S VID=$P(X0,U,2) S:VID="" VID=VST_";9000010"
.. K VPRSQ D POST^VPRHS(DFN,"Encounter",VID,,,.VPRSQ)
.. I $G(VPRSQ),$P(X0,U,4) D SAVST(VPRSQ,"U",1) ;VType deleted
TV .. ; post related v-file records next
.. S VFL="" F S VFL=$O(@VPRPX@(VSTX,VFL)) Q:VFL="" D
... S VDA=0 F S VDA=$O(@VPRPX@(VSTX,VFL,VDA)) Q:VDA<1 D
.... S VNM=$$NAME(VFL,VDA) Q:VNM="" ;not tracked
.... S V0=$$ZERO(VFL,VDA),VID=VDA_";"_$P(VNM,U,2)
.... ; if exists & is valid send to HS, else quit/delete
.... I V0,$P(V0,U,2)=DFN,$P(V0,U,3)=VST D POST^VPRHS(DFN,$P(VNM,U),VID,,VST) Q
.... Q:$G(@VPRPX@(VSTX,VFL,VDA)) ;new, backed out (don't send)
.... K VPRSQ ;S VID=VDA_"~"_VST_";"_$P(VNM,U,2)
.... D POST^VPRHS(DFN,$P(VNM,U),VID,"@",VST,.VPRSQ)
.... I $G(VPRSQ) D SAVE(VPRSQ,VDA)
.. D KILL ;delete XTMP, unlock
.. ; post related documents
.. S VDA=0 F S VDA=$O(^TIU(8925,"V",+VST,VDA)) Q:VDA<1 I $G(@VPRPX@("DOC",VDA)) D DOC
TD ; look for waiting documents w/o visit [yet]
S VPRI=0 F S VPRI=$O(@VPRPX@("ADOC",VPRI)) Q:VPRI<1 Q:VPRI>VPRDT D
. S VDA=0 F S VDA=$O(@VPRPX@("ADOC",VPRI,VDA)) Q:VDA<1 D
.. I '$G(@VPRPX@("DOC",VDA)) K @VPRPX@("ADOC",VPRI,VDA) Q ;bad xref
.. D DOC
TQ ; re-task if more data
S X=$O(@VPRPX@(0)) I $L(X),X'="ZTSK" D QUE(5) Q
K @VPRPX@("ZTSK")
Q
;
DELALL ; -- delete visit + vfiles from HS [from TASK]
S VFL="" F S VFL=$O(@VPRPX@(VSTX,VFL)) Q:VFL="" D
. S VDA=0 F S VDA=$O(@VPRPX@(VSTX,VFL,VDA)) Q:VDA<1 D
.. S VNM=$$NAME(VFL,VDA) I VNM="" Q ;not tracked in HS
.. I $G(@VPRPX@(VSTX,VFL,VDA)) Q ;never sent to HS
.. K VPRSQ S VID=VDA_";"_$P(VNM,U,2) ;_"~"_VST
.. D POST^VPRHS(DFN,$P(VNM,U),VID,"@",VST,.VPRSQ)
.. I $G(VPRSQ) D SAVE(VPRSQ,VDA)
K VPRSQ D POST^VPRHS(DFN,"Encounter",VST_";9000010","@",,.VPRSQ)
I $G(VPRSQ) D SAVST(VPRSQ)
KILL ; clean up ^XTMP
K @VPRPX@(VSTX),@VPRPX@("AVST",VPRI,VSTX)
L -@VPRPX@(VSTX)
Q
;
SAVE(NUM,DA) ; -- save data for V-file record [from TV,DELALL] in
; ^XTMP("VPR-"_NUM, 0) = DT+14 ^ DT ^ Deleted records
; ^XTMP("VPR-"_NUM,DA) = DFN ^ TYPE ^ ID ^ U/D ^ VISIT#
; ^XTMP("VPR-"_NUM,DA,0) = DATA
Q:'$G(NUM) Q:'$G(DA)
S:'$G(VPRD14) VPRD14=$$FMADD^XLFDT(DT,14)
S ^XTMP("VPR-"_NUM,0)=VPRD14_U_DT_"^Deleted record for AVPR"
S ^XTMP("VPR-"_NUM,DA)=DFN_U_$P(VNM,U)_U_VID_"^D^"_VST
S X=$G(@VPRPX@(VSTX,VFL,DA,0)) S:$L(X) ^XTMP("VPR-"_NUM,DA,0)=X
Q
SAVST(NUM,ACT,TYP) ; -- save visit in ^XTMP [from TASK,DELALL]
Q:'$G(NUM) Q:'$G(VST) S ACT=$G(ACT,"D")
S:'$G(VPRD14) VPRD14=$$FMADD^XLFDT(DT,14)
S ^XTMP("VPR-"_NUM,0)=VPRD14_U_DT_"^Deleted visit for AVPR"
S ^XTMP("VPR-"_NUM,VST)=DFN_"^Encounter^"_VST_";9000010^"_ACT_U_U_$G(TYP)
Q
;
DOC ; -- process Document VDA [from TASK]
L +@VPRPX@("DOC",VDA):5 Q:'$T ;will requeue
N VPRTIU,STS,ACT,CLS,VPRSQ
S X0=$G(@VPRPX@("DOC",VDA)) D EXTRACT(VDA)
S VST=$G(VPRTIU(.03)),DFN=$G(VPRTIU(.02))
; quit if has visit, still in ^XTMP (send w/visit)
I VST,$G(@VPRPX@(VST_"~"_DFN)) L -@VPRPX@("DOC",VDA) Q
; else post to HS
S VID=$P(X0,U,2) I VID="" S VID=VDA_";8925"
S STS=$G(VPRTIU(.05)),ACT=$S($P(X0,U,4)="@":"@",STS>13:"@",1:"")
I ACT="@",'VST S VST=$P(X0,U,3) ;amended
D POST^VPRHS(DFN,"Document",VID,ACT,VST,.VPRSQ)
I ACT="@",$G(VPRSQ) D ;save to preserve visit#
. S ^XTMP("VPR-"_VPRSQ,VDA)=DFN_"^Document^"_VID_"^D^"_VST
. S X=+$G(VPRTIU(.01)),^XTMP("VPR-"_VPRSQ,VDA,0)=X_U_DFN_U_VST
. S ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
; update alert containers if CLS is CWD
S CLS=$G(VPRTIU(.04))
D:CLS=27 POST^VPRHS(DFN,"AdvanceDirective",VID,ACT)
D:CLS=30!(CLS=31) POST^VPRHS(DFN,"Alert",VID,ACT)
DQ ; clean up array, unlock
K @VPRPX@("DOC",VDA),@VPRPX@("ADOC",+X0,VDA)
L -@VPRPX@("DOC",VDA)
;
I VST D ;add/update Surgery when report completed
. N PROC S PROC=$G(VPRTIU(1405)) Q:'PROC
. I PROC["SRF" D POST^VPRHS(DFN,"Procedure",+PROC_";130",,VST) Q
Q
;
N I,DR,DIC,DIQ,VPRQ Q:'$G(DA)
I $P(X0,U,4)="@" D Q
. N X1 S X1=$G(@VPRPX@("DOC",VDA,0))
. F I=1:1:5 S VPRTIU(".0"_I)=$P(X1,U,I)
S DIC=8925,DIQ="VPRQ",DIQ(0)="I",DR=".01:.05;1405" D EN^DIQ1
F I=.01,.02,.03,.04,.05,1405 S VPRTIU(I)=$G(VPRQ(8925,DA,I,"I"))
Q
;
NAME(X,DA) ; -- return container name for V-files
N Y S Y=""
I X="HF" D
. N NM S DA=+$G(DA),NM=$P($G(^AUTTHF($$HF(DA),0)),U)
. I $$FHX(NM) S Y="FamilyHistory^9000010.23" Q
. I $$SHX(NM) S Y="SocialHistory^9000010.23" Q
. I $$C19(NM) S Y="Vaccination^9000010.23" Q
. ;S Y="HealthConcern^9000010.23"
I X="IMM" S Y="Vaccination^9000010.11"
I X="ICR" S Y="Vaccination^9000010.707"
I X="XAM" S Y="PhysicalExam^9000010.13"
I X="POV" S Y="Diagnosis^9000010.07"
I X="CPT" S Y="Procedure^9000010.18"
; X="SK" S Y="Procedure^9000010.12"
; X="PED" S Y="education^9000010.16"
I X="DOC" S Y="Document^8925"
Q Y
;
HF(IEN) ; -- return AUTTHF ptr, expects VST & VSTX
N X S IEN=+$G(IEN)
I $G(VST),$D(^TMP("PXKCO",$J,VST)) D Q +X
. S X=$G(^TMP("PXKCO",$J,VST,"HF",IEN,0,"BEFORE")) S:'X X=$G(^("AFTER"))
I $D(VPRPX),$G(VSTX) S X=$G(@VPRPX@(VSTX,"HF",IEN,0)) I X Q +X
S X=$$ZERO("HF",IEN) I X Q +X
Q 0
;
FHX(X) ; -- return 1 or 0, if HF name is for FamilyHistory
I X["FAMILY HISTORY" Q 1
I X["FAMILY HX" Q 1
Q 0
;
SHX(X) ; -- return 1 or 0, if HF name is for SocialHistory
I (X["TOBACCO")!(X["SMOK") Q 1
; (X["LIVES")!(X["LIVING") Q 1
; (X["RELIGIO")!(X["SPIRIT") Q 1
Q 0
;
C19(X) ; -- return 1 or 0, if HF name is for COVID imm refusal
I X?1"VA-SARS-COV-2 VACCINE REFUSAL".E Q 1
I X?1"VA-SARS-COV-2 IMM REFUSAL".E Q 1
Q 0
;
ZERO(X,DA) ; -- return zero node
N GBL,Y S Y="",DA=+$G(DA)
S GBL="^AUPNV"_$G(X),Y=$G(@GBL@(DA,0))
Q Y
;
NODE(NAME,DA,NUM) ; -- return global node
N GBL,Y S Y="",DA=+$G(DA)
S GBL=U_NAME_DA_")"
S Y=$G(@GBL@(NUM))
Q Y
;
DUP(DA) ; -- duplicate CPT record?
N VCPT,NODE,CPT,PKG,Y,IEN,GBL,IMM,SYS
M VCPT=^TMP("PXKCO",$J,VST,SUB,DA)
S NODE=$S($G(VCPT(0,"AFTER")):"AFTER",1:"BEFORE")
; skip eval/mgt codes
S CPT=$P($G(VCPT(0,NODE)),U) I CPT>99200,CPT<99500 Q 1
; skip Surgery (duplicates)
S PKG=+$P($G(VCPT(812,NODE)),U,2) I PKG,$P($G(^DIC(9.4,PKG,0)),U,2)="SR" Q 1
; skip V IMMUNIZATIONS codes
S GBL="^AUTTIMM",(Y,IEN)=0
F S IEN=$O(^TMP("PXKCO",$J,VST,"IMM",IEN)) Q:IEN<1 D Q:Y
. S NODE=$S($G(^TMP("PXKCO",$J,VST,"IMM",IEN,0,"AFTER")):"AFTER",1:"BEFORE")
. S IMM=+$G(^TMP("PXKCO",$J,VST,"IMM",IEN,0,NODE))
. S SYS=+$O(@GBL@(IMM,3,"B","CPT",0))
. S:SYS Y=+$O(@GBL@(IMM,3,SYS,1,"B",CPT,0))
I Y Q 1
; else ok/not dup
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRENC 12221 printed Sep 23, 2025@20:21:33 Page 2
VPRENC ;SLC/MKB -- VistA Encounter updates ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**19,20,26,25,27,28,29**;Sep 01, 2011;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Collect all visit changes in (NOW = time last modified):
+5 ;^XTMP("VPRPX",0) = DT+2 ^ DT ^ VPR ENCOUNTERS
+6 ;^XTMP("VPRPX", visit~dfn) = NOW ^ ID ^ NEW ^ VTYP
+7 ;^XTMP("VPRPX", visit~dfn, "SUB", ien) = NEW
+8 ;^XTMP("VPRPX", visit~dfn, "SUB", ien, 0) = BEFORE 0-node, if deleted
+9 ;^XTMP("VPRPX", "DOC", ien) = NOW ^ id [^ visit ^ @/1, if amended]
+10 ;^XTMP("VPRPX", "DOC", ien, 0) = BEFORE 0-node, if deleted
+11 ;^XTMP("VPRPX", "AVST"/"ADOC", NOW, ien) = ""
+12 ;
+13 ; where:
+14 ; NOW = time last modified
+15 ; ID = record id as 'ien;file#'
+16 ; NEW = 1 if new during session
+17 ; VTYP = 1 if visit type in V CPT was deleted (else null)
+18 ;
PX ; -- PXK VISIT DATA EVENT protocol listener
+1 ;monitoring disabled
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+2 NEW VST,PX0A,PX0B,DFN,VSTX,VPRPX,X,NOW,NEW,ID,SUB,DA,ACT,VTYP
+3 SET VST=+$ORDER(^TMP("PXKCO",$JOB,0))
if VST<1
QUIT
+4 SET PX0A=$GET(^TMP("PXKCO",$JOB,VST,"VST",VST,0,"AFTER"))
SET PX0B=$GET(^("BEFORE"))
+5 SET DFN=$SELECT($LENGTH(PX0A):+$PIECE(PX0A,U,5),1:+$PIECE(PX0B,U,5))
if DFN<1
QUIT
+6 ;visit id for XTMP
SET VSTX=VST_"~"_DFN
+7 ;
+8 ; get or set up ^XTMP
+9 SET VPRPX=$NAME(^XTMP("VPRPX"))
+10 ;I'$T
LOCK +@VPRPX@(VSTX):5
+11 ;
+12 ; Visit file
+13 SET X=$GET(@VPRPX@(VSTX))
SET NOW=+X
SET ID=$PIECE(X,U,2)
SET NEW=$PIECE(X,U,3)
SET VTYP=$PIECE(X,U,4)
+14 ;reset clock
if NOW
KILL @VPRPX@("AVST",NOW,VSTX)
+15 IF ID=""
SET ID=VST_";9000010"
+16 SET NOW=$$NOW^XLFDT
SET @VPRPX@("AVST",NOW,VSTX)=""
+17 if PX0B=""
SET NEW=1
+18 SET @VPRPX@(VSTX)=NOW_U_ID_U_NEW_U_VTYP
+19 ;
+20 ; V-files
+21 ;"PED","SK"
FOR SUB="IMM","ICR","XAM","POV","HF","CPT"
Begin DoDot:1
+22 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXKCO",$JOB,VST,SUB,DA))
if DA<1
QUIT
Begin DoDot:2
+23 ;not changed
SET ACT=$$DIFF(SUB,DA)
if 'ACT
QUIT
+24 ;not Hx
IF SUB="HF"
if $$NAME(SUB,DA)=""
QUIT
+25 ;duplicate code
IF SUB="CPT"
Begin DoDot:3
+26 if $PIECE($GET(^TMP("PXKCO",$JOB,VST,SUB,DA,0,"BEFORE")),U)'?1"992"2N
QUIT
+27 ;visit type deleted
if ACT<1
SET $PIECE(@VPRPX@(VSTX),U,4)=1
End DoDot:3
if $$DUP(DA)
QUIT
+28 SET NEW=$GET(@VPRPX@(VSTX,SUB,DA))
if ACT=2
SET NEW=1
+29 ;new flag
SET @VPRPX@(VSTX,SUB,DA)=NEW
+30 SET X=$GET(^TMP("PXKCO",$JOB,VST,SUB,DA,0,"AFTER"))
if 'X
SET X=$GET(^("BEFORE"))
+31 if $LENGTH(X)
SET @VPRPX@(VSTX,SUB,DA,0)=X
End DoDot:2
End DoDot:1
PXQ ; done
+1 LOCK -@VPRPX@(VSTX)
+2 IF '$GET(@VPRPX@("ZTSK"))
DO NEWTSK
+3 QUIT
+4 ;
DIFF(NM,IEN) ; -- returns 0/1 if un/changed, 2 if new, -1 if deleted
+1 NEW NODE,AFTER,BEFORE,DIFF
+2 SET DIFF=0
FOR NODE=0,12,13,811
Begin DoDot:1
+3 SET AFTER=$GET(^TMP("PXKCO",$JOB,VST,NM,IEN,NODE,"AFTER"))
SET BEFORE=$GET(^("BEFORE"))
+4 if BEFORE=AFTER
QUIT
SET DIFF=1
+5 ;new
if (NODE=0)&(BEFORE="")
SET DIFF=2
+6 ;deleted
if (NODE=0)&(AFTER="")
SET DIFF=-1
End DoDot:1
if DIFF
QUIT
+7 QUIT DIFF
+8 ;
EDP(IEN) ; -- EDP Log file #230 AVPR index
+1 ;monitoring disabled
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+2 NEW EDP0,VST,DFN,VSTX,VPRPX,X,NOW,ID,NEW
+3 SET IEN=+$GET(IEN)
if IEN<1
QUIT
+4 SET EDP0=$GET(^EDP(230,IEN,0))
SET VST=+$PIECE(EDP0,U,12)
if VST<1
QUIT
+5 SET DFN=+$PIECE(EDP0,U,6)
if DFN<1
QUIT
+6 ; non-PCE event so post immediately for BMS
+7 DO POST^VPRHS(DFN,"Encounter",VST_";9000010")
+8 QUIT
+9 ; get or set up ^XTMP [old]
+10 ;visit id for XTMP
SET VSTX=VST_"~"_DFN
+11 SET VPRPX=$NAME(^XTMP("VPRPX"))
+12 ;I'$T
LOCK +@VPRPX@(VSTX):5
+13 ;
+14 ; Visit file
+15 SET X=$GET(@VPRPX@(VSTX))
SET NOW=+X
SET ID=$PIECE(X,U,2)
SET NEW=$PIECE(X,U,3)
+16 ;reset clock
if NOW
KILL @VPRPX@("AVST",NOW,VSTX)
+17 IF ID=""
SET ID=VST_";9000010"
+18 SET NOW=$$NOW^XLFDT
SET @VPRPX@("AVST",NOW,VSTX)=""
+19 SET @VPRPX@(VSTX)=NOW_U_ID_U_NEW
+20 ;
+21 LOCK -@VPRPX@(VSTX)
+22 IF '$GET(@VPRPX@("ZTSK"))
DO NEWTSK
+23 QUIT
+24 ;
TIU(IEN,ACT,VST) ; -- TIU Document file #8925 [from TIU/R^VPREVNT]
+1 ; add to ^XTMP("VPRPX") list w/encounters
+2 NEW VPRPX,X0,NOW,NEW
+3 SET VPRPX=$NAME(^XTMP("VPRPX"))
SET IEN=+$GET(IEN)
+4 ;I'$T
LOCK +@VPRPX@("DOC",IEN):5
+5 ;
+6 SET X0=$GET(@VPRPX@("DOC",IEN))
SET NOW=+X0
if NOW
KILL @VPRPX@("ADOC",NOW,IEN)
+7 ;VST passed in if retracted
SET VST=$GET(VST,$PIECE(X0,U,3))
SET NEW=$PIECE(X0,U,4)
+8 ; ACT=1 for new amendment, if aborted (@) kill XTMP and quit
+9 IF NEW
IF $GET(ACT)="@"
KILL @VPRPX@("DOC",IEN)
LOCK -@VPRPX@("DOC",IEN)
QUIT
+10 ;
+11 SET NOW=$$NOW^XLFDT
SET @VPRPX@("ADOC",NOW,IEN)=""
if $LENGTH($GET(ACT))
SET NEW=ACT
+12 SET @VPRPX@("DOC",IEN)=NOW_U_IEN_";8925"_U_VST_U_NEW
+13 if NEW="@"
SET @VPRPX@("DOC",IEN,0)=$$NODE("TIU(8925,",IEN,0)
+14 LOCK -@VPRPX@("DOC",IEN)
+15 IF '$GET(@VPRPX@("ZTSK"))
DO NEWTSK
+16 QUIT
+17 ;
NEWTSK ; -- start new task
+1 ;will try again
LOCK +^XTMP("VPRPX","ZTSK"):3
if '$TEST
QUIT
+2 ; if no competing process got there first, create task
+3 IF '$GET(^XTMP("VPRPX","ZTSK"))
DO QUE(5)
+4 LOCK -^XTMP("VPRPX","ZTSK")
+5 QUIT
+6 ;
QUE(M) ; -- create task to post encounters, documents to HS
+1 NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
+2 SET ZTRTN="TASK^VPRENC"
SET ZTDESC="VPR Encounters"
SET ZTIO=""
+3 SET M=+$GET(M,5)
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,M)
+4 DO ^%ZTLOAD
+5 SET ^XTMP("VPRPX","ZTSK")=$GET(ZTSK)
+6 SET ^XTMP("VPRPX",0)=$$FMADD^XLFDT(DT,2)_U_DT_"^Encounters for HealthShare"
+7 QUIT
+8 ;
TASK ; -- post an encounter update
+1 ;monitoring disabled
SET ZTREQ="@"
if '$PIECE($GET(^VPR(1,0)),U,2)
QUIT
+2 NEW VPRPX,VPRDT,VPRI,VSTX,VST,X0,DFN,V0,VNM,VFL,VDA,VID,ACT,X,VPRD14,VPRSQ
+3 SET VPRPX=$NAME(^XTMP("VPRPX"))
SET VPRDT=$$FMADD^XLFDT($$NOW^XLFDT,,,-2)
+4 SET VPRD14=$$FMADD^XLFDT(DT,14)
+5 ; post visits that have been stable for at least 5 minutes
+6 SET VPRI=0
FOR
SET VPRI=$ORDER(@VPRPX@("AVST",VPRI))
if VPRI<1
QUIT
if VPRI>VPRDT
QUIT
Begin DoDot:1
+7 SET VSTX=""
FOR
SET VSTX=$ORDER(@VPRPX@("AVST",VPRI,VSTX))
if VSTX=""
QUIT
Begin DoDot:2
+8 IF '$DATA(@VPRPX@(VSTX))
KILL @VPRPX@("AVST",VPRI,VSTX)
QUIT
+9 ;will requeue
LOCK +@VPRPX@(VSTX):5
if '$TEST
QUIT
+10 SET X0=$GET(@VPRPX@(VSTX))
SET VST=+VSTX
SET DFN=+$PIECE(VSTX,"~",2)
+11 SET V0=$GET(^AUPNVSIT(VST,0))
+12 ;deleted or replaced:
IF V0=""!($PIECE(V0,U,5)'=DFN)
Begin DoDot:3
+13 ; not in HS, just kill XTMP
IF $PIECE(X0,U,3)
DO KILL
QUIT
+14 ; else send delete to HS
DO DELALL
End DoDot:3
QUIT
+15 ; post Encounter to HS
+16 SET VID=$PIECE(X0,U,2)
if VID=""
SET VID=VST_";9000010"
+17 KILL VPRSQ
DO POST^VPRHS(DFN,"Encounter",VID,,,.VPRSQ)
+18 ;VType deleted
IF $GET(VPRSQ)
IF $PIECE(X0,U,4)
DO SAVST(VPRSQ,"U",1)
TV ; post related v-file records next
+1 SET VFL=""
FOR
SET VFL=$ORDER(@VPRPX@(VSTX,VFL))
if VFL=""
QUIT
Begin DoDot:3
+2 SET VDA=0
FOR
SET VDA=$ORDER(@VPRPX@(VSTX,VFL,VDA))
if VDA<1
QUIT
Begin DoDot:4
+3 ;not tracked
SET VNM=$$NAME(VFL,VDA)
if VNM=""
QUIT
+4 SET V0=$$ZERO(VFL,VDA)
SET VID=VDA_";"_$PIECE(VNM,U,2)
+5 ; if exists & is valid send to HS, else quit/delete
+6 IF V0
IF $PIECE(V0,U,2)=DFN
IF $PIECE(V0,U,3)=VST
DO POST^VPRHS(DFN,$PIECE(VNM,U),VID,,VST)
QUIT
+7 ;new, backed out (don't send)
if $GET(@VPRPX@(VSTX,VFL,VDA))
QUIT
+8 ;S VID=VDA_"~"_VST_";"_$P(VNM,U,2)
KILL VPRSQ
+9 DO POST^VPRHS(DFN,$PIECE(VNM,U),VID,"@",VST,.VPRSQ)
+10 IF $GET(VPRSQ)
DO SAVE(VPRSQ,VDA)
End DoDot:4
End DoDot:3
+11 ;delete XTMP, unlock
DO KILL
+12 ; post related documents
+13 SET VDA=0
FOR
SET VDA=$ORDER(^TIU(8925,"V",+VST,VDA))
if VDA<1
QUIT
IF $GET(@VPRPX@("DOC",VDA))
DO DOC
End DoDot:2
End DoDot:1
TD ; look for waiting documents w/o visit [yet]
+1 SET VPRI=0
FOR
SET VPRI=$ORDER(@VPRPX@("ADOC",VPRI))
if VPRI<1
QUIT
if VPRI>VPRDT
QUIT
Begin DoDot:1
+2 SET VDA=0
FOR
SET VDA=$ORDER(@VPRPX@("ADOC",VPRI,VDA))
if VDA<1
QUIT
Begin DoDot:2
+3 ;bad xref
IF '$GET(@VPRPX@("DOC",VDA))
KILL @VPRPX@("ADOC",VPRI,VDA)
QUIT
+4 DO DOC
End DoDot:2
End DoDot:1
TQ ; re-task if more data
+1 SET X=$ORDER(@VPRPX@(0))
IF $LENGTH(X)
IF X'="ZTSK"
DO QUE(5)
QUIT
+2 KILL @VPRPX@("ZTSK")
+3 QUIT
+4 ;
DELALL ; -- delete visit + vfiles from HS [from TASK]
+1 SET VFL=""
FOR
SET VFL=$ORDER(@VPRPX@(VSTX,VFL))
if VFL=""
QUIT
Begin DoDot:1
+2 SET VDA=0
FOR
SET VDA=$ORDER(@VPRPX@(VSTX,VFL,VDA))
if VDA<1
QUIT
Begin DoDot:2
+3 ;not tracked in HS
SET VNM=$$NAME(VFL,VDA)
IF VNM=""
QUIT
+4 ;never sent to HS
IF $GET(@VPRPX@(VSTX,VFL,VDA))
QUIT
+5 ;_"~"_VST
KILL VPRSQ
SET VID=VDA_";"_$PIECE(VNM,U,2)
+6 DO POST^VPRHS(DFN,$PIECE(VNM,U),VID,"@",VST,.VPRSQ)
+7 IF $GET(VPRSQ)
DO SAVE(VPRSQ,VDA)
End DoDot:2
End DoDot:1
+8 KILL VPRSQ
DO POST^VPRHS(DFN,"Encounter",VST_";9000010","@",,.VPRSQ)
+9 IF $GET(VPRSQ)
DO SAVST(VPRSQ)
KILL ; clean up ^XTMP
+1 KILL @VPRPX@(VSTX),@VPRPX@("AVST",VPRI,VSTX)
+2 LOCK -@VPRPX@(VSTX)
+3 QUIT
+4 ;
SAVE(NUM,DA) ; -- save data for V-file record [from TV,DELALL] in
+1 ; ^XTMP("VPR-"_NUM, 0) = DT+14 ^ DT ^ Deleted records
+2 ; ^XTMP("VPR-"_NUM,DA) = DFN ^ TYPE ^ ID ^ U/D ^ VISIT#
+3 ; ^XTMP("VPR-"_NUM,DA,0) = DATA
+4 if '$GET(NUM)
QUIT
if '$GET(DA)
QUIT
+5 if '$GET(VPRD14)
SET VPRD14=$$FMADD^XLFDT(DT,14)
+6 SET ^XTMP("VPR-"_NUM,0)=VPRD14_U_DT_"^Deleted record for AVPR"
+7 SET ^XTMP("VPR-"_NUM,DA)=DFN_U_$PIECE(VNM,U)_U_VID_"^D^"_VST
+8 SET X=$GET(@VPRPX@(VSTX,VFL,DA,0))
if $LENGTH(X)
SET ^XTMP("VPR-"_NUM,DA,0)=X
+9 QUIT
SAVST(NUM,ACT,TYP) ; -- save visit in ^XTMP [from TASK,DELALL]
+1 if '$GET(NUM)
QUIT
if '$GET(VST)
QUIT
SET ACT=$GET(ACT,"D")
+2 if '$GET(VPRD14)
SET VPRD14=$$FMADD^XLFDT(DT,14)
+3 SET ^XTMP("VPR-"_NUM,0)=VPRD14_U_DT_"^Deleted visit for AVPR"
+4 SET ^XTMP("VPR-"_NUM,VST)=DFN_"^Encounter^"_VST_";9000010^"_ACT_U_U_$GET(TYP)
+5 QUIT
+6 ;
DOC ; -- process Document VDA [from TASK]
+1 ;will requeue
LOCK +@VPRPX@("DOC",VDA):5
if '$TEST
QUIT
+2 NEW VPRTIU,STS,ACT,CLS,VPRSQ
+3 SET X0=$GET(@VPRPX@("DOC",VDA))
DO EXTRACT(VDA)
+4 SET VST=$GET(VPRTIU(.03))
SET DFN=$GET(VPRTIU(.02))
+5 ; quit if has visit, still in ^XTMP (send w/visit)
+6 IF VST
IF $GET(@VPRPX@(VST_"~"_DFN))
LOCK -@VPRPX@("DOC",VDA)
QUIT
+7 ; else post to HS
+8 SET VID=$PIECE(X0,U,2)
IF VID=""
SET VID=VDA_";8925"
+9 SET STS=$GET(VPRTIU(.05))
SET ACT=$SELECT($PIECE(X0,U,4)="@":"@",STS>13:"@",1:"")
+10 ;amended
IF ACT="@"
IF 'VST
SET VST=$PIECE(X0,U,3)
+11 DO POST^VPRHS(DFN,"Document",VID,ACT,VST,.VPRSQ)
+12 ;save to preserve visit#
IF ACT="@"
IF $GET(VPRSQ)
Begin DoDot:1
+13 SET ^XTMP("VPR-"_VPRSQ,VDA)=DFN_"^Document^"_VID_"^D^"_VST
+14 SET X=+$GET(VPRTIU(.01))
SET ^XTMP("VPR-"_VPRSQ,VDA,0)=X_U_DFN_U_VST
+15 SET ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
End DoDot:1
+16 ; update alert containers if CLS is CWD
+17 SET CLS=$GET(VPRTIU(.04))
+18 if CLS=27
DO POST^VPRHS(DFN,"AdvanceDirective",VID,ACT)
+19 if CLS=30!(CLS=31)
DO POST^VPRHS(DFN,"Alert",VID,ACT)
DQ ; clean up array, unlock
+1 KILL @VPRPX@("DOC",VDA),@VPRPX@("ADOC",+X0,VDA)
+2 LOCK -@VPRPX@("DOC",VDA)
+3 ;
+4 ;add/update Surgery when report completed
IF VST
Begin DoDot:1
+5 NEW PROC
SET PROC=$GET(VPRTIU(1405))
if 'PROC
QUIT
+6 IF PROC["SRF"
DO POST^VPRHS(DFN,"Procedure",+PROC_";130",,VST)
QUIT
End DoDot:1
+7 QUIT
+8 ;
+1 NEW I,DR,DIC,DIQ,VPRQ
if '$GET(DA)
QUIT
+2 IF $PIECE(X0,U,4)="@"
Begin DoDot:1
+3 NEW X1
SET X1=$GET(@VPRPX@("DOC",VDA,0))
+4 FOR I=1:1:5
SET VPRTIU(".0"_I)=$PIECE(X1,U,I)
End DoDot:1
QUIT
+5 SET DIC=8925
SET DIQ="VPRQ"
SET DIQ(0)="I"
SET DR=".01:.05;1405"
DO EN^DIQ1
+6 FOR I=.01,.02,.03,.04,.05,1405
SET VPRTIU(I)=$GET(VPRQ(8925,DA,I,"I"))
+7 QUIT
+8 ;
NAME(X,DA) ; -- return container name for V-files
+1 NEW Y
SET Y=""
+2 IF X="HF"
Begin DoDot:1
+3 NEW NM
SET DA=+$GET(DA)
SET NM=$PIECE($GET(^AUTTHF($$HF(DA),0)),U)
+4 IF $$FHX(NM)
SET Y="FamilyHistory^9000010.23"
QUIT
+5 IF $$SHX(NM)
SET Y="SocialHistory^9000010.23"
QUIT
+6 IF $$C19(NM)
SET Y="Vaccination^9000010.23"
QUIT
+7 ;S Y="HealthConcern^9000010.23"
End DoDot:1
+8 IF X="IMM"
SET Y="Vaccination^9000010.11"
+9 IF X="ICR"
SET Y="Vaccination^9000010.707"
+10 IF X="XAM"
SET Y="PhysicalExam^9000010.13"
+11 IF X="POV"
SET Y="Diagnosis^9000010.07"
+12 IF X="CPT"
SET Y="Procedure^9000010.18"
+13 ; X="SK" S Y="Procedure^9000010.12"
+14 ; X="PED" S Y="education^9000010.16"
+15 IF X="DOC"
SET Y="Document^8925"
+16 QUIT Y
+17 ;
HF(IEN) ; -- return AUTTHF ptr, expects VST & VSTX
+1 NEW X
SET IEN=+$GET(IEN)
+2 IF $GET(VST)
IF $DATA(^TMP("PXKCO",$JOB,VST))
Begin DoDot:1
+3 SET X=$GET(^TMP("PXKCO",$JOB,VST,"HF",IEN,0,"BEFORE"))
if 'X
SET X=$GET(^("AFTER"))
End DoDot:1
QUIT +X
+4 IF $DATA(VPRPX)
IF $GET(VSTX)
SET X=$GET(@VPRPX@(VSTX,"HF",IEN,0))
IF X
QUIT +X
+5 SET X=$$ZERO("HF",IEN)
IF X
QUIT +X
+6 QUIT 0
+7 ;
FHX(X) ; -- return 1 or 0, if HF name is for FamilyHistory
+1 IF X["FAMILY HISTORY"
QUIT 1
+2 IF X["FAMILY HX"
QUIT 1
+3 QUIT 0
+4 ;
SHX(X) ; -- return 1 or 0, if HF name is for SocialHistory
+1 IF (X["TOBACCO")!(X["SMOK")
QUIT 1
+2 ; (X["LIVES")!(X["LIVING") Q 1
+3 ; (X["RELIGIO")!(X["SPIRIT") Q 1
+4 QUIT 0
+5 ;
C19(X) ; -- return 1 or 0, if HF name is for COVID imm refusal
+1 IF X?1"VA-SARS-COV-2 VACCINE REFUSAL".E
QUIT 1
+2 IF X?1"VA-SARS-COV-2 IMM REFUSAL".E
QUIT 1
+3 QUIT 0
+4 ;
ZERO(X,DA) ; -- return zero node
+1 NEW GBL,Y
SET Y=""
SET DA=+$GET(DA)
+2 SET GBL="^AUPNV"_$GET(X)
SET Y=$GET(@GBL@(DA,0))
+3 QUIT Y
+4 ;
NODE(NAME,DA,NUM) ; -- return global node
+1 NEW GBL,Y
SET Y=""
SET DA=+$GET(DA)
+2 SET GBL=U_NAME_DA_")"
+3 SET Y=$GET(@GBL@(NUM))
+4 QUIT Y
+5 ;
DUP(DA) ; -- duplicate CPT record?
+1 NEW VCPT,NODE,CPT,PKG,Y,IEN,GBL,IMM,SYS
+2 MERGE VCPT=^TMP("PXKCO",$JOB,VST,SUB,DA)
+3 SET NODE=$SELECT($GET(VCPT(0,"AFTER")):"AFTER",1:"BEFORE")
+4 ; skip eval/mgt codes
+5 SET CPT=$PIECE($GET(VCPT(0,NODE)),U)
IF CPT>99200
IF CPT<99500
QUIT 1
+6 ; skip Surgery (duplicates)
+7 SET PKG=+$PIECE($GET(VCPT(812,NODE)),U,2)
IF PKG
IF $PIECE($GET(^DIC(9.4,PKG,0)),U,2)="SR"
QUIT 1
+8 ; skip V IMMUNIZATIONS codes
+9 SET GBL="^AUTTIMM"
SET (Y,IEN)=0
+10 FOR
SET IEN=$ORDER(^TMP("PXKCO",$JOB,VST,"IMM",IEN))
if IEN<1
QUIT
Begin DoDot:1
+11 SET NODE=$SELECT($GET(^TMP("PXKCO",$JOB,VST,"IMM",IEN,0,"AFTER")):"AFTER",1:"BEFORE")
+12 SET IMM=+$GET(^TMP("PXKCO",$JOB,VST,"IMM",IEN,0,NODE))
+13 SET SYS=+$ORDER(@GBL@(IMM,3,"B","CPT",0))
+14 if SYS
SET Y=+$ORDER(@GBL@(IMM,3,SYS,1,"B",CPT,0))
End DoDot:1
if Y
QUIT
+15 IF Y
QUIT 1
+16 ; else ok/not dup
+17 QUIT 0
