Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAUTL7

RAUTL7.m

Go to the documentation of this file.
  1. RAUTL7 ;HISC/CAH,FPT,GJC-Utility for RACCESS array ;5/8/97 14:55
  1. ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1. DIVIACC ; Sets up division and imaging access based on location.
  1. ; Requires RACCESS array. Creates 'DIV-IMG' elements of
  1. ; array: RACCESS(DUZ,"DIV-IMG",Division name,Imaging type name)=""
  1. I '$D(RACCESS(DUZ,"LOC")) D Q
  1. . W !?5,"Please contact your ADPAC regarding access to"
  1. . W !?5,"Imaging Locations.",$C(7)
  1. . Q
  1. N X,Y S X=0
  1. F S X=$O(RACCESS(DUZ,"LOC",X)) Q:'X D
  1. . S X(0)=$G(^RA(79.1,X,0)),X("DIV")=+$G(^RA(79.1,X,"DIV"))
  1. . S X("DIV")=+$G(^RA(79,X("DIV"),0)),X("IMG")=+$P(X(0),"^",6)
  1. . S Y("DIV")=$P($G(^DIC(4,X("DIV"),0)),"^")
  1. . S Y("IMG")=$P($G(^RA(79.2,X("IMG"),0)),"^")
  1. . I Y("DIV")]"",(Y("IMG")]"") D
  1. .. S RACCESS(DUZ,"DIV-IMG",Y("DIV"),Y("IMG"))=""
  1. .. Q
  1. . Q
  1. Q
  1. SETUPDI() ; Set up Division/Imaging Type access
  1. ; Requires RACCESS(DUZ,"IMG"). Passes back to calling routine
  1. ; a 1 if failure because user has no imaging type access based on
  1. ; location access (probably no location access in File 200) .
  1. ; Passes back 0 if success. Does a call to
  1. ; above routine to set up "DIV-IMG" elements of RACCESS array.
  1. ; If "DIV-IMG" elements do not exist, displays error message
  1. ; to user.
  1. N Y S Y=0
  1. I '$D(RACCESS(DUZ,"IMG")) S Y=1 D Q Y
  1. . W !?5,"You do not have access to any Imaging Locations."
  1. . W !?5,"Contact your ADPAC.",$C(7)
  1. . Q
  1. D DIVIACC^RAUTL7 ; Set up Div-Img access array
  1. I '$D(RACCESS(DUZ,"DIV-IMG")) S Y=1 D Q Y
  1. . W !?5,"You have no Imaging Location Access Privileges."
  1. . W !?5,"Contact your ADPAC.",$C(7)
  1. . H 3 Q
  1. Q Y
  1. SELDIV ; Select Division, if exists
  1. ; Requires RACCESS "DIV" elements. Prompts user to select division(s).
  1. ; Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
  1. ; contains all divisions selected.
  1. N RAONE S RAONE=$$DIV1()
  1. I $P(RAONE,"^")]"" S RAQUIT=0 D Q
  1. . S ^TMP($J,"RA D-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
  1. . Q
  1. S RADIC="^RA(79,",RADIC(0)="QEAMZ"
  1. S RADIC("A")="Select Rad/Nuc Med Division: ",RADIC("B")="All"
  1. S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+Y))",RAUTIL="RA D-TYPE"
  1. D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
  1. Q
  1. SELIMG ; Select Imaging Type, if exists
  1. ; Prompts user to select Imaging Type(s).
  1. ; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)=""
  1. N RA,RAIMGNUM,RAONE S RA="",RAONE=$$IMG1()
  1. ; .... chk if only 1 img type is available
  1. I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
  1. . S ^TMP($J,"RA I-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))=""
  1. . Q
  1. ; .... chk if only 1 img type within selectable division is available
  1. ; raimgnum = number of selectable img types
  1. I $D(^TMP($J,"RA D-TYPE")) D
  1. . D SETUP^RAUTL7A S RAIMGNUM=$$IMGNUM^RAUTL7A()
  1. . Q
  1. I $D(^TMP($J,"RA D-TYPE")),(RAIMGNUM=1) D S RAQUIT=0 Q
  1. . N RA0,RA1
  1. . S RA1=+$O(^TMP($J,"DIV-IMG",0)),RA0=$P($G(^RA(79.2,RA1,0)),"^")
  1. . S ^TMP($J,"RA I-TYPE",RA0,RA1)=""
  1. . Q
  1. S RADIC="^RA(79.2,",RADIC(0)="QEAMZ",RAUTIL="RA I-TYPE"
  1. S RADIC("A")="Select Imaging Type: ",RADIC("B")="All"
  1. I $D(^TMP($J,"RA D-TYPE")) D
  1. . S RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))"
  1. . Q
  1. ; why do we need to check the alternative ? DIVLOC+3 prevents this
  1. ; alternative from occurring.
  1. E S RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))"
  1. W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
  1. Q
  1. SELLOC ; Select Imaging Location
  1. ; Prompts user to select Imaging Location(s)
  1. ; Creates ^TMP($J,"RA LOC-TYPE",img-loc name,img-loc ien)
  1. N RALOCNUM,RAONE S RAONE=$$LOC1()
  1. ; .... chk if only 1 img type is available
  1. I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q
  1. . S ^TMP($J,"RA LOC-TYPE",$P($G(^SC(+$P(RAONE,"^"),0)),U),$P(RAONE,"^",2))=""
  1. . Q
  1. ; .... chk if only 1 img type within selectable division is available
  1. I $D(^TMP($J,"RA D-TYPE")) D
  1. . D SETUPL^RAUTL7A S RALOCNUM=$$LOCNUM^RAUTL7A()
  1. . Q
  1. I $D(^TMP($J,"RA D-TYPE")),(RALOCNUM=1) D S RAQUIT=0 Q
  1. . N RA0,RA1
  1. . S RA1=+$O(^TMP($J,"DIV-ITYP-ILOC",0)),RA0=$P($G(^RA(79.1,RA1,0)),"^")
  1. . S RA0=$P($G(^SC(+RA0,0)),U)
  1. . S ^TMP($J,"RA LOC-TYPE",RA0,RA1)=""
  1. . Q
  1. S RADIC="^RA(79.1,",RADIC(0)="QEAMZ",RAUTIL="RA LOC-TYPE"
  1. S RADIC("A")="Select Imaging Location: ",RADIC("B")="All"
  1. I $D(^TMP($J,"RA D-TYPE")) D
  1. . S RADIC("S")="I $D(^TMP($J,""DIV-ITYP-ILOC"",+Y))"
  1. . Q
  1. ; the alternative is included here to match that in SELIMG
  1. E S RADIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
  1. W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y
  1. Q
  1. DIV1() ; Check if the user has access to more than one division
  1. ; Returns Division name AND Division IEN if one only.
  1. ; Returns Null if more than one division.
  1. N X,Y S X=+$O(RACCESS(DUZ,"DIV",0)) Q:'X ""
  1. S Y=+$O(RACCESS(DUZ,"DIV",X)) Q:'Y $P($G(^DIC(4,X,0)),"^")_"^"_X
  1. Q ""
  1. 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.
  1. ; Returns Null if more than one imaging type.
  1. N X,Y S X=+$O(RACCESS(DUZ,"IMG",0)) Q:'X ""
  1. S Y=+$O(RACCESS(DUZ,"IMG",X)) Q:'Y $P($G(^RA(79.2,X,0)),"^")_"^"_X
  1. Q ""
  1. LOC1() ; Check if the user has access to more than one location
  1. ; Returns Rad/Nuc Med Location if one only.
  1. ; Returns Null if more than one Rad/Nuc Med Location, or no access
  1. N X,Y S X=+$O(RACCESS(DUZ,"LOC",0)) Q:'X ""
  1. S Y=+$O(RACCESS(DUZ,"LOC",X)) Q:'Y $P($G(^RA(79.1,X,0)),"^")_"^"_X
  1. Q ""
  1. DIVLOC() ; Entry point to setup division/img-typ/img-loc access
  1. N X S X=$$SETUPDI^RAUTL7() Q:X 1
  1. D SELDIV^RAUTL7 ; Select Rad division(s)
  1. I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) D Q 1
  1. . K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
  1. . Q
  1. N RASUB S RASUB="" D SELIMG^RAUTL7 ; Select I-Type
  1. I '$D(^TMP($J,"RA I-TYPE"))!(RAQUIT) D Q 1
  1. . K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
  1. . Q
  1. K ^TMP($J,"DIV-IMG")
  1. Q 0