- 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 Feb 19, 2025@00:04:39 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 ;
