RAORDU1 ;HISC/CAH - AISC/SAW-Utility for Rad/NM Orders Module ;05/15/09 12:56
;;5.0;Radiology/Nuclear Medicine;**10,41,75,99**;Mar 16, 1998;Build 5
;P#99 - changed Pregnant title to Pregnant at time of order entry.
CP ;Create protocols for Rad/Nuc Med in OE/RR Protocol file (#100)
;based upon entries in the Rad/Nuc Med Common Procedure file (#71.3)
;
I $$ORVR^RAORDU()>2.5 W !!,"In order to use this option, your site must be running version 2.5 of the",!,"Order Entry/Results Reporting package." G Q
;
;Check/set package and default protocol values
S ORPKG=$O(^DIC(9.4,"C","RA",0)) I 'ORPKG W !,$C(7),"There is no entry for the Radiology/Nuclear Medicine package in your Package",!,"file (#9.4), unable to proceed. Contact your site manager." G Q
S ORDEF=$O(^ORD(101,"B","RA OERR DEFAULT PROTOCOL",0)) I 'ORDEF W !,$C(7),"You do not have a default Radiology/Nuclear Medicine protocol in your",!,"Protocol file (#101), unable to continue. Contact your site manager." G Q
S (I,RACNT,RAF1,X)=0 K ^TMP($J,"RAEX") W !!?10,"Create an OE/RR Protocol from a Radiology/Nuclear Medicine",!?10,"Common Procedure",!
F S I=$O(^RAMIS(71.3,I)) Q:I'>0 I $D(^(I,0)) S Y=I_"^"_^(0) I $P(Y,"^",6)']"",$D(^RAMIS(71,+$P(Y,"^",2),0)) S RACNT=RACNT+1,^TMP($J,"RAEX",RACNT)=Y W !,RACNT,?6,$P(^RAMIS(71,+$P(Y,"^",2),0),"^") D:'(RACNT#15) ASK^RAUTL4 Q:X="^"!(X>0)
G Q:X="^" I 'RACNT W !,$C(7),"The Common Procedures file does not have any entries from which to choose." G Q
I RACNT=1 S RADUP(1)="" W !!,"There is only one Common Procedure to choose from." S DIR(0)="YA",DIR("A")="Okay to continue? " D ^DIR G Q:Y'=1,CP1
I X'>0,RACNT#15 D ASK^RAUTL4 G Q:'$D(RADUP)
CP1 S RAI=0 F S RAI=$O(RADUP(RAI)) Q:RAI'>0 S Y=^TMP($J,"RAEX",RAI),DA=+Y,Y=$P(Y,"^",2,99) W !!,"Processing the ",$P(^RAMIS(71,+Y,0),"^")," procedure.",! D CP2
Q K %1,D,D0,DA,DIC,DIE,DIR,DR,I,J,K,ORDEF,OREA,ORFL,ORPKG,ORTXT,RACNT,RADUP,RAERR,RAF1,RAI,RAILOC,RAPAR,RASEL,X,Y,Z,^TMP($J,"RAEX")
K DI,DIG,DIH,DIU,DIV,DQ
Q
CP2 S RAERR=0 S RAILOC=$P(Y,"^",8) I 'RAILOC S RAILOC=$O(^RA(79.1,0)) I RAILOC,$O(^(RAILOC)) K RAILOC W !,$C(7),"You must enter an 'Imaging Location' before this procedure can be processed",!,"as an orderable item in OE/RR." S RAERR=1
S ORTXT=$P(Y,"^",13) I ORTXT']"" W !,$C(7),"You must enter a 'Name of Ordeable Item' before this procedure can be processed",!,"as an orderable item in OE/RR." S RAERR=1
I RAERR K RAILOC,ORTXT Q
S ORFL=+Y_";RAMIS(71,",OREA="S RADR1=1,RAPRI="_+Y_",RAILOC="_RAILOC_$S($P(Y,"^",11):",RARU="_$P(Y,"^",11),1:"")
S Z="^^^^^RACAT^RAREQDT^^RAMT^RAIP" F X=6,9,10 S OREA=OREA_$S($P(Y,"^",X)]"":","_$P(Z,"^",X)_"="_""""_$P(Y,"^",X)_"""",1:"")
I $O(^RAMIS(71.3,DA,"M",0)) S K=0 F J=1:1 S K=$O(^RAMIS(71.3,DA,"M",K)) Q:K'>0 S X=$G(^(K,0)) I $D(^RAMIS(71.2,+X,0)) S X=$P(^(0),"^") I X]"" S OREA=OREA_",RAMOD("_J_")="_""""_X_""""
S OREA=OREA_" D ^RAORR"
I $G(^DIC(9.4,ORPKG,0))]"" N RA1 S RA1=$P(^(0),"^",2)_+ORFL_" "_ORTXT S:$O(^ORD(101,"B",RA1,0)) ORDA=$O(^(0)) ; define ORDA if filelink record exists in file #101
;D EN3^ORUPREF2 W:$D(Y) !,*7,"Unable to create an orderable item in OE/RR."
Q ;dead code OE 2.5 from CP down to here
;
DISP ;Display request with defaults
S:'$D(RAMOD)#2 RAMOD=""
S J="",$P(J,"-",80)="" W !!,J
I $D(RAMOD)>9 S RAMOD="" F I=1:1 Q:'$D(RAMOD(I)) S RAMOD=RAMOD_$S(I'=1:", ",1:"")_RAMOD(I) S RAI=0 S RAI=+$O(^RAMIS(71.2,"B",RAMOD(I),RAI)) I $P($G(^RAMIS(71.2,RAI,0)),U,2)="p" S RAACI="p"
W !?10,"Patient: ",RANME I RASEX'="M" S:'$D(RAPREG) RAPREG="" W " Pregnant at time of order entry: ",$S(RAPREG="y":"YES",RAPREG="u":"UNKNOWN",RAPREG="n":"NO",1:"")
W !?8,"Procedure: ",$S($D(^RAMIS(71,RAPRI,0)):$P(^(0),"^"),1:"UNKNOWN"),!?2,"Proc. Modifiers: ",RAMOD
S:'$D(RAMT) RAMT=$S($G(RAACI)="p":"p",$E(RACAT)="I":"w",1:"a") S RAMT=RAMT_"^"_$P($P(^DD(75.1,19,0),RAMT_":",2),";") W !?9,"Category: ",RACAT,?49,"Mode of Transport: ",$P(RAMT,"^",2)
S:'$D(RAIP) RAIP="n" W !," Desired Date: ",RAWHEN,?46,"Isolation Procedures: ",$S(RAIP="y":"YES",1:"NO")
S:'$D(RARU) RARU=9 W !," Request Urgency: ",$S($D(RARU):$P($P(^DD(75.1,6,0),RARU_":",2),";"),1:"ROUTINE"),?46,"Scheduled for Pre-op: ",$S($D(RAPREOP1):"YES",1:"NO")
I $D(RAILOC) W !,"Submit Request To: ",$S($D(^RA(79.1,+RAILOC,0)):$S($D(^SC(+$P(^(0),"^"),0)):$P(^(0),"^"),1:"Unknown"),1:"Unknown")
W !," Request Location: ",$S($P($G(^SC(+RALIFN,0)),U)]"":$E($P($G(^SC(+RALIFN,0)),U),1,26),1:"Unkown") I $$ORVR^RAORDU()'<3 W ?46,"Nature of order: SVC CORRECTION"
D DISREA(RAREAST) ;display the reason for study
;*Billing Aware Project:
; Display New ICD-9 Dx and their related SC/EI/MST/HNC responses.
;
BADISP D:$P($G(RABWDX(1)),U,1)>0 BADISP^RABWORD1(.RABWDX)
;*
K ^UTILITY($J,"W"),^(1) S DIWF="WN",DIWL=1,DIWR=79,I=0 W !!,"Clinical History:",! F S I=$O(^TMP($J,"RAWP",I)) Q:I'>0 S X=^(I,0) D ^DIWP
D ^DIWW W !,J
S DIR(0)="Y",DIR("A")="Do you want to change any of the above",DIR("B")="NO" D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) RAOUT=1 Q:$D(RAOUT) S:Y=0 RADR1=1 S:Y'=0 RADR2=1,RASTOP=0
; RASTOP is used to track whether the procedure messages have printed.
; If you answer 'yes' to "Do you want to edit this request", you
; will see the procedure messages again (if they exist and if you
; viewed them before. Value altered in ADDORD+1^RAORD1 & EN2+1^RAPRI)
Q
;
DISREA(X) ;this function formats and displays the reason for study for this
;order.
;input: X - the reason for study (a string between three & sixty four
;characters in length)
N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,LINES,Z
;accumulate & format data; column width of sixty (DIWF's C60) characters
S DIWF="C60",DIWL=1 D ^DIWP
W !," Reason for Study: " S I=0,LINES=^UTILITY($J,"W",DIWL)
;LINES: # of formatted lines in ^UTILITY
F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:'I W ?19,$G(^(I,0)) W:I'=LINES !
K ^UTILITY($J,"W",DIWL)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDU1 5901 printed Apr 09, 2024@21:35:45 Page 2
RAORDU1 ;HISC/CAH - AISC/SAW-Utility for Rad/NM Orders Module ;05/15/09 12:56
+1 ;;5.0;Radiology/Nuclear Medicine;**10,41,75,99**;Mar 16, 1998;Build 5
+2 ;P#99 - changed Pregnant title to Pregnant at time of order entry.
CP ;Create protocols for Rad/Nuc Med in OE/RR Protocol file (#100)
+1 ;based upon entries in the Rad/Nuc Med Common Procedure file (#71.3)
+2 ;
+3 IF $$ORVR^RAORDU()>2.5
WRITE !!,"In order to use this option, your site must be running version 2.5 of the",!,"Order Entry/Results Reporting package."
GOTO Q
+4 ;
+5 ;Check/set package and default protocol values
+6 SET ORPKG=$ORDER(^DIC(9.4,"C","RA",0))
IF 'ORPKG
WRITE !,$CHAR(7),"There is no entry for the Radiology/Nuclear Medicine package in your Package",!,"file (#9.4), unable to proceed. Contact your site manager."
GOTO Q
+7 SET ORDEF=$ORDER(^ORD(101,"B","RA OERR DEFAULT PROTOCOL",0))
IF 'ORDEF
WRITE !,$CHAR(7),"You do not have a default Radiology/Nuclear Medicine protocol in your",!,"Protocol file (#101), unable to continue. Contact your site manager."
GOTO Q
+8 SET (I,RACNT,RAF1,X)=0
KILL ^TMP($JOB,"RAEX")
WRITE !!?10,"Create an OE/RR Protocol from a Radiology/Nuclear Medicine",!?10,"Common Procedure",!
+9 FOR
SET I=$ORDER(^RAMIS(71.3,I))
if I'>0
QUIT
IF $DATA(^(I,0))
SET Y=I_"^"_^(0)
IF $PIECE(Y,"^",6)']""
IF $DATA(^RAMIS(71,+$PIECE(Y,"^",2),0))
SET RACNT=RACNT+1
SET ^TMP($JOB,"RAEX",RACNT)=Y
WRITE !,RACNT,?6,$PIECE(^RAMIS(71,+$PIECE(Y,"^",2),0),"^")
if '(RACNT#15)
DO ASK^RAUTL4
if X="^"!(X>0)
QUIT
+10 if X="^"
GOTO Q
IF 'RACNT
WRITE !,$CHAR(7),"The Common Procedures file does not have any entries from which to choose."
GOTO Q
+11 IF RACNT=1
SET RADUP(1)=""
WRITE !!,"There is only one Common Procedure to choose from."
SET DIR(0)="YA"
SET DIR("A")="Okay to continue? "
DO ^DIR
if Y'=1
GOTO Q
GOTO CP1
+12 IF X'>0
IF RACNT#15
DO ASK^RAUTL4
if '$DATA(RADUP)
GOTO Q
CP1 SET RAI=0
FOR
SET RAI=$ORDER(RADUP(RAI))
if RAI'>0
QUIT
SET Y=^TMP($JOB,"RAEX",RAI)
SET DA=+Y
SET Y=$PIECE(Y,"^",2,99)
WRITE !!,"Processing the ",$PIECE(^RAMIS(71,+Y,0),"^")," procedure.",!
DO CP2
Q KILL %1,D,D0,DA,DIC,DIE,DIR,DR,I,J,K,ORDEF,OREA,ORFL,ORPKG,ORTXT,RACNT,RADUP,RAERR,RAF1,RAI,RAILOC,RAPAR,RASEL,X,Y,Z,^TMP($JOB,"RAEX")
+1 KILL DI,DIG,DIH,DIU,DIV,DQ
+2 QUIT
CP2 SET RAERR=0
SET RAILOC=$PIECE(Y,"^",8)
IF 'RAILOC
SET RAILOC=$ORDER(^RA(79.1,0))
IF RAILOC
IF $ORDER(^(RAILOC))
KILL RAILOC
WRITE !,$CHAR(7),"You must enter an 'Imaging Location' before this procedure can be processed",!,"as an orderable item in OE/RR."
SET RAERR=1
+1 SET ORTXT=$PIECE(Y,"^",13)
IF ORTXT']""
WRITE !,$CHAR(7),"You must enter a 'Name of Ordeable Item' before this procedure can be processed",!,"as an orderable item in OE/RR."
SET RAERR=1
+2 IF RAERR
KILL RAILOC,ORTXT
QUIT
+3 SET ORFL=+Y_";RAMIS(71,"
SET OREA="S RADR1=1,RAPRI="_+Y_",RAILOC="_RAILOC_$SELECT($PIECE(Y,"^",11):",RARU="_$PIECE(Y,"^",11),1:"")
+4 SET Z="^^^^^RACAT^RAREQDT^^RAMT^RAIP"
FOR X=6,9,10
SET OREA=OREA_$SELECT($PIECE(Y,"^",X)]"":","_$PIECE(Z,"^",X)_"="_""""_$PIECE(Y,"^",X)_"""",1:"")
+5 IF $ORDER(^RAMIS(71.3,DA,"M",0))
SET K=0
FOR J=1:1
SET K=$ORDER(^RAMIS(71.3,DA,"M",K))
if K'>0
QUIT
SET X=$GET(^(K,0))
IF $DATA(^RAMIS(71.2,+X,0))
SET X=$PIECE(^(0),"^")
IF X]""
SET OREA=OREA_",RAMOD("_J_")="_""""_X_""""
+6 SET OREA=OREA_" D ^RAORR"
+7 ; define ORDA if filelink record exists in file #101
IF $GET(^DIC(9.4,ORPKG,0))]""
NEW RA1
SET RA1=$PIECE(^(0),"^",2)_+ORFL_" "_ORTXT
if $ORDER(^ORD(101,"B",RA1,0))
SET ORDA=$ORDER(^(0))
+8 ;D EN3^ORUPREF2 W:$D(Y) !,*7,"Unable to create an orderable item in OE/RR."
+9 ;dead code OE 2.5 from CP down to here
QUIT
+10 ;
DISP ;Display request with defaults
+1 if '$DATA(RAMOD)#2
SET RAMOD=""
+2 SET J=""
SET $PIECE(J,"-",80)=""
WRITE !!,J
+3 IF $DATA(RAMOD)>9
SET RAMOD=""
FOR I=1:1
if '$DATA(RAMOD(I))
QUIT
SET RAMOD=RAMOD_$SELECT(I'=1:", ",1:"")_RAMOD(I)
SET RAI=0
SET RAI=+$ORDER(^RAMIS(71.2,"B",RAMOD(I),RAI))
IF $PIECE($GET(^RAMIS(71.2,RAI,0)),U,2)="p"
SET RAACI="p"
+4 WRITE !?10,"Patient: ",RANME
IF RASEX'="M"
if '$DATA(RAPREG)
SET RAPREG=""
WRITE " Pregnant at time of order entry: ",$SELECT(RAPREG="y":"YES",RAPREG="u":"UNKNOWN",RAPREG="n":"NO",1:"")
+5 WRITE !?8,"Procedure: ",$SELECT($DATA(^RAMIS(71,RAPRI,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),!?2,"Proc. Modifiers: ",RAMOD
+6 if '$DATA(RAMT)
SET RAMT=$SELECT($GET(RAACI)="p":"p",$EXTRACT(RACAT)="I":"w",1:"a")
SET RAMT=RAMT_"^"_$PIECE($PIECE(^DD(75.1,19,0),RAMT_":",2),";")
WRITE !?9,"Category: ",RACAT,?49,"Mode of Transport: ",$PIECE(RAMT,"^",2)
+7 if '$DATA(RAIP)
SET RAIP="n"
WRITE !," Desired Date: ",RAWHEN,?46,"Isolation Procedures: ",$SELECT(RAIP="y":"YES",1:"NO")
+8 if '$DATA(RARU)
SET RARU=9
WRITE !," Request Urgency: ",$SELECT($DATA(RARU):$PIECE($PIECE(^DD(75.1,6,0),RARU_":",2),";"),1:"ROUTINE"),?46,"Scheduled for Pre-op: ",$SELECT($DATA(RAPREOP1):"YES",1:"NO")
+9 IF $DATA(RAILOC)
WRITE !,"Submit Request To: ",$SELECT($DATA(^RA(79.1,+RAILOC,0)):$SELECT($DATA(^SC(+$PIECE(^(0),"^"),0)):$PIECE(^(0),"^"),1:"Unknown"),1:"Unknown")
+10 WRITE !," Request Location: ",$SELECT($PIECE($GET(^SC(+RALIFN,0)),U)]"":$EXTRACT($PIECE($GET(^SC(+RALIFN,0)),U),1,26),1:"Unkown")
IF $$ORVR^RAORDU()'<3
WRITE ?46,"Nature of order: SVC CORRECTION"
+11 ;display the reason for study
DO DISREA(RAREAST)
+12 ;*Billing Aware Project:
+13 ; Display New ICD-9 Dx and their related SC/EI/MST/HNC responses.
+14 ;
BADISP if $PIECE($GET(RABWDX(1)),U,1)>0
DO BADISP^RABWORD1(.RABWDX)
+1 ;*
+2 KILL ^UTILITY($JOB,"W"),^(1)
SET DIWF="WN"
SET DIWL=1
SET DIWR=79
SET I=0
WRITE !!,"Clinical History:",!
FOR
SET I=$ORDER(^TMP($JOB,"RAWP",I))
if I'>0
QUIT
SET X=^(I,0)
DO ^DIWP
+3 DO ^DIWW
WRITE !,J
+4 SET DIR(0)="Y"
SET DIR("A")="Do you want to change any of the above"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET RAOUT=1
if $DATA(RAOUT)
QUIT
if Y=0
SET RADR1=1
if Y'=0
SET RADR2=1
SET RASTOP=0
+5 ; RASTOP is used to track whether the procedure messages have printed.
+6 ; If you answer 'yes' to "Do you want to edit this request", you
+7 ; will see the procedure messages again (if they exist and if you
+8 ; viewed them before. Value altered in ADDORD+1^RAORD1 & EN2+1^RAPRI)
+9 QUIT
+10 ;
DISREA(X) ;this function formats and displays the reason for study for this
+1 ;order.
+2 ;input: X - the reason for study (a string between three & sixty four
+3 ;characters in length)
+4 NEW %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,LINES,Z
+5 ;accumulate & format data; column width of sixty (DIWF's C60) characters
+6 SET DIWF="C60"
SET DIWL=1
DO ^DIWP
+7 WRITE !," Reason for Study: "
SET I=0
SET LINES=^UTILITY($JOB,"W",DIWL)
+8 ;LINES: # of formatted lines in ^UTILITY
+9 FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if 'I
QUIT
WRITE ?19,$GET(^(I,0))
if I'=LINES
WRITE !
+10 KILL ^UTILITY($JOB,"W",DIWL)
+11 QUIT
+12 ;
