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 Sep 23, 2025@19:36:37 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
