VPRDJ01 ;SLC/MKB -- Orders ;6/25/12 16:11
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^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, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
;
OR1(ID) ; -- order ID >> ^TMP("ORR",$J,ORLIST,VPRN)
N ORDER,CHILD,VPRC
D ORX(ID,.ORDER)
S VPRC=0 F S VPRC=$O(^OR(100,ID,2,VPRC)) Q:VPRC<1 D
. K CHILD D ORX(VPRC,.CHILD)
. M ORDER("children",VPRC)=CHILD
D ADD^VPRDJ("ORDER","order")
Q
ORX(IFN,ORD) ; -- extract order IFN into ORD("attribute")
N ORLIST,ORLST,X0,X8,LOC,X,I,DA
S ORLST=$S(+$G(VPRN):VPRN-1,1:0) S:'$D(ORLIST) ORLIST=$H
D GET^ORQ12(IFN,ORLIST,1)
S X0=$G(^TMP("ORR",$J,ORLIST,ORLST))
;
S ORD("localId")=IFN,ORD("uid")=$$SETUID^VPRUTILS("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^VPRUTILS(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^VPRUTILS($P(X0,U,3))
S ORD("start")=$$TM($P(X0,U,4)),ORD("stop")=$$TM($P(X0,U,5))
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^VPRDOR($P(X0,U,7))
D SETTEXT^VPRUTILS($NA(^TMP("ORR",$J,ORLIST,ORLST,"TX")),$NA(^TMP("VPRTEXT",$J,IFN)))
M ORD("content","\")=^TMP("VPRTEXT",$J,IFN)
S X=$$GET1^DIQ(100,IFN_",",1,"I") I X D
. S ORD("providerUid")=$$SETUID^VPRUTILS("user",,+X)
. S ORD("providerName")=$P($G(^VA(200,+X,0)),U)
S LOC=+$$GET1^DIQ(100,IFN_",",6,"I"),FAC=$$FAC^VPRD(LOC) I LOC D
. S ORD("locationName")=$P($G(^SC(LOC,0)),U)
. S ORD("locationUid")=$$SETUID^VPRUTILS("location",,LOC)
D FACILITY^VPRUTILS(FAC,"ORD")
S ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
S X=$$GET1^DIQ(100,IFN_",",9,"I") S:X ORD("predecessor")=$$SETUID^VPRUTILS("order",DFN,+X)
S X=$$GET1^DIQ(100,IFN_",",9.1,"I") S:X ORD("successor")=$$SETUID^VPRUTILS("order",DFN,+X)
D RESULTS
; sign/verify
S X8=$G(^OR(100,IFN,8,1,0)),I=0 I $P(X8,U,6) D ;signed
. N PROV S PROV=$P(X8,U,5) S:PROV<1 PROV=$P(X8,U,3) ;if on chart,
. D USER(.I,"S",PROV,$P(X8,U,6)) ; use provider
I $P(X8,U,9) D USER(.I,"N",$P(X8,U,8),$P(X8,U,9)) ;nurse
I $P(X8,U,11) D USER(.I,"C",$P(X8,U,10),$P(X8,U,11)) ;clerk
I $P(X8,U,19) D USER(.I,"R",$P(X8,U,18),$P(X8,U,19)) ;chart review
Q
; 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
;
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 VPRD,I,N,X D DOCLIST^GMRCGUIB(.VPRD,+ORPK)
. S N=1,ORD("results",N,"uid")=$$SETUID^VPRUTILS("consult",DFN,+ORPK)
. S I=0 F S I=$O(VPRD(50,I)) Q:I<1 S X=$G(VPRD(50,I)) D
.. Q:'$D(@(U_$P(X,";",2)_+X_")")) ;text deleted
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^VPRUTILS("document",DFN,+X)
. Q:ORDG'="PROC"
. N VPRC D FIND^DIC(702,,"@","Q",+ORPK,,"ACON",,,"VPRC") ;CP
. S I=0 F S I=$O(VPRC("DILIST",2,I)) Q:I<1 D
.. S X=+$G(VPRC("DILIST",2,I))_";MDD(702,"
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^VPRUTILS("procedure",DFN,X)
I ORPKG="LR" D Q
. Q:$L(ORPK,";")'>3 ;no results yet, or parent order
. N SUB,IDT,CDT,ITM,VPRT,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,.VPRT)
.. S (T,N)=0 F S T=$O(VPRT(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^VPRUTILS("lab",DFN,$P(ID,";",2,9))
. I SUB="MI" D Q
.. S ITM="M;A;",N=0,LRDFN=$G(^DPT(DFN,"LR"))
.. 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^VPRUTILS("lab",DFN,ID)
.. S N=N+1,ORD("results",N,"uid")=$$SETUID^VPRUTILS("document",DFN,SUB_";"_IDT)
. ; SUB:"AP" [AU,CY,EM,SP]
. S ORD("results",1,"uid")=$$SETUID^VPRUTILS("lab",DFN,SUB_";"_IDT)
. S ORD("results",2,"uid")=$$SETUID^VPRUTILS("document",DFN,SUB_";"_IDT)
I ORPKG["PS" D Q
. S:ORPK ORD("results",1,"uid")=$$SETUID^VPRUTILS("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^VPRUTILS("image",DFN,IDT_"-"_CN)
; rest should be generic (OR) orders
I ORDG="NTX" S ORD("results",1,"uid")=$$SETUID^VPRUTILS("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^VPRUTILS("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,,,,"VPRS")
. S NTX("scheduleName")=$G(^TMP($J,"VPRS",X,.01))
. S NTX("adminTimes")=$G(^TMP($J,"VPRS",X,1))
. K ^TMP($J,"VPRS")
D ADD^VPRDJ("NTX","treatment")
Q
;
USER(N,ROLE,IEN,DATE) ; -- add signature/verification data
S N=+$G(N)+1
S ORD("clinicians",N,"signedDateTime")=$$JSONDT^VPRUTILS(DATE)
S ORD("clinicians",N,"role")=$G(ROLE)
Q:+$G(IEN)<1
S ORD("clinicians",N,"uid")=$$SETUID^VPRUTILS("user",,IEN)
S ORD("clinicians",N,"name")=$P($G(^VA(200,IEN,0)),U)
Q
;
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^VPRUTILS(Y)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ01 6611 printed Apr 09, 2024@21:47:45 Page 2
VPRDJ01 ;SLC/MKB -- Orders ;6/25/12 16:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+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, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
+24 ;
OR1(ID) ; -- order ID >> ^TMP("ORR",$J,ORLIST,VPRN)
+1 NEW ORDER,CHILD,VPRC
+2 DO ORX(ID,.ORDER)
+3 SET VPRC=0
FOR
SET VPRC=$ORDER(^OR(100,ID,2,VPRC))
if VPRC<1
QUIT
Begin DoDot:1
+4 KILL CHILD
DO ORX(VPRC,.CHILD)
+5 MERGE ORDER("children",VPRC)=CHILD
End DoDot:1
+6 DO ADD^VPRDJ("ORDER","order")
+7 QUIT
ORX(IFN,ORD) ; -- extract order IFN into ORD("attribute")
+1 NEW ORLIST,ORLST,X0,X8,LOC,X,I,DA
+2 SET ORLST=$SELECT(+$GET(VPRN):VPRN-1,1:0)
if '$DATA(ORLIST)
SET ORLIST=$HOROLOG
+3 DO GET^ORQ12(IFN,ORLIST,1)
+4 SET X0=$GET(^TMP("ORR",$JOB,ORLIST,ORLST))
+5 ;
+6 SET ORD("localId")=IFN
SET ORD("uid")=$$SETUID^VPRUTILS("order",DFN,IFN)
+7 SET X=$$OI^ORX8(+X0)
IF $LENGTH(X)
Begin DoDot:1
+8 NEW ARRAY,NAME
+9 SET ARRAY("Code")=1_U_"oi"
SET ARRAY("Name")=2
SET ARRAY("PackageRef")=3
+10 DO SPLITVAL^VPRUTILS(X,.ARRAY)
SET ORD("name")=ARRAY("Name")
+11 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
SET ORD("oi"_NAME)=$GET(ARRAY(NAME))
End DoDot:1
+12 SET ORD("displayGroup")=$PIECE(X0,U,2)
+13 SET ORD("entered")=$$JSONDT^VPRUTILS($PIECE(X0,U,3))
+14 SET ORD("start")=$$TM($PIECE(X0,U,4))
SET ORD("stop")=$$TM($PIECE(X0,U,5))
+15 SET ORD("statusCode")="urn:va:order-status:"_$PIECE(X0,U,7)
+16 SET ORD("statusName")=$PIECE(X0,U,6)
+17 SET ORD("statusVuid")="urn:va:vuid:"_$$STS^VPRDOR($PIECE(X0,U,7))
+18 DO SETTEXT^VPRUTILS($NAME(^TMP("ORR",$JOB,ORLIST,ORLST,"TX")),$NAME(^TMP("VPRTEXT",$JOB,IFN)))
+19 MERGE ORD("content","\")=^TMP("VPRTEXT",$JOB,IFN)
+20 SET X=$$GET1^DIQ(100,IFN_",",1,"I")
IF X
Begin DoDot:1
+21 SET ORD("providerUid")=$$SETUID^VPRUTILS("user",,+X)
+22 SET ORD("providerName")=$PIECE($GET(^VA(200,+X,0)),U)
End DoDot:1
+23 SET LOC=+$$GET1^DIQ(100,IFN_",",6,"I")
SET FAC=$$FAC^VPRD(LOC)
IF LOC
Begin DoDot:1
+24 SET ORD("locationName")=$PIECE($GET(^SC(LOC,0)),U)
+25 SET ORD("locationUid")=$$SETUID^VPRUTILS("location",,LOC)
End DoDot:1
+26 DO FACILITY^VPRUTILS(FAC,"ORD")
+27 SET ORD("service")=$$GET1^DIQ(100,IFN_",","12:1")
+28 SET X=$$GET1^DIQ(100,IFN_",",9,"I")
if X
SET ORD("predecessor")=$$SETUID^VPRUTILS("order",DFN,+X)
+29 SET X=$$GET1^DIQ(100,IFN_",",9.1,"I")
if X
SET ORD("successor")=$$SETUID^VPRUTILS("order",DFN,+X)
+30 DO RESULTS
+31 ; sign/verify
+32 ;signed
SET X8=$GET(^OR(100,IFN,8,1,0))
SET I=0
IF $PIECE(X8,U,6)
Begin DoDot:1
+33 ;if on chart,
NEW PROV
SET PROV=$PIECE(X8,U,5)
if PROV<1
SET PROV=$PIECE(X8,U,3)
+34 ; use provider
DO USER(.I,"S",PROV,$PIECE(X8,U,6))
End DoDot:1
+35 ;nurse
IF $PIECE(X8,U,9)
DO USER(.I,"N",$PIECE(X8,U,8),$PIECE(X8,U,9))
+36 ;clerk
IF $PIECE(X8,U,11)
DO USER(.I,"C",$PIECE(X8,U,10),$PIECE(X8,U,11))
+37 ;chart review
IF $PIECE(X8,U,19)
DO USER(.I,"R",$PIECE(X8,U,18),$PIECE(X8,U,19))
+38 QUIT
+39 ; acknowledgements
+40 SET DA=0
FOR
SET DA=$ORDER(^ORA(102.4,"B",+IFN,DA))
if DA<1
QUIT
Begin DoDot:1
+41 ;stub - not ack'd
SET X0=$GET(^ORA(102.4,DA,0))
if '$PIECE(X0,U,3)
QUIT
+42 SET X=+$PIECE(X0,U,2)
SET X=$SELECT(X:X_U_$PIECE($GET(^VA(200,X,0)),U),1:U)
+43 SET ORD("acknowledgement",DA)=X_U_$PIECE(X0,U,3)
End DoDot:1
+44 QUIT
+45 ;
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 NEW VPRD,I,N,X
DO DOCLIST^GMRCGUIB(.VPRD,+ORPK)
+5 SET N=1
SET ORD("results",N,"uid")=$$SETUID^VPRUTILS("consult",DFN,+ORPK)
+6 SET I=0
FOR
SET I=$ORDER(VPRD(50,I))
if I<1
QUIT
SET X=$GET(VPRD(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^VPRUTILS("document",DFN,+X)
End DoDot:2
+9 if ORDG'="PROC"
QUIT
+10 ;CP
NEW VPRC
DO FIND^DIC(702,,"@","Q",+ORPK,,"ACON",,,"VPRC")
+11 SET I=0
FOR
SET I=$ORDER(VPRC("DILIST",2,I))
if I<1
QUIT
Begin DoDot:2
+12 SET X=+$GET(VPRC("DILIST",2,I))_";MDD(702,"
+13 SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^VPRUTILS("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,VPRT,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,.VPRT)
+20 SET (T,N)=0
FOR
SET T=$ORDER(VPRT(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^VPRUTILS("lab",DFN,$PIECE(ID,";",2,9))
End DoDot:2
QUIT
+21 IF SUB="MI"
Begin DoDot:2
+22 SET ITM="M;A;"
SET N=0
SET LRDFN=$GET(^DPT(DFN,"LR"))
+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^VPRUTILS("lab",DFN,ID)
End DoDot:3
+26 SET N=N+1
SET ORD("results",N,"uid")=$$SETUID^VPRUTILS("document",DFN,SUB_";"_IDT)
End DoDot:2
QUIT
+27 ; SUB:"AP" [AU,CY,EM,SP]
+28 SET ORD("results",1,"uid")=$$SETUID^VPRUTILS("lab",DFN,SUB_";"_IDT)
+29 SET ORD("results",2,"uid")=$$SETUID^VPRUTILS("document",DFN,SUB_";"_IDT)
End DoDot:1
QUIT
+30 IF ORPKG["PS"
Begin DoDot:1
+31 if ORPK
SET ORD("results",1,"uid")=$$SETUID^VPRUTILS("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^VPRUTILS("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^VPRUTILS("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^VPRUTILS("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,,,,"VPRS")
+8 SET NTX("scheduleName")=$GET(^TMP($JOB,"VPRS",X,.01))
+9 SET NTX("adminTimes")=$GET(^TMP($JOB,"VPRS",X,1))
+10 KILL ^TMP($JOB,"VPRS")
End DoDot:1
+11 DO ADD^VPRDJ("NTX","treatment")
+12 QUIT
+13 ;
USER(N,ROLE,IEN,DATE) ; -- add signature/verification data
+1 SET N=+$GET(N)+1
+2 SET ORD("clinicians",N,"signedDateTime")=$$JSONDT^VPRUTILS(DATE)
+3 SET ORD("clinicians",N,"role")=$GET(ROLE)
+4 if +$GET(IEN)<1
QUIT
+5 SET ORD("clinicians",N,"uid")=$$SETUID^VPRUTILS("user",,IEN)
+6 SET ORD("clinicians",N,"name")=$PIECE($GET(^VA(200,IEN,0)),U)
+7 QUIT
+8 ;
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^VPRUTILS(Y)
+4 QUIT Y
