- 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 Feb 18, 2025@23:28:07 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