HMPEVNT ;SLC/MKB,ASMR/JD,RRB,CPC,MBS -- VistA event listeners;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; DG FIELD MONITOR 3344
; DGPM MOVEMENT EVENTS 1181
; GMRA ENTERED IN ERROR 1467
; GMRA SIGN-OFF ON DATA 1469
; GMRC EVSEND OR 3140
; LR70 CH EVSEND OR 6087
; MDC OBSERVATION UPDATE 6084
; PS EVSEND OR 2415
; PSB EVSEND HMP 6085
; PXK VISIT DATA EVENT 1298
; RA EVSEND OR 6086
; SDAM APPOINTMENT EVENTS 1320
; ^AUPNVSIT 2028
; ^DPT 10035
; ^OR(100 5771
; DIQ 2056
; GMVUTL 5046
; TIUSRVLO 2834
; VADPT 10061
; VASITE 10112
; XLFDT 10103
; XTHC10 5515
; ORDRNUM^PSSUTLA2 6426 ;DE6363 - JD - 8/23/16
;
; DE2818 - SQA findings.
; 1) Correct unkilled variables by modifying line tags to accept variables as
; parameters and modifying associated protocol routine calls to pass variables
; as parameters. RRB - 10/28/2015
;
;Oct 15, 2015 - PB - modified to trigger an unsolicited sync action when an order is discontinued and the patient is subscribed to eHMP
;
;DE3327 - 5/4/16 - JD - Removed the server hardcoding (hmp-development-box).
; *** NOTE ***
; It is understood that as of the date of modifying this code (5/4/16), there
; is one AND ONLY one server entry in the HMP Subscription file (#800000)
; per site. This will be fixed in future releases to accommodate multiple
; servers per site.
;
Q
;
DG(DGDA,DGFIELD,DGFILE) ; -- DG FIELD MONITOR protocol listener /DE2818
Q:$G(DGFILE)'=2 ;Patient file only
N DFN S DFN=+$G(DGDA)
; operational pt-select - *s68 BEGIN
I "^.01^.02^.03^.09^.101^.351^.361^"[(U_+$G(DGFIELD)_U) D
. ; -- if patient entry has been deleted, delete pt-select object
. I $G(DGFIELD)=".01",'$D(^DPT(DFN)) D POSTX("pt-select",DFN,"@") Q ; *s68 - END
. D POSTX("pt-select",DFN_"&"_$G(DGFIELD))
; subscribed patient
I $D(^HMP(800000,"AITEM",DFN)),$$FLD(+$G(DGFIELD)) D POST(DFN,"patient",DFN)
Q
;
FLD(X) ; --Return 1 or 0, if X is a field tracked by HMP
S X=U_+$G(X)_U
I "^.01^.02^.03^.05^.08^.09^.351^.361^.364^"[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^"[X Q 1 ;NOK
I "^.301^.302^1901^.32102^.32103^.32201^.5295^"[X Q 1 ;serv conn
;New fields. JD - 9/24/15
I "^.133^"[X Q 1 ;email address
I "^.1211^.1212^.1213^.1214^.1215^.1216^"[X Q 1 ;temporary address
I "^.331^.332^.333^.334^.335^.336^.337^.338^.339^.33011^"[X Q 1 ;emergency contact addr/phone
I "^.215^.21011^"[X Q 1 ;NOK addr line 3 and work phone
I "^.3731^"[X Q 1 ;service connected conditions
I "^.18^3^8^16^"[X Q 1 ;insurance
Q 0
;
DGPM(DGPMA,DGPMDA,DGPMP,DGPMT) ; -- DGPM MOVEMENT EVENTS protocol listener /DE2818
; [expects DFN,DGPM* variables]
N ADM,ACT S ADM=DGPMDA
I DGPMT'=1 S ADM=$S(DGPMA:$P(DGPMA,U,14),1:$P(DGPMP,U,14)) Q:ADM<1
S ACT=$S(DGPMA:"",1:"@")
I $D(^HMP(800000,"AITEM",DFN)) D POST(DFN,"visit","H"_ADM,ACT)
; update roster(s) if current movement
N ADMX,MVTX,PREV,NEW,OLD,WARD
S ADMX=$Q(^DGPM("ATID1",DFN)) Q:$QS(ADMX,4)'=ADM
S MVTX=$Q(^DGPM("APMV",DFN,ADM)) Q:$QS(MVTX,5)'=DGPMDA
S PREV=$G(DGPMP) I 'PREV,DGPMT'=1 D ;previous or edited mvt
. S MVTX=$Q(@MVTX) Q:DFN'=$QS(MVTX,2) Q:ADM'=$QS(MVTX,3)
. S PREV=$G(^DGPM(+$QS(MVTX,5),0))
S NEW=$P(DGPMA,U,6),OLD=$P(PREV,U,6)
I NEW'=OLD F WARD=NEW,OLD I WARD D
. S I=0 F S I=$O(^HMPROSTR("AD",WARD_";DIC(42,",I)) Q:I<1 D POSTX("roster",I)
Q
;-find visit# for corresponding admission [not used]
N ADM,PTF,IDT,ID,ACT
I DGPMA S ADM=+DGPMA,PTF=+$P(DGPMA,U,16)
E S ADM=+DGPMP,PTF=+$P(DGPMP,U,16)
I DGPMT'=1 D Q:ADM<1
. N VAIP S VAIP("E")=DGPMDA
. D IN5^VADPT S ADM=+VAIP(13,1),PTF=+VAIP(12)
S IDT=9999999-$P(ADM,".") S:ADM["." IDT=IDT_"."_$P(ADM,".",2)
S ID=+$O(^AUPNVSIT("AAH",DFN,IDT,0)) Q:'ID
S ACT=$S(DGPMA:"",1:"@")
D POST(DFN,"visit",ID,ACT)
; POST(DFN,"ptf",PTF,ACT):DGPMT=3
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
;
PCMMT(SCPTTMAF,SCPTTMB4) ; -- SCMC PATIENT TEAM CHANGES protocol listener /DE2818
;I '$P($G(SCPTTMB4),U,8),'$P($G(SCPTTMAF),U,8) Q ;not pc change ;DE5410 removed to track changes to other teams
N DFN S DFN=$S($G(SCPTTMAF):+SCPTTMAF,1:+$G(SCPTTMB4)) Q:'DFN
D POST(DFN,"patient",DFN)
Q
;
PCMMTP(SCPTTPAF,SCPTTPB4) ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener /DE2818
;I '$P($G(SCPTTPB4),U,5),'$P($G(SCPTTPAF),U,5) Q ;not pc change ;DE5410 removed to track changes to other teams
N TM,DFN
S TM=$S($G(SCPTTPAF):+SCPTTPAF,1:+$G(SCPTTPB4)) Q:'TM
;DE2818
S DFN=$$GET1^DIQ(404.42,+TM_",",.01,"I") ;ICR 1922
D POST(DFN,"patient",DFN)
Q
;
SDAM(SDATA) ; -- SDAM APPOINTMENT EVENTS protocol listener /DE2818
I $G(SDATA)'="" D Q ;appointments ;DE5411 still process if Piece 1 not set, catches auto-rebook status
. N DFN,DATE,HLOC,STS,REASON,PROV
. S DFN=+$P(SDATA,U,2) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
. Q:'$D(^HMP(800000,"AITEM",DFN))
. S DATE=+$P(SDATA,U,3),HLOC=+$P(SDATA,U,4),(PROV,REASON)=""
. D POST(DFN,"appointment","A;"_DATE_";"_HLOC_";"_REASON_";"_$TR($P(PROV,U,1,2),"^",";"))
Q
;
PCE ; -- PXK VISIT DATA EVENT protocol listener, used by HMP PCE EVENTS protocol
N ACT,DA,DFN,HMPPXK,IEN,PX0A,PX0B,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ;DE4195 and DE6485
S IEN=+$O(^TMP("PXKCO",$J,0)) Q:IEN<1
S PX0A=$G(^TMP("PXKCO",$J,IEN,"VST",IEN,0,"AFTER")),PX0B=$G(^("BEFORE"))
S DFN=$S($L(PX0A):+$P(PX0A,U,5),1:+$P(PX0B,U,5))
Q:'(DFN>0) Q:'$D(^HMP(800000,"AITEM",DFN)) ;DE4496 19 August 2016
; Visit file
S ACT=$S(PX0A="":"@",1:"")
;DE4195 - put subsequent processing into taskman
M HMPPXK=^TMP("PXKCO",$J)
; DE6485, add null device in ZTIO
S ZTRTN="PCE2^HMPEVNT",ZTDTH=$H,ZTIO="",ZTSAVE("HMPPXK(")="",ZTSAVE("DFN")="",ZTSAVE("IEN")="",ZTSAVE("ACT")=""
S ZTDESC="HMP PXK VISIT EVENT HANDLER"
D ^%ZTLOAD
Q
PCE2 ; DE4195 - run in taskman
N DA,SUB
D POST(DFN,"visit",IEN,ACT)
; check V-files
;DE4879 - Removed Health Factors from loop (was SUB="HF","IMM",...)
F SUB="IMM","XAM","CPT","PED","POV","SK" D
. S DA=0 F S DA=$O(HMPPXK(IEN,SUB,DA)) Q:DA<1 D
.. S ACT=$S($G(HMPPXK(IEN,SUB,DA,0,"AFTER"))="":"@",1:"")
.. D POST(DFN,$$NAME(SUB),DA,ACT)
Q
;
NAME(X) ; -- return object name for V-files
N Y S Y=""
I X="HF" S Y="factor"
I X="IMM" S Y="immunization"
I X="XAM" S Y="exam"
I X="CPT" S Y="cpt"
I X="PED" S Y="education"
I X="POV" S Y="pov"
I X="SK" S Y="skin"
Q Y
;
ZPCE ; -- old PXK VISIT DATA EVENT protocol listener [not in use]
N IEN,PX0,PX150,DFN,DA
S IEN=+$O(^TMP("PXKCO",$J,0)) Q:IEN<1
S PX0=$G(^TMP("PXKCO",$J,IEN,"VST",IEN,0,"AFTER")) Q:$P(PX0,U,7)="E"
I PX0="" D POST(DFN,"visit",IEN,"@") Q ;deleted
S PX150=$G(^TMP("PXKCO",$J,IEN,"VST",IEN,150,"AFTER")) Q:$P(PX150,U,3)'="P"
S DFN=+$P(PX0,U,5) Q:'(DFN>0) Q:'$D(^HMP(800000,"AITEM",DFN)) ;DE4496 19 August 2016
D POST(DFN,"visit",IEN)
S DA=0 F S DA=$O(^TMP("PXKCO",$J,IEN,"IMM",DA)) Q:DA<1 D POST(DFN,"immunization",DA)
S DA=0 F S DA=$O(^TMP("PXKCO",$J,IEN,"HF",DA)) Q:DA<1 D POST(DFN,"factor",DA)
Q
;
XQOR(MSG) ; -- messaging listener (update meds, labs, xrays, consults)
N HMPMSG,HMPPKG,MSH,ORC,DFN
S HMPMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@HMPMSG@(0))
S MSH=0 F S MSH=$O(@HMPMSG@(MSH)) Q:MSH'>0 Q:$E(@HMPMSG@(MSH),1,3)="MSH"
Q:'MSH Q:'$L($G(@HMPMSG@(MSH)))
S HMPPKG=$$TYPE($P(@HMPMSG@(MSH),"|",3)) Q:'$L(HMPPKG)
S DFN=$$PID Q:'(DFN>0) Q:'$D(^HMP(800000,"AITEM",DFN)) ;DE4496 19 August 2016
S ORC=MSH F S ORC=$O(@HMPMSG@(+ORC)) Q:ORC'>0 I $E(@HMPMSG@(ORC),1,3)="ORC" D
. N ORDCNTRL,PKGIFN,ORIFN,PORIFN
. S ORC=ORC_U_@HMPMSG@(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 ORDCNTRL["U"!("DE^ZP^ZR^ZV^SN"[ORDCNTRL) Q ;Oct 15, 2015 - PB - modified to trigger an unsolicited sync action when a signed order is discontinued
. S ORIFN=+$P($P(ORC,"|",3),U),PKGIFN=$P($P(ORC,"|",4),U)
. ; If this is a child order get the parent and send it too
. ; PORIFN = PARENT ORDER IFN
. S PORIFN=+$P($G(^OR(100,ORIFN,3)),U,9)
. I $$RESULT D ;update ancillary domains
.. D POST(DFN,HMPPKG,PKGIFN)
.. D:HMPPKG="image" POST(DFN,"document",PKGIFN)
.. I HMPPKG="lab",PKGIFN'["CH",'$$LRTIU(DFN,PKGIFN) D POST(DFN,"document",$P(PKGIFN,";",4,5))
. I ORIFN,ORDCNTRL'="ZD" D ;update order(s)
.. D POST(DFN,"order",ORIFN)
.. I PORIFN D POST(DFN,"order",PORIFN)
.. N ORIG S ORIG=+$P($G(^OR(100,ORIFN,3)),U,5)
.. I ORIG D POST(DFN,"order",ORIG) ;need fwd ptrs, sig flds
Q
;
RESULT() ; -- Return 1 or 0, if message broadcasts a result
; [may modify PKGIFN for use in POST]
N Y S Y=0
I HMPPKG="consult" S Y=1,PKGIFN=+PKGIFN G RQ
I HMPPKG="med" S Y=1,PKGIFN=ORIFN G RQ
I HMPPKG="lab" S:ORDCNTRL="RE"&($L(PKGIFN,";")>3) Y=1 G RQ
I HMPPKG="image" S:PKGIFN["~" Y=1,PKGIFN=$TR($P(PKGIFN,"~",2,3),"~","-") G RQ
RQ Q Y
;
LRTIU(DFN,ORPK) ; -- Return 1 or 0, if LR report is in TIU
I $G(DFN)<1!'$L($G(ORPK)) Q 0
I ORPK["CH"!(ORPK["MI") Q 0
N SUB,IDT,LRDFN
S SUB=$P(ORPK,";",4),IDT=+$P(ORPK,";",5),LRDFN=+$G(^DPT(+DFN,"LR"))
I $O(^LR(LRDFN,SUB,IDT,.05,0)) Q 1
Q 0
;
NA(MSG) ; -- messaging listener (new backdoor orders)
N HMPMSG,HMPPKG,MSH,ORC,DFN
S HMPMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@HMPMSG@(0))
S MSH=0 F S MSH=$O(@HMPMSG@(MSH)) Q:MSH'>0 Q:$E(@HMPMSG@(MSH),1,3)="MSH"
Q:'MSH Q:'$L($G(@HMPMSG@(MSH)))
S HMPPKG=$$TYPE($P(@HMPMSG@(MSH),"|",5)) Q:'$L(HMPPKG)
S DFN=$$PID Q:'(DFN>0) Q:'$D(^HMP(800000,"AITEM",DFN)) ;DE4496 19 August 2016
S ORC=MSH F S ORC=$O(@HMPMSG@(+ORC)) Q:ORC'>0 I $E(@HMPMSG@(ORC),1,3)="ORC" D
. N ORDCNTRL,ORIFN
. S ORC=ORC_U_@HMPMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
. Q:ORDCNTRL'="NA"
. S ORIFN=+$P($P(ORC,"|",3),U) D POST(DFN,"order",ORIFN)
. I HMPPKG="med" D POST(DFN,HMPPKG,ORIFN)
Q
;
TYPE(NAME) ; -- Returns type name for XML
I NAME="LABORATORY" Q "lab"
I NAME="PHARMACY" Q "med"
I NAME="CONSULTS" Q "consult"
I NAME="PROCEDURES" Q "consult"
I NAME="RADIOLOGY" Q "image"
I NAME="IMAGING" Q "image"
I NAME="ORDER ENTRY" Q "order"
I NAME="DIETETICS" Q "diet"
Q ""
;
PID() ; -- Returns patient from PID segment in current msg
N I,SEG,Y S I=MSH
F S I=$O(@HMPMSG@(I)) Q:I'>0 S SEG=$E(@HMPMSG@(I),1,3) Q:SEG="ORC" I SEG="PID" D Q
. S Y=+$P(@HMPMSG@(I),"|",4)
.;I '$D(^DPT(Y,0)) S:$L($P(@HMPMSG@(I),"|",5)) Y=+$P(@HMPMSG@(I),"|",5) ;alt ID for Lab
Q Y
;
PV1() ; -- Returns patient class from PV1 segment in current msg
N I,SEG,Y S I=MSH,Y=""
F S I=$O(@HMPMSG@(I)) Q:I'>0 S SEG=$E(@HMPMSG@(I),1,3) Q:SEG="ORC" I SEG="PV1" D Q
. S Y=$P(@HMPMSG@(I),"|",3)
I Y="",$G(ORIFN) S Y=$$GET1^DIQ(100,+ORIFN_",",10,"I")
Q Y
;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
; also GMRA ENTERED IN ERROR [ACT=@]
N DFN,IEN
S DFN=+$G(GMRAPA(0)),IEN=+$G(GMRAPA)
D POST(DFN,"allergy",IEN,$G(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(DFN,"problem",IEN) ;,ACT)
Q
;
GMRV(DFN,IEN,ERR) ; -- Vital Measurement file #120.5 AHMP index
S DFN=+$G(DFN),IEN=+$G(IEN)
N ACT S ACT=$S($G(ERR):"@",1:"")
D POST(DFN,"vital",IEN,ACT)
Q
;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener
N DFN,ID,ACT
S DFN=+$G(OBS("PATIENT_ID","I")) Q:'(DFN>0) ;DE4496 19 August 2016
S ID=$G(OBS("OBS_ID","I")) Q:'$L(ID)
S ACT=$S('$G(OBS("STATUS","I")):"@",1:"")
D POST(DFN,"obs",ID,ACT)
I $G(OBS("DOMAIN","VITALS")) D POST(DFN,"vital",ID,ACT)
Q
;
CP(DFN,ID,ACT) ; -- CP Transaction file #702 AHMP index
S DFN=+$G(DFN),ID=$G(ID)
D POST(DFN,"document",ID,$G(ACT)) ;de3944 also need to generate document for procedure to link results to
D POST(DFN,"procedure",ID,$G(ACT))
Q
;
SR(DFN,IEN,ACT) ; -- Surgery [SROERR] update
S DFN=+$G(DFN),IEN=+$G(IEN)
D POST(DFN,"surgery",IEN,$G(ACT))
Q
;*s68 - BEGINS
TIU(DFN,IEN) ; -- TIU Document file #8925 AHMP index
N ACT,STS,DAD,REPCAT
S DFN=+$G(DFN),IEN=+$G(IEN),ACT=""
S STS=$G(X(2)),DAD=$G(X(3)) ;X = FM data array for index
S:DAD IEN=DAD I 'DAD D ;if addendum, repull entire note
. ;I STS=15 S ACT="@" ;retracted; DE3693 - do not delete note from JDS if retracted, March 18, 2016
. I $G(X2(1))="" S ACT="@" ;deleted (new title = null)
D POST(DFN,"document",IEN,ACT)
;DE3944 update surgery based on reports
S REPCAT=$$CATG^HMPDTIU($$GET1^DIQ(8925,IEN_",",".01","I"))
I REPCAT="SR" D
. N REPCASE S REPCASE=$$GET1^DIQ(8925,IEN_",","1701","I")
. S REPCASE=$P(REPCASE,"Case #: ",2)
. I REPCASE D POST(DFN,"surgery",REPCASE)
;DE3241 - If TIU update changes CWADF values, trigger patient update so change get in fresh. stream
;If this note has a parent document type of "CLINICAL WARNING", "CRISIS NOTE", or "ADVANCE DIRECTIVE"...
;parent document type is "Document Class"...
;AND this note's status is COMPLETED or AMENDED
;THEN this document may update the C, W, or D CWADF values and patient fresh. stream update needs to be triggered
N DADTYPE,DADNAME,STATUS
S DADTYPE=$$GET1^DIQ(8925,IEN_",",".04","I") Q:'DADTYPE Q:$$GET1^DIQ(8925.1,DADTYPE_",",".04","I")'="DC"
S DADNAME=$$GET1^DIQ(8925.1,DADTYPE_",",".01")
I $S(DADNAME="CLINICAL WARNING":0,DADNAME="CRISIS NOTE":0,DADNAME="ADVANCE DIRECTIVE":0,1:1) Q
D POST(DFN,"patient",DFN)
Q
; Deprecated calls
DOCDEF ;
DOCITEM ;
USR ;
Q
; *s68 - END
PSB(PSBIEN) ; -- HMP PSB EVENTS protocol listener (BCMA) /DE2818
N IEN,DFN,ORPK,TYPE,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>0) Q:ORPK<1 S TYPE=$S(ORPK["V":"IV",ORPK["U":5,1:"") Q:TYPE="" ;DE4496 19 August 2016
S ORIFN=$$ORDRNUM^PSSUTLA2(DFN,TYPE,+ORPK) ;DE4382 get order number from PSSUTLA2. ICR 6426
D:ORIFN POST(DFN,"med",ORIFN)
Q
;
XU(IEN,ACT) ; -- XU USER ADD/CHANGE/TERMINATE option listener
S IEN=+$G(IEN) Q:IEN<1
D POSTX("user",IEN,$G(ACT))
Q
;
POST(DFN,TYPE,ID,ACT) ; -- track updated patient data
S DFN=+$G(DFN),TYPE=$G(TYPE),ID=$G(ID)
Q:'(DFN>0) Q:TYPE="" Q:ID="" ;incomplete request - DE4496 19 August 2016
Q:$G(^XTMP("HMP-off",TYPE)) ;domain turned 'off'
Q:'$D(^HMP(800000,"AITEM",DFN)) ;patient not subscribed to
N HMPDT S HMPDT="HMP-"_DT
;S ^XTMP(HMPDT,$$NEXT)=DFN_U_TYPE_U_ID_U_$G(ACT)
N NODES
D POST^HMPDJFS(DFN,TYPE,ID,$G(ACT),"",.NODES)
Q
;
POSTX(TYPE,ID,ACT) ; -- track updated reference items
S TYPE=$G(TYPE),ID=$G(ID)
Q:TYPE="" Q:ID="" ;incomplete request
Q:$G(^XTMP("HMP-off",TYPE)) ;domain turned 'off'
N HMPDT S HMPDT="HMP-"_DT ;"HMPEF-"_DT
;S ^XTMP(HMPDT,$$NEXT)=U_TYPE_U_ID_U_$G(ACT)
N NODES
D POST^HMPDJFS("OPD",TYPE,ID,$G(ACT),"",.NODES)
Q
;
NEXT() ; -- Return next sequential number in ^XTMP(HMPDT,n)
L +^XTMP(HMPDT):5 ;I'$T ??
N Y S Y=+$O(^XTMP(HMPDT,"A"),-1)+1
I '$D(^XTMP(HMPDT,0)) S ^(0)=$$FMADD^XLFDT(DT,3)_U_DT_"^HMP Updates"
L -^XTMP(HMPDT)
Q Y
;
HTTP(URL,DFN,TYPE,ID) ; -- send message that TYPE/ID has been updated [not in use]
N DIV,X,HMPX
S DFN=+$G(DFN) Q:'(DFN>0) ;patient req'd - DE4496 19 August 2016
S DIV=$P($$SITE^VASITE,U,3) ;station number
S URL=$G(URL)_"?division="_DIV_"&dfn="_+$G(DFN)
I $L($G(TYPE)) S URL=URL_"&type="_TYPE
I $L($G(ID)) S URL=URL_"&id="_ID
S ^XTMP("HMP",DFN,"HTTP")=$H
S X=$$GETURL^XTHC10(URL,,"HMPX")
; I X>200 = ERROR
Q
DGREG ; register a newly registered patient in eHMP during the initial registration - Sep 29, 2015 - Phil Burkhalter
Q:'($G(DFN)>0) ;DE4496 19 August 2016
Q:'$D(^DPT(DFN,0)) ; Quit if patient is not in the patient file
;check the XPAR for HMP Auto Enrollment with newly registered patients,
;if set to yes for automatically adding a new HMP subscription:
;add the patient to HMP(800000 and to a pt-select update. Only want to do an update for the one patient if possible.
;if set to no for automatically adding a new HMP subscrption:
;only do the pt-select update, DO NOT add to the HMP subscription
S X=$$GET^XPAR("SYS","HMP AUTOSYNC REG") ;X=1 Yes auto subscribe patient to HMP, X="" or X=0 No don't auto subscribe the patient to HMP
I $G(X)'=1 D POSTX(DFN,"patient",DFN) Q ; Do pt-select
I $G(X)=1 D
.Q:$D(^HMP(800000,"AITEM",DFN)) ; Quit if the patient has already been added to the eHMP subscription
.S ARGS("command")="putPtSubscription",ARGS("localId")=$G(DFN)
.;DE3327
.I '$L($G(ARGS("server"))) S ARGS("server")=$P($G(^HMP(800000,1,0)),"^") ; See comments at the top
.D API^HMPDJFS(.RSLT,.ARGS) D POSTX(DFN,"patient",DFN) ; add patient to HMP(800000 and if patient is added, add patient to the freshness stream
.K ARGS,RSLT
K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPEVNT 17921 printed Oct 16, 2024@17:54:40 Page 2
HMPEVNT ;SLC/MKB,ASMR/JD,RRB,CPC,MBS -- VistA event listeners;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; DG FIELD MONITOR 3344
+7 ; DGPM MOVEMENT EVENTS 1181
+8 ; GMRA ENTERED IN ERROR 1467
+9 ; GMRA SIGN-OFF ON DATA 1469
+10 ; GMRC EVSEND OR 3140
+11 ; LR70 CH EVSEND OR 6087
+12 ; MDC OBSERVATION UPDATE 6084
+13 ; PS EVSEND OR 2415
+14 ; PSB EVSEND HMP 6085
+15 ; PXK VISIT DATA EVENT 1298
+16 ; RA EVSEND OR 6086
+17 ; SDAM APPOINTMENT EVENTS 1320
+18 ; ^AUPNVSIT 2028
+19 ; ^DPT 10035
+20 ; ^OR(100 5771
+21 ; DIQ 2056
+22 ; GMVUTL 5046
+23 ; TIUSRVLO 2834
+24 ; VADPT 10061
+25 ; VASITE 10112
+26 ; XLFDT 10103
+27 ; XTHC10 5515
+28 ; ORDRNUM^PSSUTLA2 6426 ;DE6363 - JD - 8/23/16
+29 ;
+30 ; DE2818 - SQA findings.
+31 ; 1) Correct unkilled variables by modifying line tags to accept variables as
+32 ; parameters and modifying associated protocol routine calls to pass variables
+33 ; as parameters. RRB - 10/28/2015
+34 ;
+35 ;Oct 15, 2015 - PB - modified to trigger an unsolicited sync action when an order is discontinued and the patient is subscribed to eHMP
+36 ;
+37 ;DE3327 - 5/4/16 - JD - Removed the server hardcoding (hmp-development-box).
+38 ; *** NOTE ***
+39 ; It is understood that as of the date of modifying this code (5/4/16), there
+40 ; is one AND ONLY one server entry in the HMP Subscription file (#800000)
+41 ; per site. This will be fixed in future releases to accommodate multiple
+42 ; servers per site.
+43 ;
+44 QUIT
+45 ;
DG(DGDA,DGFIELD,DGFILE) ; -- DG FIELD MONITOR protocol listener /DE2818
+1 ;Patient file only
if $GET(DGFILE)'=2
QUIT
+2 NEW DFN
SET DFN=+$GET(DGDA)
+3 ; operational pt-select - *s68 BEGIN
+4 IF "^.01^.02^.03^.09^.101^.351^.361^"[(U_+$GET(DGFIELD)_U)
Begin DoDot:1
+5 ; -- if patient entry has been deleted, delete pt-select object
+6 ; *s68 - END
IF $GET(DGFIELD)=".01"
IF '$DATA(^DPT(DFN))
DO POSTX("pt-select",DFN,"@")
QUIT
+7 DO POSTX("pt-select",DFN_"&"_$GET(DGFIELD))
End DoDot:1
+8 ; subscribed patient
+9 IF $DATA(^HMP(800000,"AITEM",DFN))
IF $$FLD(+$GET(DGFIELD))
DO POST(DFN,"patient",DFN)
+10 QUIT
+11 ;
FLD(X) ; --Return 1 or 0, if X is a field tracked by HMP
+1 SET X=U_+$GET(X)_U
+2 ;demographic
IF "^.01^.02^.03^.05^.08^.09^.351^.361^.364^"[X
QUIT 1
+3 ;addr/phone
IF "^.111^.1112^.112^.113^.114^.115^.131^.132^.134^"[X
QUIT 1
+4 ;NOK
IF "^.211^.212^.213^.214^.216^.217^.218^.219^"[X
QUIT 1
+5 ;serv conn
IF "^.301^.302^1901^.32102^.32103^.32201^.5295^"[X
QUIT 1
+6 ;New fields. JD - 9/24/15
+7 ;email address
IF "^.133^"[X
QUIT 1
+8 ;temporary address
IF "^.1211^.1212^.1213^.1214^.1215^.1216^"[X
QUIT 1
+9 ;emergency contact addr/phone
IF "^.331^.332^.333^.334^.335^.336^.337^.338^.339^.33011^"[X
QUIT 1
+10 ;NOK addr line 3 and work phone
IF "^.215^.21011^"[X
QUIT 1
+11 ;service connected conditions
IF "^.3731^"[X
QUIT 1
+12 ;insurance
IF "^.18^3^8^16^"[X
QUIT 1
+13 QUIT 0
+14 ;
DGPM(DGPMA,DGPMDA,DGPMP,DGPMT) ; -- DGPM MOVEMENT EVENTS protocol listener /DE2818
+1 ; [expects DFN,DGPM* variables]
+2 NEW ADM,ACT
SET ADM=DGPMDA
+3 IF DGPMT'=1
SET ADM=$SELECT(DGPMA:$PIECE(DGPMA,U,14),1:$PIECE(DGPMP,U,14))
if ADM<1
QUIT
+4 SET ACT=$SELECT(DGPMA:"",1:"@")
+5 IF $DATA(^HMP(800000,"AITEM",DFN))
DO POST(DFN,"visit","H"_ADM,ACT)
+6 ; update roster(s) if current movement
+7 NEW ADMX,MVTX,PREV,NEW,OLD,WARD
+8 SET ADMX=$QUERY(^DGPM("ATID1",DFN))
if $QSUBSCRIPT(ADMX,4)'=ADM
QUIT
+9 SET MVTX=$QUERY(^DGPM("APMV",DFN,ADM))
if $QSUBSCRIPT(MVTX,5)'=DGPMDA
QUIT
+10 ;previous or edited mvt
SET PREV=$GET(DGPMP)
IF 'PREV
IF DGPMT'=1
Begin DoDot:1
+11 SET MVTX=$QUERY(@MVTX)
if DFN'=$QSUBSCRIPT(MVTX,2)
QUIT
if ADM'=$QSUBSCRIPT(MVTX,3)
QUIT
+12 SET PREV=$GET(^DGPM(+$QSUBSCRIPT(MVTX,5),0))
End DoDot:1
+13 SET NEW=$PIECE(DGPMA,U,6)
SET OLD=$PIECE(PREV,U,6)
+14 IF NEW'=OLD
FOR WARD=NEW,OLD
IF WARD
Begin DoDot:1
+15 SET I=0
FOR
SET I=$ORDER(^HMPROSTR("AD",WARD_";DIC(42,",I))
if I<1
QUIT
DO POSTX("roster",I)
End DoDot:1
+16 QUIT
+17 ;-find visit# for corresponding admission [not used]
+18 NEW ADM,PTF,IDT,ID,ACT
+19 IF DGPMA
SET ADM=+DGPMA
SET PTF=+$PIECE(DGPMA,U,16)
+20 IF '$TEST
SET ADM=+DGPMP
SET PTF=+$PIECE(DGPMP,U,16)
+21 IF DGPMT'=1
Begin DoDot:1
+22 NEW VAIP
SET VAIP("E")=DGPMDA
+23 DO IN5^VADPT
SET ADM=+VAIP(13,1)
SET PTF=+VAIP(12)
End DoDot:1
if ADM<1
QUIT
+24 SET IDT=9999999-$PIECE(ADM,".")
if ADM["."
SET IDT=IDT_"."_$PIECE(ADM,".",2)
+25 SET ID=+$ORDER(^AUPNVSIT("AAH",DFN,IDT,0))
if 'ID
QUIT
+26 SET ACT=$SELECT(DGPMA:"",1:"@")
+27 DO POST(DFN,"visit",ID,ACT)
+28 ; POST(DFN,"ptf",PTF,ACT):DGPMT=3
+29 QUIT
+30 ;
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 ;
PCMMT(SCPTTMAF,SCPTTMB4) ; -- SCMC PATIENT TEAM CHANGES protocol listener /DE2818
+1 ;I '$P($G(SCPTTMB4),U,8),'$P($G(SCPTTMAF),U,8) Q ;not pc change ;DE5410 removed to track changes to other teams
+2 NEW DFN
SET DFN=$SELECT($GET(SCPTTMAF):+SCPTTMAF,1:+$GET(SCPTTMB4))
if 'DFN
QUIT
+3 DO POST(DFN,"patient",DFN)
+4 QUIT
+5 ;
PCMMTP(SCPTTPAF,SCPTTPB4) ; -- SCMC PATIENT TEAM POSITION CHANGES protocol listener /DE2818
+1 ;I '$P($G(SCPTTPB4),U,5),'$P($G(SCPTTPAF),U,5) Q ;not pc change ;DE5410 removed to track changes to other teams
+2 NEW TM,DFN
+3 SET TM=$SELECT($GET(SCPTTPAF):+SCPTTPAF,1:+$GET(SCPTTPB4))
if 'TM
QUIT
+4 ;DE2818
+5 ;ICR 1922
SET DFN=$$GET1^DIQ(404.42,+TM_",",.01,"I")
+6 DO POST(DFN,"patient",DFN)
+7 QUIT
+8 ;
SDAM(SDATA) ; -- SDAM APPOINTMENT EVENTS protocol listener /DE2818
+1 ;appointments ;DE5411 still process if Piece 1 not set, catches auto-rebook status
IF $GET(SDATA)'=""
Begin DoDot:1
+2 NEW DFN,DATE,HLOC,STS,REASON,PROV
+3 ;DE4496 19 August 2016
SET DFN=+$PIECE(SDATA,U,2)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+4 if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+5 SET DATE=+$PIECE(SDATA,U,3)
SET HLOC=+$PIECE(SDATA,U,4)
SET (PROV,REASON)=""
+6 DO POST(DFN,"appointment","A;"_DATE_";"_HLOC_";"_REASON_";"_$TRANSLATE($PIECE(PROV,U,1,2),"^",";"))
End DoDot:1
QUIT
+7 QUIT
+8 ;
PCE ; -- PXK VISIT DATA EVENT protocol listener, used by HMP PCE EVENTS protocol
+1 ;DE4195 and DE6485
NEW ACT,DA,DFN,HMPPXK,IEN,PX0A,PX0B,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 SET IEN=+$ORDER(^TMP("PXKCO",$JOB,0))
if IEN<1
QUIT
+3 SET PX0A=$GET(^TMP("PXKCO",$JOB,IEN,"VST",IEN,0,"AFTER"))
SET PX0B=$GET(^("BEFORE"))
+4 SET DFN=$SELECT($LENGTH(PX0A):+$PIECE(PX0A,U,5),1:+$PIECE(PX0B,U,5))
+5 ;DE4496 19 August 2016
if '(DFN>0)
QUIT
if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+6 ; Visit file
+7 SET ACT=$SELECT(PX0A="":"@",1:"")
+8 ;DE4195 - put subsequent processing into taskman
+9 MERGE HMPPXK=^TMP("PXKCO",$JOB)
+10 ; DE6485, add null device in ZTIO
+11 SET ZTRTN="PCE2^HMPEVNT"
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTSAVE("HMPPXK(")=""
SET ZTSAVE("DFN")=""
SET ZTSAVE("IEN")=""
SET ZTSAVE("ACT")=""
+12 SET ZTDESC="HMP PXK VISIT EVENT HANDLER"
+13 DO ^%ZTLOAD
+14 QUIT
PCE2 ; DE4195 - run in taskman
+1 NEW DA,SUB
+2 DO POST(DFN,"visit",IEN,ACT)
+3 ; check V-files
+4 ;DE4879 - Removed Health Factors from loop (was SUB="HF","IMM",...)
+5 FOR SUB="IMM","XAM","CPT","PED","POV","SK"
Begin DoDot:1
+6 SET DA=0
FOR
SET DA=$ORDER(HMPPXK(IEN,SUB,DA))
if DA<1
QUIT
Begin DoDot:2
+7 SET ACT=$SELECT($GET(HMPPXK(IEN,SUB,DA,0,"AFTER"))="":"@",1:"")
+8 DO POST(DFN,$$NAME(SUB),DA,ACT)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
NAME(X) ; -- return object name for V-files
+1 NEW Y
SET Y=""
+2 IF X="HF"
SET Y="factor"
+3 IF X="IMM"
SET Y="immunization"
+4 IF X="XAM"
SET Y="exam"
+5 IF X="CPT"
SET Y="cpt"
+6 IF X="PED"
SET Y="education"
+7 IF X="POV"
SET Y="pov"
+8 IF X="SK"
SET Y="skin"
+9 QUIT Y
+10 ;
ZPCE ; -- old PXK VISIT DATA EVENT protocol listener [not in use]
+1 NEW IEN,PX0,PX150,DFN,DA
+2 SET IEN=+$ORDER(^TMP("PXKCO",$JOB,0))
if IEN<1
QUIT
+3 SET PX0=$GET(^TMP("PXKCO",$JOB,IEN,"VST",IEN,0,"AFTER"))
if $PIECE(PX0,U,7)="E"
QUIT
+4 ;deleted
IF PX0=""
DO POST(DFN,"visit",IEN,"@")
QUIT
+5 SET PX150=$GET(^TMP("PXKCO",$JOB,IEN,"VST",IEN,150,"AFTER"))
if $PIECE(PX150,U,3)'="P"
QUIT
+6 ;DE4496 19 August 2016
SET DFN=+$PIECE(PX0,U,5)
if '(DFN>0)
QUIT
if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+7 DO POST(DFN,"visit",IEN)
+8 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXKCO",$JOB,IEN,"IMM",DA))
if DA<1
QUIT
DO POST(DFN,"immunization",DA)
+9 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXKCO",$JOB,IEN,"HF",DA))
if DA<1
QUIT
DO POST(DFN,"factor",DA)
+10 QUIT
+11 ;
XQOR(MSG) ; -- messaging listener (update meds, labs, xrays, consults)
+1 NEW HMPMSG,HMPPKG,MSH,ORC,DFN
+2 SET HMPMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@HMPMSG@(0))
QUIT
+3 SET MSH=0
FOR
SET MSH=$ORDER(@HMPMSG@(MSH))
if MSH'>0
QUIT
if $EXTRACT(@HMPMSG@(MSH),1,3)="MSH"
QUIT
+4 if 'MSH
QUIT
if '$LENGTH($GET(@HMPMSG@(MSH)))
QUIT
+5 SET HMPPKG=$$TYPE($PIECE(@HMPMSG@(MSH),"|",3))
if '$LENGTH(HMPPKG)
QUIT
+6 ;DE4496 19 August 2016
SET DFN=$$PID
if '(DFN>0)
QUIT
if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+7 SET ORC=MSH
FOR
SET ORC=$ORDER(@HMPMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT(@HMPMSG@(ORC),1,3)="ORC"
Begin DoDot:1
+8 NEW ORDCNTRL,PKGIFN,ORIFN,PORIFN
+9 SET ORC=ORC_U_@HMPMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+10 ; QUIT if action failed, conversion, purge, or backdoor verify/new
+11 ;I ORDCNTRL["U"!("DE^ZC^ZP^ZR^ZV^SN"[ORDCNTRL) Q
+12 ;Oct 15, 2015 - PB - modified to trigger an unsolicited sync action when a signed order is discontinued
IF ORDCNTRL["U"!("DE^ZP^ZR^ZV^SN"[ORDCNTRL)
QUIT
+13 SET ORIFN=+$PIECE($PIECE(ORC,"|",3),U)
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+14 ; If this is a child order get the parent and send it too
+15 ; PORIFN = PARENT ORDER IFN
+16 SET PORIFN=+$PIECE($GET(^OR(100,ORIFN,3)),U,9)
+17 ;update ancillary domains
IF $$RESULT
Begin DoDot:2
+18 DO POST(DFN,HMPPKG,PKGIFN)
+19 if HMPPKG="image"
DO POST(DFN,"document",PKGIFN)
+20 IF HMPPKG="lab"
IF PKGIFN'["CH"
IF '$$LRTIU(DFN,PKGIFN)
DO POST(DFN,"document",$PIECE(PKGIFN,";",4,5))
End DoDot:2
+21 ;update order(s)
IF ORIFN
IF ORDCNTRL'="ZD"
Begin DoDot:2
+22 DO POST(DFN,"order",ORIFN)
+23 IF PORIFN
DO POST(DFN,"order",PORIFN)
+24 NEW ORIG
SET ORIG=+$PIECE($GET(^OR(100,ORIFN,3)),U,5)
+25 ;need fwd ptrs, sig flds
IF ORIG
DO POST(DFN,"order",ORIG)
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
RESULT() ; -- Return 1 or 0, if message broadcasts a result
+1 ; [may modify PKGIFN for use in POST]
+2 NEW Y
SET Y=0
+3 IF HMPPKG="consult"
SET Y=1
SET PKGIFN=+PKGIFN
GOTO RQ
+4 IF HMPPKG="med"
SET Y=1
SET PKGIFN=ORIFN
GOTO RQ
+5 IF HMPPKG="lab"
if ORDCNTRL="RE"&($LENGTH(PKGIFN,";")>3)
SET Y=1
GOTO RQ
+6 IF HMPPKG="image"
if PKGIFN["~"
SET Y=1
SET PKGIFN=$TRANSLATE($PIECE(PKGIFN,"~",2,3),"~","-")
GOTO RQ
RQ QUIT Y
+1 ;
LRTIU(DFN,ORPK) ; -- Return 1 or 0, if LR report is in TIU
+1 IF $GET(DFN)<1!'$LENGTH($GET(ORPK))
QUIT 0
+2 IF ORPK["CH"!(ORPK["MI")
QUIT 0
+3 NEW SUB,IDT,LRDFN
+4 SET SUB=$PIECE(ORPK,";",4)
SET IDT=+$PIECE(ORPK,";",5)
SET LRDFN=+$GET(^DPT(+DFN,"LR"))
+5 IF $ORDER(^LR(LRDFN,SUB,IDT,.05,0))
QUIT 1
+6 QUIT 0
+7 ;
NA(MSG) ; -- messaging listener (new backdoor orders)
+1 NEW HMPMSG,HMPPKG,MSH,ORC,DFN
+2 SET HMPMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@HMPMSG@(0))
QUIT
+3 SET MSH=0
FOR
SET MSH=$ORDER(@HMPMSG@(MSH))
if MSH'>0
QUIT
if $EXTRACT(@HMPMSG@(MSH),1,3)="MSH"
QUIT
+4 if 'MSH
QUIT
if '$LENGTH($GET(@HMPMSG@(MSH)))
QUIT
+5 SET HMPPKG=$$TYPE($PIECE(@HMPMSG@(MSH),"|",5))
if '$LENGTH(HMPPKG)
QUIT
+6 ;DE4496 19 August 2016
SET DFN=$$PID
if '(DFN>0)
QUIT
if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+7 SET ORC=MSH
FOR
SET ORC=$ORDER(@HMPMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT(@HMPMSG@(ORC),1,3)="ORC"
Begin DoDot:1
+8 NEW ORDCNTRL,ORIFN
+9 SET ORC=ORC_U_@HMPMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+10 if ORDCNTRL'="NA"
QUIT
+11 SET ORIFN=+$PIECE($PIECE(ORC,"|",3),U)
DO POST(DFN,"order",ORIFN)
+12 IF HMPPKG="med"
DO POST(DFN,HMPPKG,ORIFN)
End DoDot:1
+13 QUIT
+14 ;
TYPE(NAME) ; -- Returns type name for XML
+1 IF NAME="LABORATORY"
QUIT "lab"
+2 IF NAME="PHARMACY"
QUIT "med"
+3 IF NAME="CONSULTS"
QUIT "consult"
+4 IF NAME="PROCEDURES"
QUIT "consult"
+5 IF NAME="RADIOLOGY"
QUIT "image"
+6 IF NAME="IMAGING"
QUIT "image"
+7 IF NAME="ORDER ENTRY"
QUIT "order"
+8 IF NAME="DIETETICS"
QUIT "diet"
+9 QUIT ""
+10 ;
PID() ; -- Returns patient from PID segment in current msg
+1 NEW I,SEG,Y
SET I=MSH
+2 FOR
SET I=$ORDER(@HMPMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@HMPMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="PID"
Begin DoDot:1
+3 SET Y=+$PIECE(@HMPMSG@(I),"|",4)
+4 ;I '$D(^DPT(Y,0)) S:$L($P(@HMPMSG@(I),"|",5)) Y=+$P(@HMPMSG@(I),"|",5) ;alt ID for Lab
End DoDot:1
QUIT
+5 QUIT Y
+6 ;
PV1() ; -- Returns patient class from PV1 segment in current msg
+1 NEW I,SEG,Y
SET I=MSH
SET Y=""
+2 FOR
SET I=$ORDER(@HMPMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@HMPMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="PV1"
Begin DoDot:1
+3 SET Y=$PIECE(@HMPMSG@(I),"|",3)
End DoDot:1
QUIT
+4 IF Y=""
IF $GET(ORIFN)
SET Y=$$GET1^DIQ(100,+ORIFN_",",10,"I")
+5 QUIT Y
+6 ;
GMRA(ACT) ; -- GMRA SIGN-OFF ON DATA protocol listener
+1 ; also GMRA ENTERED IN ERROR [ACT=@]
+2 NEW DFN,IEN
+3 SET DFN=+$GET(GMRAPA(0))
SET IEN=+$GET(GMRAPA)
+4 DO POST(DFN,"allergy",IEN,$GET(ACT))
+5 QUIT
+6 ;
GMPL(DFN,IEN) ; -- GMPL EVENT protocol listener
+1 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
+2 ;N ACT S ACT=$S($P($G(^AUPNPROB(IEN,1)),U,2)="H":"@",1:"")
+3 ;,ACT)
DO POST(DFN,"problem",IEN)
+4 QUIT
+5 ;
GMRV(DFN,IEN,ERR) ; -- Vital Measurement file #120.5 AHMP index
+1 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
+2 NEW ACT
SET ACT=$SELECT($GET(ERR):"@",1:"")
+3 DO POST(DFN,"vital",IEN,ACT)
+4 QUIT
+5 ;
MDC(OBS) ; -- MDC OBSERVATION UPDATE protocol listener
+1 NEW DFN,ID,ACT
+2 ;DE4496 19 August 2016
SET DFN=+$GET(OBS("PATIENT_ID","I"))
if '(DFN>0)
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(DFN,"obs",ID,ACT)
+6 IF $GET(OBS("DOMAIN","VITALS"))
DO POST(DFN,"vital",ID,ACT)
+7 QUIT
+8 ;
CP(DFN,ID,ACT) ; -- CP Transaction file #702 AHMP index
+1 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
+2 ;de3944 also need to generate document for procedure to link results to
DO POST(DFN,"document",ID,$GET(ACT))
+3 DO POST(DFN,"procedure",ID,$GET(ACT))
+4 QUIT
+5 ;
SR(DFN,IEN,ACT) ; -- Surgery [SROERR] update
+1 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
+2 DO POST(DFN,"surgery",IEN,$GET(ACT))
+3 QUIT
+4 ;*s68 - BEGINS
TIU(DFN,IEN) ; -- TIU Document file #8925 AHMP index
+1 NEW ACT,STS,DAD,REPCAT
+2 SET DFN=+$GET(DFN)
SET IEN=+$GET(IEN)
SET ACT=""
+3 ;X = FM data array for index
SET STS=$GET(X(2))
SET DAD=$GET(X(3))
+4 ;if addendum, repull entire note
if DAD
SET IEN=DAD
IF 'DAD
Begin DoDot:1
+5 ;I STS=15 S ACT="@" ;retracted; DE3693 - do not delete note from JDS if retracted, March 18, 2016
+6 ;deleted (new title = null)
IF $GET(X2(1))=""
SET ACT="@"
End DoDot:1
+7 DO POST(DFN,"document",IEN,ACT)
+8 ;DE3944 update surgery based on reports
+9 SET REPCAT=$$CATG^HMPDTIU($$GET1^DIQ(8925,IEN_",",".01","I"))
+10 IF REPCAT="SR"
Begin DoDot:1
+11 NEW REPCASE
SET REPCASE=$$GET1^DIQ(8925,IEN_",","1701","I")
+12 SET REPCASE=$PIECE(REPCASE,"Case #: ",2)
+13 IF REPCASE
DO POST(DFN,"surgery",REPCASE)
End DoDot:1
+14 ;DE3241 - If TIU update changes CWADF values, trigger patient update so change get in fresh. stream
+15 ;If this note has a parent document type of "CLINICAL WARNING", "CRISIS NOTE", or "ADVANCE DIRECTIVE"...
+16 ;parent document type is "Document Class"...
+17 ;AND this note's status is COMPLETED or AMENDED
+18 ;THEN this document may update the C, W, or D CWADF values and patient fresh. stream update needs to be triggered
+19 NEW DADTYPE,DADNAME,STATUS
+20 SET DADTYPE=$$GET1^DIQ(8925,IEN_",",".04","I")
if 'DADTYPE
QUIT
if $$GET1^DIQ(8925.1,DADTYPE_",",".04","I")'="DC"
QUIT
+21 SET DADNAME=$$GET1^DIQ(8925.1,DADTYPE_",",".01")
+22 IF $SELECT(DADNAME="CLINICAL WARNING":0,DADNAME="CRISIS NOTE":0,DADNAME="ADVANCE DIRECTIVE":0,1:1)
QUIT
+23 DO POST(DFN,"patient",DFN)
+24 QUIT
+25 ; Deprecated calls
DOCDEF ;
DOCITEM ;
USR ;
+1 QUIT
+2 ; *s68 - END
PSB(PSBIEN) ; -- HMP PSB EVENTS protocol listener (BCMA) /DE2818
+1 NEW IEN,DFN,ORPK,TYPE,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 ;DE4496 19 August 2016
if '(DFN>0)
QUIT
if ORPK<1
QUIT
SET TYPE=$SELECT(ORPK["V":"IV",ORPK["U":5,1:"")
if TYPE=""
QUIT
+5 ;DE4382 get order number from PSSUTLA2. ICR 6426
SET ORIFN=$$ORDRNUM^PSSUTLA2(DFN,TYPE,+ORPK)
+6 if ORIFN
DO POST(DFN,"med",ORIFN)
+7 QUIT
+8 ;
XU(IEN,ACT) ; -- XU USER ADD/CHANGE/TERMINATE option listener
+1 SET IEN=+$GET(IEN)
if IEN<1
QUIT
+2 DO POSTX("user",IEN,$GET(ACT))
+3 QUIT
+4 ;
POST(DFN,TYPE,ID,ACT) ; -- track updated patient data
+1 SET DFN=+$GET(DFN)
SET TYPE=$GET(TYPE)
SET ID=$GET(ID)
+2 ;incomplete request - DE4496 19 August 2016
if '(DFN>0)
QUIT
if TYPE=""
QUIT
if ID=""
QUIT
+3 ;domain turned 'off'
if $GET(^XTMP("HMP-off",TYPE))
QUIT
+4 ;patient not subscribed to
if '$DATA(^HMP(800000,"AITEM",DFN))
QUIT
+5 NEW HMPDT
SET HMPDT="HMP-"_DT
+6 ;S ^XTMP(HMPDT,$$NEXT)=DFN_U_TYPE_U_ID_U_$G(ACT)
+7 NEW NODES
+8 DO POST^HMPDJFS(DFN,TYPE,ID,$GET(ACT),"",.NODES)
+9 QUIT
+10 ;
POSTX(TYPE,ID,ACT) ; -- track updated reference items
+1 SET TYPE=$GET(TYPE)
SET ID=$GET(ID)
+2 ;incomplete request
if TYPE=""
QUIT
if ID=""
QUIT
+3 ;domain turned 'off'
if $GET(^XTMP("HMP-off",TYPE))
QUIT
+4 ;"HMPEF-"_DT
NEW HMPDT
SET HMPDT="HMP-"_DT
+5 ;S ^XTMP(HMPDT,$$NEXT)=U_TYPE_U_ID_U_$G(ACT)
+6 NEW NODES
+7 DO POST^HMPDJFS("OPD",TYPE,ID,$GET(ACT),"",.NODES)
+8 QUIT
+9 ;
NEXT() ; -- Return next sequential number in ^XTMP(HMPDT,n)
+1 ;I'$T ??
LOCK +^XTMP(HMPDT):5
+2 NEW Y
SET Y=+$ORDER(^XTMP(HMPDT,"A"),-1)+1
+3 IF '$DATA(^XTMP(HMPDT,0))
SET ^(0)=$$FMADD^XLFDT(DT,3)_U_DT_"^HMP Updates"
+4 LOCK -^XTMP(HMPDT)
+5 QUIT Y
+6 ;
HTTP(URL,DFN,TYPE,ID) ; -- send message that TYPE/ID has been updated [not in use]
+1 NEW DIV,X,HMPX
+2 ;patient req'd - DE4496 19 August 2016
SET DFN=+$GET(DFN)
if '(DFN>0)
QUIT
+3 ;station number
SET DIV=$PIECE($$SITE^VASITE,U,3)
+4 SET URL=$GET(URL)_"?division="_DIV_"&dfn="_+$GET(DFN)
+5 IF $LENGTH($GET(TYPE))
SET URL=URL_"&type="_TYPE
+6 IF $LENGTH($GET(ID))
SET URL=URL_"&id="_ID
+7 SET ^XTMP("HMP",DFN,"HTTP")=$HOROLOG
+8 SET X=$$GETURL^XTHC10(URL,,"HMPX")
+9 ; I X>200 = ERROR
+10 QUIT
DGREG ; register a newly registered patient in eHMP during the initial registration - Sep 29, 2015 - Phil Burkhalter
+1 ;DE4496 19 August 2016
if '($GET(DFN)>0)
QUIT
+2 ; Quit if patient is not in the patient file
if '$DATA(^DPT(DFN,0))
QUIT
+3 ;check the XPAR for HMP Auto Enrollment with newly registered patients,
+4 ;if set to yes for automatically adding a new HMP subscription:
+5 ;add the patient to HMP(800000 and to a pt-select update. Only want to do an update for the one patient if possible.
+6 ;if set to no for automatically adding a new HMP subscrption:
+7 ;only do the pt-select update, DO NOT add to the HMP subscription
+8 ;X=1 Yes auto subscribe patient to HMP, X="" or X=0 No don't auto subscribe the patient to HMP
SET X=$$GET^XPAR("SYS","HMP AUTOSYNC REG")
+9 ; Do pt-select
IF $GET(X)'=1
DO POSTX(DFN,"patient",DFN)
QUIT
+10 IF $GET(X)=1
Begin DoDot:1
+11 ; Quit if the patient has already been added to the eHMP subscription
if $DATA(^HMP(800000,"AITEM",DFN))
QUIT
+12 SET ARGS("command")="putPtSubscription"
SET ARGS("localId")=$GET(DFN)
+13 ;DE3327
+14 ; See comments at the top
IF '$LENGTH($GET(ARGS("server")))
SET ARGS("server")=$PIECE($GET(^HMP(800000,1,0)),"^")
+15 ; add patient to HMP(800000 and if patient is added, add patient to the freshness stream
DO API^HMPDJFS(.RSLT,.ARGS)
DO POSTX(DFN,"patient",DFN)
+16 KILL ARGS,RSLT
End DoDot:1
+17 KILL X
+18 QUIT
