BGPGP ; IHS/CMI/MAW - BGPG Patient Lookup 4/28/2009 12:43:21 PM ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;;
;
;
;
Q
GETPAT(RETVAL,BGPSTR) ;EP -- return patient in ADO table
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPERRR,BGPUIEN,P
S P="|"
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPERRR=""
S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$C(30)
S BGPDUZ2=$P(BGPSTR,P)
S BGPPAT=$P(BGPSTR,P,2)
S BGPMT=$P(BGPSTR,P,3)
I BGPMT="" S BGPMT=99999
S BGPNPAT=$P(BGPSTR,P,4)
I '$G(BGPDUZ2) S BGPDUZ2=DUZ(2)
;I BGPNPAT]"" S BGPPAT=BGPNPAT ;cmi/maw 3/12/09 for testing
I BGPMT="ALL" S BGPMT=9999999
S BGPMT=(BGPMT-1)
I BGPPAT?9N D
. S BGPPIEN=$$PATSSN(BGPPAT)
I BGPPAT?1.6N D
. S BGPPIEN=$$PATCHT(.BGPPIEN,BGPPAT)
I BGPPAT?1.2N1"/"1.2N1"/"4N D
. S X=BGPPAT D ^%DT S BGPPAT=Y
. S BGPPIEN=$$PATDOB(.BGPPIEN,BGPPAT)
I '$G(BGPPIEN) D PATNAM(.BGPPIEN,BGPPAT,BGPNPAT)
I $G(BGPPIEN),'$G(BGPPATS) D PATADO(.BGPPIEN)
S ^BGPTMP($J,BGPI+1)=$C(31)
K BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN,BGPDOD,BGPMORE,BGPAGE,BGPCNTR,BGPDG,BGPDUZ2,BGPMT,BGPNAM
K BGPPATS,BGPNPAT,BGPPI,BGPUPD
Q
;
PATSSN(PAT) ;EP -- look up by ssn
S BGPPIEN=$O(^DPT("SSN",PAT,0))
S BGPPIEN(1)=BGPPIEN
Q $G(BGPPIEN)
;
PATCHT(BGPPIEN,PAT) ;EP -- lookup by chart
;ihs/cmi/maw 2/2/2011 added fix for same patient with same chart in multiple divisions
N BGPCNT,BGPOEN
S BGPCNT=0,BGPPATE=0,BGPMCNT=0
S BGPDA=(PAT-1) F S BGPDA=$O(^AUPNPAT("D",BGPDA)) Q:'BGPDA!(BGPDA>PAT)!(BGPCNT>BGPMT) D
. S BGPIEN=0 F S BGPIEN=$O(^AUPNPAT("D",BGPDA,BGPIEN)) Q:'BGPIEN D
.. S BGPOEN=0 F S BGPOEN=$O(^AUPNPAT("D",BGPDA,BGPIEN,BGPOEN)) Q:'BGPOEN!($G(BGPPIEN)) D
... ;I $O(^AUPNPAT("D",BGPDA,BGPIEN,0))=BGPDUZ2 S BGPPIEN=BGPIEN
... I BGPOEN=BGPDUZ2 S BGPPIEN=BGPIEN
... Q:'$G(BGPPIEN)
... S BGPCNT=BGPCNT+1
... S:'$D(BGPPIEN(BGPCNT)) BGPPIEN(BGPCNT)=0
... S BGPPIEN(BGPCNT)=BGPPIEN
Q $G(BGPPIEN)
;
PATDOB(BGPPATE,PAT) ;EP -- lookup by DOB
N BGPCNT
S BGPCNT=0,BGPPATE=0
S BGPDOB=PAT-1 F S BGPDOB=$O(^DPT("ADOB",BGPDOB)) Q:'BGPDOB!(BGPDOB'=+PAT)!(BGPCNT>BGPMT) D
. S BGPIEN=0 F S BGPIEN=$O(^DPT("ADOB",BGPDOB,BGPIEN)) Q:'BGPIEN D
.. S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
.. S BGPCNT=BGPCNT+1,BGPPATE=1
.. S BGPPATE(BGPCNT)=BGPIEN
S BGPPATE=BGPCNT
Q $G(BGPPATE)
;
PATNAM(BGPPATE,PAT,NPAT) ;lookup by name
S BGPCNT=0,BGPPATE=0
N BGPLEN
S BGPLEN=$L(PAT)
S BGPNAM=PAT
S BGPNAM=$$BEGIN(PAT)
I $G(NPAT)]"" S BGPNAM=NPAT
F S BGPNAM=$O(^DPT("B",BGPNAM)) Q:BGPNAM=""!($E(BGPNAM,1,BGPLEN)'=PAT) D
. S BGPIEN=0 F S BGPIEN=$O(^DPT("B",BGPNAM,BGPIEN)) Q:'BGPIEN D
.. N BGPOEN
.. I $O(^DPT("B",BGPNAM,BGPIEN,0)) D
... S BGPOEN=0 F S BGPOEN=$O(^DPT("B",BGPNAM,BGPIEN,BGPOEN)) Q:'BGPOEN D
.... ;Q:$O(^DPT("B",BGPNAM,BGPIEN,0)) ;cmi/maw 4/25/2005 don't get aliases
.... S BGPCNT=BGPCNT+1
.... S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
.... S BGPPATE(BGPCNT)=BGPIEN_U_BGPNAM
.. I '$O(^DPT("B",BGPNAM,BGPIEN,0)) D
... S BGPCNT=BGPCNT+1
... S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
... S BGPPATE(BGPCNT)=BGPIEN
S BGPPATE=BGPCNT
Q $G(BGPPATE)
;
BEGIN(PT) ;EP -- get begin point
N BGPPDA,BGPPIEN,BGPPCNT
S BGPPCNT=0
S BGPPDA=PT
I $O(^DPT("B",BGPPDA,0)) D
. S BGPPDA=$O(^DPT("B",BGPPDA),-1)
F S BGPPDA=$O(^DPT("B",BGPPDA)) Q
I $G(BGPPDA)="" Q ""
Q $O(^DPT("B",BGPPDA),-1)
;
PATADO(PIEN) ;EP -- ado return
S BGPCNTR=0
S BGPDA=0 F S BGPDA=$O(PIEN(BGPDA)) Q:'BGPDA D
. S BGPPI=$P($G(PIEN(BGPDA)),U)
. S BGPAL=$P($G(PIEN(BGPDA)),U,2)
. ;D PTSEC^DGSEC4(.BGPDG,BGPPI,0) ;logs patient, cant do here
. D DGSEC(.BGPDG,BGPPI,DUZ,0) ;don't log patient but get sensitivity info for patient lookup
. N BGPDGMSG,BGPFLAG
. I $G(BGPDG(1)) D
.. S BGPFLAG=BGPDG(1)
.. N BGPDGDA
.. S BGPDGMSG=""
.. S BGPDGDA=1 F S BGPDGDA=$O(BGPDG(BGPDGDA)) Q:'BGPDGDA D
... I $E(BGPDG(BGPDGDA),1,3)="* *" Q
... S BGPDGMSG=BGPDGMSG_" "_$G(BGPDG(BGPDGDA))
. S BGPDGMSG=$TR($G(BGPDGMSG),"*")
. I BGPCNTR>BGPMT Q
. S BGPCNTR=BGPCNTR+1
. S BGPNM=$S(BGPAL]"":BGPAL_" ",1:"")_$P($G(^DPT(BGPPI,0)),U)
. ;S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPPI,0)),U,3))
. S BGPDB=$$LVDT($P($G(^DPT(BGPPI,0)),U,3))
. I $G(BGPFLAG),$G(BGPFLAG)'=4,$G(BGPFLAG)'=3 S BGPDB="**SENSITIVE**"
. S BGPSX=$P($G(^DPT(BGPPI,0)),U,2)
. S BGPCT=$$HRN^AUPNPAT(BGPPI,BGPDUZ2)
. S BGPSSN=$P($G(^DPT(BGPPI,0)),U,9)
. I BGPSSN]"" D
.. N LN
.. S LN=$L(BGPSSN)
.. S BGPSSN="XXX-XX-"_$E(BGPSSN,(LN-3),LN)
. I $G(BGPFLAG),$G(BGPFLAG)'=4,$G(BGPFLAG)'=3 S BGPSSN="**SENSITIVE**"
. S BGPUPD=$P($G(^AUPNPAT(BGPPI,0)),U,3) ;cmi/maw 5/17/2007 added last reg update
. ;S BGPELG=$$GET1^DIQ(9000001,BGPPI,1111) ;cmi/maw 5/17/2007 added class/ben for status bar
. S BGPDOD=$S($P($G(^DPT(BGPPI,.35)),U):$$LVDT($P($G(^DPT(BGPPI,.35)),U)),1:"")
. S BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
. I $G(BGPFLAG) S BGPAGE="**SENSITIVE**"
. I '$G(BGPFLAG),$$GET1^DIQ(43,1,9999999.01)="YES" S BGPFLAG=9 ;ihs/cmi/maw 12/6/2010 for track all patients spt
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPPI_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_$G(BGPHD)_U_$G(BGPMORE)_U_BGPDOD_U_BGPAGE_U_$G(BGPFLAG)_U_$E(BGPDGMSG,1,2500)_$C(30)
Q
;
PATSTR(RETVAL,BGPSTR) ;EP -- return the patient demographic information
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPERRR,BGPUIEN,P
S P="|"
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPERRR=""
S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$C(30)
S BGPPAT(1)=$P(BGPSTR,P,2)
S BGPDUZ2=$P(BGPSTR,P)
S BGPMT=9999999
D PATADO(.BGPPAT)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
LOGPAT(RETVAL,BGPSTR) ;-- log sensitive patient information
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPERRR,BGPPAT,P,BGPFLAG,BGPDGMSG,BGPDGDA,RESULT
S P="|"
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPPAT=$P(BGPSTR,P)
D DGSEC(.RESULT,BGPPAT,DUZ,0) ;cmi/maw 3/4/2010 logging takes place in NOTICE^DGSEC4
I $G(RESULT(1))=4 S BGPFLAG=1
I $G(RESULT(1))=3 S BGPFLAG=1
I '$G(BGPFLAG),$G(RESULT(1))'=0 D NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",3)
I $G(RESULT(1))=0,$$GET1^DIQ(43,1,9999999.01)="YES" D ;ihs/cmi/maw 12/6/2010 added for track all
. D NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",$S($P($G(^DGSL(38.1,BGPPAT,0)),U,2):3,1:1))
S @RETVAL@(BGPI)="T00001Return"_$C(30)
S BGPI=BGPI+1
S @RETVAL@(BGPI)=$G(RESULT)_$C(30)
S @RETVAL@(BGPI+1)=$C(31)
Q
;
DGSEC(RESULT,DFN,DUZ,DGMSG) ;EP -- mock the dgsec call but dont log, couldnt find a way to call PTSEC^DGSEC4 without logging
S DGMSG=$G(DGMSG,1)
I $$STATUS^BDGSPT2(DUZ,DFN,1)["RESTRICTED ACCESS" D Q
.S RESULT(1)=5 Q:DGMSG'=1
.S RESULT(2)="Sorry, you are restricted from accessing this patient's record."
.S RESULT(3)="If you have questions, please contact your HIM department."
D OWNREC^DGSEC4(.RESULT,DFN,$G(DUZ),DGMSG)
I RESULT(1)=1 S RESULT(1)=3 Q
I RESULT(1)=2 S RESULT(1)=4 Q
K RESULT
D SENS^DGSEC4(.RESULT,DFN,$G(DUZ))
Q
;
LVDT(PDT) ;EP - return date for list view format
I PDT="" Q ""
Q $E(PDT,4,5)_"/"_$E(PDT,6,7)_"/"_($E(PDT,1,3)+1700)
;
BGPGP ; IHS/CMI/MAW - BGPG Patient Lookup 4/28/2009 12:43:21 PM ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;;
+3 ;
+4 ;
+5 ;
+6 QUIT
GETPAT(RETVAL,BGPSTR) ;EP -- return patient in ADO table
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPERRR,BGPUIEN,P
+3 SET P="|"
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPERRR=""
+8 SET ^BGPTMP($JOB,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$CHAR(30)
+9 SET BGPDUZ2=$PIECE(BGPSTR,P)
+10 SET BGPPAT=$PIECE(BGPSTR,P,2)
+11 SET BGPMT=$PIECE(BGPSTR,P,3)
+12 IF BGPMT=""
SET BGPMT=99999
+13 SET BGPNPAT=$PIECE(BGPSTR,P,4)
+14 IF '$GET(BGPDUZ2)
SET BGPDUZ2=DUZ(2)
+15 ;I BGPNPAT]"" S BGPPAT=BGPNPAT ;cmi/maw 3/12/09 for testing
+16 IF BGPMT="ALL"
SET BGPMT=9999999
+17 SET BGPMT=(BGPMT-1)
+18 IF BGPPAT?9N
Begin DoDot:1
+19 SET BGPPIEN=$$PATSSN(BGPPAT)
End DoDot:1
+20 IF BGPPAT?1.6N
Begin DoDot:1
+21 SET BGPPIEN=$$PATCHT(.BGPPIEN,BGPPAT)
End DoDot:1
+22 IF BGPPAT?1.2N1"/"1.2N1"/"4N
Begin DoDot:1
+23 SET X=BGPPAT
DO ^%DT
SET BGPPAT=Y
+24 SET BGPPIEN=$$PATDOB(.BGPPIEN,BGPPAT)
End DoDot:1
+25 IF '$GET(BGPPIEN)
DO PATNAM(.BGPPIEN,BGPPAT,BGPNPAT)
+26 IF $GET(BGPPIEN)
IF '$GET(BGPPATS)
DO PATADO(.BGPPIEN)
+27 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+28 KILL BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN,BGPDOD,BGPMORE,BGPAGE,BGPCNTR,BGPDG,BGPDUZ2,BGPMT,BGPNAM
+29 KILL BGPPATS,BGPNPAT,BGPPI,BGPUPD
+30 QUIT
+31 ;
PATSSN(PAT) ;EP -- look up by ssn
+1 SET BGPPIEN=$ORDER(^DPT("SSN",PAT,0))
+2 SET BGPPIEN(1)=BGPPIEN
+3 QUIT $GET(BGPPIEN)
+4 ;
PATCHT(BGPPIEN,PAT) ;EP -- lookup by chart
+1 ;ihs/cmi/maw 2/2/2011 added fix for same patient with same chart in multiple divisions
+2 NEW BGPCNT,BGPOEN
+3 SET BGPCNT=0
SET BGPPATE=0
SET BGPMCNT=0
+4 SET BGPDA=(PAT-1)
FOR
SET BGPDA=$ORDER(^AUPNPAT("D",BGPDA))
IF 'BGPDA!(BGPDA>PAT)!(BGPCNT>BGPMT)
QUIT
Begin DoDot:1
+5 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^AUPNPAT("D",BGPDA,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+6 SET BGPOEN=0
FOR
SET BGPOEN=$ORDER(^AUPNPAT("D",BGPDA,BGPIEN,BGPOEN))
IF 'BGPOEN!($GET(BGPPIEN))
QUIT
Begin DoDot:3
+7 ;I $O(^AUPNPAT("D",BGPDA,BGPIEN,0))=BGPDUZ2 S BGPPIEN=BGPIEN
+8 IF BGPOEN=BGPDUZ2
SET BGPPIEN=BGPIEN
+9 IF '$GET(BGPPIEN)
QUIT
+10 SET BGPCNT=BGPCNT+1
+11 IF '$DATA(BGPPIEN(BGPCNT))
SET BGPPIEN(BGPCNT)=0
+12 SET BGPPIEN(BGPCNT)=BGPPIEN
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT $GET(BGPPIEN)
+14 ;
PATDOB(BGPPATE,PAT) ;EP -- lookup by DOB
+1 NEW BGPCNT
+2 SET BGPCNT=0
SET BGPPATE=0
+3 SET BGPDOB=PAT-1
FOR
SET BGPDOB=$ORDER(^DPT("ADOB",BGPDOB))
IF 'BGPDOB!(BGPDOB'=+PAT)!(BGPCNT>BGPMT)
QUIT
Begin DoDot:1
+4 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^DPT("ADOB",BGPDOB,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+5 IF '$DATA(BGPPATE(BGPCNT))
SET BGPPATE(BGPCNT)=0
+6 SET BGPCNT=BGPCNT+1
SET BGPPATE=1
+7 SET BGPPATE(BGPCNT)=BGPIEN
End DoDot:2
End DoDot:1
+8 SET BGPPATE=BGPCNT
+9 QUIT $GET(BGPPATE)
+10 ;
PATNAM(BGPPATE,PAT,NPAT) ;lookup by name
+1 SET BGPCNT=0
SET BGPPATE=0
+2 NEW BGPLEN
+3 SET BGPLEN=$LENGTH(PAT)
+4 SET BGPNAM=PAT
+5 SET BGPNAM=$$BEGIN(PAT)
+6 IF $GET(NPAT)]""
SET BGPNAM=NPAT
+7 FOR
SET BGPNAM=$ORDER(^DPT("B",BGPNAM))
IF BGPNAM=""!($EXTRACT(BGPNAM,1,BGPLEN)'=PAT)
QUIT
Begin DoDot:1
+8 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^DPT("B",BGPNAM,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+9 NEW BGPOEN
+10 IF $ORDER(^DPT("B",BGPNAM,BGPIEN,0))
Begin DoDot:3
+11 SET BGPOEN=0
FOR
SET BGPOEN=$ORDER(^DPT("B",BGPNAM,BGPIEN,BGPOEN))
IF 'BGPOEN
QUIT
Begin DoDot:4
+12 ;Q:$O(^DPT("B",BGPNAM,BGPIEN,0)) ;cmi/maw 4/25/2005 don't get aliases
+13 SET BGPCNT=BGPCNT+1
+14 IF '$DATA(BGPPATE(BGPCNT))
SET BGPPATE(BGPCNT)=0
+15 SET BGPPATE(BGPCNT)=BGPIEN_U_BGPNAM
End DoDot:4
End DoDot:3
+16 IF '$ORDER(^DPT("B",BGPNAM,BGPIEN,0))
Begin DoDot:3
+17 SET BGPCNT=BGPCNT+1
+18 IF '$DATA(BGPPATE(BGPCNT))
SET BGPPATE(BGPCNT)=0
+19 SET BGPPATE(BGPCNT)=BGPIEN
End DoDot:3
End DoDot:2
End DoDot:1
+20 SET BGPPATE=BGPCNT
+21 QUIT $GET(BGPPATE)
+22 ;
BEGIN(PT) ;EP -- get begin point
+1 NEW BGPPDA,BGPPIEN,BGPPCNT
+2 SET BGPPCNT=0
+3 SET BGPPDA=PT
+4 IF $ORDER(^DPT("B",BGPPDA,0))
Begin DoDot:1
+5 SET BGPPDA=$ORDER(^DPT("B",BGPPDA),-1)
End DoDot:1
+6 FOR
SET BGPPDA=$ORDER(^DPT("B",BGPPDA))
QUIT
+7 IF $GET(BGPPDA)=""
QUIT ""
+8 QUIT $ORDER(^DPT("B",BGPPDA),-1)
+9 ;
PATADO(PIEN) ;EP -- ado return
+1 SET BGPCNTR=0
+2 SET BGPDA=0
FOR
SET BGPDA=$ORDER(PIEN(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+3 SET BGPPI=$PIECE($GET(PIEN(BGPDA)),U)
+4 SET BGPAL=$PIECE($GET(PIEN(BGPDA)),U,2)
+5 ;D PTSEC^DGSEC4(.BGPDG,BGPPI,0) ;logs patient, cant do here
+6 ;don't log patient but get sensitivity info for patient lookup
DO DGSEC(.BGPDG,BGPPI,DUZ,0)
+7 NEW BGPDGMSG,BGPFLAG
+8 IF $GET(BGPDG(1))
Begin DoDot:2
+9 SET BGPFLAG=BGPDG(1)
+10 NEW BGPDGDA
+11 SET BGPDGMSG=""
+12 SET BGPDGDA=1
FOR
SET BGPDGDA=$ORDER(BGPDG(BGPDGDA))
IF 'BGPDGDA
QUIT
Begin DoDot:3
+13 IF $EXTRACT(BGPDG(BGPDGDA),1,3)="* *"
QUIT
+14 SET BGPDGMSG=BGPDGMSG_" "_$GET(BGPDG(BGPDGDA))
End DoDot:3
End DoDot:2
+15 SET BGPDGMSG=$TRANSLATE($GET(BGPDGMSG),"*")
+16 IF BGPCNTR>BGPMT
QUIT
+17 SET BGPCNTR=BGPCNTR+1
+18 SET BGPNM=$SELECT(BGPAL]"":BGPAL_" ",1:"")_$PIECE($GET(^DPT(BGPPI,0)),U)
+19 ;S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPPI,0)),U,3))
+20 SET BGPDB=$$LVDT($PIECE($GET(^DPT(BGPPI,0)),U,3))
+21 IF $GET(BGPFLAG)
IF $GET(BGPFLAG)'=4
IF $GET(BGPFLAG)'=3
SET BGPDB="**SENSITIVE**"
+22 SET BGPSX=$PIECE($GET(^DPT(BGPPI,0)),U,2)
+23 SET BGPCT=$$HRN^AUPNPAT(BGPPI,BGPDUZ2)
+24 SET BGPSSN=$PIECE($GET(^DPT(BGPPI,0)),U,9)
+25 IF BGPSSN]""
Begin DoDot:2
+26 NEW LN
+27 SET LN=$LENGTH(BGPSSN)
+28 SET BGPSSN="XXX-XX-"_$EXTRACT(BGPSSN,(LN-3),LN)
End DoDot:2
+29 IF $GET(BGPFLAG)
IF $GET(BGPFLAG)'=4
IF $GET(BGPFLAG)'=3
SET BGPSSN="**SENSITIVE**"
+30 ;cmi/maw 5/17/2007 added last reg update
SET BGPUPD=$PIECE($GET(^AUPNPAT(BGPPI,0)),U,3)
+31 ;S BGPELG=$$GET1^DIQ(9000001,BGPPI,1111) ;cmi/maw 5/17/2007 added class/ben for status bar
+32 SET BGPDOD=$SELECT($PIECE($GET(^DPT(BGPPI,.35)),U):$$LVDT($PIECE($GET(^DPT(BGPPI,.35)),U)),1:"")
+33 SET BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
+34 IF $GET(BGPFLAG)
SET BGPAGE="**SENSITIVE**"
+35 ;ihs/cmi/maw 12/6/2010 for track all patients spt
IF '$GET(BGPFLAG)
IF $$GET1^DIQ(43,1,9999999.01)="YES"
SET BGPFLAG=9
+36 SET BGPI=BGPI+1
+37 SET ^BGPTMP($JOB,BGPI)=BGPPI_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_$GET(BGPHD)_U_$GET(BGPMORE)_U_BGPDOD_U_BGPAGE_U_$GET(BGPFLAG)_U_$EXTRACT(BGPDGMSG,1,2500)_$CHAR(30)
End DoDot:1
+38 QUIT
+39 ;
PATSTR(RETVAL,BGPSTR) ;EP -- return the patient demographic information
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPERRR,BGPUIEN,P
+3 SET P="|"
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPERRR=""
+8 SET ^BGPTMP($JOB,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$CHAR(30)
+9 SET BGPPAT(1)=$PIECE(BGPSTR,P,2)
+10 SET BGPDUZ2=$PIECE(BGPSTR,P)
+11 SET BGPMT=9999999
+12 DO PATADO(.BGPPAT)
+13 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+14 QUIT
+15 ;
LOGPAT(RETVAL,BGPSTR) ;-- log sensitive patient information
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPERRR,BGPPAT,P,BGPFLAG,BGPDGMSG,BGPDGDA,RESULT
+3 SET P="|"
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPPAT=$PIECE(BGPSTR,P)
+8 ;cmi/maw 3/4/2010 logging takes place in NOTICE^DGSEC4
DO DGSEC(.RESULT,BGPPAT,DUZ,0)
+9 IF $GET(RESULT(1))=4
SET BGPFLAG=1
+10 IF $GET(RESULT(1))=3
SET BGPFLAG=1
+11 IF '$GET(BGPFLAG)
IF $GET(RESULT(1))'=0
DO NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",3)
+12 ;ihs/cmi/maw 12/6/2010 added for track all
IF $GET(RESULT(1))=0
IF $$GET1^DIQ(43,1,9999999.01)="YES"
Begin DoDot:1
+13 DO NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",$SELECT($PIECE($GET(^DGSL(38.1,BGPPAT,0)),U,2):3,1:1))
End DoDot:1
+14 SET @RETVAL@(BGPI)="T00001Return"_$CHAR(30)
+15 SET BGPI=BGPI+1
+16 SET @RETVAL@(BGPI)=$GET(RESULT)_$CHAR(30)
+17 SET @RETVAL@(BGPI+1)=$CHAR(31)
+18 QUIT
+19 ;
DGSEC(RESULT,DFN,DUZ,DGMSG) ;EP -- mock the dgsec call but dont log, couldnt find a way to call PTSEC^DGSEC4 without logging
+1 SET DGMSG=$GET(DGMSG,1)
+2 IF $$STATUS^BDGSPT2(DUZ,DFN,1)["RESTRICTED ACCESS"
Begin DoDot:1
+3 SET RESULT(1)=5
IF DGMSG'=1
QUIT
+4 SET RESULT(2)="Sorry, you are restricted from accessing this patient's record."
+5 SET RESULT(3)="If you have questions, please contact your HIM department."
End DoDot:1
QUIT
+6 DO OWNREC^DGSEC4(.RESULT,DFN,$GET(DUZ),DGMSG)
+7 IF RESULT(1)=1
SET RESULT(1)=3
QUIT
+8 IF RESULT(1)=2
SET RESULT(1)=4
QUIT
+9 KILL RESULT
+10 DO SENS^DGSEC4(.RESULT,DFN,$GET(DUZ))
+11 QUIT
+12 ;
LVDT(PDT) ;EP - return date for list view format
+1 IF PDT=""
QUIT ""
+2 QUIT $EXTRACT(PDT,4,5)_"/"_$EXTRACT(PDT,6,7)_"/"_($EXTRACT(PDT,1,3)+1700)
+3 ;
