ORQ12 ; slc/dcm - Get patient orders in context ;Mar 04, 2019@14:04:01
;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215,243,356,441,444,377**;Dec 17, 1997;Build 582
GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
; IFN=ifn of order
; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
; DETAIL=see description in ^ORQ1
;
N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD
S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr
S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
; S FLAGREA=$P(X6,U,7)
S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
D TEXT(.TXT,IFN_";"_$G(ACTOR)) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
Q
;
TEXT(ORTX,ORIFN,WIDTH,ORUGROUP) ; -- Returns text of order ORIFN in ORTX(#) ;RTW UAP
N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA
K ORTX S:'$G(WIDTH) WIDTH=244
S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN
I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1
;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf
S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0))
S ORTX=1,ORTX(1)=""
I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD
G:$G(ORIGVIEW)>1 T1
S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic
S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD
I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed
. I $P(OR3,U,11)=2 S X="Renew" D ADD Q
. N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG Q:$P(OR3,U,11)'=1
. S X="Change" D ADD S ORI=0
. I $G(IOST)'="P-OTHER" D
. .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG)
. .F S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD
. .S X=" to" D ADD
T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0))
N ORUAPVER,OROITEM,ORDG
S ORUAPVER=0 ;RTW UAP SORTING
S ORDG=$$GET1^DIQ(100,ORIFN,23,"E") S:(ORDG["IV")!(ORDG["INFUSION") ORUAPVER=1
I $G(ORUGROUP),ORUAPVER=1 S ORUIFN=ORIFN,ORUTA=ORTA D UAPALPHA^ORTOULT4(.ORTOADD,ORUTA,ORUIFN) Q:$G(ORTOADD) ;RTW UAP INFUSION sorting change
S ORI=0 F S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD
Q:$G(ORIGVIEW)>1 ;contents of global only
S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text
; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD
I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD
I $$GET^XPAR("ALL","OR FLAGGED & WARD COMMENTS") S ORXZ=$D(^OR(100,ORIFN,8,ORACT,5,0)) I ORXZ S X=$G(^OR(100,ORIFN,8,ORACT,5,1,0)) D:$L(X) ADD K ORXZ ;RTW 441
I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason
I $$GET^XPAR("ALL","OR FLAGGED & WARD COMMENTS"),+$G(^OR(100,ORIFN,8,ORACT,3)),$L($P(^OR(100,ORIFN,8,ORACT,3),U,5)) S X="*Flagged - "_$P(^OR(100,ORIFN,8,ORACT,3),U,5)_" - " D ADD ;RTW 441
I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP
Q
;
S ORPAR=$O(^XTV(8989.51,"B","OR FLAGGED & WARD COMMENTS",ORPAR))
LASTXT(IFN) ; -- Returns action with latest text for order IFN
N I,Y S Y=1
S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 S:$O(^(I,.1,0)) Y=I
Q Y
;
LAST(CODE) ; -- Return DA of last occurence of CODE action
N DA
I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry
E S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry
Q DA
;
ACTION(X) ; -- Returns text of action X
N Y
S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"")
Q Y
;
DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am
N Y,D,T,T1,Z
S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM"
S:T1>12 T1=T1-12,Z="PM"
S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z
Q Y
;
NAME(X) ; -- Returns name as Lname,F
N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" ""
S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q
S Y=$$LOWER^VALM1(Y) ; mixed case
Q Y
;
ADD ; -- Add text X to ORTX()
N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space
I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line
I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q
F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1
. I $L(Z)>WIDTH F S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH S ORTX=ORTX+1,Y=0
. S ORTX=ORTX+1,Y=0
Q
;
EXPD ; -- loop through ^XTMP("ORAE" to get expired orders
K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J)
N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP
S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE
F S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE) D
. S IFN=0 F S IFN=$O(^XTMP("ORAE",PAT,TO,TM,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D
.. ;*356 Protect if x-ref dangles.
.. I '$D(^OR(100,IFN)) K ^XTMP("ORAE",PAT,TO,TM,IFN) Q
.. S USTS=$P(^OR(100,IFN,3),U,3)
.. Q:+$G(USTS)'=7 ;quit if order no longer expired
.. S ORREP=$P(^OR(100,IFN,3),U,6)
.. Q:+$G(ORREP)>0 ;quit if order has been replaced
.. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)=""
S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D
.S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D
..S ACTOR=+$P(X3,U,7) D LP1^ORQ11
..;S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11
S ^TMP("ORR",$J,ORLIST,"TOT")=$G(ORLST)
K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J)
Q
GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
; IFN=ifn of order
; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
; DETAIL=see description in ^ORQ1
;
N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS
S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6))
S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3)
S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"")
S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9)
S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0
I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q
S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))=""
I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q
S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT
Q
;
GETSTAT(ITEM) ;
N SIEN
S SIEN=+$P($G(^OR(100,ITEM,3)),U,3) I SIEN=0 Q ""
Q $P($G(^ORD(100.01,SIEN,0)),U)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQ12 7452 printed Oct 16, 2024@18:33:41 Page 2
ORQ12 ; slc/dcm - Get patient orders in context ;Mar 04, 2019@14:04:01
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215,243,356,441,444,377**;Dec 17, 1997;Build 582
GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
+1 ; IFN=ifn of order
+2 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
+3 ; DETAIL=see description in ^ORQ1
+4 ;
+5 NEW X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD
+6 SET ORLST=ORLST+1
SET ^TMP("ORGOTIT",$JOB,IFN,+$GET(ACTOR))=""
+7 IF '$GET(DETAIL)
SET ^TMP("ORR",$JOB,NEWD,ORLST)=IFN_$SELECT($GET(ACTOR):";"_ACTOR,1:"")
QUIT
+8 SET X0=^OR(100,IFN,0)
SET X3=$GET(^(3))
SET X4=$GET(^(4))
SET X6=$GET(^(6))
+9 SET DG=$PIECE(X0,U,11)
SET DG=$PIECE($GET(^ORD(100.98,+DG,0)),U,3)
+10 ;.01^abbr
SET STAT=$SELECT($PIECE(X3,U,3):$PIECE(^ORD(100.01,$PIECE(X3,U,3),0),U,1,2),1:"")
+11 SET ENTERD=$PIECE(X0,U,7)
SET START=$PIECE(X0,U,8)
SET STOP=$PIECE(X0,U,9)
+12 ; S FLAGREA=$P(X6,U,7)
+13 SET ^TMP("ORR",$JOB,NEWD,ORLST)=IFN_$SELECT($GET(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
+14 DO TEXT(.TXT,IFN_";"_$GET(ACTOR))
MERGE ^TMP("ORR",$JOB,NEWD,ORLST,"TX")=TXT
+15 QUIT
+16 ;
TEXT(ORTX,ORIFN,WIDTH,ORUGROUP) ; -- Returns text of order ORIFN in ORTX(#) ;RTW UAP
+1 NEW OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA
+2 KILL ORTX
if '$GET(WIDTH)
SET WIDTH=244
+3 SET ORACT=+$PIECE(ORIFN,";",2)
SET ORIFN=+ORIFN
+4 IF ORACT<1
SET ORACT=+$PIECE($GET(^OR(100,ORIFN,3)),U,7)
if 'ORACT
SET ORACT=1
+5 ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf
+6 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
SET OR6=$GET(^(6))
SET ORX=$GET(^(8,ORACT,0))
+7 SET ORTX=1
SET ORTX(1)=""
+8 IF $PIECE($GET(OR0),U,11)'=""
IF ($PIECE(^ORD(100.98,$PIECE(OR0,U,11),0),U)="NON-VA MEDICATIONS")
SET X="Non-VA"
DO ADD
+9 if $GET(ORIGVIEW)>1
GOTO T1
+10 ;generic
if $PIECE(OR0,U,14)=$ORDER(^DIC(9.4,"C","OR",0))
SET ORTX(1)=">>"
+11 SET X=$$ACTION($PIECE(ORX,U,2))
if $LENGTH(X)
DO ADD
+12 ; Changed or Renewed
IF $PIECE(ORX,U,2)="NW"
IF $PIECE(OR3,U,11)
IF '$GET(ORIGVIEW)
Begin DoDot:1
+13 IF $PIECE(OR3,U,11)=2
SET X="Renew"
DO ADD
QUIT
+14 NEW ORIG,ORIGTA
SET ORIG=+$PIECE(OR3,U,5)
if 'ORIG
QUIT
if $PIECE(OR3,U,11)'=1
QUIT
+15 SET X="Change"
DO ADD
SET ORI=0
+16 IF $GET(IOST)'="P-OTHER"
Begin DoDot:2
+17 ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG)
SET ORIGTA=$$LASTXT(ORIG)
+18 FOR
SET ORI=$ORDER(^OR(100,ORIG,8,ORIGTA,.1,ORI))
if ORI'>0
QUIT
SET X=$GET(^(ORI,0))
if $EXTRACT(X,1,3)=">> "
SET X=$EXTRACT(X,4,999)
DO ADD
+19 SET X=" to"
DO ADD
End DoDot:2
End DoDot:1
T1 SET ORTA=+$PIECE(ORX,U,14)
SET FIRST=+$ORDER(^OR(100,ORIFN,8,ORTA,.1,0))
+1 NEW ORUAPVER,OROITEM,ORDG
+2 ;RTW UAP SORTING
SET ORUAPVER=0
+3 SET ORDG=$$GET1^DIQ(100,ORIFN,23,"E")
if (ORDG["IV")!(ORDG["INFUSION")
SET ORUAPVER=1
+4 ;RTW UAP INFUSION sorting change
IF $GET(ORUGROUP)
IF ORUAPVER=1
SET ORUIFN=ORIFN
SET ORUTA=ORTA
DO UAPALPHA^ORTOULT4(.ORTOADD,ORUTA,ORUIFN)
if $GET(ORTOADD)
QUIT
+5 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100,ORIFN,8,ORTA,.1,ORI))
if ORI'>0
QUIT
SET X=$GET(^(ORI,0))
if (FIRST=ORI)&($EXTRACT(X,1,3)=">> ")
SET X=$EXTRACT(X,4,999)
if $LENGTH(X)
DO ADD
+6 ;contents of global only
if $GET(ORIGVIEW)>1
QUIT
+7 ; additional text
SET DLG=$PIECE(OR0,U,5)
KILL Y
IF DLG
IF $PIECE(DLG,";",2)["101.41"
IF $DATA(^ORD(101.41,+DLG,9))
XECUTE ^(9)
IF $LENGTH($GET(Y))
SET X=Y
DO ADD
+8 ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD
+9 IF $PIECE(ORX,U,4)=2
SET X="*UNSIGNED*"
DO ADD
+10 ;RTW 441
IF $$GET^XPAR("ALL","OR FLAGGED & WARD COMMENTS")
SET ORXZ=$DATA(^OR(100,ORIFN,8,ORACT,5,0))
IF ORXZ
SET X=$GET(^OR(100,ORIFN,8,ORACT,5,1,0))
if $LENGTH(X)
DO ADD
KILL ORXZ
+11 ; DC Reason
IF $PIECE(ORX,U,2)="DC"!("^1^13^"[(U_$PIECE(OR3,U,3)_U))
IF $LENGTH(OR6)
SET X=" <"_$SELECT($LENGTH($PIECE(OR6,U,5)):$PIECE(OR6,U,5),$PIECE(OR6,U,4):$PIECE($GET(^ORD(100.03,+$PIECE(OR6,U,4),0)),U),1:"")_">"
if $LENGTH(X)>3
DO ADD
+12 ;RTW 441
IF $$GET^XPAR("ALL","OR FLAGGED & WARD COMMENTS")
IF +$GET(^OR(100,ORIFN,8,ORACT,3))
IF $LENGTH($PIECE(^OR(100,ORIFN,8,ORACT,3),U,5))
SET X="*Flagged - "_$PIECE(^OR(100,ORIFN,8,ORACT,3),U,5)_" - "
DO ADD
+13 ; Flagged - show in FUP
IF $DATA(XQAID)
IF $GET(ORFLG)=12
SET ORX=$GET(^OR(100,ORIFN,8,ORACT,3))
IF $PIECE(ORX,U)
SET X=" Flagged "_$$DATETIME($PIECE(ORX,U,3))_$SELECT($PIECE(ORX,U,4):" by "_$$NAME($PIECE(ORX,U,4)),1:"")_": "_$PIECE(ORX,U,5)
DO ADD
+14 QUIT
+15 ;
+16 SET ORPAR=$ORDER(^XTV(8989.51,"B","OR FLAGGED & WARD COMMENTS",ORPAR))
LASTXT(IFN) ; -- Returns action with latest text for order IFN
+1 NEW I,Y
SET Y=1
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,IFN,8,I))
if I'>0
QUIT
if $ORDER(^(I,.1,0))
SET Y=I
+3 QUIT Y
+4 ;
LAST(CODE) ; -- Return DA of last occurence of CODE action
+1 NEW DA
+2 ; last entry
IF '$LENGTH($GET(CODE))
SET DA=$ORDER(^OR(100,ORIFN,8,"A"),-1)
+3 ; last CODE entry
IF '$TEST
SET DA=$ORDER(^OR(100,ORIFN,8,"C",CODE,"?"),-1)
+4 QUIT DA
+5 ;
ACTION(X) ; -- Returns text of action X
+1 NEW Y
+2 SET Y=$SELECT(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$GET(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$GET(ORIGVIEW):"Renew",1:"")
+3 QUIT Y
+4 ;
DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am
+1 NEW Y,D,T,T1,Z
+2 SET D=$PIECE(X,".")
SET T=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET T1=$EXTRACT(T,1,2)
SET Z="AM"
+3 if T1>12
SET T1=T1-12
SET Z="PM"
+4 SET Y=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))_"@"_T1_":"_$EXTRACT(T,3,4)_Z
+5 QUIT Y
+6 ;
NAME(X) ; -- Returns name as Lname,F
+1 NEW Y,Z
SET Z=$PIECE($GET(^VA(200,+X,0)),U)
if Z=""
QUIT ""
+2 SET Y=$PIECE(Z,",")_","
FOR I=$FIND(Z,","):1:$LENGTH(Z)
IF $EXTRACT(Z,I)'=" "
SET Y=Y_$EXTRACT(Z,I)
QUIT
+3 ; mixed case
SET Y=$$LOWER^VALM1(Y)
+4 QUIT Y
+5 ;
ADD ; -- Add text X to ORTX()
+1 ;allow for space
NEW I,Y
SET Y=$LENGTH(ORTX(ORTX))
if Y
SET Y=Y+1
+2 ;new line
IF $EXTRACT(X)=" "
IF Y
SET ORTX=ORTX+1
SET ORTX(ORTX)=""
SET Y=0
SET X=$EXTRACT(X,2,999)
+3 IF Y+$LENGTH(X)'>WIDTH
SET ORTX(ORTX)=ORTX(ORTX)_$SELECT(Y:" ",1:"")_X
QUIT
+4 FOR I=1:1:$LENGTH(X," ")
SET Z=$PIECE(X," ",I)
if (Y+$LENGTH(Z))>WIDTH
Begin DoDot:1
+5 IF $LENGTH(Z)>WIDTH
FOR
SET ORTX(ORTX)=$GET(ORTX(ORTX))_$SELECT(Y:" ",1:"")_$EXTRACT(Z,1,WIDTH-Y)
SET Z=$EXTRACT(Z,WIDTH-Y+1,999)
if $LENGTH(Z)'>WIDTH
QUIT
SET ORTX=ORTX+1
SET Y=0
+6 SET ORTX=ORTX+1
SET Y=0
End DoDot:1
SET ORTX(ORTX)=$GET(ORTX(ORTX))_$SELECT(Y:" ",1:"")_Z
SET Y=$LENGTH(ORTX(ORTX))
if Y
SET Y=Y+1
+7 QUIT
+8 ;
EXPD ; -- loop through ^XTMP("ORAE" to get expired orders
+1 KILL ^TMP("ORGOTIT",$JOB),^TMP("ORSORT",$JOB)
+2 NEW TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP
+3 SET NOW=+$EXTRACT($$NOW^XLFDT,1,12)
SET TO=0
SET SDATE=9999999-SDATE
SET EDATE=9999999-EDATE
+4 FOR
SET TO=$ORDER(^XTMP("ORAE",PAT,TO))
if 'TO
QUIT
IF $DATA(ORGRP(TO))
SET TM=EDATE
FOR
SET TM=$ORDER(^XTMP("ORAE",PAT,TO,TM))
if 'TM!(TM>SDATE)!(+TM<EDATE)
QUIT
Begin DoDot:1
+5 SET IFN=0
FOR
SET IFN=$ORDER(^XTMP("ORAE",PAT,TO,TM,IFN))
if 'IFN
QUIT
IF ('$DATA(^TMP("ORGOTIT",$JOB,IFN))!MULT)
Begin DoDot:2
+6 ;*356 Protect if x-ref dangles.
+7 IF '$DATA(^OR(100,IFN))
KILL ^XTMP("ORAE",PAT,TO,TM,IFN)
QUIT
+8 SET USTS=$PIECE(^OR(100,IFN,3),U,3)
+9 ;quit if order no longer expired
if +$GET(USTS)'=7
QUIT
+10 SET ORREP=$PIECE(^OR(100,IFN,3),U,6)
+11 ;quit if order has been replaced
if +$GET(ORREP)>0
QUIT
+12 SET ^TMP("ORSORT",$JOB,9999999-TM,TO,IFN)=""
End DoDot:2
End DoDot:1
+13 SET TM=0
FOR
SET TM=$ORDER(^TMP("ORSORT",$JOB,TM))
if 'TM
QUIT
SET TO=0
FOR
SET TO=$ORDER(^TMP("ORSORT",$JOB,TM,TO))
if 'TO
QUIT
Begin DoDot:1
+14 SET IFN=0
FOR
SET IFN=$ORDER(^TMP("ORSORT",$JOB,TM,TO,IFN))
if 'IFN
QUIT
IF $DATA(^OR(100,IFN,0))
IF $DATA(^(3))
SET X0=^(0)
SET X3=^(3)
Begin DoDot:2
+15 SET ACTOR=+$PIECE(X3,U,7)
DO LP1^ORQ11
+16 ;S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11
End DoDot:2
End DoDot:1
+17 SET ^TMP("ORR",$JOB,ORLIST,"TOT")=$GET(ORLST)
+18 KILL ^TMP("ORSORT",$JOB),^TMP("ORGOTIT",$JOB)
+19 QUIT
GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array
+1 ; IFN=ifn of order
+2 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST)
+3 ; DETAIL=see description in ^ORQ1
+4 ;
+5 NEW X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS
+6 SET X0=^OR(100,IFN,0)
SET X3=$GET(^(3))
SET X4=$GET(^(4))
SET X6=$GET(^(6))
+7 SET DG=$PIECE(X0,U,11)
SET DG=$PIECE($GET(^ORD(100.98,+DG,0)),U,3)
+8 SET STAT=$SELECT($PIECE(X3,U,3):$PIECE(^ORD(100.01,$PIECE(X3,U,3),0),U,1,2),1:"")
+9 SET ENTERD=$PIECE(X0,U,7)
SET START=$PIECE(X0,U,8)
SET STOP=$PIECE(X0,U,9)
+10 SET DCREAS=$PIECE($GET(X6),U,4)
if DCREAS'>0
QUIT
+11 IF DCREAS'=$ORDER(^ORD(100.03,"B","Entered in error",""))
QUIT
+12 SET ORLST=ORLST+1
SET ^TMP("ORGOTIT",$JOB,IFN,+$GET(ACTOR))=""
+13 IF '$GET(DETAIL)
SET ^TMP("ORR",$JOB,NEWD,ORLST)=IFN_$SELECT($GET(ACTOR):";"_ACTOR,1:"")
QUIT
+14 SET ^TMP("ORR",$JOB,NEWD,ORLST)=IFN_$SELECT($GET(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT
+15 DO TEXT(.TXT,IFN)
MERGE ^TMP("ORR",$JOB,NEWD,ORLST,"TX")=TXT
+16 QUIT
+17 ;
GETSTAT(ITEM) ;
+1 NEW SIEN
+2 SET SIEN=+$PIECE($GET(^OR(100,ITEM,3)),U,3)
IF SIEN=0
QUIT ""
+3 QUIT $PIECE($GET(^ORD(100.01,SIEN,0)),U)
