Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDIR8A

MAGDIR8A.m

Go to the documentation of this file.
  1. MAGDIR8A ;WOIFO/PMK,JSJ - Read a DICOM image file ; Jul 14, 2021@09:50:40
  1. ;;3.0;IMAGING;**11,51,49,123,138,231,307**;Mar 19, 2002;Build 28
  1. ;; Per VHA Directive 2004-038, this routine should not be modified.
  1. ;; +---------------------------------------------------------------+
  1. ;; | Property of the US Government. |
  1. ;; | No permission to copy or redistribute this software is given. |
  1. ;; | Use of unreleased versions of this software requires the user |
  1. ;; | to execute a written test agreement with the VistA Imaging |
  1. ;; | Development Office of the Department of Veterans Affairs, |
  1. ;; | telephone (301) 734-0100. |
  1. ;; | The Food and Drug Administration classifies this software as |
  1. ;; | a medical device. As such, it may not be changed in any way. |
  1. ;; | Modifications to this software may result in an adulterated |
  1. ;; | medical device under 21CFR820, the use of which is considered |
  1. ;; | to be a violation of US Federal Statutes. |
  1. ;; +---------------------------------------------------------------+
  1. ;;
  1. ;
  1. ; M2MB server
  1. ;
  1. ; Reference to FIND1^DIC in ICR #2051
  1. ; Reference to GET1^DIQ in ICR #2056
  1. ; Reference to ACCFIND^RAAPI in ICR #5020
  1. ; Reference to ^RA(70 in ICR #1172
  1. ; Reference to ^RA(72 in ICR #1174
  1. ;
  1. ; Lookup the patient/study in the imaging service's database
  1. ; Different entry points are invoked from LOOKUP^MAGDIR81
  1. ;
  1. RADLKUP ; Radiology patient/study lookup -- called by ^MAGDIR81
  1. ; (also invoked by ^MAGDEXC4, ^MAGDFND4 and ^MAGDIW1)
  1. ;
  1. ; returns RADATA array DFN, DATETIME, and PROCDESC
  1. ;
  1. N CPTCODE ;-- CPT code for the procedure
  1. N CPTNAME ;-- CPT name for the procedure
  1. N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
  1. N PROCIEN ;-- radiology procedure ien in ^RAMIS(71)
  1. N RAIX ;----- cross reference subscript for case number lookup
  1. N RADPT1 ;--- first level subscript in ^RADPT
  1. N RADPT2 ;--- second level subscript in ^RADPT (after "DT")
  1. N RADPT3 ;--- third level subscript in ^RADPT (after "P")
  1. N I,LIST,VARIABLE,X,Z
  1. ;
  1. ; find the patient/study in ^RARPT using the Radiology Case Number
  1. K RADATA ; kill returned array of Radiology Package data
  1. D RADLKUP1
  1. S LIST="RADPT1^RADPT2^RADPT3^PROCIEN^CPTCODE^CPTNAME^Z^EXAMSTS"
  1. F I=1:1:$L(LIST,"^") D
  1. . S VARIABLE=$P(LIST,"^",I)
  1. . S RADATA(VARIABLE)=$G(@VARIABLE)
  1. . Q
  1. Q
  1. ;
  1. RADLKUP1 ; not an entry point
  1. N LIST
  1. Q:CASENUMB="" ;LB 12/16/98
  1. S X=$$ACCFIND^RAAPI(CASENUMB,.LIST)
  1. ;
  1. I X'=1 D ; P231 PMK 11/12/2019
  1. . ; if accession number prefix exists, strip it off and try lookup again
  1. . N ANPREFIX,STRIPPEDCASENUMB
  1. . S ANPREFIX=$$ANPREFIX^MAGDSTAB Q:ANPREFIX=""
  1. . S STRIPPEDCASENUMB=$P(CASENUMB,ANPREFIX,2,999) Q:STRIPPEDCASENUMB=""
  1. . S X=$$ACCFIND^RAAPI(STRIPPEDCASENUMB,.LIST)
  1. . Q
  1. ;
  1. Q:X'=1 S X=LIST(1) ; two conditions, no accession number & duplicate
  1. S RADPT1=$P(X,"^",1),RADPT2=$P(X,"^",2),RADPT3=$P(X,"^",3)
  1. I '$D(^RADPT(RADPT1,0)) Q ; no patient demographics file pointer
  1. ; get patient demographics file pointer
  1. S X=^RADPT(RADPT1,0),DFN=$P(X,"^")
  1. I '$D(^RADPT(RADPT1,"DT",RADPT2,0)) Q ; no datetime level
  1. ; get date and time of examination
  1. S DATETIME=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1)
  1. ; get case info
  1. S X=$G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
  1. S PROCIEN=$P(X,"^",2),EXAMSTS=$P(X,"^",3)
  1. I EXAMSTS S EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
  1. S (PROCDESC,CPTNAME,CPTCODE)=""
  1. I 'PROCIEN Q ; need PROCIEN to do lookup in ^RAMIS
  1. S Z=$G(^RAMIS(71,PROCIEN,0))
  1. S PROCDESC=$P(Z,"^"),CPTCODE=$P(Z,"^",9)
  1. S CPTNAME=PROCDESC ; approximate value since ^ICPT is not translated
  1. Q
  1. ;
  1. CONLKUP ; CPRS Consult/Procedure patient/study lookup -- called by ^MAGDIR81
  1. N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
  1. N CONPROC,Z
  1. S GMRCIEN=$$GMRCIEN^MAGDFCNV(ACNUMB) I 'GMRCIEN Q ; check for legal consult accession number
  1. S DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
  1. I DFN="" Q ; no patient demographics file pointer
  1. S EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8) ; check for cancelled exam
  1. I "^CANCELLED^DISCONTINUED^DISCONTINUED/EDIT^EXPIRED^"[("^"_EXAMSTS_"^") D Q
  1. . S RADATA("EXAMSTS")="CANCELLED" ; value needed in PIDCHECK
  1. . Q
  1. S PROCDESC=$$GET1^DIQ(123,GMRCIEN,1)
  1. S Z=$$GET1^DIQ(123,GMRCIEN,13,"I") ; request type
  1. S CONPROC=$S(Z="C":"CONSULT",Z="P":"PROCEDURE",1:"UNKNOWN")
  1. Q
  1. ;
  1. LABLKUP ; Lab patient/study lookup -- called by ^MAGDIR81
  1. N ABBR,CASE,FMYEAR,LRAA,IENS,YEAR ;P307
  1. S ABBR=$P(ACNUMB," ",1),YEAR=$P(ACNUMB," ",2),CASE=$P(ACNUMB," ",3) ;P307
  1. S LRAA=$$FIND1^DIC(68,"","BX",ABBR,"","","ERR") ; get lab area index ;P307
  1. S LRSS=$$GET1^DIQ(68,LRAA,.02,"I") ;P307
  1. S PROCDESC=$$GET1^DIQ(68,LRAA,.01)
  1. S FMYEAR="3"_YEAR_"0000"
  1. S IENS=CASE_","_FMYEAR_","_LRAA
  1. ; lookup in ACCESSION file (#68)
  1. S LRDFN=$$GET1^DIQ(68.02,IENS,.01)
  1. I LRDFN="" Q ; no AP study
  1. I $$GET1^DIQ(68.02,IENS,1)'="PATIENT" Q ; patient not in PATIENT file (#2)
  1. I $$GET1^DIQ(68.02,IENS,15)'=ACNUMB Q ; not right specimen
  1. S LRI=$$GET1^DIQ(68.02,IENS,13.5,"I")
  1. ; lookup in LAB DATA file (#63)
  1. I $$GET1^DIQ(63,LRDFN,.02)'="PATIENT" Q ; patient not in PATIENT file (#2)
  1. S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
  1. Q
  1. ;
  1. PIDCHECK() ; compare VistA patient ID with DICOM patient ID
  1. N CHECK ;---- patient demographic comparison check value
  1. N FIRSTVAH ;- patient first name from VADM(1)
  1. N IDDCM ;---- patient id, w/o punctuation, from image header
  1. N IDVAH ;---- patient id from VADM(2)
  1. N LASTVAH ;-- patient last name from VADM(1)
  1. N MIVAH ;---- patient middle initial from VADM(1)
  1. N DIQUIET,I,VA,VAERR,X,Y
  1. ;
  1. S X=PNAMEDCM X ^%ZOSF("UPPERCASE") S PNAMEDCM=Y
  1. ; parse the DICOM patient name (2 formats)
  1. I PNAMEDCM["^" D ; DICOM format patient name
  1. . S LASTDCM=$P(PNAMEDCM,"^"),FIRSTDCM=$P(PNAMEDCM,"^",2)
  1. . S MIDCM=$P(PNAMEDCM,"^",3)
  1. . Q
  1. E I PNAMEDCM["," D ; ACR-NEMA format patient name
  1. . F Q:'$F(PNAMEDCM,", ") D ; remove blanks after last name comma
  1. . . S PNAMEDCM=$P(PNAMEDCM,", ")_","_$P(PNAMEDCM,", ",2,999)
  1. . . Q
  1. . S LASTDCM=$P(PNAMEDCM,","),FIRSTDCM=$P(PNAMEDCM,",",2)
  1. . S MIDCM=$S(PNAMEDCM[",":$P(FIRSTDCM,",",2),1:$P(FIRSTDCM," ",2,999))
  1. . Q
  1. E D ; patient name in "last first mi" order with space delimiters
  1. . S LASTDCM=$P(PNAMEDCM," "),FIRSTDCM=$P(PNAMEDCM," ",2)
  1. . S MIDCM=$P(PNAMEDCM," ",3)
  1. . Q
  1. S FIRSTDCM=$S(FIRSTDCM[",":$P(FIRSTDCM,","),1:$P(FIRSTDCM," "))
  1. ; only check the first part of the name
  1. ; remove dashes and atypical punctuation from the DICOM PID
  1. S IDDCM="" F I=1:1:$L(PID) I $E(PID,I)?1AN S IDDCM=IDDCM_$E(PID,I)
  1. ;
  1. I CASENUMB="" Q "-1,NO CASE #"
  1. I '$G(DFN) Q "-2,BAD CASE #"
  1. I $G(RADATA("EXAMSTS"))="CANCELLED" Q "-3,CANCELLED"
  1. ;
  1. ; lookup patient in VistA database
  1. S DIQUIET=1 D DEM^MAGSPID($G(INSTLOC)) ; P123
  1. S PNAMEVAH=VADM(1)
  1. S LASTVAH=$P(PNAMEVAH,","),FIRSTVAH=$P(PNAMEVAH,",",2)
  1. S MIVAH=$TR($P(FIRSTVAH," ",2,999),"."),FIRSTVAH=$P(FIRSTVAH," ")
  1. I $$ISIHS^MAGSPID() S (IDVAH,DCMPID)=VA("PID") ; P123 proper VA/IHS PID
  1. E S IDVAH=$P(VADM(2),"^"),DCMPID=$P(VADM(2),"^",2)
  1. ;
  1. ; compare the values - allow a single transposition in the patient name,
  1. ; but require exact patient id values (i.e., social security numbers)
  1. S CHECK=(5*$$COMPARE(LASTDCM,LASTVAH))
  1. S CHECK=CHECK+(5*$$COMPARE($E(FIRSTDCM,1,6),$E(FIRSTVAH,1,6)))
  1. S CHECK=CHECK+(1*$$COMPARE(MIDCM,MIVAH))
  1. S CHECK=CHECK+(5*(IDDCM=IDVAH)) ; patient id requires an exact match
  1. I CHECK<14.5 Q "-4,PID ERROR" ; require an "almost exact" match
  1. Q 0 ; correct patient
  1. ;
  1. COMPARE(A,B) ; pattern match checker
  1. Q:A=B 1 ; exact match
  1. Q:A="" 0 Q:B="" 0 ; don't count missing data
  1. ; calculate fractional value for pattern match
  1. N I,LENGTH,MATCH
  1. S MATCH=0,LENGTH=$S($L(B)>$L(A):$L(B),1:$L(A))
  1. F I=1:1:LENGTH D
  1. . I $E(A,I)=$E(B,I) S MATCH=MATCH+1
  1. . E I $E(A,I)=$E(B,I-1) S MATCH=MATCH+.25
  1. . E I $E(A,I)=$E(B,I+1) S MATCH=MATCH+.25
  1. . E I $E(A,I-1)=$E(B,I) S MATCH=MATCH+.25
  1. . E I $E(A,I+1)=$E(B,I) S MATCH=MATCH+.25
  1. . Q
  1. Q MATCH/LENGTH ; return fractional pattern match value