source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL7.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: 5.6 KB
Line 
1RAUTL7 ;HISC/CAH,FPT,GJC-Utility for RACCESS array ;5/8/97 14:55
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3DIVIACC ; Sets up division and imaging access based on location.
4 ; Requires RACCESS array. Creates 'DIV-IMG' elements of
5 ; array: RACCESS(DUZ,"DIV-IMG",Division name,Imaging type name)=""
6 I '$D(RACCESS(DUZ,"LOC")) D Q
7 . W !?5,"Please contact your ADPAC regarding access to"
8 . W !?5,"Imaging Locations.",$C(7)
9 . Q
10 N X,Y S X=0
11 F S X=$O(RACCESS(DUZ,"LOC",X)) Q:'X D
12 . S X(0)=$G(^RA(79.1,X,0)),X("DIV")=+$G(^RA(79.1,X,"DIV"))
13 . S X("DIV")=+$G(^RA(79,X("DIV"),0)),X("IMG")=+$P(X(0),"^",6)
14 . S Y("DIV")=$P($G(^DIC(4,X("DIV"),0)),"^")
15 . S Y("IMG")=$P($G(^RA(79.2,X("IMG"),0)),"^")
16 . I Y("DIV")]"",(Y("IMG")]"") D
17 .. S RACCESS(DUZ,"DIV-IMG",Y("DIV"),Y("IMG"))=""
18 .. Q
19 . Q
20 Q
21SETUPDI() ; Set up Division/Imaging Type access
22 ; Requires RACCESS(DUZ,"IMG"). Passes back to calling routine
23 ; a 1 if failure because user has no imaging type access based on
24 ; location access (probably no location access in File 200) .
25 ; Passes back 0 if success. Does a call to
26 ; above routine to set up "DIV-IMG" elements of RACCESS array.
27 ; If "DIV-IMG" elements do not exist, displays error message
28 ; to user.
29 N Y S Y=0
30 I '$D(RACCESS(DUZ,"IMG")) S Y=1 D Q Y
31 . W !?5,"You do not have access to any Imaging Locations."
32 . W !?5,"Contact your ADPAC.",$C(7)
33 . Q
34 D DIVIACC^RAUTL7 ; Set up Div-Img access array
35 I '$D(RACCESS(DUZ,"DIV-IMG")) S Y=1 D Q Y
36 . W !?5,"You have no Imaging Location Access Privileges."
37 . W !?5,"Contact your ADPAC.",$C(7)
38 . H 3 Q
39 Q Y
40SELDIV ; Select Division, if exists
41 ; Requires RACCESS "DIV" elements. Prompts user to select division(s).
42 ; Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
43 ; contains all divisions selected.
44 N RAONE S RAONE=$$DIV1()
45 I $P(RAONE,"^")]"" S RAQUIT=0 D Q
46 . S ^TMP($J,"RA D-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
47 . Q
48 S RADIC="^RA(79,",RADIC(0)="QEAMZ"
49 S RADIC("A")="Select Rad/Nuc Med Division: ",RADIC("B")="All"
50 S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+Y))",RAUTIL="RA D-TYPE"
51 D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
52 Q
53SELIMG ; Select Imaging Type, if exists
54 ; Prompts user to select Imaging Type(s).
55 ; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)=""
56 N RA,RAIMGNUM,RAONE S RA="",RAONE=$$IMG1()
57 ; .... chk if only 1 img type is available
58 I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
59 . S ^TMP($J,"RA I-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
60 . Q
61 ; .... chk if only 1 img type within selectable division is available
62 ; raimgnum = number of selectable img types
63 I $D(^TMP($J,"RA D-TYPE")) D
64 . D SETUP^RAUTL7A S RAIMGNUM=$$IMGNUM^RAUTL7A()
65 . Q
66 I $D(^TMP($J,"RA D-TYPE")),(RAIMGNUM=1) D S RAQUIT=0 Q
67 . N RA0,RA1
68 . S RA1=+$O(^TMP($J,"DIV-IMG",0)),RA0=$P($G(^RA(79.2,RA1,0)),"^")
69 . S ^TMP($J,"RA I-TYPE",RA0,RA1)=""
70 . Q
71 S RADIC="^RA(79.2,",RADIC(0)="QEAMZ",RAUTIL="RA I-TYPE"
72 S RADIC("A")="Select Imaging Type: ",RADIC("B")="All"
73 I $D(^TMP($J,"RA D-TYPE")) D
74 . S RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
75 . Q
76 ; why do we need to check the alternative ? DIVLOC+3 prevents this
77 ; alternative from occurring.
78 E S RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))"
79 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
80 Q
81SELLOC ; Select Imaging Location
82 ; Prompts user to select Imaging Location(s)
83 ; Creates ^TMP($J,"RA LOC-TYPE",img-loc name,img-loc ien)
84 N RALOCNUM,RAONE S RAONE=$$LOC1()
85 ; .... chk if only 1 img type is available
86 I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
87 . S ^TMP($J,"RA LOC-TYPE",$P($G(^SC(+$P(RAONE,"^"),0)),U),$P(RAONE,"^",2))=""
88 . Q
89 ; .... chk if only 1 img type within selectable division is available
90 I $D(^TMP($J,"RA D-TYPE")) D
91 . D SETUPL^RAUTL7A S RALOCNUM=$$LOCNUM^RAUTL7A()
92 . Q
93 I $D(^TMP($J,"RA D-TYPE")),(RALOCNUM=1) D S RAQUIT=0 Q
94 . N RA0,RA1
95 . S RA1=+$O(^TMP($J,"DIV-ITYP-ILOC",0)),RA0=$P($G(^RA(79.1,RA1,0)),"^")
96 . S RA0=$P($G(^SC(+RA0,0)),U)
97 . S ^TMP($J,"RA LOC-TYPE",RA0,RA1)=""
98 . Q
99 S RADIC="^RA(79.1,",RADIC(0)="QEAMZ",RAUTIL="RA LOC-TYPE"
100 S RADIC("A")="Select Imaging Location: ",RADIC("B")="All"
101 I $D(^TMP($J,"RA D-TYPE")) D
102 . S RADIC("S")="I $D(^TMP($J,""DIV-ITYP-ILOC"",+Y))"
103 . Q
104 ; the alternative is included here to match that in SELIMG
105 E S RADIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
106 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
107 Q
108DIV1() ; Check if the user has access to more than one division
109 ; Returns Division name AND Division IEN if one only.
110 ; Returns Null if more than one division.
111 N X,Y S X=+$O(RACCESS(DUZ,"DIV",0)) Q:'X ""
112 S Y=+$O(RACCESS(DUZ,"DIV",X)) Q:'Y $P($G(^DIC(4,X,0)),"^")_"^"_X
113 Q ""
114IMG1() ; Check if the user has access to more than one i-type
115 ; Returns Imaging type name AND Imaging Type IEN if one only.
116 ; Returns Null if more than one imaging type.
117 N X,Y S X=+$O(RACCESS(DUZ,"IMG",0)) Q:'X ""
118 S Y=+$O(RACCESS(DUZ,"IMG",X)) Q:'Y $P($G(^RA(79.2,X,0)),"^")_"^"_X
119 Q ""
120LOC1() ; Check if the user has access to more than one location
121 ; Returns Rad/Nuc Med Location if one only.
122 ; Returns Null if more than one Rad/Nuc Med Location, or no access
123 N X,Y S X=+$O(RACCESS(DUZ,"LOC",0)) Q:'X ""
124 S Y=+$O(RACCESS(DUZ,"LOC",X)) Q:'Y $P($G(^RA(79.1,X,0)),"^")_"^"_X
125 Q ""
126DIVLOC() ; Entry point to setup division/img-typ/img-loc access
127 N X S X=$$SETUPDI^RAUTL7() Q:X 1
128 D SELDIV^RAUTL7 ; Select Rad division(s)
129 I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) D Q 1
130 . K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
131 . Q
132 N RASUB S RASUB="" D SELIMG^RAUTL7 ; Select I-Type
133 I '$D(^TMP($J,"RA I-TYPE"))!(RAQUIT) D Q 1
134 . K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
135 . Q
136 K ^TMP($J,"DIV-IMG")
137 Q 0
Note: See TracBrowser for help on using the repository browser.