- 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
- 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