source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL17.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: 4.9 KB
Line 
1RAUTL17 ;HISC/DAD-RAD/NUC MED COMMON PROCEDURE FILE (#71.3) UTILITIES ;6/14/96 11:34
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3EN1 ; *** Get an imaging type
4 ; Input: None
5 ; Output: The variable 'Y' will be one of the following
6 ; -1 = No imaging type selected (up-arrow, time-out, etc.)
7 ; 0 = No active imaging types found
8 ; IEN = IMAGING TYPE file (#79.2) IEN
9 N DIC,RAI,RAIMGTYI,X
10 ; *** Get active imaging types (must have at least one imaging
11 ; location and at least one procedure to be active)
12 S (RAI,RAIMGTYI)=0
13 F S RAIMGTYI=$O(^RA(79.2,RAIMGTYI)) Q:RAIMGTYI'>0 D
14 . I $O(^RAMIS(71,"AIMG",RAIMGTYI,0)),$O(^RA(79.1,"BIMG",RAIMGTYI,0)) D
15 .. S RAIMGTYI(RAIMGTYI)=1
16 .. Q
17 . Q
18 S RAIMGTYI=+$O(RAIMGTYI(0))
19 ; *** No active imaging types
20 I RAIMGTYI'>0 D S Y=0 G EN1EXIT
21 . W !!?5,"No 'active' imaging types were found. For an imaging"
22 . W !?5,"type to be active it must be assigned to at least one"
23 . W !?5,"imaging location and at least one procedure."
24 . Q
25 ; *** Only one active imaging type
26 I $O(RAIMGTYI(RAIMGTYI))'>0 S Y=RAIMGTYI G EN1EXIT
27 ; *** display the imaging types available for selection
28 W !,"Select one of the following imaging types:"
29 F S RAI=$O(RAIMGTYI(RAI)) Q:RAI'>0 W !?3,$$GET1^DIQ(79.2,RAI_",",.01)
30 ; *** Prompt for active imaging type
31 K DIC S DIC="^RA(79.2,",DIC(0)="AEMQ",DIC("A")="Select IMAGING TYPE: "
32 S DIC("S")="I $G(RAIMGTYI(+Y))"
33 W ! D ^DIC S Y=+Y
34EN1EXIT Q
35 ;
36EN2(RAIMGTYI,RAPROCD0) ; *** Common procedure file error check
37 ; Input: IMAGING TYPE file (#79.2) IEN (RAIMGTYI)
38 ; PROCEDURE file (#71) IEN (RAPROCD0) (Optional)
39 ; Output: Number_of_Common_Proccedures ^ $S(Duplicate_Sequence#:1,1:0)
40 ;
41 N RA,RACNT,RAD0,RADUP,RASEQ
42 S (RASEQ,RACNT,RADUP)=0
43 F S RASEQ=$O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ)) Q:RASEQ'>0 D
44 . S RAD0=0
45 . F S RAD0=$O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)) Q:RAD0'>0 D
46 .. S RACNT=RACNT+1 I $G(RASEQ(RASEQ)) S RADUP=1
47 .. S RASEQ(RASEQ)=$S($G(RASEQ(RASEQ)):RASEQ(RASEQ)_U,1:"")_RAD0
48 .. Q
49 . Q
50 I $G(RAPROCD0),RADUP'>0 D
51 . S RAD0=0 K RASEQ
52 . F S RAD0=$O(^RAMIS(71.3,"B",RAPROCD0,RAD0)) Q:RAD0'>0 D
53 .. S RA=$G(^RAMIS(71.3,RAD0,0)),RASEQ=$P(RA,U,4)
54 .. I RASEQ S RASEQ(RASEQ)=""
55 .. Q
56 . S RASEQ=0
57 . F S RASEQ=$O(RASEQ(RASEQ)) Q:RASEQ'>0!RADUP D
58 .. I $O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,0)) S RADUP=1
59 .. Q
60 . Q
61 Q RACNT_U_RADUP
62 ;
63EN3(D0) ; *** imaging type of a procedure
64 ; Input: RAD/NUC MED PROCEDURE file (#71) IEN
65 ; Output: IMAGING TYPE file (#79.2) IEN
66 Q +$P($G(^RAMIS(71,+D0,0)),U,12)
67 ;
68EN5(RAD0,RAIMGTYI,RASEQ,SK) ; *** Update ^RAMIS(71.3,"AA", xref
69 ; Input: RAD0 = RAD/NUC MED COMMON PROCEDURE file (#71.3) IEN
70 ; RAPRC = PROCEDURE file (#71) IEN
71 ; RASEQ = Sequence number
72 ; SK = Set/Kill flag: $S(SK="S":Set_xref,SK="K":Kill_xref)
73 I (RASEQ'>0)!(RAIMGTYI'>0) Q
74 I SK="S" S ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)=""
75 I SK="K" K ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)
76 Q
77 ;
78EN6(RAIMGTYI,RAPROCD0) ; *** Common procedure file error messages
79 ;Invoked when .01 field of file 71.3 is edited, allowing the user
80 ;to change the procedure that the .01 field points to
81 ; Input: IMAGING TYPE file (#79.2) IEN (RAIMGTYI)
82 ; PROCEDURE file (#71) IEN (RAPROCD0)
83 N RA,RACNT,RADUP
84 S RA=$$EN2(RAIMGTYI,RAPROCD0),RACNT=$P(RA,U),RADUP=$P(RA,U,2)
85 I RACNT>40!RADUP D K X
86 . N RATXT
87 . S RATXT(1)=""
88 . S RATXT(2)="Changing/ADDING this procedure would cause the following"
89 . S RATXT(3)="problem(s) in the Rad/Nuc Med Common Procedure file:"
90 . S RATXT(4)=""
91 . I RACNT>40 S RATXT(10)=" More than 40 common procedures with the same imaging type."
92 . I RADUP S RATXT(20)=" Two or more procedures with the same sequence number."
93 . S RATXT(30)=""
94 . S RATXT(31)="In order to change this procedure you must first"
95 . S RATXT(32)="inactivate it in the Rad/Nuc Med Common Procedure file."
96 . S RATXT(33)=""
97 . D EN^DDIOL(.RATXT)
98 . Q
99 Q
100DESC(RAD0,RAY) ; Detemine if a procedure qualifies as a descendent for this
101 ; parent procedure. Descendent must be either a detailed or series
102 ; type procedure, must be of same imaging type of the parent, and must
103 ; not be inactive. Called from ^DD(71.05,.01,0)
104 ; 'RAD0' ien of parent procedure in file 71
105 ; 'RAY' ien of pointed to procedure in file 71
106 ; Returns: 'RA' i.e, 0:invalid procedure, 1:valid procedure
107 ; RAPARNT: zero node of parent procedure
108 ; RAPARNT(12): i-type of parent procedure
109 ; RADESC : zero node of descendent procedure
110 ; RADESC("I"): inactivation date (if any) of descendent
111 ; RADESC(6) : procedure type of descendent
112 ; RADESC(12) : i-type of descendent procedure
113 Q:RAD0'>0!(RAY'>0) 0
114 Q:'$D(^RAMIS(71,RAD0,0))!('$D(^RAMIS(71,RAY,0))) 0
115 N RA,RAI,RADESC,RAPARNT S RA=0
116 S RAPARNT=$G(^RAMIS(71,RAD0,0)),RAPARNT(12)=+$P(RAPARNT,U,12)
117 S RADESC=$G(^RAMIS(71,RAY,0)),RADESC(6)=$P(RADESC,U,6)
118 S RADESC(12)=$P(RADESC,U,12)
119 S RADESC("I")=+$G(^RAMIS(71,RAY,"I"))
120 S RAI=$S(RADESC("I")=0:1,RADESC("I")>DT:1,1:0)
121 I RADESC(12)=RAPARNT(12),("^D^S^"[(U_RADESC(6)_U)),(RAI) S RA=1
122 Q RA
Note: See TracBrowser for help on using the repository browser.