ORWDX ;SLC/KCM,REV,JLI - Order dialog utilities ;Feb 16, 2024@13:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246,243,283,296,280,306,350,424,421,461,490,397,377,539,405,588,601**;Dec 17, 1997;Build 1
;Per VA Directive 6402, this routine should not be modified.
;
;Reference to ^DIC(9.4 in ICR #2058
;Reference to ^SC( in ICR #10040
;Reference to ^LAB(60,D0,8,0 in ICR #2387
;
ORDITM(Y,FROM,DIR,XREF,QOCALL,ACCESS) ; Subset of orderable items
; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
N I,IEN,CNT,X,DTXT,CURTM,DEFROUTE,ORDSTART,CHKLAB,CODE,ORTESTIEN,ORLABOK
N ORLRFILTER
S ORDSTART=$O(^ORD(101.43,XREF,FROM))
S DEFROUTE="",CHKLAB=(XREF="S.LAB")&($L($G(ACCESS))>1)
S ORLRFILTER=$S(XREF="S.LAB":+$$GET^XPAR("SYS","OR LR ORDERABLE ITEM FILTERING",1,"I"),1:0)
S QOCALL=+$G(QOCALL)
S I=0,CNT=44,CURTM=$$NOW^XLFDT
F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D
. S IEN="" F S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN D
. . S X=^ORD(101.43,XREF,FROM,IEN)
. . I +$P(X,U,3),$P(X,U,3)<CURTM Q
. . I 'QOCALL,$P(X,U,5) Q
. . I QOCALL,$P(X,U,5),FROM'=ORDSTART Q
. . I CHKLAB D I ACCESS'[(U_CODE_U) Q
. . . S CODE=$P($G(^ORD(101.43,IEN,"LR")),U,6)
. . . I CODE="" S CODE="CH"
. . I ORLRFILTER,'$$CHKLABDIV^ORWDX2(IEN,XREF) Q
. . S I=I+1
. . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
. . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
Q
;
ODITMBC(Y,XREF,ODLST) ;
N CNT,NM,XRF
S CNT=0,NM=0,XRF=XREF
F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT))
Q
FNDINFO(Y,ODIEN) ;
D FNDINFO^ORWDX1(.Y,.ODIEN)
Q
DLGDEF(LST,DLG) ; Format mapping for a dlg
D DLGDEF^ORWDX1(.LST,.DLG)
Q
DLGQUIK(LST,QO) ;(NOT USED)
D LOADRSP(.LST,QO)
Q
LOADRSP(LST,RSPID,TRANS,ORREN) ; Load responses from 101.41 or 100
; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick
; X123456;1 = change order, 134 = quick dialog
; ORREN: If ORREN is set to 1 then RSPID is the order getting renewed
N I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC,ORADDTITRRESP
S ROOT=""
K ^TMP($J,"ORWDX LOADRSP","QO SAVE")
I +RSPID=$P(RSPID,"-",1) D
.S ^TMP($J,"ORWDX LOADRSP","QO SAVE")=+RSPID
I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2
I $E(RSPID)="X" D G XROOT^ORWDX2
. N ORIFN
. S ORIFN=+$P(RSPID,"X",2)
. S ROOT="^OR(100,"_ORIFN_",4.5)"
. I $$ISTITR^ORUTL3(ORIFN) D TITR(ORIFN,$G(ORREN),.ROOT,.ORADDTITRRESP)
I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2
Q:ROOT=""
G XROOT^ORWDX2
;
TITR(ORIFN,ORREN,ROOT,ORADDTITRRESP) ; Special handling for outpatient med titration orders
N ORRESPIEN
;
; for titration renewals, only renew maintenance portion
I $G(ORREN) D
. S ROOT=$$GETTMP^ORWTITR(ORIFN)
;
; when changing an old titration order (pre-v32b/p405), check
; if it's marked as titrating in back-door, but not in 100
I '$G(ORREN) D
. S ORRESPIEN=$O(^OR(100,ORIFN,4.5,"ID","TITR",0))
. I ORRESPIEN,$D(^OR(100,ORIFN,4.5,+ORRESPIEN,1)) Q
. S ORADDTITRRESP=1 ; add titration response in ORWDX2
Q
;
SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF,INDICAT) ;
; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment
;
D SAVE^ORWDX3 ;moved to ORWDX3 because of routine size
;
Q
;
SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc
N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK,OR3
N ORLR,ORLAB,I ;*539
S ORWERR="",ORIX=0,LOC=LOC_";SC("
;*539
F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1
F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D Q:ORWERR]""
. S (ORIFN,ORWLST(ORIX))=ORIENS(ORIX)
. S PTEVT=$P(^OR(100,+ORIFN,0),U,17)
. I PTEVT D
.. I $D(EVENT(PTEVT)) S LOCK=1 Q
.. S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)=""
. I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
. S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1
. S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
. ;*539 Add Protocol Invocation for Lab
. I $G(ORLR(+$P(^OR(100,+ORIFN,0),U,14))),'$G(ORLAB) D
.. I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1
. I $D(^OR(100,+ORIFN,8,ORDA,0)) D
.. S ORSIGST=$P($G(^(0)),U,4),ORNATURE=$P($G(^(0)),U,12) ;naked references refer to OR(100,+ORIFN,8,ORDA on line above
. S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2)
. I OK,$G(LOCK) D
.. S OR3=$G(^OR(100,+ORIFN,3)) I $P(OR3,"^",3)'=10!($P(OR3,"^",9)]"") D UNLK1^ORX2(ORIENS(ORIX)) Q ;order already released or has a parent
.. S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location
.. S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty
.. D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195
. I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
. E D
.. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17)
.. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2)
. S X="RS"
. S $P(ORWLST(ORIX),U,2)=X
I $G(ORLAB) D BTS^ORMBLD(ORVP) ;*539 Finish Protocol Invocation
S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195
Q
SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign
; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code
; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order
SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I
S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0
F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1
S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D
. S X=ORWREC(ORWI),ORWERR=""
. S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4)
. S ORBEF=0
. I '$D(^OR(100,+ORDERID,0)) Q
. I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15)
. S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR)
. S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR)
. I $L(ORWERR) S ORWERR="1^"_ORWERR
. I '$L(ORWERR) D
.. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start
... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1
.. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2)
.. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID)
. S ORWLST(ORWI)=ORDERID,X=""
. I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q
. I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R"
. I ORWSIG'=2 S X=X_"S"
. S $P(ORWLST(ORWI),U,2)=X
I $G(ORLAB) D BTS^ORMBLD(ORVP)
I $D(ORWLST)>9 D
. N I,A
. S I=0 F S I=$O(ORWLST(I)) Q:I="" S A=$G(ORWLST(I)) I A["Invalid Procedure, Inactive, no Imaging Type" D SM^ORWDX2(A)
Q
DLGID(VAL,ORIFN) ; return dlg IEN for order
S VAL=$P(^OR(100,+ORIFN,0),U,5)
S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0)
Q
FORMID(VAL,ORIFN) ; Base dlg FormID for an order
N DLG
S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5)
Q:$P(DLG,";",2)'="ORD(101.41,"
D FORMID^ORWDXM(.VAL,+DLG)
Q
AGAIN(VAL,DLG) ; return true to keep dlg for another order
S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9)
Q
DGRP(VAL,DLG) ; Display grp pointer for a dlg
S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm
S VAL=$P($G(^ORD(101.41,DLG,0)),U,5)
Q
DGNM(VAL,NM) ; Display grp pointer for name
S VAL=$O(^ORD(100.98,"B",NM,0))
Q
WRLST(LST,LOC) ; List of dlgs for writing orders
G WRLST1^ORWDX1
MSG(LST,IEN) ; Msg text for orderable item
N I
S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0)
Q
DISMSG(VAL,IEN) ; Disabled mge for ordering dlg
S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3)
Q
LOCK(OK,DFN) ; Attempt to lock pt for ordering
S OK=$$LOCK^ORX2(DFN)
Q
UNLOCK(OK,DFN) ; Unlock pt for ordering
D UNLOCK^ORX2(DFN) S OK=1
Q
LOCKORD(OK,ORIFN) ; Attempt to lock order
S OK=$$LOCK1^ORX2(ORIFN)
Q
UNLKORD(OK,ORIFN) ; Unlock order
D UNLK1^ORX2(ORIFN) S OK=1
Q
UNLKOTH(OK,ORIFN) ; Unlock pt not by this session
K ^XTMP("ORPTLK-"_ORIFN) S OK=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDX 8251 printed Jan 18, 2025@03:36:59 Page 2
ORWDX ;SLC/KCM,REV,JLI - Order dialog utilities ;Feb 16, 2024@13:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246,243,283,296,280,306,350,424,421,461,490,397,377,539,405,588,601**;Dec 17, 1997;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Reference to ^DIC(9.4 in ICR #2058
+5 ;Reference to ^SC( in ICR #10040
+6 ;Reference to ^LAB(60,D0,8,0 in ICR #2387
+7 ;
ORDITM(Y,FROM,DIR,XREF,QOCALL,ACCESS) ; Subset of orderable items
+1 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
+2 NEW I,IEN,CNT,X,DTXT,CURTM,DEFROUTE,ORDSTART,CHKLAB,CODE,ORTESTIEN,ORLABOK
+3 NEW ORLRFILTER
+4 SET ORDSTART=$ORDER(^ORD(101.43,XREF,FROM))
+5 SET DEFROUTE=""
SET CHKLAB=(XREF="S.LAB")&($LENGTH($GET(ACCESS))>1)
+6 SET ORLRFILTER=$SELECT(XREF="S.LAB":+$$GET^XPAR("SYS","OR LR ORDERABLE ITEM FILTERING",1,"I"),1:0)
+7 SET QOCALL=+$GET(QOCALL)
+8 SET I=0
SET CNT=44
SET CURTM=$$NOW^XLFDT
+9 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^ORD(101.43,XREF,FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+10 SET IEN=""
FOR
SET IEN=$ORDER(^ORD(101.43,XREF,FROM,IEN),DIR)
if 'IEN
QUIT
Begin DoDot:2
+11 SET X=^ORD(101.43,XREF,FROM,IEN)
+12 IF +$PIECE(X,U,3)
IF $PIECE(X,U,3)<CURTM
QUIT
+13 IF 'QOCALL
IF $PIECE(X,U,5)
QUIT
+14 IF QOCALL
IF $PIECE(X,U,5)
IF FROM'=ORDSTART
QUIT
+15 IF CHKLAB
Begin DoDot:3
+16 SET CODE=$PIECE($GET(^ORD(101.43,IEN,"LR")),U,6)
+17 IF CODE=""
SET CODE="CH"
End DoDot:3
IF ACCESS'[(U_CODE_U)
QUIT
+18 IF ORLRFILTER
IF '$$CHKLABDIV^ORWDX2(IEN,XREF)
QUIT
+19 SET I=I+1
+20 IF 'X
SET Y(I)=IEN_U_$PIECE(X,U,2)_U_$PIECE(X,U,2)
+21 IF '$TEST
SET Y(I)=IEN_U_$PIECE(X,U,2)_$CHAR(9)_"<"_$PIECE(X,U,4)_">"_U_$PIECE(X,U,4)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
ODITMBC(Y,XREF,ODLST) ;
+1 NEW CNT,NM,XRF
+2 SET CNT=0
SET NM=0
SET XRF=XREF
+3 FOR
SET CNT=$ORDER(ODLST(CNT))
if 'CNT
QUIT
DO FNDINFO(.Y,ODLST(CNT))
+4 QUIT
FNDINFO(Y,ODIEN) ;
+1 DO FNDINFO^ORWDX1(.Y,.ODIEN)
+2 QUIT
DLGDEF(LST,DLG) ; Format mapping for a dlg
+1 DO DLGDEF^ORWDX1(.LST,.DLG)
+2 QUIT
DLGQUIK(LST,QO) ;(NOT USED)
+1 DO LOADRSP(.LST,QO)
+2 QUIT
LOADRSP(LST,RSPID,TRANS,ORREN) ; Load responses from 101.41 or 100
+1 ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick
+2 ; X123456;1 = change order, 134 = quick dialog
+3 ; ORREN: If ORREN is set to 1 then RSPID is the order getting renewed
+4 NEW I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC,ORADDTITRRESP
+5 SET ROOT=""
+6 KILL ^TMP($JOB,"ORWDX LOADRSP","QO SAVE")
+7 IF +RSPID=$PIECE(RSPID,"-",1)
Begin DoDot:1
+8 SET ^TMP($JOB,"ORWDX LOADRSP","QO SAVE")=+RSPID
End DoDot:1
+9 IF RSPID["-"
SET ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")"
GOTO XROOT^ORWDX2
+10 IF $EXTRACT(RSPID)="X"
Begin DoDot:1
+11 NEW ORIFN
+12 SET ORIFN=+$PIECE(RSPID,"X",2)
+13 SET ROOT="^OR(100,"_ORIFN_",4.5)"
+14 IF $$ISTITR^ORUTL3(ORIFN)
DO TITR(ORIFN,$GET(ORREN),.ROOT,.ORADDTITRRESP)
End DoDot:1
GOTO XROOT^ORWDX2
+15 IF +RSPID=RSPID
SET ROOT="^ORD(101.41,"_+RSPID_",6)"
GOTO XROOT^ORWDX2
+16 if ROOT=""
QUIT
+17 GOTO XROOT^ORWDX2
+18 ;
TITR(ORIFN,ORREN,ROOT,ORADDTITRRESP) ; Special handling for outpatient med titration orders
+1 NEW ORRESPIEN
+2 ;
+3 ; for titration renewals, only renew maintenance portion
+4 IF $GET(ORREN)
Begin DoDot:1
+5 SET ROOT=$$GETTMP^ORWTITR(ORIFN)
End DoDot:1
+6 ;
+7 ; when changing an old titration order (pre-v32b/p405), check
+8 ; if it's marked as titrating in back-door, but not in 100
+9 IF '$GET(ORREN)
Begin DoDot:1
+10 SET ORRESPIEN=$ORDER(^OR(100,ORIFN,4.5,"ID","TITR",0))
+11 IF ORRESPIEN
IF $DATA(^OR(100,ORIFN,4.5,+ORRESPIEN,1))
QUIT
+12 ; add titration response in ORWDX2
SET ORADDTITRRESP=1
End DoDot:1
+13 QUIT
+14 ;
SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF,INDICAT) ;
+1 ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
+2 ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment
+3 ;
+4 ;moved to ORWDX3 because of routine size
DO SAVE^ORWDX3
+5 ;
+6 QUIT
+7 ;
SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc
+1 NEW OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK,OR3
+2 ;*539
NEW ORLR,ORLAB,I
+3 SET ORWERR=""
SET ORIX=0
SET LOC=LOC_";SC("
+4 ;*539
+5 FOR I="LR","VBEC"
SET X=+$ORDER(^DIC(9.4,"C",I,0))
if X
SET ORLR(X)=1
+6 FOR
SET ORIX=$ORDER(ORIENS(ORIX))
if 'ORIX
QUIT
Begin DoDot:1
+7 SET (ORIFN,ORWLST(ORIX))=ORIENS(ORIX)
+8 SET PTEVT=$PIECE(^OR(100,+ORIFN,0),U,17)
+9 IF PTEVT
Begin DoDot:2
+10 IF $DATA(EVENT(PTEVT))
SET LOCK=1
QUIT
+11 SET LOCK=$$LCKEVT^ORX2(PTEVT)
if LOCK
SET EVENT(PTEVT)=""
End DoDot:2
+12 IF 'LOCK
SET ORWERR="1^delayed event is locked - another user is processing orders for this event"
SET ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR
QUIT
+13 SET ORDA=$PIECE(ORIFN,";",2)
if 'ORDA
SET ORDA=1
+14 SET ORVP=$PIECE($GET(^OR(100,+ORIFN,0)),U,2)
+15 ;*539 Add Protocol Invocation for Lab
+16 IF $GET(ORLR(+$PIECE(^OR(100,+ORIFN,0),U,14)))
IF '$GET(ORLAB)
Begin DoDot:2
+17 IF $LENGTH($TEXT(BHS^ORMBLD))
DO BHS^ORMBLD(ORVP)
SET ORLAB=1
End DoDot:2
+18 IF $DATA(^OR(100,+ORIFN,8,ORDA,0))
Begin DoDot:2
+19 ;naked references refer to OR(100,+ORIFN,8,ORDA on line above
SET ORSIGST=$PIECE($GET(^(0)),U,4)
SET ORNATURE=$PIECE($GET(^(0)),U,12)
End DoDot:2
+20 SET OK=$$LOCK1^ORX2(ORIFN)
IF 'OK
SET ORWERR="1^"_$PIECE(OK,U,2)
+21 IF OK
IF $GET(LOCK)
Begin DoDot:2
+22 ;order already released or has a parent
SET OR3=$GET(^OR(100,+ORIFN,3))
IF $PIECE(OR3,"^",3)'=10!($PIECE(OR3,"^",9)]"")
DO UNLK1^ORX2(ORIENS(ORIX))
QUIT
+23 ;set location
if $GET(LOC)
SET $PIECE(^OR(100,+ORIFN,0),U,10)=LOC
+24 ;set specialty
if $GET(TS)
SET $PIECE(^OR(100,+ORIFN,0),U,13)=TS
+25 ;add ,LOCK to if statement for 195
DO EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR)
DO UNLK1^ORX2(ORIENS(ORIX))
End DoDot:2
+26 IF $LENGTH(ORWERR)
SET ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR
QUIT
+27 IF '$TEST
Begin DoDot:2
+28 SET PTEVT=$PIECE($GET(^OR(100,+ORIENS(ORIX),0)),U,17)
+29 if $$TYPE^OREVNTX(PTEVT)="M"
DO SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2)
End DoDot:2
+30 SET X="RS"
+31 SET $PIECE(ORWLST(ORIX),U,2)=X
End DoDot:1
if ORWERR]""
QUIT
+32 ;*539 Finish Protocol Invocation
IF $GET(ORLAB)
DO BTS^ORMBLD(ORVP)
+33 ;195
SET J=0
FOR
SET J=$ORDER(EVENT(J))
if '+J
QUIT
DO UNLEVT^ORX2(J)
+34 QUIT
SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign
+1 ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code
+2 ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order
SEND1 NEW ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I
+1 SET ORVP=DFN_";DPT("
SET ORL=ORL_";SC("
SET ORL(2)=ORL
SET ORWLST=0
+2 FOR I="LR","VBEC"
SET X=+$ORDER(^DIC(9.4,"C",I,0))
if X
SET ORLR(X)=1
+3 SET ORWI=0
FOR
SET ORWI=$ORDER(ORWREC(ORWI))
if 'ORWI
QUIT
Begin DoDot:1
+4 SET X=ORWREC(ORWI)
SET ORWERR=""
+5 SET ORDERID=$PIECE(X,U)
SET ORWSIG=$PIECE(X,U,2)
SET ORWREL=$PIECE(X,U,3)
SET ORWNATR=$PIECE(X,U,4)
+6 SET ORBEF=0
+7 IF '$DATA(^OR(100,+ORDERID,0))
QUIT
+8 IF $DATA(^OR(100,+ORDERID,8,+$PIECE(ORDERID,";",2),0))
SET ORBEF=$PIECE(^OR(100,+ORDERID,8,+$PIECE(ORDERID,";",2),0),U,15)
+9 if $DATA(^OR(100,+ORDERID,8,+$PIECE(ORDERID,";",2),0))
SET ORWNATR=$SELECT($PIECE(^OR(100,+ORDERID,8,+$PIECE(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR)
+10 SET ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR)
+11 IF $LENGTH(ORWERR)
SET ORWERR="1^"_ORWERR
+12 IF '$LENGTH(ORWERR)
Begin DoDot:2
+13 ; lab batch start
IF $GET(ORLR(+$PIECE(^OR(100,+ORDERID,0),U,14)))
IF '$GET(ORLAB)
Begin DoDot:3
+14 IF $LENGTH($TEXT(BHS^ORMBLD))
DO BHS^ORMBLD(ORVP)
SET ORLAB=1
End DoDot:3
+15 NEW OK
SET OK=$$LOCK1^ORX2(ORDERID)
IF 'OK
SET ORWERR="1^"_$PIECE(OK,U,2)
+16 IF OK
DO EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR)
DO UNLK1^ORX2(ORDERID)
End DoDot:2
+17 SET ORWLST(ORWI)=ORDERID
SET X=""
+18 IF $LENGTH(ORWERR)
SET ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR
QUIT
+19 IF ORWREL
IF ((ORBEF=10)!(ORBEF=11))
IF ($PIECE(^OR(100,+ORDERID,3),U,3)'=10)
SET X="R"
+20 IF ORWSIG'=2
SET X=X_"S"
+21 SET $PIECE(ORWLST(ORWI),U,2)=X
End DoDot:1
+22 IF $GET(ORLAB)
DO BTS^ORMBLD(ORVP)
+23 IF $DATA(ORWLST)>9
Begin DoDot:1
+24 NEW I,A
+25 SET I=0
FOR
SET I=$ORDER(ORWLST(I))
if I=""
QUIT
SET A=$GET(ORWLST(I))
IF A["Invalid Procedure, Inactive, no Imaging Type"
DO SM^ORWDX2(A)
End DoDot:1
+26 QUIT
DLGID(VAL,ORIFN) ; return dlg IEN for order
+1 SET VAL=$PIECE(^OR(100,+ORIFN,0),U,5)
+2 SET VAL=$SELECT($PIECE(VAL,";",2)="ORD(101.41,":+VAL,1:0)
+3 QUIT
FORMID(VAL,ORIFN) ; Base dlg FormID for an order
+1 NEW DLG
+2 SET VAL=0
SET DLG=$PIECE(^OR(100,+ORIFN,0),U,5)
+3 if $PIECE(DLG,";",2)'="ORD(101.41,"
QUIT
+4 DO FORMID^ORWDXM(.VAL,+DLG)
+5 QUIT
AGAIN(VAL,DLG) ; return true to keep dlg for another order
+1 SET VAL=''$PIECE($GET(^ORD(101.41,DLG,0)),U,9)
+2 QUIT
DGRP(VAL,DLG) ; Display grp pointer for a dlg
+1 ;kcm
SET DLG=$SELECT($EXTRACT(DLG)="`":+$PIECE(DLG,"`",2),1:$ORDER(^ORD(101.41,"AB",DLG,0)))
+2 SET VAL=$PIECE($GET(^ORD(101.41,DLG,0)),U,5)
+3 QUIT
DGNM(VAL,NM) ; Display grp pointer for name
+1 SET VAL=$ORDER(^ORD(100.98,"B",NM,0))
+2 QUIT
WRLST(LST,LOC) ; List of dlgs for writing orders
+1 GOTO WRLST1^ORWDX1
MSG(LST,IEN) ; Msg text for orderable item
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,IEN,8,I))
if I'>0
QUIT
SET LST(I)=^(I,0)
+3 QUIT
DISMSG(VAL,IEN) ; Disabled mge for ordering dlg
+1 SET VAL=$PIECE($GET(^ORD(101.41,+IEN,0)),U,3)
+2 QUIT
LOCK(OK,DFN) ; Attempt to lock pt for ordering
+1 SET OK=$$LOCK^ORX2(DFN)
+2 QUIT
UNLOCK(OK,DFN) ; Unlock pt for ordering
+1 DO UNLOCK^ORX2(DFN)
SET OK=1
+2 QUIT
LOCKORD(OK,ORIFN) ; Attempt to lock order
+1 SET OK=$$LOCK1^ORX2(ORIFN)
+2 QUIT
UNLKORD(OK,ORIFN) ; Unlock order
+1 DO UNLK1^ORX2(ORIFN)
SET OK=1
+2 QUIT
UNLKOTH(OK,ORIFN) ; Unlock pt not by this session
+1 KILL ^XTMP("ORPTLK-"_ORIFN)
SET OK=1
+2 QUIT
