RAORDR2 ;ABV/SCR/MKN - Refer Pending/Hold Requests Reason for Request ; Jul 08, 2022@13:00:02
;;5.0;Radiology/Nuclear Medicine;**148,161,170,190**;Mar 16, 1998;Build 1
;
; Routine/File IA Type
; -------------------------------------
; DETAIL^ORWOR NONE
; ^OR(100 5771,6475 (C)
;
;
GETREAS ;Get Reason
N RAARRAY,RACOUNT,RAERR,RAFILE,RAI,RAL,RAMED,RANEXT,RARTRN1
S RAIENS=RAOIFN_","
S RAFILE=100.008 ;get order actions
S RAFIELDS=".01;.1;2;3;4;5;6;12;13;16;17" ;only using .01,2,3,5,6,12
S RACOUNT=1,RANEXT=0
F S RANEXT=$O(^OR(100,RAORDIEN,8,RANEXT)) Q:'+RANEXT D
.S RAIENS=RANEXT_","_RAORDIEN_","
.S RAFIELDS=".01;2;3;7;12;13;21;22;"
.D GETS^DIQ(RAFILE,RAIENS,RAFIELDS,"E","RARTRN1","RAERR")
S RAX=$O(^RA(75.2,"B","COMMUNITY CARE APPT",""))
D:RAX?1.N
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)="",RACOUNT=RACOUNT+1
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" ** Radiology Order placed on hold due to COMMUNITY CARE APPT **",RACOUNT=RACOUNT+1
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)="",RACOUNT=RACOUNT+1
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Date/Time Ordered: "_$G(RARTRN1(100.008,RAIENS,.01,"E"))_" "_$G(RARTRN1(100.008,RAIENS,2,"E"))_" order entered by "_$G(RARTRN1(100.008,RAIENS,3,"E"))
.S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
.S RACOUNT=RACOUNT+2
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Nature of Order: "_$G(RARTRN1(100.008,RAIENS,12,"E"))
.S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
.S RACOUNT=RACOUNT+2
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Elec Signature: "_$G(RARTRN1(100.008,RAIENS,5,"E"))_" on "_$G(RARTRN1(100.008,RAIENS,6,"E"))
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
D GETINFO^RAORDR(.RAARAY) Q:RAQUIT
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Justification for Community Care:"
S RACOUNT=RACOUNT+1
;P170 - CC Justifications redone
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" "_$P(RAREAS,U,2)
I $D(RAEXP) D
.K RAL D BRKLINE^RAORDR(.RAL," "_RAEXP,70)
.D SETLINES
.Q
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Type of Service: "_$P(RAARAY("TYPEOFSERVICE"),U,2)
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
S RANEXT=0
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Category: "_RAORTYP
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Ordering Location: "_RAORDLOC
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
I RAORPRE'="" D
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Pre-Op Scheduled Date/Time: "_RAORPRE
.S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
.S RACOUNT=RACOUNT+2
I RAORPREG'="" D
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Pregnant: "_RAORPREG
.S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
.S RACOUNT=RACOUNT+2
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Date Desired (not guaranteed): "_RAORWANT
S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
S RACOUNT=RACOUNT+2
I $G(RAARAY("THIRDPARTY")) D
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Third Party: "_$P(RAARAY("THIRDPARTY"),U,2)
.S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
.S RACOUNT=RACOUNT+2
I $G(RAARAY("TRAUMA")) D
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" History of Trauma :"_$P(RAARAY("TRAUMA"),U,2)
.S RANEXT=0
.F S RANEXT=$O(RAARAY("TRAUMA",RANEXT)) Q:RANEXT="" D
. .S ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
. .S RACOUNT=RACOUNT+2
. .S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAARAY("TRAUMA",RANEXT)
D ORDDET
Q
;
ORDDET ;Get Order Detail
N RACR,RAHDORD,RAN,RAHDORD,RAOUT,RAX,RAY
S RAX="",$P(RAX,"-",79)=""
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" ",RACOUNT=RACOUNT+1
S RAY="Radiology order details "
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY_$E(RAX,1,79-$L(RAY)),RACOUNT=RACOUNT+1
S RAY="Radiology order IEN:"_RAORDIEN
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY,RACOUNT=RACOUNT+1
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)="",RACOUNT=RACOUNT+1
D DETAIL^ORWOR(.RAOUT,RAORDIEN,RAORVP)
S RAN=0 F S RAN=$O(@RAOUT@(RAN)) Q:'RAN D
.S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=@RAOUT@(RAN),RACOUNT=RACOUNT+1,ORDIALOG("WP",RAWPN,1,RACOUNT,0)="",RACOUNT=RACOUNT+1
S RAY="RAD"_$E(RAX,1,76)
S ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY,RACOUNT=RACOUNT+1,ORDIALOG("WP",RAWPN,1,RACOUNT,0)="",RACOUNT=RACOUNT+1
Q
;
SETLINES ;
S RAI="" F S RAI=$O(RAL(RAI)) Q:'RAI S RACOUNT=RACOUNT+1,ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" "_RAL(RAI)
Q
;
GETILOC(RAITYP) ;p170 returns imaging location
;It's possible for the order to not have a 'submit to' location, in which case we'll try to
;determine a location based on imaging type and user's division or prompt the user.
;Also come here if I-LOC from order has no CCC
;RAITYP :Imaging Type from the radiology order (#79.2)
;Returns an Imaging Location (#79.1)
Q:'$D(RAITYP)
N RAOILOC,RAIL,RAILS,RAS,RASOC,RAUDIV S RAUDIV=DUZ(2) I $D(RAUDIV) D
.S RAIL="" F Q:$G(RAOILOC)]"" S RAIL=$O(^RA(79,RAUDIV,"L","B",RAIL)) Q:RAIL="" D
..I RAITYP=$$GET1^DIQ(79.1,RAIL,6,"I")&($O(^RA(79.1,RAIL,"CON",0))) S RAOILOC=RAIL
..Q
.Q
I $G(RAOILOC)="" D ;still no location? Lets prompt the user...
.D LOCSCRN
.I $D(RAILS) D
..W !,"Please select the "_$$GET1^DIQ(79.2,RAITYP,.01)_" location you want to use.",!
..S (RAS,RASOC)="" F S RAS=$O(RAILS(RAS)) Q:RAS="" D
...S RASOC=RASOC_RAS
...Q
..N DIR,Y,DIRUT S DIR(0)="S^"_RASOC D ^DIR Q:$D(DIRUT)
..S RAOILOC=$G(RAILS(+Y_":"_Y(0)_";"))
..Q
.E W !!,"There are no consult titles associated with "_$$GET1^DIQ(79.2,RAITYP,.01)_".",!,"Please contact your Radiology ADPAC." Q
.Q
Q $S($G(RAOILOC)>0:RAOILOC,1:0)
CCCHK(RADA,RAY) ;p161 -input transform for entering cc consults to the Imaging Location
;Matched on I-TYPE for location and Naming Convention.
;Ex: COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO
;Allows for site identifier appension
;RADA = ILOC
N RAITYP,RACON,RASTR,RAM
S RAITYP=$$GET1^DIQ(79.1,RADA,6) S:RAITYP="CT SCAN" RAITYP="CT"
S RASTR=$P(^GMR(123.5,RAY,0),U)
S RACON="COMMUNITY CARE-IMAGING "_RAITYP
I RAITYP="MAMMOGRAPHY" Q $S(($P(RASTR," DIAGNOSTIC-AUTO",1)=RACON)!($P(RASTR," SCREEN-AUTO",1)=RACON):1,1:0)
E Q $S($P(RASTR,"-AUTO",1)=RACON:1,1:0)
;
LOCSCRN() ;Screen for user prompt to select the i-loc for the order referral
N RAI,RAC S (RAI,RAC)=0
F S RAI=$O(^RA(79.1,"BIMG",RAITYP,RAI)) Q:RAI="" D
.Q:$P(^RA(79.1,RAI,0),U,19)]"" ;inactive
.Q:'$O(^RA(79.1,RAI,"CON",0)) ;no CCC
.S RAC=RAC+1 ;ctr
.S RAILS(RAC_":"_$$GET1^DIQ(79.1,RAI,.01)_";")=RAI
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDR2 6486 printed Apr 09, 2024@21:38:54 Page 2
RAORDR2 ;ABV/SCR/MKN - Refer Pending/Hold Requests Reason for Request ; Jul 08, 2022@13:00:02
+1 ;;5.0;Radiology/Nuclear Medicine;**148,161,170,190**;Mar 16, 1998;Build 1
+2 ;
+3 ; Routine/File IA Type
+4 ; -------------------------------------
+5 ; DETAIL^ORWOR NONE
+6 ; ^OR(100 5771,6475 (C)
+7 ;
+8 ;
GETREAS ;Get Reason
+1 NEW RAARRAY,RACOUNT,RAERR,RAFILE,RAI,RAL,RAMED,RANEXT,RARTRN1
+2 SET RAIENS=RAOIFN_","
+3 ;get order actions
SET RAFILE=100.008
+4 ;only using .01,2,3,5,6,12
SET RAFIELDS=".01;.1;2;3;4;5;6;12;13;16;17"
+5 SET RACOUNT=1
SET RANEXT=0
+6 FOR
SET RANEXT=$ORDER(^OR(100,RAORDIEN,8,RANEXT))
if '+RANEXT
QUIT
Begin DoDot:1
+7 SET RAIENS=RANEXT_","_RAORDIEN_","
+8 SET RAFIELDS=".01;2;3;7;12;13;21;22;"
+9 DO GETS^DIQ(RAFILE,RAIENS,RAFIELDS,"E","RARTRN1","RAERR")
End DoDot:1
+10 SET RAX=$ORDER(^RA(75.2,"B","COMMUNITY CARE APPT",""))
+11 if RAX?1.N
Begin DoDot:1
+12 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=""
SET RACOUNT=RACOUNT+1
+13 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" ** Radiology Order placed on hold due to COMMUNITY CARE APPT **"
SET RACOUNT=RACOUNT+1
+14 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=""
SET RACOUNT=RACOUNT+1
+15 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Date/Time Ordered: "_$GET(RARTRN1(100.008,RAIENS,.01,"E"))_" "_$GET(RARTRN1(100.008,RAIENS,2,"E"))_" order entered by "_$GET(RARTRN1(100.008,RAIENS,3,"E"))
+16 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+17 SET RACOUNT=RACOUNT+2
+18 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Nature of Order: "_$GET(RARTRN1(100.008,RAIENS,12,"E"))
+19 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+20 SET RACOUNT=RACOUNT+2
+21 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Elec Signature: "_$GET(RARTRN1(100.008,RAIENS,5,"E"))_" on "_$GET(RARTRN1(100.008,RAIENS,6,"E"))
End DoDot:1
+22 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+23 SET RACOUNT=RACOUNT+2
+24 DO GETINFO^RAORDR(.RAARAY)
if RAQUIT
QUIT
+25 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Justification for Community Care:"
+26 SET RACOUNT=RACOUNT+1
+27 ;P170 - CC Justifications redone
+28 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" "_$PIECE(RAREAS,U,2)
+29 IF $DATA(RAEXP)
Begin DoDot:1
+30 KILL RAL
DO BRKLINE^RAORDR(.RAL," "_RAEXP,70)
+31 DO SETLINES
+32 QUIT
End DoDot:1
+33 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+34 SET RACOUNT=RACOUNT+2
+35 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Type of Service: "_$PIECE(RAARAY("TYPEOFSERVICE"),U,2)
+36 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+37 SET RACOUNT=RACOUNT+2
+38 SET RANEXT=0
+39 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Category: "_RAORTYP
+40 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+41 SET RACOUNT=RACOUNT+2
+42 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Ordering Location: "_RAORDLOC
+43 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+44 SET RACOUNT=RACOUNT+2
+45 IF RAORPRE'=""
Begin DoDot:1
+46 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Pre-Op Scheduled Date/Time: "_RAORPRE
+47 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+48 SET RACOUNT=RACOUNT+2
End DoDot:1
+49 IF RAORPREG'=""
Begin DoDot:1
+50 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Pregnant: "_RAORPREG
+51 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+52 SET RACOUNT=RACOUNT+2
End DoDot:1
+53 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Date Desired (not guaranteed): "_RAORWANT
+54 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+55 SET RACOUNT=RACOUNT+2
+56 IF $GET(RAARAY("THIRDPARTY"))
Begin DoDot:1
+57 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" Third Party: "_$PIECE(RAARAY("THIRDPARTY"),U,2)
+58 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+59 SET RACOUNT=RACOUNT+2
End DoDot:1
+60 IF $GET(RAARAY("TRAUMA"))
Begin DoDot:1
+61 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" History of Trauma :"_$PIECE(RAARAY("TRAUMA"),U,2)
+62 SET RANEXT=0
+63 FOR
SET RANEXT=$ORDER(RAARAY("TRAUMA",RANEXT))
if RANEXT=""
QUIT
Begin DoDot:2
+64 SET ORDIALOG("WP",RAWPN,1,RACOUNT+1,0)=""
+65 SET RACOUNT=RACOUNT+2
+66 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAARAY("TRAUMA",RANEXT)
End DoDot:2
End DoDot:1
+67 DO ORDDET
+68 QUIT
+69 ;
ORDDET ;Get Order Detail
+1 NEW RACR,RAHDORD,RAN,RAHDORD,RAOUT,RAX,RAY
+2 SET RAX=""
SET $PIECE(RAX,"-",79)=""
+3 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" "
SET RACOUNT=RACOUNT+1
+4 SET RAY="Radiology order details "
+5 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY_$EXTRACT(RAX,1,79-$LENGTH(RAY))
SET RACOUNT=RACOUNT+1
+6 SET RAY="Radiology order IEN:"_RAORDIEN
+7 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY
SET RACOUNT=RACOUNT+1
+8 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=""
SET RACOUNT=RACOUNT+1
+9 DO DETAIL^ORWOR(.RAOUT,RAORDIEN,RAORVP)
+10 SET RAN=0
FOR
SET RAN=$ORDER(@RAOUT@(RAN))
if 'RAN
QUIT
Begin DoDot:1
+11 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=@RAOUT@(RAN)
SET RACOUNT=RACOUNT+1
SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=""
SET RACOUNT=RACOUNT+1
End DoDot:1
+12 SET RAY="RAD"_$EXTRACT(RAX,1,76)
+13 SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=RAY
SET RACOUNT=RACOUNT+1
SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=""
SET RACOUNT=RACOUNT+1
+14 QUIT
+15 ;
SETLINES ;
+1 SET RAI=""
FOR
SET RAI=$ORDER(RAL(RAI))
if 'RAI
QUIT
SET RACOUNT=RACOUNT+1
SET ORDIALOG("WP",RAWPN,1,RACOUNT,0)=" "_RAL(RAI)
+2 QUIT
+3 ;
GETILOC(RAITYP) ;p170 returns imaging location
+1 ;It's possible for the order to not have a 'submit to' location, in which case we'll try to
+2 ;determine a location based on imaging type and user's division or prompt the user.
+3 ;Also come here if I-LOC from order has no CCC
+4 ;RAITYP :Imaging Type from the radiology order (#79.2)
+5 ;Returns an Imaging Location (#79.1)
+6 if '$DATA(RAITYP)
QUIT
+7 NEW RAOILOC,RAIL,RAILS,RAS,RASOC,RAUDIV
SET RAUDIV=DUZ(2)
IF $DATA(RAUDIV)
Begin DoDot:1
+8 SET RAIL=""
FOR
if $GET(RAOILOC)]""
QUIT
SET RAIL=$ORDER(^RA(79,RAUDIV,"L","B",RAIL))
if RAIL=""
QUIT
Begin DoDot:2
+9 IF RAITYP=$$GET1^DIQ(79.1,RAIL,6,"I")&($ORDER(^RA(79.1,RAIL,"CON",0)))
SET RAOILOC=RAIL
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 ;still no location? Lets prompt the user...
IF $GET(RAOILOC)=""
Begin DoDot:1
+13 DO LOCSCRN
+14 IF $DATA(RAILS)
Begin DoDot:2
+15 WRITE !,"Please select the "_$$GET1^DIQ(79.2,RAITYP,.01)_" location you want to use.",!
+16 SET (RAS,RASOC)=""
FOR
SET RAS=$ORDER(RAILS(RAS))
if RAS=""
QUIT
Begin DoDot:3
+17 SET RASOC=RASOC_RAS
+18 QUIT
End DoDot:3
+19 NEW DIR,Y,DIRUT
SET DIR(0)="S^"_RASOC
DO ^DIR
if $DATA(DIRUT)
QUIT
+20 SET RAOILOC=$GET(RAILS(+Y_":"_Y(0)_";"))
+21 QUIT
End DoDot:2
+22 IF '$TEST
WRITE !!,"There are no consult titles associated with "_$$GET1^DIQ(79.2,RAITYP,.01)_".",!,"Please contact your Radiology ADPAC."
QUIT
+23 QUIT
End DoDot:1
+24 QUIT $SELECT($GET(RAOILOC)>0:RAOILOC,1:0)
CCCHK(RADA,RAY) ;p161 -input transform for entering cc consults to the Imaging Location
+1 ;Matched on I-TYPE for location and Naming Convention.
+2 ;Ex: COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO
+3 ;Allows for site identifier appension
+4 ;RADA = ILOC
+5 NEW RAITYP,RACON,RASTR,RAM
+6 SET RAITYP=$$GET1^DIQ(79.1,RADA,6)
if RAITYP="CT SCAN"
SET RAITYP="CT"
+7 SET RASTR=$PIECE(^GMR(123.5,RAY,0),U)
+8 SET RACON="COMMUNITY CARE-IMAGING "_RAITYP
+9 IF RAITYP="MAMMOGRAPHY"
QUIT $SELECT(($PIECE(RASTR," DIAGNOSTIC-AUTO",1)=RACON)!($PIECE(RASTR," SCREEN-AUTO",1)=RACON):1,1:0)
+10 IF '$TEST
QUIT $SELECT($PIECE(RASTR,"-AUTO",1)=RACON:1,1:0)
+11 ;
LOCSCRN() ;Screen for user prompt to select the i-loc for the order referral
+1 NEW RAI,RAC
SET (RAI,RAC)=0
+2 FOR
SET RAI=$ORDER(^RA(79.1,"BIMG",RAITYP,RAI))
if RAI=""
QUIT
Begin DoDot:1
+3 ;inactive
if $PIECE(^RA(79.1,RAI,0),U,19)]""
QUIT
+4 ;no CCC
if '$ORDER(^RA(79.1,RAI,"CON",0))
QUIT
+5 ;ctr
SET RAC=RAC+1
+6 SET RAILS(RAC_":"_$$GET1^DIQ(79.1,RAI,.01)_";")=RAI
+7 QUIT
End DoDot:1
+8 QUIT
