MAGDSTQA ;WOIFO/PMK - Study Tracker - Query/Retrieve user patient lookup ; Aug 30, 2020@17:57:08
;;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. |
;; +---------------------------------------------------------------+
;;
;
; Notice: This routine is on both VistA and the DICOM Gateway
;
; RPC version of ^MAGDSTA3 on VistA
;
; Supported IA #3027 reference DG SENSITIVE RECORD ACCESS rpc
; Supported IA #3027 reference PTSEC^DGSEC4 subroutine call
; Supported IA #3027 reference DG SENSITIVE RECORD BULLETIN rpc
; Supported IA #3027 reference NOTICE^DGSEC4 subroutine call
; Supported IA #10103 reference $$FMTE^XLFDT function call
Q
;
; Entry point from ^MAGDSTA1 for automatic (batch) Q/R client
PATIENTA ; need just DFN for current patient, no previous PII
N CLIENT S CLIENT="AUTOMATIC"
N CHANGED,CHANGEDATE,DFN,DOB,DOD,FINIS,IPATINFO,K,PATINFO,PROMPT
;
; IPATINFO and PATINFO are not used in this subroutine
;
S DFN=$G(^TMP("MAG",$J,"BATCH Q/R","PATIENT DFN"))
S PROMPT="patient"
S IPATINFO=$$PATIENT(.PATINFO,DFN)
Q
;
PATIENT(PATINFO,DFN) ; look up the patients
N DOB,DONE,I,NAME,RETURN,RPCERR,SENSITIVE,SEX,SSN,VA,VADM,VAERR,X
S DFN=$G(DFN),RETURN=0
I DFN'="" D
. W !!,"The patient is currently defined as follows: "
. I $$VISTA^MAGDSTQ D ; VistA code - call API
. . D PAT^MAGDRPC1(.VAINFO,DFN)
. . Q
. E D ; DICOM Gateway code - call RPC
. . S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM GET PATIENT","M",.VAINFO,DFN)
. . I RPCERR<0 D S RETURN=-1 Q
. . . D ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM GET PATIENT rpc",.VAINFO)
. . . Q
. . Q
. I RETURN Q
. D VADPT^MAGDRPC0(.VAINFO)
. S VAICN=$G(VAICN)
. D SCREEN(.SENSITIVE,DFN)
. S NAME=VADM(1),DOB=$P(VADM(3),"^",2),SSN=$P(VADM(2),"^",2)
. S SEX=$P(VADM(5),"^",1)
. K PATINFO
. D SAVEINFO(.PATINFO,DFN,NAME,DOB,SSN,SEX,,SENSITIVE)
. W !! D PRINTHDR
. D PRINTPAT(.PATINFO,1)
. I $$YESNO^MAGDSTQ("Do you wish to change it?","n",.X)<0 S QUIT=1 Q
. I X="YES" D
. . S RETURN=$$PATIENT1(.PATINFO)
. . Q
. E D ; save info
. . S RETURN=1
. Q
E D
. S RETURN=$$PATIENT1(.PATINFO)
. Q
Q RETURN
;
PATIENT1(PATINFO) ; lookup patient
N I,IN,OK,RETURN,X
S OK=0 F D Q:OK
. W !!,"Enter Patient: "
. R X:DTIME E S X="^"
. I X["^" S OK=-1 Q
. I X="@" D Q
. . F I="PATIENT NAME","PATIENT ID","PATIENT BIRTH DATE","PATIENT'S SEX","PATIENT DFN" D
. . . K ^TMP("MAG",$J,"Q/R QUERY",QRSTACK,I)
. . . Q
. . K ^TMP("MAG",$J,"Q/R PARAM","PATIENT LOOKUP MODE") ; reset VistA/Manual Mode
. . S DFN="",OK=-2
. . Q
. I "?"[X D Q
. . W !!,"Enter either the Patient Name (last,first), the Social Security Number,"
. . W !,"or the Quick PID (initial + last four). You may use ""@"" to remove it."
. . Q
. S X=$TR(X,"-") ; remove dashes in SSN for lookup
. D PATLKUP(.PATINFO,X)
. S RETURN=$$PATIENT2("PATIENTS",.PATINFO,"") ; no default (3rd argument)
. Q
I OK<0 D
. S QUIT=1
. S RETURN=0
. Q
Q RETURN
;
PATIENT2(LISTMODE,INFO,DEFAULT) ; called to display a list of patients or a list of PII changes
; INFO can be either PATINFO or HISTINFO, same format
N COUNT
S COUNT=$G(INFO(0)),DEFAULT=$G(DEFAULT)
I LISTMODE="PATIENTS" D I 'COUNT Q 0
. I 'COUNT W " -- NO MATCH"
. E W " -- ",COUNT," MATCH" W:COUNT>1 "ES"
. Q
I COUNT=1 D
. S RETURN=$$SINGLE(LISTMODE,.INFO,1)
. Q
E D
. S RETURN=$$MULTIPLE(LISTMODE,.INFO,DEFAULT)
. Q
Q RETURN
;
SINGLE(LISTMODE,INFO,I) ; single match
N DATETIME,FIRSTDAY,FIRSTIEN,LASTDAY,LASTIEN,RETURN,STUDYCOUNT
S DFN=$P(INFO(I),"^",1),SENSITIVE=$P(INFO(I),"^",7)
W !! D PRINTHDR
D PRINTPAT(.INFO,I)
I SENSITIVE D I 'RETURN Q RETURN
. S RETURN=$$PATCHECK(DFN) Q:'RETURN
. W !! D PRINTHDR
. D PRINTPAT(.INFO,I,1)
. W ?65,"*SENSITIVE*"
. Q
I CLIENT="AUTOMATIC" D
. S RETURN=$$SINGLEA
. Q
E D ; CLIENT="MANUAL"
. S RETURN=$$SINGLEQ
. Q
Q RETURN
;
SINGLEA() ; automatic (batch) query retrieve
; check for radiology or consults
I IMAGINGSERVICE="RADIOLOGY" D ; look for radiology reports in the range
. D RADLKUP^MAGDSTA4(DFN,.STUDYCOUNT,.FIRSTDAY,.LASTDAY,.FIRSTIEN,.LASTIEN)
. Q
E D ; look for consults/procedures in the range
. D CONLKUP^MAGDSTA6(DFN,.STUDYCOUNT,.FIRSTDAY,.LASTDAY,.FIRSTIEN,.LASTIEN)
. Q
;
I 'STUDYCOUNT S RETURN=0
E D
. I $$YESNO^MAGDSTQ("Is this the correct "_PROMPT_"?","n",.X)>0,X="YES" D
. . S RETURN=I
. . S ^TMP("MAG",$J,"BATCH Q/R","PATIENT DFN")=$P(INFO(I),"^",1)
. . S ^TMP("MAG",$J,"BATCH Q/R","BEGIN DATE")=FIRSTDAY
. . S ^TMP("MAG",$J,"BATCH Q/R","END DATE")=LASTDAY+.235959 ; end of day
. . S (DONE,FINIS,OK)=1
. . Q
. E S RETURN=0
. Q
Q RETURN
;
SINGLEQ() ; manual query retrieve
I $$YESNO^MAGDSTQ("Is this the correct "_PROMPT_"?","n",.X)>0,X="YES" D
. S RETURN=I
. S (DONE,FINIS,OK)=1
. Q
E S RETURN=0
Q RETURN
;
PATCHECK(DFN) ; check patient sensitivity
N NOTICE,SECINFO,PATCHECK,X
I $D(PATCHECKED(DFN)) Q 1 ; patient already checked
;
I $$VISTA^MAGDSTQ D ; VistA code
. D PTSEC^DGSEC4(.SECINFO,DFN,1,"^VistA Query/Retrieve Client") ; ICR #3027
. Q
E D I SECINFO(1)=-1 D Q 0 ; DICOM Gateway code
. S X=$$CALLRPC^MAGM2VCU("DG SENSITIVE RECORD ACCESS","M",.SECINFO,DFN,1,"^DICOM Gateway Query/Retrieve Client")
. I SECINFO(1)=-1 D Q ; RPC failed
. . D ERRORMSG^MAGDSTQ0(1,"Error in DG SENSITIVE RECORD ACCESS rpc",.SECINFO)
. . Q
. Q
I SECINFO(1) D I 'PATCHECK Q 0
. N I
. W ! S I=1 F S I=$O(SECINFO(I)) Q:I="" D
. . ; write sensitive patient warning message
. . W !?(IOM-$L(SECINFO(I))/2),SECINFO(I)
. . Q
. I SECINFO(1)=1 D CONTINUE^MAGDSTQ S PATCHECK=1 Q
. I SECINFO(1)'=2 D CONTINUE^MAGDSTQ S PATCHECK=0 Q
. I $$YESNO^MAGDSTQ("Do you want to continue processing this patient record?","n",.X)<0 S PATCHECK=0 Q
. I X="NO" S PATCHECK=0 Q
. I $$VISTA^MAGDSTQ D ; VistA code
. . D NOTICE^DGSEC4(.NOTICE,DFN,"^VistA Query/Retrieve Client",1) ; ICR #3027
. . Q
. E D ; DICOM Gateway code
. . S X=$$CALLRPC^MAGM2VCU("DG SENSITIVE RECORD BULLETIN","M",.NOTICE,DFN,"^DICOM Gateway Query/Retrieve Client",1)
. . I 'NOTICE D S PATCHECK=0 Q ; RPC error
. . . D ERRORMSG^MAGDSTQ0(1,"Error in DG SENSITIVE RECORD BULLETIN rpc",.NOTICE)
. . . Q
. . Q
. S PATCHECK=1
. Q
E S PATCHECK=1
I PATCHECK S PATCHECKED(DFN)=1
Q PATCHECK
;
MULTIPLE(LISTMODE,INFO,DEFAULT) ; display information for multiple patients/pii changes
N DONE,RETURN
S (DONE,RETURN)=0
I LISTMODE="PATIENTS" W !!,"There are ",COUNT," matches"
E W !!,"There are changes in the patient identification"
R "... Press <Enter> for list",X:$G(DTIME,300)
I COUNT>20 D ; more than twenty patients/pii changes
. F K=1:20:COUNT S RETURN=$$MULTI(DEFAULT) Q:DONE
. Q
E D ; twenty or less patients
. S K=1 S RETURN=$$MULTI(DEFAULT) Q:DONE
Q RETURN
;
MULTI(DEFAULT) ; display one set of patients
N I,K20,FINIS,RETURN
S RETURN=0
S K20=K+19 I K20>COUNT S K20=COUNT
S FINIS=0 F D Q:FINIS
. W @IOF D PRINTHDR
. F I=K:1:K20 D
. . D PRINTPAT(.INFO,I)
. W !!,"Enter 1-",K20," to select the ",PROMPT
. I K20<COUNT W ", or <Enter> to see more ",PROMPT,"s"
. W ": " I DEFAULT'="" W DEFAULT,"// "
. R I:$G(DTIME,300) E S I="^"
. I I="" W DEFAULT S I=DEFAULT
. I I="" S FINIS=1 Q
. I I["^" S DONE=1,I="",FINIS=-1 Q
. I I?1N.N,I'<1,I'>K20 S RETURN=$$SINGLE(LISTMODE,.INFO,I) Q
. W " ???" R X:$G(DTIME,300)
. Q
Q RETURN
;
PRINTHDR ; print column header
W ?4,"Social Sec#",?16,"Sex",?21,"Patient's Name",?53,"Birth Date"
I $G(LISTMODE)="PII CHANGES" W ?65,"Change Date"
W !?4,"-----------",?16,"---",?21,"--------------",?53,"----------"
I $G(LISTMODE)="PII CHANGES" W ?65,"---------------"
Q
;
PRINTPAT(INFO,I,SENSITIVEOK) ; print patient information
N X
D GETINFO(.INFO,I)
;
I '$G(SENSITIVEOK),SENSITIVE D
. W !,$J(I,2),")",?4,"*SENSITIVE*",?17,$E(SEX,1),?21,$E(NAME,1,30),?53,"*SENSITIVE*"
. Q
E D
. W !,$J(I,2),")",?4,SSN,?17,$E(SEX,1),?21,$E(NAME,1,30),?53,DOB
. Q
I $G(LISTMODE)="PII CHANGES" D
. I CHANGED'="" D
. . W ?65,CHANGED,?70,"- ",$$CHANGEDT(CHANGEDATE)
. . Q
. E W ?72,$$CHANGEDT(CHANGEDATE)
. Q
Q
;
SAVEINFO(INFO,DFN,NAME,DOB,PID,SEX,DOD,SENSITIVE,CHANGED,CHANGEDATE) ; save pii
; DFN^patient name^DOB^PID^SEX^DOD^Sensitive^Changed Field^Change date & time
; 1 2 3 4 5 6 7 8 9
N X
I DOB?1"00/00/"4N S DOB=$E(DOB,7,10) ; only year
S X=DFN_"^"_NAME_"^"_DOB_"^"_PID_"^"_SEX_"^"_$G(DOD)
S X=X_"^"_$G(SENSITIVE)_"^"_$G(CHANGED)_"^"_$G(CHANGEDATE)
S INFO(0)=$G(INFO(0))+1
S INFO(INFO(0))=X
Q
;
GETINFO(INFO,I) ; retrieve pii
S X=INFO(I),DFN=$P(X,"^",1),NAME=$P(X,"^",2),DOB=$P(X,"^",3)
S SSN=$P(X,"^",4),SEX=$P(X,"^",5),DOD=$P(X,"^",6)
S SENSITIVE=$P(X,"^",7),CHANGED=$P(X,"^",8),CHANGEDATE=$P(X,"^",9)
Q
;
CHANGEDT(X) ; return change date in mm/dd/yy format
S X=$$FMTE^XLFDT(X,"5Z")
Q $E(X,1,6)_$E(X,9,10)
;
PATLKUP(OUTPUT,INPUT) ; patient lookup
; 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)
;
I $$VISTA^MAGDSTQ D ; VistA code - call API
. D PATLKUP^MAGDSTA3(.OUTPUT,INPUT)
. Q
E D ; DICOM Gateway code - call RPC
. N ARRAY,COUNT,I,RPCERR
. K OUTPUT
. S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM PATIENT LOOKUP","MT",.ARRAY,INPUT)
. I RPCERR<0 D S OUTPUT(0)=-1 Q
. . D ERRORMSG^MAGDSTQ0(1,"Error in rpc MAG DICOM PATIENT LOOKUP",.ARRAY)
. . Q
. S COUNT=ARRAY(1)
. F I=0:1:COUNT S OUTPUT(I)=ARRAY(I+1)
. Q
Q
;
SCREEN(SCREEN,DFN) ; 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
;
I $$VISTA^MAGDSTQ D ; VistA code - call API
. D SCREEN^MAGDSTA3(.SCREEN,DFN)
. Q
E D ; DICOM Gateway code - call RPC
. N RPCERR
. S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM GET PT SENSITIVITY","M",.SCREEN,DFN)
. I RPCERR<0 D S SCREEN=-1
. . D ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM GET PT SENSITIVITY rpc",.SCREEN)
. . Q
. Q
Q
;
;
;
HISTLKUP(OUTPUT,DFN) ; 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)
;
I $$VISTA^MAGDSTQ D ; VistA code - call API
. D HISTLKUP^MAGDSTA3(.OUTPUT,DFN)
. Q
E D ; DICOM Gateway code - call RPC
. N ARRAY,COUNT,I,RPCERR
. K OUTPUT
. S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM PATIENT HISTORY","MT",.ARRAY,DFN)
. I RPCERR<0 D S OUTPUT(0)=-1 Q
. . D ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM PATIENT HISTORY rpc",.ARRAY)
. . Q
. S COUNT=ARRAY(1)
. F I=0:1:COUNT S OUTPUT(I)=ARRAY(I+1)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDSTQA 12413 printed Apr 09, 2024@21:07:16 Page 2
MAGDSTQA ;WOIFO/PMK - Study Tracker - Query/Retrieve user patient lookup ; Aug 30, 2020@17:57:08
+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 ; Notice: This routine is on both VistA and the DICOM Gateway
+19 ;
+20 ; RPC version of ^MAGDSTA3 on VistA
+21 ;
+22 ; Supported IA #3027 reference DG SENSITIVE RECORD ACCESS rpc
+23 ; Supported IA #3027 reference PTSEC^DGSEC4 subroutine call
+24 ; Supported IA #3027 reference DG SENSITIVE RECORD BULLETIN rpc
+25 ; Supported IA #3027 reference NOTICE^DGSEC4 subroutine call
+26 ; Supported IA #10103 reference $$FMTE^XLFDT function call
+27 QUIT
+28 ;
+29 ; Entry point from ^MAGDSTA1 for automatic (batch) Q/R client
PATIENTA ; need just DFN for current patient, no previous PII
+1 NEW CLIENT
SET CLIENT="AUTOMATIC"
+2 NEW CHANGED,CHANGEDATE,DFN,DOB,DOD,FINIS,IPATINFO,K,PATINFO,PROMPT
+3 ;
+4 ; IPATINFO and PATINFO are not used in this subroutine
+5 ;
+6 SET DFN=$GET(^TMP("MAG",$JOB,"BATCH Q/R","PATIENT DFN"))
+7 SET PROMPT="patient"
+8 SET IPATINFO=$$PATIENT(.PATINFO,DFN)
+9 QUIT
+10 ;
PATIENT(PATINFO,DFN) ; look up the patients
+1 NEW DOB,DONE,I,NAME,RETURN,RPCERR,SENSITIVE,SEX,SSN,VA,VADM,VAERR,X
+2 SET DFN=$GET(DFN)
SET RETURN=0
+3 IF DFN'=""
Begin DoDot:1
+4 WRITE !!,"The patient is currently defined as follows: "
+5 ; VistA code - call API
IF $$VISTA^MAGDSTQ
Begin DoDot:2
+6 DO PAT^MAGDRPC1(.VAINFO,DFN)
+7 QUIT
End DoDot:2
+8 ; DICOM Gateway code - call RPC
IF '$TEST
Begin DoDot:2
+9 SET RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM GET PATIENT","M",.VAINFO,DFN)
+10 IF RPCERR<0
Begin DoDot:3
+11 DO ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM GET PATIENT rpc",.VAINFO)
+12 QUIT
End DoDot:3
SET RETURN=-1
QUIT
+13 QUIT
End DoDot:2
+14 IF RETURN
QUIT
+15 DO VADPT^MAGDRPC0(.VAINFO)
+16 SET VAICN=$GET(VAICN)
+17 DO SCREEN(.SENSITIVE,DFN)
+18 SET NAME=VADM(1)
SET DOB=$PIECE(VADM(3),"^",2)
SET SSN=$PIECE(VADM(2),"^",2)
+19 SET SEX=$PIECE(VADM(5),"^",1)
+20 KILL PATINFO
+21 DO SAVEINFO(.PATINFO,DFN,NAME,DOB,SSN,SEX,,SENSITIVE)
+22 WRITE !!
DO PRINTHDR
+23 DO PRINTPAT(.PATINFO,1)
+24 IF $$YESNO^MAGDSTQ("Do you wish to change it?","n",.X)<0
SET QUIT=1
QUIT
+25 IF X="YES"
Begin DoDot:2
+26 SET RETURN=$$PATIENT1(.PATINFO)
+27 QUIT
End DoDot:2
+28 ; save info
IF '$TEST
Begin DoDot:2
+29 SET RETURN=1
End DoDot:2
+30 QUIT
End DoDot:1
+31 IF '$TEST
Begin DoDot:1
+32 SET RETURN=$$PATIENT1(.PATINFO)
+33 QUIT
End DoDot:1
+34 QUIT RETURN
+35 ;
PATIENT1(PATINFO) ; lookup patient
+1 NEW I,IN,OK,RETURN,X
+2 SET OK=0
FOR
Begin DoDot:1
+3 WRITE !!,"Enter Patient: "
+4 READ X:DTIME
IF '$TEST
SET X="^"
+5 IF X["^"
SET OK=-1
QUIT
+6 IF X="@"
Begin DoDot:2
+7 FOR I="PATIENT NAME","PATIENT ID","PATIENT BIRTH DATE","PATIENT'S SEX","PATIENT DFN"
Begin DoDot:3
+8 KILL ^TMP("MAG",$JOB,"Q/R QUERY",QRSTACK,I)
+9 QUIT
End DoDot:3
+10 ; reset VistA/Manual Mode
KILL ^TMP("MAG",$JOB,"Q/R PARAM","PATIENT LOOKUP MODE")
+11 SET DFN=""
SET OK=-2
+12 QUIT
End DoDot:2
QUIT
+13 IF "?"[X
Begin DoDot:2
+14 WRITE !!,"Enter either the Patient Name (last,first), the Social Security Number,"
+15 WRITE !,"or the Quick PID (initial + last four). You may use ""@"" to remove it."
+16 QUIT
End DoDot:2
QUIT
+17 ; remove dashes in SSN for lookup
SET X=$TRANSLATE(X,"-")
+18 DO PATLKUP(.PATINFO,X)
+19 ; no default (3rd argument)
SET RETURN=$$PATIENT2("PATIENTS",.PATINFO,"")
+20 QUIT
End DoDot:1
if OK
QUIT
+21 IF OK<0
Begin DoDot:1
+22 SET QUIT=1
+23 SET RETURN=0
+24 QUIT
End DoDot:1
+25 QUIT RETURN
+26 ;
PATIENT2(LISTMODE,INFO,DEFAULT) ; called to display a list of patients or a list of PII changes
+1 ; INFO can be either PATINFO or HISTINFO, same format
+2 NEW COUNT
+3 SET COUNT=$GET(INFO(0))
SET DEFAULT=$GET(DEFAULT)
+4 IF LISTMODE="PATIENTS"
Begin DoDot:1
+5 IF 'COUNT
WRITE " -- NO MATCH"
+6 IF '$TEST
WRITE " -- ",COUNT," MATCH"
if COUNT>1
WRITE "ES"
+7 QUIT
End DoDot:1
IF 'COUNT
QUIT 0
+8 IF COUNT=1
Begin DoDot:1
+9 SET RETURN=$$SINGLE(LISTMODE,.INFO,1)
+10 QUIT
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET RETURN=$$MULTIPLE(LISTMODE,.INFO,DEFAULT)
+13 QUIT
End DoDot:1
+14 QUIT RETURN
+15 ;
SINGLE(LISTMODE,INFO,I) ; single match
+1 NEW DATETIME,FIRSTDAY,FIRSTIEN,LASTDAY,LASTIEN,RETURN,STUDYCOUNT
+2 SET DFN=$PIECE(INFO(I),"^",1)
SET SENSITIVE=$PIECE(INFO(I),"^",7)
+3 WRITE !!
DO PRINTHDR
+4 DO PRINTPAT(.INFO,I)
+5 IF SENSITIVE
Begin DoDot:1
+6 SET RETURN=$$PATCHECK(DFN)
if 'RETURN
QUIT
+7 WRITE !!
DO PRINTHDR
+8 DO PRINTPAT(.INFO,I,1)
+9 WRITE ?65,"*SENSITIVE*"
+10 QUIT
End DoDot:1
IF 'RETURN
QUIT RETURN
+11 IF CLIENT="AUTOMATIC"
Begin DoDot:1
+12 SET RETURN=$$SINGLEA
+13 QUIT
End DoDot:1
+14 ; CLIENT="MANUAL"
IF '$TEST
Begin DoDot:1
+15 SET RETURN=$$SINGLEQ
+16 QUIT
End DoDot:1
+17 QUIT RETURN
+18 ;
SINGLEA() ; automatic (batch) query retrieve
+1 ; check for radiology or consults
+2 ; look for radiology reports in the range
IF IMAGINGSERVICE="RADIOLOGY"
Begin DoDot:1
+3 DO RADLKUP^MAGDSTA4(DFN,.STUDYCOUNT,.FIRSTDAY,.LASTDAY,.FIRSTIEN,.LASTIEN)
+4 QUIT
End DoDot:1
+5 ; look for consults/procedures in the range
IF '$TEST
Begin DoDot:1
+6 DO CONLKUP^MAGDSTA6(DFN,.STUDYCOUNT,.FIRSTDAY,.LASTDAY,.FIRSTIEN,.LASTIEN)
+7 QUIT
End DoDot:1
+8 ;
+9 IF 'STUDYCOUNT
SET RETURN=0
+10 IF '$TEST
Begin DoDot:1
+11 IF $$YESNO^MAGDSTQ("Is this the correct "_PROMPT_"?","n",.X)>0
IF X="YES"
Begin DoDot:2
+12 SET RETURN=I
+13 SET ^TMP("MAG",$JOB,"BATCH Q/R","PATIENT DFN")=$PIECE(INFO(I),"^",1)
+14 SET ^TMP("MAG",$JOB,"BATCH Q/R","BEGIN DATE")=FIRSTDAY
+15 ; end of day
SET ^TMP("MAG",$JOB,"BATCH Q/R","END DATE")=LASTDAY+.235959
+16 SET (DONE,FINIS,OK)=1
+17 QUIT
End DoDot:2
+18 IF '$TEST
SET RETURN=0
+19 QUIT
End DoDot:1
+20 QUIT RETURN
+21 ;
SINGLEQ() ; manual query retrieve
+1 IF $$YESNO^MAGDSTQ("Is this the correct "_PROMPT_"?","n",.X)>0
IF X="YES"
Begin DoDot:1
+2 SET RETURN=I
+3 SET (DONE,FINIS,OK)=1
+4 QUIT
End DoDot:1
+5 IF '$TEST
SET RETURN=0
+6 QUIT RETURN
+7 ;
PATCHECK(DFN) ; check patient sensitivity
+1 NEW NOTICE,SECINFO,PATCHECK,X
+2 ; patient already checked
IF $DATA(PATCHECKED(DFN))
QUIT 1
+3 ;
+4 ; VistA code
IF $$VISTA^MAGDSTQ
Begin DoDot:1
+5 ; ICR #3027
DO PTSEC^DGSEC4(.SECINFO,DFN,1,"^VistA Query/Retrieve Client")
+6 QUIT
End DoDot:1
+7 ; DICOM Gateway code
IF '$TEST
Begin DoDot:1
+8 SET X=$$CALLRPC^MAGM2VCU("DG SENSITIVE RECORD ACCESS","M",.SECINFO,DFN,1,"^DICOM Gateway Query/Retrieve Client")
+9 ; RPC failed
IF SECINFO(1)=-1
Begin DoDot:2
+10 DO ERRORMSG^MAGDSTQ0(1,"Error in DG SENSITIVE RECORD ACCESS rpc",.SECINFO)
+11 QUIT
End DoDot:2
QUIT
+12 QUIT
End DoDot:1
IF SECINFO(1)=-1
Begin DoDot:1
End DoDot:1
QUIT 0
+13 IF SECINFO(1)
Begin DoDot:1
+14 NEW I
+15 WRITE !
SET I=1
FOR
SET I=$ORDER(SECINFO(I))
if I=""
QUIT
Begin DoDot:2
+16 ; write sensitive patient warning message
+17 WRITE !?(IOM-$LENGTH(SECINFO(I))/2),SECINFO(I)
+18 QUIT
End DoDot:2
+19 IF SECINFO(1)=1
DO CONTINUE^MAGDSTQ
SET PATCHECK=1
QUIT
+20 IF SECINFO(1)'=2
DO CONTINUE^MAGDSTQ
SET PATCHECK=0
QUIT
+21 IF $$YESNO^MAGDSTQ("Do you want to continue processing this patient record?","n",.X)<0
SET PATCHECK=0
QUIT
+22 IF X="NO"
SET PATCHECK=0
QUIT
+23 ; VistA code
IF $$VISTA^MAGDSTQ
Begin DoDot:2
+24 ; ICR #3027
DO NOTICE^DGSEC4(.NOTICE,DFN,"^VistA Query/Retrieve Client",1)
+25 QUIT
End DoDot:2
+26 ; DICOM Gateway code
IF '$TEST
Begin DoDot:2
+27 SET X=$$CALLRPC^MAGM2VCU("DG SENSITIVE RECORD BULLETIN","M",.NOTICE,DFN,"^DICOM Gateway Query/Retrieve Client",1)
+28 ; RPC error
IF 'NOTICE
Begin DoDot:3
+29 DO ERRORMSG^MAGDSTQ0(1,"Error in DG SENSITIVE RECORD BULLETIN rpc",.NOTICE)
+30 QUIT
End DoDot:3
SET PATCHECK=0
QUIT
+31 QUIT
End DoDot:2
+32 SET PATCHECK=1
+33 QUIT
End DoDot:1
IF 'PATCHECK
QUIT 0
+34 IF '$TEST
SET PATCHECK=1
+35 IF PATCHECK
SET PATCHECKED(DFN)=1
+36 QUIT PATCHECK
+37 ;
MULTIPLE(LISTMODE,INFO,DEFAULT) ; display information for multiple patients/pii changes
+1 NEW DONE,RETURN
+2 SET (DONE,RETURN)=0
+3 IF LISTMODE="PATIENTS"
WRITE !!,"There are ",COUNT," matches"
+4 IF '$TEST
WRITE !!,"There are changes in the patient identification"
+5 READ "... Press <Enter> for list",X:$GET(DTIME,300)
+6 ; more than twenty patients/pii changes
IF COUNT>20
Begin DoDot:1
+7 FOR K=1:20:COUNT
SET RETURN=$$MULTI(DEFAULT)
if DONE
QUIT
+8 QUIT
End DoDot:1
+9 ; twenty or less patients
IF '$TEST
Begin DoDot:1
+10 SET K=1
SET RETURN=$$MULTI(DEFAULT)
if DONE
QUIT
End DoDot:1
+11 QUIT RETURN
+12 ;
MULTI(DEFAULT) ; display one set of patients
+1 NEW I,K20,FINIS,RETURN
+2 SET RETURN=0
+3 SET K20=K+19
IF K20>COUNT
SET K20=COUNT
+4 SET FINIS=0
FOR
Begin DoDot:1
+5 WRITE @IOF
DO PRINTHDR
+6 FOR I=K:1:K20
Begin DoDot:2
+7 DO PRINTPAT(.INFO,I)
End DoDot:2
+8 WRITE !!,"Enter 1-",K20," to select the ",PROMPT
+9 IF K20<COUNT
WRITE ", or <Enter> to see more ",PROMPT,"s"
+10 WRITE ": "
IF DEFAULT'=""
WRITE DEFAULT,"// "
+11 READ I:$GET(DTIME,300)
IF '$TEST
SET I="^"
+12 IF I=""
WRITE DEFAULT
SET I=DEFAULT
+13 IF I=""
SET FINIS=1
QUIT
+14 IF I["^"
SET DONE=1
SET I=""
SET FINIS=-1
QUIT
+15 IF I?1N.N
IF I'<1
IF I'>K20
SET RETURN=$$SINGLE(LISTMODE,.INFO,I)
QUIT
+16 WRITE " ???"
READ X:$GET(DTIME,300)
+17 QUIT
End DoDot:1
if FINIS
QUIT
+18 QUIT RETURN
+19 ;
PRINTHDR ; print column header
+1 WRITE ?4,"Social Sec#",?16,"Sex",?21,"Patient's Name",?53,"Birth Date"
+2 IF $GET(LISTMODE)="PII CHANGES"
WRITE ?65,"Change Date"
+3 WRITE !?4,"-----------",?16,"---",?21,"--------------",?53,"----------"
+4 IF $GET(LISTMODE)="PII CHANGES"
WRITE ?65,"---------------"
+5 QUIT
+6 ;
PRINTPAT(INFO,I,SENSITIVEOK) ; print patient information
+1 NEW X
+2 DO GETINFO(.INFO,I)
+3 ;
+4 IF '$GET(SENSITIVEOK)
IF SENSITIVE
Begin DoDot:1
+5 WRITE !,$JUSTIFY(I,2),")",?4,"*SENSITIVE*",?17,$EXTRACT(SEX,1),?21,$EXTRACT(NAME,1,30),?53,"*SENSITIVE*"
+6 QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !,$JUSTIFY(I,2),")",?4,SSN,?17,$EXTRACT(SEX,1),?21,$EXTRACT(NAME,1,30),?53,DOB
+9 QUIT
End DoDot:1
+10 IF $GET(LISTMODE)="PII CHANGES"
Begin DoDot:1
+11 IF CHANGED'=""
Begin DoDot:2
+12 WRITE ?65,CHANGED,?70,"- ",$$CHANGEDT(CHANGEDATE)
+13 QUIT
End DoDot:2
+14 IF '$TEST
WRITE ?72,$$CHANGEDT(CHANGEDATE)
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
SAVEINFO(INFO,DFN,NAME,DOB,PID,SEX,DOD,SENSITIVE,CHANGED,CHANGEDATE) ; save pii
+1 ; DFN^patient name^DOB^PID^SEX^DOD^Sensitive^Changed Field^Change date & time
+2 ; 1 2 3 4 5 6 7 8 9
+3 NEW X
+4 ; only year
IF DOB?1"00/00/"4N
SET DOB=$EXTRACT(DOB,7,10)
+5 SET X=DFN_"^"_NAME_"^"_DOB_"^"_PID_"^"_SEX_"^"_$GET(DOD)
+6 SET X=X_"^"_$GET(SENSITIVE)_"^"_$GET(CHANGED)_"^"_$GET(CHANGEDATE)
+7 SET INFO(0)=$GET(INFO(0))+1
+8 SET INFO(INFO(0))=X
+9 QUIT
+10 ;
GETINFO(INFO,I) ; retrieve pii
+1 SET X=INFO(I)
SET DFN=$PIECE(X,"^",1)
SET NAME=$PIECE(X,"^",2)
SET DOB=$PIECE(X,"^",3)
+2 SET SSN=$PIECE(X,"^",4)
SET SEX=$PIECE(X,"^",5)
SET DOD=$PIECE(X,"^",6)
+3 SET SENSITIVE=$PIECE(X,"^",7)
SET CHANGED=$PIECE(X,"^",8)
SET CHANGEDATE=$PIECE(X,"^",9)
+4 QUIT
+5 ;
CHANGEDT(X) ; return change date in mm/dd/yy format
+1 SET X=$$FMTE^XLFDT(X,"5Z")
+2 QUIT $EXTRACT(X,1,6)_$EXTRACT(X,9,10)
+3 ;
PATLKUP(OUTPUT,INPUT) ; patient lookup
+1 ; INPUT = value to lookup
+2 ; Lookup uses multiple index lookup of File #2
+3 ;
+4 ; OUTPUT = data
+5 ; OUTPUT(0) = number of records
+6 ; for i=1:number of records returned:
+7 ; DFN^patient name^DOB^PID^SEX^DOD^Sensitive
+8 ; 1 2 3 4 5 6 7
+9 ;
+10 ; (DOD = Date of Death)
+11 ;
+12 ; VistA code - call API
IF $$VISTA^MAGDSTQ
Begin DoDot:1
+13 DO PATLKUP^MAGDSTA3(.OUTPUT,INPUT)
+14 QUIT
End DoDot:1
+15 ; DICOM Gateway code - call RPC
IF '$TEST
Begin DoDot:1
+16 NEW ARRAY,COUNT,I,RPCERR
+17 KILL OUTPUT
+18 SET RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM PATIENT LOOKUP","MT",.ARRAY,INPUT)
+19 IF RPCERR<0
Begin DoDot:2
+20 DO ERRORMSG^MAGDSTQ0(1,"Error in rpc MAG DICOM PATIENT LOOKUP",.ARRAY)
+21 QUIT
End DoDot:2
SET OUTPUT(0)=-1
QUIT
+22 SET COUNT=ARRAY(1)
+23 FOR I=0:1:COUNT
SET OUTPUT(I)=ARRAY(I+1)
+24 QUIT
End DoDot:1
+25 QUIT
+26 ;
SCREEN(SCREEN,DFN) ; Screening logic sensitive patients
+1 ; Input : DFN - Pointer to PATIENT file (#2)
+2 ; Output : 0 - Don't apply screen
+3 ; 1 - Apply screen - sensitive patient
+4 ; 2 - Apply screen - employee
+5 ; Notes : Screen applied if patient is sensitive or an employee
+6 ;
+7 ; VistA code - call API
IF $$VISTA^MAGDSTQ
Begin DoDot:1
+8 DO SCREEN^MAGDSTA3(.SCREEN,DFN)
+9 QUIT
End DoDot:1
+10 ; DICOM Gateway code - call RPC
IF '$TEST
Begin DoDot:1
+11 NEW RPCERR
+12 SET RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM GET PT SENSITIVITY","M",.SCREEN,DFN)
+13 IF RPCERR<0
Begin DoDot:2
+14 DO ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM GET PT SENSITIVITY rpc",.SCREEN)
+15 QUIT
End DoDot:2
SET SCREEN=-1
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
+19 ;
+20 ;
HISTLKUP(OUTPUT,DFN) ; look up historical patient changes in the audit archive
+1 ; INPUT = value to lookup
+2 ; Lookup uses multiple index lookup of File #2
+3 ;
+4 ; OUTPUT = data
+5 ; OUTPUT(0) = number of records
+6 ; for i=1:number of records returned:
+7 ; DFN^Patient Name^DOB^PID^SEX^DOD^Sensitive^Changed Field^Change date & time
+8 ; 1 2 3 4 5 6 7 8 9
+9 ;
+10 ; (DOD = Date of Death; DOD and Sensitive are null)
+11 ;
+12 ; VistA code - call API
IF $$VISTA^MAGDSTQ
Begin DoDot:1
+13 DO HISTLKUP^MAGDSTA3(.OUTPUT,DFN)
+14 QUIT
End DoDot:1
+15 ; DICOM Gateway code - call RPC
IF '$TEST
Begin DoDot:1
+16 NEW ARRAY,COUNT,I,RPCERR
+17 KILL OUTPUT
+18 SET RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM PATIENT HISTORY","MT",.ARRAY,DFN)
+19 IF RPCERR<0
Begin DoDot:2
+20 DO ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM PATIENT HISTORY rpc",.ARRAY)
+21 QUIT
End DoDot:2
SET OUTPUT(0)=-1
QUIT
+22 SET COUNT=ARRAY(1)
+23 FOR I=0:1:COUNT
SET OUTPUT(I)=ARRAY(I+1)
+24 QUIT
End DoDot:1
+25 QUIT
