RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;24 Jul 2019 9:18 AM
;;5.0;Radiology/Nuclear Medicine;**8,137,144,154,157**;Mar 16, 1998;Build 2
;Supported IA #10076 ^XUSEC(
;
RSBIT ; renumber selections by imaging type
; The RAORDS array has the list of orders the user selected to register
; in the order the user entered them. This subroutine will reorganize
; the array so the orders are arranged by imaging type of their
; procedure starting with the imaging type the user is currently signed
; on with followed by the ascending internal entry number of the
; remaining imaging types.
;
Q:'$D(RAORDS)
K RALOOP,RAORDST
F RALOOP=1:1 Q:'$D(RAORDS(RALOOP)) D
.S RAON=+$P(RAORDS(RALOOP),U,1) Q:'RAON
.S RAPN=+$P(^RAO(75.1,RAON,0),U,2) Q:'RAPN
.S RAIN=+$P(^RAMIS(71,RAPN,0),U,12) Q:'RAIN
.S RAORDST(RAIN,RALOOP)=RAON
.Q
S RAIMGTYN=+$O(^RA(79.2,"B",RAIMGTY,0)) Q:'RAIMGTYN
K RAORDS S (RALOOP,RAIN)=0
I $D(RAORDST(RAIMGTYN)) F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN) K RAORDST(RAIMGTYN,RAIN)
I $D(RAORDST) S RAIMGTYN=0 F S RAIMGTYN=$O(RAORDST(RAIMGTYN)) Q:'RAIMGTYN S RAIN=0 F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)
K RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN
Q
SETDISV ; when registering procedures of different imaging types set imaging
; location default value in DIC("B") if only one location associated with
; imaging type.
N RACNT,RAITNHLD,RAITNXT,RALOOP
S (RACNT,RAITNXT)=0
F RALOOP=0:0 S RAITNXT=$O(^RA(79.1,"BIMG",RAITN,RAITNXT)) Q:'RAITNXT S RACNT=RACNT+1,RAITNHLD=RAITNXT
;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD
I RACNT=1,RAITNHLD,$G(^RA(79.1,RAITNHLD,0))]"" S DIC("B")=$P($G(^SC(+^(0),0)),"^")
Q
SL ; switch locations
; Prompt the user to switch locations if the current sign-on imaging
; type does not match the procedure's imaging type.
; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0
S RAITN=$P(^RAMIS(71,+$P(Y,U,2),0),U,12)
;P154 Check switched to location until it's correct or ^ out
;p157 users holding the RA SWITCHLOC can proceed under different modality
F Q:RAITN=+$O(^RA(79.2,"B",RAIMGTY,0))!(RAQUIT=1) D Q:($D(^XUSEC("RA SWITCHLOC",DUZ)))
.S RAMLCHLD=RAMLC,RAYHOLD=Y,RAPROLOC=$P(^RA(79.2,RAITN,0),U,1),RAMDIVHD=RAMDIV
.D LABEL
.W !!?7,"Current Imaging Type: ",RAIMGTY
.W !?5,"Procedure Imaging Type: ",RAPROLOC
.W !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!
.D SETDISV
.K RAMLC S RASWLOC=""
.D SET^RAPSET1
.K RASWLOC
.I '$D(RAMLC) S RAQUIT=1,RAMLC=RAMLCHLD Q
.I RAMDIVHD'=RAMDIV W !!,"You have switched Divisions from: ",$P(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$P(^DIC(4,+RAMDIV,0),U),!
.D DT Q:RAQUIT
.S Y=RAYHOLD
.Q
K RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD
Q
DT ; prompt for new imaging date/time when imaging type changes
Q:'$D(^RADPT(RADFN,"DT",RADTI,0))
N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv?
R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME
I '$T!(X=" ")!(X="^") S RAQUIT=1 Q
S:X="" RANOW="",X="NOW"
I X="NOW" S RADTICHK=9999999.9999-($E($$NOW^XLFDT,1,12)) I $D(^RADPT(RADFN,"DT",RADTICHK,0)) D SUB1MIN K RADTICHK
S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR"
D ^%DT K %DT G DT:Y<0
DT1 S RADTE=Y,RADTI=9999999.9999-RADTE I $D(^RADPT(RADFN,"DT",RADTI,0)) W !,$C(7),"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option." G DT
DT2 K RADTEBAD S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE D SUB1MIN S RADTE=X,RADTI=RADTICHK G DT2
K RADTEBAD
I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT"
I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT"
Q
SUB1MIN ; subtract 1 minute from NOW to get an unused date/time
F RALOOP=1:1 S X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0) S RADTICHK=9999999.9999-X Q:'$D(^RADPT(RADFN,"DT",RADTICHK,0))
K RALOOP
Q
;
LABEL ; *** Print labels
I $D(RAPX) D
. W ! S RAPX=RADFN,RAZIS=1
. S RASAV2=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0))
. S RASAV3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",$S($G(RACNI):RACNI,1:+$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",0))),0))
. D FLH^RAFLH K RANUMF
. I $P(RAMDV,U,8) D JAC^RAJAC
. S RADFN=RAPX K RAZIS
. I $P($G(^DIC(195.4,1,"UP")),U,2) D ^RTQ5
. K RAPX
. Q
Q
;
PRNRQ ;Print Request at Registration - P137/KLM
I '$D(RAORDS) Q ;no order array
N RAJ,RAOIFN,RAILOC,RAION,RAARY,RAIENS
S RAJ=0 F S RAJ=$O(RAORDS(RAJ)) Q:RAJ="" D
.S RAOIFN=$G(RAORDS(RAJ)) Q:RAOIFN=""
.S RAIENS=RADTI_","_RADFN_"," ;P144/KLM
.S RAILOC=$$GET1^DIQ(70.02,RAIENS,4,"I") Q:RAILOC="" ;get i-loc from registered exam **changed from order /p144
.S RAION=$$GET1^DIQ(79.1,RAILOC,28) Q:RAION="" ;Registered Request printer defined?
.;Orders for registered exams may span modalities
.;order status is active/registered - build RAARY(DEVICE NAME,ORDER IEN)
.I $$GET1^DIQ(75.1,RAOIFN,5,"I")=6 S RAARY(RAION,RAOIFN)=""
.;End RAJ loop on RAORDS
;Setup task vars for each reg req device with orders
I $D(RAARY) D
.S RAION="" F S RAION=$O(RAARY(RAION)) Q:RAION="" D
..N RAORS
..S ZTIO=RAION
..S RAOIFN=0 F S RAOIFN=$O(RAARY(RAION,RAOIFN)) Q:RAOIFN="" D
...S RAORS(RAOIFN)=""
...;End RAOIFN loop - Order IEN
..S ZTDESC="Rad/Nuc Med Registered Request Print"
..S ZTDTH=$H,ZTRTN="PRNRQ1^RAREG3"
..S ZTSAVE("RADFN")="",ZTSAVE("RAORS(")="" D ^%ZTLOAD
..K ZTIO,ZTDTH,ZTSAVE,ZTDESC,ZTRTN
..I $D(ZTSK) W !!,"Task "_ZTSK_": registered request(s) queued to print on device ",RAION,!
..;End RAION loop - Device Name
.;End RAARY
K RAORS,RAION,RAJ,RAILOC,RAARY,RAOIFN
Q
PRNRQ1 ;task entry point - P137
N RAPAGE,RAX,RAOIFN
S RAPAGE=0,RAX="" ;needed for ^RAORD5
S RAOIFN=0 F S RAOIFN=$O(RAORS(RAOIFN)) Q:RAOIFN="" D
.U IO D ^RAORD5
K RAPAGE,RAX,RAOIFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAREG3 5929 printed Oct 16, 2024@18:39:42 Page 2
RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;24 Jul 2019 9:18 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**8,137,144,154,157**;Mar 16, 1998;Build 2
+2 ;Supported IA #10076 ^XUSEC(
+3 ;
RSBIT ; renumber selections by imaging type
+1 ; The RAORDS array has the list of orders the user selected to register
+2 ; in the order the user entered them. This subroutine will reorganize
+3 ; the array so the orders are arranged by imaging type of their
+4 ; procedure starting with the imaging type the user is currently signed
+5 ; on with followed by the ascending internal entry number of the
+6 ; remaining imaging types.
+7 ;
+8 if '$DATA(RAORDS)
QUIT
+9 KILL RALOOP,RAORDST
+10 FOR RALOOP=1:1
if '$DATA(RAORDS(RALOOP))
QUIT
Begin DoDot:1
+11 SET RAON=+$PIECE(RAORDS(RALOOP),U,1)
if 'RAON
QUIT
+12 SET RAPN=+$PIECE(^RAO(75.1,RAON,0),U,2)
if 'RAPN
QUIT
+13 SET RAIN=+$PIECE(^RAMIS(71,RAPN,0),U,12)
if 'RAIN
QUIT
+14 SET RAORDST(RAIN,RALOOP)=RAON
+15 QUIT
End DoDot:1
+16 SET RAIMGTYN=+$ORDER(^RA(79.2,"B",RAIMGTY,0))
if 'RAIMGTYN
QUIT
+17 KILL RAORDS
SET (RALOOP,RAIN)=0
+18 IF $DATA(RAORDST(RAIMGTYN))
FOR
SET RAIN=$ORDER(RAORDST(RAIMGTYN,RAIN))
if 'RAIN
QUIT
SET RALOOP=RALOOP+1
SET RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)
KILL RAORDST(RAIMGTYN,RAIN)
+19 IF $DATA(RAORDST)
SET RAIMGTYN=0
FOR
SET RAIMGTYN=$ORDER(RAORDST(RAIMGTYN))
if 'RAIMGTYN
QUIT
SET RAIN=0
FOR
SET RAIN=$ORDER(RAORDST(RAIMGTYN,RAIN))
if 'RAIN
QUIT
SET RALOOP=RALOOP+1
SET RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)
+20 KILL RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN
+21 QUIT
SETDISV ; when registering procedures of different imaging types set imaging
+1 ; location default value in DIC("B") if only one location associated with
+2 ; imaging type.
+3 NEW RACNT,RAITNHLD,RAITNXT,RALOOP
+4 SET (RACNT,RAITNXT)=0
+5 FOR RALOOP=0:0
SET RAITNXT=$ORDER(^RA(79.1,"BIMG",RAITN,RAITNXT))
if 'RAITNXT
QUIT
SET RACNT=RACNT+1
SET RAITNHLD=RAITNXT
+6 ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD
+7 IF RACNT=1
IF RAITNHLD
IF $GET(^RA(79.1,RAITNHLD,0))]""
SET DIC("B")=$PIECE($GET(^SC(+^(0),0)),"^")
+8 QUIT
SL ; switch locations
+1 ; Prompt the user to switch locations if the current sign-on imaging
+2 ; type does not match the procedure's imaging type.
+3 ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0
+4 SET RAITN=$PIECE(^RAMIS(71,+$PIECE(Y,U,2),0),U,12)
+5 ;P154 Check switched to location until it's correct or ^ out
+6 ;p157 users holding the RA SWITCHLOC can proceed under different modality
+7 FOR
if RAITN=+$ORDER(^RA(79.2,"B",RAIMGTY,0))!(RAQUIT=1)
QUIT
Begin DoDot:1
+8 SET RAMLCHLD=RAMLC
SET RAYHOLD=Y
SET RAPROLOC=$PIECE(^RA(79.2,RAITN,0),U,1)
SET RAMDIVHD=RAMDIV
+9 DO LABEL
+10 WRITE !!?7,"Current Imaging Type: ",RAIMGTY
+11 WRITE !?5,"Procedure Imaging Type: ",RAPROLOC
+12 WRITE !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!
+13 DO SETDISV
+14 KILL RAMLC
SET RASWLOC=""
+15 DO SET^RAPSET1
+16 KILL RASWLOC
+17 IF '$DATA(RAMLC)
SET RAQUIT=1
SET RAMLC=RAMLCHLD
QUIT
+18 IF RAMDIVHD'=RAMDIV
WRITE !!,"You have switched Divisions from: ",$PIECE(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$PIECE(^DIC(4,+RAMDIV,0),U),!
+19 DO DT
if RAQUIT
QUIT
+20 SET Y=RAYHOLD
+21 QUIT
End DoDot:1
if ($DATA(^XUSEC("RA SWITCHLOC",DUZ)))
QUIT
+22 KILL RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD
+23 QUIT
DT ; prompt for new imaging date/time when imaging type changes
+1 if '$DATA(^RADPT(RADFN,"DT",RADTI,0))
QUIT
+2 ;How many hrs in adv?
NEW RAHRS
SET RAHRS=+$PIECE($GET(^RA(79,+RAMDIV,.1)),"^",24)
+3 READ !!,"Imaging Exam Date/Time: NOW// ",X:DTIME
+4 IF '$TEST!(X=" ")!(X="^")
SET RAQUIT=1
QUIT
+5 if X=""
SET RANOW=""
SET X="NOW"
+6 IF X="NOW"
SET RADTICHK=9999999.9999-($EXTRACT($$NOW^XLFDT,1,12))
IF $DATA(^RADPT(RADFN,"DT",RADTICHK,0))
DO SUB1MIN
KILL RADTICHK
+7 SET %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0)
SET %DT="ETXR"
+8 DO ^%DT
KILL %DT
if Y<0
GOTO DT
DT1 SET RADTE=Y
SET RADTI=9999999.9999-RADTE
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
WRITE !,$CHAR(7),"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option."
GOTO DT
DT2 KILL RADTEBAD
SET RADTEBAD=$ORDER(^RADPT(RADFN,"DT","B",RADTE))
IF RADTEBAD[RADTE
DO SUB1MIN
SET RADTE=X
SET RADTI=RADTICHK
GOTO DT2
+1 KILL RADTEBAD
+2 IF $DATA(RANOW)
IF $DATA(RAWARD)
SET RACAT="INPATIENT"
+3 IF '$DATA(RANOW)
KILL RAWARD,RABED,RASER
DO ^RASERV
if $DATA(RAWARD)
SET RACAT="INPATIENT"
+4 QUIT
SUB1MIN ; subtract 1 minute from NOW to get an unused date/time
+1 FOR RALOOP=1:1
SET X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0)
SET RADTICHK=9999999.9999-X
if '$DATA(^RADPT(RADFN,"DT",RADTICHK,0))
QUIT
+2 KILL RALOOP
+3 QUIT
+4 ;
LABEL ; *** Print labels
+1 IF $DATA(RAPX)
Begin DoDot:1
+2 WRITE !
SET RAPX=RADFN
SET RAZIS=1
+3 SET RASAV2=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),0))
+4 SET RASAV3=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",$SELECT($GET(RACNI):RACNI,1:+$ORDER(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",0))),0))
+5 DO FLH^RAFLH
KILL RANUMF
+6 IF $PIECE(RAMDV,U,8)
DO JAC^RAJAC
+7 SET RADFN=RAPX
KILL RAZIS
+8 IF $PIECE($GET(^DIC(195.4,1,"UP")),U,2)
DO ^RTQ5
+9 KILL RAPX
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
PRNRQ ;Print Request at Registration - P137/KLM
+1 ;no order array
IF '$DATA(RAORDS)
QUIT
+2 NEW RAJ,RAOIFN,RAILOC,RAION,RAARY,RAIENS
+3 SET RAJ=0
FOR
SET RAJ=$ORDER(RAORDS(RAJ))
if RAJ=""
QUIT
Begin DoDot:1
+4 SET RAOIFN=$GET(RAORDS(RAJ))
if RAOIFN=""
QUIT
+5 ;P144/KLM
SET RAIENS=RADTI_","_RADFN_","
+6 ;get i-loc from registered exam **changed from order /p144
SET RAILOC=$$GET1^DIQ(70.02,RAIENS,4,"I")
if RAILOC=""
QUIT
+7 ;Registered Request printer defined?
SET RAION=$$GET1^DIQ(79.1,RAILOC,28)
if RAION=""
QUIT
+8 ;Orders for registered exams may span modalities
+9 ;order status is active/registered - build RAARY(DEVICE NAME,ORDER IEN)
+10 IF $$GET1^DIQ(75.1,RAOIFN,5,"I")=6
SET RAARY(RAION,RAOIFN)=""
+11 ;End RAJ loop on RAORDS
End DoDot:1
+12 ;Setup task vars for each reg req device with orders
+13 IF $DATA(RAARY)
Begin DoDot:1
+14 SET RAION=""
FOR
SET RAION=$ORDER(RAARY(RAION))
if RAION=""
QUIT
Begin DoDot:2
+15 NEW RAORS
+16 SET ZTIO=RAION
+17 SET RAOIFN=0
FOR
SET RAOIFN=$ORDER(RAARY(RAION,RAOIFN))
if RAOIFN=""
QUIT
Begin DoDot:3
+18 SET RAORS(RAOIFN)=""
+19 ;End RAOIFN loop - Order IEN
End DoDot:3
+20 SET ZTDESC="Rad/Nuc Med Registered Request Print"
+21 SET ZTDTH=$HOROLOG
SET ZTRTN="PRNRQ1^RAREG3"
+22 SET ZTSAVE("RADFN")=""
SET ZTSAVE("RAORS(")=""
DO ^%ZTLOAD
+23 KILL ZTIO,ZTDTH,ZTSAVE,ZTDESC,ZTRTN
+24 IF $DATA(ZTSK)
WRITE !!,"Task "_ZTSK_": registered request(s) queued to print on device ",RAION,!
+25 ;End RAION loop - Device Name
End DoDot:2
+26 ;End RAARY
End DoDot:1
+27 KILL RAORS,RAION,RAJ,RAILOC,RAARY,RAOIFN
+28 QUIT
PRNRQ1 ;task entry point - P137
+1 NEW RAPAGE,RAX,RAOIFN
+2 ;needed for ^RAORD5
SET RAPAGE=0
SET RAX=""
+3 SET RAOIFN=0
FOR
SET RAOIFN=$ORDER(RAORS(RAOIFN))
if RAOIFN=""
QUIT
Begin DoDot:1
+4 USE IO
DO ^RAORD5
End DoDot:1
+5 KILL RAPAGE,RAX,RAOIFN
+6 QUIT
