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