BDMGUB ; IHS/CMI/LAB - BDM DMS GUI Utilities ;
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,4**;JUN 14, 2007
;
;
;
;cmi/anch/maw 1/23/2005 added in PATCHT a quit if mult chts with same #
;cmi/anch/maw 2/1/2006 changed visit retrieval to ADO.NET
;cmi/anch/maw 3/22/2006 changed weight, bp, labs, to sort earliest to latest
;cmi/anch/maw 3/23/2006 changed patient lookup to not look at other names
;
DEBUG(BDMRET,BDMSTR) ;-- debug
D DEBUG^%Serenji("CHK^BDMGU(.BDMRET,.BDMSTR)")
Q
;
DELLET(RETVAL,BDMSTR) ;-- delete a letter out of the DMS LETTERS file
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,R,I
S P="|",R="~"
S BDMERR=""
K ^BDMTMP($J)
S RETVAL="^BDMTMP("_$J_")"
F I=2:1 D Q:$P(BDMSTR,R,I)=""
. N BDMI,BDMDA
. Q:$P(BDMSTR,R,I)=""
. S BDMI=$P(BDMSTR,R,I)
. S DIK="^BDMLET(",DA=BDMI D ^DIK
S ^BDMTMP($J,0)="T00250DATA"_$C(30)
S ^BDMTMP($J,1)=$G(BDMERR)_$C(30)
S ^BDMTMP($J,2)=$C(31)_BDMERR
Q
;
LETI(BDMRET) ;-- get all letter Items
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMI,BDMB,BDME
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMB="BDM"
S ^BDMTMP($J,BDMI)="T00030Letter Item"_$C(30)
S BDMDA=BDMB F S BDMDA=$O(^DD("FUNC","B",BDMDA)) Q:BDMDA=""!($P(BDMDA," ")'=BDMB) D
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^DD("FUNC","B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$P($P($G(^DD("FUNC",BDMIEN,0)),U)," ",2,99)_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
;
LETS(BDMRET,BDMSTR) ;-- get all letter Items for letter
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMI,P,BDMLET
S P="|"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMLET=$P(BDMSTR,P)
S ^BDMTMP($J,BDMI)="T00030Letter Items"_$C(30)
S BDMDA=0 F S BDMDA=$O(^BDMLET(BDMLET,"ITEM",BDMDA)) Q:'BDMDA D
. N BDMLIEN
. S BDMLIEN=$P($G(^BDMLET(BDMLET,"ITEM",BDMDA,0)),U)
. S BDMLETS=$P($P($G(^DD("FUNC",BDMLIEN,0)),U)," ",2,99)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMLETS_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
;
LETD(BDMRET,BDMSTR) ;-- get letter data
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMI,P,BDMLET,BDMLETI,BDMDFN,BDMREGNM,BDMRPDA
S P="|"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0,BDMCNT=0
S ^BDMTMP($J,BDMI)="T32767DATA"_$C(30)
S BDMLET=$P(BDMSTR,P)
S BDMDFN=$P(BDMSTR,P,2)
S BDMPDFN=$P(BDMSTR,P,3)
S BDMREGNM=$P(BDMSTR,P,4)
S BDMLETI=$O(^BDMLET("B",BDMLET,0))
S BDMLDA=0 F S BDMLDA=$O(^BDMLET(BDMLETI,"ITEM",BDMLDA)) Q:'BDMLDA D
. N BDMIEN,BDMT
. S BDMIEN=$G(^BDMLET(BDMLETI,"ITEM",BDMLDA,0))
. S BDMT=$G(^DD("FUNC",BDMIEN,0))
. X ^DD("FUNC",BDMIEN,1)
. S BDMCNT=BDMCNT+1
. S $P(^BDMTMP($J,1),",",BDMCNT)=$P(BDMT," ",2,99)
. S $P(^BDMTMP($J,2),",",BDMCNT)=X
S ^BDMTMP($J,1)=$G(^BDMTMP($J,1))_$C(30)
S ^BDMTMP($J,2)=$G(^BDMTMP($J,2))_$C(30)
S ^BDMTMP($J,3)=$C(31)
Q
;
FIRST(DFN) ;EP;TO PRINT PATIENT NAME IN A LETTER
N Z
S Z=$P($G(^DPT(DFN,0)),U)
Q $P($P(Z,",",2)," ")
;
LAST(DFN) ;EP;TO PRINT PATIENT NAME IN A LETTER
N Z
S Z=$P($G(^DPT(DFN,0)),U)
Q $P(Z,",")
;
CHT(DFN) ;EP;TO PRINT PATIENT CHART NUMBER PATCH 4
Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
;
ADD(DFN) ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
N Z
S Z=$G(^DPT(DFN,.11))
Q $P(Z,U,1)
;S Z=Z_$P(Z,U,4)_", "_$P($G(^DIC(5,+$P(Z,U,5),0)),U,2)_" "_$P(Z,U,6)
;
CITY(DFN) ;EP - city
N Z
Q $P($G(^DPT(DFN,.11)),U,4)
;
STATE(DFN) ;EP - state
N Z
Q $S($P($G(^DPT(DFN,.11)),U,5)]"":$P($G(^DIC(5,$P($G(^DPT(DFN,.11)),U,5),0)),U),1:"")
;
ZIP(DFN) ;EP-Zip
N Z
Q $P($G(^DPT(DFN,.11)),U,6)
;
FUM(DFN) ;EP;TO PRINT FOLLOW-UP MESSAGE
S BDM("STATUS")="A"
;S BDM("STATUS")=STAT
S BDM("STATUS")=$E($G(BDM("STATUS"))) ;IHS/CIM/THL PATCH 5
S BDMPDA=DFN
D SSET^BDMVRL42 ;IHS/CIM/THL PATCH 5
N BDMX,BDMVAL
S BDMX=0,BDMVAL=""
F S BDMX=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX)) Q:'BDMX!$D(BDMQUIT) D
.S BDMY=""
.F S BDMY=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY)) Q:BDMY=""!$D(BDMQUIT) D
..S BDMZ=$G(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY))
..S BDMVAL=BDMVAL_BDMY_$P(BDMZ,U)
Q BDMVAL
;
PRV(BDMRPDA) ;EP;TO PRINT PROVIDER NAME IN A LETTER
N Z
S Z=+$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
S Z=$P($G(^VA(200,Z,0)),U)
S Z=$P($P(Z,",",2)," ")_" "_$P(Z,",")
Q Z
;
CHK(BDMRET,BDMSTR) ;check report status
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMDUZ2,BDMI
S P="|"
S BDMDUZ=$P(BDMSTR,P)
K ^BDMTMP($J)
K ^TMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S ^BDMTMP($J,BDMI)="T00007BMXIEN^T00030Name^T00030User^T00020Start Time^T00020End Time^T00030Option^T00020Report Status^T00030Type of Report"_$C(30)
N BDMDA
S BDMDA=0 F S BDMDA=$O(^BDMGUI("AUSR",BDMDUZ,BDMDA)) Q:'BDMDA D
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^BDMGUI("AUSR",BDMDUZ,BDMDA,BDMIEN)) Q:'BDMIEN D
.. N BDMDATA,BDMNM,BDMUSER,BDMST,BDMET,BDMTOR,BDMRS,BDMTOO,BDMSTI,BDMOPT
.. S BDMDATA=$G(^BDMGUI(BDMIEN,0))
.. S BDMNM=$P(BDMDATA,U)
.. S BDMUSER=$P($G(^VA(200,$P(BDMDATA,U,2),0)),U)
.. S BDMSTI=9999999-$P(BDMDATA,U,3)
.. S BDMST=$$FMTE^XLFDT($P(BDMDATA,U,3))
.. S BDMET=$$FMTE^XLFDT($P(BDMDATA,U,4))
.. S BDMTOR=$$GET1^DIQ(9003201.4,BDMIEN,.05)
.. S BDMOPT=$$GET1^DIQ(9003201.4,BDMIEN,.06)
.. S BDMRS=$$GET1^DIQ(9003201.4,BDMIEN,.07)
.. ;S BDMI=BDMI+1
.. S ^TMP($J,BDMSTI,BDMIEN_"BDM")="A"_BDMIEN_U_BDMNM_U_BDMUSER_U_BDMST_U_BDMET_U_BDMOPT_U_BDMRS_U_BDMTOR
N BDMDA
S BDMDA=0 F S BDMDA=$O(^BDMGUI("AUSR",BDMDUZ,BDMDA)) Q:'BDMDA D
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^BDMGUI("AUSR",BDMDUZ,BDMDA,BDMIEN)) Q:'BDMIEN D
.. N BDMDATA,BDMNM,BDMUSER,BDMST,BDMET,BDMTOR,BDMRS,BDMTOO,BDMSTI,BDMOPT
.. S BDMDATA=$G(^BDMGUI(BDMIEN,0))
.. S BDMNM=$P(BDMDATA,U)
.. S BDMUSER=$P($G(^VA(200,$P(BDMDATA,U,2),0)),U)
.. S BDMSTI=9999999-$P(BDMDATA,U,3)
.. S BDMST=$$FMTE^XLFDT($P(BDMDATA,U,3))
.. S BDMET=$$FMTE^XLFDT($P(BDMDATA,U,4))
.. S BDMTOR=$$GET1^DIQ(9003201.4,BDMIEN,.05)
.. S BDMOPT=$$GET1^DIQ(9003201.4,BDMIEN,.06)
.. S BDMRS=$$GET1^DIQ(9003201.4,BDMIEN,.07)
.. ;S BDMI=BDMI+1
.. S ^TMP($J,BDMSTI,BDMIEN_"BDM")="B"_BDMIEN_U_BDMNM_U_BDMUSER_U_BDMST_U_BDMET_U_BDMOPT_U_BDMRS_U_BDMTOR
N BDMDA
S BDMDA=0 F S BDMDA=$O(^TMP($J,BDMDA)) Q:'BDMDA D
. N BDMTIEN
. S BDMTIEN=0 F S BDMTIEN=$O(^TMP($J,BDMDA,BDMTIEN)) Q:BDMTIEN="" D
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$G(^TMP($J,BDMDA,BDMTIEN))_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
;
DCMP(BDMRET,BDMSTR) ;-- delete complications list
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,R,I,BDMDA
S P="|",R="~"
S BDMERR=""
K ^BDMTMP($J)
S RETVAL="^BDMTMP("_$J_")"
S BDMDA=$P(BDMSTR,P)
F I=2:1 D Q:$P(BDMSTR,R,I)=""
. Q:$P(BDMSTR,R,I)=""
. S DA(1)=$P(BDMSTR,R,I)
. S DIK="^ACM(42.1,"_DA(1)_","_"""RG"""_",",DA=BDMDA D ^DIK
S ^BDMTMP($J,0)="T00250DATA"_$C(30)
S ^BDMTMP($J,1)=$G(BDMERR)_$C(30)
S ^BDMTMP($J,2)=$C(31)_BDMERR
Q
;
GETIEN(BDMRET,BDMSTR) ;-- get ien of file based on xref value passed in
S X="MERR^BDMGU",@^%ZOSF("TRAP") ;m error trap
N P,BDMGFL,BDMGXRF,BDMGVAL,BDMGGLB,BDMGI,BDMGLK
S P="|"
S BDMGFL=$P(BDMSTR,P)
S BDMGXRF=$P(BDMSTR,P,2)
S BDMGVAL=$P(BDMSTR,P,3)
S BDMGGLB=^DIC(BDMGFL,0,"GL")
K ^BDMTMP($J)
S BDMGI=0
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMGI)="T00007BMXIEN"_$C(30)
S BDMGI=BDMGI+1
S BDMGLK=BDMGGLB_""""_BDMGXRF_""")"
S ^BDMTMP($J,BDMGI)=$O(@BDMGLK@(BDMGVAL,0))_$C(30)
S ^BDMTMP($J,BDMGI+1)=$C(31)
Q
;
STCNT(BDMRET,BDMSTR) ;-- get search template count and return result
N P,BDMTRNE,BDMTRN,BDMI,BDMRG,BDMRGE
S P="|"
S BDMTRNE=$P(BDMSTR,P,2)
S BDMTRN=$O(^DIBT("B",BDMTRNE,0))
S BDMRGE=$P(BDMSTR,P)
S BDMRG=$O(^ACM(41.1,"B",BDMRGE,0))
S BDMRET="^BDMTMP("_$J_")"
K ^BDMTMP($J)
S ^BDMTMP($J,0)="T10000TEXT"_$C(30)
S BDMI=0
N BDMDA,BDMCNT
S BDMCNT=0
S BDMDA=0 F S BDMDA=$O(^DIBT(BDMTRN,1,BDMDA)) Q:'BDMDA D
. S BDMCNT=BDMCNT+1
S ^BDMTMP($J,1)="There are "_BDMCNT_" patients in this search template"_$C(30)
S ^BDMTMP($J,2)="The following transfer has been selected:"_$C(30)
S ^BDMTMP($J,3)="From SEARCH TEMPLATE: "_BDMTRNE_$C(30)
S ^BDMTMP($J,4)="To CMS register: "_BDMRGE_$C(30)
S ^BDMTMP($J,5)="Transfer Status: A - ACTIVE"_$C(30)
S ^BDMTMP($J,6)=$C(31)
Q
;
CHKPN(BDMRET,BDMSTR) ;-- check the problem number on DMU
N P,BDMPN,AUPNPAT
S P="|"
S BDMPN=$P(BDMSTR,P)
S AUPNPAT=$P(BDMSTR,P,2)
S BDMRET="^BDMTMP("_$J_")"
K ^BDMTMP($J)
S ^BDMTMP($J,0)="T00007VALIDPROBLEMNUMBER"_$C(30)
N BDMVPN
S BDMVPN=$$PROBNUM^APCDDMUP(BDMPN)
S ^BDMTMP($J,1)=BDMVPN_$C(30)
S ^BDMTMP($J,2)=$C(31)
Q
;
LOCG(RETVAL,BDMSTR) ;-- get the local option entry
N P,BDMIEN,BDMCODE,BDMTEXT
S P="|"
S BDMIEN=$P(BDMSTR,P)
S RETVAL="^BDMTMP("_$J_")"
K ^BDMTMP($J)
S @RETVAL@(0)="T00001Code^T00030Text"_$C(30)
S BDMCODE=$$GET1^DIQ(9002241,BDMIEN,1101)
S BDMTEXT=$$GET1^DIQ(9002241,BDMIEN,1102)
S @RETVAL@(1)=BDMCODE_U_BDMTEXT_$C(30)
S @RETVAL@(2)=$C(31)
Q
;
LOCS(RETVAL,BDMSTR) ;-- save the local option entry
N P,BDMIEN,BDMCODE,BDMTEXT,BDMRET
S P="|"
S BDMIEN=$P(BDMSTR,P)
S BDMCODE=$P(BDMSTR,P,2)
S BDMTEXT=$P(BDMSTR,P,3)
S RETVAL="^BDMTMP("_$J_")"
K ^BDMTMP($J)
S @RETVAL@(0)="T00001return"_$C(30)
N FDA,FIENS,FERR
S FIENS=BDMIEN_","
S FDA(9002241,FIENS,1101)=BDMCODE
S FDA(9002241,FIENS,1102)=BDMTEXT
D UPDATE^DIE("K","FDA","FERR(1)")
S BDMRET=$S($D(FERR(1)):1,1:0)
S @RETVAL@(1)=BDMRET_$C(30)
S @RETVAL@(2)=$C(31)
Q
;
BDMGUB ; IHS/CMI/LAB - BDM DMS GUI Utilities ;
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,4**;JUN 14, 2007
+2 ;
+3 ;
+4 ;
+5 ;cmi/anch/maw 1/23/2005 added in PATCHT a quit if mult chts with same #
+6 ;cmi/anch/maw 2/1/2006 changed visit retrieval to ADO.NET
+7 ;cmi/anch/maw 3/22/2006 changed weight, bp, labs, to sort earliest to latest
+8 ;cmi/anch/maw 3/23/2006 changed patient lookup to not look at other names
+9 ;
DEBUG(BDMRET,BDMSTR) ;-- debug
+1 DO DEBUG^%Serenji("CHK^BDMGU(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
DELLET(RETVAL,BDMSTR) ;-- delete a letter out of the DMS LETTERS file
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,R,I
+3 SET P="|"
SET R="~"
+4 SET BDMERR=""
+5 KILL ^BDMTMP($JOB)
+6 SET RETVAL="^BDMTMP("_$JOB_")"
+7 FOR I=2:1
Begin DoDot:1
+8 NEW BDMI,BDMDA
+9 IF $PIECE(BDMSTR,R,I)=""
QUIT
+10 SET BDMI=$PIECE(BDMSTR,R,I)
+11 SET DIK="^BDMLET("
SET DA=BDMI
DO ^DIK
End DoDot:1
IF $PIECE(BDMSTR,R,I)=""
QUIT
+12 SET ^BDMTMP($JOB,0)="T00250DATA"_$CHAR(30)
+13 SET ^BDMTMP($JOB,1)=$GET(BDMERR)_$CHAR(30)
+14 SET ^BDMTMP($JOB,2)=$CHAR(31)_BDMERR
+15 QUIT
+16 ;
LETI(BDMRET) ;-- get all letter Items
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,BDMB,BDME
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMB="BDM"
+7 SET ^BDMTMP($JOB,BDMI)="T00030Letter Item"_$CHAR(30)
+8 SET BDMDA=BDMB
FOR
SET BDMDA=$ORDER(^DD("FUNC","B",BDMDA))
IF BDMDA=""!($PIECE(BDMDA," ")'=BDMB)
QUIT
Begin DoDot:1
+9 NEW BDMIEN
+10 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^DD("FUNC","B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+11 SET BDMI=BDMI+1
+12 SET ^BDMTMP($JOB,BDMI)=$PIECE($PIECE($GET(^DD("FUNC",BDMIEN,0)),U)," ",2,99)_$CHAR(30)
End DoDot:2
End DoDot:1
+13 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+14 QUIT
+15 ;
LETS(BDMRET,BDMSTR) ;-- get all letter Items for letter
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,P,BDMLET
+3 SET P="|"
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 SET BDMI=0
+7 SET BDMLET=$PIECE(BDMSTR,P)
+8 SET ^BDMTMP($JOB,BDMI)="T00030Letter Items"_$CHAR(30)
+9 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMLET(BDMLET,"ITEM",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+10 NEW BDMLIEN
+11 SET BDMLIEN=$PIECE($GET(^BDMLET(BDMLET,"ITEM",BDMDA,0)),U)
+12 SET BDMLETS=$PIECE($PIECE($GET(^DD("FUNC",BDMLIEN,0)),U)," ",2,99)
+13 SET BDMI=BDMI+1
+14 SET ^BDMTMP($JOB,BDMI)=BDMLETS_$CHAR(30)
End DoDot:1
+15 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+16 QUIT
+17 ;
LETD(BDMRET,BDMSTR) ;-- get letter data
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,P,BDMLET,BDMLETI,BDMDFN,BDMREGNM,BDMRPDA
+3 SET P="|"
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 SET BDMI=0
SET BDMCNT=0
+7 SET ^BDMTMP($JOB,BDMI)="T32767DATA"_$CHAR(30)
+8 SET BDMLET=$PIECE(BDMSTR,P)
+9 SET BDMDFN=$PIECE(BDMSTR,P,2)
+10 SET BDMPDFN=$PIECE(BDMSTR,P,3)
+11 SET BDMREGNM=$PIECE(BDMSTR,P,4)
+12 SET BDMLETI=$ORDER(^BDMLET("B",BDMLET,0))
+13 SET BDMLDA=0
FOR
SET BDMLDA=$ORDER(^BDMLET(BDMLETI,"ITEM",BDMLDA))
IF 'BDMLDA
QUIT
Begin DoDot:1
+14 NEW BDMIEN,BDMT
+15 SET BDMIEN=$GET(^BDMLET(BDMLETI,"ITEM",BDMLDA,0))
+16 SET BDMT=$GET(^DD("FUNC",BDMIEN,0))
+17 XECUTE ^DD("FUNC",BDMIEN,1)
+18 SET BDMCNT=BDMCNT+1
+19 SET $PIECE(^BDMTMP($JOB,1),",",BDMCNT)=$PIECE(BDMT," ",2,99)
+20 SET $PIECE(^BDMTMP($JOB,2),",",BDMCNT)=X
End DoDot:1
+21 SET ^BDMTMP($JOB,1)=$GET(^BDMTMP($JOB,1))_$CHAR(30)
+22 SET ^BDMTMP($JOB,2)=$GET(^BDMTMP($JOB,2))_$CHAR(30)
+23 SET ^BDMTMP($JOB,3)=$CHAR(31)
+24 QUIT
+25 ;
FIRST(DFN) ;EP;TO PRINT PATIENT NAME IN A LETTER
+1 NEW Z
+2 SET Z=$PIECE($GET(^DPT(DFN,0)),U)
+3 QUIT $PIECE($PIECE(Z,",",2)," ")
+4 ;
LAST(DFN) ;EP;TO PRINT PATIENT NAME IN A LETTER
+1 NEW Z
+2 SET Z=$PIECE($GET(^DPT(DFN,0)),U)
+3 QUIT $PIECE(Z,",")
+4 ;
CHT(DFN) ;EP;TO PRINT PATIENT CHART NUMBER PATCH 4
+1 QUIT $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+2 ;
ADD(DFN) ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
+1 NEW Z
+2 SET Z=$GET(^DPT(DFN,.11))
+3 QUIT $PIECE(Z,U,1)
+4 ;S Z=Z_$P(Z,U,4)_", "_$P($G(^DIC(5,+$P(Z,U,5),0)),U,2)_" "_$P(Z,U,6)
+5 ;
CITY(DFN) ;EP - city
+1 NEW Z
+2 QUIT $PIECE($GET(^DPT(DFN,.11)),U,4)
+3 ;
STATE(DFN) ;EP - state
+1 NEW Z
+2 QUIT $SELECT($PIECE($GET(^DPT(DFN,.11)),U,5)]"":$PIECE($GET(^DIC(5,$PIECE($GET(^DPT(DFN,.11)),U,5),0)),U),1:"")
+3 ;
ZIP(DFN) ;EP-Zip
+1 NEW Z
+2 QUIT $PIECE($GET(^DPT(DFN,.11)),U,6)
+3 ;
FUM(DFN) ;EP;TO PRINT FOLLOW-UP MESSAGE
+1 SET BDM("STATUS")="A"
+2 ;S BDM("STATUS")=STAT
+3 ;IHS/CIM/THL PATCH 5
SET BDM("STATUS")=$EXTRACT($GET(BDM("STATUS")))
+4 SET BDMPDA=DFN
+5 ;IHS/CIM/THL PATCH 5
DO SSET^BDMVRL42
+6 NEW BDMX,BDMVAL
+7 SET BDMX=0
SET BDMVAL=""
+8 FOR
SET BDMX=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX))
IF 'BDMX!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+9 SET BDMY=""
+10 FOR
SET BDMY=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
IF BDMY=""!$DATA(BDMQUIT)
QUIT
Begin DoDot:2
+11 SET BDMZ=$GET(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
+12 SET BDMVAL=BDMVAL_BDMY_$PIECE(BDMZ,U)
End DoDot:2
End DoDot:1
+13 QUIT BDMVAL
+14 ;
PRV(BDMRPDA) ;EP;TO PRINT PROVIDER NAME IN A LETTER
+1 NEW Z
+2 SET Z=+$PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,15)
+3 SET Z=$PIECE($GET(^VA(200,Z,0)),U)
+4 SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+5 QUIT Z
+6 ;
CHK(BDMRET,BDMSTR) ;check report status
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMDUZ2,BDMI
+3 SET P="|"
+4 SET BDMDUZ=$PIECE(BDMSTR,P)
+5 KILL ^BDMTMP($JOB)
+6 KILL ^TMP($JOB)
+7 SET BDMRET="^BDMTMP("_$JOB_")"
+8 SET BDMI=0
+9 SET ^BDMTMP($JOB,BDMI)="T00007BMXIEN^T00030Name^T00030User^T00020Start Time^T00020End Time^T00030Option^T00020Report Status^T00030Type of Report"_$CHAR(30)
+10 NEW BDMDA
+11 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMGUI("AUSR",BDMDUZ,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+12 NEW BDMIEN
+13 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^BDMGUI("AUSR",BDMDUZ,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+14 NEW BDMDATA,BDMNM,BDMUSER,BDMST,BDMET,BDMTOR,BDMRS,BDMTOO,BDMSTI,BDMOPT
+15 SET BDMDATA=$GET(^BDMGUI(BDMIEN,0))
+16 SET BDMNM=$PIECE(BDMDATA,U)
+17 SET BDMUSER=$PIECE($GET(^VA(200,$PIECE(BDMDATA,U,2),0)),U)
+18 SET BDMSTI=9999999-$PIECE(BDMDATA,U,3)
+19 SET BDMST=$$FMTE^XLFDT($PIECE(BDMDATA,U,3))
+20 SET BDMET=$$FMTE^XLFDT($PIECE(BDMDATA,U,4))
+21 SET BDMTOR=$$GET1^DIQ(9003201.4,BDMIEN,.05)
+22 SET BDMOPT=$$GET1^DIQ(9003201.4,BDMIEN,.06)
+23 SET BDMRS=$$GET1^DIQ(9003201.4,BDMIEN,.07)
+24 ;S BDMI=BDMI+1
+25 SET ^TMP($JOB,BDMSTI,BDMIEN_"BDM")="A"_BDMIEN_U_BDMNM_U_BDMUSER_U_BDMST_U_BDMET_U_BDMOPT_U_BDMRS_U_BDMTOR
End DoDot:2
End DoDot:1
+26 NEW BDMDA
+27 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMGUI("AUSR",BDMDUZ,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+28 NEW BDMIEN
+29 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^BDMGUI("AUSR",BDMDUZ,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+30 NEW BDMDATA,BDMNM,BDMUSER,BDMST,BDMET,BDMTOR,BDMRS,BDMTOO,BDMSTI,BDMOPT
+31 SET BDMDATA=$GET(^BDMGUI(BDMIEN,0))
+32 SET BDMNM=$PIECE(BDMDATA,U)
+33 SET BDMUSER=$PIECE($GET(^VA(200,$PIECE(BDMDATA,U,2),0)),U)
+34 SET BDMSTI=9999999-$PIECE(BDMDATA,U,3)
+35 SET BDMST=$$FMTE^XLFDT($PIECE(BDMDATA,U,3))
+36 SET BDMET=$$FMTE^XLFDT($PIECE(BDMDATA,U,4))
+37 SET BDMTOR=$$GET1^DIQ(9003201.4,BDMIEN,.05)
+38 SET BDMOPT=$$GET1^DIQ(9003201.4,BDMIEN,.06)
+39 SET BDMRS=$$GET1^DIQ(9003201.4,BDMIEN,.07)
+40 ;S BDMI=BDMI+1
+41 SET ^TMP($JOB,BDMSTI,BDMIEN_"BDM")="B"_BDMIEN_U_BDMNM_U_BDMUSER_U_BDMST_U_BDMET_U_BDMOPT_U_BDMRS_U_BDMTOR
End DoDot:2
End DoDot:1
+42 NEW BDMDA
+43 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^TMP($JOB,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+44 NEW BDMTIEN
+45 SET BDMTIEN=0
FOR
SET BDMTIEN=$ORDER(^TMP($JOB,BDMDA,BDMTIEN))
IF BDMTIEN=""
QUIT
Begin DoDot:2
+46 SET BDMI=BDMI+1
+47 SET ^BDMTMP($JOB,BDMI)=$GET(^TMP($JOB,BDMDA,BDMTIEN))_$CHAR(30)
End DoDot:2
End DoDot:1
+48 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+49 QUIT
+50 ;
DCMP(BDMRET,BDMSTR) ;-- delete complications list
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,R,I,BDMDA
+3 SET P="|"
SET R="~"
+4 SET BDMERR=""
+5 KILL ^BDMTMP($JOB)
+6 SET RETVAL="^BDMTMP("_$JOB_")"
+7 SET BDMDA=$PIECE(BDMSTR,P)
+8 FOR I=2:1
Begin DoDot:1
+9 IF $PIECE(BDMSTR,R,I)=""
QUIT
+10 SET DA(1)=$PIECE(BDMSTR,R,I)
+11 SET DIK="^ACM(42.1,"_DA(1)_","_"""RG"""_","
SET DA=BDMDA
DO ^DIK
End DoDot:1
IF $PIECE(BDMSTR,R,I)=""
QUIT
+12 SET ^BDMTMP($JOB,0)="T00250DATA"_$CHAR(30)
+13 SET ^BDMTMP($JOB,1)=$GET(BDMERR)_$CHAR(30)
+14 SET ^BDMTMP($JOB,2)=$CHAR(31)_BDMERR
+15 QUIT
+16 ;
GETIEN(BDMRET,BDMSTR) ;-- get ien of file based on xref value passed in
+1 ;m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMGFL,BDMGXRF,BDMGVAL,BDMGGLB,BDMGI,BDMGLK
+3 SET P="|"
+4 SET BDMGFL=$PIECE(BDMSTR,P)
+5 SET BDMGXRF=$PIECE(BDMSTR,P,2)
+6 SET BDMGVAL=$PIECE(BDMSTR,P,3)
+7 SET BDMGGLB=^DIC(BDMGFL,0,"GL")
+8 KILL ^BDMTMP($JOB)
+9 SET BDMGI=0
+10 SET BDMRET="^BDMTMP("_$JOB_")"
+11 SET ^BDMTMP($JOB,BDMGI)="T00007BMXIEN"_$CHAR(30)
+12 SET BDMGI=BDMGI+1
+13 SET BDMGLK=BDMGGLB_""""_BDMGXRF_""")"
+14 SET ^BDMTMP($JOB,BDMGI)=$ORDER(@BDMGLK@(BDMGVAL,0))_$CHAR(30)
+15 SET ^BDMTMP($JOB,BDMGI+1)=$CHAR(31)
+16 QUIT
+17 ;
STCNT(BDMRET,BDMSTR) ;-- get search template count and return result
+1 NEW P,BDMTRNE,BDMTRN,BDMI,BDMRG,BDMRGE
+2 SET P="|"
+3 SET BDMTRNE=$PIECE(BDMSTR,P,2)
+4 SET BDMTRN=$ORDER(^DIBT("B",BDMTRNE,0))
+5 SET BDMRGE=$PIECE(BDMSTR,P)
+6 SET BDMRG=$ORDER(^ACM(41.1,"B",BDMRGE,0))
+7 SET BDMRET="^BDMTMP("_$JOB_")"
+8 KILL ^BDMTMP($JOB)
+9 SET ^BDMTMP($JOB,0)="T10000TEXT"_$CHAR(30)
+10 SET BDMI=0
+11 NEW BDMDA,BDMCNT
+12 SET BDMCNT=0
+13 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIBT(BDMTRN,1,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+14 SET BDMCNT=BDMCNT+1
End DoDot:1
+15 SET ^BDMTMP($JOB,1)="There are "_BDMCNT_" patients in this search template"_$CHAR(30)
+16 SET ^BDMTMP($JOB,2)="The following transfer has been selected:"_$CHAR(30)
+17 SET ^BDMTMP($JOB,3)="From SEARCH TEMPLATE: "_BDMTRNE_$CHAR(30)
+18 SET ^BDMTMP($JOB,4)="To CMS register: "_BDMRGE_$CHAR(30)
+19 SET ^BDMTMP($JOB,5)="Transfer Status: A - ACTIVE"_$CHAR(30)
+20 SET ^BDMTMP($JOB,6)=$CHAR(31)
+21 QUIT
+22 ;
CHKPN(BDMRET,BDMSTR) ;-- check the problem number on DMU
+1 NEW P,BDMPN,AUPNPAT
+2 SET P="|"
+3 SET BDMPN=$PIECE(BDMSTR,P)
+4 SET AUPNPAT=$PIECE(BDMSTR,P,2)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 KILL ^BDMTMP($JOB)
+7 SET ^BDMTMP($JOB,0)="T00007VALIDPROBLEMNUMBER"_$CHAR(30)
+8 NEW BDMVPN
+9 SET BDMVPN=$$PROBNUM^APCDDMUP(BDMPN)
+10 SET ^BDMTMP($JOB,1)=BDMVPN_$CHAR(30)
+11 SET ^BDMTMP($JOB,2)=$CHAR(31)
+12 QUIT
+13 ;
LOCG(RETVAL,BDMSTR) ;-- get the local option entry
+1 NEW P,BDMIEN,BDMCODE,BDMTEXT
+2 SET P="|"
+3 SET BDMIEN=$PIECE(BDMSTR,P)
+4 SET RETVAL="^BDMTMP("_$JOB_")"
+5 KILL ^BDMTMP($JOB)
+6 SET @RETVAL@(0)="T00001Code^T00030Text"_$CHAR(30)
+7 SET BDMCODE=$$GET1^DIQ(9002241,BDMIEN,1101)
+8 SET BDMTEXT=$$GET1^DIQ(9002241,BDMIEN,1102)
+9 SET @RETVAL@(1)=BDMCODE_U_BDMTEXT_$CHAR(30)
+10 SET @RETVAL@(2)=$CHAR(31)
+11 QUIT
+12 ;
LOCS(RETVAL,BDMSTR) ;-- save the local option entry
+1 NEW P,BDMIEN,BDMCODE,BDMTEXT,BDMRET
+2 SET P="|"
+3 SET BDMIEN=$PIECE(BDMSTR,P)
+4 SET BDMCODE=$PIECE(BDMSTR,P,2)
+5 SET BDMTEXT=$PIECE(BDMSTR,P,3)
+6 SET RETVAL="^BDMTMP("_$JOB_")"
+7 KILL ^BDMTMP($JOB)
+8 SET @RETVAL@(0)="T00001return"_$CHAR(30)
+9 NEW FDA,FIENS,FERR
+10 SET FIENS=BDMIEN_","
+11 SET FDA(9002241,FIENS,1101)=BDMCODE
+12 SET FDA(9002241,FIENS,1102)=BDMTEXT
+13 DO UPDATE^DIE("K","FDA","FERR(1)")
+14 SET BDMRET=$SELECT($DATA(FERR(1)):1,1:0)
+15 SET @RETVAL@(1)=BDMRET_$CHAR(30)
+16 SET @RETVAL@(2)=$CHAR(31)
+17 QUIT
+18 ;
