- 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 Jan 18, 2025@03:39:57 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