RAORD1A	;HISC/FPT-Request an Exam ;7/27/07  08:00
	;;5.0;Radiology/Nuclear Medicine;**1,86**;Mar 16, 1998;Build 7
	;
	;Call to WIN^DGPMDDCF (Supported IA #1246) from the SCREENW function
	;Supported IA #10039 reference to ^DIC(42
	;Supported IA #10040 reference to ^SC
	;Supported IA #10061 reference to ^VADPT
	;Supported IA #10103 reference to ^XLFDT
	;
SCREEN(RAINPAT,RACPRS27)	; screen for active clinics/wards
	; This code is also called from RAORD1 (screen for the Patient Location
	; prompt which is a pointer to the HOSPITAL LOCATION (#44) file.)
	; We want to EXCLUDE from our selection the following types of
	; hospital locations:
	;
	;  1) Occasion of Service (OOS) locations (fld: 50.01) 'OOS' node
	;  2) File Area ("F") or Imaging ("I") locations (fld: 2)
	;  3) Inactivate Date (fld: 2505) 'I' node
	;
	; input: RAINPAT=1 if the patient is an inpatient located on a ward, else 0.
	;        RACPRS27=1 if the environment is running CPRS GUI v27, else 0.
	;
	Q:$D(^SC(+Y,"OOS"))#2 0 ; #1
	N RA44 S RA44=$G(^SC(+Y,0)),RA44(42)=$P($G(^SC(+Y,42)),U)
	Q:"^F^I^"[(U_$P(RA44,U,3)_U) 0 ; #2
	;
	; if the hospital location is defined as a ward set RAWARD to 1, else 0
	N RAWARD S RAWARD=0
	;check the pointer to the WARD LOCATION file.
	I RA44(42)>0 D  Q:RAWARD=-1 0
	.;Error; the HOSPITAL LOCATION cannot be of TYPE 'Clinic' & point to a ward
	.I $P(RA44,U,3)="C" S RAWARD=-1 Q
	.;Error; bad pointers between files 42 & 44
	.I $P($G(^DIC(42,RA44(42),44)),U)'=+Y S RAWARD=-1 Q
	.;ok, set ward flag...
	.S RAWARD=1
	.Q
	;
	; 1) if the hospital location is a ward check if we should screen by ward
	; 2) the hosp location=ward, facility is running v26, and we have an
	;    outpatient quit zero (default of the $S)
	I RAWARD  Q $S(RACPRS27!RAINPAT:$$SCREENW(+Y),1:0)
	;
	; if the hospital location is a clinic, we have an inpatient, and the
	; facility is not running CPRS v27 return 0
	I 'RACPRS27,(RAINPAT) Q 0
	;
	; Check INACTIVATE DATE against REACTIVATE DATE
	; inactivate date = reactivate date (allow)
	; inactivate date > reactivate date (disallow)
	; inactivate date < reactivate date (allow)
	;
	N RASCA,RASCI,RASCINDE S RASCINDE=$G(^SC(+Y,"I"))
	S RASCI=+$P(RASCINDE,U),RASCA=+$P(RASCINDE,U,2)
	;
	Q $S(RASCI'>0:1,RASCI>DT:1,1:RASCI'>RASCA)
	;
SCREENW(Y)	; check the out-of-service field of the WARD LOCATION (#42) record.
	;input Y: ien of the HOSPITAL LOCATION record
	; RAWHEN: DATE DESIRED (Not guaranteed) (file: 75.1, fld: 21) optional
	;output : '0' if not valid, else '1' if valid 
	N D0,DGPMOS,X
	S D0=+$G(^SC(Y,42))
	Q:'D0 0
	Q:'($D(^DIC(42,D0,0))#2) 0
	;
	;WIN^DGPMDDCF (Supported IA #1246) Is the ward active?
	; Input
	;  D0 "Dee zero" (req): IEN of WARD LOCATION file.  
	;  DGPMOS (opt): defaults to DT. Is the ward in service on this date?  
	; Output
	;  X: 1 if out of service, 0 if in service, or -1 if input variables
	;     not defined properly. Be careful; note the difference in their
	;     boolean definition ('0'=success) and ours ('0'=failure)
	;
	S:$D(RAWHEN)#2 DGPMOS=$P(RAWHEN,".",1)
	D WIN^DGPMDDCF
	Q 'X  ;alter 'X' (the WIN^DGPMDDCF output value) to meet our ($$SCREENW) output definition
	;
PREG(RADFN,RADT)	; Subroutine will display the pregnancy prompt to the
	; user if the patient is between the ages of 12 - 55 inclusive.
	; Called from CREATE1^RAORD1.
	; Input : RADFN - Patient, RADT - Today's date
	; Output: Patient Pregnant? (yes, no, unknown or no default)
	;   Note: (may set RAOUT if the user times out or '^' out)
	Q:RASEX'="F" "" ; not a female
	S:RADT="" RADT=$$DT^XLFDT()
	N RADAYS,VADM D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal
	S RADAYS=$$FMDIFF^XLFDT(RAWHEN,$P(VADM(3),"^"),3)
	Q:((RADAYS\365.25)<12) "" ; too young
	Q:((RADAYS\365.25)>55) "" ; too old
	N DIR,DIROUT,DIRUT,DUOUT,DTOUT S DIR(0)="75.1,13" D ^DIR
	S:$D(DIRUT) RAOUT="^" Q:$D(RAOUT) ""
	Q $P(Y,"^")
	;
INIMOD(Y)	; check if the user has selected the same
	; modifier more than once when the order is requested.
	; The 'Request an Exam' option.  Called from MODS^RAORD1
	; Input: 'Y' the name of the procedure modifier
	; Output: 'X' if the user has not entered this modifier in
	;             the past return one (1).  Else return zero (0).
	Q:'$D(RAMOD) 1 ; must allow the selection of the first modifier
	; after this, it is assumed that the RAMOD array is defined.
	N RACNT,X S X=1,RACNT=99999
	F  S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0)  S:RAMOD(RACNT)=Y X=0
	Q X
	;