source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX2.m@ 789

Last change on this file since 789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1ORWDX2 ; SLC/JM/AGP - Order dialog utilities ;11/09/2006
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243**;Dec 17, 1997;Build 242
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ;
7NXT() ; -- Gets index in array
8 S ILST=ILST+1
9 Q ILST
10 ;
11EXTVAL(IVAL,DLG) ; External value given a dlg ptr
12 N ORDIALOG
13 S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
14 S ORDIALOG(DLG,1)=IVAL
15 I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time
16 Q $$EXT^ORCD(DLG,1) ; all others
17 ;
18XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
19 N CHKDOSE,DOSE,INSTR
20 S (ILST,I)=0,CHKDOSE=$$CHKDOSES
21 F S I=$O(@ROOT@(I)) Q:I'>0 D
22 . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
23 . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
24 . I '$L(ID) S ID="ID"_DLG
25 . S VAL=$G(@ROOT@(I,1))
26 . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
27 . I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy
28 . S LST($$NXT)="~"_DLG_U_INST_U_ID
29 . I $L(VAL) D
30 .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
31 .. I CHKDOSE D DOSEINFO
32 . I $D(@ROOT@(I,2))>1 D
33 .. I $E(RSPID)?1U,'$G(TRANS),ID="COMMENT",'$$DRAFT(RSPID) D FORMID^ORWDX(.X,+$E(RSPID,2,99)) Q:X=140
34 .. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D
35 ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
36 I CHKDOSE D FIXDOSES
37 I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
38 Q
39 ;
40DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
41 N IEN,STS,ES
42 I $E(ID)?1U,$E(ID)'="X" Q 0
43 S IEN=$S(ID:+ID,1:+$E(ID,2,99))
44 S STS=$P($G(^OR(100,IEN,3)),U,3),ES=$P($G(^(8,1,0)),U,4)
45 I STS=5 Q 1
46 I STS=11 Q 1
47 I STS=10,ES=2 Q 1
48 Q 0
49 ;
50CHKDOSES() ; Returns true if doses may need to be modified
51 Q $$PATCH^XPDUTL("PSS*1.0*78")&($T(DOSE^PSSORUTE)'="")
52 ;
53DOSEINFO ; Collect pointers to dose information
54 I ID="INSTR" S INSTR(INST)=ILST-1
55 I ID="DOSE",+VAL>0 S DOSE(INST)=ILST-1 ; +VAL filters out local dosages
56 Q
57 ;
58FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
59 N CODE,OLDDOSE,IDX,NEWDOSE,IIDX
60 S IIDX=0
61 F S IIDX=$O(INSTR(IIDX)) Q:'+IIDX D
62 . I +$G(INSTR(IIDX))>0,+$G(DOSE(IIDX))>0 D
63 .. S OLDDOSE=$E(LST(INSTR(IIDX)),2,999)
64 .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
65 .. I OLDDOSE'=NEWDOSE D
66 ... F IDX=0:1:1 D
67 .... S CODE=$E(LST(INSTR(IIDX)+IDX),1)
68 .... S LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
69 .. S OLDDOSE=$P(LST(DOSE(IIDX)),"&",5)
70 .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
71 .. I OLDDOSE'=NEWDOSE D
72 ... F IDX=0:1:1 D
73 .... S $P(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
74 Q
75 ;
76DCREASON(LST) ; Return a list of DC reasons
77 N ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
78 S ILST=1,LST(ILST)="~DCReason"
79 S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D
80 . I $P(X,U,4) Q ; inactive
81 . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg
82 . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto
83 . S ARRAY($P(X,U))="i"_IEN_U_$P(X,U)
84 D GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
85 ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
86 F CNT=1:1:SEQARR D
87 . S IEN=$P(SEQARR(CNT),U,2),NAME=$P(^ORD(100.03,IEN,0),U)
88 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_NAME
89 . I $D(ARRAY(NAME))>0 K ARRAY(NAME)
90 I $D(ARRAY)'>0 Q
91 S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
92 .S ILST=ILST+1,LST(ILST)=ARRAY(NAME)
93 Q
Note: See TracBrowser for help on using the repository browser.