BMCRR22P ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ PRINTS COMMENTS FROM RCIS COMMENT FILE
;IHS/ITSC/FCJ MODIFIED PRINT FORMAT AND ADDED SR SUF
;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMCPG=0 I '$D(^XTMP("BMCRR22",BMCJOB,BMCBT)) D @("HEAD"_(2-($E(IOST,1,2)="C-"))) W !,"No referrals to report",! G XIT
S BMCPN=0 K BMCQUIT D @("HEAD"_(2-($E(IOST,1,2)="C-")))
F S BMCPN=$O(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) D DFN
XIT ;
K ^XTMP("BMCRR22",BMCJOB,BMCBT)
K BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
K BMCCTYP
D KILL^AUPNPAT
K DFN
Q
DFN ;
S DFN="" F S DFN=$O(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN)) Q:DFN=""!($D(BMCQUIT)) D PRINT
Q
PRINT ;print one referral
S BMC2="15,61",BMC1="1,45"
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT)) S BMCRREC=^BMCREF(BMCREF,0) D BUILD
Q
BUILD ; build array
K BMCAR
S BMCRREC=^BMCREF(BMCREF,0)
I $P($G(^BMCREF(BMCREF,1)),U)'="",BMCTYPR'="Y" Q
W !!
S Y=$P(BMCRREC,U,3) D ^AUPNPAT
S BMCSTR="",BMCCTR=0
W "Name: "_$E($P(^DPT($P(BMCRREC,U,3),0),U),1,25),?32,$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN)
W ?60,"Ref:",$$VAL^XBDIQ1(90001,BMCREF,.02),$P($G(^BMCREF(BMCREF,1)),U)
K BMCAR D ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
S I=0 F S I=$O(BMCAR(I)) Q:I'=+I S BMCSTR=BMCAR(I,.01)_" "
I BMCSTR]"" S BMCSTR="AKA'S: "_BMCSTR D SET Q:$D(BMCQUIT)
S BMCSTR="Tribe: "_$E($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$S($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
S BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118) D SET Q:$D(BMCQUIT)
CHARTS ;print duz(2) chart then first 4 in mult.
K BMCAR D ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
I $D(BMCAR(DUZ(2))) S BMCSTR=$P(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02) S (I,F,C)=0 F S I=$O(BMCAR(I)) Q:I'=+I!(C>4) I I'=DUZ(2) S C=C+1,BMCSTR=BMCSTR_" "_$P(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
D SET Q:$D(BMCQUIT)
REQ ;
S BMCSTR="Referred To:",Y=$$FACREF^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="Attending:"
S BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$E($$VAL^XBDIQ1(90001,BMCREF,.09),1,18),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$L(Y)) D SET Q:$D(BMCQUIT)
S BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06) D SET Q:$D(BMCQUIT)
S BMCSTR="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19) D SET Q:$D(BMCQUIT)
S BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Date Discharge Consult Rec'd: "_$$VAL^XBDIQ1(90001,BMCREF,.18) D SET Q:$D(BMCQUIT)
S BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201) D SET Q:$D(BMCQUIT)
DRG ;
S BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11) D SET Q:$D(BMCQUIT)
D VFILES
2 ;BUSINESS OFFICE COMMENTS
I '$D(^BMCCOM("AD",BMCREF)) Q
S BMCCTYP="B",BMCSTR="Business Office Notes: " D COMMENTS Q:$D(BMCQUIT)
3 ;
S BMCCTYP="D",BMCSTR="Discharge Comments: " D COMMENTS Q:$D(BMCQUIT)
4 ;CASE REVIEW COMMENTS
S BMCCTYP="C",BMCSTR="Case Review Comments: " D COMMENTS Q:$D(BMCQUIT)
Q
D COMMENTS^BMCRR5P
Q:BMCOPT="B"
;S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET
Q
VFILES ;set up array of all v file entries
NEW DA,D0,DIC,DIQ,DR,DI
S BMCVFLE=90001 F BMCVL=0:0 S BMCVFLE=$O(^DIC(BMCVFLE)) Q:BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($D(BMCQUIT)) D VF2
Q
;
VF2 ;
S BMCVNM=$P(^DIC(BMCVFLE,0),U),BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)",BMCVDFN=""
F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN="" D VF3
Q
;
VF3 ;
I BMCVI<2 S BMCSTR=$E(BMCVNM)_$$LOW^XLFSTR($E(BMCVNM,2,99)) D SET Q:$D(BMCQUIT)
K BMCAR D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 2 NEW LINES
S BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
I BMCVFLE="90001.01" D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01","BMCAR(","I") S BMCAR(.01)=$P($$ICDDX^ICDEX(BMCAR(.01,"I"),BMCDOS,,"I"),U,2)
S Y=BMCAR(.01)_" - "_BMCAR(.06),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$L(Y)) D SET Q:$D(BMCQUIT)
Q
S ;
S (C,F)=0 F S F=$O(BMCAR(F)) Q:F'=+F I BMCAR(F)]"" D
.S C=C+1,Y=$E($S($G(^DD(90001,F,.1))]"":$P(^DD(90001,F,.1),U),1:$P(^DD(90001,F,0),U)),1,13)_": ",Y=$E(Y)_$$LOW^XLFSTR($E(Y,2,999)),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC1,",",C),$L(Y))
.S Y=$E(BMCAR(F),1,20),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC2,",",C),$L(Y))
D SET Q:$D(BMCQUIT)
Q
BUILD1 ;
S BMCSTR=$E(BMCH,1,25)_":",BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$L(BMCV))
D SET Q:$D(BMCQUIT)
Q
SET ;set array
I $Y>(IOSL-3),BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
W !,BMCSTR
S BMCSTR=""
Q
;
WP ;EP - Entry point to print wp fields pass node in BMCNODE
;PASS FILE IN BMCFILE, ENTRY IN BMCREF
K ^UTILITY($J,"W")
S BMCX=0
I '$D(BMCG) S BMCG=^DIC(BMCFILE,0,"GL"),BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
S DIWL=1,DIWR=75,DIWF="C75" F S BMCX=$O(@BMCG) Q:BMCX'=+BMCX!($D(BMCQUIT)) D
.S Y=$P(BMCG,")")_",0)" S X=@Y D ^DIWP
.Q
WPS ;EP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(BMCQUIT)) S BMCSTR=$$SETSTR^VALM1(^UTILITY($J,"W",DIWL,Z,0),BMCSTR,5,$L(^UTILITY($J,"W",DIWL,Z,0))) D SET Q:$D(BMCQUIT)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
Q
HEAD ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
S BMCPG=BMCPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
W !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($H),"1P")
W !,BMC80D
Q
BMCRR22P ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ PRINTS COMMENTS FROM RCIS COMMENT FILE
+3 ;IHS/ITSC/FCJ MODIFIED PRINT FORMAT AND ADDED SR SUF
+4 ;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
+5 ;
+6 SET BMC80E="==============================================================================="
+7 SET BMC80D="-------------------------------------------------------------------------------"
+8 SET BMCPG=0
IF '$DATA(^XTMP("BMCRR22",BMCJOB,BMCBT))
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
WRITE !,"No referrals to report",!
GOTO XIT
+9 SET BMCPN=0
KILL BMCQUIT
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+10 FOR
SET BMCPN=$ORDER(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN))
IF BMCPN=""!($DATA(BMCQUIT))
QUIT
DO DFN
XIT ;
+1 KILL ^XTMP("BMCRR22",BMCJOB,BMCBT)
+2 KILL BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
+3 KILL BMCCTYP
+4 DO KILL^AUPNPAT
+5 KILL DFN
+6 QUIT
DFN ;
+1 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN))
IF DFN=""!($DATA(BMCQUIT))
QUIT
DO PRINT
+2 QUIT
PRINT ;print one referral
+1 SET BMC2="15,61"
SET BMC1="1,45"
+2 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR22",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN,BMCREF))
IF BMCREF'=+BMCREF!($DATA(BMCQUIT))
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
DO BUILD
+3 QUIT
BUILD ; build array
+1 KILL BMCAR
+2 SET BMCRREC=^BMCREF(BMCREF,0)
+3 IF $PIECE($GET(^BMCREF(BMCREF,1)),U)'=""
IF BMCTYPR'="Y"
QUIT
+4 WRITE !!
+5 SET Y=$PIECE(BMCRREC,U,3)
DO ^AUPNPAT
+6 SET BMCSTR=""
SET BMCCTR=0
+7 WRITE "Name: "_$EXTRACT($PIECE(^DPT($PIECE(BMCRREC,U,3),0),U),1,25),?32,$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN)
+8 WRITE ?60,"Ref:",$$VAL^XBDIQ1(90001,BMCREF,.02),$PIECE($GET(^BMCREF(BMCREF,1)),U)
+9 KILL BMCAR
DO ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
+10 SET I=0
FOR
SET I=$ORDER(BMCAR(I))
IF I'=+I
QUIT
SET BMCSTR=BMCAR(I,.01)_" "
+11 IF BMCSTR]""
SET BMCSTR="AKA'S: "_BMCSTR
DO SET
IF $DATA(BMCQUIT)
QUIT
+12 SET BMCSTR="Tribe: "_$EXTRACT($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$SELECT($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
+13 SET BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118)
DO SET
IF $DATA(BMCQUIT)
QUIT
CHARTS ;print duz(2) chart then first 4 in mult.
+1 KILL BMCAR
DO ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
+2 IF $DATA(BMCAR(DUZ(2)))
SET BMCSTR=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02)
SET (I,F,C)=0
FOR
SET I=$ORDER(BMCAR(I))
IF I'=+I!(C>4)
QUIT
IF I'=DUZ(2)
SET C=C+1
SET BMCSTR=BMCSTR_" "_$PIECE(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
+3 DO SET
IF $DATA(BMCQUIT)
QUIT
REQ ;
+1 SET BMCSTR="Referred To:"
SET Y=$$FACREF^BMCRLU(BMCREF)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$LENGTH(Y))
SET Y="Attending:"
+2 SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$LENGTH(Y))
SET Y=$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,18)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$LENGTH(Y))
DO SET
IF $DATA(BMCQUIT)
QUIT
+3 SET BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
DO SET
IF $DATA(BMCQUIT)
QUIT
+4 SET BMCSTR="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19)
DO SET
IF $DATA(BMCQUIT)
QUIT
+5 SET BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Date Discharge Consult Rec'd: "_$$VAL^XBDIQ1(90001,BMCREF,.18)
DO SET
IF $DATA(BMCQUIT)
QUIT
+6 SET BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
DO SET
IF $DATA(BMCQUIT)
QUIT
DRG ;
+1 SET BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11)
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 DO VFILES
2 ;BUSINESS OFFICE COMMENTS
+1 IF '$DATA(^BMCCOM("AD",BMCREF))
QUIT
+2 SET BMCCTYP="B"
SET BMCSTR="Business Office Notes: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
3 ;
+1 SET BMCCTYP="D"
SET BMCSTR="Discharge Comments: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
4 ;CASE REVIEW COMMENTS
+1 SET BMCCTYP="C"
SET BMCSTR="Case Review Comments: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
+2 QUIT
+1 DO COMMENTS^BMCRR5P
+2 IF BMCOPT="B"
QUIT
+3 ;S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET
+4 QUIT
VFILES ;set up array of all v file entries
+1 NEW DA,D0,DIC,DIQ,DR,DI
+2 SET BMCVFLE=90001
FOR BMCVL=0:0
SET BMCVFLE=$ORDER(^DIC(BMCVFLE))
IF BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($DATA(BMCQUIT))
QUIT
DO VF2
+3 QUIT
+4 ;
VF2 ;
+1 SET BMCVNM=$PIECE(^DIC(BMCVFLE,0),U)
SET BMCVDG=^DIC(BMCVFLE,0,"GL")
SET BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)"
SET BMCVDFN=""
+2 FOR BMCVI=1:1
SET BMCVDFN=$ORDER(@BMCVIGR)
IF BMCVDFN=""
QUIT
DO VF3
+3 QUIT
+4 ;
VF3 ;
+1 IF BMCVI<2
SET BMCSTR=$EXTRACT(BMCVNM)_$$LOW^XLFSTR($EXTRACT(BMCVNM,2,99))
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 KILL BMCAR
DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
+3 ;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 2 NEW LINES
+4 SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+5 IF BMCVFLE="90001.01"
DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01","BMCAR(","I")
SET BMCAR(.01)=$PIECE($$ICDDX^ICDEX(BMCAR(.01,"I"),BMCDOS,,"I"),U,2)
+6 SET Y=BMCAR(.01)_" - "_BMCAR(.06)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$LENGTH(Y))
DO SET
IF $DATA(BMCQUIT)
QUIT
+7 QUIT
S ;
+1 SET (C,F)=0
FOR
SET F=$ORDER(BMCAR(F))
IF F'=+F
QUIT
IF BMCAR(F)]""
Begin DoDot:1
+2 SET C=C+1
SET Y=$EXTRACT($SELECT($GET(^DD(90001,F,.1))]"":$PIECE(^DD(90001,F,.1),U),1:$PIECE(^DD(90001,F,0),U)),1,13)_": "
SET Y=$EXTRACT(Y)_$$LOW^XLFSTR($EXTRACT(Y,2,999))
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC1,",",C),$LENGTH(Y))
+3 SET Y=$EXTRACT(BMCAR(F),1,20)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC2,",",C),$LENGTH(Y))
End DoDot:1
+4 DO SET
IF $DATA(BMCQUIT)
QUIT
+5 QUIT
BUILD1 ;
+1 SET BMCSTR=$EXTRACT(BMCH,1,25)_":"
SET BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$LENGTH(BMCV))
+2 DO SET
IF $DATA(BMCQUIT)
QUIT
+3 QUIT
SET ;set array
+1 IF $Y>(IOSL-3)
IF BMCOPT'="B"
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 WRITE !,BMCSTR
+3 SET BMCSTR=""
+4 QUIT
+5 ;
WP ;EP - Entry point to print wp fields pass node in BMCNODE
+1 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
+2 KILL ^UTILITY($JOB,"W")
+3 SET BMCX=0
+4 IF '$DATA(BMCG)
SET BMCG=^DIC(BMCFILE,0,"GL")
SET BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
+5 SET DIWL=1
SET DIWR=75
SET DIWF="C75"
FOR
SET BMCX=$ORDER(@BMCG)
IF BMCX'=+BMCX!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+6 SET Y=$PIECE(BMCG,")")_",0)"
SET X=@Y
DO ^DIWP
+7 QUIT
End DoDot:1
WPS ;EP
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(BMCQUIT))
QUIT
SET BMCSTR=$$SETSTR^VALM1(^UTILITY($JOB,"W",DIWL,Z,0),BMCSTR,5,$LENGTH(^UTILITY($JOB,"W",DIWL,Z,0)))
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
+4 QUIT
HEAD ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 SET BMCPG=BMCPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
+3 WRITE !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($HOROLOG),"1P")
+4 WRITE !,BMC80D
+5 QUIT
