- 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