- 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 Jan 18, 2025@02:55:12 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