RAORDR ;ABV/SCR/MKN - Refer Pending/Hold Requests ; Nov 09, 2022@10:54:24
;;5.0;Radiology/Nuclear Medicine;**148,161,170,179,190,196**;Mar 16, 1998;Build 1
;
; p196/KLM - Does the following:
; - Update order selection to use RAORDS
; - Add 'Order Referred' indicator to file 75.1
; - Add ENTRY/EXIT action to RA ORDERREF to set
; option aware variable
; - Change autohold check to use above indicator
; - Update consult comment to use controlled API
; - Remove unused code
;
;
; Routine/File IA Type
; -------------------------------------
; DEM^VADPT 10061 (S)
; ^DIWP 10011 (S)
; ^SC( 10040 (S)
; ^VA(200 10060 (S)
; ^DPT( 10035 (S)
; CMT^GMRCGUIB 2980 (C)
; ^OR(100 5771,6475 (C)
; ^GMR(123 6116,2586 (C)
;
Q
ENT ;Entry
;
N DIC,DIR,DIRUT,DTOUT,DUOUT,QQ,RA123IEN,RA44NA,RAANS,RAANS2,RAARAY,RAARRAY
N RACDW,RACDWN,RACIENS,RACOMCT,RACNT,RACOM,RACOUNT,RADD,RADFN,RADT,RAEND
N RAERR,RAEXPL,RAF,RAHDR,RAI,RAILOC,RAJUST,RAJUST2,RAILOC1,RALOCNM,RAMAND
N RAN,RANOW,RANOW2,RAO,RAOBEG,RAOEND,RAOIFN,RAOPHY,RAORD0,RAORDIEN,RAPOP
N RAPR,RAPRTYDT,RAQUES,RAQUIT,RAREAS,RAREQSTA,RARES,RASELOC,RASTART,RASUB
N RAT,RAUCID,X,Y,RAEXP,RANME
;
S (RAARRAY,RACIENS,RAILOC)=""
GETPAT ;
S (RACOUNT,RASELOC)=0 K RAEOS
K DIC,DIRUT,^TMP("RAORDR",$J),RAARRAY
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC K DIC
I $D(DIRUT) S RAQUIT=1
Q:$G(RAQUIT)!($G(Y)=-1)
S RADFN=+Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown") ;p196 - RANME needed for call to ^RAORDS
K DIR S DIR(0)="E" D ^DIR G:'+Y GETPAT
S Y="P",RAQUIT=0
S (RACOUNT,RAF,RARES)=0
D GETORD
;p196 - New order lookup returns RAORDS array
G:'$O(RAORDS(0))!(RAQUIT) GETPAT
S RAORDIEN=$$MAKECONS^RAORDR1($G(RAORDS(1)))
;p196
;Add comments to Consult that was just created
;P170
N I,RET
S RAUCID="",RA123IEN=$G(^OR(100,RAORDIEN,4)) I $P(RA123IEN,";",2)="GMRC" D
.S RA123IEN=+RA123IEN,RAUCID=$$GET1^DIQ(123,RA123IEN,80)
.D:RA123IEN
..S RACOM(1)="#COI#",RACOM(2)="COI-Veteran OPT-IN for Community Care",RACOM(3)=$P(RAREAS,U,2)
..I $D(RAEXP) D
...D BRKLINE(.RET,RAEXP,74)
...S I=0 F S I=$O(RET(I)) Q:I="" S RACOM(I+3)=$G(RET(I))
...Q
..S RADT=$$NOW^XLFDT() ;p179 - comment activity date is now
..L +^GMR(123,RA123IEN):5 I '$T D ERROR^RAORDR1("Consult record locked, cannot update comments.") Q ;p161 -Lock consult
..;p196 - update comment API to use #2980
..D CMT^GMRCGUIB(RA123IEN,.RACOM,,RADT)
..L -^GMR(123,RA123IEN)
.W !!,"Consult with UCID: "_$S(RAUCID]"":RAUCID,1:"(Not known)")," has been created",!
.I 'RA123IEN W !!,"**NO Consult created**",!
D KILL
G GETPAT
;
KILL ;
K DIC,DIR,DIRUT,QQ,RA123IEN,RA44NA,RAANS,RAANS2,RAARAY,RAARRAY,RACDW,RACDWN,RACIENS,RACOMCT,RACNT,RACOM
K RACOUNT,RADD,RADFN,RADT,RAEND,RAERR,RAEXPL,RAF,RAHDR,RAI,RAILOC,RAJUST,RAJUST2,RAILOC1,RALOCNM,RAN,RANOW
K RANOW2,RAO,RAOBEG,RAOEND,RAOIFN,RAOPHY,RAORD0,RAORDIEN,RAPOP,RAPR,RAPRTYDT,RAQUES,RAQUIT,RAREAS,RAUDIV
K RAREQSTA,RARES,RASELOC,RASTART,RASUB,RAT,RAUCID,X,Y,RET,RAEXP,RALADT,RAOI,ORDIALOG,RAEXP,RAIENS,RASOC,RAOVSTS
S (RACIENS,RAILOC)=""
Q
;
GETORD ;p196 - update order selection
S RAOVSTS="3;5;8"
W ! D ^RAORDS
I $O(RAORDS(""),-1)>1 D
.W !,"Only one order can be referred at a time",!
.S DIR(0)="Y",DIR("A")="Do you want to select again",DIR("B")="YES" D ^DIR
.I Y=1 G GETORD
.E K RAORDS,DIR,Y
.Q
Q
GETINFO(RAARAY) ;this function collects information that would be collected from a SEOC in Consult Toolbox
N DIR,DIRUT,RACOUNT,RAGMRC1,RARPT,Y
;
S (RAJUST,RAQUIT,RARPT)=0
;D SETJUST2 ;Set up RAJUST array with prompts
D GETMAIN
S:'$D(RAARAY("TYPEOFSERVICE")) RAARAY("TYPEOFSERVICE")="4^Diagnostic"
S RAARAY("THIRDPARTY")="2^NO"
S RAARAY("TRAUMA")="2^NO"
Q
;
GETMAIN ;Ask the main questions and fill in the answers at tag GETJSUB
;P170 - CC Justifications now stored in file #75.3 instead of hardcoded in this routine.
N RAJN,RAJJ,RAI,CNT S RAJN=""
W !!,"Justification for Community Care"
;W !!,?5,"Select one of the following:",!
S RAI=0 F S RAI=$O(^RA(75.3,RAI)) Q:RAI="B" D
.S RAJJ=$$GET1^DIQ(75.3,RAI,.01),RAJJ=$S($L(RAJJ,":")>1:$P(RAJJ,": ",2),1:RAJJ)
.I RAI=1 S RAJN=RAI_":"_RAJJ_";"
.E S RAJN=RAJN_RAI_":"_RAJJ_";"
.Q
S RAJN=$E(RAJN,1,$L(RAJN)-1)
N DIR,Y S DIR(0)="S^"_RAJN D ^DIR I $D(DIRUT) S RAQUIT=1 Q
S RAREAS=Y_"^"_$$GET1^DIQ(75.3,Y,.01) K DIR,Y
I RAREAS="" S RAQUIT=1 Q
I $$GET1^DIQ(75.3,+RAREAS,2,"I")=1 D
.S DIR(0)="F^3:240",DIR("A")="EXPLAIN" S DIR("?")="Enter Explaination for '"_$P(RAREAS,U,2)_"': 3-240 characters"
.D ^DIR I $D(DIRUT) S RAQUIT=1 Q
.S RAEXP=Y
.Q
K DIR,DIRUT,Y
Q
BRKLINE(OUT,LINE,LGTH) ;Break line down into 80 character lines in OUT
N CT,DIWL,DIWR,I,X
S LINE=$$TRIM^XLFSTR(LINE)
K ^UTILITY($J,"W") S CT=0,DIWL=1,DIWR=LGTH,X=LINE D ^DIWP
S I="" F S I=$O(^UTILITY($J,"W",1,I)) Q:'I S CT=CT+1,OUT(CT)=^UTILITY($J,"W",1,I,0)
K ^UTILITY($J,"W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDR 5163 printed Sep 23, 2025@20:14:23 Page 2
RAORDR ;ABV/SCR/MKN - Refer Pending/Hold Requests ; Nov 09, 2022@10:54:24
+1 ;;5.0;Radiology/Nuclear Medicine;**148,161,170,179,190,196**;Mar 16, 1998;Build 1
+2 ;
+3 ; p196/KLM - Does the following:
+4 ; - Update order selection to use RAORDS
+5 ; - Add 'Order Referred' indicator to file 75.1
+6 ; - Add ENTRY/EXIT action to RA ORDERREF to set
+7 ; option aware variable
+8 ; - Change autohold check to use above indicator
+9 ; - Update consult comment to use controlled API
+10 ; - Remove unused code
+11 ;
+12 ;
+13 ; Routine/File IA Type
+14 ; -------------------------------------
+15 ; DEM^VADPT 10061 (S)
+16 ; ^DIWP 10011 (S)
+17 ; ^SC( 10040 (S)
+18 ; ^VA(200 10060 (S)
+19 ; ^DPT( 10035 (S)
+20 ; CMT^GMRCGUIB 2980 (C)
+21 ; ^OR(100 5771,6475 (C)
+22 ; ^GMR(123 6116,2586 (C)
+23 ;
+24 QUIT
ENT ;Entry
+1 ;
+2 NEW DIC,DIR,DIRUT,DTOUT,DUOUT,QQ,RA123IEN,RA44NA,RAANS,RAANS2,RAARAY,RAARRAY
+3 NEW RACDW,RACDWN,RACIENS,RACOMCT,RACNT,RACOM,RACOUNT,RADD,RADFN,RADT,RAEND
+4 NEW RAERR,RAEXPL,RAF,RAHDR,RAI,RAILOC,RAJUST,RAJUST2,RAILOC1,RALOCNM,RAMAND
+5 NEW RAN,RANOW,RANOW2,RAO,RAOBEG,RAOEND,RAOIFN,RAOPHY,RAORD0,RAORDIEN,RAPOP
+6 NEW RAPR,RAPRTYDT,RAQUES,RAQUIT,RAREAS,RAREQSTA,RARES,RASELOC,RASTART,RASUB
+7 NEW RAT,RAUCID,X,Y,RAEXP,RANME
+8 ;
+9 SET (RAARRAY,RACIENS,RAILOC)=""
GETPAT ;
+1 SET (RACOUNT,RASELOC)=0
KILL RAEOS
+2 KILL DIC,DIRUT,^TMP("RAORDR",$JOB),RAARRAY
+3 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+4 IF $DATA(DIRUT)
SET RAQUIT=1
+5 if $GET(RAQUIT)!($GET(Y)=-1)
QUIT
+6 ;p196 - RANME needed for call to ^RAORDS
SET RADFN=+Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
+7 KILL DIR
SET DIR(0)="E"
DO ^DIR
if '+Y
GOTO GETPAT
+8 SET Y="P"
SET RAQUIT=0
+9 SET (RACOUNT,RAF,RARES)=0
+10 DO GETORD
+11 ;p196 - New order lookup returns RAORDS array
+12 if '$ORDER(RAORDS(0))!(RAQUIT)
GOTO GETPAT
+13 SET RAORDIEN=$$MAKECONS^RAORDR1($GET(RAORDS(1)))
+14 ;p196
+15 ;Add comments to Consult that was just created
+16 ;P170
+17 NEW I,RET
+18 SET RAUCID=""
SET RA123IEN=$GET(^OR(100,RAORDIEN,4))
IF $PIECE(RA123IEN,";",2)="GMRC"
Begin DoDot:1
+19 SET RA123IEN=+RA123IEN
SET RAUCID=$$GET1^DIQ(123,RA123IEN,80)
+20 if RA123IEN
Begin DoDot:2
+21 SET RACOM(1)="#COI#"
SET RACOM(2)="COI-Veteran OPT-IN for Community Care"
SET RACOM(3)=$PIECE(RAREAS,U,2)
+22 IF $DATA(RAEXP)
Begin DoDot:3
+23 DO BRKLINE(.RET,RAEXP,74)
+24 SET I=0
FOR
SET I=$ORDER(RET(I))
if I=""
QUIT
SET RACOM(I+3)=$GET(RET(I))
+25 QUIT
End DoDot:3
+26 ;p179 - comment activity date is now
SET RADT=$$NOW^XLFDT()
+27 ;p161 -Lock consult
LOCK +^GMR(123,RA123IEN):5
IF '$TEST
DO ERROR^RAORDR1("Consult record locked, cannot update comments.")
QUIT
+28 ;p196 - update comment API to use #2980
+29 DO CMT^GMRCGUIB(RA123IEN,.RACOM,,RADT)
+30 LOCK -^GMR(123,RA123IEN)
End DoDot:2
+31 WRITE !!,"Consult with UCID: "_$SELECT(RAUCID]"":RAUCID,1:"(Not known)")," has been created",!
+32 IF 'RA123IEN
WRITE !!,"**NO Consult created**",!
End DoDot:1
+33 DO KILL
+34 GOTO GETPAT
+35 ;
KILL ;
+1 KILL DIC,DIR,DIRUT,QQ,RA123IEN,RA44NA,RAANS,RAANS2,RAARAY,RAARRAY,RACDW,RACDWN,RACIENS,RACOMCT,RACNT,RACOM
+2 KILL RACOUNT,RADD,RADFN,RADT,RAEND,RAERR,RAEXPL,RAF,RAHDR,RAI,RAILOC,RAJUST,RAJUST2,RAILOC1,RALOCNM,RAN,RANOW
+3 KILL RANOW2,RAO,RAOBEG,RAOEND,RAOIFN,RAOPHY,RAORD0,RAORDIEN,RAPOP,RAPR,RAPRTYDT,RAQUES,RAQUIT,RAREAS,RAUDIV
+4 KILL RAREQSTA,RARES,RASELOC,RASTART,RASUB,RAT,RAUCID,X,Y,RET,RAEXP,RALADT,RAOI,ORDIALOG,RAEXP,RAIENS,RASOC,RAOVSTS
+5 SET (RACIENS,RAILOC)=""
+6 QUIT
+7 ;
GETORD ;p196 - update order selection
+1 SET RAOVSTS="3;5;8"
+2 WRITE !
DO ^RAORDS
+3 IF $ORDER(RAORDS(""),-1)>1
Begin DoDot:1
+4 WRITE !,"Only one order can be referred at a time",!
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want to select again"
SET DIR("B")="YES"
DO ^DIR
+6 IF Y=1
GOTO GETORD
+7 IF '$TEST
KILL RAORDS,DIR,Y
+8 QUIT
End DoDot:1
+9 QUIT
GETINFO(RAARAY) ;this function collects information that would be collected from a SEOC in Consult Toolbox
+1 NEW DIR,DIRUT,RACOUNT,RAGMRC1,RARPT,Y
+2 ;
+3 SET (RAJUST,RAQUIT,RARPT)=0
+4 ;D SETJUST2 ;Set up RAJUST array with prompts
+5 DO GETMAIN
+6 if '$DATA(RAARAY("TYPEOFSERVICE"))
SET RAARAY("TYPEOFSERVICE")="4^Diagnostic"
+7 SET RAARAY("THIRDPARTY")="2^NO"
+8 SET RAARAY("TRAUMA")="2^NO"
+9 QUIT
+10 ;
GETMAIN ;Ask the main questions and fill in the answers at tag GETJSUB
+1 ;P170 - CC Justifications now stored in file #75.3 instead of hardcoded in this routine.
+2 NEW RAJN,RAJJ,RAI,CNT
SET RAJN=""
+3 WRITE !!,"Justification for Community Care"
+4 ;W !!,?5,"Select one of the following:",!
+5 SET RAI=0
FOR
SET RAI=$ORDER(^RA(75.3,RAI))
if RAI="B"
QUIT
Begin DoDot:1
+6 SET RAJJ=$$GET1^DIQ(75.3,RAI,.01)
SET RAJJ=$SELECT($LENGTH(RAJJ,":")>1:$PIECE(RAJJ,": ",2),1:RAJJ)
+7 IF RAI=1
SET RAJN=RAI_":"_RAJJ_";"
+8 IF '$TEST
SET RAJN=RAJN_RAI_":"_RAJJ_";"
+9 QUIT
End DoDot:1
+10 SET RAJN=$EXTRACT(RAJN,1,$LENGTH(RAJN)-1)
+11 NEW DIR,Y
SET DIR(0)="S^"_RAJN
DO ^DIR
IF $DATA(DIRUT)
SET RAQUIT=1
QUIT
+12 SET RAREAS=Y_"^"_$$GET1^DIQ(75.3,Y,.01)
KILL DIR,Y
+13 IF RAREAS=""
SET RAQUIT=1
QUIT
+14 IF $$GET1^DIQ(75.3,+RAREAS,2,"I")=1
Begin DoDot:1
+15 SET DIR(0)="F^3:240"
SET DIR("A")="EXPLAIN"
SET DIR("?")="Enter Explaination for '"_$PIECE(RAREAS,U,2)_"': 3-240 characters"
+16 DO ^DIR
IF $DATA(DIRUT)
SET RAQUIT=1
QUIT
+17 SET RAEXP=Y
+18 QUIT
End DoDot:1
+19 KILL DIR,DIRUT,Y
+20 QUIT
BRKLINE(OUT,LINE,LGTH) ;Break line down into 80 character lines in OUT
+1 NEW CT,DIWL,DIWR,I,X
+2 SET LINE=$$TRIM^XLFSTR(LINE)
+3 KILL ^UTILITY($JOB,"W")
SET CT=0
SET DIWL=1
SET DIWR=LGTH
SET X=LINE
DO ^DIWP
+4 SET I=""
FOR
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
SET CT=CT+1
SET OUT(CT)=^UTILITY($JOB,"W",1,I,0)
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
