HMPDOR ;SLC/MKB,ASMR/RRB,BL - Orders extract;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 DBIA#
; ------------------- -----
; ^ORA(102.4) 5769
; ^SC 10040
; ^VA(200) 10060
; DIQ 2056
; ORQ1,^TMP("ORR",$J) 3154
; ORQ12,^TMP("ORGOTIT",$J) 5704
; ORX8 2467
Q
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's orders
S DFN=+$G(DFN)
; DE5111 begin
; invalid DFN, log event as type "missing" and quit
I '(DFN>0) D Q
. N LOGTXT S LOGTXT(1)=" invalid DFN: "_DFN D EVNTLOG(.LOGTXT,"M")
; DE5111 end
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
N ORLIST,HMPN,HMPITM,HMPCNT
;
; get one order
I $G(IFN) D G ENQ
. ; DE5111 begin
. ; check for existence of Order, log it if missing
. I '$L($$GET1^DIQ(100,IFN_",",.01)) D Q ;log event as type "missing" and quit
.. N LOGTXT S LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_DFN D EVNTLOG(.LOGTXT,"M")
. ; DE5111 end
. N ORLST S ORLST=0,ORLIST=$H
. D GET^ORQ12(IFN,ORLIST,1) S HMPN=1
. D EN1(HMPN,.HMPITM) ;DE5111, D XML(.HMPITM) call removed
. K ^TMP("ORGOTIT",$J)
;
; get all orders
D EN^ORQ1(DFN_";DPT(",,6,,BEG,END,1) S HMPCNT=0
S HMPN=0 F S HMPN=$O(^TMP("ORR",$J,ORLIST,HMPN)) Q:HMPN<1 D Q:HMPCNT'<MAX
. K HMPITM D EN1(HMPN,.HMPITM) Q:'$D(HMPITM)
. ;DE5111, this code removed: D XML(.HMPITM) S HMPCNT=HMPCNT+1
ENQ ; end
K ^TMP("ORR",$J),^TMP("HMPTEXT",$J)
Q
;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
; from EN: expects ^TMP("ORR",$J,ORLIST,HMPN)
N X0,IFN,LOC,X,DA
K ORD,^TMP("HMPTEXT",$J)
S X0=$G(^TMP("ORR",$J,ORLIST,NUM)),IFN=+X0
;DE5111 begin
I '(IFN>0) D Q ;if invalid IFN from ^TMP("ORR",$J), log it and quit
. N LOGTXT S LOGTXT(1)=" invalid IFN: "_IFN_", DFN: "_$G(DFN,"*no DFN*")
. D EVNTLOG(.LOGTXT,"C") ; event type is "corrupt"
;
I '$L($$GET1^DIQ(100,IFN_",",.01)) D Q ;if no Order found for this IFN, log it and quit
. N LOGTXT S LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_$G(DFN,"*no DFN*")
. D EVNTLOG(.LOGTXT,"M") ; event type is "missing"
;DE5111 end
S ORD("id")=IFN,ORD("name")=$$OI^ORX8(+X0)
S ORD("group")=$P(X0,U,2),ORD("entered")=$P(X0,U,3)
S ORD("start")=$P(X0,U,4),ORD("stop")=$P(X0,U,5)
S ORD("status")=$P(X0,U,7)_U_$P(X0,U,6)_U_$$STS($P(X0,U,7))
M ^TMP("HMPTEXT",$J,IFN)=^TMP("ORR",$J,ORLIST,HMPN,"TX")
S ORD("content")=$NA(^TMP("HMPTEXT",$J,IFN))
S X=$$GET1^DIQ(100,IFN_",",1,"I"),ORD("provider")=X_U_$P($G(^VA(200,+X,0)),U) ;ICR 10060 DE2818 ASF 11/10/15
S X=$$GET1^DIQ(100,IFN_",",6),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)),ORD("location")=LOC_U_X ;ICR 10040 DE2818 ASF 11/9/15
S ORD("facility")=$$FAC^HMPD(LOC)
S ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
; acknowledgements
S DA=0 F S DA=$O(^ORA(102.4,"B",+IFN,DA)) Q:DA<1 D ;ICR 5769 DE2818 ASF 11/9/15
. S X0=$G(^ORA(102.4,DA,0)) Q:'$P(X0,U,3) ;stub - not ack'd
. S X=+$P(X0,U,2),X=$S(X:X_U_$P($G(^VA(200,X,0)),U),1:U)
. S ORD("acknowledgement",DA)=X_U_$P(X0,U,3)
Q
;
STS(X) ; -- return VUID for status abbreviation X
N Y,I,STS
S STS="dc^comp^hold^flag^pend^actv^exp^schd^part^dlay^unr^dc/e^canc^laps^rnew^none"
F I=1:1:16 Q:$P(STS,U,I)=X
S Y=$$VUID^HMPD(I,100.01)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(ORD) ; -- Return patient data as XML in @HMP@(n), DE5111, calls in this routine to here disabled
; as <element code='123' displayName='ABC' />
N ATT,X,Y,I,NAMES
D ADD("<order>") S HMPTOTL=$G(HMPTOTL)+1
S ATT="" F S ATT=$O(ORD(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S NAMES="code^name^"_$S(ATT?1"ack".E:"date",1:"vuid")_"^Z"
. I ATT?1"ack".E D S Y="" Q
.. D ADD("<"_ATT_"s>")
.. S I=0 F S I=$O(ORD(ATT,I)) Q:I<1 D
... S X=$G(ORD(ATT,I))
... S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
.. D ADD("</"_ATT_"s>")
. S X=$G(ORD(ATT)),Y="" Q:'$L(X)
. I ATT="content" D S Y="" Q ;text
.. S Y="<content xml:space='preserve'>" D ADD(Y)
.. S I=0 F S I=$O(@X@(I)) Q:I<1 S Y=$$ESC^HMPD(@X@(I)) D ADD(Y)
.. D ADD("</content>")
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</order>")
Q
;DE5111, the XML subroutine may be removed if not needed, 11 August 2016
LOOP() ; -- build sub-items string from NAMES and X
N STR,P,TAG S STR=""
F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
;
;DE5111 begin
EVNTLOG(ENVNTXT,EVNTYP) ; log information in HMP EVENT, 10 August 2016
;EVNTXT - text to be placed into log, passed by reference
;EVNTYP - type of event, optional - dafaults to "other" in $$NWNTRY^HMPLOG
N J,LNCNT,LOGTXT,STKINFO
D STK2TXT^HMPLOG(.STKINFO) ; retrieve $stack info
S J=0,LNCNT=1 F J=$O(ENVNTXT(J)) Q:'J S LNCNT=LNCNT+1,LOGTXT(LNCNT)=ENVNTXT(J) ; save text passed in
S LNCNT=LNCNT+1,LOGTXT(LNCNT)=" " ;skip line before stack
S LNCNT=LNCNT+1,LOGTXT(LNCNT)=" code from $stack: "
S J=0 F S J=$O(STKINFO(J)) Q:'J S LNCNT=LNCNT+1,LOGTXT(LNCNT)=STKINFO(J)
S LNCNT=LNCNT+1,LOGTXT(LNCNT)=" " ; blank line following word-processing text, $$NWNTRY^HMPLOG appends text to end
S J=$$NWNTRY^HMPLOG($$NOW^XLFDT,$G(EVNTYP),.LOGTXT) ; log event, new entry IEN in J, not needed
;DE5111 end
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDOR 5663 printed Sep 23, 2025@19:29:45 Page 2
HMPDOR ;SLC/MKB,ASMR/RRB,BL - Orders extract;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 DBIA#
+5 ; ------------------- -----
+6 ; ^ORA(102.4) 5769
+7 ; ^SC 10040
+8 ; ^VA(200) 10060
+9 ; DIQ 2056
+10 ; ORQ1,^TMP("ORR",$J) 3154
+11 ; ORQ12,^TMP("ORGOTIT",$J) 5704
+12 ; ORX8 2467
+13 QUIT
+14 ; ------------ Get data from VistA ------------
+15 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's orders
+1 SET DFN=+$GET(DFN)
+2 ; DE5111 begin
+3 ; invalid DFN, log event as type "missing" and quit
+4 IF '(DFN>0)
Begin DoDot:1
+5 NEW LOGTXT
SET LOGTXT(1)=" invalid DFN: "_DFN
DO EVNTLOG(.LOGTXT,"M")
End DoDot:1
QUIT
+6 ; DE5111 end
+7 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+8 NEW ORLIST,HMPN,HMPITM,HMPCNT
+9 ;
+10 ; get one order
+11 IF $GET(IFN)
Begin DoDot:1
+12 ; DE5111 begin
+13 ; check for existence of Order, log it if missing
+14 ;log event as type "missing" and quit
IF '$LENGTH($$GET1^DIQ(100,IFN_",",.01))
Begin DoDot:2
+15 NEW LOGTXT
SET LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_DFN
DO EVNTLOG(.LOGTXT,"M")
End DoDot:2
QUIT
+16 ; DE5111 end
+17 NEW ORLST
SET ORLST=0
SET ORLIST=$HOROLOG
+18 DO GET^ORQ12(IFN,ORLIST,1)
SET HMPN=1
+19 ;DE5111, D XML(.HMPITM) call removed
DO EN1(HMPN,.HMPITM)
+20 KILL ^TMP("ORGOTIT",$JOB)
End DoDot:1
GOTO ENQ
+21 ;
+22 ; get all orders
+23 DO EN^ORQ1(DFN_";DPT(",,6,,BEG,END,1)
SET HMPCNT=0
+24 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("ORR",$JOB,ORLIST,HMPN))
if HMPN<1
QUIT
Begin DoDot:1
+25 KILL HMPITM
DO EN1(HMPN,.HMPITM)
if '$DATA(HMPITM)
QUIT
+26 ;DE5111, this code removed: D XML(.HMPITM) S HMPCNT=HMPCNT+1
End DoDot:1
if HMPCNT'<MAX
QUIT
ENQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("HMPTEXT",$JOB)
+2 QUIT
+3 ;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
+1 ; from EN: expects ^TMP("ORR",$J,ORLIST,HMPN)
+2 NEW X0,IFN,LOC,X,DA
+3 KILL ORD,^TMP("HMPTEXT",$JOB)
+4 SET X0=$GET(^TMP("ORR",$JOB,ORLIST,NUM))
SET IFN=+X0
+5 ;DE5111 begin
+6 ;if invalid IFN from ^TMP("ORR",$J), log it and quit
IF '(IFN>0)
Begin DoDot:1
+7 NEW LOGTXT
SET LOGTXT(1)=" invalid IFN: "_IFN_", DFN: "_$GET(DFN,"*no DFN*")
+8 ; event type is "corrupt"
DO EVNTLOG(.LOGTXT,"C")
End DoDot:1
QUIT
+9 ;
+10 ;if no Order found for this IFN, log it and quit
IF '$LENGTH($$GET1^DIQ(100,IFN_",",.01))
Begin DoDot:1
+11 NEW LOGTXT
SET LOGTXT(1)=" missing order IFN: "_IFN_", DFN: "_$GET(DFN,"*no DFN*")
+12 ; event type is "missing"
DO EVNTLOG(.LOGTXT,"M")
End DoDot:1
QUIT
+13 ;DE5111 end
+14 SET ORD("id")=IFN
SET ORD("name")=$$OI^ORX8(+X0)
+15 SET ORD("group")=$PIECE(X0,U,2)
SET ORD("entered")=$PIECE(X0,U,3)
+16 SET ORD("start")=$PIECE(X0,U,4)
SET ORD("stop")=$PIECE(X0,U,5)
+17 SET ORD("status")=$PIECE(X0,U,7)_U_$PIECE(X0,U,6)_U_$$STS($PIECE(X0,U,7))
+18 MERGE ^TMP("HMPTEXT",$JOB,IFN)=^TMP("ORR",$JOB,ORLIST,HMPN,"TX")
+19 SET ORD("content")=$NAME(^TMP("HMPTEXT",$JOB,IFN))
+20 ;ICR 10060 DE2818 ASF 11/10/15
SET X=$$GET1^DIQ(100,IFN_",",1,"I")
SET ORD("provider")=X_U_$PIECE($GET(^VA(200,+X,0)),U)
+21 SET X=$$GET1^DIQ(100,IFN_",",6)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+22 ;ICR 10040 DE2818 ASF 11/9/15
SET LOC=+$ORDER(^SC("B",X,0))
SET ORD("location")=LOC_U_X
End DoDot:1
+23 SET ORD("facility")=$$FAC^HMPD(LOC)
+24 SET ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
+25 ; acknowledgements
+26 ;ICR 5769 DE2818 ASF 11/9/15
SET DA=0
FOR
SET DA=$ORDER(^ORA(102.4,"B",+IFN,DA))
if DA<1
QUIT
Begin DoDot:1
+27 ;stub - not ack'd
SET X0=$GET(^ORA(102.4,DA,0))
if '$PIECE(X0,U,3)
QUIT
+28 SET X=+$PIECE(X0,U,2)
SET X=$SELECT(X:X_U_$PIECE($GET(^VA(200,X,0)),U),1:U)
+29 SET ORD("acknowledgement",DA)=X_U_$PIECE(X0,U,3)
End DoDot:1
+30 QUIT
+31 ;
STS(X) ; -- return VUID for status abbreviation X
+1 NEW Y,I,STS
+2 SET STS="dc^comp^hold^flag^pend^actv^exp^schd^part^dlay^unr^dc/e^canc^laps^rnew^none"
+3 FOR I=1:1:16
if $PIECE(STS,U,I)=X
QUIT
+4 SET Y=$$VUID^HMPD(I,100.01)
+5 QUIT Y
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(ORD) ; -- Return patient data as XML in @HMP@(n), DE5111, calls in this routine to here disabled
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,I,NAMES
+3 DO ADD("<order>")
SET HMPTOTL=$GET(HMPTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(ORD(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET NAMES="code^name^"_$SELECT(ATT?1"ack".E:"date",1:"vuid")_"^Z"
+6 IF ATT?1"ack".E
Begin DoDot:2
+7 DO ADD("<"_ATT_"s>")
+8 SET I=0
FOR
SET I=$ORDER(ORD(ATT,I))
if I<1
QUIT
Begin DoDot:3
+9 SET X=$GET(ORD(ATT,I))
+10 SET Y="<"_ATT_" "_$$LOOP_"/>"
DO ADD(Y)
End DoDot:3
+11 DO ADD("</"_ATT_"s>")
End DoDot:2
SET Y=""
QUIT
+12 SET X=$GET(ORD(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+13 ;text
IF ATT="content"
Begin DoDot:2
+14 SET Y="<content xml:space='preserve'>"
DO ADD(Y)
+15 SET I=0
FOR
SET I=$ORDER(@X@(I))
if I<1
QUIT
SET Y=$$ESC^HMPD(@X@(I))
DO ADD(Y)
+16 DO ADD("</content>")
End DoDot:2
SET Y=""
QUIT
+17 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />"
QUIT
+18 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+19 DO ADD("</order>")
+20 QUIT
+21 ;DE5111, the XML subroutine may be removed if not needed, 11 August 2016
LOOP() ; -- build sub-items string from NAMES and X
+1 NEW STR,P,TAG
SET STR=""
+2 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET STR=STR_TAG_"='"_$$ESC^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
+4 ;
+5 ;DE5111 begin
EVNTLOG(ENVNTXT,EVNTYP) ; log information in HMP EVENT, 10 August 2016
+1 ;EVNTXT - text to be placed into log, passed by reference
+2 ;EVNTYP - type of event, optional - dafaults to "other" in $$NWNTRY^HMPLOG
+3 NEW J,LNCNT,LOGTXT,STKINFO
+4 ; retrieve $stack info
DO STK2TXT^HMPLOG(.STKINFO)
+5 ; save text passed in
SET J=0
SET LNCNT=1
FOR J=$ORDER(ENVNTXT(J))
if 'J
QUIT
SET LNCNT=LNCNT+1
SET LOGTXT(LNCNT)=ENVNTXT(J)
+6 ;skip line before stack
SET LNCNT=LNCNT+1
SET LOGTXT(LNCNT)=" "
+7 SET LNCNT=LNCNT+1
SET LOGTXT(LNCNT)=" code from $stack: "
+8 SET J=0
FOR
SET J=$ORDER(STKINFO(J))
if 'J
QUIT
SET LNCNT=LNCNT+1
SET LOGTXT(LNCNT)=STKINFO(J)
+9 ; blank line following word-processing text, $$NWNTRY^HMPLOG appends text to end
SET LNCNT=LNCNT+1
SET LOGTXT(LNCNT)=" "
+10 ; log event, new entry IEN in J, not needed
SET J=$$NWNTRY^HMPLOG($$NOW^XLFDT,$GET(EVNTYP),.LOGTXT)
+11 ;DE5111 end
