source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDIR8A.m@ 719

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1MAGDIR8A ;WOIFO/PMK - Read a DICOM image file ; 03/08/2005 07:02
2 ;;3.0;IMAGING;**11,51**;26-August-2005
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 ;
19 ; M2MB server
20 ;
21 ; Lookup the patient/study in the imaging service's database
22 ; Different entry points are invoked from LOOKUP^MAGDIR81
23 ;
24RADLKUP ; Radiology patient/study lookup -- called by ^MAGDIR81
25 ; (also invoked by ^MAGDEXC4, ^MAGDFND4 and ^MAGDIW1)
26 ;
27 ; returns RADATA array DFN, DATETIME, and PROCDESC
28 ;
29 N CPTCODE ;-- CPT code for the procedure
30 N CPTNAME ;-- CPT name for the procedure
31 N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
32 N PROCIEN ;-- radiology procedure ien in ^RAMIS(71)
33 N RAIX ;----- cross reference subscript for case number lookup
34 N RADPT1 ;--- first level subscript in ^RADPT
35 N RADPT2 ;--- second level subscript in ^RADPT (after "DT")
36 N RADPT3 ;--- third level subscript in ^RADPT (after "P")
37 N I,LIST,VARIABLE,X,Z
38 ;
39 ; find the patient/study in ^RARPT using the Radiology Case Number
40 K RADATA ; kill returned array of Radiology Package data
41 D RADLKUP1
42 S LIST="RADPT1^RADPT2^RADPT3^PROCIEN^CPTCODE^CPTNAME^Z^EXAMSTS"
43 F I=1:1:$L(LIST,"^") D
44 . S VARIABLE=$P(LIST,"^",I)
45 . S RADATA(VARIABLE)=$G(@VARIABLE)
46 . Q
47 Q
48 ;
49RADLKUP1 ; not an entry point
50 Q:CASENUMB="" ;LB 12/16/98
51 S RAIX=$S($D(^RADPT("C")):"C",1:"AE") ; for Radiology Patch RA*5*7
52 S RAIX=$S(CASENUMB["-":"ADC",1:RAIX) ; select the cross-reference
53 S RADPT1=$O(^RADPT(RAIX,CASENUMB,"")) I 'RADPT1 Q
54 S RADPT2=$O(^RADPT(RAIX,CASENUMB,RADPT1,"")) I 'RADPT2 Q
55 S RADPT3=$O(^RADPT(RAIX,CASENUMB,RADPT1,RADPT2,"")) I 'RADPT3 Q
56 S X=$O(^RADPT(RAIX,CASENUMB,RADPT1,RADPT2,RADPT3))
57 I '$D(^RADPT(RADPT1,0)) Q ; no patient demographics file pointer
58 ; get patient demographics file pointer
59 S X=^RADPT(RADPT1,0),DFN=$P(X,"^")
60 I '$D(^RADPT(RADPT1,"DT",RADPT2,0)) Q ; no datetime level
61 ; get date and time of examination
62 S DATETIME=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1)
63 ; get case info
64 S X=$G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
65 S PROCIEN=$P(X,"^",2),EXAMSTS=$P(X,"^",3)
66 I EXAMSTS S EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
67 S (PROCDESC,CPTNAME,CPTCODE)=""
68 I 'PROCIEN Q ; need PROCIEN to do lookup in ^RAMIS
69 S Z=$G(^RAMIS(71,PROCIEN,0))
70 S PROCDESC=$P(Z,"^"),CPTCODE=$P(Z,"^",9)
71 S CPTNAME=PROCDESC ; approximate value since ^ICPT is not translated
72 Q
73 ;
74CONLKUP ; CPRS Consult/Procedure patient/study lookup -- called by ^MAGDIR81
75 N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
76 N CONPROC,Z
77 I ACNUMB'?1"GMRC-".1N.N Q
78 S GMRCIEN=$P(ACNUMB,"-",2)
79 S DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
80 I DFN="" Q ; no patient demographics file pointer
81 S EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8) ; check for cancelled exam
82 I EXAMSTS="CANCELLED" S RADATA("EXAMSTS")=EXAMSTS Q
83 S PROCDESC=$$GET1^DIQ(123,GMRCIEN,1)
84 S Z=$$GET1^DIQ(123,GMRCIEN,13,"I") ; request type
85 S CONPROC=$S(Z="C":"CONSULT",Z="P":"PROCEDURE",1:"UNKNOWN")
86 Q
87 ;
88PIDCHECK() ; compare VistA patient ID with DICOM patient ID
89 N CHECK ;---- patient demographic comparison check value
90 N FIRSTVAH ;- patient first name from VADM(1)
91 N IDDCM ;---- patient id, w/o punctuation, from image header
92 N IDVAH ;---- patient id from VADM(2)
93 N LASTVAH ;-- patient last name from VADM(1)
94 N MIVAH ;---- patient middle initial from VADM(1)
95 N DIQUIET,I,VA,VAERR,X,Y
96 ;
97 S X=PNAMEDCM X ^%ZOSF("UPPERCASE") S PNAMEDCM=Y
98 ; parse the DICOM patient name (2 formats)
99 I PNAMEDCM["^" D ; DICOM format patient name
100 . S LASTDCM=$P(PNAMEDCM,"^"),FIRSTDCM=$P(PNAMEDCM,"^",2)
101 . S MIDCM=$P(PNAMEDCM,"^",3)
102 . Q
103 E I PNAMEDCM["," D ; ACR-NEMA format patient name
104 . F Q:'$F(PNAMEDCM,", ") D ; remove blanks after last name comma
105 . . S PNAMEDCM=$P(PNAMEDCM,", ")_","_$P(PNAMEDCM,", ",2,999)
106 . . Q
107 . S LASTDCM=$P(PNAMEDCM,","),FIRSTDCM=$P(PNAMEDCM,",",2)
108 . S MIDCM=$S(PNAMEDCM[",":$P(FIRSTDCM,",",2),1:$P(FIRSTDCM," ",2,999))
109 . Q
110 E D ; patient name in "last first mi" order with space delimiters
111 . S LASTDCM=$P(PNAMEDCM," "),FIRSTDCM=$P(PNAMEDCM," ",2)
112 . S MIDCM=$P(PNAMEDCM," ",3)
113 . Q
114 S FIRSTDCM=$S(FIRSTDCM[",":$P(FIRSTDCM,","),1:$P(FIRSTDCM," "))
115 ; only check the first part of the name
116 ; remove dashes and atypical punctuation from the DICOM PID
117 S IDDCM="" F I=1:1:$L(PID) I $E(PID,I)?1AN S IDDCM=IDDCM_$E(PID,I)
118 ;
119 I CASENUMB="" Q "-1,NO CASE #"
120 I '$G(DFN) Q "-2,BAD CASE #"
121 I $G(RADATA("EXAMSTS"))="CANCELLED" Q "-3,CANCELLED"
122 ;
123 ; lookup patient in VistA database
124 S DIQUIET=1 D DEM^VADPT
125 S PNAMEVAH=VADM(1)
126 S LASTVAH=$P(PNAMEVAH,","),FIRSTVAH=$P(PNAMEVAH,",",2)
127 S MIVAH=$TR($P(FIRSTVAH," ",2,999),"."),FIRSTVAH=$P(FIRSTVAH," ")
128 S IDVAH=$P(VADM(2),"^"),DCMPID=$P(VADM(2),"^",2)
129 ;
130 ; compare the values - allow a single transposition in the patient name,
131 ; but require exact patient id values (i.e., social security numbers)
132 S CHECK=(5*$$COMPARE(LASTDCM,LASTVAH))
133 S CHECK=CHECK+(5*$$COMPARE($E(FIRSTDCM,1,6),$E(FIRSTVAH,1,6)))
134 S CHECK=CHECK+(1*$$COMPARE(MIDCM,MIVAH))
135 S CHECK=CHECK+(5*(IDDCM=IDVAH)) ; patient id requires an exact match
136 I CHECK<14.5 Q "-4,PID ERROR" ; require an "almost exact" match
137 Q 0 ; correct patient
138 ;
139COMPARE(A,B) ; pattern match checker
140 Q:A=B 1 ; exact match
141 Q:A="" 0 Q:B="" 0 ; don't count missing data
142 ; calculate fractional value for pattern match
143 N I,LENGTH,MATCH
144 S MATCH=0,LENGTH=$S($L(B)>$L(A):$L(B),1:$L(A))
145 F I=1:1:LENGTH D
146 . I $E(A,I)=$E(B,I) S MATCH=MATCH+1
147 . E I $E(A,I)=$E(B,I-1) S MATCH=MATCH+.25
148 . E I $E(A,I)=$E(B,I+1) S MATCH=MATCH+.25
149 . E I $E(A,I-1)=$E(B,I) S MATCH=MATCH+.25
150 . E I $E(A,I+1)=$E(B,I) S MATCH=MATCH+.25
151 . Q
152 Q MATCH/LENGTH ; return fractional pattern match value
Note: See TracBrowser for help on using the repository browser.