Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORTOULT4

ORTOULT4.m

Go to the documentation of this file.
  1. 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
  1. ;EPIP/RTW For the Unified Action Profile 26 Oct 2016
  1. ;ICR# Type Description
  1. ;----- ---- -------------------------------------
  1. ;1014 Routine LOW^XLFSTR
  1. ;
  1. ; RPC 'ORTO SET UAP FLAG'
  1. ; RPC 'ORTO SETRVW'
  1. ; RPC 'ORTO GETRVW'
  1. Q ; NO DIRECT ENTRY
  1. ;
  1. SETUAPF(ORTOK,ORTUAPF) ;
  1. N ORTUAP
  1. S ORTUAP=+$G(ORTUAPF) ;1=user in UAP view on orders tab, 0=user in any other view
  1. S ORTOK=1 ;dummy return variable
  1. Q
  1. SETRVW(ORTOK,ORTRVW,ORTORIEN) ;
  1. ;
  1. N ORTIEN,ORTLRVW,ORTDT,ORTOK
  1. S ORTIEN=+$G(ORTORIEN),ORTLRVW=0,ORTOK=0
  1. Q:'ORTIEN
  1. Q:'$L($G(ORTRVW))
  1. N %,X,Y D NOW^%DTC S ORTDT=%
  1. N DR,DA,DIE
  1. S DIE="^OR(100,",DA=ORTIEN
  1. S DR=".61///^S X=ORTRVW;.62///^S X=ORTDT;.63///^S X=+$G(DUZ)"
  1. D ^DIE
  1. ;
  1. S ORTOK=1
  1. ;
  1. Q
  1. GETRVW(ORTRVW,ORTORIEN) ;
  1. ;
  1. N ORTIEN
  1. S ORTRVW=0
  1. S ORTIEN=+$G(ORTORIEN)
  1. Q:'ORTIEN
  1. S ORTRVW=$P($G(^OR(100,ORTIEN,.61)),U,1)
  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:"")
  1. Q
  1. ;
  1. REF ; REFORMAT ORDER LIST IN ALPHABETICAL ORDER
  1. ; FROM AGET^ORWORR
  1. N LIST,ORCITEM,ORI,ORJ,ORSUPPLY,ORTOADD,ORTIFN,ORTITEM,ORUI,ORUI2,ORUIEN,ORX,SUPPLY,ORTO,ORIGTA,ORKIEN,ORUAPIV,ORDG
  1. S (ORCNT,ORTO)=0 F ORI=0:0 S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI<.1 D
  1. .S (ORSUPPLY,ORUAPIV,SUPPLY)=0
  1. .S ORX=^TMP("ORR",$J,ORLIST,ORI)
  1. .S ORTIFN=$P($P(ORX,U),";")
  1. .S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U) Q:ORTITEM=""
  1. .S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U) ;Oitem name used for sorting.
  1. .S:$D(^ORD(101.43,ORTITEM,"PS")) ORTO=1,SUPPLY=$P($G(^("PS")),U,5) ;set ORTO is "PS" exists
  1. .S ORDG=$$GET1^DIQ(100,ORTIFN,23,"E") S:(ORDG["IV")!(ORDG["INFUSION") ORUAPIV=1 ;is the service IV or Infusion
  1. .I '$G(ORUAPIV) D UAPLASTX(ORTIFN,ORTITEM) ;all non IV reset ORCITEM if last Oitem/Otext mismatch
  1. .I $G(ORUAPIV) S ORCITEM=$$UAPIV(ORCITEM,ORTIFN) ; multiple Oitem IV no ADDITIVE get last text.
  1. .K ^TMP("ORR",$J,ORLIST,ORI)
  1. .I $$GET1^DIQ(100.98,GROUPS,.01)="PHARMACY UAP" D
  1. .. S ORUI=0 F S ORUI=$O(^ORD(100.98,GROUPS,1,ORUI)) Q:'ORUI D
  1. ... S ORUI2=$G(^ORD(100.98,GROUPS,1,ORUI,0)) I $$GET1^DIQ(100.98,ORUI2,.01)["SUPPL" S ORSUPPLY=1
  1. .Q:(SUPPLY)&'$G(ORSUPPLY)
  1. .S ORCNT=ORCNT+1
  1. .S ORCITEM=$$LOW^XLFSTR(ORCITEM) ;tallman lettering fix rtw
  1. .S LIST(ORCITEM,ORCNT)=ORX
  1. S ORICNT=0
  1. S ORCITEM="" F ORJ=0:0 S ORCITEM=$O(LIST(ORCITEM)) Q:ORCITEM="" D
  1. .F ORK=0:0 S ORK=$O(LIST(ORCITEM,ORK)) Q:ORK<1 D
  1. ..S ORUIEN=$P(LIST(ORCITEM,ORK),";"),ORKIEN=$P($P(LIST(ORCITEM,ORK),U),";",2)
  1. ..S IENS=ORKIEN_","_ORUIEN Q:$$GET1^DIQ(100.008,IENS_",","15")["dc/edit"
  1. ..S ORICNT=ORICNT+1
  1. ..S ^TMP("ORR",$J,ORLIST,ORICNT)=LIST(ORCITEM,ORK)
  1. K ORCNT,ORICNT
  1. Q
  1. ;
  1. UAPIV(ORCITEM,ORTIFN) ;this puts an IV in correct number order by first additive if it has one.
  1. N ORTITMN,ORTADD
  1. S (ORTITMN,ORTOADD)=0 F S ORTITMN=$O(^OR(100,ORTIFN,.1,ORTITMN)) Q:('ORTITMN)!(ORTOADD=1) D ;new sort when INFUSION ORDER
  1. . S ORTITEM=$P($G(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
  1. . Q:+$D(^ORD(101.43,ORTITEM,"PS"))'>0
  1. . S:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ORTOADD=0
  1. . Q:$P(^ORD(101.43,ORTITEM,"PS"),U,3)
  1. . S:$P(^ORD(101.43,ORTITEM,"PS"),U,4) ORTOADD=1 ;end new code to handle infusion orders.
  1. . S ORCITEM=$G(^ORD(101.43,ORTITEM,0),U)
  1. 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)
  1. Q ORCITEM
  1. ;
  1. 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. K ^TMP("UAP",$J),^TMP("UAPTEXT",$J)
  1. N ORUAP1,ORUAP2,ORUTX,ORUTY,ORUAPCN2,ORUAPCN3,ORUAPCNT,ORTMSAVE
  1. S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U),ORTMSAVE=ORTITEM ;set item first in case there is no additive.
  1. S (ORTITMN,ORTOADD)=0 F S ORTITMN=$O(^OR(100,ORTIFN,.1,ORTITMN)) Q:('ORTITMN)!(ORTOADD=1) D ;new sort when INFUSION ORDER
  1. . S ORTITEM=$P($G(^OR(100,ORTIFN,.1,ORTITMN,0)),U)
  1. . Q:+$D(^ORD(101.43,ORTITEM,"PS"))'>0
  1. . S:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ORTOADD=0
  1. . Q:$P(^ORD(101.43,ORTITEM,"PS"),U,3) ;this indicates a base.
  1. . S:$P(^ORD(101.43,ORTITEM,"PS"),U,4) ORTOADD=1 ;end new code to put first additive on top of infusion order display.
  1. S:'$G(ORTOADD) ORTITEM=ORTMSAVE ;code to handle if the IV has no additive.
  1. S ^TMP("UAP",$J,ORTIFN,1)=ORTITEM
  1. S ORUAP1=0,ORUAPCNT=2 F S ORUAP1=$O(^OR(100,ORTIFN,.1,ORUAP1)) Q:'ORUAP1 D
  1. . Q:$P(^OR(100,ORTIFN,.1,ORUAP1,0),U)=ORTITEM
  1. . S ^TMP("UAP",$J,ORTIFN,ORUAPCNT)=$P(^OR(100,ORTIFN,.1,ORUAP1,0),U)
  1. . S ORUAPCNT=ORUAPCNT+1
  1. S ORUAP2=0,ORUAPCN2=1 F S ORUAP2=$O(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2)) Q:'ORUAP2 D
  1. . S ORUTX=$G(^OR(100,ORTIFN,8,ORTA,.1,ORUAP2,0)) S ORUTY=$L(ORUTX)
  1. . I $E(ORUTX)=" ",ORUTY S ORUTX=$E(ORUTX,2,999) ;new line
  1. . S ^TMP("UAPTEXT",$J,ORTIFN,ORUAPCN2)=ORUTX
  1. . S ORUAPCN2=ORUAPCN2+1
  1. Q:'$G(ORTOADD) ORTOADD
  1. UAPRTW ; part of the UAPALPHA above this part takes the original IV list and places it in the new order
  1. K ORTX
  1. N ORUAP3,ORUAP4,ORUAP5,ORTITE2
  1. S ORTITE2=$P(^TMP("UAP",$J,ORTIFN,1),U)
  1. S ORUAP3=0,ORUAP4=1,ORUAPCN3=1 F S ORUAP3=$O(^TMP("UAPTEXT",$J,ORTIFN,ORUAP3)) Q:'ORUAP3 D
  1. . 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
  1. I ORUAP4>1 S ORUAP5=0 F S ORUAP5=$O(^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)) Q:'ORUAP5 D
  1. . I $G(^TMP("UAPTEXT",$J,ORTIFN,ORUAP5))'[$$GET1^DIQ(101.43,ORTITE2,.01,"I",) S ORTX(ORUAP4)=^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)
  1. . S ^TMP("UAP3",$J,ORTIFN,ORUAPCN3)=^TMP("UAPTEXT",$J,ORTIFN,ORUAP5)
  1. . S ORUAPCN3=ORUAPCN3+1,ORUAP4=ORUAP4+1
  1. Q
  1. DCREF ; Reformat order list in special Discharge View order
  1. ; Active : Hold : Pending : Discontinued : Expired
  1. ; FROM AGET^ORWORR => GET1^ORWORR1 => here
  1. N LIST,ORI,ORK,ORX,ORTIFN,ORTITEM,ORCITEM,SUPPLY,ORTSTLST,ORTSTA,ORTIDX,ORCNT,ORICNT
  1. N ORTSVPT1
  1. ;
  1. S ORTSTLST(6)=1 ;Active/Suspended
  1. S ORTSTLST(3)=2 ;Hold
  1. S ORTSTLST(5)=3 ;Pending
  1. S ORTSTLST(7)=4 ;Expired
  1. S ORTSTLST(1)=5 ;Discontinued
  1. ;
  1. I $D(^TMP("ORR",$J,ORLIST,.1)) S ORTSVPT1=$G(^TMP("ORR",$J,ORLIST,.1))
  1. ;
  1. S (ORI,ORCNT)=0
  1. F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI<.1 D
  1. .S ORX=^TMP("ORR",$J,ORLIST,ORI)
  1. .S ORTIFN=$P($P(ORX,U),";")
  1. .;
  1. .S ORTSTA=+$P($G(^OR(100,ORTIFN,3)),U,3)
  1. .S ORTIDX=$S($D(ORTSTLST(ORTSTA)):ORTSTLST(ORTSTA),1:9)
  1. .S ORTITEM=$P($G(^OR(100,ORTIFN,.1,1,0)),U) Q:ORTITEM=""
  1. .S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U),SUPPLY=$P($G(^("PS")),U,5)
  1. .K ^TMP("ORR",$J,ORLIST,ORI)
  1. .S ORCNT=ORCNT+1
  1. .S ORCITEM=$$LOW^XLFSTR(ORCITEM) ;tallman lettering fix rtw
  1. .S LIST(ORTIDX,ORCITEM,ORCNT)=ORX
  1. ;
  1. S ORICNT=0
  1. S ORTIDX=0 F S ORTIDX=$O(LIST(ORTIDX)) Q:'ORTIDX D
  1. . S ORCITEM="" F S ORCITEM=$O(LIST(ORTIDX,ORCITEM)) Q:ORCITEM="" D
  1. . . S ORK=0 F S ORK=$O(LIST(ORTIDX,ORCITEM,ORK)) Q:'ORK D
  1. . . . S ORICNT=ORICNT+1
  1. . . . S ^TMP("ORR",$J,ORLIST,ORICNT)=LIST(ORTIDX,ORCITEM,ORK)
  1. ;
  1. I $D(ORTSVPT1) S ^TMP("ORR",$J,ORLIST,.1)=ORTSVPT1
  1. ;
  1. Q
  1. UAPOFF(ORUAPOFF) ;ON/OFF SWITCH
  1. ;
  1. S ORUAPOFF=$$GET^XPAR("ALL","OR UNIFIED ACTION PROFILE OFF")
  1. Q ORUAPOFF
  1. DGROUP(ORDGNAME,ORX) ;RPC ORTO DGROUP to get the DGroup name
  1. S ORDGNAME=$P($G(^ORD(100.98,ORX,0)),U,1)
  1. Q
  1. UAPLASTX(ORTIFN,ORTITEM) ;
  1. N OROTXT,OROTXTX
  1. S ORIGTA=$$LASTXT^ORQ12(ORTIFN) ; GETS THE LAST ORDERTEXT IEN
  1. S OROTXT=$G(^OR(100,ORTIFN,8,ORIGTA,.1,1,0)) S:$E(OROTXT,1,3)=">> " OROTXT=$E(OROTXT,4,999)
  1. S ORCITEM=$P($G(^ORD(101.43,ORTITEM,0)),U)
  1. S OROTXTX=$E(OROTXT,1,2),ORCITEMX=$E(ORCITEM,1,2)
  1. S:OROTXTX'=ORCITEMX ORCITEM=OROTXT
  1. Q