Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDX2

ORWDX2.m

Go to the documentation of this file.
  1. ORWDX2 ;SLC/JM,AGP - Order dialog utilities ;Feb 22, 2024@11:19
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,280,331,405,588,601**;Dec 17, 1997;Build 1
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;Reference to $$DOSE^PSSORUTE supported by IA #4555
  1. ;Reference to ^DIC(9.4 supported by IA #2058
  1. ;Reference to ^DPT( supported by IA #10035
  1. ;Reference to ^XMD supported by IA #10070
  1. ;Reference to $$PATCH^XPDUTL supported by IA #10141
  1. ;
  1. ;
  1. Q
  1. ;
  1. NXT() ; -- Gets index in array
  1. S ILST=ILST+1
  1. Q ILST
  1. ;
  1. EXTVAL(IVAL,DLG) ; External value given a dlg ptr
  1. N ORDIALOG
  1. S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
  1. S ORDIALOG(DLG,1)=IVAL
  1. I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time
  1. Q $$EXT^ORCD(DLG,1) ; all others
  1. ;
  1. XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
  1. N CHKDOSE,DOSE,INSTR,X
  1. S (ILST,I)=0,CHKDOSE=$$CHKDOSES
  1. F S I=$O(@ROOT@(I)) Q:I'>0 D
  1. . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
  1. . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
  1. . I '$L(ID) S ID="ID"_DLG
  1. . S VAL=$G(@ROOT@(I,1))
  1. . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
  1. . ;I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy ;DJE/VM *331 - removed, not working consistently
  1. . S LST($$NXT)="~"_DLG_U_INST_U_ID
  1. . I $L(VAL) D
  1. .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
  1. .. I CHKDOSE D DOSEINFO
  1. . I $D(@ROOT@(I,2))>1 D
  1. .. I $E(RSPID)?1U,'$G(TRANS),ID="COMMENT",'$$DRAFT(RSPID) D FORMID^ORWDX(.X,+$E(RSPID,2,99)) Q:X=140
  1. .. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D
  1. ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
  1. I $G(ORADDTITRRESP) D TITR(.LST,.ILST)
  1. I CHKDOSE D FIXDOSES
  1. I ROOT["^OR(100," D
  1. . N ORIFN,OVRIDE,REMCOM,RET
  1. . S ORIFN=$P(ROOT,",",2) Q:+ORIFN<1
  1. . I "^14^13^11^10^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS",.RET)
  1. . I "^14^13^11^10^"'[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"SIGNATURE_CPRS",.RET)
  1. . Q:'$D(RET)
  1. . S (OVRIDE,REMCOM)=""
  1. . N IEN S IEN=0 F S IEN=$O(RET(ORIFN,IEN)) Q:'IEN D Q:((OVRIDE'="")&(REMCOM'=""))
  1. .. I OVRIDE="" S OVRIDE=$G(^ORD(100.05,IEN,3,1,0))
  1. .. N X S X=0 F S X=$O(^ORD(100.05,IEN,4,X)) Q:+X=0 D Q:REMCOM'=""
  1. ... I REMCOM="" S REMCOM=$G(^ORD(100.05,IEN,4,X,4))
  1. . I OVRIDE'="" D
  1. .. S LST($$NXT)="~^^OVERRIDE"
  1. .. S LST($$NXT)="t"_OVRIDE
  1. . I REMCOM'="" D
  1. .. S LST($$NXT)="~^^ORREMCOMMENT"
  1. .. S LST($$NXT)="t"_REMCOM
  1. I $E(ROOT,1,15)="^TMP(""ORWTITR""," D Q
  1. . K ^TMP("ORWTITR",$J)
  1. I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
  1. Q
  1. ;
  1. DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
  1. N IEN,STS,ES
  1. I $E(ID)?1U,$E(ID)'="X" Q 0
  1. S IEN=$S(ID:+ID,1:+$E(ID,2,99))
  1. S STS=$P($G(^OR(100,IEN,3)),U,3),ES=$P($G(^(8,1,0)),U,4)
  1. I STS=5 Q 1
  1. I STS=11 Q 1
  1. I STS=10,ES=2 Q 1
  1. Q 0
  1. ;
  1. TITR(LST,ILST) ; Add titration response (when changing old titration order)
  1. S LST($$NXT)="~"_$$PTR^ORWDXM1("TITRATION")_"^1^TITR"
  1. S LST($$NXT)="i1"
  1. S LST($$NXT)="eYES"
  1. Q
  1. ;
  1. CHKDOSES() ; Returns true if doses may need to be modified
  1. Q $$PATCH^XPDUTL("PSS*1.0*78")&($T(DOSE^PSSORUTE)'="")
  1. ;
  1. DOSEINFO ; Collect pointers to dose information
  1. I ID="INSTR" S INSTR(INST)=ILST-1
  1. I ID="DOSE",+VAL>0 S DOSE(INST)=ILST-1 ; +VAL filters out local dosages
  1. Q
  1. ;
  1. FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
  1. N CODE,OLDDOSE,IDX,NEWDOSE,IIDX
  1. S IIDX=0
  1. F S IIDX=$O(INSTR(IIDX)) Q:'+IIDX D
  1. . I +$G(INSTR(IIDX))>0,+$G(DOSE(IIDX))>0 D
  1. .. S OLDDOSE=$E(LST(INSTR(IIDX)),2,999)
  1. .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
  1. .. I OLDDOSE'=NEWDOSE D
  1. ... F IDX=0:1:1 D
  1. .... S CODE=$E(LST(INSTR(IIDX)+IDX),1)
  1. .... S LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
  1. .. S OLDDOSE=$P(LST(DOSE(IIDX)),"&",5)
  1. .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
  1. .. I OLDDOSE'=NEWDOSE D
  1. ... F IDX=0:1:1 D
  1. .... S $P(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
  1. Q
  1. ;
  1. DCREASON(LST) ; Return a list of DC reasons
  1. N ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
  1. S ILST=1,LST(ILST)="~DCReason"
  1. S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D
  1. . I $P(X,U,4) Q ; inactive
  1. . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg
  1. . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto
  1. . I $P(X,U)="EHRM TRANSITIONED UTILITY" Q
  1. . I $P(X,U)="EHRM TRANSITIONED",'$$ONEHR^ORACCESS() Q
  1. . S ARRAY($P(X,U))="i"_IEN_U_$P(X,U)
  1. D GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
  1. ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
  1. F CNT=1:1:SEQARR D
  1. . S IEN=$P(SEQARR(CNT),U,2),NAME=$P(^ORD(100.03,IEN,0),U)
  1. . S ILST=ILST+1,LST(ILST)="i"_IEN_U_NAME
  1. . I $D(ARRAY(NAME))>0 K ARRAY(NAME)
  1. I $D(ARRAY)'>0 Q
  1. S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
  1. .S ILST=ILST+1,LST(ILST)=ARRAY(NAME)
  1. Q
  1. SM(ERROR) ; Send message to Radiology users
  1. K XMY N XMDUZ,XMSUB,XMTEXT,OR0,ORIFN,DFN,OIP,OI,ORERR,MG
  1. S XMDUZ="CPRS,ORDERS",MG=$$GET^XPAR("SYS","OR RADIOLOGY ISSUES") I MG="" Q
  1. S XMY("G."_MG)="",XMSUB="CPRS Order Error on Radiology Order"
  1. S XMTEXT="ORERR(",ORIFN=+ERROR
  1. 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))
  1. S ORERR(1,0)="Patient: "_$P($G(^DPT(DFN,0)),"^")
  1. S ORERR(2,0)="CPRS Order Number: "_ORIFN
  1. S ORERR(3,0)="CPRS Orderable Item: "_OI_" - "_$P($G(^ORD(101.43,OI,0)),"^")
  1. S ORERR(4,0)=" "
  1. S ORERR(5,0)="Error from Radiology: "_$P(ERROR,"^",4)
  1. D ^XMD
  1. Q
  1. CHKLABDIV(ORDITEM,ORXREF) ; Compare user's signed in division to lab test
  1. ; division(s)
  1. I "^S.LAB^S.AP^"'[(U_ORXREF_U) Q 1
  1. I '+$G(DUZ(2)) Q 1
  1. N ORTESTIEN
  1. S ORTESTIEN=$P($P($G(^ORD(101.43,ORDITEM,0)),U,2),";",1)
  1. I '+ORTESTIEN Q 1
  1. I +$O(^LAB(60,ORTESTIEN,8,0))=0 Q 1
  1. N ORLABOK,ORINSTTYPES,ORDIV,ORDIVS,OREXIST
  1. ;OUTPATIENT CLINIC SHOULD SHOW OUTPATIENT CLINIC'S AND PARENT FACILITY'S TESTS
  1. S ORINSTTYPES("CBOC")="",ORINSTTYPES("OCMC")="",ORINSTTYPES("OCS")=""
  1. S ORINSTTYPES("OPC")="",ORINSTTYPES("RO-OC")=""
  1. S ORDIVS=1,ORDIVS(1)=DUZ(2)_U_$$NNT^XUAF4(DUZ(2))
  1. I $D(ORINSTTYPES($P(ORDIVS(1),U,4)))=1 D
  1. .S ORDIV=+$$PRNT^XUAF4($P(ORDIVS(ORDIVS),U,3))
  1. .S:ORDIV>0 ORDIVS=2,ORDIVS(2)=ORDIV_U_$$NNT^XUAF4(ORDIV)
  1. S ORLABOK=1
  1. F ORDIV=1:1:ORDIVS D Q:OREXIST
  1. . S OREXIST=$D(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV)))
  1. . S ORLABOK=(OREXIST>9)
  1. . I 'ORLABOK Q
  1. . S ORLABOK=($P($G(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV),0)),U,3)'=1)
  1. Q ORLABOK