RAORDR2 ;ABV/SCR/MKN - Refer Pending/Hold Requests Reason for Request ; Feb 14, 2025@07:59:30
 ;;5.0;Radiology/Nuclear Medicine;**148,161,170,190,223**;Mar 16, 1998;Build 4
 ;
 ; 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) ;p161 -input transform for entering cc consults to the Imaging Location
 ;p223 -Matched on I-TYPE for location and Naming Convention in file 71.1235.
 ;Ex: COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO
 ;Allows for Special procedure mapping
 ;Allows for site identifier appension
 ;p223 updated screen for new CC titles
 N RAITYP,RACON,RASTR,RAM,RAITI,RARTN,RACIEN
 S RAITYP=$$GET1^DIQ(79.1,RADA,6),RAITI=$$GET1^DIQ(79.1,RADA,6,"I")
 S RACON="" F  S RACON=$O(^RA(71.1235,"C",RAITI,RACON)) Q:RACON=""  D
 .D FIND^DIC(123.5,"","@;.01","B",RACON,"","","","","RARTN")
 .I $D(RARTN("DILIST",2))=10 S RACIEN=0 F  S RACIEN=$O(RARTN("DILIST",2,RACIEN)) Q:RACIEN=""  D
 ..S RARY($G(RARTN("DILIST",2,RACIEN)))=$G(RARTN("DILIST","ID",RACIEN,.01))
 ..Q
 .Q
 Q
 ;
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   6687     printed  Sep 23, 2025@20:14:25                                                                                                                                                                                                     Page 2
RAORDR2   ;ABV/SCR/MKN - Refer Pending/Hold Requests Reason for Request ; Feb 14, 2025@07:59:30
 +1       ;;5.0;Radiology/Nuclear Medicine;**148,161,170,190,223**;Mar 16, 1998;Build 4
 +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) ;p161 -input transform for entering cc consults to the Imaging Location
 +1       ;p223 -Matched on I-TYPE for location and Naming Convention in file 71.1235.
 +2       ;Ex: COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO
 +3       ;Allows for Special procedure mapping
 +4       ;Allows for site identifier appension
 +5       ;p223 updated screen for new CC titles
 +6        NEW RAITYP,RACON,RASTR,RAM,RAITI,RARTN,RACIEN
 +7        SET RAITYP=$$GET1^DIQ(79.1,RADA,6)
           SET RAITI=$$GET1^DIQ(79.1,RADA,6,"I")
 +8        SET RACON=""
           FOR 
               SET RACON=$ORDER(^RA(71.1235,"C",RAITI,RACON))
               if RACON=""
                   QUIT 
               Begin DoDot:1
 +9                DO FIND^DIC(123.5,"","@;.01","B",RACON,"","","","","RARTN")
 +10               IF $DATA(RARTN("DILIST",2))=10
                       SET RACIEN=0
                       FOR 
                           SET RACIEN=$ORDER(RARTN("DILIST",2,RACIEN))
                           if RACIEN=""
                               QUIT 
                           Begin DoDot:2
 +11                           SET RARY($GET(RARTN("DILIST",2,RACIEN)))=$GET(RARTN("DILIST","ID",RACIEN,.01))
 +12                           QUIT 
                           End DoDot:2
 +13               QUIT 
               End DoDot:1
 +14       QUIT 
 +15      ;
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