- 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 Feb 18, 2025@23:18:17 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>")