Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPREVNT

VPREVNT.m

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