RASYS ;HISC/CAH AISC/TMP - System Definition Menu ; Feb 07, 2024@06:40:30
;;5.0;Radiology/Nuclear Medicine;**42,47,178,210**;Mar 16, 1998;Build 1
1 ;;Division Parameter Set-up
S DIC="^RA(79,",DIC(0)="AELMQ",DIC("A")="Select Division: ",DLAYGO=79
D ^DIC K DIC,DLAYGO I Y<0 K X,Y G Q1
;p210/KLM begin - option to enter the new phone number field w/o going thru the whole template.
S RAY=+Y K DIR,Y
S DIR("A")="Would you like to enter/edit the FACILITY PHONE NUMBER only"
S DIR(0)="Y",DIR("B")="NO",DIR("?")="Enter 'YES' to add/edit the phone number, or 'NO' to edit all division parameters."
D ^DIR I $D(DIRUT) G Q1
I Y=1 D K DIR,Y G Q1
. S DA=RAY,DIE="^RA(79,",DR=200 D ^DIE
. Q
K DIR,Y
;p210 end
S DA=RAY,DIE="^RA(79,",DR="[RA DIVISION PARAMETERS]",RAXIT=0 D ^DIE
I $O(^RA(79,DA,"L",0)) D
. D:'$D(IOF) HOME^%ZIS W @IOF S RAINC=0
. F S RAINC=$O(^RA(79,DA,"L",RAINC)) Q:RAINC'>0 D Q:RAXIT
.. D EN1^RASYS1($P($G(^RA(79,DA,"L",RAINC,0)),"^"))
.. Q
. Q
K %,%X,%Y,C,D0,DA,DE,DQ,DIE,DR,RAINC,RAXIT D Q1 W ! G 1
Q1 K D,DDC,DG,DI,DIG,DIH,DIU,DIV,DIW,DISYS,DST,DUOUT,I,J,POP,RAY,RAT
Q
;
2 ;;Print Division Parameter List
S DIC="^RA(79,",L=0,FLDS="[RA IMAGE DIV LIST]",BY="#DIVISION",FR="",TO="" D EN1^DIP K FR,TO,FLDS,BY,DHD Q
;
3 ;;Location Parameter Set-up
S DIC="^RA(79.1,",DIC(0)="AELMQZ",DIC("A")="Select Location: ",DLAYGO=79.1
D ^DIC K DIC,DLAYGO I Y<0 D KILL3 Q ; DIC(0)="AELMQZ" patch 42 'Z' added
I $P(Y,U,3)=1 W !!," * Since you have added a new Imaging Location, remember to assign * ",!," * it to a Rad/Nuc Med division through Division Parameter Set-up. * ",!
W:$P(Y,U,3)'=1 ! W !,"Imaging Location: ",Y(0,0) ; patch 42
S DA=+Y,DIE="^RA(79.1,",DR="[RA LOCATION PARAMETERS]",RAXIT=0 D ^DIE
D:'$D(IOF) HOME^%ZIS W @IOF D EN1^RASYS1(DA) D KILL3 W ! G 3
KILL3 K %,%X,%W,%Y,D,E,DE,DA,D0,RAREQPRT,DIE,DIV,DQ,DR,RAFLH,RAJAC,RARPT,RAXIT,X,Y
K C,DDH,DI,DIG,DIH,DISYS,DIU,DIW,DIWI,I,POP,RALERT,RALINE
Q
;
4 ;;Imaging Location Parameter List
N RAINA S RAINA=0 K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("B")="No"
S DIR("A")="Do you wish to include inactive Imaging Locations"
S DIR("?",1)="Enter 'Yes' if inactive Imaging Locations are to be"
S DIR("?")="included, 'No' if only active locations are desired."
D ^DIR S:$D(DIRUT) RAINA=-1
K DIR,DIROUT,DIRUT,DTOUT,DUOUT G:RAINA<0 KILL
S RAINA=Y ; 1 if inactives are included, 0 if only actives included
N RAX,RAY S RAX=$$LOC^RAUTL12(RAINA) G:'RAX KILL
S RAY="Rad/Nuc Med Imaging Location Parameter List"
S DIC="^RA(79.1,",BY="[RA IMAGE LOC LIST]",L=0
S DIS(0)="I $$INA^RASYS(D0)"
S RAPOP=$$ZIS(RAY)
I +RAPOP D HOME^%ZIS,KILL Q
I +$P(RAPOP,"^",2) D KILL Q ; Q'ed off in ZIS subroutine
E D ENTASK ; not queued, to run now
Q
;
5 ;;Camera/Equip/Room Entry/Edit
S DIC="^RA(78.6,",DIC(0)="AELMQ",DIC("A")="Select Camera/Equip/Room: ",DLAYGO=78.6 D ^DIC K DIC,DLAYGO I Y<0 K X,Y D KILL5 Q
S DA=+Y,DIE="^RA(78.6,",DR=".01:99" D ^DIE K %,D0,DA,DE,DQ,DIE,DR,X,Y D KILL5 W ! G 5
KILL5 K D,DG,DI,DISYS,I,POP Q
;
6 ;;List of Camera/Equip/Rooms
S DIC="^RA(79.1,",L=0,BY="[RA EXAM ROOM LIST]"
S DIOEND="D NOLOC^RASYS" D EN1^DIP
K DIOEND,FLDS,BY,DHD,TO,FR,RANOLOC,POP
Q
ENTASK ; Entry point for the tasked job.
S RAIOP=ION_";"_IOST_";"_IOM_";"_IOSL,IOP=RAIOP
S:$E(IOP,1,3)="HFS" %ZIS("HFSNAME")=IO,%ZIS("HFSMODE")="W"
D EN1^DIP
D KILL^RASYS
Q
INA(RAD0) ; Determine if an Imaging Location is inactive.
; Input : 'RAD0' ien of file 79.1
; Output: '1' if the location is valid, '0' if invalid
N RA791 S RA791=$G(^RA(79.1,D0,0))
S RA791(1)=$$XTERNAL^RAUTL5($P(RA791,"^"),$P($G(^DD(79.1,.01,0)),"^",2))
Q:'($D(^TMP($J,"RA L-TYPE",RA791(1),D0))#2) 0 ; not user selected
Q 1
KILL ; Kill and quit
K ^TMP($J,"RA L-TYPE"),%X,%XX,%Y,%YY
K %ZIS,BY,DHD,DIC,DIS,DTOUT,DUOUT,FLDS,FR,L,POP,RAIOP,RAINA,RAPOP,TO
K X,Y,ZTDESC,ZTRTN,ZTSAVE,POP,I
Q
NOLOC ;print camera/equip/rm's not assigned to any imaging loc
I $D(RANOLOC) Q
N R1,R2,R3,RACAM,R4 S R4=0
S R1=0 F S R1=$O(^RA(78.6,R1)) Q:'R1 S RACAM(R1)=""
S R2=0 F S R2=$O(^RA(79.1,R2)) Q:'R2 S R3=0 F S R3=$O(^RA(79.1,R2,"R",R3)) Q:'R3 D
. S R1=$G(^RA(79.1,R2,"R",R3,0))
. K RACAM(R1)
S R1=0 F S R1=$O(RACAM(R1)) W:'R1 # Q:'R1 D
. W:R4 ! S R4=1 W ?3,$E($P(^RA(78.6,R1,0),U),1,15),?20,"**UNASSIGNED**",?45,"**UNASSIGNED**"
S RANOLOC=1 Q
INACT ; write inactive flag, called by 'List of Camera/Equip/Rms' option
Q:$G(DDDD0)=""
N RA1,RA2 S RA1=$O(^RA(78.6,"B",DDDD0,0)),RA2=0
I RA1 I $G(^RA(78.6,RA1,0))]"",$P(^(0),U,3)]"" S RA2=1
W ?0,$S(RA2:"(*)",1:" "),$E(DDDD0,1,15)
Q
7 ;;RA SYSUPLOC /RA178;KLM - Menu to automatically set outside locations 'Suppress Ordering?' prompt to YES.
N RACM,RAILOC,RAIL,RAFDA,RADIC,RAUTIL S RACM=2
K ^TMP($J,"RA178")
W !!,?5,"This option will set the selected outside imaging locations to"
W !,?5,"'Suppress Ordering'. Doing this will prevent the location from"
W !,?5,"showing up in CPRS as a 'Submit To' location for a radiology"
W !,?5,"request."
W !!,?3,"**Note that your selection is limited to outside (no credit) locations.**"
W !,?3,"**If you select 'ALL', all of your outside locations will be updated.**"
S RADIC="^RA(79.1,",RADIC(0)="OEMZ",RADIC("S")="I $P(^RA(79.1,+Y,0),U,19)="""",$D(^RA(79.1,""ACM"",2,+Y))"
S RADIC("A")="Select Location(s): ",RAUTIL="RA178"
W !! D EN1^RASELCT(.RADIC,RAUTIL)
I $O(^TMP($J,"RA178",""))="" W !!?3,$C(7),"No location selected." Q
S RAILOC="" F S RAILOC=$O(^TMP($J,"RA178",RAILOC)) Q:RAILOC="" D
.S RAIL=0 F S RAIL=$O(^TMP($J,"RA178",RAILOC,RAIL)) Q:RAIL="" D
..S:$$GET1^DIQ(79.1,RAIL,.1)="" RAFDA(79.1,RAIL_",",.1)="Y"
..Q
.Q
D FILE^DIE("","RAFDA") W !!?2,"Location(s) updated...",!
W !,?2,"Your outside location order suppression status:"
N RAI S RAI=0 F S RAI=$O(^RA(79.1,"ACM",RACM,RAI)) Q:RAI="" D
.W !?2,$E($$GET1^DIQ(79.1,RAI,.01),1,25),?30,"Suppress Order?: ",$S($G(^RA(79.1,RAI,.1))="Y":"YES",1:"NO")
.Q
W ! S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
K ^TMP($J,"RA178"),DIR,DIRUT,DUOUT
Q
ZIS(RA) ; Select a device.
; 'RAPOP'=device selection successful (1:no) ^ '^%ZTLOAD' called (1:yes)
K %ZIS,IOP S %ZIS="NMQ"
W ! S %ZIS("A")="DEVICE: " D ^%ZIS
S RAPOP=POP_"^"
I '+RAPOP,($D(IO("Q"))) D
. K IO("Q") S ZTDESC=RA,ZTRTN="ENTASK^RASYS"
. D ZTSAVE,^%ZTLOAD S $P(RAPOP,"^",2)=1
. I +$G(ZTSK) W !?3,"Request Queued, Task #: ",$G(ZTSK)
. D HOME^%ZIS
. Q
Q RAPOP
ZTSAVE ; Save off variables for the tasked job.
N I F I="BY","DIC","FLDS","FR","L","RAINA","TO" S ZTSAVE(I)=""
S:($D(DIS)\10) ZTSAVE("DIS(")=""
S:($D(DHD)#2) ZTSAVE("DHD")=""
S:($D(^TMP($J,"RA L-TYPE"))\10) ZTSAVE("^TMP($J,""RA L-TYPE"",")=""
Q
RDEV ; Select a Resource Device for a division. This subroutine is linked
; directly to the option: RA RESOURCE DEVICE. This option is a menu
; item under the RA SITEMANAGER menu option.
N %,%X,%Y,C,D,D0,DA,DDER,DDH,DI,DIC,DIE,DQ,DR,X,Y S (DIC,DIE)="^RA(79,"
S DIC(0)="QEAMZ",DIC("A")="Select a Rad/Nuc Med Division: " D ^DIC
G:Y'>0 QRDEV S DA=+Y,DR="D RDEVHLP^RASYS;100" D ^DIE
QRDEV K DISYS,DST,I,POP
Q
RDEVHLP ; Display the Description Text for the Resource Device (#100) field
; on the Rad/Nuc Med Division file.
N RA100DES,Z S Z=0 D FIELD^DID(79,100,"","DESCRIPTION","RA100DES")
Q:'$D(RA100DES("DESCRIPTION")) W !
F S Z=$O(RA100DES("DESCRIPTION",Z)) Q:Z'>0 D
. W !,$G(RA100DES("DESCRIPTION",Z))
. Q
W !
Q
;
SACNPAR ; Site (long) Accession Number Parameter Entry/Edit
;W !!?3,"Warning: Editing the 'USE SITE ACCESSION NUMBER?' field on a record"
;W !?3,"in the RAD/NUC MED DIVISION file may lead to the instability of the"
;W !?3,"VistA RADIOLOGY/NUCLEAR MEDICINE application.",!
W !!?3,"Warning: Turning on the Site Specific Accession Number should only"
W !?3,"be done in conjunction with using the RA v2.4 messaging protocols."
W !!?3,"NOTE: Changing the Site Specific Accession Number parameter at a"
W !?3,"multidivisional site will change the parameter for ALL divisions."
;K DIC S DIC(0)="AEMQZ",DIC("A")="Select Facility to Edit: "
;S DIC="^RA(79," D ^DIC
;I $D(DTOUT)!($D(DUOUT))!(Y=-1) D END Q
N RAVAL S RAVAL=$O(^RA(79,0)),RAVAL=$P($G(^RA(79,RAVAL,.1)),"^",31)
W !!,"Current value of Site Specific Accession Number parameter: ",$S(RAVAL="Y":"YES",1:"NO")
S DIR(0)="YA",DIR("A")="Use Site Specific Accession Number? " D ^DIR
S DIR("?")="Answer 'YES' to turn on use of the Site Specific Accession Number or 'NO' to turn it off."
Q:$D(DIRUT)
N RAZVAL S RAZVAL="N" I Y=1 S RAZVAL="Y"
F RAZZDIV=0:0 S RAZZDIV=$O(^RA(79,RAZZDIV)) Q:RAZZDIV'>0 D
.S (DA,RADA)=+RAZZDIV,DR=".131////^S X=RAZVAL",DIE="^RA(79,"
.D ^DIE
Q
END ;
K DA,DIC,DIE,DR,DTOUT,DUOUT,RADA,X,Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASYS 8829 printed Dec 13, 2024@02:40:02 Page 2
RASYS ;HISC/CAH AISC/TMP - System Definition Menu ; Feb 07, 2024@06:40:30
+1 ;;5.0;Radiology/Nuclear Medicine;**42,47,178,210**;Mar 16, 1998;Build 1
1 ;;Division Parameter Set-up
+1 SET DIC="^RA(79,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select Division: "
SET DLAYGO=79
+2 DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL X,Y
GOTO Q1
+3 ;p210/KLM begin - option to enter the new phone number field w/o going thru the whole template.
+4 SET RAY=+Y
KILL DIR,Y
+5 SET DIR("A")="Would you like to enter/edit the FACILITY PHONE NUMBER only"
+6 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("?")="Enter 'YES' to add/edit the phone number, or 'NO' to edit all division parameters."
+7 DO ^DIR
IF $DATA(DIRUT)
GOTO Q1
+8 IF Y=1
Begin DoDot:1
+9 SET DA=RAY
SET DIE="^RA(79,"
SET DR=200
DO ^DIE
+10 QUIT
End DoDot:1
KILL DIR,Y
GOTO Q1
+11 KILL DIR,Y
+12 ;p210 end
+13 SET DA=RAY
SET DIE="^RA(79,"
SET DR="[RA DIVISION PARAMETERS]"
SET RAXIT=0
DO ^DIE
+14 IF $ORDER(^RA(79,DA,"L",0))
Begin DoDot:1
+15 if '$DATA(IOF)
DO HOME^%ZIS
WRITE @IOF
SET RAINC=0
+16 FOR
SET RAINC=$ORDER(^RA(79,DA,"L",RAINC))
if RAINC'>0
QUIT
Begin DoDot:2
+17 DO EN1^RASYS1($PIECE($GET(^RA(79,DA,"L",RAINC,0)),"^"))
+18 QUIT
End DoDot:2
if RAXIT
QUIT
+19 QUIT
End DoDot:1
+20 KILL %,%X,%Y,C,D0,DA,DE,DQ,DIE,DR,RAINC,RAXIT
DO Q1
WRITE !
GOTO 1
Q1 KILL D,DDC,DG,DI,DIG,DIH,DIU,DIV,DIW,DISYS,DST,DUOUT,I,J,POP,RAY,RAT
+1 QUIT
+2 ;
2 ;;Print Division Parameter List
+1 SET DIC="^RA(79,"
SET L=0
SET FLDS="[RA IMAGE DIV LIST]"
SET BY="#DIVISION"
SET FR=""
SET TO=""
DO EN1^DIP
KILL FR,TO,FLDS,BY,DHD
QUIT
+2 ;
3 ;;Location Parameter Set-up
+1 SET DIC="^RA(79.1,"
SET DIC(0)="AELMQZ"
SET DIC("A")="Select Location: "
SET DLAYGO=79.1
+2 ; DIC(0)="AELMQZ" patch 42 'Z' added
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
DO KILL3
QUIT
+3 IF $PIECE(Y,U,3)=1
WRITE !!," * Since you have added a new Imaging Location, remember to assign * ",!," * it to a Rad/Nuc Med division through Division Parameter Set-up. * ",!
+4 ; patch 42
if $PIECE(Y,U,3)'=1
WRITE !
WRITE !,"Imaging Location: ",Y(0,0)
+5 SET DA=+Y
SET DIE="^RA(79.1,"
SET DR="[RA LOCATION PARAMETERS]"
SET RAXIT=0
DO ^DIE
+6 if '$DATA(IOF)
DO HOME^%ZIS
WRITE @IOF
DO EN1^RASYS1(DA)
DO KILL3
WRITE !
GOTO 3
KILL3 KILL %,%X,%W,%Y,D,E,DE,DA,D0,RAREQPRT,DIE,DIV,DQ,DR,RAFLH,RAJAC,RARPT,RAXIT,X,Y
+1 KILL C,DDH,DI,DIG,DIH,DISYS,DIU,DIW,DIWI,I,POP,RALERT,RALINE
+2 QUIT
+3 ;
4 ;;Imaging Location Parameter List
+1 NEW RAINA
SET RAINA=0
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("B")="No"
+3 SET DIR("A")="Do you wish to include inactive Imaging Locations"
+4 SET DIR("?",1)="Enter 'Yes' if inactive Imaging Locations are to be"
+5 SET DIR("?")="included, 'No' if only active locations are desired."
+6 DO ^DIR
if $DATA(DIRUT)
SET RAINA=-1
+7 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
if RAINA<0
GOTO KILL
+8 ; 1 if inactives are included, 0 if only actives included
SET RAINA=Y
+9 NEW RAX,RAY
SET RAX=$$LOC^RAUTL12(RAINA)
if 'RAX
GOTO KILL
+10 SET RAY="Rad/Nuc Med Imaging Location Parameter List"
+11 SET DIC="^RA(79.1,"
SET BY="[RA IMAGE LOC LIST]"
SET L=0
+12 SET DIS(0)="I $$INA^RASYS(D0)"
+13 SET RAPOP=$$ZIS(RAY)
+14 IF +RAPOP
DO HOME^%ZIS
DO KILL
QUIT
+15 ; Q'ed off in ZIS subroutine
IF +$PIECE(RAPOP,"^",2)
DO KILL
QUIT
+16 ; not queued, to run now
IF '$TEST
DO ENTASK
+17 QUIT
+18 ;
5 ;;Camera/Equip/Room Entry/Edit
+1 SET DIC="^RA(78.6,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select Camera/Equip/Room: "
SET DLAYGO=78.6
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL X,Y
DO KILL5
QUIT
+2 SET DA=+Y
SET DIE="^RA(78.6,"
SET DR=".01:99"
DO ^DIE
KILL %,D0,DA,DE,DQ,DIE,DR,X,Y
DO KILL5
WRITE !
GOTO 5
KILL5 KILL D,DG,DI,DISYS,I,POP
QUIT
+1 ;
6 ;;List of Camera/Equip/Rooms
+1 SET DIC="^RA(79.1,"
SET L=0
SET BY="[RA EXAM ROOM LIST]"
+2 SET DIOEND="D NOLOC^RASYS"
DO EN1^DIP
+3 KILL DIOEND,FLDS,BY,DHD,TO,FR,RANOLOC,POP
+4 QUIT
ENTASK ; Entry point for the tasked job.
+1 SET RAIOP=ION_";"_IOST_";"_IOM_";"_IOSL
SET IOP=RAIOP
+2 if $EXTRACT(IOP,1,3)="HFS"
SET %ZIS("HFSNAME")=IO
SET %ZIS("HFSMODE")="W"
+3 DO EN1^DIP
+4 DO KILL^RASYS
+5 QUIT
INA(RAD0) ; Determine if an Imaging Location is inactive.
+1 ; Input : 'RAD0' ien of file 79.1
+2 ; Output: '1' if the location is valid, '0' if invalid
+3 NEW RA791
SET RA791=$GET(^RA(79.1,D0,0))
+4 SET RA791(1)=$$XTERNAL^RAUTL5($PIECE(RA791,"^"),$PIECE($GET(^DD(79.1,.01,0)),"^",2))
+5 ; not user selected
if '($DATA(^TMP($JOB,"RA L-TYPE",RA791(1),D0))#2)
QUIT 0
+6 QUIT 1
KILL ; Kill and quit
+1 KILL ^TMP($JOB,"RA L-TYPE"),%X,%XX,%Y,%YY
+2 KILL %ZIS,BY,DHD,DIC,DIS,DTOUT,DUOUT,FLDS,FR,L,POP,RAIOP,RAINA,RAPOP,TO
+3 KILL X,Y,ZTDESC,ZTRTN,ZTSAVE,POP,I
+4 QUIT
NOLOC ;print camera/equip/rm's not assigned to any imaging loc
+1 IF $DATA(RANOLOC)
QUIT
+2 NEW R1,R2,R3,RACAM,R4
SET R4=0
+3 SET R1=0
FOR
SET R1=$ORDER(^RA(78.6,R1))
if 'R1
QUIT
SET RACAM(R1)=""
+4 SET R2=0
FOR
SET R2=$ORDER(^RA(79.1,R2))
if 'R2
QUIT
SET R3=0
FOR
SET R3=$ORDER(^RA(79.1,R2,"R",R3))
if 'R3
QUIT
Begin DoDot:1
+5 SET R1=$GET(^RA(79.1,R2,"R",R3,0))
+6 KILL RACAM(R1)
End DoDot:1
+7 SET R1=0
FOR
SET R1=$ORDER(RACAM(R1))
if 'R1
WRITE #
if 'R1
QUIT
Begin DoDot:1
+8 if R4
WRITE !
SET R4=1
WRITE ?3,$EXTRACT($PIECE(^RA(78.6,R1,0),U),1,15),?20,"**UNASSIGNED**",?45,"**UNASSIGNED**"
End DoDot:1
+9 SET RANOLOC=1
QUIT
INACT ; write inactive flag, called by 'List of Camera/Equip/Rms' option
+1 if $GET(DDDD0)=""
QUIT
+2 NEW RA1,RA2
SET RA1=$ORDER(^RA(78.6,"B",DDDD0,0))
SET RA2=0
+3 IF RA1
IF $GET(^RA(78.6,RA1,0))]""
IF $PIECE(^(0),U,3)]""
SET RA2=1
+4 WRITE ?0,$SELECT(RA2:"(*)",1:" "),$EXTRACT(DDDD0,1,15)
+5 QUIT
7 ;;RA SYSUPLOC /RA178;KLM - Menu to automatically set outside locations 'Suppress Ordering?' prompt to YES.
+1 NEW RACM,RAILOC,RAIL,RAFDA,RADIC,RAUTIL
SET RACM=2
+2 KILL ^TMP($JOB,"RA178")
+3 WRITE !!,?5,"This option will set the selected outside imaging locations to"
+4 WRITE !,?5,"'Suppress Ordering'. Doing this will prevent the location from"
+5 WRITE !,?5,"showing up in CPRS as a 'Submit To' location for a radiology"
+6 WRITE !,?5,"request."
+7 WRITE !!,?3,"**Note that your selection is limited to outside (no credit) locations.**"
+8 WRITE !,?3,"**If you select 'ALL', all of your outside locations will be updated.**"
+9 SET RADIC="^RA(79.1,"
SET RADIC(0)="OEMZ"
SET RADIC("S")="I $P(^RA(79.1,+Y,0),U,19)="""",$D(^RA(79.1,""ACM"",2,+Y))"
+10 SET RADIC("A")="Select Location(s): "
SET RAUTIL="RA178"
+11 WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
+12 IF $ORDER(^TMP($JOB,"RA178",""))=""
WRITE !!?3,$CHAR(7),"No location selected."
QUIT
+13 SET RAILOC=""
FOR
SET RAILOC=$ORDER(^TMP($JOB,"RA178",RAILOC))
if RAILOC=""
QUIT
Begin DoDot:1
+14 SET RAIL=0
FOR
SET RAIL=$ORDER(^TMP($JOB,"RA178",RAILOC,RAIL))
if RAIL=""
QUIT
Begin DoDot:2
+15 if $$GET1^DIQ(79.1,RAIL,.1)=""
SET RAFDA(79.1,RAIL_",",.1)="Y"
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 DO FILE^DIE("","RAFDA")
WRITE !!?2,"Location(s) updated...",!
+19 WRITE !,?2,"Your outside location order suppression status:"
+20 NEW RAI
SET RAI=0
FOR
SET RAI=$ORDER(^RA(79.1,"ACM",RACM,RAI))
if RAI=""
QUIT
Begin DoDot:1
+21 WRITE !?2,$EXTRACT($$GET1^DIQ(79.1,RAI,.01),1,25),?30,"Suppress Order?: ",$SELECT($GET(^RA(79.1,RAI,.1))="Y":"YES",1:"NO")
+22 QUIT
End DoDot:1
+23 WRITE !
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
+24 KILL ^TMP($JOB,"RA178"),DIR,DIRUT,DUOUT
+25 QUIT
ZIS(RA) ; Select a device.
+1 ; 'RAPOP'=device selection successful (1:no) ^ '^%ZTLOAD' called (1:yes)
+2 KILL %ZIS,IOP
SET %ZIS="NMQ"
+3 WRITE !
SET %ZIS("A")="DEVICE: "
DO ^%ZIS
+4 SET RAPOP=POP_"^"
+5 IF '+RAPOP
IF ($DATA(IO("Q")))
Begin DoDot:1
+6 KILL IO("Q")
SET ZTDESC=RA
SET ZTRTN="ENTASK^RASYS"
+7 DO ZTSAVE
DO ^%ZTLOAD
SET $PIECE(RAPOP,"^",2)=1
+8 IF +$GET(ZTSK)
WRITE !?3,"Request Queued, Task #: ",$GET(ZTSK)
+9 DO HOME^%ZIS
+10 QUIT
End DoDot:1
+11 QUIT RAPOP
ZTSAVE ; Save off variables for the tasked job.
+1 NEW I
FOR I="BY","DIC","FLDS","FR","L","RAINA","TO"
SET ZTSAVE(I)=""
+2 if ($DATA(DIS)\10)
SET ZTSAVE("DIS(")=""
+3 if ($DATA(DHD)#2)
SET ZTSAVE("DHD")=""
+4 if ($DATA(^TMP($JOB,"RA L-TYPE"))\10)
SET ZTSAVE("^TMP($J,""RA L-TYPE"",")=""
+5 QUIT
RDEV ; Select a Resource Device for a division. This subroutine is linked
+1 ; directly to the option: RA RESOURCE DEVICE. This option is a menu
+2 ; item under the RA SITEMANAGER menu option.
+3 NEW %,%X,%Y,C,D,D0,DA,DDER,DDH,DI,DIC,DIE,DQ,DR,X,Y
SET (DIC,DIE)="^RA(79,"
+4 SET DIC(0)="QEAMZ"
SET DIC("A")="Select a Rad/Nuc Med Division: "
DO ^DIC
+5 if Y'>0
GOTO QRDEV
SET DA=+Y
SET DR="D RDEVHLP^RASYS;100"
DO ^DIE
QRDEV KILL DISYS,DST,I,POP
+1 QUIT
RDEVHLP ; Display the Description Text for the Resource Device (#100) field
+1 ; on the Rad/Nuc Med Division file.
+2 NEW RA100DES,Z
SET Z=0
DO FIELD^DID(79,100,"","DESCRIPTION","RA100DES")
+3 if '$DATA(RA100DES("DESCRIPTION"))
QUIT
WRITE !
+4 FOR
SET Z=$ORDER(RA100DES("DESCRIPTION",Z))
if Z'>0
QUIT
Begin DoDot:1
+5 WRITE !,$GET(RA100DES("DESCRIPTION",Z))
+6 QUIT
End DoDot:1
+7 WRITE !
+8 QUIT
+9 ;
SACNPAR ; Site (long) Accession Number Parameter Entry/Edit
+1 ;W !!?3,"Warning: Editing the 'USE SITE ACCESSION NUMBER?' field on a record"
+2 ;W !?3,"in the RAD/NUC MED DIVISION file may lead to the instability of the"
+3 ;W !?3,"VistA RADIOLOGY/NUCLEAR MEDICINE application.",!
+4 WRITE !!?3,"Warning: Turning on the Site Specific Accession Number should only"
+5 WRITE !?3,"be done in conjunction with using the RA v2.4 messaging protocols."
+6 WRITE !!?3,"NOTE: Changing the Site Specific Accession Number parameter at a"
+7 WRITE !?3,"multidivisional site will change the parameter for ALL divisions."
+8 ;K DIC S DIC(0)="AEMQZ",DIC("A")="Select Facility to Edit: "
+9 ;S DIC="^RA(79," D ^DIC
+10 ;I $D(DTOUT)!($D(DUOUT))!(Y=-1) D END Q
+11 NEW RAVAL
SET RAVAL=$ORDER(^RA(79,0))
SET RAVAL=$PIECE($GET(^RA(79,RAVAL,.1)),"^",31)
+12 WRITE !!,"Current value of Site Specific Accession Number parameter: ",$SELECT(RAVAL="Y":"YES",1:"NO")
+13 SET DIR(0)="YA"
SET DIR("A")="Use Site Specific Accession Number? "
DO ^DIR
+14 SET DIR("?")="Answer 'YES' to turn on use of the Site Specific Accession Number or 'NO' to turn it off."
+15 if $DATA(DIRUT)
QUIT
+16 NEW RAZVAL
SET RAZVAL="N"
IF Y=1
SET RAZVAL="Y"
+17 FOR RAZZDIV=0:0
SET RAZZDIV=$ORDER(^RA(79,RAZZDIV))
if RAZZDIV'>0
QUIT
Begin DoDot:1
+18 SET (DA,RADA)=+RAZZDIV
SET DR=".131////^S X=RAZVAL"
SET DIE="^RA(79,"
+19 DO ^DIE
End DoDot:1
+20 QUIT
END ;
+1 KILL DA,DIC,DIE,DR,DTOUT,DUOUT,RADA,X,Y
+2 QUIT
+3 ;
