source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m@ 724

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

revised back to 6/30/08 version

File size: 6.0 KB
Line 
1RAORD1A ;HISC/FPT-Request an Exam ;9/29/97 10:40
2 ;;5.0;Radiology/Nuclear Medicine;**1**;Mar 16, 1998
3 ;
4CS ; Category of exam switch. Called from [RA ORDER EXAM] input template
5 ; when requesting an exam. User can change category of exam from
6 ; (1) inpatient to outpatient and select a clinic patient location OR
7 ; (2) outpatient to inpatient and select a ward patient location.
8 ;
9 N RAA,RAB,X,Y K DIR
10 S RAA=$S($E(RACAT)="I":"INPATIENT",1:"OUTPATIENT")
11 S RAB=$S($E(RAA)="I":"OUTPATIENT",1:"INPATIENT")
12 W ! S DIR("A",1)="CATEGORY OF EXAM is currently "_RAA
13 S DIR("A",2)=" "
14 S DIR("A")="Want to change CATEGORY OF EXAM to "_RAB
15 S DIR(0)="Y"
16 D ^DIR K DIR
17 I $D(DIRUT) S RALIFN("OUT")="" Q
18 I Y=0 S RALIFN("NO")="" Q
19REQLOC ; select patient location
20 N DIC,RAHL,RAHLWD,RASCI W !
21ASK S DIC("A")="Patient Location: ",DIC="^SC(",DIC(0)="AEMQ"
22 I $E(RAB)="O" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="C" DIC("B")=$P(^SC(+RALIFN,0),U,1)
23 I $E(RAB)="I" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="W" DIC("B")=$P(^SC(+RALIFN,0),U,1)
24 D ^DIC K DIC
25 I +Y'>0 S RALIFN("OUT")="" Q
26 I $E(RAB)="I" S RAHLWD=+$G(^SC(+Y,42)) I RAHLWD S RAHL=+$G(^DIC(42,RAHLWD,44)) I RAHL,RAHL'=+Y W !!,*7,"This Hospital Location points to ",$P($G(^DIC(42,+Y,0)),U,1) G ASK
27 S RALIFN=+Y,RACAT=RAB
28 Q:$D(RAOERFLG) ;quit if REQLOC was called from REQLOC1
29 K:$E(RAB)="O" RAWARD
30 S:$E(RAB)="I" RAWARD=$P(^SC(+Y,0),U,1)
31 Q
32SCREEN() ; screen for active clinics/wards
33 ; This code is also called from RAORD1 (screen for the Patient Location
34 ; prompt)
35 Q:$D(^SC(+Y,"OOS")) 0 ; don't want Occasion Of Service (OOS) locations
36 N RA44 S RA44=$G(^SC(+Y,0))
37 Q:"FI"[$P(RA44,"^",3) 0 ; File areas & Imaging Types are not selectable
38 I $P(RA44,"^",3)="W" G SCREENW ; ward check
39 ; check inactivation & reactivation dates of clinic/operating
40 ; room in file #44
41 I '$D(^SC(+Y,"I")) Q 1
42 ; This Hospital Location has an "I" node. We have to check INACTIVATE
43 ; DATE & REACTIVATE DATE fields to determine if the Hosp. Location is
44 ; active.
45 N RASCA S RASCI=$G(^SC(+Y,"I")),RASCA=+$P(RASCI,"^",2)
46 ; RASCA is the REACTIVATE DATE
47 ; Not selectable if REACTIVATE DATE is beyond DT or null (0).
48 S RASCA=$S(RASCA=0:0,RASCA>DT:0,1:RASCA)
49 I +RASCI=0 Q 1 ; no INACTIVATE DATE
50 I +RASCI>DT Q 1 ; INACTIVATE DATE exceeds today's date
51 ; Check INACTIVATE DATE against REACTIVATE DATE
52 ; if REACTIVATE DATE exists and is not after (or is equal to) the
53 ; INACTIVATE DATE the location is not active.
54 I RASCA,(+RASCI<RASCA) Q 1
55 Q 0
56SCREENW ; check currently out-of-service field of ward file (#42)
57 N D0,DGPMOS,X
58 S D0=+$G(^SC(+Y,42)) I 'D0 Q 0
59 I '$D(^DIC(42,D0,0)) Q 0
60 S:$D(RAWHEN) DGPMOS=$P(RAWHEN,".",1)
61 D WIN^DGPMDDCF
62 S X=$S(X=0:1,1:0)
63 Q X
64 ;
65REQLOC1 ; Requesting Location does not go with Category of Exam
66 ; Category of Exam = Inpatient -> Requesting Location = Ward
67 ; Category of Exam = Outpatient -> Requesting Location = Clinic
68 ; Called from [RA OERR EDIT] and [RA QUICK EXAM ORDER] input templates
69 W !!?5,*7,"When the CATEGORY OF EXAM is "_$S(RAX="I":"Inpatient",1:"Outpatient")_" the REQUESTING LOCATION",!?5,"must be a "_$S(RAX="I":"Ward",1:"Clinic")_" or OR.",!
70 W !?5,"The current REQUESTING LOCATION is ",$S($P($G(^SC(+RALIFN,0)),U,1)]"":$P($G(^SC(+RALIFN,0)),U,1),1:"Unknown"),!
71 N RAB,X,Y
72 S RAX=$S(RAX="I":"INPATIENT",1:"OUTPATIENT"),RAB=RAX,RAOERRFG=""
73 D REQLOC
74 K RAOERRFG
75 Q
76TYPE(RACAT,Y) ; Indicates whether a Hospital Location is a valid selection.
77 ; If the patient is an inpatient, all operating room location types &
78 ; all wards are valid selections. If the patient is an outpatient, all
79 ; operating room location types & all clinics are valid selections.
80 ; Input Variables: RACAT=$S(Inpatient:"I",1:"O") "O" for outpatient
81 ; Input Variables: Y=IEN of entries in the Hospital Location file
82 ; This fuction returns 1 if valid, 0 if not valid
83 N RAX S RAX=0
84 I $E(RACAT,1)="I" D
85 . I $P(^SC(+Y,0),U,3)="W"!($P(^SC(+Y,0),U,3)="OR") S RAX=1
86 . Q
87 E D
88 . I $P(^SC(+Y,0),U,3)="C"!($P(^SC(+Y,0),U,3)="OR") S RAX=1
89 . Q
90 Q RAX
91MATCH(RACAT,RALOC) ; Detect mismatched req loc type and cat. of exam
92 ; and return code for correct category of exam
93 ; Input Variable: 'RACAT' - the value for the 'Category Of Exam' field.
94 ; Only passed in if either 'I' or 'O'.
95 ; 'RALOC' - The ien of the 'Requesting Location'
96 ; Output: correct category (I or O)_"^"_$S(Category='I':ward,1:"")
97 ;
98 N RA44 S RA44=$G(^SC(+RALOC,0))
99 I $E(RACAT,1)'="I",$E(RACAT,1)'="O" Q RACAT
100 I $E(RACAT,1)="O",$P(RA44,U,3)'="C",($P(RA44,U,3)'="OR") S RACAT="INPATIENT"
101 I $E(RACAT,1)="I",$P(RA44,U,3)'="W",($P(RA44,U,3)'="OR") S RACAT="OUTPATIENT"
102 Q RACAT_"^"_$S($E(RACAT,1)="I":$P(RA44,"^"),1:"")
103 ;
104PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the
105 ; user if the patient is between the ages of 12 - 55 inclusive.
106 ; Called from CREATE1^RAORD1.
107 ; Input : RADFN - Patient, RADT - Today's date
108 ; Output: Patient Pregnant? (yes, no, unknown or no default)
109 ; Note: (may set RAOUT if the user times out or '^' out)
110 Q:RASEX'="F" "" ; not a female
111 S:RADT="" RADT=$$DT^XLFDT()
112 N RADAYS,VADM D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal
113 S RADAYS=$$FMDIFF^XLFDT(RAWHEN,$P(VADM(3),"^"),3)
114 Q:((RADAYS\365.25)<12) "" ; too young
115 Q:((RADAYS\365.25)>55) "" ; too old
116 N DIR,DIROUT,DIRUT,DUOUT,DTOUT S DIR(0)="75.1,13" D ^DIR
117 S:$D(DIRUT) RAOUT="^" Q:$D(RAOUT) ""
118 Q $P(Y,"^")
119 ;
120INIMOD(Y) ; check if the user has selected the same
121 ; modifier more than once when the order is requested.
122 ; The 'Request an Exam' option. Called from MODS^RAORD1
123 ; Input: 'Y' the name of the procedure modifier
124 ; Output: 'X' if the user has not entered this modifier in
125 ; the past return one (1). Else return zero (0).
126 Q:'$D(RAMOD) 1 ; must allow the selection of the first modifier
127 ; after this, it is assumed that the RAMOD array is defined.
128 N RACNT,X S X=1,RACNT=99999
129 F S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0) S:RAMOD(RACNT)=Y X=0
130 Q X
Note: See TracBrowser for help on using the repository browser.