Routine: BGP4GUA

BGP4GUA ; 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 ;

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

DEBUG(RETVAL,BGPSTR) ;run the debugger

 D DEBUG^%Serenji("LABTAXC^BGP4GU(.RETVAL,.BGPSTR)")

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

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)

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)

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)

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)

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

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)

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^BGP4UTL2()

 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)

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)

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)

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))

BGP4GUA   ; 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       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +2       ;

 +3       ;

DEBUG(RETVAL,BGPSTR) ;run the debugger

 +1        DO DEBUG^%Serenji("LABTAXC^BGP4GU(.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^BGP4UTL2()

 +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      ;

BGP4GUA.m