source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORDU1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1RAORDU1 ;HISC/CAH - AISC/SAW-Utility for Rad/NM Orders Module ;10/27/97 12:56
2 ;;5.0;Radiology/Nuclear Medicine;**10,41,75**;Mar 16, 1998;Build 4
3CP ;Create protocols for Rad/Nuc Med in OE/RR Protocol file (#100)
4 ;based upon entries in the Rad/Nuc Med Common Procedure file (#71.3)
5 ;
6 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
7 ;
8 ;Check/set package and default protocol values
9 S ORPKG=$O(^DIC(9.4,"C","RA",0)) I 'ORPKG W !,*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
10 S ORDEF=$O(^ORD(101,"B","RA OERR DEFAULT PROTOCOL",0)) I 'ORDEF W !,*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
11 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",!
12 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)
13 G Q:X="^" I 'RACNT W !,*7,"The Common Procedures file does not have any entries from which to choose." G Q
14 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
15 I X'>0,RACNT#15 D ASK^RAUTL4 G Q:'$D(RADUP)
16CP1 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
17Q 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")
18 K DI,DIG,DIH,DIU,DIV,DQ
19 Q
20CP2 S RAERR=0 S RAILOC=$P(Y,"^",8) I 'RAILOC S RAILOC=$O(^RA(79.1,0)) I RAILOC,$O(^(RAILOC)) K RAILOC W !,*7,"You must enter an 'Imaging Location' before this procedure can be processed",!,"as an orderable item in OE/RR." S RAERR=1
21 S ORTXT=$P(Y,"^",13) I ORTXT']"" W !,*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
22 I RAERR K RAILOC,ORTXT Q
23 S ORFL=+Y_";RAMIS(71,",OREA="S RADR1=1,RAPRI="_+Y_",RAILOC="_RAILOC_$S($P(Y,"^",11):",RARU="_$P(Y,"^",11),1:"")
24 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:"")
25 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_""""
26 S OREA=OREA_" D ^RAORR"
27 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
28 ;D EN3^ORUPREF2 W:$D(Y) !,*7,"Unable to create an orderable item in OE/RR."
29 Q ;dead code OE 2.5 from CP down to here
30 ;
31DISP ;Display request with defaults
32 S:'$D(RAMOD)#2 RAMOD=""
33 S J="",$P(J,"-",80)="" W !!,J
34 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"
35 W !?10,"Patient: ",RANME I RASEX'="M" S:'$D(RAPREG) RAPREG="" W ?58,"Pregnant: ",$S(RAPREG="y":"YES",RAPREG="u":"UNKNOWN",RAPREG="n":"NO",1:"")
36 W !?8,"Procedure: ",$S($D(^RAMIS(71,RAPRI,0)):$P(^(0),"^"),1:"UNKNOWN"),!?2,"Proc. Modifiers: ",RAMOD
37 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)
38 S:'$D(RAIP) RAIP="n" W !," Desired Date: ",RAWHEN,?46,"Isolation Procedures: ",$S(RAIP="y":"YES",1:"NO")
39 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")
40 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")
41 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"
42 D DISREA(RAREAST) ;display the reason for study
43 ;*Billing Aware Project:
44 ; Display New ICD-9 Dx and their related SC/EI/MST/HNC responses.
45 ;
46BADISP D:$P($G(RABWDX(1)),U,1)>0 BADISP^RABWORD1(.RABWDX)
47 ;*
48 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
49 D ^DIWW W !,J
50 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
51 ; RASTOP is used to track whether the procedure messages have printed.
52 ; If you answer 'yes' to "Do you want to edit this request", you
53 ; will see the procedure messages again (if they exist and if you
54 ; viewed them before. Value altered in ADDORD+1^RAORD1 & EN2+1^RAPRI)
55 Q
56 ;
57DISREA(X) ;this function formats and displays the reason for study for this
58 ;order.
59 ;input: X - the reason for study (a string between three & sixty four
60 ;characters in length)
61 N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,LINES,Z
62 ;accumulate & format data; column width of sixty (DIWF's C60) characters
63 S DIWF="C60",DIWL=1 D ^DIWP
64 W !," Reason for Study: " S I=0,LINES=^UTILITY($J,"W",DIWL)
65 ;LINES: # of formatted lines in ^UTILITY
66 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:'I W ?19,$G(^(I,0)) W:I'=LINES !
67 K ^UTILITY($J,"W",DIWL)
68 Q
69 ;
Note: See TracBrowser for help on using the repository browser.