ORWDX2 ; SLC/JM/AGP - Order dialog utilities ;20-Jun-2014 09:43;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,1013**;Dec 17, 1997;Build 242
;Per VHA Directive 2004-038, this routine should not be modified.
;IHS/MSC/MGH Modified XROOT for ICD codes for ICD-10 Patch 1013
;
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,SAVCLIN,SAVSNO
S SAVCLIN="",SAVSNO=""
S (ILST,I)=0,CHKDOSE=$$CHKDOSES
S CNT=0
F S I=$O(@ROOT@(I)) Q:I'>0 D
. S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
. Q:'DLG
. S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
. I '$L(ID) S ID="ID"_DLG
. S VAL=$G(@ROOT@(I,1))
. S CNT=CNT+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
. I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX CLININD2" S SAVCLIN="~"_DLG_U_INST_U_ID Q ;IHS/MSC/MGH Patch 1013
. 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 $P($G(^ORD(101.41,DLG,0)),U)="OR GTX SNMDCNPTID" S SAVSNO=VAL ;IHS/MSC/MGH Patch 1013
. 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))
;IHS/MSC/MGH Patch 1013 changes
I SAVSNO'="" D
.S ^TMP("MGH","SNO")=SAVSNO
.S VAL=$P($$CONC^BSTSAPI(SAVSNO_"^^^1"),U,5)
.I SAVCLIN="" D
..S DLG=$O(^ORD(101.41,"B","OR GTX CLININD2",""))
..S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
..S INST=1
..S LST($$NXT)="~"_DLG_U_INST_U_ID
.E S LST($$NXT)=SAVCLIN
.S LST($$NXT)="i"_VAL,LST($$NXT)="e"_VAL
;END MOD
I CHKDOSE D FIXDOSES
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
;
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
. 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
ORWDX2 ; SLC/JM/AGP - Order dialog utilities ;20-Jun-2014 09:43;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,1013**;Dec 17, 1997;Build 242
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;IHS/MSC/MGH Modified XROOT for ICD codes for ICD-10 Patch 1013
+4 ;
+5 QUIT
+6 ;
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,SAVCLIN,SAVSNO
+2 SET SAVCLIN=""
SET SAVSNO=""
+3 SET (ILST,I)=0
SET CHKDOSE=$$CHKDOSES
+4 SET CNT=0
+5 FOR
SET I=$ORDER(@ROOT@(I))
IF I'>0
QUIT
Begin DoDot:1
+6 SET DLG=$PIECE(@ROOT@(I,0),U,2)
SET INST=$PIECE(^(0),U,3)
+7 IF 'DLG
QUIT
+8 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
+9 IF '$LENGTH(ID)
SET ID="ID"_DLG
+10 SET VAL=$GET(@ROOT@(I,1))
+11 SET CNT=CNT+1
+12 IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE"
SET ID="ADDITIVE"
+13 ; skip literal start time on copy
IF $EXTRACT(RSPID)="C"
IF (ID="START")
IF VAL
QUIT
+14 ;IHS/MSC/MGH Patch 1013
IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX CLININD2"
SET SAVCLIN="~"_DLG_U_INST_U_ID
QUIT
+15 SET LST($$NXT)="~"_DLG_U_INST_U_ID
+16 IF $LENGTH(VAL)
Begin DoDot:2
+17 SET LST($$NXT)="i"_VAL
SET LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
+18 IF CHKDOSE
DO DOSEINFO
End DoDot:2
+19 ;IHS/MSC/MGH Patch 1013
IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX SNMDCNPTID"
SET SAVSNO=VAL
+20 IF $DATA(@ROOT@(I,2))>1
Begin DoDot:2
+21 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
+22 SET J=0
FOR
SET J=$ORDER(@ROOT@(I,2,J))
IF J'>0
QUIT
Begin DoDot:3
+23 SET LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;IHS/MSC/MGH Patch 1013 changes
+25 IF SAVSNO'=""
Begin DoDot:1
+26 SET ^TMP("MGH","SNO")=SAVSNO
+27 SET VAL=$PIECE($$CONC^BSTSAPI(SAVSNO_"^^^1"),U,5)
+28 IF SAVCLIN=""
Begin DoDot:2
+29 SET DLG=$ORDER(^ORD(101.41,"B","OR GTX CLININD2",""))
+30 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
+31 SET INST=1
+32 SET LST($$NXT)="~"_DLG_U_INST_U_ID
End DoDot:2
+33 IF '$TEST
SET LST($$NXT)=SAVCLIN
+34 SET LST($$NXT)="i"_VAL
SET LST($$NXT)="e"_VAL
End DoDot:1
+35 ;END MOD
+36 IF CHKDOSE
DO FIXDOSES
+37 IF $EXTRACT(ROOT,1,4)="^TMP"
KILL ^TMP("ORWDXMQ",$JOB)
+38 QUIT
+39 ;
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 ;
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 SET ARRAY($PIECE(X,U))="i"_IEN_U_$PIECE(X,U)
End DoDot:1
+8 DO GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
+9 ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
+10 FOR CNT=1:1:SEQARR
Begin DoDot:1
+11 SET IEN=$PIECE(SEQARR(CNT),U,2)
SET NAME=$PIECE(^ORD(100.03,IEN,0),U)
+12 SET ILST=ILST+1
SET LST(ILST)="i"_IEN_U_NAME
+13 IF $DATA(ARRAY(NAME))>0
KILL ARRAY(NAME)
End DoDot:1
+14 IF $DATA(ARRAY)'>0
QUIT
+15 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
IF NAME=""
QUIT
Begin DoDot:1
+16 SET ILST=ILST+1
SET LST(ILST)=ARRAY(NAME)
End DoDot:1
+17 QUIT
