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