EDPFPTC ;SLC/MKB - Patient look-up Utilities at Facility ;4/16/13 12:24pm
;;2.0;EMERGENCY DEPARTMENT;**5**;May 2, 2012;Build 18
;
CHK(AREA,DFN,NAME) ; perform patient select checks
;
; check for active on board
N IEN,X0,CHK S NAME=$$UP^XLFSTR(NAME)
S IEN=0 F S IEN=$O(^EDP(230,"AC",EDPSITE,AREA,IEN)) Q:'IEN D Q:$D(CHK("onBoard"))
. S X0=^EDP(230,IEN,0)
. I DFN,($P(X0,U,6)=DFN) S CHK("onBoard")=$P(^DPT(DFN,0),U)
. I 'DFN,($E(NAME,1,10)'="(AMBULANCE"),($$UP^XLFSTR($P(X0,U,4))=NAME) S CHK("onBoard")=NAME
;
; stop here if no DFN
I 'DFN D Q
. S CHK("sensitive")=0,CHK("mayAccess")=1,CHK("logAccess")=0
. D XML^EDPX($$XMLA^EDPX("checks",.CHK,"/"))
;
; check for sensitive record
N EDPY,WARN,I,X
D PTSEC^DGSEC4(.EDPY,DFN,1) ;IA #3027
S CHK("dfn")=DFN
S CHK("sensitive")=(EDPY(1)>0)
S CHK("mayAccess")=(EDPY(1)<3)
S CHK("logAccess")=(EDPY(1)>1)
M WARN=EDPY K WARN(1)
;
; check for deceased patient
N DIED S DIED=0
I +$G(^DPT(DFN,.35)) D
. S DIED(1)="This patient died on "_$$FMTE^XLFDT(^DPT(DFN,.35),"D")_"."
. S DIED(2)="Do you wish to continue?"
;
; check for similar patients
K EDPY
N MSG,SIM S MSG=0,SIM=0
D GUIBS5A^DPTLK6(.EDPY,DFN) ;IA #3593
S CHK("similar")=(EDPY(1)>0)
S I=1 F S I=$O(EDPY(I)) Q:'I S X=EDPY(I) D
. I $E(X)=0 S MSG=MSG+1,MSG(MSG)=$P(X,U,2)
. I $E(X)=1 D
.. S X("dfn")=$P(X,U,2)
.. S X("name")=$P(X,U,3)
.. S X("dob")=$$FMTE^XLFDT($P(X,U,4),"D")
.. S X("ssn")=$P(X,U,5)
.. S SIM=SIM+1,SIM(SIM)=$$XMLA^EDPX("similar",.X,"/")
;
; possibly check means test: GUIMTD^DPTLK6
; possibly check legacy data: I $L($T(HXDATA^A7RDPAGU)...
;
; put it all together
D XML^EDPX($$XMLA^EDPX("checks",.CHK,"/"))
I $D(WARN) D
. D XML^EDPX("<warning>")
. S I=0 F S I=$O(WARN(I)) Q:'I D XML^EDPX(WARN(I))
. I CHK("logAccess"),CHK("mayAccess") D XML^EDPX("Are you sure you wish to continue?")
. D XML^EDPX("</warning>")
S I=0 F S I=$O(SIM(I)) Q:'I D XML^EDPX(SIM(I))
I $D(MSG) D
. D XML^EDPX("<warnSimilar>")
. S I=0 F S I=$O(MSG(I)) Q:'I D XML^EDPX(MSG(I))
. D XML^EDPX("</warnSimilar>")
I $D(DIED) D
. D XML^EDPX("<died>")
. S I=0 F S I=$O(DIED(I)) Q:'I D XML^EDPX(DIED(I))
. D XML^EDPX("</died>")
I CHK("mayAccess") D PRF(DFN)
Q
PRF(DFN) ; get Patient Record Flags
N EDPY,EDI,PRF,N,X
Q:$$GETACT^DGPFAPI(DFN,"EDPY")'>0
D XML^EDPX("<patientRecordFlags>")
S EDI=0 F S EDI=$O(EDPY(EDI)) Q:EDI<1 K PRF D
. S PRF("assignmentStatus")="Active"
. S PRF("assignTS")=$P($G(EDPY(EDI,"ASSIGNDT")),U)
. S PRF("approved")=$P($G(EDPY(EDI,"APPRVBY")),U,2)
. S PRF("nextReviewDT")=$P($G(EDPY(EDI,"REVIEWDT")),U)
. S PRF("name")=$P($G(EDPY(EDI,"FLAG")),U,2)
. S PRF("type")=$P($G(EDPY(EDI,"FLAGTYPE")),U,2)
. S PRF("category")=$P($G(EDPY(EDI,"CATEGORY")),U,2)
. S PRF("ownerSite")=$P($G(EDPY(EDI,"OWNER")),U,2)
. S PRF("originatingSite")=$P($G(EDPY(EDI,"ORIGSITE")),U,2)
. D XML^EDPX($$XMLA^EDPX("flag",.PRF,""))
. D XML^EDPX("<text>")
. S N=1,X=$G(EDPY(EDI,"NARR",1,0))
. ;bwf - 4/16/2013 - replaced next line with one that follows to fix multiple flag/multiple line issues
. ;F S N=$O(EDPY(EDI,"NARR",N)) Q:N<1 S X=X_$C(13,10)_$G(EDPY(EDI,"NARR",N,0))
. F S N=$O(EDPY(EDI,"NARR",N)) Q:N<1 S X=$G(EDPY(EDI,"NARR",N,0)) D XML^EDPX($$ESC^EDPX(X))
. ;bwf - 4/16/2013 - removed line due to multiple flag issues
. ;D XML^EDPX("<text>"_$$ESC^EDPX(X)_"</text>")
. ;bwf 4/16/2013 - added following line to build footer for patient record flag issues.
. D XML^EDPX("</text>")
. D XML^EDPX("</flag>")
D XML^EDPX("</patientRecordFlags>")
Q
;
LOG(DFN) ; Make entry in security log for sensitive patient access
N EDPY,X
D NOTICE^DGSEC4(.EDPY,DFN) ;IA #3027
S X=$S(EDPY:"ok",1:"fail")
D XML^EDPX("<save status='"_X_"' />")
Q
;
TEST ;
S EDPSITE=$$IEN^XUAF4(442),NAME="doe,john"
D CHK(1,"",NAME)
;N PID S EDPSITE=$$IEN^XUAF4(442)
;R "DFN:",PID Q:PID="" W !
;D CHK(1,PID,$P(^DPT(PID,0),U))
N I S I=0 F S I=$O(EDPXML(I)) Q:'I W !,EDPXML(I)
K EDPXML
Q
TEST1 ;
S EDPSITE=$$IEN^XUAF4(442),NAME="doe,john"
D CHK(1,"",NAME)
;
;DO LATER? -- linked progress notes
;D GETTITLE^TIUPRF2(.EDPT,DFN,EDI),GETNOTES^TIUPRF2(.EDPN,DFN,EDPT,1)
;I $O(EDPN(0)) D
;. D XML^EDPX("<notes>")
;. S N=0 F S N=$O(EDPN(N)) Q:N<1 K PN S X=EDPN(N) D
;.. S PN("id")=+X,PN("action")=$P(X,U,2),PN("author")=$P(X,U,4)
;.. S PN("noteTS")=9999999-N
;.. D TGET^TIUSRVR1(.EDPX,+X)
;.. S X=$$XMLA^EDPX("note",.PN),X=$TR(X,"/") D XML^EDPX(X)
;.. S I=1,X=$G(@EDPX@(1))
;.. F S I=$O(@EDPX@(I)) Q:I<1 S X=X_$C(13,10)_$G(@EDPX@(I))
;.. S X="<text>"_$$ESC^EDPX(X)_"</text>" D XML^EDPX(X)
;.. D XML^EDPX("</note>")
;. D XML^EDPX("</notes>")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPFPTC 4743 printed Dec 13, 2024@01:51:52 Page 2
EDPFPTC ;SLC/MKB - Patient look-up Utilities at Facility ;4/16/13 12:24pm
+1 ;;2.0;EMERGENCY DEPARTMENT;**5**;May 2, 2012;Build 18
+2 ;
CHK(AREA,DFN,NAME) ; perform patient select checks
+1 ;
+2 ; check for active on board
+3 NEW IEN,X0,CHK
SET NAME=$$UP^XLFSTR(NAME)
+4 SET IEN=0
FOR
SET IEN=$ORDER(^EDP(230,"AC",EDPSITE,AREA,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 SET X0=^EDP(230,IEN,0)
+6 IF DFN
IF ($PIECE(X0,U,6)=DFN)
SET CHK("onBoard")=$PIECE(^DPT(DFN,0),U)
+7 IF 'DFN
IF ($EXTRACT(NAME,1,10)'="(AMBULANCE")
IF ($$UP^XLFSTR($PIECE(X0,U,4))=NAME)
SET CHK("onBoard")=NAME
End DoDot:1
if $DATA(CHK("onBoard"))
QUIT
+8 ;
+9 ; stop here if no DFN
+10 IF 'DFN
Begin DoDot:1
+11 SET CHK("sensitive")=0
SET CHK("mayAccess")=1
SET CHK("logAccess")=0
+12 DO XML^EDPX($$XMLA^EDPX("checks",.CHK,"/"))
End DoDot:1
QUIT
+13 ;
+14 ; check for sensitive record
+15 NEW EDPY,WARN,I,X
+16 ;IA #3027
DO PTSEC^DGSEC4(.EDPY,DFN,1)
+17 SET CHK("dfn")=DFN
+18 SET CHK("sensitive")=(EDPY(1)>0)
+19 SET CHK("mayAccess")=(EDPY(1)<3)
+20 SET CHK("logAccess")=(EDPY(1)>1)
+21 MERGE WARN=EDPY
KILL WARN(1)
+22 ;
+23 ; check for deceased patient
+24 NEW DIED
SET DIED=0
+25 IF +$GET(^DPT(DFN,.35))
Begin DoDot:1
+26 SET DIED(1)="This patient died on "_$$FMTE^XLFDT(^DPT(DFN,.35),"D")_"."
+27 SET DIED(2)="Do you wish to continue?"
End DoDot:1
+28 ;
+29 ; check for similar patients
+30 KILL EDPY
+31 NEW MSG,SIM
SET MSG=0
SET SIM=0
+32 ;IA #3593
DO GUIBS5A^DPTLK6(.EDPY,DFN)
+33 SET CHK("similar")=(EDPY(1)>0)
+34 SET I=1
FOR
SET I=$ORDER(EDPY(I))
if 'I
QUIT
SET X=EDPY(I)
Begin DoDot:1
+35 IF $EXTRACT(X)=0
SET MSG=MSG+1
SET MSG(MSG)=$PIECE(X,U,2)
+36 IF $EXTRACT(X)=1
Begin DoDot:2
+37 SET X("dfn")=$PIECE(X,U,2)
+38 SET X("name")=$PIECE(X,U,3)
+39 SET X("dob")=$$FMTE^XLFDT($PIECE(X,U,4),"D")
+40 SET X("ssn")=$PIECE(X,U,5)
+41 SET SIM=SIM+1
SET SIM(SIM)=$$XMLA^EDPX("similar",.X,"/")
End DoDot:2
End DoDot:1
+42 ;
+43 ; possibly check means test: GUIMTD^DPTLK6
+44 ; possibly check legacy data: I $L($T(HXDATA^A7RDPAGU)...
+45 ;
+46 ; put it all together
+47 DO XML^EDPX($$XMLA^EDPX("checks",.CHK,"/"))
+48 IF $DATA(WARN)
Begin DoDot:1
+49 DO XML^EDPX("<warning>")
+50 SET I=0
FOR
SET I=$ORDER(WARN(I))
if 'I
QUIT
DO XML^EDPX(WARN(I))
+51 IF CHK("logAccess")
IF CHK("mayAccess")
DO XML^EDPX("Are you sure you wish to continue?")
+52 DO XML^EDPX("</warning>")
End DoDot:1
+53 SET I=0
FOR
SET I=$ORDER(SIM(I))
if 'I
QUIT
DO XML^EDPX(SIM(I))
+54 IF $DATA(MSG)
Begin DoDot:1
+55 DO XML^EDPX("<warnSimilar>")
+56 SET I=0
FOR
SET I=$ORDER(MSG(I))
if 'I
QUIT
DO XML^EDPX(MSG(I))
+57 DO XML^EDPX("</warnSimilar>")
End DoDot:1
+58 IF $DATA(DIED)
Begin DoDot:1
+59 DO XML^EDPX("<died>")
+60 SET I=0
FOR
SET I=$ORDER(DIED(I))
if 'I
QUIT
DO XML^EDPX(DIED(I))
+61 DO XML^EDPX("</died>")
End DoDot:1
+62 IF CHK("mayAccess")
DO PRF(DFN)
+63 QUIT
PRF(DFN) ; get Patient Record Flags
+1 NEW EDPY,EDI,PRF,N,X
+2 if $$GETACT^DGPFAPI(DFN,"EDPY")'>0
QUIT
+3 DO XML^EDPX("<patientRecordFlags>")
+4 SET EDI=0
FOR
SET EDI=$ORDER(EDPY(EDI))
if EDI<1
QUIT
KILL PRF
Begin DoDot:1
+5 SET PRF("assignmentStatus")="Active"
+6 SET PRF("assignTS")=$PIECE($GET(EDPY(EDI,"ASSIGNDT")),U)
+7 SET PRF("approved")=$PIECE($GET(EDPY(EDI,"APPRVBY")),U,2)
+8 SET PRF("nextReviewDT")=$PIECE($GET(EDPY(EDI,"REVIEWDT")),U)
+9 SET PRF("name")=$PIECE($GET(EDPY(EDI,"FLAG")),U,2)
+10 SET PRF("type")=$PIECE($GET(EDPY(EDI,"FLAGTYPE")),U,2)
+11 SET PRF("category")=$PIECE($GET(EDPY(EDI,"CATEGORY")),U,2)
+12 SET PRF("ownerSite")=$PIECE($GET(EDPY(EDI,"OWNER")),U,2)
+13 SET PRF("originatingSite")=$PIECE($GET(EDPY(EDI,"ORIGSITE")),U,2)
+14 DO XML^EDPX($$XMLA^EDPX("flag",.PRF,""))
+15 DO XML^EDPX("<text>")
+16 SET N=1
SET X=$GET(EDPY(EDI,"NARR",1,0))
+17 ;bwf - 4/16/2013 - replaced next line with one that follows to fix multiple flag/multiple line issues
+18 ;F S N=$O(EDPY(EDI,"NARR",N)) Q:N<1 S X=X_$C(13,10)_$G(EDPY(EDI,"NARR",N,0))
+19 FOR
SET N=$ORDER(EDPY(EDI,"NARR",N))
if N<1
QUIT
SET X=$GET(EDPY(EDI,"NARR",N,0))
DO XML^EDPX($$ESC^EDPX(X))
+20 ;bwf - 4/16/2013 - removed line due to multiple flag issues
+21 ;D XML^EDPX("<text>"_$$ESC^EDPX(X)_"</text>")
+22 ;bwf 4/16/2013 - added following line to build footer for patient record flag issues.
+23 DO XML^EDPX("</text>")
+24 DO XML^EDPX("</flag>")
End DoDot:1
+25 DO XML^EDPX("</patientRecordFlags>")
+26 QUIT
+27 ;
LOG(DFN) ; Make entry in security log for sensitive patient access
+1 NEW EDPY,X
+2 ;IA #3027
DO NOTICE^DGSEC4(.EDPY,DFN)
+3 SET X=$SELECT(EDPY:"ok",1:"fail")
+4 DO XML^EDPX("<save status='"_X_"' />")
+5 QUIT
+6 ;
TEST ;
+1 SET EDPSITE=$$IEN^XUAF4(442)
SET NAME="doe,john"
+2 DO CHK(1,"",NAME)
+3 ;N PID S EDPSITE=$$IEN^XUAF4(442)
+4 ;R "DFN:",PID Q:PID="" W !
+5 ;D CHK(1,PID,$P(^DPT(PID,0),U))
+6 NEW I
SET I=0
FOR
SET I=$ORDER(EDPXML(I))
if 'I
QUIT
WRITE !,EDPXML(I)
+7 KILL EDPXML
+8 QUIT
TEST1 ;
+1 SET EDPSITE=$$IEN^XUAF4(442)
SET NAME="doe,john"
+2 DO CHK(1,"",NAME)
+3 ;
+4 ;DO LATER? -- linked progress notes
+5 ;D GETTITLE^TIUPRF2(.EDPT,DFN,EDI),GETNOTES^TIUPRF2(.EDPN,DFN,EDPT,1)
+6 ;I $O(EDPN(0)) D
+7 ;. D XML^EDPX("<notes>")
+8 ;. S N=0 F S N=$O(EDPN(N)) Q:N<1 K PN S X=EDPN(N) D
+9 ;.. S PN("id")=+X,PN("action")=$P(X,U,2),PN("author")=$P(X,U,4)
+10 ;.. S PN("noteTS")=9999999-N
+11 ;.. D TGET^TIUSRVR1(.EDPX,+X)
+12 ;.. S X=$$XMLA^EDPX("note",.PN),X=$TR(X,"/") D XML^EDPX(X)
+13 ;.. S I=1,X=$G(@EDPX@(1))
+14 ;.. F S I=$O(@EDPX@(I)) Q:I<1 S X=X_$C(13,10)_$G(@EDPX@(I))
+15 ;.. S X="<text>"_$$ESC^EDPX(X)_"</text>" D XML^EDPX(X)
+16 ;.. D XML^EDPX("</note>")
+17 ;. D XML^EDPX("</notes>")
