BEDDPLKP ;GDIT/HCSD/BEE-Patient Lookup ; 29 Oct 2005 6:51 PM
;;2.0;BEDD DASHBOARD;**2,3**;Jun 04, 2014;Build 12
;
;Adapted from BQIPTLKP
;
Q
;
FND(BEDD,TEXT,MAX) ; EP -- LOOKUP PATIENTS
;
;Description - Find a list of patients based on search criteria
;Input
; TEXT - Search text which can include name, SSN, HRN, etc.
; MAX - Maximum results to return
;Output
; BEDD - Array of patients
;
NEW UID,I,H,FILE,FIELD,XREF,FLAGS,NUMB,SCREEN,BN,DFN,NAME,HRN
NEW DOB,DOD,AL,ALFLG,X,ALIAS,NODE,RCNT,TYPE,X,SEX,DISP,TMP
;
; NOTE: Since "DILIST" is used by the DIC calls it must use $J and not UID.
K BEDD,^TMP("DILIST",$J)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDPLKP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S TYPE=""
S MAX=+$G(MAX) S:MAX=0 MAX=25
;
;DOB lookup
I $$DATE(TEXT)]"" D
. S TYPE="D"
. S TEXT=$$DATE(TEXT)
. S FILE=2,FIELD=.03,XREF="ADOB",FLAGS="P",NUMB="*"
. D LKUP
;
;HRN lookup
I $O(^TMP("DILIST",$J,0))="",$L(TEXT),((TEXT?1.9N)!(TEXT?1"T"5N)) D
. NEW BN,DFN,LOC
. S TYPE="H"
. S BN=0,DFN=""
. F S DFN=$O(^AUPNPAT("D",TEXT,DFN)) Q:DFN="" D
.. S LOC=0
.. F S LOC=$O(^AUPNPAT(DFN,41,LOC)) Q:'LOC D
... I $P($G(^AUPNPAT(DFN,41,LOC,0)),U,3)'="" Q
... I $P($G(^AUPNPAT(DFN,41,LOC,0)),U,2)'=TEXT Q
... S BN=BN+1,$P(^TMP("DILIST",$J,BN,0),"^",1)=DFN
... S $P(^TMP("DILIST",$J,BN,0),"^",2)=$$GET1^DIQ(9000001,DFN_",",.01,"E")
;
;SSN L4 lookup
I TYPE="",$L(TEXT)=5,TEXT?1A4N D
. S TYPE="S4"
. S FILE=2,FIELD=.09,XREF="BS5",FLAGS="P",NUMB="*"
. D LKUP
;
; If user enter spaces after comma, strip extraneous spaces
I TYPE="" D
. S TEXT=$$REMDBL^XLFNAME1(TEXT," ")
. ;
. ;if no type of search was passed, the lookup will have to be through all cross-references
. ; Change text to all uppercase
. S TEXT=$$UP^XLFSTR(TEXT)
. S FILE=9000001,FIELD=".01",XREF="",FLAGS="MP",NUMB="*"
. D LKUP
;
; For each patient found in the search, get the list data
S BN=0 F S BN=$O(^TMP("DILIST",$J,BN)) Q:'BN D
. S DFN=$P(^TMP("DILIST",$J,BN,0),"^",1)
. ;
. ;Filter results on location
. Q:'$D(^AUPNPAT(DFN,41,DUZ(2),0))
. ;
. S NAME=$$GET1^DIQ(9000001,DFN_",",.01,"E")
. S SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
. S HRN=$$HRNL(DFN) Q:HRN=""
. S DOB=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.03,"I"))
. S DOD=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.351,"I"))
. S AL=0,ALFLG="N" D
.. S AL=$O(^DPT(DFN,.01,AL)) Q:'AL S ALFLG="Y"
. S ALIAS="" I TYPE'="H",TYPE'="S4",TEXT?1A.E,$E(NAME,1,$L(TEXT))'=TEXT S ALIAS=$$ALIAS(DFN,TEXT) I 'ALIAS Q
. I ALIAS S DISP=$P(ALIAS,U,2)_" ["_NAME_"] "
. E S DISP=NAME
. S NODE=DISP_"^"_DFN
. S DISP=DISP_" ("_SEX_") - DOB: "_DOB_" "_$S(HRN]"":"HRN: ",1:"")
. F I=1:1:$L(HRN,";") S H=$P(HRN,";",I) I H]"" Q:($L(DISP_H)>85) S DISP=DISP_$S(I>1:";",1:"")_H
. S TMP(NODE)=DFN_U_DISP
;
;Limit Results to Maximum Requested
S RCNT=0,NODE="" F S NODE=$O(TMP(NODE)) Q:(NODE="")!(RCNT'<MAX) S RCNT=RCNT+1,BEDD(RCNT)=TMP(NODE)
;
DONE ;
K ^TMP("DILIST",$J)
Q
;
LKUP ;
NEW DIQUIET
S DIQUIET=1
S:FIELD]"" FIELD=FIELD_";@"
D FIND^DIC(FILE,"",FIELD,FLAGS,TEXT,"",XREF,$G(SCREEN),"","","ERROR")
Q
;
ALIAS(PTIEN,TEXT) ;EP
; Does this patient's alias match the TEXT?
N IEN,ALIAS,ALFND
S IEN=0,ALFND=""
F S IEN=$O(^DPT(PTIEN,.01,IEN)) Q:'IEN!ALFND D
. S ALIAS=$$GET1^DIQ(2.01,IEN_","_PTIEN_",",.01,"E")
. I $E(ALIAS,1,$L(TEXT))=TEXT S ALFND="1^"_ALIAS
Q ALFND
;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
;Input
; DATE - In a standard format
;Output
; -1 is if it couldn't convert to a FileMan date
; otherwise a standard FileMan date
NEW %DT,X,Y
I DATE[":" D
. I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
. I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
. I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
S %DT="TS",X=DATE D ^%DT
I Y=-1 S Y=""
;
Q Y
;
SENS(DFN) ;EP -- Is patient sensitive flag
;Input
; DFN - Patient internal entry number
NEW FLAG
S FLAG=+$P($G(^DGSL(38.1,+DFN,0)),"^",2)
S FLAG=$S(FLAG=1:"Y",1:"N")
Q FLAG
;
HRNL(DFN) ;EP -- List of HRNs for a patient
NEW HRN,LOC,HDATA,ABR,VAL,ULOC
S LOC=0,VAL=""
S VAL=$$HLK(DUZ(2))
Q $$TKO(VAL,";")
;
HLK(ULOC) ; EP - Get HRN data for a location
NEW HDATA,IACT
S HDATA=$G(^AUPNPAT(DFN,41,ULOC,0))
S HRN=$P(HDATA,U,2),IACT=$P(HDATA,U,3)
I HRN="" Q ""
I IACT'="" S HRN="" ;Inactive patient
Q HRN
;
TKO(STR,VAL) ;EP - Take off ending character
;
;Description
; This will take off the ending character at the end of
; a string
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; same STR without the ending character
;
I $G(STR)="" Q ""
I $G(VAL)="" Q ""
;
NEW LV
S LV=$L(VAL)
I $E(STR,$L(STR)-(LV-1),$L(STR))=VAL S STR=$E(STR,1,$L(STR)-LV)
;
Q STR
;
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
Q
BEDDPLKP ;GDIT/HCSD/BEE-Patient Lookup ; 29 Oct 2005 6:51 PM
+1 ;;2.0;BEDD DASHBOARD;**2,3**;Jun 04, 2014;Build 12
+2 ;
+3 ;Adapted from BQIPTLKP
+4 ;
+5 QUIT
+6 ;
FND(BEDD,TEXT,MAX) ; EP -- LOOKUP PATIENTS
+1 ;
+2 ;Description - Find a list of patients based on search criteria
+3 ;Input
+4 ; TEXT - Search text which can include name, SSN, HRN, etc.
+5 ; MAX - Maximum results to return
+6 ;Output
+7 ; BEDD - Array of patients
+8 ;
+9 NEW UID,I,H,FILE,FIELD,XREF,FLAGS,NUMB,SCREEN,BN,DFN,NAME,HRN
+10 NEW DOB,DOD,AL,ALFLG,X,ALIAS,NODE,RCNT,TYPE,X,SEX,DISP,TMP
+11 ;
+12 ; NOTE: Since "DILIST" is used by the DIC calls it must use $J and not UID.
+13 KILL BEDD,^TMP("DILIST",$JOB)
+14 ;
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDPLKP D UNWIND^%ZTER"
+16 ;
+17 SET TYPE=""
+18 SET MAX=+$GET(MAX)
IF MAX=0
SET MAX=25
+19 ;
+20 ;DOB lookup
+21 IF $$DATE(TEXT)]""
Begin DoDot:1
+22 SET TYPE="D"
+23 SET TEXT=$$DATE(TEXT)
+24 SET FILE=2
SET FIELD=.03
SET XREF="ADOB"
SET FLAGS="P"
SET NUMB="*"
+25 DO LKUP
End DoDot:1
+26 ;
+27 ;HRN lookup
+28 IF $ORDER(^TMP("DILIST",$JOB,0))=""
IF $LENGTH(TEXT)
IF ((TEXT?1.9N)!(TEXT?1"T"5N))
Begin DoDot:1
+29 NEW BN,DFN,LOC
+30 SET TYPE="H"
+31 SET BN=0
SET DFN=""
+32 FOR
SET DFN=$ORDER(^AUPNPAT("D",TEXT,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+33 SET LOC=0
+34 FOR
SET LOC=$ORDER(^AUPNPAT(DFN,41,LOC))
IF 'LOC
QUIT
Begin DoDot:3
+35 IF $PIECE($GET(^AUPNPAT(DFN,41,LOC,0)),U,3)'=""
QUIT
+36 IF $PIECE($GET(^AUPNPAT(DFN,41,LOC,0)),U,2)'=TEXT
QUIT
+37 SET BN=BN+1
SET $PIECE(^TMP("DILIST",$JOB,BN,0),"^",1)=DFN
+38 SET $PIECE(^TMP("DILIST",$JOB,BN,0),"^",2)=$$GET1^DIQ(9000001,DFN_",",.01,"E")
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 ;SSN L4 lookup
+41 IF TYPE=""
IF $LENGTH(TEXT)=5
IF TEXT?1A4N
Begin DoDot:1
+42 SET TYPE="S4"
+43 SET FILE=2
SET FIELD=.09
SET XREF="BS5"
SET FLAGS="P"
SET NUMB="*"
+44 DO LKUP
End DoDot:1
+45 ;
+46 ; If user enter spaces after comma, strip extraneous spaces
+47 IF TYPE=""
Begin DoDot:1
+48 SET TEXT=$$REMDBL^XLFNAME1(TEXT," ")
+49 ;
+50 ;if no type of search was passed, the lookup will have to be through all cross-references
+51 ; Change text to all uppercase
+52 SET TEXT=$$UP^XLFSTR(TEXT)
+53 SET FILE=9000001
SET FIELD=".01"
SET XREF=""
SET FLAGS="MP"
SET NUMB="*"
+54 DO LKUP
End DoDot:1
+55 ;
+56 ; For each patient found in the search, get the list data
+57 SET BN=0
FOR
SET BN=$ORDER(^TMP("DILIST",$JOB,BN))
IF 'BN
QUIT
Begin DoDot:1
+58 SET DFN=$PIECE(^TMP("DILIST",$JOB,BN,0),"^",1)
+59 ;
+60 ;Filter results on location
+61 IF '$DATA(^AUPNPAT(DFN,41,DUZ(2),0))
QUIT
+62 ;
+63 SET NAME=$$GET1^DIQ(9000001,DFN_",",.01,"E")
+64 SET SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
+65 SET HRN=$$HRNL(DFN)
IF HRN=""
QUIT
+66 SET DOB=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.03,"I"))
+67 SET DOD=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.351,"I"))
+68 SET AL=0
SET ALFLG="N"
Begin DoDot:2
+69 SET AL=$ORDER(^DPT(DFN,.01,AL))
IF 'AL
QUIT
SET ALFLG="Y"
End DoDot:2
+70 SET ALIAS=""
IF TYPE'="H"
IF TYPE'="S4"
IF TEXT?1A.E
IF $EXTRACT(NAME,1,$LENGTH(TEXT))'=TEXT
SET ALIAS=$$ALIAS(DFN,TEXT)
IF 'ALIAS
QUIT
+71 IF ALIAS
SET DISP=$PIECE(ALIAS,U,2)_" ["_NAME_"] "
+72 IF '$TEST
SET DISP=NAME
+73 SET NODE=DISP_"^"_DFN
+74 SET DISP=DISP_" ("_SEX_") - DOB: "_DOB_" "_$SELECT(HRN]"":"HRN: ",1:"")
+75 FOR I=1:1:$LENGTH(HRN,";")
SET H=$PIECE(HRN,";",I)
IF H]""
IF ($LENGTH(DISP_H)>85)
QUIT
SET DISP=DISP_$SELECT(I>1:";",1:"")_H
+76 SET TMP(NODE)=DFN_U_DISP
End DoDot:1
+77 ;
+78 ;Limit Results to Maximum Requested
+79 SET RCNT=0
SET NODE=""
FOR
SET NODE=$ORDER(TMP(NODE))
IF (NODE="")!(RCNT'<MAX)
QUIT
SET RCNT=RCNT+1
SET BEDD(RCNT)=TMP(NODE)
+80 ;
DONE ;
+1 KILL ^TMP("DILIST",$JOB)
+2 QUIT
+3 ;
LKUP ;
+1 NEW DIQUIET
+2 SET DIQUIET=1
+3 IF FIELD]""
SET FIELD=FIELD_";@"
+4 DO FIND^DIC(FILE,"",FIELD,FLAGS,TEXT,"",XREF,$GET(SCREEN),"","","ERROR")
+5 QUIT
+6 ;
ALIAS(PTIEN,TEXT) ;EP
+1 ; Does this patient's alias match the TEXT?
+2 NEW IEN,ALIAS,ALFND
+3 SET IEN=0
SET ALFND=""
+4 FOR
SET IEN=$ORDER(^DPT(PTIEN,.01,IEN))
IF 'IEN!ALFND
QUIT
Begin DoDot:1
+5 SET ALIAS=$$GET1^DIQ(2.01,IEN_","_PTIEN_",",.01,"E")
+6 IF $EXTRACT(ALIAS,1,$LENGTH(TEXT))=TEXT
SET ALFND="1^"_ALIAS
End DoDot:1
+7 QUIT ALFND
+8 ;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
+1 ;Input
+2 ; DATE - In a standard format
+3 ;Output
+4 ; -1 is if it couldn't convert to a FileMan date
+5 ; otherwise a standard FileMan date
+6 NEW %DT,X,Y
+7 IF DATE[":"
Begin DoDot:1
+8 IF DATE["/"
IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1)_"@"_$PIECE(DATE," ",2)_$PIECE(DATE," ",3)
QUIT
+9 IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1,2)_"@"_$PIECE(DATE," ",3)
+10 IF $LENGTH(DATE," ")>3
SET DATE=$PIECE(DATE," ",1,3)_"@"_$PIECE(DATE," ",4,99)
End DoDot:1
+11 SET %DT="TS"
SET X=DATE
DO ^%DT
+12 IF Y=-1
SET Y=""
+13 ;
+14 QUIT Y
+15 ;
SENS(DFN) ;EP -- Is patient sensitive flag
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 NEW FLAG
+4 SET FLAG=+$PIECE($GET(^DGSL(38.1,+DFN,0)),"^",2)
+5 SET FLAG=$SELECT(FLAG=1:"Y",1:"N")
+6 QUIT FLAG
+7 ;
HRNL(DFN) ;EP -- List of HRNs for a patient
+1 NEW HRN,LOC,HDATA,ABR,VAL,ULOC
+2 SET LOC=0
SET VAL=""
+3 SET VAL=$$HLK(DUZ(2))
+4 QUIT $$TKO(VAL,";")
+5 ;
HLK(ULOC) ; EP - Get HRN data for a location
+1 NEW HDATA,IACT
+2 SET HDATA=$GET(^AUPNPAT(DFN,41,ULOC,0))
+3 SET HRN=$PIECE(HDATA,U,2)
SET IACT=$PIECE(HDATA,U,3)
+4 IF HRN=""
QUIT ""
+5 ;Inactive patient
IF IACT'=""
SET HRN=""
+6 QUIT HRN
+7 ;
TKO(STR,VAL) ;EP - Take off ending character
+1 ;
+2 ;Description
+3 ; This will take off the ending character at the end of
+4 ; a string
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; same STR without the ending character
+10 ;
+11 IF $GET(STR)=""
QUIT ""
+12 IF $GET(VAL)=""
QUIT ""
+13 ;
+14 NEW LV
+15 SET LV=$LENGTH(VAL)
+16 IF $EXTRACT(STR,$LENGTH(STR)-(LV-1),$LENGTH(STR))=VAL
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-LV)
+17 ;
+18 QUIT STR
+19 ;
+20 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 QUIT
