ORWDX2 ;SLC/JM/AGP - Order dialog utilities ; Apr 20, 2023@17:49
;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,280,331,405,588**;Dec 17, 1997;Build 29
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Reference to $$DOSE^PSSORUTE supported by IA #4555
;Reference to ^DIC(9.4 supported by IA #2058
;Reference to ^DPT( supported by IA #10035
;Reference to ^XMD supported by IA #10070
;Reference to $$PATCH^XPDUTL supported by IA #10141
;
;
Q
;
NXT() ; -- Gets index in array
S ILST=ILST+1
Q ILST
;
EXTVAL(IVAL,DLG) ; External value given a dlg ptr
N ORDIALOG
S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
S ORDIALOG(DLG,1)=IVAL
I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time
Q $$EXT^ORCD(DLG,1) ; all others
;
XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
N CHKDOSE,DOSE,INSTR,X
S (ILST,I)=0,CHKDOSE=$$CHKDOSES
F S I=$O(@ROOT@(I)) Q:I'>0 D
. S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
. S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
. I '$L(ID) S ID="ID"_DLG
. S VAL=$G(@ROOT@(I,1))
. I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
. ;I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy ;DJE/VM *331 - removed, not working consistently
. S LST($$NXT)="~"_DLG_U_INST_U_ID
. I $L(VAL) D
.. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
.. I CHKDOSE D DOSEINFO
. I $D(@ROOT@(I,2))>1 D
.. I $E(RSPID)?1U,'$G(TRANS),ID="COMMENT",'$$DRAFT(RSPID) D FORMID^ORWDX(.X,+$E(RSPID,2,99)) Q:X=140
.. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D
... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
I $G(ORADDTITRRESP) D TITR(.LST,.ILST)
I CHKDOSE D FIXDOSES
I ROOT["^OR(100," D
. N ORIFN,OVRIDE,REMCOM,RET
. S ORIFN=$P(ROOT,",",2) Q:+ORIFN<1
. I "^14^13^11^10^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS",.RET)
. I "^14^13^11^10^"'[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"SIGNATURE_CPRS",.RET)
. Q:'$D(RET)
. S (OVRIDE,REMCOM)=""
. N IEN S IEN=0 F S IEN=$O(RET(ORIFN,IEN)) Q:'IEN D Q:((OVRIDE'="")&(REMCOM'=""))
.. I OVRIDE="" S OVRIDE=$G(^ORD(100.05,IEN,3,1,0))
.. N X S X=0 F S X=$O(^ORD(100.05,IEN,4,X)) Q:+X=0 D Q:REMCOM'=""
... I REMCOM="" S REMCOM=$G(^ORD(100.05,IEN,4,X,4))
. I OVRIDE'="" D
.. S LST($$NXT)="~^^OVERRIDE"
.. S LST($$NXT)="t"_OVRIDE
. I REMCOM'="" D
.. S LST($$NXT)="~^^ORREMCOMMENT"
.. S LST($$NXT)="t"_REMCOM
I $E(ROOT,1,15)="^TMP(""ORWTITR""," D Q
. K ^TMP("ORWTITR",$J)
I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
Q
;
DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
N IEN,STS,ES
I $E(ID)?1U,$E(ID)'="X" Q 0
S IEN=$S(ID:+ID,1:+$E(ID,2,99))
S STS=$P($G(^OR(100,IEN,3)),U,3),ES=$P($G(^(8,1,0)),U,4)
I STS=5 Q 1
I STS=11 Q 1
I STS=10,ES=2 Q 1
Q 0
;
TITR(LST,ILST) ; Add titration response (when changing old titration order)
S LST($$NXT)="~"_$$PTR^ORWDXM1("TITRATION")_"^1^TITR"
S LST($$NXT)="i1"
S LST($$NXT)="eYES"
Q
;
CHKDOSES() ; Returns true if doses may need to be modified
Q $$PATCH^XPDUTL("PSS*1.0*78")&($T(DOSE^PSSORUTE)'="")
;
DOSEINFO ; Collect pointers to dose information
I ID="INSTR" S INSTR(INST)=ILST-1
I ID="DOSE",+VAL>0 S DOSE(INST)=ILST-1 ; +VAL filters out local dosages
Q
;
FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
N CODE,OLDDOSE,IDX,NEWDOSE,IIDX
S IIDX=0
F S IIDX=$O(INSTR(IIDX)) Q:'+IIDX D
. I +$G(INSTR(IIDX))>0,+$G(DOSE(IIDX))>0 D
.. S OLDDOSE=$E(LST(INSTR(IIDX)),2,999)
.. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
.. I OLDDOSE'=NEWDOSE D
... F IDX=0:1:1 D
.... S CODE=$E(LST(INSTR(IIDX)+IDX),1)
.... S LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
.. S OLDDOSE=$P(LST(DOSE(IIDX)),"&",5)
.. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
.. I OLDDOSE'=NEWDOSE D
... F IDX=0:1:1 D
.... S $P(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
Q
;
DCREASON(LST) ; Return a list of DC reasons
N ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
S ILST=1,LST(ILST)="~DCReason"
S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D
. I $P(X,U,4) Q ; inactive
. I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg
. I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto
. I $P(X,U)="EHRM TRANSITIONED UTILITY" Q
. I $P(X,U)="EHRM TRANSITIONED",'$$ONEHR^ORACCESS() Q
. S ARRAY($P(X,U))="i"_IEN_U_$P(X,U)
D GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
F CNT=1:1:SEQARR D
. S IEN=$P(SEQARR(CNT),U,2),NAME=$P(^ORD(100.03,IEN,0),U)
. S ILST=ILST+1,LST(ILST)="i"_IEN_U_NAME
. I $D(ARRAY(NAME))>0 K ARRAY(NAME)
I $D(ARRAY)'>0 Q
S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
.S ILST=ILST+1,LST(ILST)=ARRAY(NAME)
Q
SM(ERROR) ; Send message to Radiology users
K XMY N XMDUZ,XMSUB,XMTEXT,OR0,ORIFN,DFN,OIP,OI,ORERR,MG
S XMDUZ="CPRS,ORDERS",MG=$$GET^XPAR("SYS","OR RADIOLOGY ISSUES") I MG="" Q
S XMY("G."_MG)="",XMSUB="CPRS Order Error on Radiology Order"
S XMTEXT="ORERR(",ORIFN=+ERROR
S OR0=$G(^OR(100,ORIFN,0)),DFN=+$P(OR0,"^",2),OIP=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=$G(^OR(100,ORIFN,4.5,OIP,1))
S ORERR(1,0)="Patient: "_$P($G(^DPT(DFN,0)),"^")
S ORERR(2,0)="CPRS Order Number: "_ORIFN
S ORERR(3,0)="CPRS Orderable Item: "_OI_" - "_$P($G(^ORD(101.43,OI,0)),"^")
S ORERR(4,0)=" "
S ORERR(5,0)="Error from Radiology: "_$P(ERROR,"^",4)
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDX2 5503 printed Apr 09, 2024@21:40:21 Page 2
ORWDX2 ;SLC/JM/AGP - Order dialog utilities ; Apr 20, 2023@17:49
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,280,331,405,588**;Dec 17, 1997;Build 29
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Reference to $$DOSE^PSSORUTE supported by IA #4555
+5 ;Reference to ^DIC(9.4 supported by IA #2058
+6 ;Reference to ^DPT( supported by IA #10035
+7 ;Reference to ^XMD supported by IA #10070
+8 ;Reference to $$PATCH^XPDUTL supported by IA #10141
+9 ;
+10 ;
+11 QUIT
+12 ;
NXT() ; -- Gets index in array
+1 SET ILST=ILST+1
+2 QUIT ILST
+3 ;
EXTVAL(IVAL,DLG) ; External value given a dlg ptr
+1 NEW ORDIALOG
+2 SET ORDIALOG(DLG,0)=$PIECE($GET(^ORD(101.41,DLG,1)),U,1,2)
+3 SET ORDIALOG(DLG,1)=IVAL
+4 ; free text date/time
IF $EXTRACT(ORDIALOG(DLG,0))="R"
IF (+IVAL'=IVAL)
QUIT IVAL
+5 ; all others
QUIT $$EXT^ORCD(DLG,1)
+6 ;
XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
+1 NEW CHKDOSE,DOSE,INSTR,X
+2 SET (ILST,I)=0
SET CHKDOSE=$$CHKDOSES
+3 FOR
SET I=$ORDER(@ROOT@(I))
if I'>0
QUIT
Begin DoDot:1
+4 SET DLG=$PIECE(@ROOT@(I,0),U,2)
SET INST=$PIECE(^(0),U,3)
+5 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
+6 IF '$LENGTH(ID)
SET ID="ID"_DLG
+7 SET VAL=$GET(@ROOT@(I,1))
+8 IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE"
SET ID="ADDITIVE"
+9 ;I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy ;DJE/VM *331 - removed, not working consistently
+10 SET LST($$NXT)="~"_DLG_U_INST_U_ID
+11 IF $LENGTH(VAL)
Begin DoDot:2
+12 SET LST($$NXT)="i"_VAL
SET LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
+13 IF CHKDOSE
DO DOSEINFO
End DoDot:2
+14 IF $DATA(@ROOT@(I,2))>1
Begin DoDot:2
+15 IF $EXTRACT(RSPID)?1U
IF '$GET(TRANS)
IF ID="COMMENT"
IF '$$DRAFT(RSPID)
DO FORMID^ORWDX(.X,+$EXTRACT(RSPID,2,99))
if X=140
QUIT
+16 SET J=0
FOR
SET J=$ORDER(@ROOT@(I,2,J))
if J'>0
QUIT
Begin DoDot:3
+17 SET LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $GET(ORADDTITRRESP)
DO TITR(.LST,.ILST)
+19 IF CHKDOSE
DO FIXDOSES
+20 IF ROOT["^OR(100,"
Begin DoDot:1
+21 NEW ORIFN,OVRIDE,REMCOM,RET
+22 SET ORIFN=$PIECE(ROOT,",",2)
if +ORIFN<1
QUIT
+23 IF "^14^13^11^10^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
DO GETOC3^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS",.RET)
+24 IF "^14^13^11^10^"'[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
DO GETOC3^OROCAPI1(ORIFN,"SIGNATURE_CPRS",.RET)
+25 if '$DATA(RET)
QUIT
+26 SET (OVRIDE,REMCOM)=""
+27 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(RET(ORIFN,IEN))
if 'IEN
QUIT
Begin DoDot:2
+28 IF OVRIDE=""
SET OVRIDE=$GET(^ORD(100.05,IEN,3,1,0))
+29 NEW X
SET X=0
FOR
SET X=$ORDER(^ORD(100.05,IEN,4,X))
if +X=0
QUIT
Begin DoDot:3
+30 IF REMCOM=""
SET REMCOM=$GET(^ORD(100.05,IEN,4,X,4))
End DoDot:3
if REMCOM'=""
QUIT
End DoDot:2
if ((OVRIDE'="")&(REMCOM'=""))
QUIT
+31 IF OVRIDE'=""
Begin DoDot:2
+32 SET LST($$NXT)="~^^OVERRIDE"
+33 SET LST($$NXT)="t"_OVRIDE
End DoDot:2
+34 IF REMCOM'=""
Begin DoDot:2
+35 SET LST($$NXT)="~^^ORREMCOMMENT"
+36 SET LST($$NXT)="t"_REMCOM
End DoDot:2
End DoDot:1
+37 IF $EXTRACT(ROOT,1,15)="^TMP(""ORWTITR"","
Begin DoDot:1
+38 KILL ^TMP("ORWTITR",$JOB)
End DoDot:1
QUIT
+39 IF $EXTRACT(ROOT,1,4)="^TMP"
KILL ^TMP("ORWDXMQ",$JOB)
+40 QUIT
+41 ;
DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
+1 NEW IEN,STS,ES
+2 IF $EXTRACT(ID)?1U
IF $EXTRACT(ID)'="X"
QUIT 0
+3 SET IEN=$SELECT(ID:+ID,1:+$EXTRACT(ID,2,99))
+4 SET STS=$PIECE($GET(^OR(100,IEN,3)),U,3)
SET ES=$PIECE($GET(^(8,1,0)),U,4)
+5 IF STS=5
QUIT 1
+6 IF STS=11
QUIT 1
+7 IF STS=10
IF ES=2
QUIT 1
+8 QUIT 0
+9 ;
TITR(LST,ILST) ; Add titration response (when changing old titration order)
+1 SET LST($$NXT)="~"_$$PTR^ORWDXM1("TITRATION")_"^1^TITR"
+2 SET LST($$NXT)="i1"
+3 SET LST($$NXT)="eYES"
+4 QUIT
+5 ;
CHKDOSES() ; Returns true if doses may need to be modified
+1 QUIT $$PATCH^XPDUTL("PSS*1.0*78")&($TEXT(DOSE^PSSORUTE)'="")
+2 ;
DOSEINFO ; Collect pointers to dose information
+1 IF ID="INSTR"
SET INSTR(INST)=ILST-1
+2 ; +VAL filters out local dosages
IF ID="DOSE"
IF +VAL>0
SET DOSE(INST)=ILST-1
+3 QUIT
+4 ;
FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
+1 NEW CODE,OLDDOSE,IDX,NEWDOSE,IIDX
+2 SET IIDX=0
+3 FOR
SET IIDX=$ORDER(INSTR(IIDX))
if '+IIDX
QUIT
Begin DoDot:1
+4 IF +$GET(INSTR(IIDX))>0
IF +$GET(DOSE(IIDX))>0
Begin DoDot:2
+5 SET OLDDOSE=$EXTRACT(LST(INSTR(IIDX)),2,999)
+6 SET NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
+7 IF OLDDOSE'=NEWDOSE
Begin DoDot:3
+8 FOR IDX=0:1:1
Begin DoDot:4
+9 SET CODE=$EXTRACT(LST(INSTR(IIDX)+IDX),1)
+10 SET LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
End DoDot:4
End DoDot:3
+11 SET OLDDOSE=$PIECE(LST(DOSE(IIDX)),"&",5)
+12 SET NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
+13 IF OLDDOSE'=NEWDOSE
Begin DoDot:3
+14 FOR IDX=0:1:1
Begin DoDot:4
+15 SET $PIECE(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
DCREASON(LST) ; Return a list of DC reasons
+1 NEW ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
+2 SET ILST=1
SET LST(ILST)="~DCReason"
+3 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.03,IEN))
if 'IEN
QUIT
SET X=^(IEN,0)
Begin DoDot:1
+4 ; inactive
IF $PIECE(X,U,4)
QUIT
+5 ; not OR pkg
IF $PIECE(X,U,5)'=+$ORDER(^DIC(9.4,"C","OR",0))
QUIT
+6 ; nature=auto
IF $PIECE(X,U,7)=+$ORDER(^ORD(100.02,"C","A",0))
QUIT
+7 IF $PIECE(X,U)="EHRM TRANSITIONED UTILITY"
QUIT
+8 IF $PIECE(X,U)="EHRM TRANSITIONED"
IF '$$ONEHR^ORACCESS()
QUIT
+9 SET ARRAY($PIECE(X,U))="i"_IEN_U_$PIECE(X,U)
End DoDot:1
+10 DO GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
+11 ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
+12 FOR CNT=1:1:SEQARR
Begin DoDot:1
+13 SET IEN=$PIECE(SEQARR(CNT),U,2)
SET NAME=$PIECE(^ORD(100.03,IEN,0),U)
+14 SET ILST=ILST+1
SET LST(ILST)="i"_IEN_U_NAME
+15 IF $DATA(ARRAY(NAME))>0
KILL ARRAY(NAME)
End DoDot:1
+16 IF $DATA(ARRAY)'>0
QUIT
+17 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+18 SET ILST=ILST+1
SET LST(ILST)=ARRAY(NAME)
End DoDot:1
+19 QUIT
SM(ERROR) ; Send message to Radiology users
+1 KILL XMY
NEW XMDUZ,XMSUB,XMTEXT,OR0,ORIFN,DFN,OIP,OI,ORERR,MG
+2 SET XMDUZ="CPRS,ORDERS"
SET MG=$$GET^XPAR("SYS","OR RADIOLOGY ISSUES")
IF MG=""
QUIT
+3 SET XMY("G."_MG)=""
SET XMSUB="CPRS Order Error on Radiology Order"
+4 SET XMTEXT="ORERR("
SET ORIFN=+ERROR
+5 SET OR0=$GET(^OR(100,ORIFN,0))
SET DFN=+$PIECE(OR0,"^",2)
SET OIP=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0))
SET OI=$GET(^OR(100,ORIFN,4.5,OIP,1))
+6 SET ORERR(1,0)="Patient: "_$PIECE($GET(^DPT(DFN,0)),"^")
+7 SET ORERR(2,0)="CPRS Order Number: "_ORIFN
+8 SET ORERR(3,0)="CPRS Orderable Item: "_OI_" - "_$PIECE($GET(^ORD(101.43,OI,0)),"^")
+9 SET ORERR(4,0)=" "
+10 SET ORERR(5,0)="Error from Radiology: "_$PIECE(ERROR,"^",4)
+11 DO ^XMD
+12 QUIT
