ORQ3 ;SLC/RBD - Provider Role Tool APIs ;Nov 19, 2020@09:53:02
;;3.0;ORDER ENTRY/RESULTS REPORTING;**453**;Dec 17, 1997;Build 47
;
Q
;
EN(ORY,ORPRIEN,ORDT1,ORDT2) ; Get Qualifying Orders for Provider
;
; This RPC allows retrieval of Patients and Orders for which the
; Provider is the Ordering Provider and the Orders are Signed
;
; Input:
; ORY is the name of the return array
; ORPRIEN identifies the IEN of the Provider to retrieve Orders for
; ORDT1 identifies the start date to start looking from
; ORDT2 identifies the end date to stop looking once reached
; Output:
; Global ^TMP("ORPATRTN",$J,n) where n represents each record found
; starting with record "1"
; Contains data for Patient Name ^ Patient IEN ^ Order IEN ^
; Order Status ^ Order Date
;
N CNT,DFN,OR0,ORIEN,OROBJ,ORPRXFRD,ORPTNM,ORSIGNED,ORTMPDT,ORXFERNM,VADM
N ORT,ORTIN,ORTOU,ORTED,A,ORTRPR,ORTOUT,ORTODAY
S ORTODAY=$P($$NOW^XLFDT,".")
S:'$D(U) U="^" K ^TMP("ORPTINFO",$J),^TMP("ORPATRTN",$J)
S ORY=$NA(^TMP("ORPATRTN",$J))
; Loop through Providers that are Ordering Providers for Orders that have been Signed
S ORTMPDT=ORDT1,ORDT1=ORDT1-.01,ORDT2=ORDT2_".2359"
F S ORDT1=$O(^OR(100,"EPRACDT",ORPRIEN,ORDT1)) Q:ORDT1>ORDT2 Q:ORDT1="" D
. S ORIEN="" F S ORIEN=$O(^OR(100,"EPRACDT",ORPRIEN,ORDT1,ORIEN)) Q:ORIEN="" D
.. S OR0=$G(^OR(100,ORIEN,0)) I OR0="" Q
.. I $$ORDERER^ORQOR2(ORIEN)'=ORPRIEN Q ; skip if not Ord. Prv.
.. S ORSIGNED=($P($G(^OR(100,+ORIEN,8,1,0)),U,4)'=2) Q:'ORSIGNED ; skip if Order not Signed
.. ; if Old Provider already Transferred, skip
.. S ORPRXFRD=0,ORXFERNM=0
.. F S ORXFERNM=$O(^OR(100,ORIEN,11,ORXFERNM)) Q:'ORXFERNM D Q:ORPRXFRD
... N A
... S A=$G(^OR(100,ORIEN,11,ORXFERNM,0))
... I $P(A,U,2)=ORPRIEN,$P(A,"^")'>ORTODAY S ORPRXFRD=1 Q
.. Q:ORPRXFRD=1 S OROBJ=$P(OR0,U,2) Q:OROBJ'["DPT("
.. S DFN=+OROBJ D OERR^VADPT S ORPTNM=$G(VADM(1)) Q:ORPTNM=""
.. S ^TMP("ORPTINFO",$J,ORPTNM,DFN,ORIEN)=""
; Now order through Transferred To Provider index for situation where he/she has
; to Transfer Order to a third Provider (or fourth, etc.) ... only allow last entry
; from ORDER TRANSFERS multiple to be used though.
S ORDT1=ORTMPDT
F S ORDT1=$O(^OR(100,"EPRTRDT",ORPRIEN,ORDT1)) Q:ORDT1="" Q:ORDT1>ORDT2 D
. S ORIEN="" F S ORIEN=$O(^OR(100,"EPRTRDT",ORPRIEN,ORDT1,ORIEN)) Q:ORIEN="" D
.. S OR0=$G(^OR(100,ORIEN,0)) I OR0="" Q
.. S ORPRXFRD=0,ORXFERNM=" ",ORINC=0
.. F S ORXFERNM=$O(^OR(100,ORIEN,11,ORXFERNM),-1) Q:'ORXFERNM D Q:ORPRXFRD Q:ORINC
... N A
... S A=$G(^OR(100,ORIEN,11,ORXFERNM,0))
... I $P(A,U,2)=ORPRIEN,$P(A,"^")'>ORTODAY S ORPRXFRD=1 Q
... I $P(A,"^",3)=ORPRIEN S ORINC=1
.. Q:ORPRXFRD=1 S OROBJ=$P(OR0,U,2) Q:OROBJ'["DPT("
.. S DFN=+OROBJ D OERR^VADPT S ORPTNM=$G(VADM(1)) Q:ORPTNM=""
.. S ^TMP("ORPTINFO",$J,ORPTNM,DFN,ORIEN)=""
; Put in Patient Name, Patient IEN, & Order IEN order to return to GUI
S CNT=0,ORPTNM="" F S ORPTNM=$O(^TMP("ORPTINFO",$J,ORPTNM)) Q:ORPTNM="" D
. N A,ORDDT,ORPDUZ,ORXFD0
. S DFN="" F S DFN=$O(^TMP("ORPTINFO",$J,ORPTNM,DFN)) Q:DFN="" D
.. S ORIEN="" F S ORIEN=$O(^TMP("ORPTINFO",$J,ORPTNM,DFN,ORIEN)) Q:ORIEN="" D
... S CNT=CNT+1
... S A=$O(^OR(100,ORIEN,8,"C","NW","")) Q:'A S ORDDT=$P($G(^OR(100,ORIEN,8,A,0)),"^") I ORDDT="" S ORDDT=$P($G(^OR(100,ORIEN,0)),"^",7)
... S ^TMP("ORPATRTN",$J,CNT)=ORPTNM_U_DFN_U_ORIEN_U_$P($$STATUS^ORQOR2(ORIEN),U,2)_U_$$FMTE^XLFDT(ORDDT)_"^"
... S (ORT,ORTIN,ORTOU,ORTED,ORTRPR,ORPDUZ,ORXFD0)=""
... I $D(^OR(100,ORIEN,11)) D
.... N ORXFN,ORTS
.... S ORXFN=" ",ORTS=0
.... F S ORXFN=$O(^OR(100,ORIEN,11,ORXFN),-1) Q:'ORXFN D Q:ORTS
..... S A=$G(^OR(100,ORIEN,11,ORXFN,0))
..... I $P(A,"^",3)=ORPRIEN,$P(A,"^")'>ORTODAY S ORT=3,ORPDUZ=$P(A,"^",2),ORXFD0=A
..... I $P(A,"^",3)=ORPRIEN,$P(A,"^")>ORTODAY S ORT=2,ORPDUZ=$P(A,"^",2),ORXFD0=A,ORTS=1
..... I $P(A,"^",2)=ORPRIEN,$P(A,"^")>ORTODAY S ORT=1,ORPDUZ=$P(A,"^",3),ORXFD0=A,ORTS=1
.... S ORTED=$P(ORXFD0,"^") ;I $P(ORXFD0,"^")]"" S ORTED=$$FMTE^XLFDT($P(ORXFD0,"^"))
.... S ORTRPR=$$GET1^DIQ(200,ORPDUZ,.01,"E")
.... S ^TMP("ORPATRTN",$J,CNT)=^TMP("ORPATRTN",$J,CNT)_ORT_"^"_ORTED_"^"_ORTRPR_"^"_ORPDUZ
K ^TMP("ORPTINFO",$J)
Q
;
XFER(RESULTS,LST) ; Transfer Orders to New Providers
;
; This RPC allows the Transferring from one Provider to another
; which will create an entry into each order in a List into
; the ORDER TRANSFERS multiple
;
; Input:
; LST(1..n) where each entry contains:
; ORIEN identifies the IEN of the Order to create a
; Reassignment (Transfer) for
; ORPRIEN1 identifies the Transferring From Provider
; ORPRIEN2 identifies the Transferring To Provider
; ORUSER identifies the User requesting the Transfer
; ORDTTM identifies the Transfer Date/Time
; "C" or "O" indicating whether or not the current pending transfer
; should be 'Canceled' or 'Overridden'
; Output:
; Global ^TMP("ORORDRTN",$J,n) where n represents each record
; starting with record "1"
; Contains data for Order IEN ^ Success Flag
; ^ Error Message if Unsuccessful
; Where Success Flag = 0 if Unsuccessful or 1 if Successful
;
N CNT,DA,DIC,DIE,DR,ORDTTM,ORIEN,ORPRIEN1,ORPRIEN2,ORUSER,X,Y,ORTED,DIK,%H
S:'$D(U) U="^" K ^TMP("ORORDRTN",$J)
S RESULTS=$NA(^TMP("ORORDRTN",$J))
S CNT=0 F S CNT=$O(LST(CNT)) Q:CNT="" D
. S ORIEN=$P(LST(CNT),U,1),ORPRIEN1=$P(LST(CNT),U,2)
. S ORPRIEN2=$P(LST(CNT),U,3),ORUSER=$P(LST(CNT),U,4)
. S ORDTTM=$P(LST(CNT),U,5)
. I ORIEN']"" S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Order IEN Blank" Q
. I '$D(^OR(100,ORIEN)) D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Invalid Order IEN"
. I ORPRIEN1']"" D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"From Provider IEN Blank"
. I '$D(^VA(200,ORPRIEN1)) D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"From Provider IEN "_ORPRIEN1_" Invalid"
. I ORPRIEN2']"" D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"To Provider IEN Blank"
. I '$D(^VA(200,ORPRIEN2)) D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"To Provider IEN "_ORPRIEN2_" Invalid"
. I ORUSER']"" D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Transferring User IEN Blank"
. I '$D(^VA(200,ORUSER)) D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Transferring User IEN "_ORUSER_" Invalid"
. I ORDTTM'?7N S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Invalid Transfer Date" Q
. I ORDTTM<$P($$NOW^XLFDT(),".") D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Transfer Date Cannot be in the Past"
. L +^OR(100,ORIEN):0 I '$T D Q
.. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Another user is editing this Order."
. I $P(LST(CNT),"^",6)="C"!($P(LST(CNT),"^",6)="O") D Q:$P(LST(CNT),"^",6)="C"
.. S DA=$O(^OR(100,ORIEN,11," "),-1),ORPRIEN1=$P($G(^OR(100,ORIEN,11,DA,0)),"^",2)
.. S DIK="^OR(100,"_ORIEN_",11,",DA(1)=ORIEN D ^DIK
. S %H=$H D YX^%DTC S ORTED=$P(Y,"@")_"@"_$E($P(Y,"@",2),1,5)
. S DIC="^OR(100,"_ORIEN_",11,",DA(1)=ORIEN,DIC(0)="L",X=ORDTTM
. S DIC("DR")=".02////"_ORPRIEN1_";.03////"_ORPRIEN2
. S DIC("DR")=DIC("DR")_";.04////"_ORUSER_";.05///"_ORTED
. D FILE^DICN
. L -^OR(100,ORIEN)
. I +Y<0 S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_0_U_"Save Unsuccessful" Q
. S ^TMP("ORORDRTN",$J,CNT)=ORIEN_U_1
Q
;
AUTHUSR(ORY) ; Does user have permission to access Provider
; Utilities (Provider Role Tool)
S ORY=0
I $D(^XUSEC("OR PRT ACCESS",DUZ)) S ORY=1
Q
HISTORY(RESULTS,ORIEN) ; Show transfer history of an order
N ORI,CNT,A,ORFDT
Q:'$G(ORIEN) S ORI=0,CNT=0 K RESULTS
F S ORI=$O(^OR(100,ORIEN,11,ORI)) Q:'ORI D
. S CNT=CNT+1,A=$G(^OR(100,ORIEN,11,ORI,0))
. S ORFDT=$$FMTE^XLFDT($P(A,"^"))
. S RESULTS(CNT)=ORFDT_"^"_$$GET1^DIQ(200,$P(A,"^",2)_",",.01)_"^"_$$GET1^DIQ(200,$P(A,"^",3)_",",.01)
Q
SAVEALL(OK,LST) ; save the list of sizing information
N I,NAM,VAL,ORERR
S (I,OK)="" F S I=$O(LST(I)) Q:'I D
. S NAM=$P(LST(I),U,1),VAL=$P(LST(I),U,2)
. D EN^XPAR(DUZ_";VA(200,","ORPRT BOUNDS",NAM,VAL,.ORERR)
. I ORERR S OK=OK_LST(I)_":"_ORERR_U
Q
LOADALL(LST) ; load all the sizing related parameters
N ORBOUNDS,ORWIDTHS,ORCOLMNS,ILST,I S ILST=0
D GETLST^XPAR(.ORBOUNDS,DUZ_";VA(200,","ORPRT BOUNDS")
S I="" F S I=$O(ORBOUNDS(I)) Q:'I S ILST=ILST+1,LST(ILST)=ORBOUNDS(I)
Q
LIST(Y,ORSTART,OREND,ORTYPE) ;
I $G(ORTYPE)=""!($G(OREND)="")!($G(ORSTART)="") Q
N ORINDEX,ORST,OREN,ORA,ORB,ORCNT,DA,DIC,DIQ,DR,ORNM
S ORCNT=0
K ^TMP("ORRET",$J),^TMP("ORLIST",$J)
S ORINDEX=$S(ORTYPE=1:"EPRTA",ORTYPE=2:"EPRTC",1:"") Q:ORINDEX=""
S ORST=ORSTART-.01,OREN=+OREND_".9999"
F S ORST=$O(^OR(100,ORINDEX,ORST)) Q:'ORST Q:ORST>OREN D
. S ORB=0
. F S ORB=$O(^OR(100,ORINDEX,ORST,ORB)) Q:'ORB D
.. S ^TMP("ORLIST",$J,ORB)=""
S ORB=0 F S ORB=$O(^TMP("ORLIST",$J,ORB)) Q:'ORB D
. I ORTYPE=1 D
.. K ORNM
.. S DIC=200,DR=.01,DA=ORB,DIQ="ORNM",DIQ(0)="E" D EN^DIQ1
.. S ORCNT=ORCNT+1,^TMP("ORRET",$J,ORCNT)=ORB_"^"_ORNM(200,ORB,.01,"E")
. I ORTYPE=2 D
.. S ORCNT=ORCNT+1,^TMP("ORRET",$J,ORCNT)=ORB_"^"_$P($G(^DPT(ORB,0)),"^")
S Y=$NA(^TMP("ORRET",$J)) K ^TMP("ORLIST",$J)
Q
DATA(Y,ORTYPE,ORA,ORSTART,OREND) ;
N DA,DIC,DIQ,DR,I,OR011,ORCNT,OREN,ORI,ORIEN,ORINDEX,ORNM,ORPNM,ORS,ORS1,ORST,ORSTATUS
I $G(ORTYPE)=""!($G(ORA)="")!($G(ORSTART)="")!($G(OREND)="") Q
K ^TMP("ORRET",$J)
S ORINDEX=$S(ORTYPE=1:"EPRTB",ORTYPE=2:"EPRTD",1:"") Q:ORINDEX=""
I ORTYPE=2 S ORPNM=$P($G(^DPT(ORA,0)),"^")
S ORST=ORSTART-.01,OREN=+OREND_".9999",ORCNT=0
F S ORST=$O(^OR(100,ORINDEX,ORA,ORST)) Q:'ORST Q:ORST>OREN D
. S ORIEN=""
. F S ORIEN=$O(^OR(100,ORINDEX,ORA,ORST,ORIEN)) Q:'ORIEN D
.. I ORTYPE=1 S ORPNM="" S ORI=$P($G(^OR(100,ORIEN,0)),"^",2) I ORI["DPT" S ORPNM=$P($G(^DPT(+ORI,0)),"^")
.. S ORS=$P($G(^OR(100,ORIEN,3)),"^",3),ORSTATUS="" I ORS]"" S ORSTATUS=$P($G(^ORD(100.01,ORS,0)),"^")
.. S ORS1=0
.. F S ORS1=$O(^OR(100,ORIEN,11,ORS1)) Q:'ORS1 D
... K DA,DR,DIC,ORNM
... S OR011=$G(^OR(100,ORIEN,11,ORS1,0))
... F ORI=2:1:4 S DIC=200,DR=.01,DA=$P(OR011,"^",ORI),DIQ="ORNM",DIQ(0)="E" D EN^DIQ1
... S ORCNT=ORCNT+1,^TMP("ORRET",$J,ORCNT)=ORPNM_"^"_ORIEN_"^"_ORST_"^"_ORSTATUS_"^"_$P(OR011,"^")_"^"
... F I=2:1:4 S ^TMP("ORRET",$J,ORCNT)=^TMP("ORRET",$J,ORCNT)_ORNM(200,$P(OR011,"^",I),.01,"E")_"^"
... S ^TMP("ORRET",$J,ORCNT)=^TMP("ORRET",$J,ORCNT)_$P(OR011,"^",5)
S Y=$NA(^TMP("ORRET",$J))
Q
AUDIT(Y,ORAUST,ORAUEN) ;
N DA,DIC,DIQ,DR,I,OR011,ORCNT,ORDFN,OREN,ORI,ORIEN,ORMORE,ORNM,ORPNM,ORS,ORS1,ORST,ORSTATUS,OROD
I $G(ORAUST)=""!($G(ORAUEN)="") Q
K ^TMP("ORRET",$J)
S ORST=ORAUST-.01,OREN=+ORAUEN_".9999",ORCNT=0
F S ORST=$O(^OR(100,"EPRTAU",ORST)) Q:'ORST Q:ORST>OREN D
. S ORIEN=""
. F S ORIEN=$O(^OR(100,"EPRTAU",ORST,ORIEN)) Q:'ORIEN D
.. S ORPNM="" S ORDFN=$P($G(^OR(100,ORIEN,0)),"^",2) I ORDFN["DPT" S ORPNM=$P($G(^DPT(+ORDFN,0)),"^")
.. S ORS=$P($G(^OR(100,ORIEN,3)),"^",3),ORSTATUS="" I ORS]"" S ORSTATUS=$P($G(^ORD(100.01,ORS,0)),"^")
.. S OROD=$P($G(^OR(100,ORIEN,0)),"^",7)
.. S ORS1=0
.. F S ORS1=$O(^OR(100,"EPRTAU",ORST,ORIEN,ORS1)) Q:'ORS1 D
... K DA,DR,DIC,ORNM
... S OR011=$G(^OR(100,ORIEN,11,ORS1,0))
... F ORI=2:1:4 S DIC=200,DR=.01,DA=$P(OR011,"^",ORI),DIQ="ORNM",DIQ(0)="E" D EN^DIQ1
... S ORMORE=$S($O(^OR(100,ORIEN,11,ORS1)):1,1:0)
... S ORCNT=ORCNT+1,^TMP("ORRET",$J,ORCNT)=ORPNM_";"_+ORDFN_"^"_ORIEN_"^"_OROD_"^"_ORSTATUS_"^"_$P(OR011,"^")_"^"
... F I=2:1:4 S ^TMP("ORRET",$J,ORCNT)=^TMP("ORRET",$J,ORCNT)_$G(ORNM(200,$P(OR011,"^",I),.01,"E"))_"^"
... S ^TMP("ORRET",$J,ORCNT)=^TMP("ORRET",$J,ORCNT)_$P(OR011,"^",5)_"^"_ORMORE
S Y=$NA(^TMP("ORRET",$J))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQ3 11792 printed Sep 23, 2025@20:09:30 Page 2
ORQ3 ;SLC/RBD - Provider Role Tool APIs ;Nov 19, 2020@09:53:02
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**453**;Dec 17, 1997;Build 47
+2 ;
+3 QUIT
+4 ;
EN(ORY,ORPRIEN,ORDT1,ORDT2) ; Get Qualifying Orders for Provider
+1 ;
+2 ; This RPC allows retrieval of Patients and Orders for which the
+3 ; Provider is the Ordering Provider and the Orders are Signed
+4 ;
+5 ; Input:
+6 ; ORY is the name of the return array
+7 ; ORPRIEN identifies the IEN of the Provider to retrieve Orders for
+8 ; ORDT1 identifies the start date to start looking from
+9 ; ORDT2 identifies the end date to stop looking once reached
+10 ; Output:
+11 ; Global ^TMP("ORPATRTN",$J,n) where n represents each record found
+12 ; starting with record "1"
+13 ; Contains data for Patient Name ^ Patient IEN ^ Order IEN ^
+14 ; Order Status ^ Order Date
+15 ;
+16 NEW CNT,DFN,OR0,ORIEN,OROBJ,ORPRXFRD,ORPTNM,ORSIGNED,ORTMPDT,ORXFERNM,VADM
+17 NEW ORT,ORTIN,ORTOU,ORTED,A,ORTRPR,ORTOUT,ORTODAY
+18 SET ORTODAY=$PIECE($$NOW^XLFDT,".")
+19 if '$DATA(U)
SET U="^"
KILL ^TMP("ORPTINFO",$JOB),^TMP("ORPATRTN",$JOB)
+20 SET ORY=$NAME(^TMP("ORPATRTN",$JOB))
+21 ; Loop through Providers that are Ordering Providers for Orders that have been Signed
+22 SET ORTMPDT=ORDT1
SET ORDT1=ORDT1-.01
SET ORDT2=ORDT2_".2359"
+23 FOR
SET ORDT1=$ORDER(^OR(100,"EPRACDT",ORPRIEN,ORDT1))
if ORDT1>ORDT2
QUIT
if ORDT1=""
QUIT
Begin DoDot:1
+24 SET ORIEN=""
FOR
SET ORIEN=$ORDER(^OR(100,"EPRACDT",ORPRIEN,ORDT1,ORIEN))
if ORIEN=""
QUIT
Begin DoDot:2
+25 SET OR0=$GET(^OR(100,ORIEN,0))
IF OR0=""
QUIT
+26 ; skip if not Ord. Prv.
IF $$ORDERER^ORQOR2(ORIEN)'=ORPRIEN
QUIT
+27 ; skip if Order not Signed
SET ORSIGNED=($PIECE($GET(^OR(100,+ORIEN,8,1,0)),U,4)'=2)
if 'ORSIGNED
QUIT
+28 ; if Old Provider already Transferred, skip
+29 SET ORPRXFRD=0
SET ORXFERNM=0
+30 FOR
SET ORXFERNM=$ORDER(^OR(100,ORIEN,11,ORXFERNM))
if 'ORXFERNM
QUIT
Begin DoDot:3
+31 NEW A
+32 SET A=$GET(^OR(100,ORIEN,11,ORXFERNM,0))
+33 IF $PIECE(A,U,2)=ORPRIEN
IF $PIECE(A,"^")'>ORTODAY
SET ORPRXFRD=1
QUIT
End DoDot:3
if ORPRXFRD
QUIT
+34 if ORPRXFRD=1
QUIT
SET OROBJ=$PIECE(OR0,U,2)
if OROBJ'["DPT("
QUIT
+35 SET DFN=+OROBJ
DO OERR^VADPT
SET ORPTNM=$GET(VADM(1))
if ORPTNM=""
QUIT
+36 SET ^TMP("ORPTINFO",$JOB,ORPTNM,DFN,ORIEN)=""
End DoDot:2
End DoDot:1
+37 ; Now order through Transferred To Provider index for situation where he/she has
+38 ; to Transfer Order to a third Provider (or fourth, etc.) ... only allow last entry
+39 ; from ORDER TRANSFERS multiple to be used though.
+40 SET ORDT1=ORTMPDT
+41 FOR
SET ORDT1=$ORDER(^OR(100,"EPRTRDT",ORPRIEN,ORDT1))
if ORDT1=""
QUIT
if ORDT1>ORDT2
QUIT
Begin DoDot:1
+42 SET ORIEN=""
FOR
SET ORIEN=$ORDER(^OR(100,"EPRTRDT",ORPRIEN,ORDT1,ORIEN))
if ORIEN=""
QUIT
Begin DoDot:2
+43 SET OR0=$GET(^OR(100,ORIEN,0))
IF OR0=""
QUIT
+44 SET ORPRXFRD=0
SET ORXFERNM=" "
SET ORINC=0
+45 FOR
SET ORXFERNM=$ORDER(^OR(100,ORIEN,11,ORXFERNM),-1)
if 'ORXFERNM
QUIT
Begin DoDot:3
+46 NEW A
+47 SET A=$GET(^OR(100,ORIEN,11,ORXFERNM,0))
+48 IF $PIECE(A,U,2)=ORPRIEN
IF $PIECE(A,"^")'>ORTODAY
SET ORPRXFRD=1
QUIT
+49 IF $PIECE(A,"^",3)=ORPRIEN
SET ORINC=1
End DoDot:3
if ORPRXFRD
QUIT
if ORINC
QUIT
+50 if ORPRXFRD=1
QUIT
SET OROBJ=$PIECE(OR0,U,2)
if OROBJ'["DPT("
QUIT
+51 SET DFN=+OROBJ
DO OERR^VADPT
SET ORPTNM=$GET(VADM(1))
if ORPTNM=""
QUIT
+52 SET ^TMP("ORPTINFO",$JOB,ORPTNM,DFN,ORIEN)=""
End DoDot:2
End DoDot:1
+53 ; Put in Patient Name, Patient IEN, & Order IEN order to return to GUI
+54 SET CNT=0
SET ORPTNM=""
FOR
SET ORPTNM=$ORDER(^TMP("ORPTINFO",$JOB,ORPTNM))
if ORPTNM=""
QUIT
Begin DoDot:1
+55 NEW A,ORDDT,ORPDUZ,ORXFD0
+56 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("ORPTINFO",$JOB,ORPTNM,DFN))
if DFN=""
QUIT
Begin DoDot:2
+57 SET ORIEN=""
FOR
SET ORIEN=$ORDER(^TMP("ORPTINFO",$JOB,ORPTNM,DFN,ORIEN))
if ORIEN=""
QUIT
Begin DoDot:3
+58 SET CNT=CNT+1
+59 SET A=$ORDER(^OR(100,ORIEN,8,"C","NW",""))
if 'A
QUIT
SET ORDDT=$PIECE($GET(^OR(100,ORIEN,8,A,0)),"^")
IF ORDDT=""
SET ORDDT=$PIECE($GET(^OR(100,ORIEN,0)),"^",7)
+60 SET ^TMP("ORPATRTN",$JOB,CNT)=ORPTNM_U_DFN_U_ORIEN_U_$PIECE($$STATUS^ORQOR2(ORIEN),U,2)_U_$$FMTE^XLFDT(ORDDT)_"^"
+61 SET (ORT,ORTIN,ORTOU,ORTED,ORTRPR,ORPDUZ,ORXFD0)=""
+62 IF $DATA(^OR(100,ORIEN,11))
Begin DoDot:4
+63 NEW ORXFN,ORTS
+64 SET ORXFN=" "
SET ORTS=0
+65 FOR
SET ORXFN=$ORDER(^OR(100,ORIEN,11,ORXFN),-1)
if 'ORXFN
QUIT
Begin DoDot:5
+66 SET A=$GET(^OR(100,ORIEN,11,ORXFN,0))
+67 IF $PIECE(A,"^",3)=ORPRIEN
IF $PIECE(A,"^")'>ORTODAY
SET ORT=3
SET ORPDUZ=$PIECE(A,"^",2)
SET ORXFD0=A
+68 IF $PIECE(A,"^",3)=ORPRIEN
IF $PIECE(A,"^")>ORTODAY
SET ORT=2
SET ORPDUZ=$PIECE(A,"^",2)
SET ORXFD0=A
SET ORTS=1
+69 IF $PIECE(A,"^",2)=ORPRIEN
IF $PIECE(A,"^")>ORTODAY
SET ORT=1
SET ORPDUZ=$PIECE(A,"^",3)
SET ORXFD0=A
SET ORTS=1
End DoDot:5
if ORTS
QUIT
+70 ;I $P(ORXFD0,"^")]"" S ORTED=$$FMTE^XLFDT($P(ORXFD0,"^"))
SET ORTED=$PIECE(ORXFD0,"^")
+71 SET ORTRPR=$$GET1^DIQ(200,ORPDUZ,.01,"E")
+72 SET ^TMP("ORPATRTN",$JOB,CNT)=^TMP("ORPATRTN",$JOB,CNT)_ORT_"^"_ORTED_"^"_ORTRPR_"^"_ORPDUZ
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+73 KILL ^TMP("ORPTINFO",$JOB)
+74 QUIT
+75 ;
XFER(RESULTS,LST) ; Transfer Orders to New Providers
+1 ;
+2 ; This RPC allows the Transferring from one Provider to another
+3 ; which will create an entry into each order in a List into
+4 ; the ORDER TRANSFERS multiple
+5 ;
+6 ; Input:
+7 ; LST(1..n) where each entry contains:
+8 ; ORIEN identifies the IEN of the Order to create a
+9 ; Reassignment (Transfer) for
+10 ; ORPRIEN1 identifies the Transferring From Provider
+11 ; ORPRIEN2 identifies the Transferring To Provider
+12 ; ORUSER identifies the User requesting the Transfer
+13 ; ORDTTM identifies the Transfer Date/Time
+14 ; "C" or "O" indicating whether or not the current pending transfer
+15 ; should be 'Canceled' or 'Overridden'
+16 ; Output:
+17 ; Global ^TMP("ORORDRTN",$J,n) where n represents each record
+18 ; starting with record "1"
+19 ; Contains data for Order IEN ^ Success Flag
+20 ; ^ Error Message if Unsuccessful
+21 ; Where Success Flag = 0 if Unsuccessful or 1 if Successful
+22 ;
+23 NEW CNT,DA,DIC,DIE,DR,ORDTTM,ORIEN,ORPRIEN1,ORPRIEN2,ORUSER,X,Y,ORTED,DIK,%H
+24 if '$DATA(U)
SET U="^"
KILL ^TMP("ORORDRTN",$JOB)
+25 SET RESULTS=$NAME(^TMP("ORORDRTN",$JOB))
+26 SET CNT=0
FOR
SET CNT=$ORDER(LST(CNT))
if CNT=""
QUIT
Begin DoDot:1
+27 SET ORIEN=$PIECE(LST(CNT),U,1)
SET ORPRIEN1=$PIECE(LST(CNT),U,2)
+28 SET ORPRIEN2=$PIECE(LST(CNT),U,3)
SET ORUSER=$PIECE(LST(CNT),U,4)
+29 SET ORDTTM=$PIECE(LST(CNT),U,5)
+30 IF ORIEN']""
SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Order IEN Blank"
QUIT
+31 IF '$DATA(^OR(100,ORIEN))
Begin DoDot:2
+32 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Invalid Order IEN"
End DoDot:2
QUIT
+33 IF ORPRIEN1']""
Begin DoDot:2
+34 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"From Provider IEN Blank"
End DoDot:2
QUIT
+35 IF '$DATA(^VA(200,ORPRIEN1))
Begin DoDot:2
+36 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"From Provider IEN "_ORPRIEN1_" Invalid"
End DoDot:2
QUIT
+37 IF ORPRIEN2']""
Begin DoDot:2
+38 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"To Provider IEN Blank"
End DoDot:2
QUIT
+39 IF '$DATA(^VA(200,ORPRIEN2))
Begin DoDot:2
+40 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"To Provider IEN "_ORPRIEN2_" Invalid"
End DoDot:2
QUIT
+41 IF ORUSER']""
Begin DoDot:2
+42 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Transferring User IEN Blank"
End DoDot:2
QUIT
+43 IF '$DATA(^VA(200,ORUSER))
Begin DoDot:2
+44 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Transferring User IEN "_ORUSER_" Invalid"
End DoDot:2
QUIT
+45 IF ORDTTM'?7N
SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Invalid Transfer Date"
QUIT
+46 IF ORDTTM<$PIECE($$NOW^XLFDT(),".")
Begin DoDot:2
+47 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Transfer Date Cannot be in the Past"
End DoDot:2
QUIT
+48 LOCK +^OR(100,ORIEN):0
IF '$TEST
Begin DoDot:2
+49 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Another user is editing this Order."
End DoDot:2
QUIT
+50 IF $PIECE(LST(CNT),"^",6)="C"!($PIECE(LST(CNT),"^",6)="O")
Begin DoDot:2
+51 SET DA=$ORDER(^OR(100,ORIEN,11," "),-1)
SET ORPRIEN1=$PIECE($GET(^OR(100,ORIEN,11,DA,0)),"^",2)
+52 SET DIK="^OR(100,"_ORIEN_",11,"
SET DA(1)=ORIEN
DO ^DIK
End DoDot:2
if $PIECE(LST(CNT),"^",6)="C"
QUIT
+53 SET %H=$HOROLOG
DO YX^%DTC
SET ORTED=$PIECE(Y,"@")_"@"_$EXTRACT($PIECE(Y,"@",2),1,5)
+54 SET DIC="^OR(100,"_ORIEN_",11,"
SET DA(1)=ORIEN
SET DIC(0)="L"
SET X=ORDTTM
+55 SET DIC("DR")=".02////"_ORPRIEN1_";.03////"_ORPRIEN2
+56 SET DIC("DR")=DIC("DR")_";.04////"_ORUSER_";.05///"_ORTED
+57 DO FILE^DICN
+58 LOCK -^OR(100,ORIEN)
+59 IF +Y<0
SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_0_U_"Save Unsuccessful"
QUIT
+60 SET ^TMP("ORORDRTN",$JOB,CNT)=ORIEN_U_1
End DoDot:1
+61 QUIT
+62 ;
AUTHUSR(ORY) ; Does user have permission to access Provider
+1 ; Utilities (Provider Role Tool)
+2 SET ORY=0
+3 IF $DATA(^XUSEC("OR PRT ACCESS",DUZ))
SET ORY=1
+4 QUIT
HISTORY(RESULTS,ORIEN) ; Show transfer history of an order
+1 NEW ORI,CNT,A,ORFDT
+2 if '$GET(ORIEN)
QUIT
SET ORI=0
SET CNT=0
KILL RESULTS
+3 FOR
SET ORI=$ORDER(^OR(100,ORIEN,11,ORI))
if 'ORI
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
SET A=$GET(^OR(100,ORIEN,11,ORI,0))
+5 SET ORFDT=$$FMTE^XLFDT($PIECE(A,"^"))
+6 SET RESULTS(CNT)=ORFDT_"^"_$$GET1^DIQ(200,$PIECE(A,"^",2)_",",.01)_"^"_$$GET1^DIQ(200,$PIECE(A,"^",3)_",",.01)
End DoDot:1
+7 QUIT
SAVEALL(OK,LST) ; save the list of sizing information
+1 NEW I,NAM,VAL,ORERR
+2 SET (I,OK)=""
FOR
SET I=$ORDER(LST(I))
if 'I
QUIT
Begin DoDot:1
+3 SET NAM=$PIECE(LST(I),U,1)
SET VAL=$PIECE(LST(I),U,2)
+4 DO EN^XPAR(DUZ_";VA(200,","ORPRT BOUNDS",NAM,VAL,.ORERR)
+5 IF ORERR
SET OK=OK_LST(I)_":"_ORERR_U
End DoDot:1
+6 QUIT
LOADALL(LST) ; load all the sizing related parameters
+1 NEW ORBOUNDS,ORWIDTHS,ORCOLMNS,ILST,I
SET ILST=0
+2 DO GETLST^XPAR(.ORBOUNDS,DUZ_";VA(200,","ORPRT BOUNDS")
+3 SET I=""
FOR
SET I=$ORDER(ORBOUNDS(I))
if 'I
QUIT
SET ILST=ILST+1
SET LST(ILST)=ORBOUNDS(I)
+4 QUIT
LIST(Y,ORSTART,OREND,ORTYPE) ;
+1 IF $GET(ORTYPE)=""!($GET(OREND)="")!($GET(ORSTART)="")
QUIT
+2 NEW ORINDEX,ORST,OREN,ORA,ORB,ORCNT,DA,DIC,DIQ,DR,ORNM
+3 SET ORCNT=0
+4 KILL ^TMP("ORRET",$JOB),^TMP("ORLIST",$JOB)
+5 SET ORINDEX=$SELECT(ORTYPE=1:"EPRTA",ORTYPE=2:"EPRTC",1:"")
if ORINDEX=""
QUIT
+6 SET ORST=ORSTART-.01
SET OREN=+OREND_".9999"
+7 FOR
SET ORST=$ORDER(^OR(100,ORINDEX,ORST))
if 'ORST
QUIT
if ORST>OREN
QUIT
Begin DoDot:1
+8 SET ORB=0
+9 FOR
SET ORB=$ORDER(^OR(100,ORINDEX,ORST,ORB))
if 'ORB
QUIT
Begin DoDot:2
+10 SET ^TMP("ORLIST",$JOB,ORB)=""
End DoDot:2
End DoDot:1
+11 SET ORB=0
FOR
SET ORB=$ORDER(^TMP("ORLIST",$JOB,ORB))
if 'ORB
QUIT
Begin DoDot:1
+12 IF ORTYPE=1
Begin DoDot:2
+13 KILL ORNM
+14 SET DIC=200
SET DR=.01
SET DA=ORB
SET DIQ="ORNM"
SET DIQ(0)="E"
DO EN^DIQ1
+15 SET ORCNT=ORCNT+1
SET ^TMP("ORRET",$JOB,ORCNT)=ORB_"^"_ORNM(200,ORB,.01,"E")
End DoDot:2
+16 IF ORTYPE=2
Begin DoDot:2
+17 SET ORCNT=ORCNT+1
SET ^TMP("ORRET",$JOB,ORCNT)=ORB_"^"_$PIECE($GET(^DPT(ORB,0)),"^")
End DoDot:2
End DoDot:1
+18 SET Y=$NAME(^TMP("ORRET",$JOB))
KILL ^TMP("ORLIST",$JOB)
+19 QUIT
DATA(Y,ORTYPE,ORA,ORSTART,OREND) ;
+1 NEW DA,DIC,DIQ,DR,I,OR011,ORCNT,OREN,ORI,ORIEN,ORINDEX,ORNM,ORPNM,ORS,ORS1,ORST,ORSTATUS
+2 IF $GET(ORTYPE)=""!($GET(ORA)="")!($GET(ORSTART)="")!($GET(OREND)="")
QUIT
+3 KILL ^TMP("ORRET",$JOB)
+4 SET ORINDEX=$SELECT(ORTYPE=1:"EPRTB",ORTYPE=2:"EPRTD",1:"")
if ORINDEX=""
QUIT
+5 IF ORTYPE=2
SET ORPNM=$PIECE($GET(^DPT(ORA,0)),"^")
+6 SET ORST=ORSTART-.01
SET OREN=+OREND_".9999"
SET ORCNT=0
+7 FOR
SET ORST=$ORDER(^OR(100,ORINDEX,ORA,ORST))
if 'ORST
QUIT
if ORST>OREN
QUIT
Begin DoDot:1
+8 SET ORIEN=""
+9 FOR
SET ORIEN=$ORDER(^OR(100,ORINDEX,ORA,ORST,ORIEN))
if 'ORIEN
QUIT
Begin DoDot:2
+10 IF ORTYPE=1
SET ORPNM=""
SET ORI=$PIECE($GET(^OR(100,ORIEN,0)),"^",2)
IF ORI["DPT"
SET ORPNM=$PIECE($GET(^DPT(+ORI,0)),"^")
+11 SET ORS=$PIECE($GET(^OR(100,ORIEN,3)),"^",3)
SET ORSTATUS=""
IF ORS]""
SET ORSTATUS=$PIECE($GET(^ORD(100.01,ORS,0)),"^")
+12 SET ORS1=0
+13 FOR
SET ORS1=$ORDER(^OR(100,ORIEN,11,ORS1))
if 'ORS1
QUIT
Begin DoDot:3
+14 KILL DA,DR,DIC,ORNM
+15 SET OR011=$GET(^OR(100,ORIEN,11,ORS1,0))
+16 FOR ORI=2:1:4
SET DIC=200
SET DR=.01
SET DA=$PIECE(OR011,"^",ORI)
SET DIQ="ORNM"
SET DIQ(0)="E"
DO EN^DIQ1
+17 SET ORCNT=ORCNT+1
SET ^TMP("ORRET",$JOB,ORCNT)=ORPNM_"^"_ORIEN_"^"_ORST_"^"_ORSTATUS_"^"_$PIECE(OR011,"^")_"^"
+18 FOR I=2:1:4
SET ^TMP("ORRET",$JOB,ORCNT)=^TMP("ORRET",$JOB,ORCNT)_ORNM(200,$PIECE(OR011,"^",I),.01,"E")_"^"
+19 SET ^TMP("ORRET",$JOB,ORCNT)=^TMP("ORRET",$JOB,ORCNT)_$PIECE(OR011,"^",5)
End DoDot:3
End DoDot:2
End DoDot:1
+20 SET Y=$NAME(^TMP("ORRET",$JOB))
+21 QUIT
AUDIT(Y,ORAUST,ORAUEN) ;
+1 NEW DA,DIC,DIQ,DR,I,OR011,ORCNT,ORDFN,OREN,ORI,ORIEN,ORMORE,ORNM,ORPNM,ORS,ORS1,ORST,ORSTATUS,OROD
+2 IF $GET(ORAUST)=""!($GET(ORAUEN)="")
QUIT
+3 KILL ^TMP("ORRET",$JOB)
+4 SET ORST=ORAUST-.01
SET OREN=+ORAUEN_".9999"
SET ORCNT=0
+5 FOR
SET ORST=$ORDER(^OR(100,"EPRTAU",ORST))
if 'ORST
QUIT
if ORST>OREN
QUIT
Begin DoDot:1
+6 SET ORIEN=""
+7 FOR
SET ORIEN=$ORDER(^OR(100,"EPRTAU",ORST,ORIEN))
if 'ORIEN
QUIT
Begin DoDot:2
+8 SET ORPNM=""
SET ORDFN=$PIECE($GET(^OR(100,ORIEN,0)),"^",2)
IF ORDFN["DPT"
SET ORPNM=$PIECE($GET(^DPT(+ORDFN,0)),"^")
+9 SET ORS=$PIECE($GET(^OR(100,ORIEN,3)),"^",3)
SET ORSTATUS=""
IF ORS]""
SET ORSTATUS=$PIECE($GET(^ORD(100.01,ORS,0)),"^")
+10 SET OROD=$PIECE($GET(^OR(100,ORIEN,0)),"^",7)
+11 SET ORS1=0
+12 FOR
SET ORS1=$ORDER(^OR(100,"EPRTAU",ORST,ORIEN,ORS1))
if 'ORS1
QUIT
Begin DoDot:3
+13 KILL DA,DR,DIC,ORNM
+14 SET OR011=$GET(^OR(100,ORIEN,11,ORS1,0))
+15 FOR ORI=2:1:4
SET DIC=200
SET DR=.01
SET DA=$PIECE(OR011,"^",ORI)
SET DIQ="ORNM"
SET DIQ(0)="E"
DO EN^DIQ1
+16 SET ORMORE=$SELECT($ORDER(^OR(100,ORIEN,11,ORS1)):1,1:0)
+17 SET ORCNT=ORCNT+1
SET ^TMP("ORRET",$JOB,ORCNT)=ORPNM_";"_+ORDFN_"^"_ORIEN_"^"_OROD_"^"_ORSTATUS_"^"_$PIECE(OR011,"^")_"^"
+18 FOR I=2:1:4
SET ^TMP("ORRET",$JOB,ORCNT)=^TMP("ORRET",$JOB,ORCNT)_$GET(ORNM(200,$PIECE(OR011,"^",I),.01,"E"))_"^"
+19 SET ^TMP("ORRET",$JOB,ORCNT)=^TMP("ORRET",$JOB,ORCNT)_$PIECE(OR011,"^",5)_"^"_ORMORE
End DoDot:3
End DoDot:2
End DoDot:1
+20 SET Y=$NAME(^TMP("ORRET",$JOB))
+21 QUIT
