RAUTL7 ;HISC/CAH,FPT,GJC-Utility for RACCESS array ;5/8/97 14:55
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIVIACC ; Sets up division and imaging access based on location.
; Requires RACCESS array. Creates 'DIV-IMG' elements of
; array: RACCESS(DUZ,"DIV-IMG",Division name,Imaging type name)=""
I '$D(RACCESS(DUZ,"LOC")) D Q
. W !?5,"Please contact your ADPAC regarding access to"
. W !?5,"Imaging Locations.",$C(7)
. Q
N X,Y S X=0
F S X=$O(RACCESS(DUZ,"LOC",X)) Q:'X D
. S X(0)=$G(^RA(79.1,X,0)),X("DIV")=+$G(^RA(79.1,X,"DIV"))
. S X("DIV")=+$G(^RA(79,X("DIV"),0)),X("IMG")=+$P(X(0),"^",6)
. S Y("DIV")=$P($G(^DIC(4,X("DIV"),0)),"^")
. S Y("IMG")=$P($G(^RA(79.2,X("IMG"),0)),"^")
. I Y("DIV")]"",(Y("IMG")]"") D
.. S RACCESS(DUZ,"DIV-IMG",Y("DIV"),Y("IMG"))=""
.. Q
. Q
Q
SETUPDI() ; Set up Division/Imaging Type access
; Requires RACCESS(DUZ,"IMG"). Passes back to calling routine
; a 1 if failure because user has no imaging type access based on
; location access (probably no location access in File 200) .
; Passes back 0 if success. Does a call to
; above routine to set up "DIV-IMG" elements of RACCESS array.
; If "DIV-IMG" elements do not exist, displays error message
; to user.
N Y S Y=0
I '$D(RACCESS(DUZ,"IMG")) S Y=1 D Q Y
. W !?5,"You do not have access to any Imaging Locations."
. W !?5,"Contact your ADPAC.",$C(7)
. Q
D DIVIACC^RAUTL7 ; Set up Div-Img access array
I '$D(RACCESS(DUZ,"DIV-IMG")) S Y=1 D Q Y
. W !?5,"You have no Imaging Location Access Privileges."
. W !?5,"Contact your ADPAC.",$C(7)
. H 3 Q
Q Y
SELDIV ; Select Division, if exists
; Requires RACCESS "DIV" elements. Prompts user to select division(s).
; Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
; contains all divisions selected.
N RAONE S RAONE=$$DIV1()
I $P(RAONE,"^")]"" S RAQUIT=0 D Q
. S ^TMP($J,"RA D-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
. Q
S RADIC="^RA(79,",RADIC(0)="QEAMZ"
S RADIC("A")="Select Rad/Nuc Med Division: ",RADIC("B")="All"
S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+Y))",RAUTIL="RA D-TYPE"
D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
Q
SELIMG ; Select Imaging Type, if exists
; Prompts user to select Imaging Type(s).
; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)=""
N RA,RAIMGNUM,RAONE S RA="",RAONE=$$IMG1()
; .... chk if only 1 img type is available
I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
. S ^TMP($J,"RA I-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
. Q
; .... chk if only 1 img type within selectable division is available
; raimgnum = number of selectable img types
I $D(^TMP($J,"RA D-TYPE")) D
. D SETUP^RAUTL7A S RAIMGNUM=$$IMGNUM^RAUTL7A()
. Q
I $D(^TMP($J,"RA D-TYPE")),(RAIMGNUM=1) D S RAQUIT=0 Q
. N RA0,RA1
. S RA1=+$O(^TMP($J,"DIV-IMG",0)),RA0=$P($G(^RA(79.2,RA1,0)),"^")
. S ^TMP($J,"RA I-TYPE",RA0,RA1)=""
. Q
S RADIC="^RA(79.2,",RADIC(0)="QEAMZ",RAUTIL="RA I-TYPE"
S RADIC("A")="Select Imaging Type: ",RADIC("B")="All"
I $D(^TMP($J,"RA D-TYPE")) D
. S RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
. Q
; why do we need to check the alternative ? DIVLOC+3 prevents this
; alternative from occurring.
E S RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))"
W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
Q
SELLOC ; Select Imaging Location
; Prompts user to select Imaging Location(s)
; Creates ^TMP($J,"RA LOC-TYPE",img-loc name,img-loc ien)
N RALOCNUM,RAONE S RAONE=$$LOC1()
; .... chk if only 1 img type is available
I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
. S ^TMP($J,"RA LOC-TYPE",$P($G(^SC(+$P(RAONE,"^"),0)),U),$P(RAONE,"^",2))=""
. Q
; .... chk if only 1 img type within selectable division is available
I $D(^TMP($J,"RA D-TYPE")) D
. D SETUPL^RAUTL7A S RALOCNUM=$$LOCNUM^RAUTL7A()
. Q
I $D(^TMP($J,"RA D-TYPE")),(RALOCNUM=1) D S RAQUIT=0 Q
. N RA0,RA1
. S RA1=+$O(^TMP($J,"DIV-ITYP-ILOC",0)),RA0=$P($G(^RA(79.1,RA1,0)),"^")
. S RA0=$P($G(^SC(+RA0,0)),U)
. S ^TMP($J,"RA LOC-TYPE",RA0,RA1)=""
. Q
S RADIC="^RA(79.1,",RADIC(0)="QEAMZ",RAUTIL="RA LOC-TYPE"
S RADIC("A")="Select Imaging Location: ",RADIC("B")="All"
I $D(^TMP($J,"RA D-TYPE")) D
. S RADIC("S")="I $D(^TMP($J,""DIV-ITYP-ILOC"",+Y))"
. Q
; the alternative is included here to match that in SELIMG
E S RADIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
Q
DIV1() ; Check if the user has access to more than one division
; Returns Division name AND Division IEN if one only.
; Returns Null if more than one division.
N X,Y S X=+$O(RACCESS(DUZ,"DIV",0)) Q:'X ""
S Y=+$O(RACCESS(DUZ,"DIV",X)) Q:'Y $P($G(^DIC(4,X,0)),"^")_"^"_X
Q ""
IMG1() ; Check if the user has access to more than one i-type
; Returns Imaging type name AND Imaging Type IEN if one only.
; Returns Null if more than one imaging type.
N X,Y S X=+$O(RACCESS(DUZ,"IMG",0)) Q:'X ""
S Y=+$O(RACCESS(DUZ,"IMG",X)) Q:'Y $P($G(^RA(79.2,X,0)),"^")_"^"_X
Q ""
LOC1() ; Check if the user has access to more than one location
; Returns Rad/Nuc Med Location if one only.
; Returns Null if more than one Rad/Nuc Med Location, or no access
N X,Y S X=+$O(RACCESS(DUZ,"LOC",0)) Q:'X ""
S Y=+$O(RACCESS(DUZ,"LOC",X)) Q:'Y $P($G(^RA(79.1,X,0)),"^")_"^"_X
Q ""
DIVLOC() ; Entry point to setup division/img-typ/img-loc access
N X S X=$$SETUPDI^RAUTL7() Q:X 1
D SELDIV^RAUTL7 ; Select Rad division(s)
I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) D Q 1
. K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
. Q
N RASUB S RASUB="" D SELIMG^RAUTL7 ; Select I-Type
I '$D(^TMP($J,"RA I-TYPE"))!(RAQUIT) D Q 1
. K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
. Q
K ^TMP($J,"DIV-IMG")
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL7 5879 printed Apr 09, 2024@21:40 Page 2
RAUTL7 ;HISC/CAH,FPT,GJC-Utility for RACCESS array ;5/8/97 14:55
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIVIACC ; Sets up division and imaging access based on location.
+1 ; Requires RACCESS array. Creates 'DIV-IMG' elements of
+2 ; array: RACCESS(DUZ,"DIV-IMG",Division name,Imaging type name)=""
+3 IF '$DATA(RACCESS(DUZ,"LOC"))
Begin DoDot:1
+4 WRITE !?5,"Please contact your ADPAC regarding access to"
+5 WRITE !?5,"Imaging Locations.",$CHAR(7)
+6 QUIT
End DoDot:1
QUIT
+7 NEW X,Y
SET X=0
+8 FOR
SET X=$ORDER(RACCESS(DUZ,"LOC",X))
if 'X
QUIT
Begin DoDot:1
+9 SET X(0)=$GET(^RA(79.1,X,0))
SET X("DIV")=+$GET(^RA(79.1,X,"DIV"))
+10 SET X("DIV")=+$GET(^RA(79,X("DIV"),0))
SET X("IMG")=+$PIECE(X(0),"^",6)
+11 SET Y("DIV")=$PIECE($GET(^DIC(4,X("DIV"),0)),"^")
+12 SET Y("IMG")=$PIECE($GET(^RA(79.2,X("IMG"),0)),"^")
+13 IF Y("DIV")]""
IF (Y("IMG")]"")
Begin DoDot:2
+14 SET RACCESS(DUZ,"DIV-IMG",Y("DIV"),Y("IMG"))=""
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
SETUPDI() ; Set up Division/Imaging Type access
+1 ; Requires RACCESS(DUZ,"IMG"). Passes back to calling routine
+2 ; a 1 if failure because user has no imaging type access based on
+3 ; location access (probably no location access in File 200) .
+4 ; Passes back 0 if success. Does a call to
+5 ; above routine to set up "DIV-IMG" elements of RACCESS array.
+6 ; If "DIV-IMG" elements do not exist, displays error message
+7 ; to user.
+8 NEW Y
SET Y=0
+9 IF '$DATA(RACCESS(DUZ,"IMG"))
SET Y=1
Begin DoDot:1
+10 WRITE !?5,"You do not have access to any Imaging Locations."
+11 WRITE !?5,"Contact your ADPAC.",$CHAR(7)
+12 QUIT
End DoDot:1
QUIT Y
+13 ; Set up Div-Img access array
DO DIVIACC^RAUTL7
+14 IF '$DATA(RACCESS(DUZ,"DIV-IMG"))
SET Y=1
Begin DoDot:1
+15 WRITE !?5,"You have no Imaging Location Access Privileges."
+16 WRITE !?5,"Contact your ADPAC.",$CHAR(7)
+17 HANG 3
QUIT
End DoDot:1
QUIT Y
+18 QUIT Y
SELDIV ; Select Division, if exists
+1 ; Requires RACCESS "DIV" elements. Prompts user to select division(s).
+2 ; Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
+3 ; contains all divisions selected.
+4 NEW RAONE
SET RAONE=$$DIV1()
+5 IF $PIECE(RAONE,"^")]""
SET RAQUIT=0
Begin DoDot:1
+6 SET ^TMP($JOB,"RA D-TYPE",$PIECE(RAONE,"^"),$PIECE(RAONE,"^",2))=""
+7 QUIT
End DoDot:1
QUIT
+8 SET RADIC="^RA(79,"
SET RADIC(0)="QEAMZ"
+9 SET RADIC("A")="Select Rad/Nuc Med Division: "
SET RADIC("B")="All"
+10 SET RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+Y))"
SET RAUTIL="RA D-TYPE"
+11 DO EN1^RASELCT(.RADIC,RAUTIL)
KILL %W,%Y1,DIC,RADIC,RAUTIL,X,Y
+12 QUIT
SELIMG ; Select Imaging Type, if exists
+1 ; Prompts user to select Imaging Type(s).
+2 ; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)=""
+3 NEW RA,RAIMGNUM,RAONE
SET RA=""
SET RAONE=$$IMG1()
+4 ; .... chk if only 1 img type is available
+5 IF $PIECE(RAONE,"^")]""
IF ('$DATA(^TMP($JOB,"RA D-TYPE")))
SET RAQUIT=0
Begin DoDot:1
+6 SET ^TMP($JOB,"RA I-TYPE",$PIECE(RAONE,"^"),$PIECE(RAONE,"^",2))=""
+7 QUIT
End DoDot:1
QUIT
+8 ; .... chk if only 1 img type within selectable division is available
+9 ; raimgnum = number of selectable img types
+10 IF $DATA(^TMP($JOB,"RA D-TYPE"))
Begin DoDot:1
+11 DO SETUP^RAUTL7A
SET RAIMGNUM=$$IMGNUM^RAUTL7A()
+12 QUIT
End DoDot:1
+13 IF $DATA(^TMP($JOB,"RA D-TYPE"))
IF (RAIMGNUM=1)
Begin DoDot:1
+14 NEW RA0,RA1
+15 SET RA1=+$ORDER(^TMP($JOB,"DIV-IMG",0))
SET RA0=$PIECE($GET(^RA(79.2,RA1,0)),"^")
+16 SET ^TMP($JOB,"RA I-TYPE",RA0,RA1)=""
+17 QUIT
End DoDot:1
SET RAQUIT=0
QUIT
+18 SET RADIC="^RA(79.2,"
SET RADIC(0)="QEAMZ"
SET RAUTIL="RA I-TYPE"
+19 SET RADIC("A")="Select Imaging Type: "
SET RADIC("B")="All"
+20 IF $DATA(^TMP($JOB,"RA D-TYPE"))
Begin DoDot:1
+21 SET RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
+22 QUIT
End DoDot:1
+23 ; why do we need to check the alternative ? DIVLOC+3 prevents this
+24 ; alternative from occurring.
+25 IF '$TEST
SET RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))"
+26 WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
KILL %W,%Y1,DIC,RADIC,RAUTIL,X,Y
+27 QUIT
SELLOC ; Select Imaging Location
+1 ; Prompts user to select Imaging Location(s)
+2 ; Creates ^TMP($J,"RA LOC-TYPE",img-loc name,img-loc ien)
+3 NEW RALOCNUM,RAONE
SET RAONE=$$LOC1()
+4 ; .... chk if only 1 img type is available
+5 IF $PIECE(RAONE,"^")]""
IF ('$DATA(^TMP($JOB,"RA D-TYPE")))
SET RAQUIT=0
Begin DoDot:1
+6 SET ^TMP($JOB,"RA LOC-TYPE",$PIECE($GET(^SC(+$PIECE(RAONE,"^"),0)),U),$PIECE(RAONE,"^",2))=""
+7 QUIT
End DoDot:1
QUIT
+8 ; .... chk if only 1 img type within selectable division is available
+9 IF $DATA(^TMP($JOB,"RA D-TYPE"))
Begin DoDot:1
+10 DO SETUPL^RAUTL7A
SET RALOCNUM=$$LOCNUM^RAUTL7A()
+11 QUIT
End DoDot:1
+12 IF $DATA(^TMP($JOB,"RA D-TYPE"))
IF (RALOCNUM=1)
Begin DoDot:1
+13 NEW RA0,RA1
+14 SET RA1=+$ORDER(^TMP($JOB,"DIV-ITYP-ILOC",0))
SET RA0=$PIECE($GET(^RA(79.1,RA1,0)),"^")
+15 SET RA0=$PIECE($GET(^SC(+RA0,0)),U)
+16 SET ^TMP($JOB,"RA LOC-TYPE",RA0,RA1)=""
+17 QUIT
End DoDot:1
SET RAQUIT=0
QUIT
+18 SET RADIC="^RA(79.1,"
SET RADIC(0)="QEAMZ"
SET RAUTIL="RA LOC-TYPE"
+19 SET RADIC("A")="Select Imaging Location: "
SET RADIC("B")="All"
+20 IF $DATA(^TMP($JOB,"RA D-TYPE"))
Begin DoDot:1
+21 SET RADIC("S")="I $D(^TMP($J,""DIV-ITYP-ILOC"",+Y))"
+22 QUIT
End DoDot:1
+23 ; the alternative is included here to match that in SELIMG
+24 IF '$TEST
SET RADIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
+25 WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
KILL %W,%Y1,DIC,RADIC,RAUTIL,X,Y
+26 QUIT
DIV1() ; Check if the user has access to more than one division
+1 ; Returns Division name AND Division IEN if one only.
+2 ; Returns Null if more than one division.
+3 NEW X,Y
SET X=+$ORDER(RACCESS(DUZ,"DIV",0))
if 'X
QUIT ""
+4 SET Y=+$ORDER(RACCESS(DUZ,"DIV",X))
if 'Y
QUIT $PIECE($GET(^DIC(4,X,0)),"^")_"^"_X
+5 QUIT ""
IMG1() ; Check if the user has access to more than one i-type
+1 ; Returns Imaging type name AND Imaging Type IEN if one only.
+2 ; Returns Null if more than one imaging type.
+3 NEW X,Y
SET X=+$ORDER(RACCESS(DUZ,"IMG",0))
if 'X
QUIT ""
+4 SET Y=+$ORDER(RACCESS(DUZ,"IMG",X))
if 'Y
QUIT $PIECE($GET(^RA(79.2,X,0)),"^")_"^"_X
+5 QUIT ""
LOC1() ; Check if the user has access to more than one location
+1 ; Returns Rad/Nuc Med Location if one only.
+2 ; Returns Null if more than one Rad/Nuc Med Location, or no access
+3 NEW X,Y
SET X=+$ORDER(RACCESS(DUZ,"LOC",0))
if 'X
QUIT ""
+4 SET Y=+$ORDER(RACCESS(DUZ,"LOC",X))
if 'Y
QUIT $PIECE($GET(^RA(79.1,X,0)),"^")_"^"_X
+5 QUIT ""
DIVLOC() ; Entry point to setup division/img-typ/img-loc access
+1 NEW X
SET X=$$SETUPDI^RAUTL7()
if X
QUIT 1
+2 ; Select Rad division(s)
DO SELDIV^RAUTL7
+3 IF '$DATA(^TMP($JOB,"RA D-TYPE"))!(RAQUIT)
Begin DoDot:1
+4 KILL RACCESS(DUZ,"DIV-IMG"),^TMP($JOB,"DIV-IMG")
+5 QUIT
End DoDot:1
QUIT 1
+6 ; Select I-Type
NEW RASUB
SET RASUB=""
DO SELIMG^RAUTL7
+7 IF '$DATA(^TMP($JOB,"RA I-TYPE"))!(RAQUIT)
Begin DoDot:1
+8 KILL RACCESS(DUZ,"DIV-IMG"),^TMP($JOB,"DIV-IMG")
+9 QUIT
End DoDot:1
QUIT 1
+10 KILL ^TMP($JOB,"DIV-IMG")
+11 QUIT 0
