VPRSDAOR ;SLC/MKB -- SDA Order utilities ;7/29/22 14:11
;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Sep 01, 2011;Build 16
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^OR(100 5771
; ^ORD(100.98 6982
; DIC 2051
; DILFD 2055
; DIQ 2056
; ORQ1, ^TM("ORR",$J) 3154
;
;
ORDERS(DG) ; -- get orders by Display Group
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N ORDG,ORIGVIEW,ORKID,ORLIST,VPRI,VPRN,ORDER,X3,X4
S DG=$G(DG,"ALL"),ORDG=+$O(^ORD(100.98,"B",DG,0))
; return original view, child orders for Lab
S ORIGVIEW=2,ORKID=$S(DG="CH":1,DG="LAB":1,1:0)
D EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP,,,,ORKID) S VPRN=0
S VPRI=0 F S VPRI=$O(^TMP("ORR",$J,ORLIST,VPRI)) Q:VPRI<1 S ORDER=$G(^(VPRI)) D Q:VPRN'<DMAX
. I $P($P(ORDER,U),";",2)>1 Q ;skip order actions
. I $O(^OR(100,+ORDER,2,0)) Q ;skip parent orders
. S ORDER=+ORDER,X3=$G(^OR(100,ORDER,3)),X4=$G(^(4))
. Q:$P(X3,U,3)=13 I X4["P",$P(X3,U,3)=1!($P(X3,U,3)=12) Q ;cancelled
. Q:$P(X3,U,3)=14 ;lapsed
. I DG="RX",'$$RX(ORDER) Q ;skip non-PS in RX group
. I DG="LAB",$$BB(ORDER) Q ;skip blood bank in Lab
. S VPRN=VPRN+1,DLIST(VPRN)=ORDER
K ^TMP("ORR",$J)
Q
RX(ORIFN) ; -- is order really a med? (non-PS order in display group)
N X,Y,PKG S Y=0
S X=$P($G(^OR(100,+$G(ORIFN),0)),U,14),PKG=$$GET1^DIQ(9.4,+X_",",1)
I $E(PKG,1,2)="PS" S Y=1
Q Y
BB(ORIFN) ; -- return 1 or 0, if order is for Blood Bank
N X,Y,DG S Y=0
S X=$P($G(^OR(100,+$G(ORIFN),0)),U,11),DG=$P($G(^ORD(100.98,+X,0)),U,3)
I DG="BB"!(DG?1"VB".E) S Y=1
Q Y
;
NONORD ; -- get other orders: not Lab, Rad, or Med
; Query called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
N ORDG,ORPKG,ORIGVIEW,ORLIST,VPRI,VPRN,ORDER,X
S ORDG=+$O(^ORD(100.98,"B","ALL",0)) D ORPKG ;get list of pkgs to exclude
S ORIGVIEW=2 ;get original view of order
D EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP) S VPRN=0
S VPRI=0 F S VPRI=$O(^TMP("ORR",$J,ORLIST,VPRI)) Q:VPRI<1 S ORDER=$G(^(VPRI)) D Q:VPRN'<DMAX
. I $P($P(ORDER,U),";",2)>1 Q ;skip order actions
. Q:$P($G(^OR(100,+ORDER,3)),U,3)=14 ;skip lapsed orders
. S X=+$P($G(^OR(100,+ORDER,0)),U,14)
. I $D(ORPKG(X)) Q ;skip Lab,Rad,Med
. S VPRN=VPRN+1,DLIST(VPRN)=+ORDER
K ^TMP("ORR",$J)
Q
ORPKG ; -- get list of pkgs to exclude
N NMSP,X
F NMSP="LR","RA","PSG","PSIV","PSJ","PSO","PSH" D
. S X=+$$FIND1^DIC(9.4,,"QX",NMSP,"C")
. S:X>0 ORPKG(X)=""
Q
;
OR1(ORIFN) ; -- define basic variables for any order [ID Action]
; Returns OR0, OR3, OR6, OR8, ORDAD, and ORSIG to Order entities
S ORIFN=+$G(ORIFN)
S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),OR8=$G(^(8,1,0))
S ORDAD=$P($G(OR3),U,9) ;parent order
S ORSIG=$$ORSIG(ORIFN) ;signature info
Q
;
WP(ORIFN,ID) ; -- return a WP value from an order response as a string
N DA,I,X,Y S Y=""
S DA=+$O(^OR(100,+$G(ORIFN),4.5,"ID",ID,0))
S I=0 F S I=$O(^OR(100,+$G(ORIFN),4.5,DA,2,I)) Q:'I S X=$G(^(I,0)) D
. I '$L(Y) Q:(X="")!(X?1." ") S Y=X Q
. I $E(X)=" " S Y=Y_$C(13,10)_X Q
. S Y=Y_$S($E(Y,$L(Y))=" ":"",1:" ")_X
Q Y
;
ORDG(DG) ; -- return ien^name^VA100.98 for a DG abbreviation
N X,Y S X=$O(^ORD(100.98,"B",DG,0)),Y=""
S:X Y=X_U_$P($G(^ORD(100.98,X,0)),U)_"^VA100.98"
Q Y
;
LASTACT(ORIFN) ; -- return DA of current or last order action
N Y S ORIFN=+$G(ORIFN)
S Y=+$P($G(^OR(100,ORIFN,3)),U,7)
I Y<1 S Y=+$O(^OR(100,ORIFN,8,"A"),-1) S:'Y Y=1
Q Y
;
ORSIG(ORIFN) ; -- return string of signature data from Order Action as
; Signature Status (#4) ^ Signed By (#5) ^ D/T Signed (#6), or
; Signature Status (#4) ^ ^ Release D/T (#16) if not e-signed
N Y,X0,X,I S Y=""
S X0=$G(^OR(100,+$G(ORIFN),8,1,0))
I $P(X0,U,6) S Y=$P(X0,U,4,6)
; look for sign on corrected or parent order action
I Y="",$P(X0,U,15)=12 D ;replaced
. S I=+$O(^OR(100,+$G(ORIFN),8,1)),X=$G(^(I,0))
. I $P(X,U,2)="XX",$P(X,U,6) S Y=$P(X,U,4,6)
I Y="",$P(X0,U,4)=8,$G(ORDAD) D ;parent [no longer used]
. S X=$G(^OR(100,+$G(ORDAD),8,1,0))
. S:$P(X,U,6) Y=$P(X,U,4,6)
; else, return Sig Sts & Release D/T
S:Y="" Y=$P(X0,U,4)_U_U_$P(X0,U,16)
S X=$P(Y,U) S:$L(X) $P(Y,U)=$$EXTERNAL^DILFD(100.008,4,,X)
Q Y
;
FLAGS(IFN,LIST) ; -- returns 1 or 0, if any flags are active [VPRSDAOR]
; Can also return .LIST(DA) of actions w/flag nodes
N X,Y,I S Y=0
S IFN=+$G(IFN) K LIST
S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I<1 I $D(^(I,3)) S X=$G(^(3)) D
. S LIST(I)=I_","_IFN
. S:X Y=1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAOR 4832 printed Sep 23, 2025@20:22:18 Page 2
VPRSDAOR ;SLC/MKB -- SDA Order utilities ;7/29/22 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Sep 01, 2011;Build 16
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^OR(100 5771
+7 ; ^ORD(100.98 6982
+8 ; DIC 2051
+9 ; DILFD 2055
+10 ; DIQ 2056
+11 ; ORQ1, ^TM("ORR",$J) 3154
+12 ;
+13 ;
ORDERS(DG) ; -- get orders by Display Group
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW ORDG,ORIGVIEW,ORKID,ORLIST,VPRI,VPRN,ORDER,X3,X4
+5 SET DG=$GET(DG,"ALL")
SET ORDG=+$ORDER(^ORD(100.98,"B",DG,0))
+6 ; return original view, child orders for Lab
+7 SET ORIGVIEW=2
SET ORKID=$SELECT(DG="CH":1,DG="LAB":1,1:0)
+8 DO EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP,,,,ORKID)
SET VPRN=0
+9 SET VPRI=0
FOR
SET VPRI=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRI))
if VPRI<1
QUIT
SET ORDER=$GET(^(VPRI))
Begin DoDot:1
+10 ;skip order actions
IF $PIECE($PIECE(ORDER,U),";",2)>1
QUIT
+11 ;skip parent orders
IF $ORDER(^OR(100,+ORDER,2,0))
QUIT
+12 SET ORDER=+ORDER
SET X3=$GET(^OR(100,ORDER,3))
SET X4=$GET(^(4))
+13 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
IF X4["P"
IF $PIECE(X3,U,3)=1!($PIECE(X3,U,3)=12)
QUIT
+14 ;lapsed
if $PIECE(X3,U,3)=14
QUIT
+15 ;skip non-PS in RX group
IF DG="RX"
IF '$$RX(ORDER)
QUIT
+16 ;skip blood bank in Lab
IF DG="LAB"
IF $$BB(ORDER)
QUIT
+17 SET VPRN=VPRN+1
SET DLIST(VPRN)=ORDER
End DoDot:1
if VPRN'<DMAX
QUIT
+18 KILL ^TMP("ORR",$JOB)
+19 QUIT
RX(ORIFN) ; -- is order really a med? (non-PS order in display group)
+1 NEW X,Y,PKG
SET Y=0
+2 SET X=$PIECE($GET(^OR(100,+$GET(ORIFN),0)),U,14)
SET PKG=$$GET1^DIQ(9.4,+X_",",1)
+3 IF $EXTRACT(PKG,1,2)="PS"
SET Y=1
+4 QUIT Y
BB(ORIFN) ; -- return 1 or 0, if order is for Blood Bank
+1 NEW X,Y,DG
SET Y=0
+2 SET X=$PIECE($GET(^OR(100,+$GET(ORIFN),0)),U,11)
SET DG=$PIECE($GET(^ORD(100.98,+X,0)),U,3)
+3 IF DG="BB"!(DG?1"VB".E)
SET Y=1
+4 QUIT Y
+5 ;
NONORD ; -- get other orders: not Lab, Rad, or Med
+1 ; Query called from GET^DDE, returns DLIST(#)=ien
+2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+3 ;
+4 NEW ORDG,ORPKG,ORIGVIEW,ORLIST,VPRI,VPRN,ORDER,X
+5 ;get list of pkgs to exclude
SET ORDG=+$ORDER(^ORD(100.98,"B","ALL",0))
DO ORPKG
+6 ;get original view of order
SET ORIGVIEW=2
+7 DO EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP)
SET VPRN=0
+8 SET VPRI=0
FOR
SET VPRI=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRI))
if VPRI<1
QUIT
SET ORDER=$GET(^(VPRI))
Begin DoDot:1
+9 ;skip order actions
IF $PIECE($PIECE(ORDER,U),";",2)>1
QUIT
+10 ;skip lapsed orders
if $PIECE($GET(^OR(100,+ORDER,3)),U,3)=14
QUIT
+11 SET X=+$PIECE($GET(^OR(100,+ORDER,0)),U,14)
+12 ;skip Lab,Rad,Med
IF $DATA(ORPKG(X))
QUIT
+13 SET VPRN=VPRN+1
SET DLIST(VPRN)=+ORDER
End DoDot:1
if VPRN'<DMAX
QUIT
+14 KILL ^TMP("ORR",$JOB)
+15 QUIT
ORPKG ; -- get list of pkgs to exclude
+1 NEW NMSP,X
+2 FOR NMSP="LR","RA","PSG","PSIV","PSJ","PSO","PSH"
Begin DoDot:1
+3 SET X=+$$FIND1^DIC(9.4,,"QX",NMSP,"C")
+4 if X>0
SET ORPKG(X)=""
End DoDot:1
+5 QUIT
+6 ;
OR1(ORIFN) ; -- define basic variables for any order [ID Action]
+1 ; Returns OR0, OR3, OR6, OR8, ORDAD, and ORSIG to Order entities
+2 SET ORIFN=+$GET(ORIFN)
+3 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
SET OR6=$GET(^(6))
SET OR8=$GET(^(8,1,0))
+4 ;parent order
SET ORDAD=$PIECE($GET(OR3),U,9)
+5 ;signature info
SET ORSIG=$$ORSIG(ORIFN)
+6 QUIT
+7 ;
WP(ORIFN,ID) ; -- return a WP value from an order response as a string
+1 NEW DA,I,X,Y
SET Y=""
+2 SET DA=+$ORDER(^OR(100,+$GET(ORIFN),4.5,"ID",ID,0))
+3 SET I=0
FOR
SET I=$ORDER(^OR(100,+$GET(ORIFN),4.5,DA,2,I))
if 'I
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+4 IF '$LENGTH(Y)
if (X="")!(X?1." ")
QUIT
SET Y=X
QUIT
+5 IF $EXTRACT(X)=" "
SET Y=Y_$CHAR(13,10)_X
QUIT
+6 SET Y=Y_$SELECT($EXTRACT(Y,$LENGTH(Y))=" ":"",1:" ")_X
End DoDot:1
+7 QUIT Y
+8 ;
ORDG(DG) ; -- return ien^name^VA100.98 for a DG abbreviation
+1 NEW X,Y
SET X=$ORDER(^ORD(100.98,"B",DG,0))
SET Y=""
+2 if X
SET Y=X_U_$PIECE($GET(^ORD(100.98,X,0)),U)_"^VA100.98"
+3 QUIT Y
+4 ;
LASTACT(ORIFN) ; -- return DA of current or last order action
+1 NEW Y
SET ORIFN=+$GET(ORIFN)
+2 SET Y=+$PIECE($GET(^OR(100,ORIFN,3)),U,7)
+3 IF Y<1
SET Y=+$ORDER(^OR(100,ORIFN,8,"A"),-1)
if 'Y
SET Y=1
+4 QUIT Y
+5 ;
ORSIG(ORIFN) ; -- return string of signature data from Order Action as
+1 ; Signature Status (#4) ^ Signed By (#5) ^ D/T Signed (#6), or
+2 ; Signature Status (#4) ^ ^ Release D/T (#16) if not e-signed
+3 NEW Y,X0,X,I
SET Y=""
+4 SET X0=$GET(^OR(100,+$GET(ORIFN),8,1,0))
+5 IF $PIECE(X0,U,6)
SET Y=$PIECE(X0,U,4,6)
+6 ; look for sign on corrected or parent order action
+7 ;replaced
IF Y=""
IF $PIECE(X0,U,15)=12
Begin DoDot:1
+8 SET I=+$ORDER(^OR(100,+$GET(ORIFN),8,1))
SET X=$GET(^(I,0))
+9 IF $PIECE(X,U,2)="XX"
IF $PIECE(X,U,6)
SET Y=$PIECE(X,U,4,6)
End DoDot:1
+10 ;parent [no longer used]
IF Y=""
IF $PIECE(X0,U,4)=8
IF $GET(ORDAD)
Begin DoDot:1
+11 SET X=$GET(^OR(100,+$GET(ORDAD),8,1,0))
+12 if $PIECE(X,U,6)
SET Y=$PIECE(X,U,4,6)
End DoDot:1
+13 ; else, return Sig Sts & Release D/T
+14 if Y=""
SET Y=$PIECE(X0,U,4)_U_U_$PIECE(X0,U,16)
+15 SET X=$PIECE(Y,U)
if $LENGTH(X)
SET $PIECE(Y,U)=$$EXTERNAL^DILFD(100.008,4,,X)
+16 QUIT Y
+17 ;
FLAGS(IFN,LIST) ; -- returns 1 or 0, if any flags are active [VPRSDAOR]
+1 ; Can also return .LIST(DA) of actions w/flag nodes
+2 NEW X,Y,I
SET Y=0
+3 SET IFN=+$GET(IFN)
KILL LIST
+4 SET I=0
FOR
SET I=$ORDER(^OR(100,IFN,8,I))
if I<1
QUIT
IF $DATA(^(I,3))
SET X=$GET(^(3))
Begin DoDot:1
+5 SET LIST(I)=I_","_IFN
+6 if X
SET Y=1
End DoDot:1
+7 QUIT Y
