- 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 Feb 18, 2025@23:59:44 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