VPRDOR ;SLC/MKB -- Orders extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,4,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^OR(100) 5771
; ^ORA(102.4) 5769
; ^ORD(100.98) 873
; ^ORD(101.43) 2843
; ^SC 10040
; ^VA(200) 10060
; DIQ 2056
; ORQ1,^TMP("ORR",$J) 3154
; ORQ12,^TMP("ORGOTIT",$J) 5704
; ORX8 2467,3071
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's orders
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
N ORLIST,ORDG,ORFLG,ORIGVIEW,ORACT,ORDER,VPRN,VPRITM,VPRCNT
;
; get one order
I $G(IFN) D G ENQ
. N ORLST S ORLST=0,ORLIST=$H
. S:$P(IFN,";",2)'>1 ORIGVIEW=2 ;force orig order text
. D GET^ORQ12(+IFN,ORLIST,1,$P(IFN,";",2)) S VPRN=1
. D EN1(VPRN,.VPRITM),XML(.VPRITM)
. K ^TMP("ORGOTIT",$J)
;
; get [all] orders
S ORDG=$G(FILTER("group"),"ALL"),ORDG=+$O(^ORD(100.98,"B",ORDG,0))
S ORFLG=+$G(FILTER("view"),6) ;default = Released Orders
S ORACT=$S("^2^8^9^10^11^13^14^20^21^"[(U_ORFLG_U):1,1:0)
I 'ORACT S ORIGVIEW=2 ;get original view of order unless action req'd
D EN^ORQ1(DFN_";DPT(",ORDG,ORFLG,,BEG,END,1,1) S VPRCNT=0
S VPRN=0 F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ORDER=$G(^(VPRN)) D Q:VPRCNT'<MAX
. I $P($P(ORDER,U),";",2)>1,'$G(ORACT) Q ;skip order actions
. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
ENQ ; end
K ^TMP("ORR",$J),^TMP("VPRTEXT",$J)
Q
;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
; from EN: expects ^TMP("ORR",$J,ORLIST,VPRN)
N X0,X8,IFN,OI,LOC,PKG,ORPK,X,DA
K ORD,^TMP("VPRTEXT",$J)
S X0=$G(^TMP("ORR",$J,ORLIST,NUM)),IFN=$P(X0,U)
S ORD("id")=IFN,OI=$$OI^ORX8(+IFN),ORD("name")=$P(OI,U,1,2)
S ORD("codingSystem")=$P($G(^ORD(101.43,+OI,0)),U,3,4)
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("VPRTEXT",$J,IFN)=^TMP("ORR",$J,ORLIST,VPRN,"TX")
S ORD("content")=$NA(^TMP("VPRTEXT",$J,IFN))
S X=$$GET1^DIQ(100,+IFN_",",6),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)),ORD("location")=LOC_U_X
S ORD("facility")=$$FAC^VPRD(LOC)
S PKG=$$GET1^DIQ(100,+IFN_",","12:1"),ORD("service")=PKG
S X=$P(X0,U,2),X=$S($L(X):+$O(^ORD(100.98,"B",X,0)),1:0)
S:X ORD("type")=$P($G(^ORD(100.98,X,0)),U,2)
S ORPK=$$PKGID^ORX8(+IFN)
S X=$S(PKG?1"PS".E:+IFN,1:ORPK) ;order#(PS) or 4-node
S ORD("resultID")=$S(PKG="GMRC":+X,1:X) ;strip trailing string
S:PKG?1"PS".E ORD("vuid")=$$VUID^VPRDPS(+IFN)
I PKG="LR" D
. N LNC S LNC=$$LOINC^VPRDLR(DFN,ORPK,+$P(OI,U,3)) Q:'LNC
. S ORD("codingSystem")=LNC_"^LNC"
. S ORD("vuid")=$$VUID^VPRD(+LNC,95.3)
ENA ; order [NEW] action info
S DA=$P(IFN,";",2) S:DA<1 DA=1
S X8=$G(^OR(100,+IFN,8,DA,0)),X=$P(X8,U,3)
S:X ORD("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S ORD("signatureStatus")=$$EXTERNAL^DILFD(100.008,4,,$P(X8,U,4))
S X=$P(X8,U,6) S:X ORD("signed")=X S X=$P(X8,U,5)
S:X ORD("signer")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S X=$P(X8,U,16) S:X ORD("released")=X
I "dca"[$E(ORD("status"),1,2) D ;discontinued
. N DC,X6 S X6=$G(^OR(100,+IFN,6))
. S DC=$P(X6,U,3),X=+$P(X6,U,2) Q:DC<1
. S DC=DC_U_$S(X:X_U_$P($G(^VA(200,X,0)),U),1:U)
. S X=$P(X6,U,5) I X="" S X=$$EXTERNAL^DILFD(100,64,,$P(X6,U,4))
. S ORD("discontinued")=DC_$S($L(X):U_X,1:"")
; acknowledgements
S DA=0 F S DA=$O(^ORA(102.4,"B",+IFN,DA)) Q:DA<1 D
. 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^VPRD(I,100.01)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(ORD) ; -- Return patient data as XML in @VPR@(n)
; as <element code='123' displayName='ABC' />
N ATT,X,Y,I,NAMES
D ADD("<order>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(ORD(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S NAMES=$$LABELS(ATT)
. 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^VPRD(@X@(I)) D ADD(Y)
.. D ADD("</content>")
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</order>")
Q
;
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^VPRD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
;
LABELS(X) ; -- return string of attribute labels for element X
N Y S Y="code^name"
I X?1"ack".E S Y=Y_"^date"
I X="status" S Y=Y_"^vuid"
I X="provider"!(X="signer") S Y=Y_U_$$PROVTAGS^VPRD
I X="discontinued" S Y="date^by^byName^reason"
S Y=Y_"^Z"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDOR 5657 printed Oct 16, 2024@18:45:26 Page 2
VPRDOR ;SLC/MKB -- Orders extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^OR(100) 5771
+7 ; ^ORA(102.4) 5769
+8 ; ^ORD(100.98) 873
+9 ; ^ORD(101.43) 2843
+10 ; ^SC 10040
+11 ; ^VA(200) 10060
+12 ; DIQ 2056
+13 ; ORQ1,^TMP("ORR",$J) 3154
+14 ; ORQ12,^TMP("ORGOTIT",$J) 5704
+15 ; ORX8 2467,3071
+16 ;
+17 ; ------------ Get data from VistA ------------
+18 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's orders
+1 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+2 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+3 NEW ORLIST,ORDG,ORFLG,ORIGVIEW,ORACT,ORDER,VPRN,VPRITM,VPRCNT
+4 ;
+5 ; get one order
+6 IF $GET(IFN)
Begin DoDot:1
+7 NEW ORLST
SET ORLST=0
SET ORLIST=$HOROLOG
+8 ;force orig order text
if $PIECE(IFN,";",2)'>1
SET ORIGVIEW=2
+9 DO GET^ORQ12(+IFN,ORLIST,1,$PIECE(IFN,";",2))
SET VPRN=1
+10 DO EN1(VPRN,.VPRITM)
DO XML(.VPRITM)
+11 KILL ^TMP("ORGOTIT",$JOB)
End DoDot:1
GOTO ENQ
+12 ;
+13 ; get [all] orders
+14 SET ORDG=$GET(FILTER("group"),"ALL")
SET ORDG=+$ORDER(^ORD(100.98,"B",ORDG,0))
+15 ;default = Released Orders
SET ORFLG=+$GET(FILTER("view"),6)
+16 SET ORACT=$SELECT("^2^8^9^10^11^13^14^20^21^"[(U_ORFLG_U):1,1:0)
+17 ;get original view of order unless action req'd
IF 'ORACT
SET ORIGVIEW=2
+18 DO EN^ORQ1(DFN_";DPT(",ORDG,ORFLG,,BEG,END,1,1)
SET VPRCNT=0
+19 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ORDER=$GET(^(VPRN))
Begin DoDot:1
+20 ;skip order actions
IF $PIECE($PIECE(ORDER,U),";",2)>1
IF '$GET(ORACT)
QUIT
+21 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+22 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
ENQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("VPRTEXT",$JOB)
+2 QUIT
+3 ;
EN1(NUM,ORD) ; -- return an order in ORD("attribute")=value
+1 ; from EN: expects ^TMP("ORR",$J,ORLIST,VPRN)
+2 NEW X0,X8,IFN,OI,LOC,PKG,ORPK,X,DA
+3 KILL ORD,^TMP("VPRTEXT",$JOB)
+4 SET X0=$GET(^TMP("ORR",$JOB,ORLIST,NUM))
SET IFN=$PIECE(X0,U)
+5 SET ORD("id")=IFN
SET OI=$$OI^ORX8(+IFN)
SET ORD("name")=$PIECE(OI,U,1,2)
+6 SET ORD("codingSystem")=$PIECE($GET(^ORD(101.43,+OI,0)),U,3,4)
+7 SET ORD("group")=$PIECE(X0,U,2)
SET ORD("entered")=$PIECE(X0,U,3)
+8 SET ORD("start")=$PIECE(X0,U,4)
SET ORD("stop")=$PIECE(X0,U,5)
+9 SET ORD("status")=$PIECE(X0,U,7)_U_$PIECE(X0,U,6)_U_$$STS($PIECE(X0,U,7))
+10 MERGE ^TMP("VPRTEXT",$JOB,IFN)=^TMP("ORR",$JOB,ORLIST,VPRN,"TX")
+11 SET ORD("content")=$NAME(^TMP("VPRTEXT",$JOB,IFN))
+12 SET X=$$GET1^DIQ(100,+IFN_",",6)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+13 SET LOC=+$ORDER(^SC("B",X,0))
SET ORD("location")=LOC_U_X
End DoDot:1
+14 SET ORD("facility")=$$FAC^VPRD(LOC)
+15 SET PKG=$$GET1^DIQ(100,+IFN_",","12:1")
SET ORD("service")=PKG
+16 SET X=$PIECE(X0,U,2)
SET X=$SELECT($LENGTH(X):+$ORDER(^ORD(100.98,"B",X,0)),1:0)
+17 if X
SET ORD("type")=$PIECE($GET(^ORD(100.98,X,0)),U,2)
+18 SET ORPK=$$PKGID^ORX8(+IFN)
+19 ;order#(PS) or 4-node
SET X=$SELECT(PKG?1"PS".E:+IFN,1:ORPK)
+20 ;strip trailing string
SET ORD("resultID")=$SELECT(PKG="GMRC":+X,1:X)
+21 if PKG?1"PS".E
SET ORD("vuid")=$$VUID^VPRDPS(+IFN)
+22 IF PKG="LR"
Begin DoDot:1
+23 NEW LNC
SET LNC=$$LOINC^VPRDLR(DFN,ORPK,+$PIECE(OI,U,3))
if 'LNC
QUIT
+24 SET ORD("codingSystem")=LNC_"^LNC"
+25 SET ORD("vuid")=$$VUID^VPRD(+LNC,95.3)
End DoDot:1
ENA ; order [NEW] action info
+1 SET DA=$PIECE(IFN,";",2)
if DA<1
SET DA=1
+2 SET X8=$GET(^OR(100,+IFN,8,DA,0))
SET X=$PIECE(X8,U,3)
+3 if X
SET ORD("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+4 SET ORD("signatureStatus")=$$EXTERNAL^DILFD(100.008,4,,$PIECE(X8,U,4))
+5 SET X=$PIECE(X8,U,6)
if X
SET ORD("signed")=X
SET X=$PIECE(X8,U,5)
+6 if X
SET ORD("signer")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
+7 SET X=$PIECE(X8,U,16)
if X
SET ORD("released")=X
+8 ;discontinued
IF "dca"[$EXTRACT(ORD("status"),1,2)
Begin DoDot:1
+9 NEW DC,X6
SET X6=$GET(^OR(100,+IFN,6))
+10 SET DC=$PIECE(X6,U,3)
SET X=+$PIECE(X6,U,2)
if DC<1
QUIT
+11 SET DC=DC_U_$SELECT(X:X_U_$PIECE($GET(^VA(200,X,0)),U),1:U)
+12 SET X=$PIECE(X6,U,5)
IF X=""
SET X=$$EXTERNAL^DILFD(100,64,,$PIECE(X6,U,4))
+13 SET ORD("discontinued")=DC_$SELECT($LENGTH(X):U_X,1:"")
End DoDot:1
+14 ; acknowledgements
+15 SET DA=0
FOR
SET DA=$ORDER(^ORA(102.4,"B",+IFN,DA))
if DA<1
QUIT
Begin DoDot:1
+16 ;stub - not ack'd
SET X0=$GET(^ORA(102.4,DA,0))
if '$PIECE(X0,U,3)
QUIT
+17 SET X=+$PIECE(X0,U,2)
SET X=$SELECT(X:X_U_$PIECE($GET(^VA(200,X,0)),U),1:U)
+18 SET ORD("acknowledgement",DA)=X_U_$PIECE(X0,U,3)
End DoDot:1
+19 QUIT
+20 ;
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^VPRD(I,100.01)
+5 QUIT Y
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(ORD) ; -- Return patient data as XML in @VPR@(n)
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,I,NAMES
+3 DO ADD("<order>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(ORD(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET NAMES=$$LABELS(ATT)
+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^VPRD(@X@(I))
DO ADD(Y)
+16 DO ADD("</content>")
End DoDot:2
SET Y=""
QUIT
+17 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(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 ;
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^VPRD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
+4 ;
LABELS(X) ; -- return string of attribute labels for element X
+1 NEW Y
SET Y="code^name"
+2 IF X?1"ack".E
SET Y=Y_"^date"
+3 IF X="status"
SET Y=Y_"^vuid"
+4 IF X="provider"!(X="signer")
SET Y=Y_U_$$PROVTAGS^VPRD
+5 IF X="discontinued"
SET Y="date^by^byName^reason"
+6 SET Y=Y_"^Z"
+7 QUIT Y
