- 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 Feb 19, 2025@00:05:23 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