- 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 Jan 18, 2025@03:47:03 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