RAPSET ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Set Sign-on parameters ; Aug 25, 2021@13:21:09
;;5.0;Radiology/Nuclear Medicine;**21,184**;Mar 16, 1998;Build 2
D CHKSP^RAUTL2
I 'RADV!('RALC) W !!,*7,"You must initialize at least one Radiology/Nuclear Medicine Division",!,"and one Imaging Location to proceed.",!,"Refer to the Radiology/Nuclear Medicine ADPAC Guide.",!! K RADV,RALC S XQUIT="" Q
K RADV,RALC S (RADIV,RALOC,RADEV,DIV,LOC,DEV)="" G LOC:$D(^RA(79.2,"AC","E"))
D HOME^%ZIS ;I $D(IOS),IOS S DEV=$P(^%ZIS(1,+IOS,0),"^")
;
LOC I $S('($D(DUZ)#2):1,'DUZ:1,1:0) W !,*7,"Your user code 'DUZ' must be defined to continue." S XQUIT="" G Q^RAPSET1
S DEV="" W:$D(^RA(79.2,"AC","E")) ?15,"**** Normal Computer is Down. ****",!
I $G(DIC("B"))="",$D(^DISV(+DUZ,"^RA(79.1,")),$D(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0)) S DIC("B")=$S($D(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0)):$S($D(^SC(+^(0),0)):$P(^(0),"^"),1:""),1:"") I DIC("B")']"" K DIC("B")
I $D(DIC("B")),$P($G(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0)),U,19) K DIC("B")
; display default img loc ONLY IF it matches proc's img loc's img type
; SETDISV^RAREG3 already took care of settg default DIC("B") if lone img type
G:'$G(RAITN) LOC1
N RA1,RA2,RA3
G:$G(DIC("B"))="" LOC1
S RA1=0,RA2=0 ; RA1 = name of loc RA2 = ien of img loc
F S RA1=$O(^SC("B",DIC("B"),RA1)) Q:'RA1 S:'RA2 RA2=$O(^RA(79.1,"B",RA1,0)) ; use 1st non-null RA2
S RA3=$P(^RA(79.1,RA2,0),"^",6) ;ien img type
I RA3'=RAITN K DIC("B")
I $P(^RA(79.1,RA2,0),"^",19) K DIC("B") ;Don't show inactive loc as dflt
LOC1 D:'$D(RACCESS(DUZ)) VARACC^RAUTL6(DUZ) ; Setup user's access
S DIC("A")="Please select a sign-on Imaging Location: "
S DIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
I $D(RAOPT("REG"))#2!('$D(^XUSEC("RA ALLOC",DUZ))) D
.S DIC("S")=DIC("S")_"&($P(^RA(79.1,+Y,0),U,19)']"""")"
I $D(RADUPSCN),($D(RAREGX(4))),($D(RAYN)) D
. S DIC("B")=$P($G(^SC(+$G(^RA(79.1,RAREGX(4),0)),0)),U)
. N X S X=$P($G(^RA(79.1,RAREGX(4),0)),U,19) I X,X'>DT K DIC("B")
. S DIC("S")=DIC("S")_"&(+Y=RAREGX(4))" ; RA FLASH (DUP^RAEDCN)
. Q
S DIC="^RA(79.1,",DIC(0)="AEMQ" D ^DIC
K DIC("A"),DIC("S") I $D(DTOUT)!($D(DUOUT)) S XQUIT="" G Q^RAPSET1
I Y<0 W !?3,*7,"You must choose an Imaging 'Location' to continue...",!?3,"or enter '^' to stop.",! G LOC1
S LOC=+Y,DIV=$O(^RA(79,"AL",LOC,0))
;RA184/KLM - Change next line so we don't boot the user out of VistA if the ILOC isn't assign a division.
I DIV'>0!('$D(^RA(79,+DIV,0))) W !!,$C(7),"***Selected location is not assigned to a division!***",! G LOC1
S RADIV=^RA(79,DIV,0),RALOC=$S($D(^RA(79.1,LOC,0)):^(0),1:"")
I RALOC']"" W !!,*7,"Imaging Location definition error. Call your site manager." S XQUIT="" G Q^RAPSET1
;
PAR S RAMDIV=DIV,Y=$S($D(^RA(79,DIV,.1)):^(.1),1:""),RAMDV="" F I=1:1 Q:$P(Y,"^",I,99)']"" S RAMDV=RAMDV_$S($P(Y,"^",I)="Y"!($P(Y,"^",I)="y"):1,1:0)_"^"
I $P(RAMDV,"^",6),DEV,$P(RADEV,"^")["Y" S $P(RAMDV,"^",6)=0
;
S RAMLC=LOC_"^"_$S('$P(RAMDV,"^",2):+$P(RALOC,"^",2),1:0)
S RAI=$S($P(RALOC,"^",3)']"":-1,1:+$P(RALOC,"^",3)),RAFLH=$S($D(^%ZIS(1,+RAI,0)):$P(^(0),"^"),1:"")
I RAFLH']""!($D(^RA(79.2,"AC","E"))) S %ZIS="N",%ZIS("A")="Default Flash Card Printer: " D ^%ZIS D:POP NOESC S RAFLH=$S(POP:"",IO=IO(0):"",1:ION),RAI=$S(RAFLH="":"",1:$O(^%ZIS(1,"B",RAFLH,0)))
S RAMLC=RAMLC_"^"_RAFLH_"^"_$S($P(RAMDV,"^",8):$S($P(RALOC,"^",4):$P(RALOC,"^",4),1:2),1:0),RAFLH=$S(RAFLH']"":0,RAI>0:RAI,1:0)
S RAI=$S($P(RALOC,"^",5)']"":-1,1:+$P(RALOC,"^",5)),RAJAC=$S($D(^%ZIS(1,+RAI,0)):$P(^(0),"^"),1:"")
I RAJAC']""!($D(^RA(79.2,"AC","E"))) S %ZIS="N",%ZIS("A")="Default Jacket Label Printer: " D ^%ZIS D:POP NOESC S RAJAC=$S(POP:"",IO=IO(0):"",1:ION),RAI=$S(RAJAC="":"",1:$O(^%ZIS(1,"B",RAJAC,0)))
S RAMLC=RAMLC_"^"_RAJAC_"^"_$P(RALOC,"^",6,9),RAJAC=$S(RAJAC']"":0,RAI>0:RAI,1:0)
S RAI=$S($P(RALOC,"^",10)']"":-1,1:+$P(RALOC,"^",10)),RARPT=$S($D(^%ZIS(1,+RAI,0)):$P(^(0),"^"),1:"")
I RARPT']""!($D(^RA(79.2,"AC","E"))) S %ZIS="N",%ZIS("A")="Default Report Printer: " D ^%ZIS D:POP NOESC S RARPT=$S(POP:"",IO=IO(0):"",1:ION),RAI=$S(RARPT="":"",1:$O(^%ZIS(1,"B",RARPT,0)))
S RAMLC=RAMLC_"^"_RARPT_"^"_$P(RALOC,"^",11,13),RARPT=$S(RARPT']"":0,RAI>0:RAI,1:0) S LINE="",$P(LINE,"-",80)=""
S RAIMGTY=$$IMGTY^RAUTL12("l",+RAMLC)
I RAIMGTY']"" D UNDEF,KILL^RAPSET1 Q
D HOME^%ZIS G ^RAPSET1
;
UNDEF ; Message for undefined imaging types
N RAVAPOR
I '+$G(RAMLC) D Q
. W !?5,"Imaging Location data is not defined, "
. W "contact IRM.",$C(7)
. Q
S RAVAPOR=$P($G(^SC(+$P($G(^RA(79.1,+RAMLC,0)),U),0)),U)
W !?5,"An Imaging Type was not defined for the following Imaging"
W !?5,"Location: '"_$S(RAVAPOR']"":"Unknown",1:RAVAPOR)_"'"
Q
NOESC ; No up-arrow allowed at Flash Card, Jacket Label, or Report
; printer device prompts after selecting sign-on imaging location.
W $C(7),!,"No up-arrow allowed. Default printer will be your terminal."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPSET 4909 printed Oct 16, 2024@18:39:32 Page 2
RAPSET ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Set Sign-on parameters ; Aug 25, 2021@13:21:09
+1 ;;5.0;Radiology/Nuclear Medicine;**21,184**;Mar 16, 1998;Build 2
+2 DO CHKSP^RAUTL2
+3 IF 'RADV!('RALC)
WRITE !!,*7,"You must initialize at least one Radiology/Nuclear Medicine Division",!,"and one Imaging Location to proceed.",!,"Refer to the Radiology/Nuclear Medicine ADPAC Guide.",!!
KILL RADV,RALC
SET XQUIT=""
QUIT
+4 KILL RADV,RALC
SET (RADIV,RALOC,RADEV,DIV,LOC,DEV)=""
if $DATA(^RA(79.2,"AC","E"))
GOTO LOC
+5 ;I $D(IOS),IOS S DEV=$P(^%ZIS(1,+IOS,0),"^")
DO HOME^%ZIS
+6 ;
LOC IF $SELECT('($DATA(DUZ)#2):1,'DUZ:1,1:0)
WRITE !,*7,"Your user code 'DUZ' must be defined to continue."
SET XQUIT=""
GOTO Q^RAPSET1
+1 SET DEV=""
if $DATA(^RA(79.2,"AC","E"))
WRITE ?15,"**** Normal Computer is Down. ****",!
+2 IF $GET(DIC("B"))=""
IF $DATA(^DISV(+DUZ,"^RA(79.1,"))
IF $DATA(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0))
SET DIC("B")=$SELECT($DATA(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0)):$SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:""),1:"")
IF DIC("B")']""
KILL DIC("B")
+3 IF $DATA(DIC("B"))
IF $PIECE($GET(^RA(79.1,+^DISV(+DUZ,"^RA(79.1,"),0)),U,19)
KILL DIC("B")
+4 ; display default img loc ONLY IF it matches proc's img loc's img type
+5 ; SETDISV^RAREG3 already took care of settg default DIC("B") if lone img type
+6 if '$GET(RAITN)
GOTO LOC1
+7 NEW RA1,RA2,RA3
+8 if $GET(DIC("B"))=""
GOTO LOC1
+9 ; RA1 = name of loc RA2 = ien of img loc
SET RA1=0
SET RA2=0
+10 ; use 1st non-null RA2
FOR
SET RA1=$ORDER(^SC("B",DIC("B"),RA1))
if 'RA1
QUIT
if 'RA2
SET RA2=$ORDER(^RA(79.1,"B",RA1,0))
+11 ;ien img type
SET RA3=$PIECE(^RA(79.1,RA2,0),"^",6)
+12 IF RA3'=RAITN
KILL DIC("B")
+13 ;Don't show inactive loc as dflt
IF $PIECE(^RA(79.1,RA2,0),"^",19)
KILL DIC("B")
LOC1 ; Setup user's access
if '$DATA(RACCESS(DUZ))
DO VARACC^RAUTL6(DUZ)
+1 SET DIC("A")="Please select a sign-on Imaging Location: "
+2 SET DIC("S")="I $D(RACCESS(DUZ,""LOC"",+Y))"
+3 IF $DATA(RAOPT("REG"))#2!('$DATA(^XUSEC("RA ALLOC",DUZ)))
Begin DoDot:1
+4 SET DIC("S")=DIC("S")_"&($P(^RA(79.1,+Y,0),U,19)']"""")"
End DoDot:1
+5 IF $DATA(RADUPSCN)
IF ($DATA(RAREGX(4)))
IF ($DATA(RAYN))
Begin DoDot:1
+6 SET DIC("B")=$PIECE($GET(^SC(+$GET(^RA(79.1,RAREGX(4),0)),0)),U)
+7 NEW X
SET X=$PIECE($GET(^RA(79.1,RAREGX(4),0)),U,19)
IF X
IF X'>DT
KILL DIC("B")
+8 ; RA FLASH (DUP^RAEDCN)
SET DIC("S")=DIC("S")_"&(+Y=RAREGX(4))"
+9 QUIT
End DoDot:1
+10 SET DIC="^RA(79.1,"
SET DIC(0)="AEMQ"
DO ^DIC
+11 KILL DIC("A"),DIC("S")
IF $DATA(DTOUT)!($DATA(DUOUT))
SET XQUIT=""
GOTO Q^RAPSET1
+12 IF Y<0
WRITE !?3,*7,"You must choose an Imaging 'Location' to continue...",!?3,"or enter '^' to stop.",!
GOTO LOC1
+13 SET LOC=+Y
SET DIV=$ORDER(^RA(79,"AL",LOC,0))
+14 ;RA184/KLM - Change next line so we don't boot the user out of VistA if the ILOC isn't assign a division.
+15 IF DIV'>0!('$DATA(^RA(79,+DIV,0)))
WRITE !!,$CHAR(7),"***Selected location is not assigned to a division!***",!
GOTO LOC1
+16 SET RADIV=^RA(79,DIV,0)
SET RALOC=$SELECT($DATA(^RA(79.1,LOC,0)):^(0),1:"")
+17 IF RALOC']""
WRITE !!,*7,"Imaging Location definition error. Call your site manager."
SET XQUIT=""
GOTO Q^RAPSET1
+18 ;
PAR SET RAMDIV=DIV
SET Y=$SELECT($DATA(^RA(79,DIV,.1)):^(.1),1:"")
SET RAMDV=""
FOR I=1:1
if $PIECE(Y,"^",I,99)']""
QUIT
SET RAMDV=RAMDV_$SELECT($PIECE(Y,"^",I)="Y"!($PIECE(Y,"^",I)="y"):1,1:0)_"^"
+1 IF $PIECE(RAMDV,"^",6)
IF DEV
IF $PIECE(RADEV,"^")["Y"
SET $PIECE(RAMDV,"^",6)=0
+2 ;
+3 SET RAMLC=LOC_"^"_$SELECT('$PIECE(RAMDV,"^",2):+$PIECE(RALOC,"^",2),1:0)
+4 SET RAI=$SELECT($PIECE(RALOC,"^",3)']"":-1,1:+$PIECE(RALOC,"^",3))
SET RAFLH=$SELECT($DATA(^%ZIS(1,+RAI,0)):$PIECE(^(0),"^"),1:"")
+5 IF RAFLH']""!($DATA(^RA(79.2,"AC","E")))
SET %ZIS="N"
SET %ZIS("A")="Default Flash Card Printer: "
DO ^%ZIS
if POP
DO NOESC
SET RAFLH=$SELECT(POP:"",IO=IO(0):"",1:ION)
SET RAI=$SELECT(RAFLH="":"",1:$ORDER(^%ZIS(1,"B",RAFLH,0)))
+6 SET RAMLC=RAMLC_"^"_RAFLH_"^"_$SELECT($PIECE(RAMDV,"^",8):$SELECT($PIECE(RALOC,"^",4):$PIECE(RALOC,"^",4),1:2),1:0)
SET RAFLH=$SELECT(RAFLH']"":0,RAI>0:RAI,1:0)
+7 SET RAI=$SELECT($PIECE(RALOC,"^",5)']"":-1,1:+$PIECE(RALOC,"^",5))
SET RAJAC=$SELECT($DATA(^%ZIS(1,+RAI,0)):$PIECE(^(0),"^"),1:"")
+8 IF RAJAC']""!($DATA(^RA(79.2,"AC","E")))
SET %ZIS="N"
SET %ZIS("A")="Default Jacket Label Printer: "
DO ^%ZIS
if POP
DO NOESC
SET RAJAC=$SELECT(POP:"",IO=IO(0):"",1:ION)
SET RAI=$SELECT(RAJAC="":"",1:$ORDER(^%ZIS(1,"B",RAJAC,0)))
+9 SET RAMLC=RAMLC_"^"_RAJAC_"^"_$PIECE(RALOC,"^",6,9)
SET RAJAC=$SELECT(RAJAC']"":0,RAI>0:RAI,1:0)
+10 SET RAI=$SELECT($PIECE(RALOC,"^",10)']"":-1,1:+$PIECE(RALOC,"^",10))
SET RARPT=$SELECT($DATA(^%ZIS(1,+RAI,0)):$PIECE(^(0),"^"),1:"")
+11 IF RARPT']""!($DATA(^RA(79.2,"AC","E")))
SET %ZIS="N"
SET %ZIS("A")="Default Report Printer: "
DO ^%ZIS
if POP
DO NOESC
SET RARPT=$SELECT(POP:"",IO=IO(0):"",1:ION)
SET RAI=$SELECT(RARPT="":"",1:$ORDER(^%ZIS(1,"B",RARPT,0)))
+12 SET RAMLC=RAMLC_"^"_RARPT_"^"_$PIECE(RALOC,"^",11,13)
SET RARPT=$SELECT(RARPT']"":0,RAI>0:RAI,1:0)
SET LINE=""
SET $PIECE(LINE,"-",80)=""
+13 SET RAIMGTY=$$IMGTY^RAUTL12("l",+RAMLC)
+14 IF RAIMGTY']""
DO UNDEF
DO KILL^RAPSET1
QUIT
+15 DO HOME^%ZIS
GOTO ^RAPSET1
+16 ;
UNDEF ; Message for undefined imaging types
+1 NEW RAVAPOR
+2 IF '+$GET(RAMLC)
Begin DoDot:1
+3 WRITE !?5,"Imaging Location data is not defined, "
+4 WRITE "contact IRM.",$CHAR(7)
+5 QUIT
End DoDot:1
QUIT
+6 SET RAVAPOR=$PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,+RAMLC,0)),U),0)),U)
+7 WRITE !?5,"An Imaging Type was not defined for the following Imaging"
+8 WRITE !?5,"Location: '"_$SELECT(RAVAPOR']"":"Unknown",1:RAVAPOR)_"'"
+9 QUIT
NOESC ; No up-arrow allowed at Flash Card, Jacket Label, or Report
+1 ; printer device prompts after selecting sign-on imaging location.
+2 WRITE $CHAR(7),!,"No up-arrow allowed. Default printer will be your terminal."
+3 QUIT
