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**;Sep 01, 2011;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; DG FIELD MONITOR 3344
; DG PTF ICD DIAGNOSIS NOTIFIER 6850
; DG SA FILE ENTRY NOTIFIER 7232
; DGPM MOVEMENT EVENTS 1181
; FH EVSEND OR 6097
; GMPL EVENT 6065
; GMRA ASSESSMENT CHANGE 6986
; GMRA ENTERED IN ERROR 1467
; GMRA SIGN-OFF ON DATA 1469
; GMRA VERIFY DATA 1470
; GMRC EVSEND OR 3140
; IBCN NEW INSURANCE 7010
; LR7O AP EVSEND OR 7011
; LR70 CH EVSEND OR 6087
; MDC OBSERVATION UPDATE 6084
; OR EVSEND FH 6090
; OR EVSEND GMRC 3135
; OR EVSEND LRCH 6091
; OR EVSEND ORG 6092
; OR EVSEND PS 6093
; OR EVSEND RA 6094
; OR EVSEND VPR 6095
; PS EVSEND OR 2415
; PSB EVSEND VPR 6085
; PXK VISIT DATA EVENT 1298
; RA EVSEND OR 6086
; 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
; ^DPT 10035
; ^GMR(120.8 6973
; ^GMR(120.86 3449
; ^LR 525
; ^OR(100 5771
; ^PSB(53.79 5909
; ^RADPT 2480
; ^TIU(8925.1 5677
; DIC 2051
; DIQ 2056
; PSSUTLA1 3373
; TIULX 3058
;
DG ; -- DG FIELD MONITOR protocol listener
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
;
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,ADM0,VAINDT,X,VPRI
; Quit if admission is deleted (still has Visit#)
I DGPMT=1 Q:'$G(DGPMA) S ADM=DGPMDA,ADM0=DGPMA
I DGPMT'=1 S ADM=+$P(DGPMA,U,14),ADM0=$G(^DGPM(ADM,0))
; loop to find all Visits (have seen >1 per admission)
; if no visit# yet, will be updated when assigned in PCE section
Q:ADM<1 S X=+ADM0,VAINDT=(9999999-$P(X,"."))_"."_$P(X,".",2)
S VPRI=0 F S VPRI=$O(^AUPNVSIT("AAH",DFN,VAINDT,VPRI)) Q:VPRI<1 D
. D POST^VPRHS(DFN,"Encounter",ADM_"~"_VPRI_";405")
Q
;
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
;
PTF ; -- DG PTF ICD DIAGNOSIS NOTIFIER protocol listener
N DFN,IEN,ACT,ADM,VST,OLD,VPRSQ
S DFN=+$G(^TMP("DG PTF ICD NOTIFIER",$J,"DFN")) Q:DFN<1
S IEN=+$G(^TMP("DG PTF ICD NOTIFIER",$J,"DISCHARGE","IENS")) Q:IEN<1
Q:'$D(^TMP("DG PTF ICD NOTIFIER",$J,"DISCHARGE","PDX")) ;no DXLS
S ACT="" I $G(^TMP("DG PTF ICD NOTIFIER",$J,"DISCHARGE","PDX","NEW"))="" S OLD=$G(^("OLD")),ACT="@"
S ADM=$$FIND1^DIC(405,,"Q",IEN,"APTF"),VST=$$VNUM^VPRSDAV(ADM)
D:VST POST^VPRHS(DFN,"Diagnosis",IEN_";45",ACT,VST,.VPRSQ)
I ACT="@",$G(VPRSQ) D ;save ICD code
. S ^XTMP("VPR-"_VPRSQ,IEN)=DFN_"^Diagnosis^"_IEN_";45^D^"_VST
. S ^XTMP("VPR-"_VPRSQ,IEN,0)=OLD_U_U_VST
. S ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
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
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=$S($G(SDAMEVT)=2:"@",1:"")
D POST^VPRHS(DFN,"Appointment",(DATE_","_DFN_";2.98"),ACT)
Q
;
PCE ; -- PXK VISIT DATA EVENT protocol listener
G PX^VPRENC ;moved in VPR*1*19
Q
;
XQOR(MSG,FD) ; -- CPRS protocol event listener
; FD = frontdoor msg from CPRS (get ORIFN for new backdoor orders)
; else = backdoor msg/ack from Pharmacy, Lab, Radiology, etc.
N VPRMSG,VPRPKG,VPRSDA,DFN,ORC,ACT
S VPRMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@VPRMSG@(0))
S DFN=$$PID Q:DFN<1
S ORC=0 F S ORC=$O(@VPRMSG@(+ORC)) Q:ORC'>0 I $E($G(@VPRMSG@(ORC)),1,3)="ORC" D
. N ORDCNTRL,PKGIFN,ORIFN,STS,ORIG
. S ORC=ORC_U_@VPRMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
. ; QUIT if action failed, conversion, purge, or backdoor verify/new
. I ORDCNTRL["U"!("DE^ZC^ZP^ZR^ZV^SN"[ORDCNTRL) Q
. I $G(FD),ORDCNTRL'="NA" Q ;only want NA msg, from CPRS
. ; Update *Order containers
. S ORIFN=+$P($P(ORC,"|",3),U),PKGIFN=$P($P(ORC,"|",4),U)
. S VPRPKG=$P($P(ORC,"|",4),U,2) ;default namespace, if 'ORIFN
. Q:$O(^OR(100,ORIFN,2,0)) ;should not be getting parent orders
. S STS=$P($G(^OR(100,ORIFN,3)),U,3) Q:STS=10 Q:STS=11
. S ACT="" I "CA^OC^CR"[ORDCNTRL,STS=13 S ACT="@" ;cancelled
. I ORIFN D ;IFC Consults have no local order#
.. S VPRPKG=$$NMSP(ORIFN),VPRSDA=$$ORDCONT(VPRPKG)
.. D POST^VPRHS(DFN,VPRSDA,ORIFN_";100",ACT)
. ; Update Referral or Document containers
. I VPRPKG="GMRC",PKGIFN D POST^VPRHS(DFN,"Referral",+PKGIFN_";123") Q
. Q:ORDCNTRL'="RE"
. I $E(VPRPKG,1,2)="RA" D RAD Q
. I $E(VPRPKG,1,2)="LR" D LRD Q
Q
;
NMSP(IFN) ; -- Returns package namespace from pointer
N X,Y S X=$P($G(^OR(100,+$G(IFN),0)),U,14)
S Y=$$GET1^DIQ(9.4,+X_",",1)
Q Y
;
ORDCONT(NMSP) ; -- Returns SDA Order container name
S NMSP=$G(NMSP)
I $E(NMSP,1,2)="LR" Q "LabOrder"
I $E(NMSP,1,2)="PS" Q "Medication"
I $E(NMSP,1,2)="RA" Q "RadOrder"
Q "OtherOrder"
;
GMRC ; -- Referrals [from XQOR: no longer used]
N VST S VST=$$GET1^DIQ(123,+PKGIFN,"16:.03","I")
D POST^VPRHS(DFN,"Referral",+PKGIFN_";123",,VST)
; update CP in Procedures?
I ORDCNTRL="RE",$$GET1^DIQ(123,+PKGIFN,1.01,"I") D ;CP
. N VPRC,ID D FIND^DIC(702,,"@","Q",+PKGIFN,,"ACON",,,"VPRC")
. S I=0 F S I=$O(VPRC("DILIST",2,I)) Q:I<1 D
.. S ID=+$G(VPRC("DILIST",2,I))
.. D POST^VPRHS(DFN,"Procedure",ID_";702",,VST)
Q
;
RAD ; -- Radiology documents
N IDT,RPT,I,X,STS,ACT
S IDT=+$O(^RADPT("AO",+PKGIFN,DFN,0)),I=0
; find report(s) for order
F S I=$O(^RADPT("AO",+PKGIFN,DFN,IDT,I)) Q:I<1 D
. S X=+$P($G(^RADPT(DFN,"DT",IDT,"P",I,0)),U,17) ;,VST=$P($G(^(0)),U,27)
. Q:'X S STS=$$GET1^DIQ(74,X_",",5,"I"),ACT=""
. Q:STS'="V"&(STS'="EF")&(STS'="X") I STS="X" S ACT="@"
. S:'$D(RPT(X)) RPT(X)=IDT_"-"_I ;S:VST VST(X)=VST
; update Document container
S X=0 F S X=$O(RPT(X)) Q:X<1 D POST^VPRHS(DFN,"Document",X_";74",ACT) ;X_"~"_RPT(X)
Q
;
LRAP(MSG) ; -- LR7O AP EVSEND OR protocol listener
N VPRMSG,DFN,ORC
S VPRMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@VPRMSG@(0))
S DFN=$$PID Q:DFN<1
S ORC=0 F S ORC=$O(@VPRMSG@(+ORC)) Q:ORC'>0 I $E($G(@VPRMSG@(ORC)),1,3)="ORC" D
. N ORDCNTRL,PKGIFN
. S ORC=ORC_U_@VPRMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
. Q:ORDCNTRL'="RE" S PKGIFN=$P($P(ORC,"|",4),U)
. D LRD
Q
;
LRD ; -- AP/MI documents [from XQOR, LRAP: expects PKGIFN]
N SUB,IDT,LRDFN,X
S SUB=$P($G(PKGIFN),";",4),IDT=$P($G(PKGIFN),";",5)
Q:'IDT Q:SUB="" Q:SUB="CH"
S LRDFN=+$G(^DPT(DFN,"LR"))
; report in TIU or not complete
I SUB="MI" Q:'$$MI1^VPRSDAB(LRDFN,IDT)
I SUB'="MI" Q:$O(^LR(LRDFN,SUB,IDT,.05,0)) Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11)
; update report
S X=IDT_","_LRDFN_"~"_SUB_";"_$S(SUB="MI":63.05,1:63.08)
D POST^VPRHS(DFN,"Document",X)
Q
;
PID() ; -- Returns patient from PID segment in current msg
N I,SEG,Y S I=0
F S I=$O(@VPRMSG@(I)) Q:I'>0 S SEG=$E($G(@VPRMSG@(I)),1,3) Q:SEG="ORC" I SEG="PID" D Q
. S Y=+$P(@VPRMSG@(I),"|",4)
.;I '$D(^DPT(Y,0)) S:$L($P(@VPRMSG@(I),"|",5)) Y=+$P(@VPRMSG@(I),"|",5) ;alt ID for Lab
Q Y
;
PSB ; -- PSB EVSEND VPR protocol listener (BCMA)
N IEN,DFN,ORPK,ORIFN
S IEN=$S($P($G(PSBIEN),",",2)'="":+$P(PSBIEN,",",2),$G(PSBIEN)="+1":+$G(PSBIEN(1)),1:+$G(PSBIEN))
S DFN=+$G(^PSB(53.79,IEN,0)),ORPK=$P($G(^(.1)),U)
Q:DFN<1 Q:ORPK<1
S ORIFN=$S($L($T(PLACER^PSSUTLA1)):$$PLACER^PSSUTLA1(DFN,ORPK),1:0)
D:ORIFN POST^VPRHS(DFN,"Medication",ORIFN_";100")
Q
;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
; also GMRA ENTERED IN ERROR [ACT=@]
N DFN,IEN,NEW,I
S DFN=+$G(GMRAPA(0)),IEN=+$G(GMRAPA)
D POST^VPRHS(DFN,"Allergy",IEN_";120.8") ;,$G(ACT))
Q
; update assessment? [use Assessment event now]
I $G(ACT)="@" D:'$P($G(^GMR(120.86,DFN,0)),U,2) POST^VPRHS(DFN,"Allergy",DFN_";120.86")
I $G(ACT)="" D D:NEW POST^VPRHS(DFN,"Allergy",DFN_";120.86","@")
. S NEW=1,I=0 ;is the current allergy the first, only active one?
. F S I=$O(^GMR(120.8,"B",DFN,I)) Q:I<1 I I'=IEN,'$G(^GMR(120.8,I,"ER")) S NEW=0 Q
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
;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener [not in use]
N DFN,ID,ACT
S DFN=+$G(OBS("PATIENT_ID","I")) Q:DFN<1
S ID=$G(OBS("OBS_ID","I")) Q:'$L(ID)
S ACT=$S('$G(OBS("STATUS","I")):"@",1:"")
D POST^VPRHS(DFN,"Observation",ID_";704.117",ACT)
;I $G(OBS("DOMAIN","VITALS")) D POST^VPRHS(DFN,"Observation",ID,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
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 ;not DELETE
. S DFN=+$G(@ARY@("PATIENT")),VST=$G(@ARY@("VISIT"))
. S IEN=+$G(@ARY@("DOCUMENT"))
. S DAD=+$$GET1^DIQ(8925,IEN,.06,"I") S:DAD IEN=DAD
. D TIU^VPRENC(IEN,,VST)
;
Q:ACT'="REASSIGN"
S DFN=+$G(@ARY@("PATIENT","OLD")),VST=$G(@ARY@("VISIT","OLD"))
S X=$S(DFN=+$G(@ARY@("PATIENT","NEW")):"NEW",1:"OLD")
S IEN=+$G(@ARY@("DOCUMENT",X)) ;DA in NEW only if patient unchanged
S DAD=+$$GET1^DIQ(8925,IEN,.06,"I") I DAD D TIU^VPRENC(DAD) Q
; remove document from old patient/visit
; new document saved via regular index event
D POST^VPRHS(DFN,"Document",IEN_";8925","@",VST,.VPRSQ)
I $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") ;rebuild
D:CLS=30!(CLS=31) POST^VPRHS(DFN,"Alert",IEN_";8925","@")
Q
;
LR() ; -- Return ien of Lab class
N Y S Y=+$O(^TIU(8925.1,"B","LR LABORATORY REPORTS",0))
I Y>0,$S($P($G(^TIU(8925.1,Y,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S Y=0
Q Y
;
IBCN ; -- IBCN NEW INSURANCE EVENTS listener
I $G(DFN) D POST^VPRHS(DFN,"MemberEnrollment") ;rebuild container
Q
;
PCMMT ; -- SCMC PATIENT TEAM CHANGES protocol listener
;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
;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 15527 printed Jul 13, 2022@16:58:36 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**;Sep 01, 2011;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; DG FIELD MONITOR 3344
+7 ; DG PTF ICD DIAGNOSIS NOTIFIER 6850
+8 ; DG SA FILE ENTRY NOTIFIER 7232
+9 ; DGPM MOVEMENT EVENTS 1181
+10 ; FH EVSEND OR 6097
+11 ; GMPL EVENT 6065
+12 ; GMRA ASSESSMENT CHANGE 6986
+13 ; GMRA ENTERED IN ERROR 1467
+14 ; GMRA SIGN-OFF ON DATA 1469
+15 ; GMRA VERIFY DATA 1470
+16 ; GMRC EVSEND OR 3140
+17 ; IBCN NEW INSURANCE 7010
+18 ; LR7O AP EVSEND OR 7011
+19 ; LR70 CH EVSEND OR 6087
+20 ; MDC OBSERVATION UPDATE 6084
+21 ; OR EVSEND FH 6090
+22 ; OR EVSEND GMRC 3135
+23 ; OR EVSEND LRCH 6091
+24 ; OR EVSEND ORG 6092
+25 ; OR EVSEND PS 6093
+26 ; OR EVSEND RA 6094
+27 ; OR EVSEND VPR 6095
+28 ; PS EVSEND OR 2415
+29 ; PSB EVSEND VPR 6085
+30 ; PXK VISIT DATA EVENT 1298
+31 ; RA EVSEND OR 6086
+32 ; SCMC PATIENT TEAM CHANGES 7012
+33 ; SCMC PATIENT TEAM POSITION 7013
+34 ; SDAM APPOINTMENT EVENTS 1320
+35 ; TIU DOCUMENT ACTION EVENT 6774
+36 ; WV PREGNANCY STATUS CHANGE EVENT 7200
+37 ; ^AUPNPROB 5703
+38 ; ^AUPNVSIT 2028
+39 ; ^DGPM 1865
+40 ; ^DGS(41.1 3796
+41 ; ^DPT 10035
+42 ; ^GMR(120.8 6973
+43 ; ^GMR(120.86 3449
+44 ; ^LR 525
+45 ; ^OR(100 5771
+46 ; ^PSB(53.79 5909
+47 ; ^RADPT 2480
+48 ; ^TIU(8925.1 5677
+49 ; DIC 2051
+50 ; DIQ 2056
+51 ; PSSUTLA1 3373
+52 ; TIULX 3058
+53 ;
DG ; -- DG FIELD MONITOR protocol listener
+1 NEW VPRFN
SET VPRFN=$GET(DGFILE)
+2 IF "^2^2.01^2.02^2.06^38.1^"'[(U_VPRFN_U)
QUIT
+3 NEW DFN
SET DFN=+$GET(DGDA)
+4 ; collect individual fields into single tasked update if possible
+5 ;skip fld check
DO QUE^VPRHS(DFN)
QUIT
+6 IF VPRFN=2
if $$FLD(+$GET(DGFIELD))
DO QUE^VPRHS(DFN)
QUIT
+7 DO POST^VPRHS(DFN,"Patient",DFN_";2")
+8 QUIT
+9 ;
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 ;
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,ADM0,VAINDT,X,VPRI
+4 ; Quit if admission is deleted (still has Visit#)
+5 IF DGPMT=1
if '$GET(DGPMA)
QUIT
SET ADM=DGPMDA
SET ADM0=DGPMA
+6 IF DGPMT'=1
SET ADM=+$PIECE(DGPMA,U,14)
SET ADM0=$GET(^DGPM(ADM,0))
+7 ; loop to find all Visits (have seen >1 per admission)
+8 ; if no visit# yet, will be updated when assigned in PCE section
+9 if ADM<1
QUIT
SET X=+ADM0
SET VAINDT=(9999999-$PIECE(X,"."))_"."_$PIECE(X,".",2)
+10 SET VPRI=0
FOR
SET VPRI=$ORDER(^AUPNVSIT("AAH",DFN,VAINDT,VPRI))
if VPRI<1
QUIT
Begin DoDot:1
+11 DO POST^VPRHS(DFN,"Encounter",ADM_"~"_VPRI_";405")
End DoDot:1
+12 QUIT
+13 ;
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 ;
PTF ; -- DG PTF ICD DIAGNOSIS NOTIFIER protocol listener
+1 NEW DFN,IEN,ACT,ADM,VST,OLD,VPRSQ
+2 SET DFN=+$GET(^TMP("DG PTF ICD NOTIFIER",$JOB,"DFN"))
if DFN<1
QUIT
+3 SET IEN=+$GET(^TMP("DG PTF ICD NOTIFIER",$JOB,"DISCHARGE","IENS"))
if IEN<1
QUIT
+4 ;no DXLS
if '$DATA(^TMP("DG PTF ICD NOTIFIER",$JOB,"DISCHARGE","PDX"))
QUIT
+5 SET ACT=""
IF $GET(^TMP("DG PTF ICD NOTIFIER",$JOB,"DISCHARGE","PDX","NEW"))=""
SET OLD=$GET(^("OLD"))
SET ACT="@"
+6 SET ADM=$$FIND1^DIC(405,,"Q",IEN,"APTF")
SET VST=$$VNUM^VPRSDAV(ADM)
+7 if VST
DO POST^VPRHS(DFN,"Diagnosis",IEN_";45",ACT,VST,.VPRSQ)
+8 ;save ICD code
IF ACT="@"
IF $GET(VPRSQ)
Begin DoDot:1
+9 SET ^XTMP("VPR-"_VPRSQ,IEN)=DFN_"^Diagnosis^"_IEN_";45^D^"_VST
+10 SET ^XTMP("VPR-"_VPRSQ,IEN,0)=OLD_U_U_VST
+11 SET ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
End DoDot:1
+12 QUIT
+13 ;
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 IF $GET(^TMP("DG SA FILE ENTRY NOTIFIER",$JOB,"ACTION"))="DELETED"
SET ACT="@"
+6 IF $GET(^TMP("DG SA FILE ENTRY NOTIFIER",$JOB,"ACTION"))="MODIFIED"
IF $PIECE($GET(^DGS(41.1,IEN,0)),U,13)
SET ACT="@"
+7 DO POST^VPRHS(DFN,"Appointment",IEN_";41.1",ACT)
+8 QUIT
+9 ;
SDAM ; -- SDAM APPOINTMENT EVENTS protocol listener
+1 NEW DFN,DATE,ACT
if '$GET(SDATA)
QUIT
+2 ;only track make, cancel, no show, check in/out
if $GET(SDAMEVT)>5
QUIT
+3 ; quit if status has not changed
+4 if $GET(SDATA("BEFORE","STATUS"))=$GET(SDATA("AFTER","STATUS"))
QUIT
+5 SET DFN=+$PIECE(SDATA,U,2)
if DFN<1
QUIT
+6 SET DATE=+$PIECE(SDATA,U,3)
SET ACT=$SELECT($GET(SDAMEVT)=2:"@",1:"")
+7 DO POST^VPRHS(DFN,"Appointment",(DATE_","_DFN_";2.98"),ACT)
+8 QUIT
+9 ;
PCE ; -- PXK VISIT DATA EVENT protocol listener
+1 ;moved in VPR*1*19
GOTO PX^VPRENC
+2 QUIT
+3 ;
XQOR(MSG,FD) ; -- CPRS protocol event listener
+1 ; FD = frontdoor msg from CPRS (get ORIFN for new backdoor orders)
+2 ; else = backdoor msg/ack from Pharmacy, Lab, Radiology, etc.
+3 NEW VPRMSG,VPRPKG,VPRSDA,DFN,ORC,ACT
+4 SET VPRMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@VPRMSG@(0))
QUIT
+5 SET DFN=$$PID
if DFN<1
QUIT
+6 SET ORC=0
FOR
SET ORC=$ORDER(@VPRMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT($GET(@VPRMSG@(ORC)),1,3)="ORC"
Begin DoDot:1
+7 NEW ORDCNTRL,PKGIFN,ORIFN,STS,ORIG
+8 SET ORC=ORC_U_@VPRMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+9 ; QUIT if action failed, conversion, purge, or backdoor verify/new
+10 IF ORDCNTRL["U"!("DE^ZC^ZP^ZR^ZV^SN"[ORDCNTRL)
QUIT
+11 ;only want NA msg, from CPRS
IF $GET(FD)
IF ORDCNTRL'="NA"
QUIT
+12 ; Update *Order containers
+13 SET ORIFN=+$PIECE($PIECE(ORC,"|",3),U)
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+14 ;default namespace, if 'ORIFN
SET VPRPKG=$PIECE($PIECE(ORC,"|",4),U,2)
+15 ;should not be getting parent orders
if $ORDER(^OR(100,ORIFN,2,0))
QUIT
+16 SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
if STS=10
QUIT
if STS=11
QUIT
+17 ;cancelled
SET ACT=""
IF "CA^OC^CR"[ORDCNTRL
IF STS=13
SET ACT="@"
+18 ;IFC Consults have no local order#
IF ORIFN
Begin DoDot:2
+19 SET VPRPKG=$$NMSP(ORIFN)
SET VPRSDA=$$ORDCONT(VPRPKG)
+20 DO POST^VPRHS(DFN,VPRSDA,ORIFN_";100",ACT)
End DoDot:2
+21 ; Update Referral or Document containers
+22 IF VPRPKG="GMRC"
IF PKGIFN
DO POST^VPRHS(DFN,"Referral",+PKGIFN_";123")
QUIT
+23 if ORDCNTRL'="RE"
QUIT
+24 IF $EXTRACT(VPRPKG,1,2)="RA"
DO RAD
QUIT
+25 IF $EXTRACT(VPRPKG,1,2)="LR"
DO LRD
QUIT
End DoDot:1
+26 QUIT
+27 ;
NMSP(IFN) ; -- Returns package namespace from pointer
+1 NEW X,Y
SET X=$PIECE($GET(^OR(100,+$GET(IFN),0)),U,14)
+2 SET Y=$$GET1^DIQ(9.4,+X_",",1)
+3 QUIT Y
+4 ;
ORDCONT(NMSP) ; -- Returns SDA Order container name
+1 SET NMSP=$GET(NMSP)
+2 IF $EXTRACT(NMSP,1,2)="LR"
QUIT "LabOrder"
+3 IF $EXTRACT(NMSP,1,2)="PS"
QUIT "Medication"
+4 IF $EXTRACT(NMSP,1,2)="RA"
QUIT "RadOrder"
+5 QUIT "OtherOrder"
+6 ;
GMRC ; -- Referrals [from XQOR: no longer used]
+1 NEW VST
SET VST=$$GET1^DIQ(123,+PKGIFN,"16:.03","I")
+2 DO POST^VPRHS(DFN,"Referral",+PKGIFN_";123",,VST)
+3 ; update CP in Procedures?
+4 ;CP
IF ORDCNTRL="RE"
IF $$GET1^DIQ(123,+PKGIFN,1.01,"I")
Begin DoDot:1
+5 NEW VPRC,ID
DO FIND^DIC(702,,"@","Q",+PKGIFN,,"ACON",,,"VPRC")
+6 SET I=0
FOR
SET I=$ORDER(VPRC("DILIST",2,I))
if I<1
QUIT
Begin DoDot:2
+7 SET ID=+$GET(VPRC("DILIST",2,I))
+8 DO POST^VPRHS(DFN,"Procedure",ID_";702",,VST)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
RAD ; -- Radiology documents
+1 NEW IDT,RPT,I,X,STS,ACT
+2 SET IDT=+$ORDER(^RADPT("AO",+PKGIFN,DFN,0))
SET I=0
+3 ; find report(s) for order
+4 FOR
SET I=$ORDER(^RADPT("AO",+PKGIFN,DFN,IDT,I))
if I<1
QUIT
Begin DoDot:1
+5 ;,VST=$P($G(^(0)),U,27)
SET X=+$PIECE($GET(^RADPT(DFN,"DT",IDT,"P",I,0)),U,17)
+6 if 'X
QUIT
SET STS=$$GET1^DIQ(74,X_",",5,"I")
SET ACT=""
+7 if STS'="V"&(STS'="EF")&(STS'="X")
QUIT
IF STS="X"
SET ACT="@"
+8 ;S:VST VST(X)=VST
if '$DATA(RPT(X))
SET RPT(X)=IDT_"-"_I
End DoDot:1
+9 ; update Document container
+10 ;X_"~"_RPT(X)
SET X=0
FOR
SET X=$ORDER(RPT(X))
if X<1
QUIT
DO POST^VPRHS(DFN,"Document",X_";74",ACT)
+11 QUIT
+12 ;
LRAP(MSG) ; -- LR7O AP EVSEND OR protocol listener
+1 NEW VPRMSG,DFN,ORC
+2 SET VPRMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@VPRMSG@(0))
QUIT
+3 SET DFN=$$PID
if DFN<1
QUIT
+4 SET ORC=0
FOR
SET ORC=$ORDER(@VPRMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT($GET(@VPRMSG@(ORC)),1,3)="ORC"
Begin DoDot:1
+5 NEW ORDCNTRL,PKGIFN
+6 SET ORC=ORC_U_@VPRMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+7 if ORDCNTRL'="RE"
QUIT
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+8 DO LRD
End DoDot:1
+9 QUIT
+10 ;
LRD ; -- AP/MI documents [from XQOR, LRAP: expects PKGIFN]
+1 NEW SUB,IDT,LRDFN,X
+2 SET SUB=$PIECE($GET(PKGIFN),";",4)
SET IDT=$PIECE($GET(PKGIFN),";",5)
+3 if 'IDT
QUIT
if SUB=""
QUIT
if SUB="CH"
QUIT
+4 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+5 ; report in TIU or not complete
+6 IF SUB="MI"
if '$$MI1^VPRSDAB(LRDFN,IDT)
QUIT
+7 IF SUB'="MI"
if $ORDER(^LR(LRDFN,SUB,IDT,.05,0))
QUIT
if '$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,11)
QUIT
+8 ; update report
+9 SET X=IDT_","_LRDFN_"~"_SUB_";"_$SELECT(SUB="MI":63.05,1:63.08)
+10 DO POST^VPRHS(DFN,"Document",X)
+11 QUIT
+12 ;
PID() ; -- Returns patient from PID segment in current msg
+1 NEW I,SEG,Y
SET I=0
+2 FOR
SET I=$ORDER(@VPRMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT($GET(@VPRMSG@(I)),1,3)
if SEG="ORC"
QUIT
IF SEG="PID"
Begin DoDot:1
+3 SET Y=+$PIECE(@VPRMSG@(I),"|",4)
+4 ;I '$D(^DPT(Y,0)) S:$L($P(@VPRMSG@(I),"|",5)) Y=+$P(@VPRMSG@(I),"|",5) ;alt ID for Lab
End DoDot:1
QUIT
+5 QUIT Y
+6 ;
PSB ; -- PSB EVSEND VPR protocol listener (BCMA)
+1 NEW IEN,DFN,ORPK,ORIFN
+2 SET IEN=$SELECT($PIECE($GET(PSBIEN),",",2)'="":+$PIECE(PSBIEN,",",2),$GET(PSBIEN)="+1":+$GET(PSBIEN(1)),1:+$GET(PSBIEN))
+3 SET DFN=+$GET(^PSB(53.79,IEN,0))
SET ORPK=$PIECE($GET(^(.1)),U)
+4 if DFN<1
QUIT
if ORPK<1
QUIT
+5 SET ORIFN=$SELECT($LENGTH($TEXT(PLACER^PSSUTLA1)):$$PLACER^PSSUTLA1(DFN,ORPK),1:0)
+6 if ORIFN
DO POST^VPRHS(DFN,"Medication",ORIFN_";100")
+7 QUIT
+8 ;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
+1 ; also GMRA ENTERED IN ERROR [ACT=@]
+2 NEW DFN,IEN,NEW,I
+3 SET DFN=+$GET(GMRAPA(0))
SET IEN=+$GET(GMRAPA)
+4 ;,$G(ACT))
DO POST^VPRHS(DFN,"Allergy",IEN_";120.8")
+5 QUIT
+6 ; update assessment? [use Assessment event now]
+7 IF $GET(ACT)="@"
if '$PIECE($GET(^GMR(120.86,DFN,0)),U,2)
DO POST^VPRHS(DFN,"Allergy",DFN_";120.86")
+8 IF $GET(ACT)=""
Begin DoDot:1
+9 ;is the current allergy the first, only active one?
SET NEW=1
SET I=0
+10 FOR
SET I=$ORDER(^GMR(120.8,"B",DFN,I))
if I<1
QUIT
IF I'=IEN
IF '$GET(^GMR(120.8,I,"ER"))
SET NEW=0
QUIT
End DoDot:1
if NEW
DO POST^VPRHS(DFN,"Allergy",DFN_";120.86","@")
+11 QUIT
+12 ;
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 ;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener [not in use]
+1 NEW DFN,ID,ACT
+2 SET DFN=+$GET(OBS("PATIENT_ID","I"))
if DFN<1
QUIT
+3 SET ID=$GET(OBS("OBS_ID","I"))
if '$LENGTH(ID)
QUIT
+4 SET ACT=$SELECT('$GET(OBS("STATUS","I")):"@",1:"")
+5 DO POST^VPRHS(DFN,"Observation",ID_";704.117",ACT)
+6 ;I $G(OBS("DOMAIN","VITALS")) D POST^VPRHS(DFN,"Observation",ID,ACT)
+7 QUIT
+8 ;
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 NEW STS,DAD,ACT
+2 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
if DFN<1
QUIT
if IEN<1
QUIT
+3 ;X = FM data array for index
SET STS=$GET(X(2))
SET DAD=$GET(X(3))
+4 ;not complete
IF STS<7
QUIT
+5 ;archived, leave in cache unchanged
IF STS=9
QUIT
+6 ;removed, handled via protocol
IF STS>13
QUIT
+7 ;if addendum, repull entire note
if DAD
SET IEN=DAD
+8 ;add/remove amendment
SET ACT=$SELECT(X2(2)&(X1(2)=""):1,X1&(X2=""):"@",1:"")
+9 ;add to ^XTMP("VPRPX") encounter list
DO TIU^VPRENC(IEN,ACT)
+10 QUIT
+11 ;
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"))
+6 SET DAD=+$$GET1^DIQ(8925,IEN,.06,"I")
if DAD
SET IEN=DAD
+7 DO TIU^VPRENC(IEN,,VST)
End DoDot:1
QUIT
+8 ;
+9 if ACT'="REASSIGN"
QUIT
+10 SET DFN=+$GET(@ARY@("PATIENT","OLD"))
SET VST=$GET(@ARY@("VISIT","OLD"))
+11 SET X=$SELECT(DFN=+$GET(@ARY@("PATIENT","NEW")):"NEW",1:"OLD")
+12 ;DA in NEW only if patient unchanged
SET IEN=+$GET(@ARY@("DOCUMENT",X))
+13 SET DAD=+$$GET1^DIQ(8925,IEN,.06,"I")
IF DAD
DO TIU^VPRENC(DAD)
QUIT
+14 ; remove document from old patient/visit
+15 ; new document saved via regular index event
+16 DO POST^VPRHS(DFN,"Document",IEN_";8925","@",VST,.VPRSQ)
+17 ;save visit
IF $GET(VPRSQ)
Begin DoDot:1
+18 SET ^XTMP("VPR-"_VPRSQ,IEN)=DFN_"^Document^"_IEN_";8925^D^"_VST
+19 SET X=+$$GET1^DIQ(8925,IEN,.01,"I")
SET ^XTMP("VPR-"_VPRSQ,IEN,0)=X_U_DFN_U_VST
+20 SET ^XTMP("VPR-"_VPRSQ,0)=$$FMADD^XLFDT(DT,14)_U_DT_"^Deleted record for AVPR"
End DoDot:1
+21 SET CLS=$$GET1^DIQ(8925,IEN,.04,"I")
+22 ;rebuild
if CLS=27
DO POST^VPRHS(DFN,"AdvanceDirective")
+23 if CLS=30!(CLS=31)
DO POST^VPRHS(DFN,"Alert",IEN_";8925","@")
+24 QUIT
+25 ;
LR() ; -- Return ien of Lab class
+1 NEW Y
SET Y=+$ORDER(^TIU(8925.1,"B","LR LABORATORY REPORTS",0))
+2 IF Y>0
IF $SELECT($PIECE($GET(^TIU(8925.1,Y,0)),U,4)="CL":0,$PIECE($GET(^(0)),U,4)="DC":0,1:1)
SET Y=0
+3 QUIT Y
+4 ;
IBCN ; -- IBCN NEW INSURANCE EVENTS listener
+1 ;rebuild container
IF $GET(DFN)
DO POST^VPRHS(DFN,"MemberEnrollment")
+2 QUIT
+3 ;
PCMMT ; -- SCMC PATIENT TEAM CHANGES protocol listener
+1 ;I '$G(SCPCTM) Q ;not pc change
+2 NEW DFN
SET DFN=$SELECT($GET(SCPTTMAF):+SCPTTMAF,1:+$GET(SCPTTMB4))
if 'DFN
QUIT
+3 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+4 QUIT
+5 ;
PCMMTP ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener
+1 ;I '$G(SCPCTP) Q ;not pc change
+2 NEW TM,DFN
+3 SET TM=$SELECT($GET(SCPTTPAF):+SCPTTPAF,1:+$GET(SCPTTPB4))
if 'TM
QUIT
+4 SET DFN=+$$GET1^DIQ(404.42,TM_",",.01,"I")
+5 ;POST^VPRHS(DFN,"Patient",DFN_";2")
DO QUE^VPRHS(DFN)
+6 QUIT
+7 ;
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
