BMCRR7P2 ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMCPG=0 I '$D(^XTMP("BMCRR7",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("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) D DFN
XIT ;
K ^XTMP("BMCRR7",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
D KILL^AUPNPAT
K DFN
Q
DFN ;
S DFN="" F S DFN=$O(^XTMP("BMCRR7",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("BMCRR7",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
;D TERM^VALM0
S BMCRREC=^BMCREF(BMCREF,0)
;I BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
W !!
S Y=$P(BMCRREC,U,3) D ^AUPNPAT
S BMCSTR="",BMCCTR=0
S BMCSTR="Name: "_$E($P(^DPT($P(BMCRREC,U,3),0),U),1,25)_" "_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN) D SET Q:$D(BMCQUIT)
S X=$$VAL^XBDIQ1(90001,BMCREF,.02) W ?57,"Ref #: "_X
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)
;K BMCAR D ENP^XBDIQ1(90001,BMCREF,".19;.31","BMCAR(","E") D S
S BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499) D SET Q:$D(BMCQUIT)
;S BMCSTR="Est LOS:",Y=$$AVLOS^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="LOS to Date: ",BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$$VAL^XBDIQ1(90001,BMCREF,.1499),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,61,$L(Y)) 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 ;
G:'$D(^BMCREF(BMCREF,2)) 3
S BMCSTR="Business Office Notes: " D SET Q:$D(BMCQUIT)
K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=2 D WP
S BMCSTR="" D SET Q:$D(BMCQUIT)
3 ;
G:'$D(^BMCREF(BMCREF,3)) COMMENTS
S BMCSTR="Discharge Comments:" D SET Q:$D(BMCQUIT)
K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=3 D WP
S BMCSTR="" D SET Q:$D(BMCQUIT)
I '$D(^BMCCOM("AD",BMCREF)) Q
S BMCI=0 F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT)) D
.S Y=$P(^BMCCOM(BMCI,0),U),BMCSTR="Comments Made on "_$$FMTE^XLFDT(Y,"5D") D SET Q:$D(BMCQUIT)
.S BMCG="^BMCCOM("_BMCI_",1,BMCX)" D WP
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")
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
BMCRR7P2 ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 SET BMC80E="==============================================================================="
+3 SET BMC80D="-------------------------------------------------------------------------------"
+4 SET BMCPG=0
IF '$DATA(^XTMP("BMCRR7",BMCJOB,BMCBT))
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
WRITE !,"No referrals to report",!
GOTO XIT
+5 SET BMCPN=0
KILL BMCQUIT
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+6 FOR
SET BMCPN=$ORDER(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN))
IF BMCPN=""!($DATA(BMCQUIT))
QUIT
DO DFN
XIT ;
+1 KILL ^XTMP("BMCRR7",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 DO KILL^AUPNPAT
+4 KILL DFN
+5 QUIT
DFN ;
+1 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BMCRR7",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("BMCRR7",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 ;D TERM^VALM0
+3 SET BMCRREC=^BMCREF(BMCREF,0)
+4 ;I BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
+5 WRITE !!
+6 SET Y=$PIECE(BMCRREC,U,3)
DO ^AUPNPAT
+7 SET BMCSTR=""
SET BMCCTR=0
+8 SET BMCSTR="Name: "_$EXTRACT($PIECE(^DPT($PIECE(BMCRREC,U,3),0),U),1,25)_" "_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN)
DO SET
IF $DATA(BMCQUIT)
QUIT
+9 SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)
WRITE ?57,"Ref #: "_X
+10 KILL BMCAR
DO ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
+11 SET I=0
FOR
SET I=$ORDER(BMCAR(I))
IF I'=+I
QUIT
SET BMCSTR=BMCAR(I,.01)_" "
+12 IF BMCSTR]""
SET BMCSTR="AKA'S: "_BMCSTR
DO SET
IF $DATA(BMCQUIT)
QUIT
+13 SET BMCSTR="Tribe: "_$EXTRACT($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$SELECT($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
+14 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 ;K BMCAR D ENP^XBDIQ1(90001,BMCREF,".19;.31","BMCAR(","E") D S
+5 SET BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499)
DO SET
IF $DATA(BMCQUIT)
QUIT
+6 ;S BMCSTR="Est LOS:",Y=$$AVLOS^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="LOS to Date: ",BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$$VAL^XBDIQ1(90001,BMCREF,.1499),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,61,$L(Y)) D SET Q:$D(BMCQUIT)
+7 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 ;
+1 IF '$DATA(^BMCREF(BMCREF,2))
GOTO 3
+2 SET BMCSTR="Business Office Notes: "
DO SET
IF $DATA(BMCQUIT)
QUIT
+3 KILL BMCG
SET BMCFILE=90001
SET BMCREF=BMCREF
SET BMCNODE=2
DO WP
+4 SET BMCSTR=""
DO SET
IF $DATA(BMCQUIT)
QUIT
3 ;
+1 IF '$DATA(^BMCREF(BMCREF,3))
GOTO COMMENTS
+2 SET BMCSTR="Discharge Comments:"
DO SET
IF $DATA(BMCQUIT)
QUIT
+3 KILL BMCG
SET BMCFILE=90001
SET BMCREF=BMCREF
SET BMCNODE=3
DO WP
+4 SET BMCSTR=""
DO SET
IF $DATA(BMCQUIT)
QUIT
+1 IF '$DATA(^BMCCOM("AD",BMCREF))
QUIT
+2 SET BMCI=0
FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'=+BMCI!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+3 SET Y=$PIECE(^BMCCOM(BMCI,0),U)
SET BMCSTR="Comments Made on "_$$FMTE^XLFDT(Y,"5D")
DO SET
IF $DATA(BMCQUIT)
QUIT
+4 SET BMCG="^BMCCOM("_BMCI_",1,BMCX)"
DO WP
End DoDot:1
+5 IF BMCOPT="B"
QUIT
+6 SET BMCSTR=""
DO SET
SET BMCSTR="Additional Comments:"
DO SET
+7 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 SET Y=BMCAR(.01)_" - "_BMCAR(.06)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$LENGTH(Y))
DO SET
IF $DATA(BMCQUIT)
QUIT
+4 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
