source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDRA32.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1ORWDRA32 ; SLC/KCM/REV/JDL - Radiology calls to support windows [6/28/02] ;1/25/06 12:18
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,116,141,215**;Dec 17, 1997
3 ;
4DEF(LST,PATID,EVTDIV,IMGTYP) ; Get dialog data for radiology
5 N ILST,I,ORX S ILST=0
6 S LST($$NXT)="~ShortList" D SHORT
7 S IMGTYP=$$IMTYPE(IMGTYP)
8 S LST($$NXT)="~Common Procedures" D COMMPRO
9 S LST($$NXT)="~Modifiers" D MODIFYR
10 S LST($$NXT)="~Urgencies" D URGENCY
11 S LST($$NXT)="~Transport" D TRNSPRT
12 S LST($$NXT)="~Category" D CATEGRY
13 S LST($$NXT)="~Submit to" D SUBMIT
14 S LST($$NXT)="~Last 7 Days" D LAST7
15 Q
16MODIFYR ; Get the modifiers (should be by imaging type)
17 S I=$O(^RA(79.2,"C",IMGTYP,0)) Q:'I
18 S ORX=0 F S ORX=$O(^RAMIS(71.2,"AB",I,ORX)) Q:'ORX S LST($$NXT)="i"_ORX_U_$P(^RAMIS(71.2,ORX,0),U)
19 Q
20SHORT ; from DEF, get short list of imaging quick orders
21 N I,TMP
22 D GETQLST^ORWDXQ(.TMP,IMGTYP,"Q")
23 S I=0 F S I=$O(TMP(I)) Q:'I D
24 . S LST($$NXT)="i"_TMP(I)
25 Q
26COMMPRO ; Get the common procedures
27 N ORX
28 S ORX=""
29 F S ORX=$O(^ORD(101.43,"COMMON",IMGTYP,ORX)) Q:ORX="" D
30 . S I=$O(^ORD(101.43,"COMMON",IMGTYP,ORX,0))
31 . I $$REQDET,$P($G(^ORD(101.43,I,"RA")),U,2)="B" Q
32 . S LST($$NXT)="i"_I_U_ORX_U_U_$$REQAPPR(I)
33 Q
34URGENCY ; Get the allowable urgencies and default
35 S ORX="",I=0
36 F S ORX=$O(^ORD(101.42,"S.RA",ORX)) Q:ORX="" D
37 . S I=$O(^ORD(101.42,"S.RA",ORX,0))
38 . S LST($$NXT)="i"_I_U_ORX
39 S I=$O(^ORD(101.42,"B","ROUTINE",0))
40 S LST($$NXT)="d"_I_U_"ROUTINE"
41 Q
42TRNSPRT ; Get the modes of transport
43 F ORX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR" D
44 . S LST($$NXT)="i"_ORX
45 ; figure default on windows side
46 Q
47CATEGRY ; Get the categories of exam
48 F ORX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH" D
49 . S LST($$NXT)="i"_ORX
50 ; figure default on windows side
51 Q
52SUBMIT ; Get the locations to which the request may be submitted
53 N TMPLST,ASK,ORX
54 D EN4^RAO7PC1(IMGTYP,"TMPLST")
55 S I=0 F S I=$O(TMPLST(I)) Q:'I S LST($$NXT)="i"_TMPLST(I)
56 I $D(TMPLST) S I=$O(TMPLST(0)),ORX=$P(TMPLST(I),U,1,2),LST($$NXT)="d"_ORX
57 S LST($$NXT)="~Ask Submit"
58 I $G(EVTDIV) S ORX=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA SUBMIT PROMPT",1,"Q")
59 E S ORX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
60 ;S DUZ(2)=TMPDIV
61 S ASK=$S($L(ORX):ORX,1:1)
62 S LST($$NXT)="d"_ASK_U_$S(ASK=1:"YES",ASK=0:"NO",1:"YES")
63 Q
64LAST7 ; Get exams for the last 7 days
65 K ^TMP($J,"RAE7") D EN2^RAO7PC1(PATID)
66 S I=0 F S I=$O(^TMP($J,"RAE7",PATID,I)) Q:'I D
67 . S LST($$NXT)="i"_I_U_^TMP($J,"RAE7",PATID,I)
68 K ^TMP($J,"RAE7")
69 Q
70PROCMSG(ORY,IEN) ; return order message for a procedure
71 N I
72 S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S ORY(I)=^(I,0)
73 Q
74NXT() ; Increment index of LST
75 S ILST=ILST+1
76 Q ILST
77RAORDITM(Y,FROM,DIR,IMGTYP) ; Return a subset of orderable items
78 ; .Return Array, Starting Text, Direction, Cross Reference (S.xxx)
79 N I,IEN,CNT,ORX,DTXT,REQDET,REQAPPR,XREF S I=0,CNT=44
80 S XREF="S."_$$IMTYPE(IMGTYP)
81 F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D
82 . S IEN=0 F S IEN=$O(^ORD(101.43,XREF,FROM,IEN)) Q:'IEN D
83 . . I $$REQDET,$P($G(^ORD(101.43,IEN,"RA")),U,2)="B" Q
84 . . S ORX=^ORD(101.43,XREF,FROM,IEN)
85 . . I +$P(ORX,U,3),$P(ORX,U,3)<DT Q
86 . . S I=I+1
87 . . I 'ORX S Y(I)=IEN_U_$P(ORX,U,2)_U_$P(ORX,U,2)_U_$$REQAPPR(IEN)
88 . . E S Y(I)=IEN_U_$P(ORX,U,2)_" <"_$P(ORX,U,4)_">"_U_$P(ORX,U,4)_U_$$REQAPPR(IEN)
89 Q
90REQDET() ; Are "broad" procedures allowed for this division?
91 N RESULT
92 I $G(EVTDIV) S RESULT=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA REQUIRE DETAILED",1,"Q")
93 E S RESULT=$$GET^XPAR("ALL","RA REQUIRE DETAILED",1,"Q")
94 Q RESULT
95 ;
96REQAPPR(IEN) ; does procedure require radiologist approval?
97 N RAIEN
98 S RAIEN=$P($P($G(^ORD(101.43,IEN,0)),U,2),";",1)
99 I +RAIEN=0 Q ""
100 Q $P($G(^RAMIS(71,RAIEN,0)),U,11)
101 ;
102ISOLATN(Y,DFN) ;Is patient on isolation procedures?
103 N ORVP
104 S ORVP=DFN_";DPT("
105 S Y=$$IP^ORMBLD
106 Q
107APPROVAL(Y,DUMMY) ; RETURNS LIST OF RADIOLOGISTS WHO MAY APPROVE A
108 ; PROCEDURE WHEN REQUIRED
109 N ORX,I
110 S I="" F S I=$O(^VA(200,"ARC","S",I)) Q:I="" D
111 . ;I $P($G(^VA(200,I,"PS")),U,4),$P(^VA(200,I,"PS"),U,4)'>DT Q
112 . I '$$ACTIVE^XUSER(I) Q
113 . I $P($G(^VA(200,I,"RA")),U,3),$P(^VA(200,I,"RA"),U,3)'>DT Q
114 . S ORX=$P($G(^VA(200,I,0)),U)
115 . S Y(I)=I_U_ORX
116 Q
117IMTYPE(DGRP) ; return the mnemonic for the imaging type
118 Q $P(^ORD(100.98,DGRP,0),U,3)
119IMTYPSEL(Y,DUMMY) ;return list of active imaging types
120 N ORX,I,IEN,DGRP,MNEM,NAME
121 S ORX=""
122 F I=1:1 S ORX=$O(^RA(79.2,"C",ORX)) Q:ORX="" D
123 . I '$D(^ORD(101.43,"S."_ORX)) Q
124 . S IEN=$O(^RA(79.2,"C",ORX,0))
125 . S NAME=$P(^RA(79.2,IEN,0),U,1)
126 . S MNEM=$P(^RA(79.2,IEN,0),U,3)
127 . S DGRP=$O(^ORD(100.98,"B",MNEM,0))
128 . S Y(I)=IEN_U_NAME_U_MNEM_U_DGRP
129 Q
130RADSRC(Y,SRCTYPE) ; return list of available contract/sharing/research sources
131 S ORX=0
132 F I=1:1 S ORX=$O(^DIC(34,ORX)) Q:+ORX=0 D
133 . Q:($P(^DIC(34,ORX,0),U,2)'=SRCTYPE)
134 . I $D(^DIC(34,ORX,"I")),(^DIC(34,ORX,"I")<$$NOW^XLFDT) Q
135 . S Y(I)=I_U_$P(^DIC(34,ORX,0),U,1)
136 Q
137LOCTYPE(Y,ORLOC) ; Returns type of location (C,W)
138 S Y=-1
139 Q:$G(ORLOC)=""
140 S Y=$P($G(^SC(+$G(ORLOC),0)),U,3)
141 Q
Note: See TracBrowser for help on using the repository browser.