source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPRI.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1RAPRI ;HISC/CAH,GJC AISC/DMK-Display Common Procedures ;3/12/98 11:26
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3DISP ;Display list of common procedures - called from RAORD1
4 W ! D EN1^RAUTL17 S RAIMGTYI=Y G:RAIMGTYI'>0 DISPQ
5DISP1 I '$O(^RAMIS(71.3,"AA",RAIMGTYI,0)) S RACNT=0 G DISPQ
6 D HOME^%ZIS W @IOF
7 S X="COMMON RADIOLOGY/NUCLEAR MEDICINE PROCEDURES ("_$P($G(^RA(79.2,RAIMGTYI,0)),U)_")" W !?80-$L(X)\2,X,!?80-$L(X)\2,$TR($J("",$L(X))," ","-")
8 S II=0 F I=1:1:40 S RAPRC(I)=""
9 D TOTAL
10 F I=1:1:RASEQ W:RAPRC(I)]"" !?1,I,") ",$P(RAPRC(I),"^") I RAPRC(I+RASEQ)]"" W ?44,(I+RASEQ),") ",$P(RAPRC(I+RASEQ),"^")
11DISPQ K I,II,RASEQ,DISYS,POP
12 Q
13LOOKUP ;Lookup procedure - called from RAORD1
14 ;If user enters the sequential number on the common procedure list,
15 ;the only screening done takes place when the procedure is stuffed
16 ;in the input template. If user enters the name or CPT of a procedure
17 ;at the prompt, additional screening takes place. Common procedures
18 ;are not division-specific, so there is no way of stopping adpac's
19 ;from using 'Broad' procedures on a common list.
20 I X?1.2N,+X=X,X'>RACNT S Y=$P($G(RAPRC(X)),"^",2) S:'$$BROAD() Y=-1 G Q
21 N DIC,Y W ! S DIC(0)="EQMZ",DIC="^RAMIS(71,"
22 S DIC("S")="N RAI,RA0 S RAI=$G(^(""I"")),RA0=$G(^(0)) I $S('RAI:1,DT'>RAI:1,1:0),$P(RA0,U,12)=RAIMGTYI,$S($P(RA0,U,6)=""P"":$O(^RAMIS(71,+Y,4,0)),1:1)"
23 S DIC("S")=DIC("S")_",$$BROAD^RAPRI()"
24 D ^DIC K DIC("S") S:X=""!(X="^") Y=-1
25Q S (RAPRI,X)=+Y,RAPRI("X")=$P($G(^RAMIS(71,RAPRI,0)),"^")
26 I X>0 D Q:RAPRI'>0 ;GJC@12/27/93 modified GJC@2-26-96
27 . I $O(^RAMIS(71,RAPRI,3,0))!($O(^RAMIS(71,RAPRI,"EDU",0))) D EN2
28 . S RAS3=RADFN
29 . D ORDPRC1^RAUTL2
30 . Q
31 Q:RAPRI>0 S RAREASK=1 W !!,*7,"Unable to process this request due to an invalid procedure.",! I $P(RARX,",",(RAJ+1))="" R X:3 Q
32 S DIR(0)="Y",DIR("A")="Continue processing remaining input" D ^DIR K DIR S:Y'=1 RAOUT=1 Q
33HELP ; Called from ADDORD1^RAORD1
34 I $E(RARX,1,2)="??" D
35 . ; display screened entries from Rad/Nuc Med Procedure file
36 . N D,DIC,DZ,RADIC S D="B"
37 . S RADIC("S")="N RA S RA(0)=$G(^(0)),RA(""I"")=$G(^RAMIS(71,+Y,""I""))"
38 . S RADIC("S1")=" I $P(RA(0),U,12)=RAIMGTYI,('RA(""I"")!(DT<RA(""I"")))"
39 . S DIC="^RAMIS(71,",DIC(0)="Q",DIC("S")=RADIC("S")_RADIC("S1"),DZ="??"
40 . S DIC("W")="W "" "",?54,$$PRCCPT^RADD1()" D DQ^DICQ
41 . Q
42 W !!?2,"To select a commonly ordered procedure, enter a number from the display above."
43 W !!?2,"To select procedures other than those listed above, enter the procedure name,",!?2,"synonym, or CPT number.",!!?2,"You may enter a single procedure or multiple procedures separated by commas."
44 W !?2,"To see a list of all selectable procedures, enter '??'.",!
45 S DIR(0)="E" D ^DIR K DIR
46 Q
47EN2 ;Rad/Nuc Med Procedure Message Display
48 ; Quit if you've seen these messages before. Value altered in the
49 ; following routines: ADDORD+1^RAORD1 & DISP+12^RAORDU1
50 ;ATTENTION: This code must be parallel to code in PROGMSG^RAUTL5
51 Q:+$G(RASTOP) S RASTOP=1
52 N RAXIT S RAXIT="" W:$Y @IOF
53 I $O(^RAMIS(71,RAPRI,3,0)) D
54 . N I,RAX,X S I=0
55 . W !!,*7,"NOTE: The following special requirements apply to this procedure: ",RAPRI("X"),!
56 . F S I=$O(^RAMIS(71,RAPRI,3,I)) Q:I'>0 D Q:RAXIT="^"
57 .. S RAX=+$G(^RAMIS(71,RAPRI,3,I,0))
58 .. I $D(^RAMIS(71.4,+RAX,0)) D
59 ... I $Y>(IOSL-6) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
60 ... S X=$G(^RAMIS(71.4,+RAX,0)) W !,X
61 ... Q
62 .. Q
63 . Q
64 I $O(^RAMIS(71,RAPRI,"EDU",0)),($$UP^XLFSTR($P($G(^RAMIS(71,RAPRI,0)),"^",17))="Y") D
65 . W:+$O(^RAMIS(71,+RAPRI,3,0))>0 !!
66 . N DIW,DIWF,DIWL,DIWR,RAX,X
67 . K ^UTILITY($J,"W") S DIWF="W",DIWL=1,DIWR=75,RAX=0
68 . F S RAX=$O(^RAMIS(71,RAPRI,"EDU",RAX)) Q:RAX'>0 D Q:RAXIT="^"
69 .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
70 .. S X=$G(^RAMIS(71,RAPRI,"EDU",RAX,0)) D ^DIWP
71 .. Q
72 . Q:RAXIT="^"
73 . I $Y>(IOSL-4) S RAXIT=$$EOS^RAPRI() Q:RAXIT="^" W @IOF
74 . Q:RAXIT="^" D ^DIWW
75 . Q
76 Q:RAXIT="^"
77 W ! I $G(DR)="[RA QUICK EXAM ORDER]"!(($Y+5)>IOSL) W !,"Press RETURN to continue" R RAJUNK:DTIME K RAJUNK
78 Q
79 ;
80TOTAL N I,J,K,L
81 S (I,K,L,RACNT)=0
82 F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I>40!('I) S RACNT=I F S K=$O(^(I,K)) Q:'K I $D(^RAMIS(71.3,K,0)) S RAPRC(I)=$E($P($G(^RAMIS(71,+^(0),0)),"^"),1,32)_"^"_$P(^RAMIS(71.3,K,0),"^")
83 S RASEQ=$S(RACNT<40:(RACNT\2),1:20)
84 I RACNT#2 S RASEQ=RASEQ+1
85 Q
86GET(DA) ;Get the IEN for the procedure. Used in input transform
87 ;file 75.1 (Rad/Nuc Med Orders), field 125 (Modifiers).CEW
88 Q +$P($G(^RAO(75.1,DA,0)),U,2)
89EOS() ; End of screen message, 'Press return to continue'
90 N X
91 I $D(RAPKG) D ; entered through Rad/Nuc Med
92 . R !!?5,"Press return to continue ",X:DTIME S:'$T X="^"
93 . Q
94 E D
95 . D READ^ORUTL S:'$T X="^"
96 . Q
97 Q $S($E(X)="^":"^",1:"") ; Return '^' to skip printing, "" to scroll on
98 ;
99BROAD() ; Checks if the 'Detailed Procedure Required' field on the Rad/Nuc Med
100 ; Division file is 'yes', and the procedure type is 'Broad'.
101 ; Variables: Y-the ien of the procedure in file 71
102 ; RALIFN-ien of patient location in file 44 (set in RAORD1)
103 ; Return: 0 if invalid procedure, 1 if valid procedure
104 Q $S($P($G(^RAMIS(71,Y,0)),"^",6)="B"&($P($G(^RA(79,+$$DIVSION^RAUTL6(DT,RALIFN),.1)),"^",7)="Y"):0,1:1)
Note: See TracBrowser for help on using the repository browser.