source: FOIAVistA/trunk/r/MEDICINE-MC/MCUIMAG0.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1MCUIMAG0 ;HCIOFO/DAD-Create / Update Med Procedure with Image Pointer ;7/23/97 07:36
2 ;;2.3;Medicine;**7,12**;09/13/1996
3 Q
4 ;
5UPDATE(MCDATE,MCPROCD0,MCDFN,MCMAGPTR,MCD0,OK) ;
6 ; *** Main driver to update Medicine files from Imaging ***
7 ; MCDATE = Date/Time of procedure (FM internal format)
8 ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)
9 ; MCDFN = Pointer to the Patient file (#2)
10 ; MCMAGPTR() = An array whose subscripts are pointers to the Image
11 ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)=
12 ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)
13 ; MCD0 = Pointer to one of the Medicine Procedure data files
14 ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
15 N DD,DIC,DINUM,DO,MCPATFLD,X,Y
16 S MCDATE=+$G(MCDATE),MCPROCD0=+$G(MCPROCD0)
17 S MCDFN=+$G(MCDFN),MCD0=+$G(MCD0)
18 S MCFILE=+$P($P($G(^MCAR(697.2,MCPROCD0,0)),U,2),"(",2)
19 I MCFILE'>0 D Q
20 . S OK="0^Medicine Procedure file global location not found"
21 . Q
22 S MCPATFLD=$$PATFLD(MCFILE)
23 I MCPATFLD'>0 D Q
24 . S OK="0^Medical Patient field not found in Medicine Procedure file"
25 . Q
26 I MCD0>0 S OK=$$VALID(MCFILE,MCD0,MCDFN,MCPROCD0) Q:'OK
27 I MCD0'>0 D Q:'OK
28 . N MCIEN S MCIEN=0
29 . F S MCIEN=$O(^MCAR(MCFILE,"B",MCDATE,MCIEN)) Q:MCIEN'>0 D Q:MCD0
30 .. S OK=$$VALID(MCFILE,MCIEN,MCDFN,MCPROCD0)
31 .. I OK S MCD0=MCIEN
32 .. Q
33 . I MCD0'>0 D NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,.MCD0,.OK)
34 . Q
35 I $O(MCMAGPTR(0)) D FILE(MCD0,MCFILE,.MCMAGPTR,.OK) Q:'OK
36 S MCD0=MCD0_U_MCFILE
37 Q
38 ;
39NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,MCD0,OK) ;
40 ; *** Create new Medicine patient (if needed) and procedure records ***
41 ; MCDATE = Date/Time of procedure (FM internal format)
42 ; MCDFN = Pointer to the Patient file (#2)
43 ; MCFILE = File number of one of the Medicine Procedure data files
44 ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)
45 ; MCPATFLD = Field# in one of the Medicine Procedure data files
46 ; that points to the Medical Patient file (#690)
47 ; MCD0 = Pointer to one of the Medicine Procedure data files
48 ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
49 N DD,DIC,DINUM,DLAYGO,DO,MCARCODE,MCPRCFLD,MCRESULT,X,Y
50 S OK="1^New stub record created in Medicine Procedure data file"
51 ; *** Create a new record in the Medical Patient file (#690) ***
52 I '$D(^MCAR(690,MCDFN)) D Q:'OK
53 . K DD,DIC,DINUM,DO
54 . S (X,DINUM)=MCDFN,DLAYGO=690
55 . S DIC="^MCAR(690,",DIC(0)="L"
56 . D FILE^DICN
57 . I Y'>0 D
58 .. S OK="0^Cannot add patient to Medical Patient file"
59 .. Q
60 . Q
61 ; *** Create a stub record ***
62 K DD,DIC,DINUM,DO
63 S DIC=$$GET1^DID(MCFILE,"","","GLOBAL NAME")
64 S DIC(0)="L",DLAYGO=MCFILE
65 S DIC("DR")=MCPATFLD_"///`"_MCDFN
66 S MCARCODE=$P($G(^MCAR(697.2,MCPROCD0,0)),U,4) S:MCARCODE="" MCARCODE=U
67 S MCPRCFLD=$$PRCFLD(MCFILE)
68 I MCPRCFLD>0 D PRCSUBS Q:'OK
69 S X=MCDATE
70 D FILE^DICN S MCD0=+Y
71 I MCD0'>0 D
72 . S OK="0^Cannot create stub record in the Medicine Procedure data file"
73 . Q
74 Q
75 ;
76FILE(MCD0,MCFILE,MCMAGPTR,OK) ;
77 ; *** Store the Image file (#2005) pointers in Med Proc data files ***
78 ; MCD0 = Pointer to one of the Medicine Procedure data files
79 ; MCFILE = File number of one of the Medicine Procedure data files
80 ; MCMAGPTR() = An array whose subscripts are pointers to the Image
81 ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)=
82 ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)
83 ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
84 N DD,DIC,DINUM,DLAYGO,DO,MCD1,MCDIC,MCMAGD0,MCNODE,X,Y
85 S OK="1^The Medicine Procedure file has been updated"
86 I $O(MCMAGPTR(0))'>0 D Q
87 . S OK="0^No image number to file in Medicine Procedure file"
88 . Q
89 I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q
90 . S OK="0^Image field not found in the Medicine Procedure file"
91 . Q
92 S MCNODE=$P($$GET1^DID(MCFILE,2005,"","GLOBAL SUBSCRIPT LOCATION"),";")
93 I MCNODE="" D Q
94 . S OK="0^Medicine Procedure file global subscript location not found"
95 . Q
96 S MCDIC=$$GET1^DID(MCFILE,"","","GLOBAL NAME")_MCD0_","
97 S MCDIC=MCDIC_$S(MCNODE=+MCNODE:MCNODE,1:""""_MCNODE_"""")_","
98 S MCDIC("P")=$$GET1^DID(MCFILE,2005,"","SPECIFIER")
99 S MCMAGD0=0
100 F S MCMAGD0=$O(MCMAGPTR(MCMAGD0)) Q:MCMAGD0'>0 D Q:'OK
101 . S MCD1=+$O(^MCAR(MCFILE,MCD0,MCNODE,"B",MCMAGD0,0))
102 . I MCMAGD0'=$P($G(^MCAR(MCFILE,MCD0,MCNODE,MCD1,0)),U) S MCD1=0
103 . K DD,DIC,DINUM,DO
104 . S DIC=MCDIC,DIC(0)="L",DIC("P")=MCDIC("P")
105 . S DLAYGO=MCFILE,(D0,DA(1))=MCD0
106 . S X=MCMAGD0
107 . I MCD1'>0 D
108 .. D FILE^DICN S MCD1=+Y
109 .. I MCD1'>0 S OK="0^Cannot add image to Medicine Procedure file"
110 .. Q
111 . I OK S MCMAGPTR(MCMAGD0)=MCFILE_U_MCD0_U_MCD1
112 . Q
113 Q
114 ;
115VALID(FILE,IEN,DFN,PRC) ;
116 ; *** Make sure we have the right Medicine Procedure data file rec ***
117 ; FILE = File number of one of the Medicine Procedure data files
118 ; IEN = Pointer to one of the Medicine Procedure data files
119 ; DFN = Pointer to the Patient file (#2)
120 ; PRC = Pointer to the Procedure/Subspecialty file (#697.2)
121 ; Returns
122 ; '1^Message' = All is well, '0^Message' = Bad news
123 N FIELD,OK,TYPE
124 S OK="1^Record match found"
125 S FIELD=$$PATFLD(FILE)
126 I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,"I")'=DFN D
127 . S OK="0^Patient mismatch"
128 . Q
129 S FIELD=$$PRCFLD(FILE),TYPE=$$PRCTYPE(PRC)
130 ; *** Old Generalized Procedures module and other modules
131 I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFILE^DILFD(MCFILE,.06)'>0)) D
132 . S FIELD=$P(FIELD,U)
133 . Q
134 ; *** New Generalized Procedures module
135 I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D
136 . S FIELD=$S(TYPE="S":$P(FIELD,U),TYPE="P":$P(FIELD,U,2),1:0)
137 . Q
138 I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,"I")'=PRC D
139 . S OK="0^Procedure/Subspecialty mismatch"
140 . Q
141 Q OK
142 ;
143PRCFLD(FILE) ;
144 ; *** Procedure/Subspecialty pointer field ***
145 ; FILE = File number of one of the Medicine Procedure data files
146 ; Returns
147 ; The field# in one of the Medicine Procedure data files that points
148 ; to the Procedure/Subspecialty file (#690) (Zero [0] if not found)
149 N PRCFLD
150 S PRCFLD(694)=2,PRCFLD(694.8)=9,PRCFLD(699)=1,PRCFLD(699.5)=".05^.06"
151 Q $G(PRCFLD(FILE),0)
152 ;
153PATFLD(FILE) ;
154 ; *** Medical Patient pointer field ***
155 ; FILE = File number of one of the Medicine Procedure data files
156 ; Returns
157 ; The field# in one of the Medicine Procedure data files that points
158 ; to the Medical Patient file (#690) (Zero [0] if not found)
159 N MEDPAT
160 S MEDPAT(691)=1,MEDPAT(691.1)=1,MEDPAT(691.5)=1,MEDPAT(691.6)=1
161 S MEDPAT(691.7)=1,MEDPAT(691.8)=1,MEDPAT(694)=1,MEDPAT(694.5)=1
162 S MEDPAT(698)=1,MEDPAT(698.1)=1,MEDPAT(698.2)=1,MEDPAT(698.3)=1
163 S MEDPAT(699)=.02,MEDPAT(699.5)=.02,MEDPAT(700)=1,MEDPAT(701)=1
164 Q $G(MEDPAT(FILE),0)
165 ;
166PRCSUBS ; *** Procedure/Subspecialty DIC("DR") builder ***
167 ; *** Old Generalized Procedures module and other modules
168 N MCGENPRC,MCGENSUB,MCPRCTYP
169 I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)'>0)) D
170 . D PRCTEST(MCFILE,$P(MCPRCFLD,U),MCPROCD0,.OK)
171 . S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCPROCD0
172 . Q
173 ; *** New Generalized Procedures module
174 I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D
175 . S MCGENPRC=$$FINDPRC("GENERIC PROCEDURE","P")
176 . I MCGENPRC'>0 S OK="0^Entry 'GENERIC PROCEDURE' not found" Q
177 . S MCGENSUB=$$FINDPRC("GENERIC SUBSPECIALTY","S")
178 . I MCGENSUB'>0 S OK="0^Entry 'GENERIC SUBSPECIALTY' not found" Q
179 . S MCPRCTYP=$$PRCTYPE(MCPROCD0)
180 . I "^P^S^"'[(U_MCPRCTYP_U) S OK="0^Invalid Procedure/Subspecialty" Q
181 . D PRCTEST(MCFILE,$P(MCPRCFLD,U,$TR(MCPRCTYP,"PS","21")),MCPROCD0,.OK)
182 . I MCPRCTYP="P" D
183 .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCGENSUB
184 .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U,2)_"///`"_MCPROCD0
185 .. Q
186 . I MCPRCTYP="S" D
187 .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCPROCD0
188 .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U,2)_"///`"_MCGENPRC
189 .. Q
190 . Q
191 Q
192 ;
193PRCTEST(MCFILE,MCPRCFLD,MCPROCD0,OK) ;
194 ; *** Test for valid procedure
195 N MCRESULT
196 D CHK^DIE(MCFILE,MCPRCFLD,"","`"_MCPROCD0,.MCRESULT)
197 K ^TMP("DIERR",$J)
198 I MCRESULT=U S OK="0^Procedure is invalid"
199 Q
200 ;
201PRCTYPE(MCPROCD0) ;
202 ; *** Return the procedure type ***
203 Q $P($G(^MCAR(697.2,MCPROCD0,1)),U)
204 ;
205FINDPRC(MCENTRY,MCTYPE) ;
206 ; *** Find a procedure ***
207 ; MCENTRY = External name of the entry (697.2,.01)
208 ; MCTYPE = Internal 'Procedure/Subspecialty' type (697.2,1001)
209 ; Returns
210 ; The IEN of the procedure or zero if not found.
211 N MCFOUND,MCIEN
212 S (MCIEN,MCFOUND)=0
213 F S MCIEN=$O(^MCAR(697.2,"B",MCENTRY,MCIEN)) Q:MCIEN'>0 D Q:MCFOUND
214 . I $P($G(^MCAR(697.2,MCIEN,0)),U)=MCENTRY D
215 .. I $P($G(^MCAR(697.2,MCIEN,1)),U)=MCTYPE S MCFOUND=1
216 .. Q
217 . Q
218 Q +MCIEN
219 ;
220KILL(MCFILE,MCD0,MCD1,OK) ;
221 ; *** Remove an image from Image multiple ***
222 ; MCFILE = A Medicine Procedure data file number
223 ; MCD0 = Pointer to one of the Medicine Procedure data files
224 ; MCD1 = Pointer to one of the entries in the in the Image multiple
225 ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
226 N D0,D1,DA,DIK,MCNODE
227 S OK="1^Image pointer deleted from Medicine Procedure file"
228 I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q
229 . S OK="0^Image field not found in the Medicine Procedure file"
230 . Q
231 S DIK=$$GET1^DID(MCFILE,"","","GLOBAL NAME")
232 I DIK="" D Q
233 . S OK="0^Medicine Procedure file global name not found"
234 . Q
235 S MCNODE=$P($$GET1^DID(MCFILE,2005,"","GLOBAL SUBSCRIPT LOCATION"),";")
236 I MCNODE="" D Q
237 . S OK="0^Medicine Procedure file global subscript location not found"
238 . Q
239 S DIK=DIK_MCD0_","_$S(MCNODE=+MCNODE:MCNODE,1:""""_MCNODE_"""")_","
240 S (D0,DA(1))=MCD0,(D1,DA)=MCD1
241 D ^DIK
242 Q
Note: See TracBrowser for help on using the repository browser.