VPREVNT ;SLC/MKB -- VistA event listeners ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,17,19,21,20,26,25,27,29,31,34,33,35**;Sep 01, 2011;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; DG FIELD MONITOR 3344
; DG SA FILE ENTRY NOTIFIER 7232
; DGPM MOVEMENT EVENTS 1181
; GMPL EVENT 6065
; GMRA ASSESSMENT CHANGE 6986
; GMRA ENTERED IN ERROR 1467
; GMRA SIGN-OFF ON DATA 1469
; GMRA VERIFY DATA 1470
; IBCN NEW INSURANCE 7010
; MDC OBSERVATION UPDATE 6084
; PSB EVSEND VPR 6085
; PXK VISIT DATA EVENT 1298
; SCMC PATIENT TEAM CHANGES 7012
; SCMC PATIENT TEAM POSITION 7013
; SDAM APPOINTMENT EVENTS 1320
; TIU DOCUMENT ACTION EVENT 6774
; WV PREGNANCY STATUS CHANGE EVENT 7200
; ^AUPNPROB 5703
; ^AUPNVSIT 2028
; ^DGPM 1865
; ^DGS(41.1 3796
; ^DIC(42 10039
; ^DPT 10035
; ^GMR(120.8 6973
; ^GMR(120.86 3449
; ^TIU(8925.1 5677
; ^TIU(8925.7 7416
; %ZTLOAD 10063
; DIQ 2056
; XLFDT 10103
;
DG ; -- DG FIELD MONITOR protocol listener
; [expects variables DGDA, DGFIELD, DGFILE]
N VPRFN S VPRFN=$G(DGFILE)
I "^2^2.01^2.02^2.06^38.1^"'[(U_VPRFN_U) Q
N DFN S DFN=+$G(DGDA)
; collect individual fields into single tasked update if possible
D QUE^VPRHS(DFN) Q ;skip fld check
I VPRFN=2 D:$$FLD(+$G(DGFIELD)) QUE^VPRHS(DFN) Q
D POST^VPRHS(DFN,"Patient",DFN_";2")
Q
;
FLD(X) ; -- Return 1 or 0, if X is a field tracked by VPR
; via DG FIELD MONITOR
S X=U_+$G(X)_U
I "^.01^.02^.03^.05^.07^.08^.09^.092^.093^.351^"[X Q 1 ;demographic
I "^.111^.1112^.112^.113^.114^.115^.131^.132^.134^"[X Q 1 ;addr/phone
I "^.211^.212^.213^.214^.216^.217^.218^.219^.21011^"[X Q 1 ;NOK
I "^.331^.332^.333^.334^.335^.336^.337^.338^.339^"[X Q 1 ;ECON
I "^.301^.302^.32102^.32103^.3215^.32201^.5295^"[X Q 1 ;serv conn
I "^.14^.323^.361^1901^"[X Q 1
Q 0
;
NEWINPT() ; -- is DFN newly admitted?
N Y S Y=0
I DGPMT=1,DGPMA,'DGPMP,+$G(^DPT(DFN,.105))=DGPMDA S Y=1 ;new admission
Q Y
;
DGPM ; -- DGPM MOVEMENT EVENTS protocol listener
; [expects DFN,DGPM* variables]
I $$NEWINPT,$$ON^VPRHS,'$$SUBS^VPRHS(DFN),$$VALID^VPRHS(DFN) D NEW^VPRHS(DFN) Q
N ADM,VST,ADMA,ADMP
I DGPMT'=1 D ;update related admission if not in ^UTILITY
. S ADM=$S(DGPMA:+$P(DGPMA,U,14),1:+$P(DGPMP,U,14))
. Q:$D(^UTILITY("DGPM",$J,1,ADM))
. S VST=$$VNUM^VPRSDAV(ADM) Q:'VST
. D POST^VPRHS(DFN,"Encounter",ADM_"~"_VST_";405")
; process all updated admissions
S ADM=0 F S ADM=$O(^UTILITY("DGPM",$J,1,ADM)) Q:ADM<1 D
. S ADMA=$G(^UTILITY("DGPM",$J,1,ADM,"A")),ADMP=$G(^("P"))
. I ADMP,ADMA="" D CKVST Q ;deleted (still has Visit#)
. S VST=$$VNUM^VPRSDAV(ADM) Q:'VST
. D POST^VPRHS(DFN,"Encounter",ADM_"~"_VST_";405")
Q
CKVST ; -- delete visit if unused [from DGPM]
N HLOC,VPRSQ
S HLOC=+$G(^DIC(42,+$P(ADMP,U,6),44))
S VST=$O(^AUPNVSIT("AET",DFN,+ADMP,HLOC,"P",0)) Q:'VST
Q:$P($G(^AUPNVSIT(VST,0)),U,9)>0 ;D POST^VPRHS(DFN,"Encounter",VST_";9000010")
; save deleted encounter in ^XTMP - see DELALL^VPRENC
K VPRSQ D POST^VPRHS(DFN,"Encounter",VST_";9000010","@",,.VPRSQ)
I $G(VPRSQ) D SAVST^VPRENC(VPRSQ)
Q
;
DGS ; -- DG SA FILE ENTRY NOTIFIER protocol listener
N IEN,DFN,ACT S ACT=""
S IEN=+$G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"IEN")) Q:IEN<1
S DFN=+$G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"DFN","CURRENT"))
I DFN<1 S DFN=+$G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"DFN","OLD")) Q:DFN<1
;I $G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"ACTION"))="DELETED" S ACT="@"
;I $G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"ACTION"))="MODIFIED",$P($G(^DGS(41.1,IEN,0)),U,13) S ACT="@"
D POST^VPRHS(DFN,"Appointment",IEN_";41.1",ACT)
Q
;
SDAM ; -- SDAM APPOINTMENT EVENTS protocol listener
; [expects variables SDATA, SDAMEVT]
N DFN,DATE,ACT Q:'$G(SDATA)
Q:$G(SDAMEVT)>5 ;only track make, cancel, no show, check in/out
; quit if status has not changed
Q:$G(SDATA("BEFORE","STATUS"))=$G(SDATA("AFTER","STATUS"))
S DFN=+$P(SDATA,U,2) Q:DFN<1
S DATE=+$P(SDATA,U,3),ACT="" ;ACT=$S($G(SDAMEVT)=2:"@",1:"")
D POST^VPRHS(DFN,"Appointment",(DATE_","_DFN_";2.98"),ACT)
Q
;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
; also GMRA ENTERED IN ERROR [ACT=@]
; [expects GMRAPA variables]
N DFN,IEN,NEW,I
S DFN=+$G(GMRAPA(0)),IEN=+$G(GMRAPA)
D POST^VPRHS(DFN,"Allergy",IEN_";120.8") ;,$G(ACT))
Q
;
GMRASMT(DFN) ; -- GMRA ASSESSMENT CHANGE listener
N ACT S ACT=$S($P($G(^GMR(120.86,DFN,0)),U,2):"@",1:"")
D POST^VPRHS(DFN,"Allergy",DFN_";120.86",ACT)
Q
;
GMPL(DFN,IEN) ; -- GMPL EVENT protocol listener
S DFN=+$G(DFN),IEN=+$G(IEN)
N ACT S ACT=$S($P($G(^AUPNPROB(IEN,1)),U,2)="H":"@",1:"")
D POST^VPRHS(DFN,"Problem",IEN_";9000011",ACT)
Q
;
GMRV(DFN,IEN,ERR) ; -- Vital Measurement file #120.5 AVPR index
S DFN=+$G(DFN),IEN=+$G(IEN)
N ACT S ACT=$S($G(ERR):"@",1:"")
D POST^VPRHS(DFN,"Observation",IEN_";120.5",ACT)
Q
;
CP(DFN,ID,ACT) ; -- CP Transaction file #702 AVPR index
Q ; via VPRPROC [no longer used]
S DFN=+$G(DFN),ID=+$G(ID)
N VST S VST=$$GET1^DIQ(702,ID,".06:.03","I")
D POST^VPRHS(DFN,"Procedure",ID_";702",$G(ACT),VST)
Q
;
TIU(DFN,IEN) ; -- TIU Document file #8925 AEVT index
; [expects X, X1, X2 arrays from FM]
N STS,DAD,ACT
S DFN=+$G(DFN),IEN=+$G(IEN) Q:DFN<1 Q:IEN<1
S STS=$G(X(2)),DAD=$G(X(3)) ;X = FM data array for index
I STS<7 Q ;not complete
I STS=9 Q ;archived, leave in cache unchanged
I STS>13 Q ;removed, handled via protocol
S:DAD IEN=DAD ;if addendum, repull entire note
S ACT=$S(X2(2)&(X1(2)=""):1,X1&(X2=""):"@",1:"") ;add/remove amendment
D TIU^VPRENC(IEN,ACT) ;add to ^XTMP("VPRPX") encounter list
Q
;
TIUR ; -- TIU DOCUMENT ACTION EVENT listener (removing notes)
N ARY,ACT,DFN,IEN,VST,DAD,X,VPRSQ,CLS
S ARY=$NA(^TMP("TIUDOCACT",$J)),ACT=$G(@ARY@("ACTION"))
I ACT="RETRACT" D Q:IEN<1 G TRQ ;not DELETE
. S DFN=+$G(@ARY@("PATIENT")),VST=$G(@ARY@("VISIT"))
. S IEN=+$G(@ARY@("DOCUMENT")) Q:IEN<1 Q:DFN<1
. S DAD=+$$GET1^DIQ(8925,IEN,.06,"I") Q:'DAD
. ; update parent unless already retracted
. S IEN=$S($$GET1^DIQ(8925,DAD,.05,"I")=15:0,1:DAD)
;
Q:ACT'="REASSIGN"
S DFN=+$G(@ARY@("PATIENT","OLD")),VST=$G(@ARY@("VISIT","OLD"))
S IEN=+$G(@ARY@("DOCUMENT","OLD")) ;DA in NEW if patient unchanged
S:IEN<1 IEN=+$G(@ARY@("DOCUMENT","NEW")) Q:IEN<1 Q:DFN<1
S DAD=+$$GET1^DIQ(8925,IEN,.06,"I") I DAD D TIU^VPRENC(DAD) Q
; new document saved via regular index event
TRQ ; remove document from old patient/visit
S ACT=$S($G(DAD):"",1:"@") ;update parent if retracting addendum
D POST^VPRHS(DFN,"Document",IEN_";8925",ACT,VST,.VPRSQ)
I ACT="@",$G(VPRSQ) D ;save visit
. S ^XTMP("VPR-"_VPRSQ,IEN)=DFN_"^Document^"_IEN_";8925^D^"_VST
. S X=+$$GET1^DIQ(8925,IEN,.01,"I"),^XTMP("VPR-"_VPRSQ,IEN,0)=X_U_DFN_U_VST
. S ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
S CLS=$$GET1^DIQ(8925,IEN,.04,"I")
D:CLS=27 POST^VPRHS(DFN,"AdvanceDirective",IEN_";8925",ACT)
D:CLS=30!(CLS=31) POST^VPRHS(DFN,"Alert",IEN_";8925",ACT)
Q
;
TIUS(IEN) ; -- TIU MULTIPLE SIGNATURE file #8925.7 AVPR index
S IEN=+$G(IEN) Q:IEN<1
N TIU0,TIUIEN,DFN,VST
S TIU0=$G(^TIU(8925.7,IEN,0)),TIUIEN=+$P(TIU0,U) Q:TIUIEN<1
S DFN=$$GET1^DIQ(8925,TIUIEN,.02,"I") Q:DFN<1
S VST=$$GET1^DIQ(8925,TIUIEN,.03,"I") ;Ok if null
; non-PCE event so post immediately for BMS
D POST^VPRHS(DFN,"Document",TIUIEN_";8925",,VST)
Q
;
IBCN ; -- IBCN NEW INSURANCE EVENTS listener
; expects IBCDFN, IBEVTACT="ADD","EDT", or "DEL"
I '$G(IBCDFN) Q
N ACT,ID,VPRSQ,I S ID=IBCDFN_","_DFN
S ACT=$S($G(IBEVTACT)="DEL":"@",$G(IBEVTACT)="ADD":"",1:$$IBDIFF)
D POST^VPRHS(DFN,"MemberEnrollment",ID_";2.312",ACT,,.VPRSQ)
I ACT="@",$G(VPRSQ) D ;save old values for delete msg
. S ^XTMP("VPR-"_VPRSQ,ID)=DFN_"^MemberEnrollment^"_ID_";2.312^D^"
. F I=0,1,2,3,7 S ^XTMP("VPR-"_VPRSQ,ID,I)=$G(@("IBEVTP"_I))
. S ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
I ($G(IBEVTACT)="EDT")&(ACT="@") D ;task edit to ensure delete happens first
. N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
. S ZTRTN="IBTASK^VPREVNT",ZTDESC="VPR Insurance Update",ZTIO=""
. S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,2),ZTSAVE("DFN")="",ZTSAVE("ID")=""
. D ^%ZTLOAD
Q
IBDIFF() ; -- return 1 or 0, if key matching values changed
I +$G(IBEVTP0)'=+$G(IBEVTA0) Q 1
I $P($G(IBEVTP0),U,18)'=$P($G(IBEVTA0),U,18) Q 1
I $P($G(IBEVTP7),U,2)'=$P($G(IBEVTA7),U,2) Q 1
Q 0
IBTASK ; -- tasked update
Q:'$G(DFN) Q:'$G(ID)
D POST^VPRHS(DFN,"MemberEnrollment",ID_";2.312")
Q
;
PCMMT ; -- SCMC PATIENT TEAM CHANGES protocol listener
; [expects SCPTTM* variables]
;I '$G(SCPCTM) Q ;not pc change
N DFN S DFN=$S($G(SCPTTMAF):+SCPTTMAF,1:+$G(SCPTTMB4)) Q:'DFN
D QUE^VPRHS(DFN) ;POST^VPRHS(DFN,"Patient",DFN_";2")
Q
;
PCMMTP ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener
; [expects SCPTTP* variables]
;I '$G(SCPCTP) Q ;not pc change
N TM,DFN
S TM=$S($G(SCPTTPAF):+SCPTTPAF,1:+$G(SCPTTPB4)) Q:'TM
S DFN=+$$GET1^DIQ(404.42,TM_",",.01,"I")
D QUE^VPRHS(DFN) ;POST^VPRHS(DFN,"Patient",DFN_";2")
Q
;
WV ; -- WV PREGNANCY STATUS CHANGE EVENT protocol listener
N VPRPREG,VPRDFN,VPRFLD,VPRFLAG
M VPRPREG=^TMP("WVPREGST",$J)
Q:'$D(VPRPREG)
S VPRDFN=+$P($G(VPRPREG("AFTER","EXTERNAL ID")),",",2)
Q:VPRDFN=0
; if no before value, then new record, post
I '$D(VPRPREG("BEFORE")) D POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05") Q
Q:VPRDFN'=+$P($G(VPRPREG("BEFORE","EXTERNAL ID")),",",2)
; if external ids do not match, then additional record, post
I $G(VPRPREG("BEFORE","EXTERNAL ID"))'=$G(VPRPREG("AFTER","EXTERNAL ID")) D POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05") Q
; if change in fields we send to HS, post
S VPRFLAG=0
F VPRFLD="FROM TIME","STATE","STATUS","TO TIME" S:$G(VPRPREG("BEFORE",VPRFLD))'=$G(VPRPREG("AFTER",VPRFLD)) VPRFLAG=1 Q:VPRFLAG=1
I VPRFLAG=1 D POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05")
Q
;
; Deprecated calls:
;
DOCDEF(IEN) ; -- TIU Document Definition file #8925.1 AVPR index
Q
;
DOCITM(DAD) ; -- TIU Document Def'n Items subfile #8925.14 AVPR1 index
Q
;
USR(IEN) ; -- USR Authorization/Subscription file #8930.1 AVPR index
Q
;
XU(IEN,ACT) ; -- XU USER ADD/CHANGE/TERMINATE option listener
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPREVNT 11123 printed Dec 13, 2024@02:45:12 Page 2
VPREVNT ;SLC/MKB -- VistA event listeners ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,17,19,21,20,26,25,27,29,31,34,33,35**;Sep 01, 2011;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; DG FIELD MONITOR 3344
+7 ; DG SA FILE ENTRY NOTIFIER 7232
+8 ; DGPM MOVEMENT EVENTS 1181
+9 ; GMPL EVENT 6065
+10 ; GMRA ASSESSMENT CHANGE 6986
+11 ; GMRA ENTERED IN ERROR 1467
+12 ; GMRA SIGN-OFF ON DATA 1469
+13 ; GMRA VERIFY DATA 1470
+14 ; IBCN NEW INSURANCE 7010
+15 ; MDC OBSERVATION UPDATE 6084
+16 ; PSB EVSEND VPR 6085
+17 ; PXK VISIT DATA EVENT 1298
+18 ; SCMC PATIENT TEAM CHANGES 7012
+19 ; SCMC PATIENT TEAM POSITION 7013
+20 ; SDAM APPOINTMENT EVENTS 1320
+21 ; TIU DOCUMENT ACTION EVENT 6774
+22 ; WV PREGNANCY STATUS CHANGE EVENT 7200
+23 ; ^AUPNPROB 5703
+24 ; ^AUPNVSIT 2028
+25 ; ^DGPM 1865
+26 ; ^DGS(41.1 3796
+27 ; ^DIC(42 10039
+28 ; ^DPT 10035
+29 ; ^GMR(120.8 6973
+30 ; ^GMR(120.86 3449
+31 ; ^TIU(8925.1 5677
+32 ; ^TIU(8925.7 7416
+33 ; %ZTLOAD 10063
+34 ; DIQ 2056
+35 ; XLFDT 10103
+36 ;
DG ; -- DG FIELD MONITOR protocol listener
+1 ; [expects variables DGDA, DGFIELD, DGFILE]
+2 NEW VPRFN
SET VPRFN=$GET(DGFILE)
+3 IF "^2^2.01^2.02^2.06^38.1^"'[(U_VPRFN_U)
QUIT
+4 NEW DFN
SET DFN=+$GET(DGDA)
+5 ; collect individual fields into single tasked update if possible
+6 ;skip fld check
DO QUE^VPRHS(DFN)
QUIT
+7 IF VPRFN=2
if $$FLD(+$GET(DGFIELD))
DO QUE^VPRHS(DFN)
QUIT
+8 DO POST^VPRHS(DFN,"Patient",DFN_";2")
+9 QUIT
+10 ;
FLD(X) ; -- Return 1 or 0, if X is a field tracked by VPR
+1 ; via DG FIELD MONITOR
+2 SET X=U_+$GET(X)_U
+3 ;demographic
IF "^.01^.02^.03^.05^.07^.08^.09^.092^.093^.351^"[X
QUIT 1
+4 ;addr/phone
IF "^.111^.1112^.112^.113^.114^.115^.131^.132^.134^"[X
QUIT 1
+5 ;NOK
IF "^.211^.212^.213^.214^.216^.217^.218^.219^.21011^"[X
QUIT 1
+6 ;ECON
IF "^.331^.332^.333^.334^.335^.336^.337^.338^.339^"[X
QUIT 1
+7 ;serv conn
IF "^.301^.302^.32102^.32103^.3215^.32201^.5295^"[X
QUIT 1
+8 IF "^.14^.323^.361^1901^"[X
QUIT 1
+9 QUIT 0
+10 ;
NEWINPT() ; -- is DFN newly admitted?
+1 NEW Y
SET Y=0
+2 ;new admission
IF DGPMT=1
IF DGPMA
IF 'DGPMP
IF +$GET(^DPT(DFN,.105))=DGPMDA
SET Y=1
+3 QUIT Y
+4 ;
DGPM ; -- DGPM MOVEMENT EVENTS protocol listener
+1 ; [expects DFN,DGPM* variables]
+2 IF $$NEWINPT
IF $$ON^VPRHS
IF '$$SUBS^VPRHS(DFN)
IF $$VALID^VPRHS(DFN)
DO NEW^VPRHS(DFN)
QUIT
+3 NEW ADM,VST,ADMA,ADMP
+4 ;update related admission if not in ^UTILITY
IF DGPMT'=1
Begin DoDot:1
+5 SET ADM=$SELECT(DGPMA:+$PIECE(DGPMA,U,14),1:+$PIECE(DGPMP,U,14))
+6 if $DATA(^UTILITY("DGPM",$JOB,1,ADM))
QUIT
+7 SET VST=$$VNUM^VPRSDAV(ADM)
if 'VST
QUIT
+8 DO POST^VPRHS(DFN,"Encounter",ADM_"~"_VST_";405")
End DoDot:1
+9 ; process all updated admissions
+10 SET ADM=0
FOR
SET ADM=$ORDER(^UTILITY("DGPM",$JOB,1,ADM))
if ADM<1
QUIT
Begin DoDot:1
+11 SET ADMA=$GET(^UTILITY("DGPM",$JOB,1,ADM,"A"))
SET ADMP=$GET(^("P"))
+12 ;deleted (still has Visit#)
IF ADMP
IF ADMA=""
DO CKVST
QUIT
+13 SET VST=$$VNUM^VPRSDAV(ADM)
if 'VST
QUIT
+14 DO POST^VPRHS(DFN,"Encounter",ADM_"~"_VST_";405")
End DoDot:1
+15 QUIT
CKVST ; -- delete visit if unused [from DGPM]
+1 NEW HLOC,VPRSQ
+2 SET HLOC=+$GET(^DIC(42,+$PIECE(ADMP,U,6),44))
+3 SET VST=$ORDER(^AUPNVSIT("AET",DFN,+ADMP,HLOC,"P",0))
if 'VST
QUIT
+4 ;D POST^VPRHS(DFN,"Encounter",VST_";9000010")
if $PIECE($GET(^AUPNVSIT(VST,0)),U,9)>0
QUIT
+5 ; save deleted encounter in ^XTMP - see DELALL^VPRENC
+6 KILL VPRSQ
DO POST^VPRHS(DFN,"Encounter",VST_";9000010","@",,.VPRSQ)
+7 IF $GET(VPRSQ)
DO SAVST^VPRENC(VPRSQ)
+8 QUIT
+9 ;
DGS ; -- DG SA FILE ENTRY NOTIFIER protocol listener
+1 NEW IEN,DFN,ACT
SET ACT=""
+2 SET IEN=+$GET(^TMP("DG SA FILE ENTRY NOTIFIER",$JOB,"IEN"))
if IEN<1
QUIT
+3 SET DFN=+$GET(^TMP("DG SA FILE ENTRY NOTIFIER",$JOB,"DFN","CURRENT"))
+4 IF DFN<1
SET DFN=+$GET(^TMP("DG SA FILE ENTRY NOTIFIER",$JOB,"DFN","OLD"))
if DFN<1
QUIT
+5 ;I $G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"ACTION"))="DELETED" S ACT="@"
+6 ;I $G(^TMP("DG SA FILE ENTRY NOTIFIER",$J,"ACTION"))="MODIFIED",$P($G(^DGS(41.1,IEN,0)),U,13) S ACT="@"
+7 DO POST^VPRHS(DFN,"Appointment",IEN_";41.1",ACT)
+8 QUIT
+9 ;
SDAM ; -- SDAM APPOINTMENT EVENTS protocol listener
+1 ; [expects variables SDATA, SDAMEVT]
+2 NEW DFN,DATE,ACT
if '$GET(SDATA)
QUIT
+3 ;only track make, cancel, no show, check in/out
if $GET(SDAMEVT)>5
QUIT
+4 ; quit if status has not changed
+5 if $GET(SDATA("BEFORE","STATUS"))=$GET(SDATA("AFTER","STATUS"))
QUIT
+6 SET DFN=+$PIECE(SDATA,U,2)
if DFN<1
QUIT
+7 ;ACT=$S($G(SDAMEVT)=2:"@",1:"")
SET DATE=+$PIECE(SDATA,U,3)
SET ACT=""
+8 DO POST^VPRHS(DFN,"Appointment",(DATE_","_DFN_";2.98"),ACT)
+9 QUIT
+10 ;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
+1 ; also GMRA ENTERED IN ERROR [ACT=@]
+2 ; [expects GMRAPA variables]
+3 NEW DFN,IEN,NEW,I
+4 SET DFN=+$GET(GMRAPA(0))
SET IEN=+$GET(GMRAPA)
+5 ;,$G(ACT))
DO POST^VPRHS(DFN,"Allergy",IEN_";120.8")
+6 QUIT
+7 ;
GMRASMT(DFN) ; -- GMRA ASSESSMENT CHANGE listener
+1 NEW ACT
SET ACT=$SELECT($PIECE($GET(^GMR(120.86,DFN,0)),U,2):"@",1:"")
+2 DO POST^VPRHS(DFN,"Allergy",DFN_";120.86",ACT)
+3 QUIT
+4 ;
GMPL(DFN,IEN) ; -- GMPL EVENT protocol listener
+1 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
+2 NEW ACT
SET ACT=$SELECT($PIECE($GET(^AUPNPROB(IEN,1)),U,2)="H":"@",1:"")
+3 DO POST^VPRHS(DFN,"Problem",IEN_";9000011",ACT)
+4 QUIT
+5 ;
GMRV(DFN,IEN,ERR) ; -- Vital Measurement file #120.5 AVPR index
+1 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
+2 NEW ACT
SET ACT=$SELECT($GET(ERR):"@",1:"")
+3 DO POST^VPRHS(DFN,"Observation",IEN_";120.5",ACT)
+4 QUIT
+5 ;
CP(DFN,ID,ACT) ; -- CP Transaction file #702 AVPR index
+1 ; via VPRPROC [no longer used]
QUIT
+2 SET DFN=+$GET(DFN)
SET ID=+$GET(ID)
+3 NEW VST
SET VST=$$GET1^DIQ(702,ID,".06:.03","I")
+4 DO POST^VPRHS(DFN,"Procedure",ID_";702",$GET(ACT),VST)
+5 QUIT
+6 ;
TIU(DFN,IEN) ; -- TIU Document file #8925 AEVT index
+1 ; [expects X, X1, X2 arrays from FM]
+2 NEW STS,DAD,ACT
+3 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
if DFN<1
QUIT
if IEN<1
QUIT
+4 ;X = FM data array for index
SET STS=$GET(X(2))
SET DAD=$GET(X(3))
+5 ;not complete
IF STS<7
QUIT
+6 ;archived, leave in cache unchanged
IF STS=9
QUIT
+7 ;removed, handled via protocol
IF STS>13
QUIT
+8 ;if addendum, repull entire note
if DAD
SET IEN=DAD
+9 ;add/remove amendment
SET ACT=$SELECT(X2(2)&(X1(2)=""):1,X1&(X2=""):"@",1:"")
+10 ;add to ^XTMP("VPRPX") encounter list
DO TIU^VPRENC(IEN,ACT)
+11 QUIT
+12 ;
TIUR ; -- TIU DOCUMENT ACTION EVENT listener (removing notes)
+1 NEW ARY,ACT,DFN,IEN,VST,DAD,X,VPRSQ,CLS
+2 SET ARY=$NAME(^TMP("TIUDOCACT",$JOB))
SET ACT=$GET(@ARY@("ACTION"))
+3 ;not DELETE
IF ACT="RETRACT"
Begin DoDot:1
+4 SET DFN=+$GET(@ARY@("PATIENT"))
SET VST=$GET(@ARY@("VISIT"))
+5 SET IEN=+$GET(@ARY@("DOCUMENT"))
if IEN<1
QUIT
if DFN<1
QUIT
+6 SET DAD=+$$GET1^DIQ(8925,IEN,.06,"I")
if 'DAD
QUIT
+7 ; update parent unless already retracted
+8 SET IEN=$SELECT($$GET1^DIQ(8925,DAD,.05,"I")=15:0,1:DAD)
End DoDot:1
if IEN<1
QUIT
GOTO TRQ
+9 ;
+10 if ACT'="REASSIGN"
QUIT
+11 SET DFN=+$GET(@ARY@("PATIENT","OLD"))
SET VST=$GET(@ARY@("VISIT","OLD"))
+12 ;DA in NEW if patient unchanged
SET IEN=+$GET(@ARY@("DOCUMENT","OLD"))
+13 if IEN<1
SET IEN=+$GET(@ARY@("DOCUMENT","NEW"))
if IEN<1
QUIT
if DFN<1
QUIT
+14 SET DAD=+$$GET1^DIQ(8925,IEN,.06,"I")
IF DAD
DO TIU^VPRENC(DAD)
QUIT
+15 ; new document saved via regular index event
TRQ ; remove document from old patient/visit
+1 ;update parent if retracting addendum
SET ACT=$SELECT($GET(DAD):"",1:"@")
+2 DO POST^VPRHS(DFN,"Document",IEN_";8925",ACT,VST,.VPRSQ)
+3 ;save visit
IF ACT="@"
IF $GET(VPRSQ)
Begin DoDot:1
+4 SET ^XTMP("VPR-"_VPRSQ,IEN)=DFN_"^Document^"_IEN_";8925^D^"_VST
+5 SET X=+$$GET1^DIQ(8925,IEN,.01,"I")
SET ^XTMP("VPR-"_VPRSQ,IEN,0)=X_U_DFN_U_VST
+6 SET ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
End DoDot:1
+7 SET CLS=$$GET1^DIQ(8925,IEN,.04,"I")
+8 if CLS=27
DO POST^VPRHS(DFN,"AdvanceDirective",IEN_";8925",ACT)
+9 if CLS=30!(CLS=31)
DO POST^VPRHS(DFN,"Alert",IEN_";8925",ACT)
+10 QUIT
+11 ;
TIUS(IEN) ; -- TIU MULTIPLE SIGNATURE file #8925.7 AVPR index
+1 SET IEN=+$GET(IEN)
if IEN<1
QUIT
+2 NEW TIU0,TIUIEN,DFN,VST
+3 SET TIU0=$GET(^TIU(8925.7,IEN,0))
SET TIUIEN=+$PIECE(TIU0,U)
if TIUIEN<1
QUIT
+4 SET DFN=$$GET1^DIQ(8925,TIUIEN,.02,"I")
if DFN<1
QUIT
+5 ;Ok if null
SET VST=$$GET1^DIQ(8925,TIUIEN,.03,"I")
+6 ; non-PCE event so post immediately for BMS
+7 DO POST^VPRHS(DFN,"Document",TIUIEN_";8925",,VST)
+8 QUIT
+9 ;
IBCN ; -- IBCN NEW INSURANCE EVENTS listener
+1 ; expects IBCDFN, IBEVTACT="ADD","EDT", or "DEL"
+2 IF '$GET(IBCDFN)
QUIT
+3 NEW ACT,ID,VPRSQ,I
SET ID=IBCDFN_","_DFN
+4 SET ACT=$SELECT($GET(IBEVTACT)="DEL":"@",$GET(IBEVTACT)="ADD":"",1:$$IBDIFF)
+5 DO POST^VPRHS(DFN,"MemberEnrollment",ID_";2.312",ACT,,.VPRSQ)
+6 ;save old values for delete msg
IF ACT="@"
IF $GET(VPRSQ)
Begin DoDot:1
+7 SET ^XTMP("VPR-"_VPRSQ,ID)=DFN_"^MemberEnrollment^"_ID_";2.312^D^"
+8 FOR I=0,1,2,3,7
SET ^XTMP("VPR-"_VPRSQ,ID,I)=$GET(@("IBEVTP"_I))
+9 SET ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
End DoDot:1
+10 ;task edit to ensure delete happens first
IF ($GET(IBEVTACT)="EDT")&(ACT="@")
Begin DoDot:1
+11 NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
+12 SET ZTRTN="IBTASK^VPREVNT"
SET ZTDESC="VPR Insurance Update"
SET ZTIO=""
+13 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,2)
SET ZTSAVE("DFN")=""
SET ZTSAVE("ID")=""
+14 DO ^%ZTLOAD
End DoDot:1
+15 QUIT
IBDIFF() ; -- return 1 or 0, if key matching values changed
+1 IF +$GET(IBEVTP0)'=+$GET(IBEVTA0)
QUIT 1
+2 IF $PIECE($GET(IBEVTP0),U,18)'=$PIECE($GET(IBEVTA0),U,18)
QUIT 1
+3 IF $PIECE($GET(IBEVTP7),U,2)'=$PIECE($GET(IBEVTA7),U,2)
QUIT 1
+4 QUIT 0
IBTASK ; -- tasked update
+1 if '$GET(DFN)
QUIT
if '$GET(ID)
QUIT
+2 DO POST^VPRHS(DFN,"MemberEnrollment",ID_";2.312")
+3 QUIT
+4 ;
PCMMT ; -- SCMC PATIENT TEAM CHANGES protocol listener
+1 ; [expects SCPTTM* variables]
+2 ;I '$G(SCPCTM) Q ;not pc change
+3 NEW DFN
SET DFN=$SELECT($GET(SCPTTMAF):+SCPTTMAF,1:+$GET(SCPTTMB4))
if 'DFN
QUIT
+4 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+5 QUIT
+6 ;
PCMMTP ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener
+1 ; [expects SCPTTP* variables]
+2 ;I '$G(SCPCTP) Q ;not pc change
+3 NEW TM,DFN
+4 SET TM=$SELECT($GET(SCPTTPAF):+SCPTTPAF,1:+$GET(SCPTTPB4))
if 'TM
QUIT
+5 SET DFN=+$$GET1^DIQ(404.42,TM_",",.01,"I")
+6 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+7 QUIT
+8 ;
WV ; -- WV PREGNANCY STATUS CHANGE EVENT protocol listener
+1 NEW VPRPREG,VPRDFN,VPRFLD,VPRFLAG
+2 MERGE VPRPREG=^TMP("WVPREGST",$JOB)
+3 if '$DATA(VPRPREG)
QUIT
+4 SET VPRDFN=+$PIECE($GET(VPRPREG("AFTER","EXTERNAL ID")),",",2)
+5 if VPRDFN=0
QUIT
+6 ; if no before value, then new record, post
+7 IF '$DATA(VPRPREG("BEFORE"))
DO POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05")
QUIT
+8 if VPRDFN'=+$PIECE($GET(VPRPREG("BEFORE","EXTERNAL ID")),",",2)
QUIT
+9 ; if external ids do not match, then additional record, post
+10 IF $GET(VPRPREG("BEFORE","EXTERNAL ID"))'=$GET(VPRPREG("AFTER","EXTERNAL ID"))
DO POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05")
QUIT
+11 ; if change in fields we send to HS, post
+12 SET VPRFLAG=0
+13 FOR VPRFLD="FROM TIME","STATE","STATUS","TO TIME"
if $GET(VPRPREG("BEFORE",VPRFLD))'=$GET(VPRPREG("AFTER",VPRFLD))
SET VPRFLAG=1
if VPRFLAG=1
QUIT
+14 IF VPRFLAG=1
DO POST^VPRHS(VPRDFN,"SocialHistory",VPRDFN_";790.05")
+15 QUIT
+16 ;
+17 ; Deprecated calls:
+18 ;
DOCDEF(IEN) ; -- TIU Document Definition file #8925.1 AVPR index
+1 QUIT
+2 ;
DOCITM(DAD) ; -- TIU Document Def'n Items subfile #8925.14 AVPR1 index
+1 QUIT
+2 ;
USR(IEN) ; -- USR Authorization/Subscription file #8930.1 AVPR index
+1 QUIT
+2 ;
XU(IEN,ACT) ; -- XU USER ADD/CHANGE/TERMINATE option listener
+1 QUIT
