ORTOULT4 ;EPIP/RTW-UNIFIED ACTION PROFILE RPCS. ;Mar 05, 2019@08:07:49
;;3.0;ORDER ENTRY/RESULTS REPORTING;**444**;Dec 17, 1997;Build 48
;EPIP/RTW For the Unified Action Profile 26 Oct 2016
;ICR# Type Description
;----- ---- -------------------------------------
;1014 Routine LOW^XLFSTR
;
; RPC 'ORTO SET UAP FLAG'
; RPC 'ORTO SETRVW'
; RPC 'ORTO GETRVW'
Q ; NO DIRECT ENTRY
;
SETUAPF(ORTOK,ORTUAPF) ;
N ORTUAP
S ORTUAP=+$G(ORTUAPF) ;1=user in UAP view on orders tab, 0=user in any other view
S ORTOK=1 ;dummy return variable
Q
SETRVW(ORTOK,ORTRVW,ORTORIEN) ;
;
N ORTIEN,ORTLRVW,ORTDT,ORTOK
S ORTIEN=+$G(ORTORIEN),ORTLRVW=0,ORTOK=0
Q:'ORTIEN
Q:'$L($G(ORTRVW))
N %,X,Y D NOW^%DTC S ORTDT=%
N DR,DA,DIE
S DIE="^OR(100,",DA=ORTIEN
S DR=".61///^S X=ORTRVW;.62///^S X=ORTDT;.63///^S X=+$G(DUZ)"
D ^DIE
;
S ORTOK=1
;
Q
GETRVW(ORTRVW,ORTORIEN) ;
;
N ORTIEN
S ORTRVW=0
S ORTIEN=+$G(ORTORIEN)
Q:'ORTIEN
S ORTRVW=$P($G(^OR(100,ORTIEN,.61)),U,1)
S ORTRVW=$S(ORTRVW="0":" ",ORTRVW="1":"yes",ORTRVW="C":"cont",ORTRVW="D":"dc",ORTRVW="G":"chg",ORTRVW="N":"new",ORTRVW="R":"renew",1:"")
Q
;
REF ; REFORMAT ORDER LIST IN ALPHABETICAL ORDER
; FROM AGET^ORWORR
N LIST,ORCITEM,ORI,ORJ,ORSUPPLY,ORTOADD,ORTIFN,ORTITEM,ORUI,ORUI2,ORUIEN,ORX,SUPPLY,ORTO,ORIGTA,ORKIEN,ORUAPIV,ORDG
S (ORCNT,ORTO)=0 F ORI=0:0 S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI<.1 D
.S (ORSUPPLY,ORUAPIV,SUPPLY)=0
.S ORX=^TMP("ORR",$J,ORLIST,ORI)
.S ORTIFN=$P($P(ORX,U),";")
.S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U) Q:ORTITEM=""
.S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U) ;Oitem name used for sorting.
.S:$D(^ORD(101.43,ORTITEM,"PS")) ORTO=1,SUPPLY=$P($G(^("PS")),U,5) ;set ORTO is "PS" exists
.S ORDG=$$GET1^DIQ(100,ORTIFN,23,"E") S:(ORDG["IV")!(ORDG["INFUSION") ORUAPIV=1 ;is the service IV or Infusion
.I '$G(ORUAPIV) D UAPLASTX(ORTIFN,ORTITEM) ;all non IV reset ORCITEM if last Oitem/Otext mismatch
.I $G(ORUAPIV) S ORCITEM=$$UAPIV(ORCITEM,ORTIFN) ; multiple Oitem IV no ADDITIVE get last text.
.K ^TMP("ORR",$J,ORLIST,ORI)
.I $$GET1^DIQ(100.98,GROUPS,.01)="PHARMACY UAP" D
.. S ORUI=0 F S ORUI=$O(^ORD(100.98,GROUPS,1,ORUI)) Q:'ORUI D
... S ORUI2=$G(^ORD(100.98,GROUPS,1,ORUI,0)) I $$GET1^DIQ(100.98,ORUI2,.01)["SUPPL" S ORSUPPLY=1
.Q:(SUPPLY)&'$G(ORSUPPLY)
.S ORCNT=ORCNT+1
.S ORCITEM=$$LOW^XLFSTR(ORCITEM) ;tallman lettering fix rtw
.S LIST(ORCITEM,ORCNT)=ORX
S ORICNT=0
S ORCITEM="" F ORJ=0:0 S ORCITEM=$O(LIST(ORCITEM)) Q:ORCITEM="" D
.F ORK=0:0 S ORK=$O(LIST(ORCITEM,ORK)) Q:ORK<1 D
..S ORUIEN=$P(LIST(ORCITEM,ORK),";"),ORKIEN=$P($P(LIST(ORCITEM,ORK),U),";",2)
..S IENS=ORKIEN_","_ORUIEN Q:$$GET1^DIQ(100.008,IENS_",","15")["dc/edit"
..S ORICNT=ORICNT+1
..S ^TMP("ORR",$J,ORLIST,ORICNT)=LIST(ORCITEM,ORK)
K ORCNT,ORICNT
Q
;
UAPIV(ORCITEM,ORTIFN) ;this puts an IV in correct number order by first additive if it has one.
N ORTITMN,ORTADD
S (ORTITMN,ORTOADD)=0 F S ORTITMN=$O(^OR(100,ORTIFN,.1,ORTITMN)) Q:('ORTITMN)!(ORTOADD=1) D ;new sort when INFUSION ORDER
. S ORTITEM=$P($G(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
. Q:+$D(^ORD(101.43,ORTITEM,"PS"))'>0
. S:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ORTOADD=0
. Q:$P(^ORD(101.43,ORTITEM,"PS"),U,3)
. S:$P(^ORD(101.43,ORTITEM,"PS"),U,4) ORTOADD=1 ;end new code to handle infusion orders.
. S ORCITEM=$G(^ORD(101.43,ORTITEM,0),U)
S:'$G(ORTOADD) ORIGTA=$$LASTXT^ORQ12(ORTIFN),ORCITEM=$G(^OR(100,ORTIFN,8,ORIGTA,.1,1,0)) S:$E(ORCITEM,1,3)=">> " ORCITEM=$E(ORCITEM,4,999)
Q ORCITEM
;
UAPALPHA(ORTOADD,ORTA,ORTIFN) ; called by ORQ12 resorts the order text field so that the first additive is on the top to match the sorted by orderable item name.
K ^TMP("UAP",$J),^TMP("UAPTEXT",$J)
N ORUAP1,ORUAP2,ORUTX,ORUTY,ORUAPCN2,ORUAPCN3,ORUAPCNT,ORTMSAVE
S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U),ORTMSAVE=ORTITEM ;set item first in case there is no additive.
S (ORTITMN,ORTOADD)=0 F S ORTITMN=$O(^OR(100,ORTIFN,.1,ORTITMN)) Q:('ORTITMN)!(ORTOADD=1) D ;new sort when INFUSION ORDER
. S ORTITEM=$P($G(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
. Q:+$D(^ORD(101.43,ORTITEM,"PS"))'>0
. S:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ORTOADD=0
. Q:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ;this indicates a base.
. S:$P(^ORD(101.43,ORTITEM,"PS"),U,4) ORTOADD=1 ;end new code to put first additive on top of infusion order display.
S:'$G(ORTOADD) ORTITEM=ORTMSAVE ;code to handle if the IV has no additive.
S ^TMP("UAP",$J,ORTIFN,1)=ORTITEM
S ORUAP1=0,ORUAPCNT=2 F S ORUAP1=$O(^OR(100,ORTIFN,.1,ORUAP1)) Q:'ORUAP1 D
. Q:$P(^OR(100,ORTIFN,.1,ORUAP1,0),U)=ORTITEM
. S ^TMP("UAP",$J,ORTIFN,ORUAPCNT)=$P(^OR(100,ORTIFN,.1,ORUAP1,0),U)
. S ORUAPCNT=ORUAPCNT+1
S ORUAP2=0,ORUAPCN2=1 F S ORUAP2=$O(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2)) Q:'ORUAP2 D
. S ORUTX=$G(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2,0)) S ORUTY=$L(ORUTX)
. I $E(ORUTX)=" ",ORUTY S ORUTX=$E(ORUTX,2,999) ;new line
. S ^TMP("UAPTEXT",$J,ORTIFN,ORUAPCN2)=ORUTX
. S ORUAPCN2=ORUAPCN2+1
Q:'$G(ORTOADD) ORTOADD
UAPRTW ; part of the UAPALPHA above this part takes the original IV list and places it in the new order
K ORTX
N ORUAP3,ORUAP4,ORUAP5,ORTITE2
S ORTITE2=$P(^TMP("UAP",$J,ORTIFN,1),U)
S ORUAP3=0,ORUAP4=1,ORUAPCN3=1 F S ORUAP3=$O(^TMP("UAPTEXT",$J,ORTIFN,ORUAP3)) Q:'ORUAP3 D
. I $G(^TMP("UAPTEXT",$J,ORTIFN,ORUAP3))[$$GET1^DIQ(101.43,ORTITE2,.01,"I",) S ORTX(ORUAP4)=^TMP("UAPTEXT",$J,ORTIFN,ORUAP3),ORUAP4=ORUAP4+1 Q
I ORUAP4>1 S ORUAP5=0 F S ORUAP5=$O(^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)) Q:'ORUAP5 D
. I $G(^TMP("UAPTEXT",$J,ORTIFN,ORUAP5))'[$$GET1^DIQ(101.43,ORTITE2,.01,"I",) S ORTX(ORUAP4)=^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)
. S ^TMP("UAP3",$J,ORTIFN,ORUAPCN3)=^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)
. S ORUAPCN3=ORUAPCN3+1,ORUAP4=ORUAP4+1
Q
DCREF ; Reformat order list in special Discharge View order
; Active : Hold : Pending : Discontinued : Expired
; FROM AGET^ORWORR => GET1^ORWORR1 => here
N LIST,ORI,ORK,ORX,ORTIFN,ORTITEM,ORCITEM,SUPPLY,ORTSTLST,ORTSTA,ORTIDX,ORCNT,ORICNT
N ORTSVPT1
;
S ORTSTLST(6)=1 ;Active/Suspended
S ORTSTLST(3)=2 ;Hold
S ORTSTLST(5)=3 ;Pending
S ORTSTLST(7)=4 ;Expired
S ORTSTLST(1)=5 ;Discontinued
;
I $D(^TMP("ORR",$J,ORLIST,.1)) S ORTSVPT1=$G(^TMP("ORR",$J,ORLIST,.1))
;
S (ORI,ORCNT)=0
F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI<.1 D
.S ORX=^TMP("ORR",$J,ORLIST,ORI)
.S ORTIFN=$P($P(ORX,U),";")
.;
.S ORTSTA=+$P($G(^OR(100,ORTIFN,3)),U,3)
.S ORTIDX=$S($D(ORTSTLST(ORTSTA)):ORTSTLST(ORTSTA),1:9)
.S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U) Q:ORTITEM=""
.S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U),SUPPLY=$P($G(^("PS")),U,5)
.K ^TMP("ORR",$J,ORLIST,ORI)
.S ORCNT=ORCNT+1
.S ORCITEM=$$LOW^XLFSTR(ORCITEM) ;tallman lettering fix rtw
.S LIST(ORTIDX,ORCITEM,ORCNT)=ORX
;
S ORICNT=0
S ORTIDX=0 F S ORTIDX=$O(LIST(ORTIDX)) Q:'ORTIDX D
. S ORCITEM="" F S ORCITEM=$O(LIST(ORTIDX,ORCITEM)) Q:ORCITEM="" D
. . S ORK=0 F S ORK=$O(LIST(ORTIDX,ORCITEM,ORK)) Q:'ORK D
. . . S ORICNT=ORICNT+1
. . . S ^TMP("ORR",$J,ORLIST,ORICNT)=LIST(ORTIDX,ORCITEM,ORK)
;
I $D(ORTSVPT1) S ^TMP("ORR",$J,ORLIST,.1)=ORTSVPT1
;
Q
UAPOFF(ORUAPOFF) ;ON/OFF SWITCH
;
S ORUAPOFF=$$GET^XPAR("ALL","OR UNIFIED ACTION PROFILE OFF")
Q ORUAPOFF
DGROUP(ORDGNAME,ORX) ;RPC ORTO DGROUP to get the DGroup name
S ORDGNAME=$P($G(^ORD(100.98,ORX,0)),U,1)
Q
UAPLASTX(ORTIFN,ORTITEM) ;
N OROTXT,OROTXTX
S ORIGTA=$$LASTXT^ORQ12(ORTIFN) ; GETS THE LAST ORDERTEXT IEN
S OROTXT=$G(^OR(100,ORTIFN,8,ORIGTA,.1,1,0)) S:$E(OROTXT,1,3)=">> " OROTXT=$E(OROTXT,4,999)
S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U)
S OROTXTX=$E(OROTXT,1,2),ORCITEMX=$E(ORCITEM,1,2)
S:OROTXTX'=ORCITEMX ORCITEM=OROTXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORTOULT4 7749 printed Dec 13, 2024@02:34:19 Page 2
ORTOULT4 ;EPIP/RTW-UNIFIED ACTION PROFILE RPCS. ;Mar 05, 2019@08:07:49
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**444**;Dec 17, 1997;Build 48
+2 ;EPIP/RTW For the Unified Action Profile 26 Oct 2016
+3 ;ICR# Type Description
+4 ;----- ---- -------------------------------------
+5 ;1014 Routine LOW^XLFSTR
+6 ;
+7 ; RPC 'ORTO SET UAP FLAG'
+8 ; RPC 'ORTO SETRVW'
+9 ; RPC 'ORTO GETRVW'
+10 ; NO DIRECT ENTRY
QUIT
+11 ;
SETUAPF(ORTOK,ORTUAPF) ;
+1 NEW ORTUAP
+2 ;1=user in UAP view on orders tab, 0=user in any other view
SET ORTUAP=+$GET(ORTUAPF)
+3 ;dummy return variable
SET ORTOK=1
+4 QUIT
SETRVW(ORTOK,ORTRVW,ORTORIEN) ;
+1 ;
+2 NEW ORTIEN,ORTLRVW,ORTDT,ORTOK
+3 SET ORTIEN=+$GET(ORTORIEN)
SET ORTLRVW=0
SET ORTOK=0
+4 if 'ORTIEN
QUIT
+5 if '$LENGTH($GET(ORTRVW))
QUIT
+6 NEW %,X,Y
DO NOW^%DTC
SET ORTDT=%
+7 NEW DR,DA,DIE
+8 SET DIE="^OR(100,"
SET DA=ORTIEN
+9 SET DR=".61///^S X=ORTRVW;.62///^S X=ORTDT;.63///^S X=+$G(DUZ)"
+10 DO ^DIE
+11 ;
+12 SET ORTOK=1
+13 ;
+14 QUIT
GETRVW(ORTRVW,ORTORIEN) ;
+1 ;
+2 NEW ORTIEN
+3 SET ORTRVW=0
+4 SET ORTIEN=+$GET(ORTORIEN)
+5 if 'ORTIEN
QUIT
+6 SET ORTRVW=$PIECE($GET(^OR(100,ORTIEN,.61)),U,1)
+7 SET ORTRVW=$SELECT(ORTRVW="0":" ",ORTRVW="1":"yes",ORTRVW="C":"cont",ORTRVW="D":"dc",ORTRVW="G":"chg",ORTRVW="N":"new",ORTRVW="R":"renew",1:"")
+8 QUIT
+9 ;
REF ; REFORMAT ORDER LIST IN ALPHABETICAL ORDER
+1 ; FROM AGET^ORWORR
+2 NEW LIST,ORCITEM,ORI,ORJ,ORSUPPLY,ORTOADD,ORTIFN,ORTITEM,ORUI,ORUI2,ORUIEN,ORX,SUPPLY,ORTO,ORIGTA,ORKIEN,ORUAPIV,ORDG
+3 SET (ORCNT,ORTO)=0
FOR ORI=0:0
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
if ORI<.1
QUIT
Begin DoDot:1
+4 SET (ORSUPPLY,ORUAPIV,SUPPLY)=0
+5 SET ORX=^TMP("ORR",$JOB,ORLIST,ORI)
+6 SET ORTIFN=$PIECE($PIECE(ORX,U),";")
+7 SET ORTITEM=$PIECE($GET(^OR(100,ORTIFN,.1,1,0)),U)
if ORTITEM=""
QUIT
+8 ;Oitem name used for sorting.
SET ORCITEM=$PIECE($GET(^ORD(101.43,ORTITEM,0)),U)
+9 ;set ORTO is "PS" exists
if $DATA(^ORD(101.43,ORTITEM,"PS"))
SET ORTO=1
SET SUPPLY=$PIECE($GET(^("PS")),U,5)
+10 ;is the service IV or Infusion
SET ORDG=$$GET1^DIQ(100,ORTIFN,23,"E")
if (ORDG["IV")!(ORDG["INFUSION")
SET ORUAPIV=1
+11 ;all non IV reset ORCITEM if last Oitem/Otext mismatch
IF '$GET(ORUAPIV)
DO UAPLASTX(ORTIFN,ORTITEM)
+12 ; multiple Oitem IV no ADDITIVE get last text.
IF $GET(ORUAPIV)
SET ORCITEM=$$UAPIV(ORCITEM,ORTIFN)
+13 KILL ^TMP("ORR",$JOB,ORLIST,ORI)
+14 IF $$GET1^DIQ(100.98,GROUPS,.01)="PHARMACY UAP"
Begin DoDot:2
+15 SET ORUI=0
FOR
SET ORUI=$ORDER(^ORD(100.98,GROUPS,1,ORUI))
if 'ORUI
QUIT
Begin DoDot:3
+16 SET ORUI2=$GET(^ORD(100.98,GROUPS,1,ORUI,0))
IF $$GET1^DIQ(100.98,ORUI2,.01)["SUPPL"
SET ORSUPPLY=1
End DoDot:3
End DoDot:2
+17 if (SUPPLY)&'$GET(ORSUPPLY)
QUIT
+18 SET ORCNT=ORCNT+1
+19 ;tallman lettering fix rtw
SET ORCITEM=$$LOW^XLFSTR(ORCITEM)
+20 SET LIST(ORCITEM,ORCNT)=ORX
End DoDot:1
+21 SET ORICNT=0
+22 SET ORCITEM=""
FOR ORJ=0:0
SET ORCITEM=$ORDER(LIST(ORCITEM))
if ORCITEM=""
QUIT
Begin DoDot:1
+23 FOR ORK=0:0
SET ORK=$ORDER(LIST(ORCITEM,ORK))
if ORK<1
QUIT
Begin DoDot:2
+24 SET ORUIEN=$PIECE(LIST(ORCITEM,ORK),";")
SET ORKIEN=$PIECE($PIECE(LIST(ORCITEM,ORK),U),";",2)
+25 SET IENS=ORKIEN_","_ORUIEN
if $$GET1^DIQ(100.008,IENS_",","15")["dc/edit"
QUIT
+26 SET ORICNT=ORICNT+1
+27 SET ^TMP("ORR",$JOB,ORLIST,ORICNT)=LIST(ORCITEM,ORK)
End DoDot:2
End DoDot:1
+28 KILL ORCNT,ORICNT
+29 QUIT
+30 ;
UAPIV(ORCITEM,ORTIFN) ;this puts an IV in correct number order by first additive if it has one.
+1 NEW ORTITMN,ORTADD
+2 ;new sort when INFUSION ORDER
SET (ORTITMN,ORTOADD)=0
FOR
SET ORTITMN=$ORDER(^OR(100,ORTIFN,.1,ORTITMN))
if ('ORTITMN)!(ORTOADD=1)
QUIT
Begin DoDot:1
+3 SET ORTITEM=$PIECE($GET(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
+4 if +$DATA(^ORD(101.43,ORTITEM,"PS"))'>0
QUIT
+5 if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,3)
SET ORTOADD=0
+6 if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,3)
QUIT
+7 ;end new code to handle infusion orders.
if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,4)
SET ORTOADD=1
+8 SET ORCITEM=$GET(^ORD(101.43,ORTITEM,0),U)
End DoDot:1
+9 if '$GET(ORTOADD)
SET ORIGTA=$$LASTXT^ORQ12(ORTIFN)
SET ORCITEM=$GET(^OR(100,ORTIFN,8,ORIGTA,.1,1,0))
if $EXTRACT(ORCITEM,1,3)=">> "
SET ORCITEM=$EXTRACT(ORCITEM,4,999)
+10 QUIT ORCITEM
+11 ;
UAPALPHA(ORTOADD,ORTA,ORTIFN) ; called by ORQ12 resorts the order text field so that the first additive is on the top to match the sorted by orderable item name.
+1 KILL ^TMP("UAP",$JOB),^TMP("UAPTEXT",$JOB)
+2 NEW ORUAP1,ORUAP2,ORUTX,ORUTY,ORUAPCN2,ORUAPCN3,ORUAPCNT,ORTMSAVE
+3 ;set item first in case there is no additive.
SET ORTITEM=$PIECE($GET(^OR(100,ORTIFN,.1,1,0)),U)
SET ORTMSAVE=ORTITEM
+4 ;new sort when INFUSION ORDER
SET (ORTITMN,ORTOADD)=0
FOR
SET ORTITMN=$ORDER(^OR(100,ORTIFN,.1,ORTITMN))
if ('ORTITMN)!(ORTOADD=1)
QUIT
Begin DoDot:1
+5 SET ORTITEM=$PIECE($GET(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
+6 if +$DATA(^ORD(101.43,ORTITEM,"PS"))'>0
QUIT
+7 if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,3)
SET ORTOADD=0
+8 ;this indicates a base.
if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,3)
QUIT
+9 ;end new code to put first additive on top of infusion order display.
if $PIECE(^ORD(101.43,ORTITEM,"PS"),U,4)
SET ORTOADD=1
End DoDot:1
+10 ;code to handle if the IV has no additive.
if '$GET(ORTOADD)
SET ORTITEM=ORTMSAVE
+11 SET ^TMP("UAP",$JOB,ORTIFN,1)=ORTITEM
+12 SET ORUAP1=0
SET ORUAPCNT=2
FOR
SET ORUAP1=$ORDER(^OR(100,ORTIFN,.1,ORUAP1))
if 'ORUAP1
QUIT
Begin DoDot:1
+13 if $PIECE(^OR(100,ORTIFN,.1,ORUAP1,0),U)=ORTITEM
QUIT
+14 SET ^TMP("UAP",$JOB,ORTIFN,ORUAPCNT)=$PIECE(^OR(100,ORTIFN,.1,ORUAP1,0),U)
+15 SET ORUAPCNT=ORUAPCNT+1
End DoDot:1
+16 SET ORUAP2=0
SET ORUAPCN2=1
FOR
SET ORUAP2=$ORDER(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2))
if 'ORUAP2
QUIT
Begin DoDot:1
+17 SET ORUTX=$GET(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2,0))
SET ORUTY=$LENGTH(ORUTX)
+18 ;new line
IF $EXTRACT(ORUTX)=" "
IF ORUTY
SET ORUTX=$EXTRACT(ORUTX,2,999)
+19 SET ^TMP("UAPTEXT",$JOB,ORTIFN,ORUAPCN2)=ORUTX
+20 SET ORUAPCN2=ORUAPCN2+1
End DoDot:1
+21 if '$GET(ORTOADD)
QUIT ORTOADD
UAPRTW ; part of the UAPALPHA above this part takes the original IV list and places it in the new order
+1 KILL ORTX
+2 NEW ORUAP3,ORUAP4,ORUAP5,ORTITE2
+3 SET ORTITE2=$PIECE(^TMP("UAP",$JOB,ORTIFN,1),U)
+4 SET ORUAP3=0
SET ORUAP4=1
SET ORUAPCN3=1
FOR
SET ORUAP3=$ORDER(^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP3))
if 'ORUAP3
QUIT
Begin DoDot:1
+5 IF $GET(^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP3))[$$GET1^DIQ(101.43,ORTITE2,.01,"I",)
SET ORTX(ORUAP4)=^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP3)
SET ORUAP4=ORUAP4+1
QUIT
End DoDot:1
+6 IF ORUAP4>1
SET ORUAP5=0
FOR
SET ORUAP5=$ORDER(^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP5))
if 'ORUAP5
QUIT
Begin DoDot:1
+7 IF $GET(^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP5))'[$$GET1^DIQ(101.43,ORTITE2,.01,"I",)
SET ORTX(ORUAP4)=^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP5)
+8 SET ^TMP("UAP3",$JOB,ORTIFN,ORUAPCN3)=^TMP("UAPTEXT",$JOB,ORTIFN,ORUAP5)
+9 SET ORUAPCN3=ORUAPCN3+1
SET ORUAP4=ORUAP4+1
End DoDot:1
+10 QUIT
DCREF ; Reformat order list in special Discharge View order
+1 ; Active : Hold : Pending : Discontinued : Expired
+2 ; FROM AGET^ORWORR => GET1^ORWORR1 => here
+3 NEW LIST,ORI,ORK,ORX,ORTIFN,ORTITEM,ORCITEM,SUPPLY,ORTSTLST,ORTSTA,ORTIDX,ORCNT,ORICNT
+4 NEW ORTSVPT1
+5 ;
+6 ;Active/Suspended
SET ORTSTLST(6)=1
+7 ;Hold
SET ORTSTLST(3)=2
+8 ;Pending
SET ORTSTLST(5)=3
+9 ;Expired
SET ORTSTLST(7)=4
+10 ;Discontinued
SET ORTSTLST(1)=5
+11 ;
+12 IF $DATA(^TMP("ORR",$JOB,ORLIST,.1))
SET ORTSVPT1=$GET(^TMP("ORR",$JOB,ORLIST,.1))
+13 ;
+14 SET (ORI,ORCNT)=0
+15 FOR
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
if ORI<.1
QUIT
Begin DoDot:1
+16 SET ORX=^TMP("ORR",$JOB,ORLIST,ORI)
+17 SET ORTIFN=$PIECE($PIECE(ORX,U),";")
+18 ;
+19 SET ORTSTA=+$PIECE($GET(^OR(100,ORTIFN,3)),U,3)
+20 SET ORTIDX=$SELECT($DATA(ORTSTLST(ORTSTA)):ORTSTLST(ORTSTA),1:9)
+21 SET ORTITEM=$PIECE($GET(^OR(100,ORTIFN,.1,1,0)),U)
if ORTITEM=""
QUIT
+22 SET ORCITEM=$PIECE($GET(^ORD(101.43,ORTITEM,0)),U)
SET SUPPLY=$PIECE($GET(^("PS")),U,5)
+23 KILL ^TMP("ORR",$JOB,ORLIST,ORI)
+24 SET ORCNT=ORCNT+1
+25 ;tallman lettering fix rtw
SET ORCITEM=$$LOW^XLFSTR(ORCITEM)
+26 SET LIST(ORTIDX,ORCITEM,ORCNT)=ORX
End DoDot:1
+27 ;
+28 SET ORICNT=0
+29 SET ORTIDX=0
FOR
SET ORTIDX=$ORDER(LIST(ORTIDX))
if 'ORTIDX
QUIT
Begin DoDot:1
+30 SET ORCITEM=""
FOR
SET ORCITEM=$ORDER(LIST(ORTIDX,ORCITEM))
if ORCITEM=""
QUIT
Begin DoDot:2
+31 SET ORK=0
FOR
SET ORK=$ORDER(LIST(ORTIDX,ORCITEM,ORK))
if 'ORK
QUIT
Begin DoDot:3
+32 SET ORICNT=ORICNT+1
+33 SET ^TMP("ORR",$JOB,ORLIST,ORICNT)=LIST(ORTIDX,ORCITEM,ORK)
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 IF $DATA(ORTSVPT1)
SET ^TMP("ORR",$JOB,ORLIST,.1)=ORTSVPT1
+36 ;
+37 QUIT
UAPOFF(ORUAPOFF) ;ON/OFF SWITCH
+1 ;
+2 SET ORUAPOFF=$$GET^XPAR("ALL","OR UNIFIED ACTION PROFILE OFF")
+3 QUIT ORUAPOFF
DGROUP(ORDGNAME,ORX) ;RPC ORTO DGROUP to get the DGroup name
+1 SET ORDGNAME=$PIECE($GET(^ORD(100.98,ORX,0)),U,1)
+2 QUIT
UAPLASTX(ORTIFN,ORTITEM) ;
+1 NEW OROTXT,OROTXTX
+2 ; GETS THE LAST ORDERTEXT IEN
SET ORIGTA=$$LASTXT^ORQ12(ORTIFN)
+3 SET OROTXT=$GET(^OR(100,ORTIFN,8,ORIGTA,.1,1,0))
if $EXTRACT(OROTXT,1,3)=">> "
SET OROTXT=$EXTRACT(OROTXT,4,999)
+4 SET ORCITEM=$PIECE($GET(^ORD(101.43,ORTITEM,0)),U)
+5 SET OROTXTX=$EXTRACT(OROTXT,1,2)
SET ORCITEMX=$EXTRACT(ORCITEM,1,2)
+6 if OROTXTX'=ORCITEMX
SET ORCITEM=OROTXT
+7 QUIT
