- 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 Jan 18, 2025@04:01:39 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 ;