MAGDSTA3 ;WOIFO/PMK - Study Tracker - Query/Retrieve user patient lookup ; Jun 01, 2020@12:10:06
;;3.0;IMAGING;**231**;Mar 19, 2002;Build 9;Feb 27, 2015
;; 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. |
;; +---------------------------------------------------------------+
;;
;
; API's and RPC'S for MAGDSTQA VistA PII lookup routine
;
; Supported IA #3646 reference $$EMPL^DGSEC4 function call
; Supported IA #767 Reading DG SECURITY LOG ^DGSL(38.1,DFN,0)
; Supported IA #2051 reference FIND^DIC subroutine call
; Supported IA #2054 reference CLEAN^DILF subroutine call
; Supported IA #10061 reference DEM^VADPT subroutine call
; Supported IA #10035 for Fileman reads of ^DPT
; Supported IA #10103 reference $$FMTE^XLFDT function call
; Supported IA #2602 Reading AUDIT file (#1.1) ^DIA(2,...)
; Supported IA #3065 reference $$HLNAME^XLFNAME function call
;
Q
;
PATLKUP(OUTPUT,INPUT) ; RPC = MAG DICOM PATIENT LOOKUP
; patient lookup
; modified from FINDP^SCUTBK11 for SC PATIENT LOOKUP rpc
;
; INPUT = value to lookup
; Lookup uses multiple index lookup of File #2
;
; OUTPUT = data
; OUTPUT(0) = number of records
; for i=1:number of records returned:
; DFN^patient name^DOB^PID^SEX^DOD^Sensitive
; 1 2 3 4 5 6 7
;
; (DOD = Date of Death)
;
K OUTPUT
D FIND^DIC(2,,".01;.03;.363;.09;.02;.351","PS",INPUT,300,"B^BS^BS5^SSN")
I $G(DIERR) D CLEAN^DILF Q
N SCOUNT S SCOUNT=+^TMP("DILIST",$J,0)
N SC F SC=1:1:SCOUNT D
. N NODE,DASHSSN,DFN,DOB,DOD,NAME,PID,PRILONGID,SENSITIVE,SEX,SSN
. S NODE=^TMP("DILIST",$J,SC,0)
. ; IEN^NAME^DOB^Primary Long ID^SSN^SEX^DOD
. ; 1 2 3 4 5 6 7
. S DFN=$P(NODE,"^",1),NAME=$P(NODE,"^",2)
. S DOB=$P(NODE,"^",3),DOD=$P(NODE,"^",4)
. S SSN=$P(NODE,"^",5),SEX=$P(NODE,"^",6)
. S DASHSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
. S PRILONGID=$P(NODE,"^",4)
. I $E(SSN,1,9)'?9N S (DASHSSN,PRILONGID)=SSN
. S PID=$S($L(PRILONGID)>5:PRILONGID,1:DASHSSN)
. D SCREEN(.SENSITIVE,DFN)
. D SAVEINFO^MAGDSTQA(.OUTPUT,DFN,NAME,DOB,PID,SEX,DOD,SENSITIVE)
. Q
S OUTPUT(0)=SCOUNT
K ^TMP("DILIST",$J)
Q
;
SCREEN(SCREEN,DFN) ; RPC = MAG DICOM GET PT SENSITIVITY
; Screening logic sensitive patients
; Input : DFN - Pointer to PATIENT file (#2)
; Output : 0 - Don't apply screen
; 1 - Apply screen - sensitive patient
; 2 - Apply screen - employee
; Notes : Screen applied if patient is sensitive or an employee
;
N DGTIME,DGT,DGA1,DG1,DGXFR0
; Sensitive - screen
I $P($G(^DGSL(38.1,DFN,0)),"^",2) S SCREEN=1 Q
; Employee - screen
I $$EMPL^DGSEC4(DFN) S SCREEN=2 Q
;Don't screen
S SCREEN=0
Q
;
;
;
HISTLKUP(PII,DFN) ; RPC = MAG DICOM PATIENT HISTORY
; look up historical patient changes in the audit archive
; INPUT = value to lookup
; Lookup uses multiple index lookup of File #2
;
; OUTPUT = data
; OUTPUT(0) = number of records
; for i=1:number of records returned:
; DFN^Patient Name^DOB^PID^SEX^DOD^Sensitive^Changed Field^Change date & time
; 1 2 3 4 5 6 7 8 9
;
; (DOD = Date of Death; DOD and Sensitive are null)
;
N DOB,NAME,SEX,SSN,VA,VADM,VAERR,X
N DATETIME ; date and time of the SSN change
N DIAIEN ; ien of the record in the AUDIT file (#1.1)
N FIELDNUMBER ; SSN is field .09 in the PATIENT file (#2)
N FIELD ; name of MUMPS FIELD holding the field data
N OLD,NEW ; previous and new field value
;
K PII S PII(0)=0
; save current PII
D DEM^VADPT
S NAME=VADM(1)
S SSN=$P(VADM(2),"^",2) ; with dashes
S DOB=$P(VADM(3),"^",1),DOB=$$FMTE^XLFDT(DOB,"5Z") ; MM/DD/YYYY format
I DOB?1"00/00/"4N S $P(NODE,"^",3)=$E(DOB,7,10) ; only year
S SEX=$P(VADM(5),"^",2)
D SAVEINFO^MAGDSTQA(.PII,DFN,NAME,DOB,SSN,SEX,,,,"(todayCC)") ; CC is not displayed
;
; save PII changes
S DIAIEN="" F S DIAIEN=$O(^DIA(2,"B",DFN,DIAIEN),-1) Q:DIAIEN="" D
. S X=$G(^DIA(2,DIAIEN,0))
. S CHANGEDATE=$P(X,"^",2),FIELDNUMBER=$P(X,"^",3)
. S NEW=$G(^DIA(2,DIAIEN,2)),OLD=$G(^DIA(2,DIAIEN,3))
. I FIELDNUMBER=.01 S CHANGED="NAME" ; name change record
. E I FIELDNUMBER=.02 S CHANGED="SEX" ; sex change record
. E I FIELDNUMBER=.03 S CHANGED="DOB" ; dob change record
. E I FIELDNUMBER=.09 S CHANGED="SSN" D ; SSN change record
. . S OLD=$E(OLD,1,3)_"-"_$E(OLD,4,5)_"-"_$E(OLD,6,10) ; remember "P"
. . S NEW=$E(NEW,1,3)_"-"_$E(NEW,4,5)_"-"_$E(NEW,6,10) ; remember "P"
. . Q
. E Q ; other field
. I OLD'=@CHANGED W !?10,"Old ",CHANGED," not matching: ",OLD," to ",@CHANGED
. S @CHANGED=NEW
. D SAVEINFO^MAGDSTQA(.PII,DFN,NAME,DOB,SSN,SEX,,,CHANGED,CHANGEDATE)
. Q
Q
;
DCMNAME(OUT,DFN) ; RPC = MAG DICOM FORMAT PATIENT NAME
; get properly formatted DICOM patient name
; HL7: family ^ given ^ middle ^ suffix ^ prefix ^ degree
; DICOM: family ^ given ^ middle ^ prefix ^ suffix (4 & 5 swapped, no degree)
N DGNAME,DICOMNAME,HL7NAME
K OUT
I '$G(DFN) S OUT="-1,No Patient Identified" Q
S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
S HL7NAME=$$HLNAME^XLFNAME(.DGNAME,"","^") ; get HL7 formatted name
I HL7NAME="" S OUT="-2,No patient found with DFN="_DFN Q
; convert to DICOM format by swapping 4th and 5th components
S DICOMNAME=$P(HL7NAME,"^",1,3) ; family ^ given ^ middle
S $P(DICOMNAME,"^",4)=$P(HL7NAME,"^",5) ; prefix (e.g., DR)
S $P(DICOMNAME,"^",5)=$P(HL7NAME,"^",4) ; suffix (e.g., JR or III)
S OUT=DICOMNAME
Q
;
ANPREFIX(OUT) ; RPC = MAG DICOM GET ACN PREFIX
; Get the value of the accession number prefix
S OUT=$$ANPREFIX^MAGDSTAB
Q
;
DASHES(OUT) ; RPC = MAG DICOM GET PT ID DASHES
; Get the value of the patient identifier dashes
S OUT=$$DASHES^MAGDSTAB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDSTA3 6768 printed Oct 16, 2024@18:02:24 Page 2
MAGDSTA3 ;WOIFO/PMK - Study Tracker - Query/Retrieve user patient lookup ; Jun 01, 2020@12:10:06
+1 ;;3.0;IMAGING;**231**;Mar 19, 2002;Build 9;Feb 27, 2015
+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 ; API's and RPC'S for MAGDSTQA VistA PII lookup routine
+19 ;
+20 ; Supported IA #3646 reference $$EMPL^DGSEC4 function call
+21 ; Supported IA #767 Reading DG SECURITY LOG ^DGSL(38.1,DFN,0)
+22 ; Supported IA #2051 reference FIND^DIC subroutine call
+23 ; Supported IA #2054 reference CLEAN^DILF subroutine call
+24 ; Supported IA #10061 reference DEM^VADPT subroutine call
+25 ; Supported IA #10035 for Fileman reads of ^DPT
+26 ; Supported IA #10103 reference $$FMTE^XLFDT function call
+27 ; Supported IA #2602 Reading AUDIT file (#1.1) ^DIA(2,...)
+28 ; Supported IA #3065 reference $$HLNAME^XLFNAME function call
+29 ;
+30 QUIT
+31 ;
PATLKUP(OUTPUT,INPUT) ; RPC = MAG DICOM PATIENT LOOKUP
+1 ; patient lookup
+2 ; modified from FINDP^SCUTBK11 for SC PATIENT LOOKUP rpc
+3 ;
+4 ; INPUT = value to lookup
+5 ; Lookup uses multiple index lookup of File #2
+6 ;
+7 ; OUTPUT = data
+8 ; OUTPUT(0) = number of records
+9 ; for i=1:number of records returned:
+10 ; DFN^patient name^DOB^PID^SEX^DOD^Sensitive
+11 ; 1 2 3 4 5 6 7
+12 ;
+13 ; (DOD = Date of Death)
+14 ;
+15 KILL OUTPUT
+16 DO FIND^DIC(2,,".01;.03;.363;.09;.02;.351","PS",INPUT,300,"B^BS^BS5^SSN")
+17 IF $GET(DIERR)
DO CLEAN^DILF
QUIT
+18 NEW SCOUNT
SET SCOUNT=+^TMP("DILIST",$JOB,0)
+19 NEW SC
FOR SC=1:1:SCOUNT
Begin DoDot:1
+20 NEW NODE,DASHSSN,DFN,DOB,DOD,NAME,PID,PRILONGID,SENSITIVE,SEX,SSN
+21 SET NODE=^TMP("DILIST",$JOB,SC,0)
+22 ; IEN^NAME^DOB^Primary Long ID^SSN^SEX^DOD
+23 ; 1 2 3 4 5 6 7
+24 SET DFN=$PIECE(NODE,"^",1)
SET NAME=$PIECE(NODE,"^",2)
+25 SET DOB=$PIECE(NODE,"^",3)
SET DOD=$PIECE(NODE,"^",4)
+26 SET SSN=$PIECE(NODE,"^",5)
SET SEX=$PIECE(NODE,"^",6)
+27 SET DASHSSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,11)
+28 SET PRILONGID=$PIECE(NODE,"^",4)
+29 IF $EXTRACT(SSN,1,9)'?9N
SET (DASHSSN,PRILONGID)=SSN
+30 SET PID=$SELECT($LENGTH(PRILONGID)>5:PRILONGID,1:DASHSSN)
+31 DO SCREEN(.SENSITIVE,DFN)
+32 DO SAVEINFO^MAGDSTQA(.OUTPUT,DFN,NAME,DOB,PID,SEX,DOD,SENSITIVE)
+33 QUIT
End DoDot:1
+34 SET OUTPUT(0)=SCOUNT
+35 KILL ^TMP("DILIST",$JOB)
+36 QUIT
+37 ;
SCREEN(SCREEN,DFN) ; RPC = MAG DICOM GET PT SENSITIVITY
+1 ; Screening logic sensitive patients
+2 ; Input : DFN - Pointer to PATIENT file (#2)
+3 ; Output : 0 - Don't apply screen
+4 ; 1 - Apply screen - sensitive patient
+5 ; 2 - Apply screen - employee
+6 ; Notes : Screen applied if patient is sensitive or an employee
+7 ;
+8 NEW DGTIME,DGT,DGA1,DG1,DGXFR0
+9 ; Sensitive - screen
+10 IF $PIECE($GET(^DGSL(38.1,DFN,0)),"^",2)
SET SCREEN=1
QUIT
+11 ; Employee - screen
+12 IF $$EMPL^DGSEC4(DFN)
SET SCREEN=2
QUIT
+13 ;Don't screen
+14 SET SCREEN=0
+15 QUIT
+16 ;
+17 ;
+18 ;
HISTLKUP(PII,DFN) ; RPC = MAG DICOM PATIENT HISTORY
+1 ; look up historical patient changes in the audit archive
+2 ; INPUT = value to lookup
+3 ; Lookup uses multiple index lookup of File #2
+4 ;
+5 ; OUTPUT = data
+6 ; OUTPUT(0) = number of records
+7 ; for i=1:number of records returned:
+8 ; DFN^Patient Name^DOB^PID^SEX^DOD^Sensitive^Changed Field^Change date & time
+9 ; 1 2 3 4 5 6 7 8 9
+10 ;
+11 ; (DOD = Date of Death; DOD and Sensitive are null)
+12 ;
+13 NEW DOB,NAME,SEX,SSN,VA,VADM,VAERR,X
+14 ; date and time of the SSN change
NEW DATETIME
+15 ; ien of the record in the AUDIT file (#1.1)
NEW DIAIEN
+16 ; SSN is field .09 in the PATIENT file (#2)
NEW FIELDNUMBER
+17 ; name of MUMPS FIELD holding the field data
NEW FIELD
+18 ; previous and new field value
NEW OLD,NEW
+19 ;
+20 KILL PII
SET PII(0)=0
+21 ; save current PII
+22 DO DEM^VADPT
+23 SET NAME=VADM(1)
+24 ; with dashes
SET SSN=$PIECE(VADM(2),"^",2)
+25 ; MM/DD/YYYY format
SET DOB=$PIECE(VADM(3),"^",1)
SET DOB=$$FMTE^XLFDT(DOB,"5Z")
+26 ; only year
IF DOB?1"00/00/"4N
SET $PIECE(NODE,"^",3)=$EXTRACT(DOB,7,10)
+27 SET SEX=$PIECE(VADM(5),"^",2)
+28 ; CC is not displayed
DO SAVEINFO^MAGDSTQA(.PII,DFN,NAME,DOB,SSN,SEX,,,,"(todayCC)")
+29 ;
+30 ; save PII changes
+31 SET DIAIEN=""
FOR
SET DIAIEN=$ORDER(^DIA(2,"B",DFN,DIAIEN),-1)
if DIAIEN=""
QUIT
Begin DoDot:1
+32 SET X=$GET(^DIA(2,DIAIEN,0))
+33 SET CHANGEDATE=$PIECE(X,"^",2)
SET FIELDNUMBER=$PIECE(X,"^",3)
+34 SET NEW=$GET(^DIA(2,DIAIEN,2))
SET OLD=$GET(^DIA(2,DIAIEN,3))
+35 ; name change record
IF FIELDNUMBER=.01
SET CHANGED="NAME"
+36 ; sex change record
IF '$TEST
IF FIELDNUMBER=.02
SET CHANGED="SEX"
+37 ; dob change record
IF '$TEST
IF FIELDNUMBER=.03
SET CHANGED="DOB"
+38 ; SSN change record
IF '$TEST
IF FIELDNUMBER=.09
SET CHANGED="SSN"
Begin DoDot:2
+39 ; remember "P"
SET OLD=$EXTRACT(OLD,1,3)_"-"_$EXTRACT(OLD,4,5)_"-"_$EXTRACT(OLD,6,10)
+40 ; remember "P"
SET NEW=$EXTRACT(NEW,1,3)_"-"_$EXTRACT(NEW,4,5)_"-"_$EXTRACT(NEW,6,10)
+41 QUIT
End DoDot:2
+42 ; other field
IF '$TEST
QUIT
+43 IF OLD'=@CHANGED
WRITE !?10,"Old ",CHANGED," not matching: ",OLD," to ",@CHANGED
+44 SET @CHANGED=NEW
+45 DO SAVEINFO^MAGDSTQA(.PII,DFN,NAME,DOB,SSN,SEX,,,CHANGED,CHANGEDATE)
+46 QUIT
End DoDot:1
+47 QUIT
+48 ;
DCMNAME(OUT,DFN) ; RPC = MAG DICOM FORMAT PATIENT NAME
+1 ; get properly formatted DICOM patient name
+2 ; HL7: family ^ given ^ middle ^ suffix ^ prefix ^ degree
+3 ; DICOM: family ^ given ^ middle ^ prefix ^ suffix (4 & 5 swapped, no degree)
+4 NEW DGNAME,DICOMNAME,HL7NAME
+5 KILL OUT
+6 IF '$GET(DFN)
SET OUT="-1,No Patient Identified"
QUIT
+7 SET DGNAME("FILE")=2
SET DGNAME("IENS")=DFN
SET DGNAME("FIELD")=.01
+8 ; get HL7 formatted name
SET HL7NAME=$$HLNAME^XLFNAME(.DGNAME,"","^")
+9 IF HL7NAME=""
SET OUT="-2,No patient found with DFN="_DFN
QUIT
+10 ; convert to DICOM format by swapping 4th and 5th components
+11 ; family ^ given ^ middle
SET DICOMNAME=$PIECE(HL7NAME,"^",1,3)
+12 ; prefix (e.g., DR)
SET $PIECE(DICOMNAME,"^",4)=$PIECE(HL7NAME,"^",5)
+13 ; suffix (e.g., JR or III)
SET $PIECE(DICOMNAME,"^",5)=$PIECE(HL7NAME,"^",4)
+14 SET OUT=DICOMNAME
+15 QUIT
+16 ;
ANPREFIX(OUT) ; RPC = MAG DICOM GET ACN PREFIX
+1 ; Get the value of the accession number prefix
+2 SET OUT=$$ANPREFIX^MAGDSTAB
+3 QUIT
+4 ;
DASHES(OUT) ; RPC = MAG DICOM GET PT ID DASHES
+1 ; Get the value of the patient identifier dashes
+2 SET OUT=$$DASHES^MAGDSTAB
+3 QUIT
