DPTLK6 ;BAY/JAT,EG - Patient lookup RPCs for patient safety issue ; 11 Aug 2005 8:33 AM
;;5.3;Registration;**265,276,277,675**;Aug 13, 1993
GUIBS5(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
; with same last name
; returns: 1 or 0 (or -1 if bad dfn or no zero node)
; if 1, returns text to be displayed
; return type: array
; parameter: ien of Patient file
K GUIDATA
I '$G(DFN) S GUIDATA(1)=-1 Q
I '$D(^DPT(DFN,0)) S GUIDATA(1)=-1 Q
I '$$BS5^DPTLK5(DFN) S GUIDATA(1)=0 Q
S GUIDATA(1)=1
N DPT0,DPTNME,DPTSSN
S DPT0=$G(^DPT(DFN,0))
S DPTNME=$P($P(DPT0,U),",")
S DPTSSN=$E($P(DPT0,U,9),6,9)
S GUIDATA(2)="There is more than one patient whose last name is "_DPTNME
S GUIDATA(3)="and whose social security number ends with "_DPTSSN
S GUIDATA(4)="Are you sure you wish to continue?"
Q
;
GUIBS5A(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
; with same last name
; returns 1 or 0 in 1st string (or -1 if bad DFN or no zero node)
; if 1 returns array nodes where
; text is preceeded by 0 (0^<text>)
; and patient data is preceeded by 1 (1^DFN^patient name^DOB^SSN)
; return type: global array
; parameter: ien of Patient file
K GUIDATA
I '$G(DFN) S GUIDATA(1)=-1 Q
I '$D(^DPT(DFN,0)) S GUIDATA(1)=-1 Q
I '$$BS5^DPTLK5(DFN) S GUIDATA(1)=0 Q
K ^TMP("DPTLK6",$J)
S ^TMP("DPTLK6",$J,1)=1
N DPT0,DPTNME,DPTSSN,DPTBS5,DPTLAST,DPTIEN,DPTCNT,DPTDOB,DPTSSN1
S DPT0=^DPT(DFN,0)
S DPTNME=$E(DPT0,1),DPTSSN=$E($P(DPT0,U,9),6,9)
S DPTBS5=DPTNME_DPTSSN
S DPTLAST=$P($P(DPT0,U),",")
S ^TMP("DPTLK6",$J,2)="0^There is more than one patient whose last name is "_DPTLAST
S ^TMP("DPTLK6",$J,3)="0^and whose social security number ends with "_DPTSSN
S DPTCNT=3
S DPTIEN=0
F S DPTIEN=$O(^DPT("BS5",DPTBS5,DPTIEN)) Q:'DPTIEN D
.S DPT0=$G(^DPT(DPTIEN,0)),DPTNME=$P($P(DPT0,U),",")
.Q:DPTNME'=DPTLAST
.S DPTNME=$P(DPT0,U)
.I $T(DOB^DPTLK1)'="" S DPTDOB=$$DOB^DPTLK1(DPTIEN,2),DPTSSN1=$$SSN^DPTLK1(DPTIEN)
.E S DPTDOB=$P(DPT0,U,3),DPTSSN1=$P(DPT0,U,9)
.S DPTCNT=DPTCNT+1
.S ^TMP("DPTLK6",$J,DPTCNT)="1"_U_DPTIEN_U_DPTNME_U_DPTDOB_U_DPTSSN1
S DPTCNT=DPTCNT+1
S ^TMP("DPTLK6",$J,DPTCNT)="0^Are you sure you wish to continue?"
M GUIDATA=^TMP("DPTLK6",$J)
K ^TMP("DPTLK6",$J)
Q
;
GUIDMT(GUIDATA,DUZ2) ; RPC checks if the 'Display Means Test Required'
; message is to be displayed for the Division user is in
; returns 1 or 0 in 1st string (or -1 if bad DUZ(2))
; if 1, returns text to be displayed in 2nd and 3rd string (if any)
; return type: array
; parameter: Institution file pointer for user (optional)
K GUIDATA
I '$G(DUZ2) S DUZ2=DUZ(2)
I '$G(DUZ2) S GUIDATA(1)=-1 Q
N DPTDIV,DPTDIVMT S DPTDIV=0
S DPTDIV=$O(^DG(40.8,"AD",DUZ2,DPTDIV))
I '$G(DPTDIV) S GUIDATA(1)=-1 Q
S GUIDATA(1)=0
S DPTDIVMT=$G(^DG(40.8,DPTDIV,"MT"))
I $P(DPTDIVMT,U,3)="Y" S GUIDATA(1)=1,GUIDATA(2)="MEANS TEST REQUIRED",GUIDATA(3)=$P(DPTDIVMT,U,2)
Q
;
GUIMT(GUIDATA,DFN) ; RPC checks if Means Test is required for this patient
; returns 1 or 0 (or -1 if bad DFN)
; return type: single value
; parameter: ien of Patient file
K GUIDATA
I '$G(DFN) S GUIDATA=-1 Q
N Y,DGREQF,DGMTLST
S GUIDATA=0
S DGMTLST=$$CMTS^DGMTU(DFN)
I $P(DGMTLST,U,4)'="R" Q
S GUIDATA=1
Q
;
GUIMTD(GUIDATA,DFN,DUZ2) ; RPC checks if Means Test is required for this
; patient and if 'Means Test Required' message is to be
; displayed for the Division user is in
; returns 1 or 0 in 1st string (or -1 if bad parameters)
; if 1, returns text to be displayed in 2nd and 3rd string (if any)
; return type: array
; parameters: ien of Patient file, Institution file pointer for user
; (optional)
K GUIDATA
I '$G(DUZ2) S DUZ2=DUZ(2)
I '$G(DFN)!('$G(DUZ2)) S GUIDATA(1)=-1 Q
N DPTDIV,DPTDIVMT S DPTDIV=0
S DPTDIV=$O(^DG(40.8,"AD",DUZ2,DPTDIV))
I '$G(DPTDIV) S GUIDATA(1)=-1 Q
N Y,DGREQF,DGMTLST
S GUIDATA(1)=0
S DGMTLST=$$CMTS^DGMTU(DFN)
;only display division message if means test is required
I '$$MFLG^DGMTU(DGMTLST) Q
S DPTDIVMT=$G(^DG(40.8,DPTDIV,"MT"))
I $P(DPTDIVMT,U,3)="Y" S GUIDATA(1)=1,GUIDATA(2)="MEANS TEST REQUIRED",GUIDATA(3)=$P(DPTDIVMT,U,2)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTLK6 4266 printed Sep 23, 2025@20:36:52 Page 2
DPTLK6 ;BAY/JAT,EG - Patient lookup RPCs for patient safety issue ; 11 Aug 2005 8:33 AM
+1 ;;5.3;Registration;**265,276,277,675**;Aug 13, 1993
GUIBS5(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
+1 ; with same last name
+2 ; returns: 1 or 0 (or -1 if bad dfn or no zero node)
+3 ; if 1, returns text to be displayed
+4 ; return type: array
+5 ; parameter: ien of Patient file
+6 KILL GUIDATA
+7 IF '$GET(DFN)
SET GUIDATA(1)=-1
QUIT
+8 IF '$DATA(^DPT(DFN,0))
SET GUIDATA(1)=-1
QUIT
+9 IF '$$BS5^DPTLK5(DFN)
SET GUIDATA(1)=0
QUIT
+10 SET GUIDATA(1)=1
+11 NEW DPT0,DPTNME,DPTSSN
+12 SET DPT0=$GET(^DPT(DFN,0))
+13 SET DPTNME=$PIECE($PIECE(DPT0,U),",")
+14 SET DPTSSN=$EXTRACT($PIECE(DPT0,U,9),6,9)
+15 SET GUIDATA(2)="There is more than one patient whose last name is "_DPTNME
+16 SET GUIDATA(3)="and whose social security number ends with "_DPTSSN
+17 SET GUIDATA(4)="Are you sure you wish to continue?"
+18 QUIT
+19 ;
GUIBS5A(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
+1 ; with same last name
+2 ; returns 1 or 0 in 1st string (or -1 if bad DFN or no zero node)
+3 ; if 1 returns array nodes where
+4 ; text is preceeded by 0 (0^<text>)
+5 ; and patient data is preceeded by 1 (1^DFN^patient name^DOB^SSN)
+6 ; return type: global array
+7 ; parameter: ien of Patient file
+8 KILL GUIDATA
+9 IF '$GET(DFN)
SET GUIDATA(1)=-1
QUIT
+10 IF '$DATA(^DPT(DFN,0))
SET GUIDATA(1)=-1
QUIT
+11 IF '$$BS5^DPTLK5(DFN)
SET GUIDATA(1)=0
QUIT
+12 KILL ^TMP("DPTLK6",$JOB)
+13 SET ^TMP("DPTLK6",$JOB,1)=1
+14 NEW DPT0,DPTNME,DPTSSN,DPTBS5,DPTLAST,DPTIEN,DPTCNT,DPTDOB,DPTSSN1
+15 SET DPT0=^DPT(DFN,0)
+16 SET DPTNME=$EXTRACT(DPT0,1)
SET DPTSSN=$EXTRACT($PIECE(DPT0,U,9),6,9)
+17 SET DPTBS5=DPTNME_DPTSSN
+18 SET DPTLAST=$PIECE($PIECE(DPT0,U),",")
+19 SET ^TMP("DPTLK6",$JOB,2)="0^There is more than one patient whose last name is "_DPTLAST
+20 SET ^TMP("DPTLK6",$JOB,3)="0^and whose social security number ends with "_DPTSSN
+21 SET DPTCNT=3
+22 SET DPTIEN=0
+23 FOR
SET DPTIEN=$ORDER(^DPT("BS5",DPTBS5,DPTIEN))
if 'DPTIEN
QUIT
Begin DoDot:1
+24 SET DPT0=$GET(^DPT(DPTIEN,0))
SET DPTNME=$PIECE($PIECE(DPT0,U),",")
+25 if DPTNME'=DPTLAST
QUIT
+26 SET DPTNME=$PIECE(DPT0,U)
+27 IF $TEXT(DOB^DPTLK1)'=""
SET DPTDOB=$$DOB^DPTLK1(DPTIEN,2)
SET DPTSSN1=$$SSN^DPTLK1(DPTIEN)
+28 IF '$TEST
SET DPTDOB=$PIECE(DPT0,U,3)
SET DPTSSN1=$PIECE(DPT0,U,9)
+29 SET DPTCNT=DPTCNT+1
+30 SET ^TMP("DPTLK6",$JOB,DPTCNT)="1"_U_DPTIEN_U_DPTNME_U_DPTDOB_U_DPTSSN1
End DoDot:1
+31 SET DPTCNT=DPTCNT+1
+32 SET ^TMP("DPTLK6",$JOB,DPTCNT)="0^Are you sure you wish to continue?"
+33 MERGE GUIDATA=^TMP("DPTLK6",$JOB)
+34 KILL ^TMP("DPTLK6",$JOB)
+35 QUIT
+36 ;
GUIDMT(GUIDATA,DUZ2) ; RPC checks if the 'Display Means Test Required'
+1 ; message is to be displayed for the Division user is in
+2 ; returns 1 or 0 in 1st string (or -1 if bad DUZ(2))
+3 ; if 1, returns text to be displayed in 2nd and 3rd string (if any)
+4 ; return type: array
+5 ; parameter: Institution file pointer for user (optional)
+6 KILL GUIDATA
+7 IF '$GET(DUZ2)
SET DUZ2=DUZ(2)
+8 IF '$GET(DUZ2)
SET GUIDATA(1)=-1
QUIT
+9 NEW DPTDIV,DPTDIVMT
SET DPTDIV=0
+10 SET DPTDIV=$ORDER(^DG(40.8,"AD",DUZ2,DPTDIV))
+11 IF '$GET(DPTDIV)
SET GUIDATA(1)=-1
QUIT
+12 SET GUIDATA(1)=0
+13 SET DPTDIVMT=$GET(^DG(40.8,DPTDIV,"MT"))
+14 IF $PIECE(DPTDIVMT,U,3)="Y"
SET GUIDATA(1)=1
SET GUIDATA(2)="MEANS TEST REQUIRED"
SET GUIDATA(3)=$PIECE(DPTDIVMT,U,2)
+15 QUIT
+16 ;
GUIMT(GUIDATA,DFN) ; RPC checks if Means Test is required for this patient
+1 ; returns 1 or 0 (or -1 if bad DFN)
+2 ; return type: single value
+3 ; parameter: ien of Patient file
+4 KILL GUIDATA
+5 IF '$GET(DFN)
SET GUIDATA=-1
QUIT
+6 NEW Y,DGREQF,DGMTLST
+7 SET GUIDATA=0
+8 SET DGMTLST=$$CMTS^DGMTU(DFN)
+9 IF $PIECE(DGMTLST,U,4)'="R"
QUIT
+10 SET GUIDATA=1
+11 QUIT
+12 ;
GUIMTD(GUIDATA,DFN,DUZ2) ; RPC checks if Means Test is required for this
+1 ; patient and if 'Means Test Required' message is to be
+2 ; displayed for the Division user is in
+3 ; returns 1 or 0 in 1st string (or -1 if bad parameters)
+4 ; if 1, returns text to be displayed in 2nd and 3rd string (if any)
+5 ; return type: array
+6 ; parameters: ien of Patient file, Institution file pointer for user
+7 ; (optional)
+8 KILL GUIDATA
+9 IF '$GET(DUZ2)
SET DUZ2=DUZ(2)
+10 IF '$GET(DFN)!('$GET(DUZ2))
SET GUIDATA(1)=-1
QUIT
+11 NEW DPTDIV,DPTDIVMT
SET DPTDIV=0
+12 SET DPTDIV=$ORDER(^DG(40.8,"AD",DUZ2,DPTDIV))
+13 IF '$GET(DPTDIV)
SET GUIDATA(1)=-1
QUIT
+14 NEW Y,DGREQF,DGMTLST
+15 SET GUIDATA(1)=0
+16 SET DGMTLST=$$CMTS^DGMTU(DFN)
+17 ;only display division message if means test is required
+18 IF '$$MFLG^DGMTU(DGMTLST)
QUIT
+19 SET DPTDIVMT=$GET(^DG(40.8,DPTDIV,"MT"))
+20 IF $PIECE(DPTDIVMT,U,3)="Y"
SET GUIDATA(1)=1
SET GUIDATA(2)="MEANS TEST REQUIRED"
SET GUIDATA(3)=$PIECE(DPTDIVMT,U,2)
+21 QUIT
+22 ;
