Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BEHOPTCX

BEHOPTCX.m

Go to the documentation of this file. 
  1. BEHOPTCX ;MSC/IND/DKM - Patient Context Object ;29-Jun-2015 15:00;PLS
  1.  ;;1.1;BEH COMPONENTS;**004004,004005,004006,004007,004010,004011**;Mar 20, 2007
  1.  ;=================================================================
  1.  ; Selects patient & returns key information
  1.  ;  1    2   3   4    5      6    7    8      9       10     11  12 13  14  15  16     17     18      19
  1.  ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^VET^SENSITIVE^ADMITTED^HRN^SC^SC%^ICN^DOD^TS^PRIMTEAM^PRIMPRV^ATTND
  1. PTINFO(DATA,DFN,SLCT) ;
  1.  N X,CA,WL,RB,TS,DOD,AT,VT,VAEL,VAERR,VDT,LINE
  1.  K ^TMP("ORWPCE",$J)
  1.  Q:'$D(^DPT(+DFN,0))
  1.  S X=^DPT(DFN,0),WL=$P($G(^(.1)),U),RB=$P($G(^(.101)),U),CA=+$G(^(.105)),TS=+$G(^(.103)),DOD=+$G(^(.35)),AT=+$G(^(.1041)),VT=$G(^("VET"))
  1.  S DATA=$P(X,U,1,3)_U_$$FMTSSN($P(X,U,9))_U_U_WL_U_RB
  1.  S:$L(WL) $P(DATA,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",WL,0)),44))
  1.  S $P(DATA,U,8)=VT="Y"
  1.  S $P(DATA,U,9)=$$ISSENS(DFN)
  1.  S:CA $P(DATA,U,10)=$P($G(^DGPM(CA,0)),U)
  1.  S:'$D(IOST) IOST="P-OTHER"
  1.  I $G(DUZ("AG"))="I" D
  1.  .S $P(DATA,U,11)=$$HRN(DFN)
  1.  E  S $P(DATA,U,11)=$$EPI(DFN)
  1.  D ELIG^VADPT
  1.  S $P(DATA,U,12,13)=$P($G(VAEL(3)),U,1,2)
  1.  S $P(DATA,U,14)=$$ICN(DFN)
  1.  S $P(DATA,U,15)=DOD
  1.  S $P(DATA,U,16)=TS
  1.  S $P(DATA,U,17)=$P($$OUTPTTM^BEHOPTPC(DFN),U,2)
  1.  S $P(DATA,U,18)=$P($$OUTPTPR^BEHOPTPC(DFN),U,2)
  1.  S $P(DATA,U,19)=$S(AT:$P($G(^VA(200,AT,0)),U),1:"")
  1.  D:$G(SLCT) LAST(,DFN)
  1.  Q
  1.  ; Save/retrieve last patient selected for current institution
  1. LAST(DATA,DFN) ;
  1.  D:$$ISACTIVE($G(DFN)) EN^XPAR("USR","BEHOPTCX LAST PATIENT","`"_DUZ(2),"`"_DFN)
  1.  S DATA=$$GET^XPAR("USR","BEHOPTCX LAST PATIENT",DUZ(2),"I")
  1.  S:DATA ^DISV(DUZ,"^DPT(")=DATA
  1.  S:'$$GET^XPAR("ALL","BEHOPTCX RECALL LAST") DATA=""
  1.  Q
  1.  ; Return message if data on the legacy system
  1.  ; DATA(0)=1 if data,  DATA(n)=display message if data
  1. LEGACY(DATA,DFN) ;
  1.  S DATA(0)=0
  1.  I $L($T(HXDATA^A7RDPAGU)) D
  1.  .D HXDATA^A7RDPAGU(.DATA,DFN)
  1.  .S:$O(DATA(0)) DATA(0)=1
  1.  Q
  1.  ; Return a patient's current location
  1. INPLOC(DATA,DFN) ;
  1.  N X
  1.  S X=$G(^DPT(DFN,.102)),DATA=0
  1.  S:X X=$P($G(^DGPM(X,0)),U,6)
  1.  S:X DATA=+$G(^DIC(42,X,44)),$P(DATA,U,2)=$P($G(^DIC(42,X,0)),U),X=$P($G(^DIC(42,X,0)),U,3)
  1.  S $P(DATA,U,3)=X
  1.  Q
  1.  ; Returns true if selectable patient
  1. ISACTIVE(DFN,QUALS) ;EP
  1.  N X
  1.  S:'$D(DEMO) DEMO=+$$GET^XPAR("ALL","BEHOPTCX DEMO MODE",,"Q")
  1.  S X=$G(^DPT(+DFN,0))
  1.  Q:'$L(X)!$P(X,U,19) 0
  1.  I '$P(X,U,21),$$LKPQUAL("@BEHOPTCX DEMO MODE",.QUALS) Q 0
  1.  Q:$$LKPQUAL("MSC DG ALL SITES HIPAA",.QUALS) 1
  1.  Q:'$O(^AUPNPAT(DFN,41,0)) '$$LKPQUAL("@BEHOPTCX REQUIRES HRN",.QUALS)
  1.  Q ''$L($$HRN(DFN))
  1.  ; Return requested lookup qualifier
  1. LKPQUAL(QUAL,CACHE) ;EP
  1.  N RET
  1.  S RET=$G(CACHE(QUAL))
  1.  S:'$L(RET) (RET,CACHE(QUAL))=+$$HASKEY^BEHOUSCX(QUAL)
  1.  Q RET
  1.  ; Returns sensitive patient status
  1. ISSENS(DFN) ;
  1.  N RET
  1.  D PTSEC^DGSEC4(.RET,DFN,0)
  1.  Q $G(RET(1))
  1.  ; Get DFN from ICN
  1. ICN2DFN(DATA,ICN) ;
  1.  S DATA=$S($L($T(GETDFN^MPIF001)):$$GETDFN^MPIF001(ICN),1:"")
  1.  S:DATA<1 DATA=""
  1.  Q
  1.  ; Return ICN
  1. ICN(DFN) N X
  1.  S X=$S($L($T(GETICN^MPIF001)):+$$GETICN^MPIF001(DFN),1:"")
  1.  Q $S(X>0:X,1:"")
  1.  ; Return HRN given DFN
  1. HRN(DFN) ;EP
  1.  N X
  1.  S X=$G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0))
  1.  Q $S($P(X,U,3):"",1:$P(X,U,2))
  1.  ; Return MFN given DFN
  1. EPI(DFN) ;EP
  1.  Q $S($$TEST^CIAUOS("MSCDPTID"):$$^MSCDPTID(DFN),1:"")
  1.  ; Return formatted patient detail report
  1. PTINQ(DATA,DFN) ;
  1.  S DATA=$$TMPGBL^CIAVMRPC
  1.  D CAPTURE^CIAUHFS($TR($$GET^XPAR("ALL","BEHOPTCX DETAIL REPORT"),"~",U),DATA,80)
  1.  Q
  1.  ; Build Patient Inquiry
  1. PTINQB(DFN) ;
  1.  N DOC,TEAM,X,VAOA,PH,DOD,CAUSE,CAUSE2,NARR
  1.  S DOD=$$GET1^DIQ(2,DFN,.351)
  1.  I $L(DOD) D
  1.  .W !,"******** PATIENT IS DECEASED ************"
  1.  .W !,"Date of Death: ",DOD
  1.  .I DUZ("AG")="I" D
  1.  ..S CAUSE=$$GET1^DIQ(9000001,DFN,1114,"I")
  1.  ..;IHS/MSC/MGH Changed lookup for ICD-10
  1.  ..I $$AICD^BEHOENPC D
  1.  ...S CAUSE2=$P($$ICDDX^ICDEX(CAUSE,DOD),U,2)
  1.  ...S NARR=$P($$ICDDX^ICDEX(CAUSE,DOD),U,4)
  1.  ..E  D
  1.  ...S CAUSE2=$$GET1^DIQ(80,CAUSE,.01)
  1.  ...S NARR=$$GET1^DIQ(80,CAUSE,3)
  1.  ..W:$L(NARR) !,"Underlying Cause: ",CAUSE2_" ("_NARR_")"
  1.  D EN^BEHOPTC1                                                            ; mas patient inquiry
  1.  S DOC=$$OUTPTPR^BEHOPTPC(DFN)
  1.  S TEAM=$$OUTPTTM^BEHOPTPC(DFN)
  1.  I DOC!TEAM  D
  1.  .W !!,"Primary Care Information:"
  1.  .W:DOC !,"Primary Practitioner:  ",$P(DOC,U,2)
  1.  .W:TEAM !,"Primary Care Team:     ",$P(TEAM,U,2)
  1.  W !!,"Service Connection/Rated Disabilities:"
  1.  D DIS^DGRPDB
  1.  ;IHS/MSC/MGH Added EHR patch 8 Insurance
  1.  I DUZ("AG")="I" D
  1.  .S VDT="TODAY",VDT=$$DT^CIAU(VDT),LINE=""
  1.  .I $$MCR^AUPNPAT(DFN,VDT)=1 S LINE="MEDICARE #"_$$MCR^BTIULO2(DFN)_"/"
  1.  .I $$MCD^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"MEDICAID #"_$$MCD^BTIULO2(DFN)_"/"
  1.  .I $$PI^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"PVT INS ("_$$PIN^AUPNPAT(DFN,VDT,"E")_")/"
  1.  .I LINE]"" D
  1.  ..W !!,"INSURANCE:"
  1.  ..W !,?5,$E(LINE,1,$L(LINE)-1)
  1.  E  D
  1.  .D DISP^DGIBDSP
  1.  ;Added EHR patch 7
  1.  I DUZ("AG")="I" D
  1.  .S PH=$$GET1^DIQ(9000001,DFN,1801)
  1.  .I PH'="" W !!,"Other Phone Contact: "_PH
  1.  D OAD^VADPT                                                           ; get NOK address
  1.  D:$L(VAOA(9))
  1.  .W !!,"Next of Kin Information:"
  1.  .W !,"Name:  ",VAOA(9)                                                ; nok name
  1.  .W:$L(VAOA(10)) " (",VAOA(10),")"                                     ; relationship
  1.  .W:$L(VAOA(1)) !?7,VAOA(1)                                            ; address line 1
  1.  .W:$L(VAOA(2)) !?7,VAOA(2)                                            ; line 2
  1.  .W:$L(VAOA(3)) !?7,VAOA(3)                                            ; line 3
  1.  .D:$L(VAOA(4))
  1.  ..W !?7,VAOA(4)                                                       ; city
  1.  ..W:$L(VAOA(5)) ", "_$P(VAOA(5),U,2)                                  ; state
  1.  ..W "  ",$P(VAOA(11),U,2)                                             ; zip+4
  1.  .W:$L(VAOA(8)) !!?7,"Phone number:  ",VAOA(8)                         ; phone
  1.  ;IHS/MSC/MGH Find Language Data Patch 8
  1.  I DUZ("AG")="I" D
  1.  .N PRILAN,PRETER,PREFLAN,PROF,LANDT,IEN
  1.  .S LANDT=9999999 S LANDT=$O(^AUPNPAT(DFN,86,LANDT),-1) Q:LANDT=""  D
  1.  ..S IEN=LANDT_","_DFN
  1.  ..S PRILAN=$$GET1^DIQ(9000001.86,IEN,.02)
  1.  ..S PRETER=$$GET1^DIQ(9000001.86,IEN,.03)
  1.  ..S PREFLAN=$$GET1^DIQ(9000001.86,IEN,.04)
  1.  ..S PROF=$$GET1^DIQ(9000001.86,IEN,.06)
  1.  ..W !!,"Language Information:"
  1.  ..W:$L(PRILAN) !?5,"Primary Language: ",PRILAN
  1.  ..W:$L(PRETER) ?40,"Interpreter Needed: ",PRETER
  1.  ..W:$L(PREFLAN) !,?5,"Preferred Language: ",PREFLAN
  1.  ..W:$L(PROF) ?40,"English Proficiency: ",PROF
  1.  ;IHS/MSC/MGH Communication method
  1.  I DUZ("AG")="I" D
  1.  .N MOC,GEN
  1.  .W !!,"METHOD OF COMMUNICATION:"
  1.  .S GEN=$$GET1^DIQ(9000001,DFN,4001)
  1.  .S MOC=$$GET1^DIQ(9000001,DFN,4002)
  1.  .I GEN'="" W !?5,"PERMISSION FOR E-MAIL: "_GEN
  1.  .I MOC'="" W !?5,"PREFERRED METHOD: "_MOC
  1.  D KVAR^VADPT
  1.  K PRILAN,PRETER,LANDT,PREFLAN,PROF
  1.  Q
  1. SETCTX(DFN) ;PEP - Set the patient context
  1.  N UID
  1.  S UID=$$GETUID^CIANBUTL
  1.  D:$L(UID) QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN,UID)
  1.  Q:$Q ''$L(UID)
  1.  Q
  1.  ; Check for possible dups
  1. CHKDUP(DATA,DFN) ; EP
  1.  N DUPS,CNT,X
  1.  D GUIBS5A^DPTLK6(.DUPS,DFN)
  1.  I DUPS(1)<1 M DATA=DUPS Q
  1.  F X=1:0 S X=$O(DUPS(X)) Q:'X  D
  1.  .I 'DUPS(X) K DUPS(X) Q
  1.  .I $P(DUPS(X),U,2)=DFN D
  1.  ..S DUPS(1)=$$CD1(DUPS(X))
  1.  ..K DUPS(X)
  1.  .E  S DUPS(X)=$$CD1(DUPS(X))
  1.  S CNT=0
  1.  D CD2(1),CD2("You have selected the following patient:"),CD2(DUPS(1)),CD2()
  1.  D CD2("However, these patients also have the same last name")
  1.  D CD2("and the same last 4 digits of their SSNs:"),CD2()
  1.  F X=1:0 S X=$O(DUPS(X)) Q:'X  D CD2(DUPS(X))
  1.  D CD2(),CD2("Are you sure this is the correct patient?")
  1.  Q
  1. CD1(VAL) Q $P(VAL,U,3)_"   DOB: "_$$ENTRY^CIAUDT($P(VAL,U,4))_"   SSN: "_$$FMTSSN($P(VAL,U,5))_"   HRN: "_$$HRN($P(VAL,U,2))
  1. CD2(VAL) S CNT=CNT+1,DATA(CNT)=$G(VAL)
  1.  Q
  1.  ;
  1. FMTSSN(SSN) ;EP - P7
  1.  N X
  1.  S X=$E(SSN,6,$L(SSN))
  1.  Q "XXX-XX-"_$S($L(X):X,1:"XXXX")
  1.  ; Fires CONTEXT.PATIENT event to notify client that an ADT event has occurred
  1. CXADTEVT(DFN,DGPMT) ;EP-
  1.  I DGPMT=1!(DGPMT=3) D
  1.  .F  Q:'$$NXTUID^CIANBUTL(.X,-1,.AID)  D
  1.  ..S:+$$GETVAR^CIANBUTL("PATIENT.ID.MRN","","CONTEXT.PATIENT",X)=DFN LST("UID",X)=""
  1.  .S X="" F  S X=$O(LST("UID",X)) Q:'X  D
  1.  ..D:X QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN_U_"ADT:"_DGPMT,X)
  1.  Q
  1.  ; Fire Admit Encounter Context to set to passed VistStr
  1. FIREVST(DATA,DFN) ;EP-
  1.  S DATA=$$SETCTX^BEHOENCX($P($$ADMITINF^BEHOENCX(DFN,+$G(^DPT(DFN,.105))),U))
  1.  Q