RAUTL6 ;HISC/GJC-Utility Routine ;2/19/98 10:52
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
VARACC(DUZ) ; This subroutine will determine the Imaging Location,
; Imaging Type, and the Divisional access for a specific individual.
; Divisional Access as well as Imaging Type Access is derived from
; the Imaging Locs assigned to each Rad/Nuc Med user. If the user
; holds the RA ALLOC key, that user has access to all Imaging Locs.
; This in turn implies that the user has all Divisional and Imaging
; Type access related to each specific Imaging Location.
;
Q:'+$G(DUZ) N RADIV,RAIMG,RAINDX,RAKEY,RALOC,RAMGRKEY
S RAMGRKEY=0
;
; *** RA ALLOC Key Holder ***
; If a RA ALLOC holder, set up Imaging Loc access from file 200.
; Format: RACCESS(DUZ,"LOC",IEN of 79.1)=.01 of 79.1, IEN of file 44^.01 of 44
;
I $D(^XUSEC("RA ALLOC",DUZ)) S RAMGRKEY=1 D
. S RAINDX=0
. F S RAINDX=$O(^RA(79.1,RAINDX)) Q:RAINDX'>0 D
.. S RALOC(0)=$G(^RA(79.1,RAINDX,0)),RALOC(1)=+$P(RALOC(0),U)
.. Q:RALOC(1)'>0 S RALOC(44)=$P($G(^SC(RALOC(1),0)),U)
.. S RACCESS(DUZ,"LOC",RAINDX)=RALOC(1)_"^"_RALOC(44)
.. Q
. K RALOC
. Q
;
; *** Imaging Location Access ***
; If not a RA ALLOC holder, set up Imaging Loc access from file 200.
; Format: RACCESS(DUZ,"LOC",IEN of 79.1)=.01 of 79.1, IEN of file 44^.01 of 44
;
I 'RAMGRKEY,($D(^VA(200,DUZ,"RAL",0))),(+$O(^VA(200,DUZ,"RAL",0))) D
. S RAINDX=0
. F S RAINDX=$O(^VA(200,DUZ,"RAL",RAINDX)) Q:RAINDX'>0 D
.. S RALOC(0)=$G(^VA(200,DUZ,"RAL",RAINDX,0)),RALOC(1)=+$P(RALOC(0),U)
.. Q:RALOC(1)'>0 S RALOC(44)=+$P($G(^RA(79.1,RALOC(1),0)),U)
.. S RACCESS(DUZ,"LOC",RALOC(1))=RALOC(44)_"^"_$P($G(^SC(RALOC(44),0)),U)
.. Q
. Q
;
; *** Division Access ***
; Format: RACCESS(DUZ,"DIV",IEN of 79,IEN of 79.1)="DIV";1 of file 79.1, pntr to file 4^.01 of 4
; NOTE: The first piece of the "DIV" node is a pntr to 79 (Rad Div)
; This value is DINUMED with file 4.
;
; Division is found in the Imaging Location file, ^RA(79.1
; it is the first piece of the "DIV" node. RAINDX is the IEN
; of ^RA(79.1
I $D(RACCESS(DUZ,"LOC")) D
. S RAINDX=0
. F S RAINDX=$O(RACCESS(DUZ,"LOC",RAINDX)) Q:RAINDX'>0 D
.. S RADIV(0)=$G(^RA(79.1,RAINDX,"DIV")),RADIV(1)=+$P(RADIV(0),U)
.. Q:RADIV(1)'>0 S RADIV(2)=+$P($G(^RA(79,RADIV(1),0)),U)
.. S RACCESS(DUZ,"DIV",RADIV(1),RAINDX)=RADIV(2)_"^"_$P($G(^DIC(4,RADIV(2),0)),U)
.. Q
. Q
;
; *** Imaging Type Access ***
; Format: RACCESS(DUZ,"IMG",IEN of 79.2,IEN of 79.1)=^.01 of 79.2
; NOTE: The sixth piece of the "zero" node is a pntr to 79.2 (Img Type)
;
; Imaging Type is found in the Imaging Location file (#79.1)
; it is the sixth piece of the "zero" node. RAINDX is the IEN
; of ^RA(79.1
I $D(RACCESS(DUZ,"LOC")) D
. S RAINDX=0
. F S RAINDX=$O(RACCESS(DUZ,"LOC",RAINDX)) Q:RAINDX'>0 D
.. S RAIMG(0)=$G(^RA(79.1,RAINDX,0)),RAIMG(1)=+$P(RAIMG(0),U,6)
.. Q:RAIMG(1)'>0 S RAIMG(2)=$P($G(^RA(79.2,RAIMG(1),0)),U)
.. S RACCESS(DUZ,"IMG",RAIMG(1),RAINDX)="^"_RAIMG(2)
.. Q
. Q
Q
DSPDIV ; Display 'Divisional Access' data
N X0,X1,Y0,Y1,Y2,Y3 S X0=0,Y3=1
I '$D(RACCESS(RADUZ,"DIV")) D Q
. W !?5,"Access to Radiology/Nuclear Medicine Divisional data is not "
. W "authorized.",$C(7)
S Y1="<<< Divisions Included >>>"
W !?5,Y1
F S X0=$O(RACCESS(RADUZ,"DIV",X0)) Q:X0'>0 D
. S X1=$O(RACCESS(RADUZ,"DIV",X0,0)) Q:X1'>0
. S Y0=$G(RACCESS(RADUZ,"DIV",X0,X1)) Q:Y0']""
. S Y2=$P(Y0,U,2) D PRINT
. Q
W !
Q
DSPIMG ; Display 'Imaging Type' data
N X0,X1,Y0,Y1,Y2,Y3 S X0=0,Y3=1
I '$D(RACCESS(RADUZ,"IMG")) D Q
. W !?5,"Access to Imaging Type data is not authorized."
. W $C(7)
S Y1="<<< Imaging Types Included >>>"
W !?5,Y1
F S X0=$O(RACCESS(RADUZ,"IMG",X0)) Q:X0'>0 D
. S X1=0
. F S X1=$O(RACCESS(RADUZ,"IMG",X0,X1)) Q:X1'>0 D
.. S Y0=$G(RACCESS(RADUZ,"IMG",X0,X1)) Q:Y0']""
.. S Y2=$P(Y0,U,2) D PRINT
.. Q
. Q
W !
Q
DSPLOC ; Display 'Imaging Location' data
N X0,Y0,Y1,Y2,Y3 S X0=0,Y3=1
I '$D(RACCESS(RADUZ,"LOC")) D Q
. W !?5,"Access to Imaging Location data is not authorized.",$C(7)
S Y1="<<< Locations Included >>>"
W !?5,Y1
F S X0=$O(RACCESS(RADUZ,"LOC",X0)) Q:X0'>0 D
. S Y0=$G(RACCESS(RADUZ,"LOC",X0)) Q:Y0']""
. S Y2=$P(Y0,U,2) D PRINT
. Q
W !
Q
PRINT ; Print out data
S Y3='Y3
I 'Y3 W !?5,Y2
E W ?45,Y2
Q
DIVSION(RADATE,RALIFN) ; Determine the division associated with the Requesting
; Location on a Rad/Nuc Med Order. Use the PIMS utilities in VASITE.
; Returns an institution file ptr value or -1 if the division
; could not be determined.
; Input - RADATE=a valid FileMan date (internal format)
; defaults to DT if passed in null
; RALIFN=Req. Location from Rad/Nuc Med Order.
; Output - RA1DIV=valid pointer the the Institution File, else -1
N RA1DIV S:$G(RADATE)="" RADATE=DT
; note: field 3.5 in file 44 is named DIVISION & is a pntr to file 40.8
S RA1DIV=+$$SITE^VASITE(RADATE,+$$GET1^DIQ(44,RALIFN,3.5,"I"))
; if $$SITE^VASITE fails, return the medical center division of the
; primary medical center division (this is a ptr to file 40.8)
S:RA1DIV=-1 RA1DIV=+$$SITE^VASITE(RADATE,+$$PRIM^VASITE(RADATE))
Q RA1DIV
RAUTL6 ;HISC/GJC-Utility Routine ;2/19/98 10:52
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
VARACC(DUZ) ; This subroutine will determine the Imaging Location,
+1 ; Imaging Type, and the Divisional access for a specific individual.
+2 ; Divisional Access as well as Imaging Type Access is derived from
+3 ; the Imaging Locs assigned to each Rad/Nuc Med user. If the user
+4 ; holds the RA ALLOC key, that user has access to all Imaging Locs.
+5 ; This in turn implies that the user has all Divisional and Imaging
+6 ; Type access related to each specific Imaging Location.
+7 ;
+8 IF '+$GET(DUZ)
QUIT
NEW RADIV,RAIMG,RAINDX,RAKEY,RALOC,RAMGRKEY
+9 SET RAMGRKEY=0
+10 ;
+11 ; *** RA ALLOC Key Holder ***
+12 ; If a RA ALLOC holder, set up Imaging Loc access from file 200.
+13 ; Format: RACCESS(DUZ,"LOC",IEN of 79.1)=.01 of 79.1, IEN of file 44^.01 of 44
+14 ;
+15 IF $DATA(^XUSEC("RA ALLOC",DUZ))
SET RAMGRKEY=1
Begin DoDot:1
+16 SET RAINDX=0
+17 FOR
SET RAINDX=$ORDER(^RA(79.1,RAINDX))
IF RAINDX'>0
QUIT
Begin DoDot:2
+18 SET RALOC(0)=$GET(^RA(79.1,RAINDX,0))
SET RALOC(1)=+$PIECE(RALOC(0),U)
+19 IF RALOC(1)'>0
QUIT
SET RALOC(44)=$PIECE($GET(^SC(RALOC(1),0)),U)
+20 SET RACCESS(DUZ,"LOC",RAINDX)=RALOC(1)_"^"_RALOC(44)
+21 QUIT
End DoDot:2
+22 KILL RALOC
+23 QUIT
End DoDot:1
+24 ;
+25 ; *** Imaging Location Access ***
+26 ; If not a RA ALLOC holder, set up Imaging Loc access from file 200.
+27 ; Format: RACCESS(DUZ,"LOC",IEN of 79.1)=.01 of 79.1, IEN of file 44^.01 of 44
+28 ;
+29 IF 'RAMGRKEY
IF ($DATA(^VA(200,DUZ,"RAL",0)))
IF (+$ORDER(^VA(200,DUZ,"RAL",0)))
Begin DoDot:1
+30 SET RAINDX=0
+31 FOR
SET RAINDX=$ORDER(^VA(200,DUZ,"RAL",RAINDX))
IF RAINDX'>0
QUIT
Begin DoDot:2
+32 SET RALOC(0)=$GET(^VA(200,DUZ,"RAL",RAINDX,0))
SET RALOC(1)=+$PIECE(RALOC(0),U)
+33 IF RALOC(1)'>0
QUIT
SET RALOC(44)=+$PIECE($GET(^RA(79.1,RALOC(1),0)),U)
+34 SET RACCESS(DUZ,"LOC",RALOC(1))=RALOC(44)_"^"_$PIECE($GET(^SC(RALOC(44),0)),U)
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 ;
+38 ; *** Division Access ***
+39 ; Format: RACCESS(DUZ,"DIV",IEN of 79,IEN of 79.1)="DIV";1 of file 79.1, pntr to file 4^.01 of 4
+40 ; NOTE: The first piece of the "DIV" node is a pntr to 79 (Rad Div)
+41 ; This value is DINUMED with file 4.
+42 ;
+43 ; Division is found in the Imaging Location file, ^RA(79.1
+44 ; it is the first piece of the "DIV" node. RAINDX is the IEN
+45 ; of ^RA(79.1
+46 IF $DATA(RACCESS(DUZ,"LOC"))
Begin DoDot:1
+47 SET RAINDX=0
+48 FOR
SET RAINDX=$ORDER(RACCESS(DUZ,"LOC",RAINDX))
IF RAINDX'>0
QUIT
Begin DoDot:2
+49 SET RADIV(0)=$GET(^RA(79.1,RAINDX,"DIV"))
SET RADIV(1)=+$PIECE(RADIV(0),U)
+50 IF RADIV(1)'>0
QUIT
SET RADIV(2)=+$PIECE($GET(^RA(79,RADIV(1),0)),U)
+51 SET RACCESS(DUZ,"DIV",RADIV(1),RAINDX)=RADIV(2)_"^"_$PIECE($GET(^DIC(4,RADIV(2),0)),U)
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
+54 ;
+55 ; *** Imaging Type Access ***
+56 ; Format: RACCESS(DUZ,"IMG",IEN of 79.2,IEN of 79.1)=^.01 of 79.2
+57 ; NOTE: The sixth piece of the "zero" node is a pntr to 79.2 (Img Type)
+58 ;
+59 ; Imaging Type is found in the Imaging Location file (#79.1)
+60 ; it is the sixth piece of the "zero" node. RAINDX is the IEN
+61 ; of ^RA(79.1
+62 IF $DATA(RACCESS(DUZ,"LOC"))
Begin DoDot:1
+63 SET RAINDX=0
+64 FOR
SET RAINDX=$ORDER(RACCESS(DUZ,"LOC",RAINDX))
IF RAINDX'>0
QUIT
Begin DoDot:2
+65 SET RAIMG(0)=$GET(^RA(79.1,RAINDX,0))
SET RAIMG(1)=+$PIECE(RAIMG(0),U,6)
+66 IF RAIMG(1)'>0
QUIT
SET RAIMG(2)=$PIECE($GET(^RA(79.2,RAIMG(1),0)),U)
+67 SET RACCESS(DUZ,"IMG",RAIMG(1),RAINDX)="^"_RAIMG(2)
+68 QUIT
End DoDot:2
+69 QUIT
End DoDot:1
+70 QUIT
DSPDIV ; Display 'Divisional Access' data
+1 NEW X0,X1,Y0,Y1,Y2,Y3
SET X0=0
SET Y3=1
+2 IF '$DATA(RACCESS(RADUZ,"DIV"))
Begin DoDot:1
+3 WRITE !?5,"Access to Radiology/Nuclear Medicine Divisional data is not "
+4 WRITE "authorized.",$CHAR(7)
End DoDot:1
QUIT
+5 SET Y1="<<< Divisions Included >>>"
+6 WRITE !?5,Y1
+7 FOR
SET X0=$ORDER(RACCESS(RADUZ,"DIV",X0))
IF X0'>0
QUIT
Begin DoDot:1
+8 SET X1=$ORDER(RACCESS(RADUZ,"DIV",X0,0))
IF X1'>0
QUIT
+9 SET Y0=$GET(RACCESS(RADUZ,"DIV",X0,X1))
IF Y0']""
QUIT
+10 SET Y2=$PIECE(Y0,U,2)
DO PRINT
+11 QUIT
End DoDot:1
+12 WRITE !
+13 QUIT
DSPIMG ; Display 'Imaging Type' data
+1 NEW X0,X1,Y0,Y1,Y2,Y3
SET X0=0
SET Y3=1
+2 IF '$DATA(RACCESS(RADUZ,"IMG"))
Begin DoDot:1
+3 WRITE !?5,"Access to Imaging Type data is not authorized."
+4 WRITE $CHAR(7)
End DoDot:1
QUIT
+5 SET Y1="<<< Imaging Types Included >>>"
+6 WRITE !?5,Y1
+7 FOR
SET X0=$ORDER(RACCESS(RADUZ,"IMG",X0))
IF X0'>0
QUIT
Begin DoDot:1
+8 SET X1=0
+9 FOR
SET X1=$ORDER(RACCESS(RADUZ,"IMG",X0,X1))
IF X1'>0
QUIT
Begin DoDot:2
+10 SET Y0=$GET(RACCESS(RADUZ,"IMG",X0,X1))
IF Y0']""
QUIT
+11 SET Y2=$PIECE(Y0,U,2)
DO PRINT
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 WRITE !
+15 QUIT
DSPLOC ; Display 'Imaging Location' data
+1 NEW X0,Y0,Y1,Y2,Y3
SET X0=0
SET Y3=1
+2 IF '$DATA(RACCESS(RADUZ,"LOC"))
Begin DoDot:1
+3 WRITE !?5,"Access to Imaging Location data is not authorized.",$CHAR(7)
End DoDot:1
QUIT
+4 SET Y1="<<< Locations Included >>>"
+5 WRITE !?5,Y1
+6 FOR
SET X0=$ORDER(RACCESS(RADUZ,"LOC",X0))
IF X0'>0
QUIT
Begin DoDot:1
+7 SET Y0=$GET(RACCESS(RADUZ,"LOC",X0))
IF Y0']""
QUIT
+8 SET Y2=$PIECE(Y0,U,2)
DO PRINT
+9 QUIT
End DoDot:1
+10 WRITE !
+11 QUIT
PRINT ; Print out data
+1 SET Y3='Y3
+2 IF 'Y3
WRITE !?5,Y2
+3 IF '$TEST
WRITE ?45,Y2
+4 QUIT
DIVSION(RADATE,RALIFN) ; Determine the division associated with the Requesting
+1 ; Location on a Rad/Nuc Med Order. Use the PIMS utilities in VASITE.
+2 ; Returns an institution file ptr value or -1 if the division
+3 ; could not be determined.
+4 ; Input - RADATE=a valid FileMan date (internal format)
+5 ; defaults to DT if passed in null
+6 ; RALIFN=Req. Location from Rad/Nuc Med Order.
+7 ; Output - RA1DIV=valid pointer the the Institution File, else -1
+8 NEW RA1DIV
IF $GET(RADATE)=""
SET RADATE=DT
+9 ; note: field 3.5 in file 44 is named DIVISION & is a pntr to file 40.8
+10 SET RA1DIV=+$$SITE^VASITE(RADATE,+$$GET1^DIQ(44,RALIFN,3.5,"I"))
+11 ; if $$SITE^VASITE fails, return the medical center division of the
+12 ; primary medical center division (this is a ptr to file 40.8)
+13 IF RA1DIV=-1
SET RA1DIV=+$$SITE^VASITE(RADATE,+$$PRIM^VASITE(RADATE))
+14 QUIT RA1DIV
