source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN2.m@ 619

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

initial load of WorldVistAEHR
File size: 8.3 KB
Line 
1RAMAIN2 ;HISC/GJC-Radiology Utility File Maintenance (Part Two) ;8/15/05 10:07am
2 ;;5.0;Radiology/Nuclear Medicine;**45,62,71,65**;Mar 16, 1998;Build 8
3 ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62
4 ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71
5 ;
6 ;Supported IA #10141 reference to MES^XPDUTL
7 ;Supported IA #10142 reference to EN^DDIOL
8 ;Supported IA #10103 reference to DT^XLFDT
9 ;
102 ;;Procedure Enter/Edit
11 ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. ***
12 ; RA PROCEDURE option
13 N RACTIVE,RAENALL,RAY,RAFILE,RASTAT,RAXIT
14 S (RAENALL,RANEW71,RAXIT)=0
15 N RADIO,RAPTY,RAASK,RAROUTE ;used by the edit template
16 F D Q:$G(RAXIT)
17 . K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB
18 . S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6
19 . W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO
20 . S:+Y<0 RAXIT=1 I $G(RAXIT) K D,X,Y Q
21 . S (DA,RADA)=+Y,RAY=Y,RAFILE=71
22 . ;RA*5*71 changed next line for Remedy Call 131482
23 . S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec.
24 . L +^RAMIS(RAFILE,RADA):5
25 . I '$T D Q
26 .. W !?5,"This record is currently being edited by another user."
27 .. W !?5,"Try again later!",$C(7) S RAXIT=1
28 .. Q
29 . S RAPNM=$P($G(Y(0)),U) ;proc. name for display purposes in template
30 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
31 . S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
32 . D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing
33 . ; CM definition before editing. RATRKCMB ids the before CM values
34 . S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE
35 . K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0))
36 . ;
37 . ;check for data consistency between the 'CONTRAST MEDIA USED' &
38 . ;'CONTRAST MEDIA' fields.
39 . D CMINTEG^RAMAINU1(RADA,RAPROC(0))
40 . ;
41 . D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
42 . I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA)
43 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
44 . S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
45 . ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line
46 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D
47 .. K %,C,D0,DE,DI,DIE,DQ,DR
48 .. W !?5,$C(7),"...no CPT code entered..."
49 .. W !?5,"...will change type to a 'broad' procedure.",!
50 .. S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE
51 .. Q
52 . ;08/12/2005 104630 - KAM added next 5 lines
53 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D
54 .. K %,C,D0,DE,DI,DIK,DQ,DR
55 .. W !?5,$C(7),"...no CPT code entered..."
56 .. W !?5,"...will delete the record at this time.",!
57 .. S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK
58 . ;if an active parent w/o descendants, inactivate the parent
59 . I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D
60 .. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR
61 .. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7)
62 .. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT())
63 .. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive
64 .. Q
65 . I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA)
66 . I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D
67 .. K %,D,D0,DA,DE,DIC,DIE,DQ,DR
68 .. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE
69 .. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7)
70 .. Q
71 . K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y
72 .;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41)
73 .;file exists unconditionally
74 .D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
75 .;
76 . L -^RAMIS(RAFILE,RADA) K RADA
77 .;unconditionally update the parent procedure if the descendent
78 .I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY)
79 .;has been edited
80 . Q
81 K DIR,RACMDIFF,RATRKCMA,RATRKCMB
82 S DIR(0)="YA",DIR("B")="NO"
83 S DIR("A")="Want to run a validity check on CPT and stop codes? "
84 S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures"
85 S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)."
86 S DIR("?",3)="Broad procedures with invalid codes are included for information"
87 S DIR("?",4)="only. Inactive procedures are not required to have valid codes."
88 S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;"
89 S DIR("?",6)="CPT's must be nationally active."
90 S DIR("?")="Please answer 'YES' or 'NO'."
91 W ! D ^DIR K DIR G:$D(DIRUT) EXIT
92 D:Y ^RAPERR
93EXIT K RADA,RANEW71,X,Y
94 Q
9513 ;;Rad/Nuc Med Common Procedure File Enter/Edit
96 ; RA COMMON PROCEDURE option
97 N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0
98 W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y
99131 S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3
100 S DIC("S")="N RA S RA=+$P(^(0),U) I RAIMGTYI=$P($G(^RAMIS(71,RA,0)),U,12)"
101 S DIC("W")="N RA4 S RA4=$P($G(^(0)),""^"",4) W:RA4]"""" "" (""_RA4_"")"" W:RA4']"""" "" (no sequence number)"""
102 W ! D ^DIC K DIC,DLAYGO,D,X
103 I Y<0 D Q13 G RESEQ
104 ; If a sequence # exists, the Common Proc. is active
105 S RADA=+Y,RAY=Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5
106 I '$T D G Q13
107 . W !?5,"This record is currently being edited by another user."
108 . W !?5,"Try again later!",$C(7)
109 . Q
110 S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^"
111 I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI)
112 S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE
113 S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0))
114 ; If the procedure is different than the one originally selected and
115 ; the CPRS Order Dialog file exists, send the Orderable Item Update
116 ; message to CPRS.
117 I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D
118 . S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
119 . S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^"
120 . Q
121 K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y
122 S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0)
123 ; If before & after statuses differ, and the CPRS Order Dialog file
124 ; exists, send the Orderable Item Update message to CPRS.
125 I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D
126 . D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
127 . Q
128 L -^RAMIS(RAFILE,RADA)
129 G 131
130Q13 K DDC,DDH,DISYS,I,POP,RA713
131 Q
132RESEQ ;Resequence the common procedure list
133 N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X
134 I $D(XPDNM) D ; if called during package install
135 . S TXT(1)=" "
136 . S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List."
137 . Q
138 E W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List"
139 S DIE="^RAMIS(71.3,",(I,CNT)=0
140 F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0 D
141 . S J=0
142 . F S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0 I $D(^RAMIS(71.3,J,0)) D
143 .. S DA=J,CNT=CNT+1 N I,J
144 .. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "."
145 .. Q
146 . Q
147 I $D(XPDNM) D ; if called during package install
148 . S TXT(2)=$G(TXT(2))_" Done!"
149 . D MES^XPDUTL(.TXT)
150 . Q
151 E W " Done!"
152 Q
153LOW(X) ; Find the lowest available sequence number for a procedure within
154 ; a specific Imaging Type. Seq. #'s range from 1 to 40. If the
155 ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the
156 ; code if EN3^RAUTL18 must also be altered.
157 ; If RAHIT is passed back as "", there is no available sequence number.
158 N RA,RAHIT S RAHIT=""
159 F RA=1:1:40 D Q:RAHIT
160 . Q:$D(^RAMIS(71.3,"AA",X,RA))
161 . S:RAHIT="" RAHIT=RA
162 . Q
163 Q RAHIT
164VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
165 ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult
166 ; Dose' & 'High Adult Dose' range. This subroutine will display the
167 ; Radiopharmaceutical in question along with the values in question if
168 ; inconsistencies are found.
169 ;
170 ; Input Variable: 'RADA' the ien of the Procedure
171 N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!")
172 F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D
173 . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
174 . Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input
175 . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D
176 .. N RARRY S RARRY(1)="For Radiopharmaceutical: "
177 .. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7)
178 .. S RARRY(2)="" D EN^DDIOL(.RARRY,"")
179 .. Q
180 . Q
181 Q
182DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
183 N RADA1 S RADA1=0
184 W !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
185 F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D
186 . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
187 . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC"","
188 . S DR=".01///@" D ^DIE
189 . Q
190 K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
191 Q
192 ;
Note: See TracBrowser for help on using the repository browser.