BGP0GUA ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2009 10:28 PM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
;
DEBUG(RETVAL,BGPSTR) ;run the debugger
D DEBUG^%Serenji("LABTAXC^BGP0GU(.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/2008 added last reg update
. S BGPELG=$$GET1^DIQ(9000001,BGPPI,1111) ;cmi/maw 5/17/2008 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/2009 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/2009 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 $G(BGPPTCH),($E(BGPVER,1,2)_BGPPTCH)=BGPVERIN D Q
. S ^BGPTMP($J,BGPI)=1_$C(30)
. S ^BGPTMP($J,BGPI+1)=$C(31)
I '$G(BGPPTCH),($G(BGPVER)=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
;
BGP0GUA ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2009 10:28 PM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
+3 ;
DEBUG(RETVAL,BGPSTR) ;run the debugger
+1 DO DEBUG^%Serenji("LABTAXC^BGP0GU(.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/2008 added last reg update
SET BGPUPD=$PIECE($GET(^AUPNPAT(BGPPI,0)),U,3)
+11 ;cmi/maw 5/17/2008 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/2009 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/2009 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 $GET(BGPPTCH)
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 IF '$GET(BGPPTCH)
IF ($GET(BGPVER)=BGPVERIN)
Begin DoDot:1
+22 SET ^BGPTMP($JOB,BGPI)=1_$CHAR(30)
+23 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
End DoDot:1
QUIT
+24 ;remove the line below when done with testing and uncomment this one
SET ^BGPTMP($JOB,BGPI)=0_$CHAR(30)
+25 ;S ^BGPTMP($J,BGPI)=1_$C(30)
+26 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+27 QUIT
+28 ;
