ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ; Nov 18, 2022@12:08:57
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215,243,280,306,471,444,515,405,577**;Dec 17, 1997;Build 12
;
; Reference to ^SC in ICR #10040
; Reference to ^DPT( in ICR #10035
; Reference to ^VA(200 in ICR #10060
; Reference to ^%DTC in ICR #10000
; Reference to GET^XPAR in ICR #2263
; Reference to XUSER in ICR #2343
; Reference to PSO52EX in ICR #4902
;
GET(LST,DFN,FILTER,GROUPS) ; procedure
Q ; don't call until using same treating specialty logic as AGET
; & until MULT, ORWARD, & ORIGVIEW implemented
; & until the date ranges implemented
; Get orders for patient
; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule
; .LST=tOrder Text (repeating as necessary)
; DFN=Patient ID
; FILTER=# indicates which orders to return, default=2 (current)
; GROUPS=display grp of orders to show (default=ALL)
; -- section uses ORQ1 to get orders list rather than XGET --
N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI
K ^TMP("ORR",$J)
S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1)
S EYE=0 F S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE S IFN=^(EYE) D
. S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
. D GETFLDS
K ^TMP("ORR",$J)
G EXIT
AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT,ORRECIP) ;Get abbrev. event delayed order list for patient
; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm
; see input parameters above
; -- from ORWORR
; -- section uses ORQ1 to get orders list rather than XGET --
K ORUGROUP ;RTW UAP Pharmacist modify indication removal for UAP
N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME
S (PTEVTID,EVTNAME)=""
K ^TMP("ORR",$J),^TMP("ORRJD",$J)
S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2
I $G(GROUPS),($$GET1^DIQ(100.98,GROUPS,.01)="PHARMACY UAP")!($$GET1^DIQ(100.98,GROUPS,.01)="DISCHARGE MEDS") S ORUGROUP=GROUPS ;Capturing GROUPS for later UAP use GETFLDS
S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER
S MULT=$S("^1^6^8^9^10^11^13^14^20^22^29^30^31^32^"[(U_FILTER_U):1,1:0)
I DFN="" D Q
.S ^TMP("ORR",$J,$H)=""
.S ^TMP("ORR",$J,$H,.1)="0^0^0"
I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42
S:'$L($G(DTFROM)) DTFROM=0
S:'$L($G(DTTHRU)) DTTHRU=0
I $P(DTFROM,".")=$P(DTTHRU,"."),$P(DTFROM,".",2)>$P(DTTHRU,".",2),$P(DTTHRU,".",2)="" S $P(DTTHRU,".",2)=2359
S:'$L($G(EVENT)) EVENT=0
I $G(EVTDCREL)="TRUE" D
. D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT)
. D GET2^ORWORR1
E D
. D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT)
. D GET1^ORWORR1
Q
RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event
N EVTDCREL
S EVTDCREL="TRUE"
D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT)
Q
XGET ; retrieval algorithm before all the AC xref changes
N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI
S DFN=DFN_";DPT(",IDX=0,LST=0
I '$G(FILTER) S FILTER=2 ; Default: Current/Active
I $D(GROUPS)=1 D
. S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0))
. D XPND(GROUPS)
I FILTER=1 D DOALL G EXIT ; All
I FILTER=2 D DOCUR G EXIT ; Current
I FILTER=3 S PASS=";1;" ; Discontinued
I FILTER=4 S PASS=";2;7;" ; Comp/Expired
I FILTER=5 S PASS=";3;4;5;6;8;9;" ; Expiring
I FILTER=6 S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity
I FILTER=7 S PASS=";5;" ; Pending
I FILTER=8 Q ; Expanded
I FILTER=9 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Nurse
I FILTER=10 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Clerk
I FILTER=11 S PASS=";3;4;5;6;7;8;11;" ; Unsigned
I FILTER=12 S PASS=";4;" ; Flagged
I FILTER=13 S PASS="" ; Verbal/Phone
I FILTER=14 S PASS="" ; Verbal/Phone Unsigned
D DOGET
EXIT I LST=0 D
. N %,X,%I D NOW^%DTC
. S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found."
Q
DOGET ; Here to filter orders
S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D
. S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D
. . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp
. . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D
. . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes
. . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99
. . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q ;filter by status
. . . ; any other filtering
. . . D GETFLDS
Q
DOALL ; Here to get all orders (no filter by status)
S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D
. S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D
. . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp
. . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D
. . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes
. . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99
. . . D GETFLDS
Q
DOCUR ; Here to get all current orders
N AOCTXT,STS,STOP,%
S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS")
S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400)
D YMD^%DTC S AOCTXT=X_%
S MASK="110000100101110" ; mask out STS=1,2,7,10,12,13,14
S TIME=0 F S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME D
. S IFN=0 F S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN D
. . ; filter out display groups here
. . S ACT=0 F S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT D
. . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0)
. . . S STS=$P(X3,U,3),STOP=$P(X0,U,9)
. . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q
. . . I $P(X8,U,15)=13,($P(X8,U)<AOCTXT) D ACKILL Q
. . . I $P(X8,U,15)=13!($P(X8,U,15)=""),("RN^XX"[$P(X8,U,2)) D ACKILL Q
. . . I $E(MASK,STS),STOP<AOCTXT D ACKILL Q
. . . D GETFLDS
Q
ACKILL ; called only from DOCUR - kill AC xref
; K ^OR(100,"AC",DFN,TIME,IFN,ACT) ; let ORQ1 kill if for now
Q
GET4V11(LST,TXTVW,ORYD,IFNLST) ; get order fields TEMP
G GET41
GET4LST(LST,IFNLST) ; get order fields for list of orders
GET41 N ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA,ORIND ;PKI;*405-IND
N LOC ;IMO
S (IDX,LST,IFNIDX)=0
F S IFNIDX=$O(IFNLST(IFNIDX)) Q:'IFNIDX S IFN=IFNLST(IFNIDX) D
. S ACT=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN
. S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACT,0))
. D GETFLDS
Q
GETBYIFN(LST,IFN) ; procedure
; get fields for single order
; .LST(n)=described above in GET
; IFN=internal entry # for order
I 'IFN Q
N ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA ;PKI
S IDX=0,LST=0,ORYD=0
S X0=$G(^OR(100,+IFN,0)),X3=$G(^(3))
S ACT=$S($P(IFN,";",2):$P(IFN,";",2),$P(X3,U,7):$P(X3,U,7),1:1)
S IFN=+IFN,X8=$G(^OR(100,IFN,8,ACT,0))
GETFLDS ; used by entry points to place order fields into list
; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results
; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC^[DCORIGNAL]^IsPendingDCorder^IsDelayOrder^ParkedStatus^^PackagePrefix
S PRV=$P(X8,U,5) S:'PRV PRV=$P(X8,U,3) S PRV=PRV_U
I PRV S PRV=PRV_$P(^VA(200,+PRV,0),U)
S DEA=$$DEA^XUSER(,+PRV) ; get user DEA info - PKI
S IDX=IDX+1,LST=LST+1,ID=IFN_";"_ACT,ACTID=$P(X8,U,2)
S CSTS=$S($P(X8,U,15):$P(X8,U,15),1:$P(X3,U,3))
I $P(X8,U,15)=10,$P(X3,U,3)=14 S CSTS=14 ;delayed-lapsed order
S STRT=$S($P(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$P(X0,U,8),ACTID="DC":"",1:$P(X8,U)) ;110
S STOP=$S($P(X3,U,3)=11:$$RSTOP,ACTID="HD":$P($G(^OR(100,+IFN,8,ACT,2)),U),1:$P(X0,U,9))
S LST(IDX)="~"_ID_U_$P(X0,U,11)_U_$P(X8,U)_U_STRT_U_STOP_U_CSTS_U_$P(X8,U,4)_U_$P(X8,U,8)_U_$P(X8,U,10)_U_PRV
I '$D(ORUGROUP) S ORUGROUP="" ;RTW Pharmacist modify indication removal for UAP, first time entering CPRS all services view
I $$PARK^PSO52EX(+IFN),ACT=$P(X3,U,7) S $P(LST(IDX),U,25)="active/parked" ;405 set status of prescription tied to current action if it is "PARKED"
I $$SUSP^PSO52EX(+IFN),ACT=$P(X3,U,7) S $P(LST(IDX),U,25)="active/susp" ;405 set status of prescription tied to current action if it is "Suspended"
S $P(LST(IDX),U,13)=+$G(^OR(100,IFN,8,ACT,3)) ; flagged
I +$P(X8,U,8) S $P(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$P(X8,U,8)) ;nurse
I +$P(X8,U,10) S $P(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$P(X8,U,10)) ;clerk
I +$P(X8,U,18) S $P(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$P(X8,U,18)) ;chart review
I $L($G(DEA)) S $P(LST(IDX),U,16)=DEA ;PKI
I $P($G(^OR(100,IFN,8,ACT,2)),"^",5) S $P(LST(IDX),U,18)=$P(^(2),"^",4)
I '$P($G(^OR(100,IFN,8,ACT,2)),"^",5),$P(X0,"^",5) D ;Copy orders PKI fix
. N OI,ORVP,ORCAT,PKG,ORPKIU
. S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI
. S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14)
. S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
. I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
. S ORPKIU=0 I $D(^ORD(100.7,"C",DUZ)) S ORPKIU=1
. D PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,ORPKIU)
. I $E($G(ORY))=2 S $P(LST(IDX),U,18)=ORY
; Change to display location for Clinic Orders, Inpatients, & IV infusion orders.
N DGID,DGNAM
S LOC=""
S DGID=$P(X0,U,11)
I $L(DGID) D
.S DGNAM=$P($G(^ORD(100.98,DGID,0)),U)
.;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D
.S LOC=$P(X0,U,10) ;IMO
.S:+LOC LOC=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO
S $P(LST(IDX),U,19)=LOC ;IMO
S $P(LST(IDX),U,20)=$P($G(^OR(100,IFN,6)),"^",9)
;need a way to determine if order is in an unsigned DC state.
S $P(LST(IDX),U,21)=$S(ACTID="DC":1,1:0)
S $P(LST(IDX),U,22)=$$CHKORD^OREVNTX1(IFN)
D
. N OI,ORVP,ORCAT,PKG,ORCONSUB,ORCSPKG,ORYD
. S ORCSPKG=""
. S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI
. S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14)
. S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
. I PKG=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) S ORCSPKG="O"
. I PKG=$O(^DIC(9.4,"B","UNIT DOSE MEDICATIONS",0)) S ORCSPKG="I"
. I PKG=$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) S ORCSPKG="I"
. I PKG=$O(^DIC(9.4,"B","IV MEDICATIONS",0)) S ORCSPKG="I"
. I ORCSPKG="" S $P(LST(IDX),U,23,24)="0^0" Q
. D CSCHECK^ORDEA(.ORCONSUB,OI,ORCSPKG)
. S $P(LST(IDX),U,23)=$P(ORCONSUB,U)
. S $P(LST(IDX),U,24)=$P(ORCONSUB,U,2)
;
D
. N PKGID
. S PKGID=$P(X0,U,14)
. I PKGID>0 S $P(LST(IDX),U,26)=$P($G(^DIC(9.4,PKGID,0)),U,2)
S ORIGVIEW=$S($G(TXTVW)=0:0,$G(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$P(X8,U)'<ORYD:0,1:1)
K TXT D TEXT^ORQ12(.TXT,ID,255,ORUGROUP) ; optimize later ;RTW PASSING ORUGROUP
I $O(^OR(100,+IFN,2,0)) S LN=$O(TXT(0)),TXT(LN)="+"_TXT(LN)
I $O(^OR(100,+IFN,8,"C","XX",0)),'$G(ORUGROUP) S LN=$O(TXT(0)),TXT(LN)="*"_TXT(LN) ;RTW ORUGROUP
S (LN,ORIND)=0 F S LN=$O(TXT(LN)) Q:'LN S IDX=IDX+1,LST(IDX)="t"_TXT(LN) S:LST(IDX)["Indication" ORIND=IDX ;*405-IND
I $$ISTITR^ORUTL3(+IFN) D
. S ORX="** This Rx contains a separate titration and maintenance component to its schedule and instructions **"
. S IDX=IDX+1
. S LST(IDX)="t"_ORX
I $O(^OR(100,+IFN,8,1,.2,0)) S IDX=IDX+1,LST(IDX)="|" D ;PKI XMLText
. S I=0 F S I=$O(^OR(100,+IFN,8,1,.2,I)) Q:'I S IDX=IDX+1,LST(IDX)="x"_^(I,0)
;*405-IND
D:$O(^OR(100,IFN,4.5,"ID","INDICATION",0))
. N Z S Z=$O(^OR(100,IFN,4.5,"ID","INDICATION",0))
. S Z=$P($G(^OR(100,IFN,4.5,Z,1)),"^")
. I Z]"" S Z="tIndication: "_Z D
. . I $G(ORIND) S LST(ORIND)=Z
. . E S IDX=IDX+1,LST(IDX)=Z
Q
RSTRT() ; return start date from responses
Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","START",0)),1))
RSTOP() ; return stop date from responses
Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","STOP",0)),1))
GETTXT(LST,IFN) ; get text of an order
I $L(IFN,";")=1 S IFN=IFN_";1"
D TEXT^ORQ12(.LST,IFN,255)
Q
XPND(AGRP) ; procedure
; Expand display group (GROUPS defined outside of call)
N I,CHLD
S GROUPS(AGRP)=^ORD(100.98,AGRP,0),I=0
F S I=$O(^ORD(100.98,AGRP,1,I)) Q:'I S CHLD=$P(^(I,0),U) D XPND(CHLD)
Q
GETPKG(Y,IFN) ; get order pkg
N ORDERID,PKGID
Q:+IFN<1
S ORDERID=+IFN,Y=""
S PKGID=$P(OR(100,ORDERID,0),U,14)
S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWORR 12684 printed Oct 16, 2024@18:37:27 Page 2
ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ; Nov 18, 2022@12:08:57
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215,243,280,306,471,444,515,405,577**;Dec 17, 1997;Build 12
+2 ;
+3 ; Reference to ^SC in ICR #10040
+4 ; Reference to ^DPT( in ICR #10035
+5 ; Reference to ^VA(200 in ICR #10060
+6 ; Reference to ^%DTC in ICR #10000
+7 ; Reference to GET^XPAR in ICR #2263
+8 ; Reference to XUSER in ICR #2343
+9 ; Reference to PSO52EX in ICR #4902
+10 ;
GET(LST,DFN,FILTER,GROUPS) ; procedure
+1 ; don't call until using same treating specialty logic as AGET
QUIT
+2 ; & until MULT, ORWARD, & ORIGVIEW implemented
+3 ; & until the date ranges implemented
+4 ; Get orders for patient
+5 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
+6 ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule
+7 ; .LST=tOrder Text (repeating as necessary)
+8 ; DFN=Patient ID
+9 ; FILTER=# indicates which orders to return, default=2 (current)
+10 ; GROUPS=display grp of orders to show (default=ALL)
+11 ; -- section uses ORQ1 to get orders list rather than XGET --
+12 ;PKI
NEW ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA
+13 KILL ^TMP("ORR",$JOB)
+14 SET (IDX,LST)=0
if '$DATA(GROUPS)
SET GROUPS=1
if '$DATA(FILTER)
SET FILTER=2
+15 DO EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1)
+16 SET EYE=0
FOR
SET EYE=$ORDER(^TMP("ORR",$JOB,ORLIST,EYE))
if 'EYE
QUIT
SET IFN=^(EYE)
Begin DoDot:1
+17 SET ACT=$PIECE(IFN,";",2)
SET IFN=+IFN
SET X0=^OR(100,IFN,0)
SET X3=^(3)
SET X8=^(8,ACT,0)
+18 DO GETFLDS
End DoDot:1
+19 KILL ^TMP("ORR",$JOB)
+20 GOTO EXIT
AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT,ORRECIP) ;Get abbrev. event delayed order list for patient
+1 ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm
+2 ; see input parameters above
+3 ; -- from ORWORR
+4 ; -- section uses ORQ1 to get orders list rather than XGET --
+5 ;RTW UAP Pharmacist modify indication removal for UAP
KILL ORUGROUP
+6 NEW ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME
+7 SET (PTEVTID,EVTNAME)=""
+8 KILL ^TMP("ORR",$JOB),^TMP("ORRJD",$JOB)
+9 if '$DATA(GROUPS)
SET GROUPS=1
if '$DATA(FILTER)
SET FILTER=2
+10 ;Capturing GROUPS for later UAP use GETFLDS
IF $GET(GROUPS)
IF ($$GET1^DIQ(100.98,GROUPS,.01)="PHARMACY UAP")!($$GET1^DIQ(100.98,GROUPS,.01)="DISCHARGE MEDS")
SET ORUGROUP=GROUPS
+11 SET ORWTS=+$PIECE(FILTER,U,2)
SET FILTER=+FILTER
+12 SET MULT=$SELECT("^1^6^8^9^10^11^13^14^20^22^29^30^31^32^"[(U_FILTER_U):1,1:0)
+13 IF DFN=""
Begin DoDot:1
+14 SET ^TMP("ORR",$JOB,$HOROLOG)=""
+15 SET ^TMP("ORR",$JOB,$HOROLOG,.1)="0^0^0"
End DoDot:1
QUIT
+16 ; normally ptr to 42
IF $LENGTH($GET(^DPT(DFN,.1)))
SET ORWARD=1
+17 if '$LENGTH($GET(DTFROM))
SET DTFROM=0
+18 if '$LENGTH($GET(DTTHRU))
SET DTTHRU=0
+19 IF $PIECE(DTFROM,".")=$PIECE(DTTHRU,".")
IF $PIECE(DTFROM,".",2)>$PIECE(DTTHRU,".",2)
IF $PIECE(DTTHRU,".",2)=""
SET $PIECE(DTTHRU,".",2)=2359
+20 if '$LENGTH($GET(EVENT))
SET EVENT=0
+21 IF $GET(EVTDCREL)="TRUE"
Begin DoDot:1
+22 DO EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT)
+23 DO GET2^ORWORR1
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 DO EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT)
+26 DO GET1^ORWORR1
End DoDot:1
+27 QUIT
RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event
+1 NEW EVTDCREL
+2 SET EVTDCREL="TRUE"
+3 DO AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT)
+4 QUIT
XGET ; retrieval algorithm before all the AC xref changes
+1 ;PKI
NEW X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS
+2 SET DFN=DFN_";DPT("
SET IDX=0
SET LST=0
+3 ; Default: Current/Active
IF '$GET(FILTER)
SET FILTER=2
+4 IF $DATA(GROUPS)=1
Begin DoDot:1
+5 if 'GROUPS
SET GROUPS=$ORDER(^ORD(100.98,"B",GROUPS,0))
+6 DO XPND(GROUPS)
End DoDot:1
+7 ; All
IF FILTER=1
DO DOALL
GOTO EXIT
+8 ; Current
IF FILTER=2
DO DOCUR
GOTO EXIT
+9 ; Discontinued
IF FILTER=3
SET PASS=";1;"
+10 ; Comp/Expired
IF FILTER=4
SET PASS=";2;7;"
+11 ; Expiring
IF FILTER=5
SET PASS=";3;4;5;6;8;9;"
+12 ; New Activity
IF FILTER=6
SET PASS=";1;2;3;4;5;6;7;8;9;11;"
+13 ; Pending
IF FILTER=7
SET PASS=";5;"
+14 ; Expanded
IF FILTER=8
QUIT
+15 ; Unverified by Nurse
IF FILTER=9
SET PASS=";3;4;5;6;8;9;11;"
+16 ; Unverified by Clerk
IF FILTER=10
SET PASS=";3;4;5;6;8;9;11;"
+17 ; Unsigned
IF FILTER=11
SET PASS=";3;4;5;6;7;8;11;"
+18 ; Flagged
IF FILTER=12
SET PASS=";4;"
+19 ; Verbal/Phone
IF FILTER=13
SET PASS=""
+20 ; Verbal/Phone Unsigned
IF FILTER=14
SET PASS=""
+21 DO DOGET
EXIT IF LST=0
Begin DoDot:1
+1 NEW %,X,%I
DO NOW^%DTC
+2 SET LST(1)="~0^0^"_%_"^^^97"
SET LST(2)="tNo Orders Found."
End DoDot:1
+3 QUIT
DOGET ; Here to filter orders
+1 SET TIME=0
FOR
SET TIME=$ORDER(^OR(100,"AO",DFN,TIME))
if 'TIME
QUIT
Begin DoDot:1
+2 SET DGRP=0
FOR
SET DGRP=$ORDER(^OR(100,"AO",DFN,TIME,DGRP))
if 'DGRP
QUIT
Begin DoDot:2
+3 ;filter by display grp
IF $DATA(GROUPS)>1
if '$DATA(GROUPS(DGRP))
QUIT
+4 SET IFN=0
FOR
SET IFN=$ORDER(^OR(100,"AO",DFN,TIME,DGRP,IFN))
if 'IFN
QUIT
Begin DoDot:3
+5 ;get main nodes
SET X0=^OR(100,IFN,0)
SET X3=^(3)
+6 ;skip veil,chld,sts=99
IF $PIECE(X3,U,8)!$PIECE(X3,U,9)!($PIECE(X3,U,3)=99)
QUIT
+7 ;filter by status
IF $LENGTH(PASS)
IF (PASS'[(";"_$PIECE(X3,U,3)_";"))
QUIT
+8 ; any other filtering
+9 DO GETFLDS
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
DOALL ; Here to get all orders (no filter by status)
+1 SET TIME=0
FOR
SET TIME=$ORDER(^OR(100,"AO",DFN,TIME))
if 'TIME
QUIT
Begin DoDot:1
+2 SET DGRP=0
FOR
SET DGRP=$ORDER(^OR(100,"AO",DFN,TIME,DGRP))
if 'DGRP
QUIT
Begin DoDot:2
+3 ;filter by display grp
IF $DATA(GROUPS)>1
if '$DATA(GROUPS(DGRP))
QUIT
+4 SET IFN=0
FOR
SET IFN=$ORDER(^OR(100,"AO",DFN,TIME,DGRP,IFN))
if 'IFN
QUIT
Begin DoDot:3
+5 ;get main nodes
SET X0=^OR(100,IFN,0)
SET X3=^(3)
+6 ;skip veil,chld,sts=99
IF $PIECE(X3,U,8)!$PIECE(X3,U,9)!($PIECE(X3,U,3)=99)
QUIT
+7 DO GETFLDS
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
DOCUR ; Here to get all current orders
+1 NEW AOCTXT,STS,STOP,%
+2 SET X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS")
+3 SET %H=$HOROLOG
SET X=(%H*86400+$PIECE(%H,",",2))+(X*3600)
SET %H=(X\86400)_","_(X#86400)
+4 DO YMD^%DTC
SET AOCTXT=X_%
+5 ; mask out STS=1,2,7,10,12,13,14
SET MASK="110000100101110"
+6 SET TIME=0
FOR
SET TIME=$ORDER(^OR(100,"AC",DFN,TIME))
if 'TIME
QUIT
Begin DoDot:1
+7 SET IFN=0
FOR
SET IFN=$ORDER(^OR(100,"AC",DFN,TIME,IFN))
if 'IFN
QUIT
Begin DoDot:2
+8 ; filter out display groups here
+9 SET ACT=0
FOR
SET ACT=$ORDER(^OR(100,"AC",DFN,TIME,IFN,ACT))
if 'ACT
QUIT
Begin DoDot:3
+10 SET X0=^OR(100,IFN,0)
SET X3=^(3)
SET X8=^(8,ACT,0)
+11 SET STS=$PIECE(X3,U,3)
SET STOP=$PIECE(X0,U,9)
+12 IF $PIECE(X3,U,8)!$PIECE(X3,U,9)!(STS=99)
QUIT
+13 IF $PIECE(X8,U,15)=13
IF ($PIECE(X8,U)<AOCTXT)
DO ACKILL
QUIT
+14 IF $PIECE(X8,U,15)=13!($PIECE(X8,U,15)="")
IF ("RN^XX"[$PIECE(X8,U,2))
DO ACKILL
QUIT
+15 IF $EXTRACT(MASK,STS)
IF STOP<AOCTXT
DO ACKILL
QUIT
+16 DO GETFLDS
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
ACKILL ; called only from DOCUR - kill AC xref
+1 ; K ^OR(100,"AC",DFN,TIME,IFN,ACT) ; let ORQ1 kill if for now
+2 QUIT
GET4V11(LST,TXTVW,ORYD,IFNLST) ; get order fields TEMP
+1 GOTO GET41
GET4LST(LST,IFNLST) ; get order fields for list of orders
GET41 ;PKI;*405-IND
NEW ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA,ORIND
+1 ;IMO
NEW LOC
+2 SET (IDX,LST,IFNIDX)=0
+3 FOR
SET IFNIDX=$ORDER(IFNLST(IFNIDX))
if 'IFNIDX
QUIT
SET IFN=IFNLST(IFNIDX)
Begin DoDot:1
+4 SET ACT=$SELECT($PIECE(IFN,";",2):$PIECE(IFN,";",2),1:1)
SET IFN=+IFN
+5 SET X0=$GET(^OR(100,IFN,0))
SET X3=$GET(^(3))
SET X8=$GET(^(8,ACT,0))
+6 DO GETFLDS
End DoDot:1
+7 QUIT
GETBYIFN(LST,IFN) ; procedure
+1 ; get fields for single order
+2 ; .LST(n)=described above in GET
+3 ; IFN=internal entry # for order
+4 IF 'IFN
QUIT
+5 ;PKI
NEW ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA
+6 SET IDX=0
SET LST=0
SET ORYD=0
+7 SET X0=$GET(^OR(100,+IFN,0))
SET X3=$GET(^(3))
+8 SET ACT=$SELECT($PIECE(IFN,";",2):$PIECE(IFN,";",2),$PIECE(X3,U,7):$PIECE(X3,U,7),1:1)
+9 SET IFN=+IFN
SET X8=$GET(^OR(100,IFN,8,ACT,0))
GETFLDS ; used by entry points to place order fields into list
+1 ; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results
+2 ; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC^[DCORIGNAL]^IsPendingDCorder^IsDelayOrder^ParkedStatus^^PackagePrefix
+3 SET PRV=$PIECE(X8,U,5)
if 'PRV
SET PRV=$PIECE(X8,U,3)
SET PRV=PRV_U
+4 IF PRV
SET PRV=PRV_$PIECE(^VA(200,+PRV,0),U)
+5 ; get user DEA info - PKI
SET DEA=$$DEA^XUSER(,+PRV)
+6 SET IDX=IDX+1
SET LST=LST+1
SET ID=IFN_";"_ACT
SET ACTID=$PIECE(X8,U,2)
+7 SET CSTS=$SELECT($PIECE(X8,U,15):$PIECE(X8,U,15),1:$PIECE(X3,U,3))
+8 ;delayed-lapsed order
IF $PIECE(X8,U,15)=10
IF $PIECE(X3,U,3)=14
SET CSTS=14
+9 ;110
SET STRT=$SELECT($PIECE(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$PIECE(X0,U,8),ACTID="DC":"",1:$PIECE(X8,U))
+10 SET STOP=$SELECT($PIECE(X3,U,3)=11:$$RSTOP,ACTID="HD":$PIECE($GET(^OR(100,+IFN,8,ACT,2)),U),1:$PIECE(X0,U,9))
+11 SET LST(IDX)="~"_ID_U_$PIECE(X0,U,11)_U_$PIECE(X8,U)_U_STRT_U_STOP_U_CSTS_U_$PIECE(X8,U,4)_U_$PIECE(X8,U,8)_U_$PIECE(X8,U,10)_U_PRV
+12 ;RTW Pharmacist modify indication removal for UAP, first time entering CPRS all services view
IF '$DATA(ORUGROUP)
SET ORUGROUP=""
+13 ;405 set status of prescription tied to current action if it is "PARKED"
IF $$PARK^PSO52EX(+IFN)
IF ACT=$PIECE(X3,U,7)
SET $PIECE(LST(IDX),U,25)="active/parked"
+14 ;405 set status of prescription tied to current action if it is "Suspended"
IF $$SUSP^PSO52EX(+IFN)
IF ACT=$PIECE(X3,U,7)
SET $PIECE(LST(IDX),U,25)="active/susp"
+15 ; flagged
SET $PIECE(LST(IDX),U,13)=+$GET(^OR(100,IFN,8,ACT,3))
+16 ;nurse
IF +$PIECE(X8,U,8)
SET $PIECE(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$PIECE(X8,U,8))
+17 ;clerk
IF +$PIECE(X8,U,10)
SET $PIECE(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$PIECE(X8,U,10))
+18 ;chart review
IF +$PIECE(X8,U,18)
SET $PIECE(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$PIECE(X8,U,18))
+19 ;PKI
IF $LENGTH($GET(DEA))
SET $PIECE(LST(IDX),U,16)=DEA
+20 IF $PIECE($GET(^OR(100,IFN,8,ACT,2)),"^",5)
SET $PIECE(LST(IDX),U,18)=$PIECE(^(2),"^",4)
+21 ;Copy orders PKI fix
IF '$PIECE($GET(^OR(100,IFN,8,ACT,2)),"^",5)
IF $PIECE(X0,"^",5)
Begin DoDot:1
+22 NEW OI,ORVP,ORCAT,PKG,ORPKIU
+23 SET OI=+$ORDER(^OR(100,IFN,4.5,"ID","ORDERABLE",0))
SET OI=+$GET(^OR(100,IFN,4.5,OI,1))
if 'OI
QUIT
+24 SET ORVP=$PIECE(X0,"^",2)
SET PKG=$PIECE(X0,"^",14)
+25 SET ORCAT=$SELECT($LENGTH($PIECE($GET(^DPT(+ORVP,.1)),U)):"I",1:"O")
+26 IF PKG'=$ORDER(^DIC(9.4,"B","OUTPATIENT PHARMACY",0))
QUIT
+27 SET ORPKIU=0
IF $DATA(^ORD(100.7,"C",DUZ))
SET ORPKIU=1
+28 DO PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,ORPKIU)
+29 IF $EXTRACT($GET(ORY))=2
SET $PIECE(LST(IDX),U,18)=ORY
End DoDot:1
+30 ; Change to display location for Clinic Orders, Inpatients, & IV infusion orders.
+31 NEW DGID,DGNAM
+32 SET LOC=""
+33 SET DGID=$PIECE(X0,U,11)
+34 IF $LENGTH(DGID)
Begin DoDot:1
+35 SET DGNAM=$PIECE($GET(^ORD(100.98,DGID,0)),U)
+36 ;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D
+37 ;IMO
SET LOC=$PIECE(X0,U,10)
+38 ;IMO
if +LOC
SET LOC=$PIECE($GET(^SC(+LOC,0)),U)_":"_+LOC
End DoDot:1
+39 ;IMO
SET $PIECE(LST(IDX),U,19)=LOC
+40 SET $PIECE(LST(IDX),U,20)=$PIECE($GET(^OR(100,IFN,6)),"^",9)
+41 ;need a way to determine if order is in an unsigned DC state.
+42 SET $PIECE(LST(IDX),U,21)=$SELECT(ACTID="DC":1,1:0)
+43 SET $PIECE(LST(IDX),U,22)=$$CHKORD^OREVNTX1(IFN)
+44 Begin DoDot:1
+45 NEW OI,ORVP,ORCAT,PKG,ORCONSUB,ORCSPKG,ORYD
+46 SET ORCSPKG=""
+47 SET OI=+$ORDER(^OR(100,IFN,4.5,"ID","ORDERABLE",0))
SET OI=+$GET(^OR(100,IFN,4.5,OI,1))
if 'OI
QUIT
+48 SET ORVP=$PIECE(X0,"^",2)
SET PKG=$PIECE(X0,"^",14)
+49 SET ORCAT=$SELECT($LENGTH($PIECE($GET(^DPT(+ORVP,.1)),U)):"I",1:"O")
+50 IF PKG=$ORDER(^DIC(9.4,"B","OUTPATIENT PHARMACY",0))
SET ORCSPKG="O"
+51 IF PKG=$ORDER(^DIC(9.4,"B","UNIT DOSE MEDICATIONS",0))
SET ORCSPKG="I"
+52 IF PKG=$ORDER(^DIC(9.4,"B","INPATIENT MEDICATIONS",0))
SET ORCSPKG="I"
+53 IF PKG=$ORDER(^DIC(9.4,"B","IV MEDICATIONS",0))
SET ORCSPKG="I"
+54 IF ORCSPKG=""
SET $PIECE(LST(IDX),U,23,24)="0^0"
QUIT
+55 DO CSCHECK^ORDEA(.ORCONSUB,OI,ORCSPKG)
+56 SET $PIECE(LST(IDX),U,23)=$PIECE(ORCONSUB,U)
+57 SET $PIECE(LST(IDX),U,24)=$PIECE(ORCONSUB,U,2)
End DoDot:1
+58 ;
+59 Begin DoDot:1
+60 NEW PKGID
+61 SET PKGID=$PIECE(X0,U,14)
+62 IF PKGID>0
SET $PIECE(LST(IDX),U,26)=$PIECE($GET(^DIC(9.4,PKGID,0)),U,2)
End DoDot:1
+63 SET ORIGVIEW=$SELECT($GET(TXTVW)=0:0,$GET(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$PIECE(X8,U)'<ORYD:0,1:1)
+64 ; optimize later ;RTW PASSING ORUGROUP
KILL TXT
DO TEXT^ORQ12(.TXT,ID,255,ORUGROUP)
+65 IF $ORDER(^OR(100,+IFN,2,0))
SET LN=$ORDER(TXT(0))
SET TXT(LN)="+"_TXT(LN)
+66 ;RTW ORUGROUP
IF $ORDER(^OR(100,+IFN,8,"C","XX",0))
IF '$GET(ORUGROUP)
SET LN=$ORDER(TXT(0))
SET TXT(LN)="*"_TXT(LN)
+67 ;*405-IND
SET (LN,ORIND)=0
FOR
SET LN=$ORDER(TXT(LN))
if 'LN
QUIT
SET IDX=IDX+1
SET LST(IDX)="t"_TXT(LN)
if LST(IDX)["Indication"
SET ORIND=IDX
+68 IF $$ISTITR^ORUTL3(+IFN)
Begin DoDot:1
+69 SET ORX="** This Rx contains a separate titration and maintenance component to its schedule and instructions **"
+70 SET IDX=IDX+1
+71 SET LST(IDX)="t"_ORX
End DoDot:1
+72 ;PKI XMLText
IF $ORDER(^OR(100,+IFN,8,1,.2,0))
SET IDX=IDX+1
SET LST(IDX)="|"
Begin DoDot:1
+73 SET I=0
FOR
SET I=$ORDER(^OR(100,+IFN,8,1,.2,I))
if 'I
QUIT
SET IDX=IDX+1
SET LST(IDX)="x"_^(I,0)
End DoDot:1
+74 ;*405-IND
+75 if $ORDER(^OR(100,IFN,4.5,"ID","INDICATION",0))
Begin DoDot:1
+76 NEW Z
SET Z=$ORDER(^OR(100,IFN,4.5,"ID","INDICATION",0))
+77 SET Z=$PIECE($GET(^OR(100,IFN,4.5,Z,1)),"^")
+78 IF Z]""
SET Z="tIndication: "_Z
Begin DoDot:2
+79 IF $GET(ORIND)
SET LST(ORIND)=Z
+80 IF '$TEST
SET IDX=IDX+1
SET LST(IDX)=Z
End DoDot:2
End DoDot:1
+81 QUIT
RSTRT() ; return start date from responses
+1 QUIT $GET(^OR(100,IFN,4.5,+$ORDER(^OR(100,IFN,4.5,"ID","START",0)),1))
RSTOP() ; return stop date from responses
+1 QUIT $GET(^OR(100,IFN,4.5,+$ORDER(^OR(100,IFN,4.5,"ID","STOP",0)),1))
GETTXT(LST,IFN) ; get text of an order
+1 IF $LENGTH(IFN,";")=1
SET IFN=IFN_";1"
+2 DO TEXT^ORQ12(.LST,IFN,255)
+3 QUIT
XPND(AGRP) ; procedure
+1 ; Expand display group (GROUPS defined outside of call)
+2 NEW I,CHLD
+3 SET GROUPS(AGRP)=^ORD(100.98,AGRP,0)
SET I=0
+4 FOR
SET I=$ORDER(^ORD(100.98,AGRP,1,I))
if 'I
QUIT
SET CHLD=$PIECE(^(I,0),U)
DO XPND(CHLD)
+5 QUIT
GETPKG(Y,IFN) ; get order pkg
+1 NEW ORDERID,PKGID
+2 if +IFN<1
QUIT
+3 SET ORDERID=+IFN
SET Y=""
+4 SET PKGID=$PIECE(OR(100,ORDERID,0),U,14)
+5 if PKGID>0
SET Y=$PIECE(^DIC(9.4,PKGID,0),U,2)
+6 QUIT
