HMPDJ01 ;SLC/MKB,ASMR/MBS -- Orders ;Aug 17, 2016 11:42:39
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References ICR
; ------------------- -----
; ^DPT 10035
; ^OR(100 5771
; ^ORA(102.4 5769
; ^ORD(100.98 873
; ^PXRMINDX 4290
; ^RADPT 2480
; ^SC 10040
; ^VA(200 10060
; DIC 2051
; DIQ 2056
; GMRCGUIB 2980
; LR7OU1 2955
; ORQ1,^TMP("ORR" 3154
; ORQ12,^TMP("ORR" 5704
; ORX8 2467
; PSS51P1 4546
;
; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
Q
;
OR1(ID) ; -- order ID >> ^TMP("ORR",$J,ORLIST,HMPN)
N ORDER,CHILD,HMPC
D ORX(ID,.ORDER)
;DE2818, ^OR(100) - ICR 5771
S HMPC=0 F S HMPC=$O(^OR(100,ID,2,HMPC)) Q:HMPC<1 D
. ; DE5111 begin
. ; check for child Order's existence, if not found, log it and quit
. I '$L($$GET1^DIQ(100,HMPC_",",.01)) D Q ; HMPC is IFN
.. N LOGTXT S LOGTXT(1)=" missing child Order IFN: "_HMPC_", DFN: "_$G(DFN,"*no DFN*")
.. D EVNTLOG^HMPDOR(.LOGTXT,"M") ; event type is "missing"
. ; DE5111 end
. K CHILD D ORX(HMPC,.CHILD)
. M ORDER("children",HMPC)=CHILD
D:$D(ORDER) ;BL;DE7806 If a deleted order must not build these nodes
. S ORDER("lastUpdateTime")=$$EN^HMPSTMP("order") ;RHL 20141231
. S ORDER("stampTime")=ORDER("lastUpdateTime") ; RHL 20141231
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("order",ORDER("uid"),ORDER("stampTime")) Q:HMPMETA=1 ;US6734,US11019
D ADD^HMPDJ("ORDER","order")
Q
;
ORX(IFN,ORD) ; -- extract order IFN into ORD("attribute")
;DE5111 begin
;if no IFN passed, or invalid IFN, log it and quit
I '($G(IFN)>0) D Q
. N LOGTXT S LOGTXT(1)=" invalid order IFN: "_$G(IFN,"*no IFN*")_", DFN: "_$G(DFN,"*no DFN*")
. D EVNTLOG^HMPDOR(.LOGTXT,"C") ; event type is "corrupt"
;if Order not found for this IFN, log it and quit
I '$L($$GET1^DIQ(100,IFN_",",.01)) D Q
. N LOGTXT S LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_$G(DFN,"*no DFN*")
. D EVNTLOG^HMPDOR(.LOGTXT,"M") ; event type is "missing"
;DE5111 end
N DA,HDFN,I,LOC,ORDSTAT,ORLIST,ORLST,X,X0,X8
S ORLST=$S(+$G(HMPN):HMPN-1,1:0) S:'$D(ORLIST) ORLIST=$H
D GET^ORQ12(IFN,ORLIST,1) ; this modifies ^TMP("ORR",$J)
S X0=$G(^TMP("ORR",$J,ORLIST,ORLST))
N $ES,$ET,ERRPAT,ERRMSG
S $ET="D ERRHDLR^HMPDERRH",ERRPAT=DFN
S ERRMSG="A problem occurred converting record "_IFN_" for the orders domain"
;
S ORD("localId")=IFN,ORD("uid")=$$SETUID^HMPUTILS("order",DFN,IFN)
S X=$$OI^ORX8(+X0) I $L(X) D
. N ARRAY,NAME
. S ARRAY("Code")=1_U_"oi",ARRAY("Name")=2,ARRAY("PackageRef")=3
. D SPLITVAL^HMPUTILS(X,.ARRAY) S ORD("name")=ARRAY("Name")
. S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" S ORD("oi"_NAME)=$G(ARRAY(NAME))
S ORD("displayGroup")=$P(X0,U,2)
S ORD("entered")=$$JSONDT^HMPUTILS($P(X0,U,3))
S ORD("start")=$$JSONDT^HMPUTILS($P(X0,U,4)),ORD("stop")=$$JSONDT^HMPUTILS($P(X0,U,5)) ;US10045, DE3054
S ORD("statusCode")="urn:va:order-status:"_$P(X0,U,7)
S ORD("statusName")=$P(X0,U,6)
S ORD("statusVuid")="urn:va:vuid:"_$$STS^HMPDOR($P(X0,U,7))
D SETTEXT^HMPUTILS($NA(^TMP("ORR",$J,ORLIST,ORLST,"TX")),$NA(^TMP("HMPTEXT",$J,IFN)))
M ORD("content","\")=^TMP("HMPTEXT",$J,IFN)
; DE3504 - Jan 18, 2016, added the code for US10045 below
; US10045 - PB Dec 7, 2015 if ORDER is saved, signed, discontinued, then ORDER is unsigned
S HDFN=+$P($G(^OR(100,+IFN,0)),U,2)
S ORDSTAT=$$ORDACT(HDFN,+IFN) I ORDSTAT="DC" D
. ; DE3777 - March 15, 2016 - Modified the statusName to "UNRELEASED" for the order to match the status
. ; that appears in CPRS if the ORDER was DISCONTINUED and is UNSIGNED
. N HDC,HDCRSN,HMPORACT,HPTR,HSIGN
. S HDC=$O(^OR(100,IFN,8,"C","DC","")),HSIGN="" Q:'(HDC>0)
. S HMPORACT=$G(^OR(100,IFN,8,HDC,0))
. ; The 15th piece of HMPORACT is the RELEASE STATUS - '11' FOR unreleased
. I $P(HMPORACT,U,15)=11 S ORD("statusName")="UNRELEASED",ORD("statusCode")="urn:va:order-status:unr"
. S:$P($G(HMPORACT),U,4)=2 HSIGN="*UNSIGNED*"
. S HPTR=+$P($G(^OR(100,IFN,6)),U,4),HDCRSN=$P($G(^ORD(100.03,HPTR,0)),U) ;Combined fixes Mar 16, 2016 DE3777 CK - PB - DE4027
. I $L(HDCRSN) S ORD("content","\",2)=" <"_$G(HDCRSN)_"> "_HSIGN ; add DC order not signed in JSON object
. ; DE3777 - end of changes
;
S X=$$GET1^DIQ(100,IFN_",",1,"I") I X D
. S ORD("providerUid")=$$SETUID^HMPUTILS("user",,+X)
. S ORD("providerName")=$$GET1^DIQ(200,X_",",.01) ;DE2818, ICR 10060
S LOC=+$$GET1^DIQ(100,IFN_",",6,"I"),FAC=$$FAC^HMPD(LOC) I LOC D
. S ORD("locationName")=$$GET1^DIQ(44,LOC_",",.01) ;DE2818, ICR 10040
. S ORD("locationUid")=$$SETUID^HMPUTILS("location",,LOC)
D FACILITY^HMPUTILS(FAC,"ORD")
S ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
S X=$$GET1^DIQ(100,IFN_",",9,"I") S:X ORD("predecessor")=$$SETUID^HMPUTILS("order",DFN,+X)
S X=$$GET1^DIQ(100,IFN_",",9.1,"I") S:X ORD("successor")=$$SETUID^HMPUTILS("order",DFN,+X)
D RESULTS
; US11945 - Get parent and child orders for order
D KIN
; sign/verify
;US10045 modifications to get signed, verified and reviewed datetime stamp from HMP(800000
N C,HMUSR,HMORIN,HMPFND,HMPUF,HMSRVR,HPROV,HX8,ORFLG,ORIFN,ORIN ; US11894 Dec 18, 2015 - added variables used by Order Flag and Unflag
D ; US11894 Dec 18, 2015 - Order flagged and unflagged added to JSON
. S C=0,HMORIN=0 ; C = count for JSON object, HMORIN = IEN in sub-file
. S HMSRVR=$$SRVRNO^HMPOR(HDFN) Q:'HMSRVR ; if 'HMSRVR then not subscribed
. ; DE3584 Feb 1, 2016 - begin
. I '$D(^HMP(800000,HMSRVR,1,HDFN,1,IFN)) D ; orders not in HMP(800000) add them
.. N HMVALS,RSLT ; HMVALS = fields to update in 800000.14
.. D ORDRVALS^HMPOR(.HMVALS,IFN) ; get fields from ORDER file and map to HMP fields
.. Q:'$O(HMVALS(0)) ; error setting up fields, HMVALS("ERR") will be defined
.. S HMVALS(1.01)=$$NOW^XLFDT ; (#1.01) TRACKING START
.. D ADDORDR^HMPOR(.RSLT,.HMVALS,IFN,HDFN) ; may want to log error if RSLT<0
. ; DE3584 Feb 1, 2016 - end
. F S HMORIN=$O(^HMP(800000,HMSRVR,1,HDFN,1,IFN,2,HMORIN)) Q:'HMORIN D
.. S C=C+1,HMPFND=$G(^HMP(800000,HMSRVR,1,HDFN,1,IFN,2,HMORIN,0))
.. S HMPUF=$P(HMPFND,U,2),HMPUF=$S(HMPUF="U":"Unflagged",1:"Flagged")
.. S ORD("orderFlags",C,"order"_HMPUF_"DateTime")=$$JSONDT^HMPUTILS($P(HMPFND,U))
.. S HMUSR=$P(HMPFND,U,3)
.. S ORD("orderFlags",C,"order"_HMPUF_"By")=$$GET1^DIQ(200,HMUSR_",",.01,"E")
.. S ORD("orderFlags",C,"order"_HMPUF_"Reason")=$P(HMPFND,U,4)
;
I $D(^HMP(800000,HMSRVR,1,HDFN,1,IFN)) D Q ; check for existence of order in ^HMP(800000)
. S I=0,HX8=$G(^HMP(800000,HMSRVR,1,HDFN,1,IFN,0)),HPROV=$P(HX8,U,3)
. I HPROV'="" D USER(.I,"S",HPROV,$P(HX8,U,4)) ; get signed date/time
. I $P(HX8,U,6) D USER(.I,"N",$P(HX8,U,5),$P(HX8,U,6)) ; order verified by a nurse get the timestamp
. I $P(HX8,U,8) D USER(.I,"C",$P(HX8,U,7),$P(HX8,U,8)) ; order was verified by a clerk get the timestamp
. I $P(HX8,U,10) D USER(.I,"R",$P(HX8,U,9),$P(HX8,U,10)) ;order was reviewed get the timestamp
;
; DE3504 - Jan 18, 2016, go to ORDER file to get data
N ORACTION
S (ORACTION,I)=0
F S ORACTION=$O(^OR(100,IFN,8,ORACTION)) Q:'ORACTION D
. S HX8=$G(^OR(100,IFN,8,ORACTION,0)) I $P(HX8,U,6) D ; only if order is signed
.. S HPROV=$P(HX8,U,5) S:HPROV<1 HPROV=$P(HX8,U,3) ; signed by or provider
.. D USER(.I,"S",HPROV,$P(HX8,U,6)) ; date/time signed
.. I $P(HX8,U,9) D USER(.I,"N",$P(HX8,U,8),$P(HX8,U,9)) ; verifying nurse and date/time
.. I $P(HX8,U,11) D USER(.I,"C",$P(HX8,U,10),$P(HX8,U,11)) ; verifying clerk and date/time
.. I $P(HX8,U,19) D USER(.I,"R",$P(HX8,U,18),$P(HX8,U,19)) ; chart reviewed by and date/time
;
Q
;
KIN ; US11945 - Add parents/children (kin) to order
N HMPNOJS,HMPORKIN,I
S HMPNOJS=1 D RELATED^HMPORRPC(.HMPORKIN,IFN)
S:$D(@HMPORKIN@("parent")) ORD("parentOrderUid")=$$SETUID^HMPUTILS("order",DFN,+@HMPORKIN@("parent"))
S I="" F S I=$O(@HMPORKIN@("children",I)) Q:I="" D
. S ORD("childrenOrderUids",I)=$$SETUID^HMPUTILS("order",DFN,+@HMPORKIN@("children",I))
Q
RESULTS ; -- add ORD("results",n,"uid") list
N ORPK,ORPKG,ORDG
S ORPK=$G(^OR(100,IFN,4)),ORPKG=ORD("service"),ORDG=ORD("displayGroup")
I ORPKG="GMRC" D Q
. N HMPD,I,N,X D DOCLIST^GMRCGUIB(.HMPD,+ORPK) ; HMPD contains global references
. S N=1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("consult",DFN,+ORPK)
. S I=0 F S I=$O(HMPD(50,I)) Q:I<1 S X=$G(HMPD(50,I)) D
.. Q:'$D(@(U_$P(X,";",2)_+X_")")) ;text deleted
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("document",DFN,+X)
. Q:ORDG'="PROC"
. N HMPC D FIND^DIC(702,,"@","Q",+ORPK,,"ACON",,,"HMPC") ;CP
. S I=0 F S I=$O(HMPC("DILIST",2,I)) Q:I<1 D
.. S X=+$G(HMPC("DILIST",2,I))_";MDD(702,"
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("procedure",DFN,X)
I ORPKG="LR" D Q
. Q:$L(ORPK,";")'>3 ;no results yet, or parent order
. N SUB,IDT,CDT,ITM,HMPT,ID,T,N,LRDFN,IDX
. S SUB=$P(ORPK,";",4),IDT=$P(ORPK,";",5),CDT=9999999-IDT
. I SUB="CH" D Q
.. S ITM=+$G(ORD("oiPackageRef")) D EXPAND^LR7OU1(ITM,.HMPT)
.. S (T,N)=0 F S T=$O(HMPT(T)) Q:T<1 S ID=$O(^PXRMINDX(63,"PI",DFN,T,CDT,"")) I $L(ID) S N=N+1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("lab",DFN,$P(ID,";",2,9))
. I SUB="MI" D Q
.. S ITM="M;A;",N=0,LRDFN=$$LRDFN^HMPXGLAB(DFN) ;DE2818
.. F S ITM=$O(^PXRMINDX(63,"PI",DFN,ITM)) Q:$E(ITM,1,4)'="M;A;" I $D(^(ITM,CDT)) D
... S IDX=LRDFN_";MI;"_IDT
... F S IDX=$O(^PXRMINDX(63,"PI",DFN,ITM,CDT,IDX)) Q:IDX="" S ID=$P(IDX,";",2,99),N=N+1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("lab",DFN,ID)
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^HMPUTILS("document",DFN,SUB_";"_IDT)
. ; SUB:"AP" [AU,CY,EM,SP]
. S ORD("results",1,"uid")=$$SETUID^HMPUTILS("lab",DFN,SUB_";"_IDT)
. S ORD("results",2,"uid")=$$SETUID^HMPUTILS("document",DFN,SUB_";"_IDT)
I ORPKG["PS" D Q
. S:ORPK ORD("results",1,"uid")=$$SETUID^HMPUTILS("med",DFN,IFN)
I ORPKG="RA" D Q
. N IDT,CN S IDT=+$O(^RADPT("AO",+ORPK,DFN,0)) Q:'IDT
. S CN=0 F S CN=$O(^RADPT("AO",+ORPK,DFN,IDT,CN)) Q:CN<1 S ORD("results",CN,"uid")=$$SETUID^HMPUTILS("image",DFN,IDT_"-"_CN)
; rest should be generic (OR) orders
I ORDG="NTX" S ORD("results",1,"uid")=$$SETUID^HMPUTILS("treatment",DFN,IFN) Q
I ORDG="V/M" Q ;no link
Q
;
NTX1(IFN) ; -- extract nursing treatment order IFN into NTX("attribute")
N NTX,X
D ORX(IFN,.NTX) ;get basic order info
S NTX("orderUid")=NTX("uid")
S NTX("uid")=$$SETUID^HMPUTILS("treatment",DFN,IFN)
S X=$$VALUE^ORX8(IFN,"COMMENT") S:$L(X) NTX("instructions")=X
S X=$$VALUE^ORX8(IFN,"SCHEDULE") I X D
. D ZERO^PSS51P1(X,,,,"HMPS")
. S NTX("scheduleName")=$G(^TMP($J,"HMPS",X,.01))
. S NTX("adminTimes")=$G(^TMP($J,"HMPS",X,1))
. K ^TMP($J,"HMPS")
S NTX("lastUpdateTime")=$$EN^HMPSTMP("treatment") ;RHL 20141231
S NTX("stampTime")=NTX("lastUpdateTime") ; RHL 20141231
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("treatment",NTX("uid"),NTX("stampTime")) Q:HMPMETA=1 ;US6734,US11019
D ADD^HMPDJ("NTX","treatment")
Q
;
USER(N,ROLE,IEN,DATE) ; -- add signature/verification data
S N=+$G(N)+1
S ORD("clinicians",N,"signedDateTime")=$$JSONDT^HMPUTILS(DATE)
S ORD("clinicians",N,"role")=$G(ROLE)
Q:+$G(IEN)<1
S ORD("clinicians",N,"uid")=$$SETUID^HMPUTILS("user",,IEN)
S ORD("clinicians",N,"name")=$$GET1^DIQ(200,IEN_",",.01) ;DE2818, ICR 10060
Q
;
ORDACT(HMPDFN,ORDRNUM) ; function, if patient and order are in HMP(800000) return status code, Jan 10, 2016 US10045, US11894
N SRV S SRV=$$SRVRNO^HMPOR(HMPDFN) ; server number for patient
Q:'(SRV>0) "" ; not found, return null
Q $P($G(^HMP(800000,SRV,1,HMPDFN,1,ORDRNUM,0)),U,14) ; ORDER ACTION returned
;
TM(X) ; -- strip seconds off a FM time
N D,T,Y S D=$P(X,"."),T=$P(X,".",2)
S Y=D_$S(T:"."_$E(T,1,4),1:"")
S Y=$$JSONDT^HMPUTILS(Y)
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ01 12271 printed Nov 22, 2024@17:03:24 Page 2
HMPDJ01 ;SLC/MKB,ASMR/MBS -- Orders ;Aug 17, 2016 11:42:39
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References ICR
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; ^OR(100 5771
+8 ; ^ORA(102.4 5769
+9 ; ^ORD(100.98 873
+10 ; ^PXRMINDX 4290
+11 ; ^RADPT 2480
+12 ; ^SC 10040
+13 ; ^VA(200 10060
+14 ; DIC 2051
+15 ; DIQ 2056
+16 ; GMRCGUIB 2980
+17 ; LR7OU1 2955
+18 ; ORQ1,^TMP("ORR" 3154
+19 ; ORQ12,^TMP("ORR" 5704
+20 ; ORX8 2467
+21 ; PSS51P1 4546
+22 ;
+23 ; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
+24 QUIT
+25 ;
OR1(ID) ; -- order ID >> ^TMP("ORR",$J,ORLIST,HMPN)
+1 NEW ORDER,CHILD,HMPC
+2 DO ORX(ID,.ORDER)
+3 ;DE2818, ^OR(100) - ICR 5771
+4 SET HMPC=0
FOR
SET HMPC=$ORDER(^OR(100,ID,2,HMPC))
if HMPC<1
QUIT
Begin DoDot:1
+5 ; DE5111 begin
+6 ; check for child Order's existence, if not found, log it and quit
+7 ; HMPC is IFN
IF '$LENGTH($$GET1^DIQ(100,HMPC_",",.01))
Begin DoDot:2
+8 NEW LOGTXT
SET LOGTXT(1)=" missing child Order IFN: "_HMPC_", DFN: "_$GET(DFN,"*no DFN*")
+9 ; event type is "missing"
DO EVNTLOG^HMPDOR(.LOGTXT,"M")
End DoDot:2
QUIT
+10 ; DE5111 end
+11 KILL CHILD
DO ORX(HMPC,.CHILD)
+12 MERGE ORDER("children",HMPC)=CHILD
End DoDot:1
+13 ;BL;DE7806 If a deleted order must not build these nodes
if $DATA(ORDER)
Begin DoDot:1
+14 ;RHL 20141231
SET ORDER("lastUpdateTime")=$$EN^HMPSTMP("order")
+15 ; RHL 20141231
SET ORDER("stampTime")=ORDER("lastUpdateTime")
End DoDot:1
+16 ;US6734 - pre-compile metastamp
+17 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("order",ORDER("uid"),ORDER("stampTime"))
if HMPMETA=1
QUIT
+18 DO ADD^HMPDJ("ORDER","order")
+19 QUIT
+20 ;
ORX(IFN,ORD) ; -- extract order IFN into ORD("attribute")
+1 ;DE5111 begin
+2 ;if no IFN passed, or invalid IFN, log it and quit
+3 IF '($GET(IFN)>0)
Begin DoDot:1
+4 NEW LOGTXT
SET LOGTXT(1)=" invalid order IFN: "_$GET(IFN,"*no IFN*")_", DFN: "_$GET(DFN,"*no DFN*")
+5 ; event type is "corrupt"
DO EVNTLOG^HMPDOR(.LOGTXT,"C")
End DoDot:1
QUIT
+6 ;if Order not found for this IFN, log it and quit
+7 IF '$LENGTH($$GET1^DIQ(100,IFN_",",.01))
Begin DoDot:1
+8 NEW LOGTXT
SET LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_$GET(DFN,"*no DFN*")
+9 ; event type is "missing"
DO EVNTLOG^HMPDOR(.LOGTXT,"M")
End DoDot:1
QUIT
+10 ;DE5111 end
+11 NEW DA,HDFN,I,LOC,ORDSTAT,ORLIST,ORLST,X,X0,X8
+12 SET ORLST=$SELECT(+$GET(HMPN):HMPN-1,1:0)
if '$DATA(ORLIST)
SET ORLIST=$HOROLOG
+13 ; this modifies ^TMP("ORR",$J)
DO GET^ORQ12(IFN,ORLIST,1)
+14 SET X0=$GET(^TMP("ORR",$JOB,ORLIST,ORLST))
+15 NEW $ESTACK,$ETRAP,ERRPAT,ERRMSG
+16 SET $ETRAP="D ERRHDLR^HMPDERRH"
SET ERRPAT=DFN
+17 SET ERRMSG="A problem occurred converting record "_IFN_" for the orders domain"
+18 ;
+19 SET ORD("localId")=IFN
SET ORD("uid")=$$SETUID^HMPUTILS("order",DFN,IFN)
+20 SET X=$$OI^ORX8(+X0)
IF $LENGTH(X)
Begin DoDot:1
+21 NEW ARRAY,NAME
+22 SET ARRAY("Code")=1_U_"oi"
SET ARRAY("Name")=2
SET ARRAY("PackageRef")=3
+23 DO SPLITVAL^HMPUTILS(X,.ARRAY)
SET ORD("name")=ARRAY("Name")
+24 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
SET ORD("oi"_NAME)=$GET(ARRAY(NAME))
End DoDot:1
+25 SET ORD("displayGroup")=$PIECE(X0,U,2)
+26 SET ORD("entered")=$$JSONDT^HMPUTILS($PIECE(X0,U,3))
+27 ;US10045, DE3054
SET ORD("start")=$$JSONDT^HMPUTILS($PIECE(X0,U,4))
SET ORD("stop")=$$JSONDT^HMPUTILS($PIECE(X0,U,5))
+28 SET ORD("statusCode")="urn:va:order-status:"_$PIECE(X0,U,7)
+29 SET ORD("statusName")=$PIECE(X0,U,6)
+30 SET ORD("statusVuid")="urn:va:vuid:"_$$STS^HMPDOR($PIECE(X0,U,7))
+31 DO SETTEXT^HMPUTILS($NAME(^TMP("ORR",$JOB,ORLIST,ORLST,"TX")),$NAME(^TMP("HMPTEXT",$JOB,IFN)))
+32 MERGE ORD("content","\")=^TMP("HMPTEXT",$JOB,IFN)
+33 ; DE3504 - Jan 18, 2016, added the code for US10045 below
+34 ; US10045 - PB Dec 7, 2015 if ORDER is saved, signed, discontinued, then ORDER is unsigned
+35 SET HDFN=+$PIECE($GET(^OR(100,+IFN,0)),U,2)
+36 SET ORDSTAT=$$ORDACT(HDFN,+IFN)
IF ORDSTAT="DC"
Begin DoDot:1
+37 ; DE3777 - March 15, 2016 - Modified the statusName to "UNRELEASED" for the order to match the status
+38 ; that appears in CPRS if the ORDER was DISCONTINUED and is UNSIGNED
+39 NEW HDC,HDCRSN,HMPORACT,HPTR,HSIGN
+40 SET HDC=$ORDER(^OR(100,IFN,8,"C","DC",""))
SET HSIGN=""
if '(HDC>0)
QUIT
+41 SET HMPORACT=$GET(^OR(100,IFN,8,HDC,0))
+42 ; The 15th piece of HMPORACT is the RELEASE STATUS - '11' FOR unreleased
+43 IF $PIECE(HMPORACT,U,15)=11
SET ORD("statusName")="UNRELEASED"
SET ORD("statusCode")="urn:va:order-status:unr"
+44 if $PIECE($GET(HMPORACT),U,4)=2
SET HSIGN="*UNSIGNED*"
+45 ;Combined fixes Mar 16, 2016 DE3777 CK - PB - DE4027
SET HPTR=+$PIECE($GET(^OR(100,IFN,6)),U,4)
SET HDCRSN=$PIECE($GET(^ORD(100.03,HPTR,0)),U)
+46 ; add DC order not signed in JSON object
IF $LENGTH(HDCRSN)
SET ORD("content","\",2)=" <"_$GET(HDCRSN)_"> "_HSIGN
+47 ; DE3777 - end of changes
End DoDot:1
+48 ;
+49 SET X=$$GET1^DIQ(100,IFN_",",1,"I")
IF X
Begin DoDot:1
+50 SET ORD("providerUid")=$$SETUID^HMPUTILS("user",,+X)
+51 ;DE2818, ICR 10060
SET ORD("providerName")=$$GET1^DIQ(200,X_",",.01)
End DoDot:1
+52 SET LOC=+$$GET1^DIQ(100,IFN_",",6,"I")
SET FAC=$$FAC^HMPD(LOC)
IF LOC
Begin DoDot:1
+53 ;DE2818, ICR 10040
SET ORD("locationName")=$$GET1^DIQ(44,LOC_",",.01)
+54 SET ORD("locationUid")=$$SETUID^HMPUTILS("location",,LOC)
End DoDot:1
+55 DO FACILITY^HMPUTILS(FAC,"ORD")
+56 SET ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
+57 SET X=$$GET1^DIQ(100,IFN_",",9,"I")
if X
SET ORD("predecessor")=$$SETUID^HMPUTILS("order",DFN,+X)
+58 SET X=$$GET1^DIQ(100,IFN_",",9.1,"I")
if X
SET ORD("successor")=$$SETUID^HMPUTILS("order",DFN,+X)
+59 DO RESULTS
+60 ; US11945 - Get parent and child orders for order
+61 DO KIN
+62 ; sign/verify
+63 ;US10045 modifications to get signed, verified and reviewed datetime stamp from HMP(800000
+64 ; US11894 Dec 18, 2015 - added variables used by Order Flag and Unflag
NEW C,HMUSR,HMORIN,HMPFND,HMPUF,HMSRVR,HPROV,HX8,ORFLG,ORIFN,ORIN
+65 ; US11894 Dec 18, 2015 - Order flagged and unflagged added to JSON
Begin DoDot:1
+66 ; C = count for JSON object, HMORIN = IEN in sub-file
SET C=0
SET HMORIN=0
+67 ; if 'HMSRVR then not subscribed
SET HMSRVR=$$SRVRNO^HMPOR(HDFN)
if 'HMSRVR
QUIT
+68 ; DE3584 Feb 1, 2016 - begin
+69 ; orders not in HMP(800000) add them
IF '$DATA(^HMP(800000,HMSRVR,1,HDFN,1,IFN))
Begin DoDot:2
+70 ; HMVALS = fields to update in 800000.14
NEW HMVALS,RSLT
+71 ; get fields from ORDER file and map to HMP fields
DO ORDRVALS^HMPOR(.HMVALS,IFN)
+72 ; error setting up fields, HMVALS("ERR") will be defined
if '$ORDER(HMVALS(0))
QUIT
+73 ; (#1.01) TRACKING START
SET HMVALS(1.01)=$$NOW^XLFDT
+74 ; may want to log error if RSLT<0
DO ADDORDR^HMPOR(.RSLT,.HMVALS,IFN,HDFN)
End DoDot:2
+75 ; DE3584 Feb 1, 2016 - end
+76 FOR
SET HMORIN=$ORDER(^HMP(800000,HMSRVR,1,HDFN,1,IFN,2,HMORIN))
if 'HMORIN
QUIT
Begin DoDot:2
+77 SET C=C+1
SET HMPFND=$GET(^HMP(800000,HMSRVR,1,HDFN,1,IFN,2,HMORIN,0))
+78 SET HMPUF=$PIECE(HMPFND,U,2)
SET HMPUF=$SELECT(HMPUF="U":"Unflagged",1:"Flagged")
+79 SET ORD("orderFlags",C,"order"_HMPUF_"DateTime")=$$JSONDT^HMPUTILS($PIECE(HMPFND,U))
+80 SET HMUSR=$PIECE(HMPFND,U,3)
+81 SET ORD("orderFlags",C,"order"_HMPUF_"By")=$$GET1^DIQ(200,HMUSR_",",.01,"E")
+82 SET ORD("orderFlags",C,"order"_HMPUF_"Reason")=$PIECE(HMPFND,U,4)
End DoDot:2
End DoDot:1
+83 ;
+84 ; check for existence of order in ^HMP(800000)
IF $DATA(^HMP(800000,HMSRVR,1,HDFN,1,IFN))
Begin DoDot:1
+85 SET I=0
SET HX8=$GET(^HMP(800000,HMSRVR,1,HDFN,1,IFN,0))
SET HPROV=$PIECE(HX8,U,3)
+86 ; get signed date/time
IF HPROV'=""
DO USER(.I,"S",HPROV,$PIECE(HX8,U,4))
+87 ; order verified by a nurse get the timestamp
IF $PIECE(HX8,U,6)
DO USER(.I,"N",$PIECE(HX8,U,5),$PIECE(HX8,U,6))
+88 ; order was verified by a clerk get the timestamp
IF $PIECE(HX8,U,8)
DO USER(.I,"C",$PIECE(HX8,U,7),$PIECE(HX8,U,8))
+89 ;order was reviewed get the timestamp
IF $PIECE(HX8,U,10)
DO USER(.I,"R",$PIECE(HX8,U,9),$PIECE(HX8,U,10))
End DoDot:1
QUIT
+90 ;
+91 ; DE3504 - Jan 18, 2016, go to ORDER file to get data
+92 NEW ORACTION
+93 SET (ORACTION,I)=0
+94 FOR
SET ORACTION=$ORDER(^OR(100,IFN,8,ORACTION))
if 'ORACTION
QUIT
Begin DoDot:1
+95 ; only if order is signed
SET HX8=$GET(^OR(100,IFN,8,ORACTION,0))
IF $PIECE(HX8,U,6)
Begin DoDot:2
+96 ; signed by or provider
SET HPROV=$PIECE(HX8,U,5)
if HPROV<1
SET HPROV=$PIECE(HX8,U,3)
+97 ; date/time signed
DO USER(.I,"S",HPROV,$PIECE(HX8,U,6))
+98 ; verifying nurse and date/time
IF $PIECE(HX8,U,9)
DO USER(.I,"N",$PIECE(HX8,U,8),$PIECE(HX8,U,9))
+99 ; verifying clerk and date/time
IF $PIECE(HX8,U,11)
DO USER(.I,"C",$PIECE(HX8,U,10),$PIECE(HX8,U,11))
+100 ; chart reviewed by and date/time
IF $PIECE(HX8,U,19)
DO USER(.I,"R",$PIECE(HX8,U,18),$PIECE(HX8,U,19))
End DoDot:2
End DoDot:1
+101 ;
+102 QUIT
+103 ;
KIN ; US11945 - Add parents/children (kin) to order
+1 NEW HMPNOJS,HMPORKIN,I
+2 SET HMPNOJS=1
DO RELATED^HMPORRPC(.HMPORKIN,IFN)
+3 if $DATA(@HMPORKIN@("parent"))
SET ORD("parentOrderUid")=$$SETUID^HMPUTILS("order",DFN,+@HMPORKIN@("parent"))
+4 SET I=""
FOR
SET I=$ORDER(@HMPORKIN@("children",I))
if I=""
QUIT
Begin DoDot:1
+5 SET ORD("childrenOrderUids",I)=$$SETUID^HMPUTILS("order",DFN,+@HMPORKIN@("children",I))
End DoDot:1
+6 QUIT
RESULTS ; -- add ORD("results",n,"uid") list
+1 NEW ORPK,ORPKG,ORDG
+2 SET ORPK=$GET(^OR(100,IFN,4))
SET ORPKG=ORD("service")
SET ORDG=ORD("displayGroup")
+3 IF ORPKG="GMRC"
Begin DoDot:1
+4 ; HMPD contains global references
NEW HMPD,I,N,X
DO DOCLIST^GMRCGUIB(.HMPD,+ORPK)
+5 SET N=1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("consult",DFN,+ORPK)
+6 SET I=0
FOR
SET I=$ORDER(HMPD(50,I))
if I<1
QUIT
SET X=$GET(HMPD(50,I))
Begin DoDot:2
+7 ;text deleted
if '$DATA(@(U_$PIECE(X,";",2)_+X_")"))
QUIT
+8 SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("document",DFN,+X)
End DoDot:2
+9 if ORDG'="PROC"
QUIT
+10 ;CP
NEW HMPC
DO FIND^DIC(702,,"@","Q",+ORPK,,"ACON",,,"HMPC")
+11 SET I=0
FOR
SET I=$ORDER(HMPC("DILIST",2,I))
if I<1
QUIT
Begin DoDot:2
+12 SET X=+$GET(HMPC("DILIST",2,I))_";MDD(702,"
+13 SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("procedure",DFN,X)
End DoDot:2
End DoDot:1
QUIT
+14 IF ORPKG="LR"
Begin DoDot:1
+15 ;no results yet, or parent order
if $LENGTH(ORPK,";")'>3
QUIT
+16 NEW SUB,IDT,CDT,ITM,HMPT,ID,T,N,LRDFN,IDX
+17 SET SUB=$PIECE(ORPK,";",4)
SET IDT=$PIECE(ORPK,";",5)
SET CDT=9999999-IDT
+18 IF SUB="CH"
Begin DoDot:2
+19 SET ITM=+$GET(ORD("oiPackageRef"))
DO EXPAND^LR7OU1(ITM,.HMPT)
+20 SET (T,N)=0
FOR
SET T=$ORDER(HMPT(T))
if T<1
QUIT
SET ID=$ORDER(^PXRMINDX(63,"PI",DFN,T,CDT,""))
IF $LENGTH(ID)
SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("lab",DFN,$PIECE(ID,";",2,9))
End DoDot:2
QUIT
+21 IF SUB="MI"
Begin DoDot:2
+22 ;DE2818
SET ITM="M;A;"
SET N=0
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
+23 FOR
SET ITM=$ORDER(^PXRMINDX(63,"PI",DFN,ITM))
if $EXTRACT(ITM,1,4)'="M;A;"
QUIT
IF $DATA(^(ITM,CDT))
Begin DoDot:3
+24 SET IDX=LRDFN_";MI;"_IDT
+25 FOR
SET IDX=$ORDER(^PXRMINDX(63,"PI",DFN,ITM,CDT,IDX))
if IDX=""
QUIT
SET ID=$PIECE(IDX,";",2,99)
SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("lab",DFN,ID)
End DoDot:3
+26 SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^HMPUTILS("document",DFN,SUB_";"_IDT)
End DoDot:2
QUIT
+27 ; SUB:"AP" [AU,CY,EM,SP]
+28 SET ORD("results",1,"uid")=$$SETUID^HMPUTILS("lab",DFN,SUB_";"_IDT)
+29 SET ORD("results",2,"uid")=$$SETUID^HMPUTILS("document",DFN,SUB_";"_IDT)
End DoDot:1
QUIT
+30 IF ORPKG["PS"
Begin DoDot:1
+31 if ORPK
SET ORD("results",1,"uid")=$$SETUID^HMPUTILS("med",DFN,IFN)
End DoDot:1
QUIT
+32 IF ORPKG="RA"
Begin DoDot:1
+33 NEW IDT,CN
SET IDT=+$ORDER(^RADPT("AO",+ORPK,DFN,0))
if 'IDT
QUIT
+34 SET CN=0
FOR
SET CN=$ORDER(^RADPT("AO",+ORPK,DFN,IDT,CN))
if CN<1
QUIT
SET ORD("results",CN,"uid")=$$SETUID^HMPUTILS("image",DFN,IDT_"-"_CN)
End DoDot:1
QUIT
+35 ; rest should be generic (OR) orders
+36 IF ORDG="NTX"
SET ORD("results",1,"uid")=$$SETUID^HMPUTILS("treatment",DFN,IFN)
QUIT
+37 ;no link
IF ORDG="V/M"
QUIT
+38 QUIT
+39 ;
NTX1(IFN) ; -- extract nursing treatment order IFN into NTX("attribute")
+1 NEW NTX,X
+2 ;get basic order info
DO ORX(IFN,.NTX)
+3 SET NTX("orderUid")=NTX("uid")
+4 SET NTX("uid")=$$SETUID^HMPUTILS("treatment",DFN,IFN)
+5 SET X=$$VALUE^ORX8(IFN,"COMMENT")
if $LENGTH(X)
SET NTX("instructions")=X
+6 SET X=$$VALUE^ORX8(IFN,"SCHEDULE")
IF X
Begin DoDot:1
+7 DO ZERO^PSS51P1(X,,,,"HMPS")
+8 SET NTX("scheduleName")=$GET(^TMP($JOB,"HMPS",X,.01))
+9 SET NTX("adminTimes")=$GET(^TMP($JOB,"HMPS",X,1))
+10 KILL ^TMP($JOB,"HMPS")
End DoDot:1
+11 ;RHL 20141231
SET NTX("lastUpdateTime")=$$EN^HMPSTMP("treatment")
+12 ; RHL 20141231
SET NTX("stampTime")=NTX("lastUpdateTime")
+13 ;US6734 - pre-compile metastamp
+14 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("treatment",NTX("uid"),NTX("stampTime"))
if HMPMETA=1
QUIT
+15 DO ADD^HMPDJ("NTX","treatment")
+16 QUIT
+17 ;
USER(N,ROLE,IEN,DATE) ; -- add signature/verification data
+1 SET N=+$GET(N)+1
+2 SET ORD("clinicians",N,"signedDateTime")=$$JSONDT^HMPUTILS(DATE)
+3 SET ORD("clinicians",N,"role")=$GET(ROLE)
+4 if +$GET(IEN)<1
QUIT
+5 SET ORD("clinicians",N,"uid")=$$SETUID^HMPUTILS("user",,IEN)
+6 ;DE2818, ICR 10060
SET ORD("clinicians",N,"name")=$$GET1^DIQ(200,IEN_",",.01)
+7 QUIT
+8 ;
ORDACT(HMPDFN,ORDRNUM) ; function, if patient and order are in HMP(800000) return status code, Jan 10, 2016 US10045, US11894
+1 ; server number for patient
NEW SRV
SET SRV=$$SRVRNO^HMPOR(HMPDFN)
+2 ; not found, return null
if '(SRV>0)
QUIT ""
+3 ; ORDER ACTION returned
QUIT $PIECE($GET(^HMP(800000,SRV,1,HMPDFN,1,ORDRNUM,0)),U,14)
+4 ;
TM(X) ; -- strip seconds off a FM time
+1 NEW D,T,Y
SET D=$PIECE(X,".")
SET T=$PIECE(X,".",2)
+2 SET Y=D_$SELECT(T:"."_$EXTRACT(T,1,4),1:"")
+3 SET Y=$$JSONDT^HMPUTILS(Y)
+4 QUIT Y
+5 ;
