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