BGP8GUA ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2010 10:28 PM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
DEBUG(RETVAL,BGPSTR) ;run the debugger
D DEBUG^%Serenji("LABTAXC^BGP8GU(.RETVAL,.BGPSTR)")
Q
;
GETPAT(BGPRET,BGPSTR) ;-- return patient in ADO table
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPERR,BGPUIEN,P
S P="|"
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S BGPI=0
S BGPERR=""
S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
S BGPPAT=$P(BGPSTR,P,2)
S BGPMT=$P(BGPSTR,P,3)
S BGPNPAT=$P(BGPSTR,P,4)
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)_$G(BGPERR)
K BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
K BGPPATS
Q
;
PATSSN(PAT) ;-- look up by ssn
S BGPPIEN=$O(^DPT("SSN",PAT,0))
S BGPPIEN(1)=BGPPIEN
Q $G(BGPPIEN)
;
PATCHT(BGPPIEN,PAT) ;-- lookup by chart
N BGPCNT
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
.. I $O(^AUPNPAT("D",BGPDA,BGPIEN,0))=DUZ(2) 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) ;-- 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)!(BGPCNT>BGPMT) D
. S BGPIEN=0 F S BGPIEN=$O(^DPT("B",BGPNAM,BGPIEN)) Q:'BGPIEN 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
S BGPPATE=BGPCNT
Q $G(BGPPATE)
;
BEGIN(PT) ;-- 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) ;-- ado return
S BGPCNTR=0
S BGPDA=0 F S BGPDA=$O(PIEN(BGPDA)) Q:'BGPDA D
. S BGPCNTR=BGPCNTR+1
. S BGPPI=$G(PIEN(BGPDA))
. S BGPNM=$P($G(^DPT(BGPPI,0)),U)
. S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPPI,0)),U,3))
. S BGPSX=$P($G(^DPT(BGPPI,0)),U,2)
. S BGPCT=$$HRN^AUPNPAT(BGPPI,DUZ(2))
. S BGPSSN=$P($G(^DPT(BGPPI,0)),U,9)
. S BGPUPD=$P($G(^AUPNPAT(BGPPI,0)),U,3) ;cmi/maw 5/17/2009 added last reg update
. S BGPELG=$$GET1^DIQ(9000001,BGPPI,1111) ;cmi/maw 5/17/2009 added class/ben for status bar
. S BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPPI_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_$G(BGPHD)_U_BGPUPD_U_BGPELG_U_BGPAGE_$C(30)
Q
;
SELSP(RETVAL) ;-- return all sites in the site file for selection
N BGPI
S BGPI=0
S RETVAL="^BGPTMP("_$J_")"
K ^BGPTMP($J)
S ^BGPTMP($J,BGPI)="T00050Site"_$C(30)
N BGPDA
S BGPDA=0 F S BGPDA=$O(^BGPSITE("B",BGPDA)) Q:'BGPDA D
. N BGPSE
. S BGPSE=$P($G(^DIC(4,BGPDA,0)),U)
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPSE_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
DEMO(RETVAL,BGPSTR) ;-- cmi/maw 8.0 p2 get demo patients based on Search Template passed in
N BGPI,BGPST,BGPSTI,P
S P="|"
S BGPI=0
S BGPSTI=$P(BGPSTR,P)
;S BGPSTI=$O(^DIBT("B",BGPST,0))
S RETVAL="^BGPTMP("_$J_")"
K ^BGPTMP($J)
S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
N BGPDA
S BGPDA=0 F S BGPDA=$O(^DIBT(BGPSTI,1,BGPDA)) Q:'BGPDA D
. N BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
. S BGPI=BGPI+1
. S BGPNM=$P($G(^DPT(BGPDA,0)),U)
. S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPDA,0)),U,3))
. S BGPSX=$P($G(^DPT(BGPDA,0)),U,2)
. S BGPCT=$$HRN^AUPNPAT(BGPDA,DUZ(2))
. S BGPSSN=$P($G(^DPT(BGPDA,0)),U,9)
. S ^BGPTMP($J,BGPI)=BGPDA_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_U_U_U_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
DEMOS(RETVAL,BGPSTR) ;-- cmi/maw 6/11/2010 8.0 p1 save demo template
N P,R,BGPI,BGPST,BGPSTI,BGPPATS,BGPFDA,BGPERR,BGPIENS
S P="|",R="~"
S BGPI=0
S RETVAL="^BGPTMP("_$J_")"
S BGPST=$P(BGPSTR,P)
S BGPPATS=$P(BGPSTR,P,2)
S BGPSTI=$S($G(BGPST):BGPST,1:$O(^DIBT("B",BGPST,0)))
S ^BGPTMP($J,BGPI)="T00001Error"_$C(30)
S P="|"
I $G(BGPSTI) D Q
. D CLNDEMO(BGPSTI)
. N I
. F I=1:1 D Q:$P(BGPPATS,R,I)=""
.. Q:$P(BGPPATS,R,I)=""
.. N BGPPAT
.. S BGPPAT=$P(BGPPATS,R,I)
.. S ^DIBT(BGPSTI,1,BGPPAT)=""
. S ^BGPTMP($J,BGPI+1)=$C(31)
;S BGPIENS=""
;S BGPFDA(.401,"+1,",.01)=BGPST
;D UPDATE^DIE("","BGPFDA","BGPIENS","BGPERR(1)")
;S BGPSTI=$G(BGPIENS(1))
;N I
;F I=1:1 D Q:$P(BGPPATS,R,I)=""
;. Q:$P(BGPPATS,R,I)=""
;. N BGPPAT
;. S BGPPAT=$P(BGPPATS,R,I)
;. S ^DIBT(BGPSTI,1,BGPPAT)=""
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
CLNDEMO(STI) ;-- cmi/maw 6/11/2010 8.0 p1 clean up demo template first
N BGPDA
S DA(1)=STI
S DIK="^DIBT("_DA(1)_",1,"
S BGPDA=0 F S BGPDA=$O(^DIBT(STI,1,BGPDA)) Q:'BGPDA D
. S DA=BGPDA
. D ^DIK
K DIK
Q
;
VC(RETVAL,BGPSTR) ;-- get version number to see if client matches
N P
S P="|"
K ^BGPTMP($J)
N BGPVER,BGPVERI,BGPVERIN,BGPPKG,BGPI,BGPPTCH,BGPPTCHI,BGPVERI
S BGPI=0
S BGPVERIN=$P(BGPSTR,P)
;S BGPVERIN=8.3
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00001VersionPresent"_$C(30)
S BGPI=BGPI+1
S BGPPKG=$O(^DIC(9.4,"C","BGP",0))
I '$G(BGPPKG) D Q
. S ^BGPTMP($J,BGPI)=0_$C(30)
. S ^BGPTMP($J,BGPI+1)=$C(31)
S BGPVER=$G(^DIC(9.4,BGPPKG,"VERSION"))
S BGPVERI=$O(^DIC(9.4,BGPPKG,22,"B",BGPVER,0))
S BGPPTCH=$O(^DIC(9.4,BGPPKG,22,BGPVERI,"PAH","B",""),-1)
I ($E(BGPVER,1,2)_BGPPTCH)=BGPVERIN D Q
. S ^BGPTMP($J,BGPI)=1_$C(30)
. S ^BGPTMP($J,BGPI+1)=$C(31)
;S ^BGPTMP($J,BGPI)=0_$C(30) ;remove the line below when done with testing and uncomment this one
S ^BGPTMP($J,BGPI)=1_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
DEMOCHK(RETVAL) ;-- check to see if the demo template exists
N BGPI,BGPMSG
S BGPI=0
S RETVAL="^BGPTMP("_$J_")"
K ^BGPTMP($J)
S @RETVAL@(BGPI)="T00080Message"_$C(30)
S BGPMSG=$$CHKDST^BGP8UTL2()
I +$G(BGPMSG) D Q
. S BGPI=BGPI+1
. ;S @RETVAL@(BGPI)=$C(30)
. S @RETVAL@(BGPI+1)=$C(31)
S BGPMSG=$P(BGPMSG,U,2)
S BGPI=BGPI+1
S @RETVAL@(BGPI)=BGPMSG_$C(30)
S @RETVAL@(BGPI+1)=$C(31)
Q
;
COMCHK(BGPRET,BGPSTR) ;EP
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N P,BGPOPT,BGPI,T
S P="|"
S BGPI=0
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00200COMMUNITIES"_$C(30)
S BGPI=0
S T=$P(BGPSTR,P)
K BGPC
I '$G(T) Q 0
I '$D(^ATXAX(T)) Q 0
S X=0,G=0
F S X=$O(^ATXAX(T,21,X)) Q:'X D
.S C=$P(^ATXAX(T,21,X,0),U)
.S BGPI=BGPI+1
.I '$D(^AUTTCOM("B",C)) S ^BGPTMP($J,BGPI)="Warning "_C_" is in the taxonomy but not in the standard community table."_$C(30)
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^Behavioral Health 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^Behavioral Health 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
;
CHKFQT(BGPX) ;EP - check for queued task (BGP AUTO GPRA EXTRACT and BGPSITE variable within the task
NEW X,BGPY,TASKJ
S BGPY=$P($G(^BGPGUIR(BGPX,0)),U,9)
I '$G(BGPY) Q 0
I '$D(^%ZTSK(BGPY,0)),$P($G(^BGPGUIR(BGPX,0)),U,6)="R" Q 1 ;v16.0 check for deleted task and mark as errored if so
I $P($G(^%ZTSK(BGPY,.1)),U)="C" Q 1
I $P($G(^%ZTSK(BGPY,.1)),U)="E" Q 1
S TASKJ=$P($G(^%ZTSK(BGPY,.1)),U,4)
I $G(TASKJ) S X=TASKJ D JOBPAR^%ZOSV I $G(Y)="" Q 1 ;v16.0 check to see if job is active
;I $G(TASKJ),'$D(^$J(TASKJ)) Q 1
Q 0
;
UPLOG(GIEN,TSK) ;EP
S DIE="^BGPGUIR(",DR=".09///"_TSK
S DA=GIEN
D ^DIE
Q
;
BGP8GUA ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2010 10:28 PM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
DEBUG(RETVAL,BGPSTR) ;run the debugger
+1 DO DEBUG^%Serenji("LABTAXC^BGP8GU(.RETVAL,.BGPSTR)")
+2 QUIT
+3 ;
GETPAT(BGPRET,BGPSTR) ;-- return patient in ADO table
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPERR,BGPUIEN,P
+3 SET P="|"
+4 KILL ^BGPTMP($JOB)
+5 SET BGPRET="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPERR=""
+8 SET ^BGPTMP($JOB,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$CHAR(30)
+9 SET BGPPAT=$PIECE(BGPSTR,P,2)
+10 SET BGPMT=$PIECE(BGPSTR,P,3)
+11 SET BGPNPAT=$PIECE(BGPSTR,P,4)
+12 IF BGPMT="ALL"
SET BGPMT=9999999
+13 SET BGPMT=(BGPMT-1)
+14 IF BGPPAT?9N
Begin DoDot:1
+15 SET BGPPIEN=$$PATSSN(BGPPAT)
End DoDot:1
+16 IF BGPPAT?1.6N
Begin DoDot:1
+17 SET BGPPIEN=$$PATCHT(.BGPPIEN,BGPPAT)
End DoDot:1
+18 IF BGPPAT?1.2N1"/"1.2N1"/"4N
Begin DoDot:1
+19 SET X=BGPPAT
DO ^%DT
SET BGPPAT=Y
+20 SET BGPPIEN=$$PATDOB(.BGPPIEN,BGPPAT)
End DoDot:1
+21 IF '$GET(BGPPIEN)
DO PATNAM(.BGPPIEN,BGPPAT,BGPNPAT)
+22 IF $GET(BGPPIEN)
IF '$GET(BGPPATS)
DO PATADO(.BGPPIEN)
+23 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)
+24 KILL BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
+25 KILL BGPPATS
+26 QUIT
+27 ;
PATSSN(PAT) ;-- 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) ;-- lookup by chart
+1 NEW BGPCNT
+2 SET BGPCNT=0
SET BGPPATE=0
SET BGPMCNT=0
+3 SET BGPDA=(PAT-1)
FOR
SET BGPDA=$ORDER(^AUPNPAT("D",BGPDA))
IF 'BGPDA!(BGPDA>PAT)!(BGPCNT>BGPMT)
QUIT
Begin DoDot:1
+4 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^AUPNPAT("D",BGPDA,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+5 IF $ORDER(^AUPNPAT("D",BGPDA,BGPIEN,0))=DUZ(2)
SET BGPPIEN=BGPIEN
+6 IF '$GET(BGPPIEN)
QUIT
+7 ;
+8 SET BGPCNT=BGPCNT+1
+9 IF '$DATA(BGPPIEN(BGPCNT))
SET BGPPIEN(BGPCNT)=0
+10 SET BGPPIEN(BGPCNT)=BGPPIEN
End DoDot:2
End DoDot:1
+11 QUIT $GET(BGPPIEN)
+12 ;
PATDOB(BGPPATE,PAT) ;-- 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)!(BGPCNT>BGPMT)
QUIT
Begin DoDot:1
+8 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^DPT("B",BGPNAM,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+9 ;cmi/maw 4/25/2005 don't get aliases
IF $ORDER(^DPT("B",BGPNAM,BGPIEN,0))
QUIT
+10 SET BGPCNT=BGPCNT+1
+11 IF '$DATA(BGPPATE(BGPCNT))
SET BGPPATE(BGPCNT)=0
+12 SET BGPPATE(BGPCNT)=BGPIEN
End DoDot:2
End DoDot:1
+13 SET BGPPATE=BGPCNT
+14 QUIT $GET(BGPPATE)
+15 ;
BEGIN(PT) ;-- 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) ;-- ado return
+1 SET BGPCNTR=0
+2 SET BGPDA=0
FOR
SET BGPDA=$ORDER(PIEN(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+3 SET BGPCNTR=BGPCNTR+1
+4 SET BGPPI=$GET(PIEN(BGPDA))
+5 SET BGPNM=$PIECE($GET(^DPT(BGPPI,0)),U)
+6 SET BGPDB=$$FMTE^XLFDT($PIECE($GET(^DPT(BGPPI,0)),U,3))
+7 SET BGPSX=$PIECE($GET(^DPT(BGPPI,0)),U,2)
+8 SET BGPCT=$$HRN^AUPNPAT(BGPPI,DUZ(2))
+9 SET BGPSSN=$PIECE($GET(^DPT(BGPPI,0)),U,9)
+10 ;cmi/maw 5/17/2009 added last reg update
SET BGPUPD=$PIECE($GET(^AUPNPAT(BGPPI,0)),U,3)
+11 ;cmi/maw 5/17/2009 added class/ben for status bar
SET BGPELG=$$GET1^DIQ(9000001,BGPPI,1111)
+12 SET BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
+13 SET BGPI=BGPI+1
+14 SET ^BGPTMP($JOB,BGPI)=BGPPI_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_$GET(BGPHD)_U_BGPUPD_U_BGPELG_U_BGPAGE_$CHAR(30)
End DoDot:1
+15 QUIT
+16 ;
SELSP(RETVAL) ;-- return all sites in the site file for selection
+1 NEW BGPI
+2 SET BGPI=0
+3 SET RETVAL="^BGPTMP("_$JOB_")"
+4 KILL ^BGPTMP($JOB)
+5 SET ^BGPTMP($JOB,BGPI)="T00050Site"_$CHAR(30)
+6 NEW BGPDA
+7 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^BGPSITE("B",BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+8 NEW BGPSE
+9 SET BGPSE=$PIECE($GET(^DIC(4,BGPDA,0)),U)
+10 SET BGPI=BGPI+1
+11 SET ^BGPTMP($JOB,BGPI)=BGPSE_$CHAR(30)
End DoDot:1
+12 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+13 QUIT
+14 ;
DEMO(RETVAL,BGPSTR) ;-- cmi/maw 8.0 p2 get demo patients based on Search Template passed in
+1 NEW BGPI,BGPST,BGPSTI,P
+2 SET P="|"
+3 SET BGPI=0
+4 SET BGPSTI=$PIECE(BGPSTR,P)
+5 ;S BGPSTI=$O(^DIBT("B",BGPST,0))
+6 SET RETVAL="^BGPTMP("_$JOB_")"
+7 KILL ^BGPTMP($JOB)
+8 SET ^BGPTMP($JOB,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$CHAR(30)
+9 NEW BGPDA
+10 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(BGPSTI,1,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+11 NEW BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
+12 SET BGPI=BGPI+1
+13 SET BGPNM=$PIECE($GET(^DPT(BGPDA,0)),U)
+14 SET BGPDB=$$FMTE^XLFDT($PIECE($GET(^DPT(BGPDA,0)),U,3))
+15 SET BGPSX=$PIECE($GET(^DPT(BGPDA,0)),U,2)
+16 SET BGPCT=$$HRN^AUPNPAT(BGPDA,DUZ(2))
+17 SET BGPSSN=$PIECE($GET(^DPT(BGPDA,0)),U,9)
+18 SET ^BGPTMP($JOB,BGPI)=BGPDA_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_U_U_U_$CHAR(30)
End DoDot:1
+19 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+20 QUIT
+21 ;
DEMOS(RETVAL,BGPSTR) ;-- cmi/maw 6/11/2010 8.0 p1 save demo template
+1 NEW P,R,BGPI,BGPST,BGPSTI,BGPPATS,BGPFDA,BGPERR,BGPIENS
+2 SET P="|"
SET R="~"
+3 SET BGPI=0
+4 SET RETVAL="^BGPTMP("_$JOB_")"
+5 SET BGPST=$PIECE(BGPSTR,P)
+6 SET BGPPATS=$PIECE(BGPSTR,P,2)
+7 SET BGPSTI=$SELECT($GET(BGPST):BGPST,1:$ORDER(^DIBT("B",BGPST,0)))
+8 SET ^BGPTMP($JOB,BGPI)="T00001Error"_$CHAR(30)
+9 SET P="|"
+10 IF $GET(BGPSTI)
Begin DoDot:1
+11 DO CLNDEMO(BGPSTI)
+12 NEW I
+13 FOR I=1:1
Begin DoDot:2
+14 IF $PIECE(BGPPATS,R,I)=""
QUIT
+15 NEW BGPPAT
+16 SET BGPPAT=$PIECE(BGPPATS,R,I)
+17 SET ^DIBT(BGPSTI,1,BGPPAT)=""
End DoDot:2
IF $PIECE(BGPPATS,R,I)=""
QUIT
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+19 ;S BGPIENS=""
+20 ;S BGPFDA(.401,"+1,",.01)=BGPST
+21 ;D UPDATE^DIE("","BGPFDA","BGPIENS","BGPERR(1)")
+22 ;S BGPSTI=$G(BGPIENS(1))
+23 ;N I
+24 ;F I=1:1 D Q:$P(BGPPATS,R,I)=""
+25 ;. Q:$P(BGPPATS,R,I)=""
+26 ;. N BGPPAT
+27 ;. S BGPPAT=$P(BGPPATS,R,I)
+28 ;. S ^DIBT(BGPSTI,1,BGPPAT)=""
+29 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+30 QUIT
+31 ;
CLNDEMO(STI) ;-- cmi/maw 6/11/2010 8.0 p1 clean up demo template first
+1 NEW BGPDA
+2 SET DA(1)=STI
+3 SET DIK="^DIBT("_DA(1)_",1,"
+4 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(STI,1,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+5 SET DA=BGPDA
+6 DO ^DIK
End DoDot:1
+7 KILL DIK
+8 QUIT
+9 ;
VC(RETVAL,BGPSTR) ;-- get version number to see if client matches
+1 NEW P
+2 SET P="|"
+3 KILL ^BGPTMP($JOB)
+4 NEW BGPVER,BGPVERI,BGPVERIN,BGPPKG,BGPI,BGPPTCH,BGPPTCHI,BGPVERI
+5 SET BGPI=0
+6 SET BGPVERIN=$PIECE(BGPSTR,P)
+7 ;S BGPVERIN=8.3
+8 SET RETVAL="^BGPTMP("_$JOB_")"
+9 SET ^BGPTMP($JOB,BGPI)="T00001VersionPresent"_$CHAR(30)
+10 SET BGPI=BGPI+1
+11 SET BGPPKG=$ORDER(^DIC(9.4,"C","BGP",0))
+12 IF '$GET(BGPPKG)
Begin DoDot:1
+13 SET ^BGPTMP($JOB,BGPI)=0_$CHAR(30)
+14 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+15 SET BGPVER=$GET(^DIC(9.4,BGPPKG,"VERSION"))
+16 SET BGPVERI=$ORDER(^DIC(9.4,BGPPKG,22,"B",BGPVER,0))
+17 SET BGPPTCH=$ORDER(^DIC(9.4,BGPPKG,22,BGPVERI,"PAH","B",""),-1)
+18 IF ($EXTRACT(BGPVER,1,2)_BGPPTCH)=BGPVERIN
Begin DoDot:1
+19 SET ^BGPTMP($JOB,BGPI)=1_$CHAR(30)
+20 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+21 ;S ^BGPTMP($J,BGPI)=0_$C(30) ;remove the line below when done with testing and uncomment this one
+22 SET ^BGPTMP($JOB,BGPI)=1_$CHAR(30)
+23 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+24 QUIT
+25 ;
DEMOCHK(RETVAL) ;-- check to see if the demo template exists
+1 NEW BGPI,BGPMSG
+2 SET BGPI=0
+3 SET RETVAL="^BGPTMP("_$JOB_")"
+4 KILL ^BGPTMP($JOB)
+5 SET @RETVAL@(BGPI)="T00080Message"_$CHAR(30)
+6 SET BGPMSG=$$CHKDST^BGP8UTL2()
+7 IF +$GET(BGPMSG)
Begin DoDot:1
+8 SET BGPI=BGPI+1
+9 ;S @RETVAL@(BGPI)=$C(30)
+10 SET @RETVAL@(BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+11 SET BGPMSG=$PIECE(BGPMSG,U,2)
+12 SET BGPI=BGPI+1
+13 SET @RETVAL@(BGPI)=BGPMSG_$CHAR(30)
+14 SET @RETVAL@(BGPI+1)=$CHAR(31)
+15 QUIT
+16 ;
COMCHK(BGPRET,BGPSTR) ;EP
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPOPT,BGPI,T
+3 SET P="|"
+4 SET BGPI=0
+5 KILL ^BGPTMP($JOB)
+6 SET BGPRET="^BGPTMP("_$JOB_")"
+7 SET ^BGPTMP($JOB,BGPI)="T00200COMMUNITIES"_$CHAR(30)
+8 SET BGPI=0
+9 SET T=$PIECE(BGPSTR,P)
+10 KILL BGPC
+11 IF '$GET(T)
QUIT 0
+12 IF '$DATA(^ATXAX(T))
QUIT 0
+13 SET X=0
SET G=0
+14 FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF 'X
QUIT
Begin DoDot:1
+15 SET C=$PIECE(^ATXAX(T,21,X,0),U)
+16 SET BGPI=BGPI+1
+17 IF '$DATA(^AUTTCOM("B",C))
SET ^BGPTMP($JOB,BGPI)="Warning "_C_" is in the taxonomy but not in the standard community table."_$CHAR(30)
End DoDot:1
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+19 QUIT
+20 ;
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^Behavioral Health 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^Behavioral Health 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 ;
CHKFQT(BGPX) ;EP - check for queued task (BGP AUTO GPRA EXTRACT and BGPSITE variable within the task
+1 NEW X,BGPY,TASKJ
+2 SET BGPY=$PIECE($GET(^BGPGUIR(BGPX,0)),U,9)
+3 IF '$GET(BGPY)
QUIT 0
+4 ;v16.0 check for deleted task and mark as errored if so
IF '$DATA(^%ZTSK(BGPY,0))
IF $PIECE($GET(^BGPGUIR(BGPX,0)),U,6)="R"
QUIT 1
+5 IF $PIECE($GET(^%ZTSK(BGPY,.1)),U)="C"
QUIT 1
+6 IF $PIECE($GET(^%ZTSK(BGPY,.1)),U)="E"
QUIT 1
+7 SET TASKJ=$PIECE($GET(^%ZTSK(BGPY,.1)),U,4)
+8 ;v16.0 check to see if job is active
IF $GET(TASKJ)
SET X=TASKJ
DO JOBPAR^%ZOSV
IF $GET(Y)=""
QUIT 1
+9 ;I $G(TASKJ),'$D(^$J(TASKJ)) Q 1
+10 QUIT 0
+11 ;
UPLOG(GIEN,TSK) ;EP
+1 SET DIE="^BGPGUIR("
SET DR=".09///"_TSK
+2 SET DA=GIEN
+3 DO ^DIE
+4 QUIT
+5 ;
