BMCRR19P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9,12**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ ADDED PRINTING OF SECONDARY REF AND DX CAT
;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;4.0*9 11.2.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
;
;
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR19",BMCJOB,BMCBT)) W !,"No referrals to report",! G XIT
S BMCPN=0,BMCQUIT=0
S BMCDATE="" F S BMCDATE=$O(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE)) Q:BMCDATE=""!(BMCQUIT) D P
XIT ;
K ^XTMP("BMCRR19",BMCJOB,BMCBT)
D DONE^BMCRLP2
D KILL^AUPNPAT
K BMCDATE,BMCI,BMCCTYP,BMCRNUMB
Q
P ;
S BMCPN="" F S BMCPN=$O(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN)) Q:BMCPN=""!(BMCQUIT) D PRINT
Q
PRINT ;print one referral
I $Y>(IOSL-10) D HEAD Q:BMCQUIT
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCREF)) Q:BMCREF'=+BMCREF!(BMCQUIT) S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PRINT1
Q
PRINT1 ;
S BMCRNUMB=$P($G(^BMCREF(BMCREF,0)),U,2)
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
W !,$E($P(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
W !,"Tribe: ",$E($$TRIBE^AUPNPAT(DFN,"E"),1,20),?32,"Req Provider: ",$$VAL^XBDIQ1(90001,BMCREF,.06)
W !,"Referral #: ",BMCRNUMB W ?32,"Date Referral Initiated: ",$$REFDTI^BMCRLU(BMCREF,"S")
S BMCC=0 W !,"3RD Party: " I $$MCR^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$P(BMCRREC,U))) W "MEDICARE" S BMCC=BMCC+1
I $$MCD^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$P(BMCRREC,U))) D
.W:BMCC " " W "MEDICAID: ",$$MCDPN^AUPNPAT(DFN,$$AVDOS^BMCRLU(BMCREF,"I"),"E") S BMCC=BMCC+1
I $$PI^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$P(BMCRREC,U))) D
.W:BMCC " " W $$PIN^AUPNPAT(DFN,$$AVDOS^BMCRLU(BMCREF,"I"),"E")
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
W !,"Refer To:",?10,$E($$FACREF^BMCRLU(BMCREF),1,20),?32,$S($$VAL^XBDIQ1(90001,BMCREF,.09)]"":"Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")
SECREF ;Secondary Referral
D SECREF2^BMCRUTL
PRIPAY ;Primary Payor
I $P(BMCRREC,U,11)'="" W !,"Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11)
;
TYPE ;
I $P(BMCRREC,U,4)'="" W ?50,"Referral Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
I $P(BMCRREC,U,14)="I" D Q:BMCQUIT I 1
.W !,"Inpatient Admission Date: ",$$AVDOS^BMCRLU(BMCREF,"C"),?45,"LOS: ",$$AVLOS^BMCRLU(BMCREF,"C")
E D
.W !,"Outpatient Services requested for: ",$$AVDOS^BMCRLU(BMCREF,"C")," # of Visits: ",$$VAL^XBDIQ1(90001,BMCREF,1111)
PURPOSE ;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
K BMCP W !,"Purpose:"
S BMCP=$$GET1^DIQ(90001,BMCREF,1201,"","BMCP"),BMCP=$TR(BMCP,"|","") ;BMC*3.1*12 ADDED TR COMMAND
S DIWL=1,DIWF="C66" S X=BMCP D ^DIWP
S (C,Z)=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!(BMCQUIT) S C=C+1 D:$Y>(IOSL-3) HEAD Q:BMCQUIT W:C'=1 ! W ?10,^UTILITY($J,"W",DIWL,Z,0)
Q:BMCQUIT
K DIWL,DIWR,DIWF,Z,^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
PERTMED ;
S BMCCTYP="M"
D:$D(^BMCCOM("AD",BMCREF)) BO^BMCRUTL
Q:BMCQUIT
DX ;Print either prov nar/canned nar
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
W !,"Dx Cat:",?10,$$GET1^DIQ(90001,BMCREF,.12)
I $D(^BMCDX("AD",BMCREF)) D I 1
.W !,"Dx:"
.S BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N") ;BMC*4.0*9
.S (C,X)=0 F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!(BMCQUIT) S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-3) HEAD Q:BMCQUIT W:C'=1 ! D
..S BMCDXDOC="" I $P($G(^BMCDX(X,0)),U,6)'="" S BMCDXDOC=$P($G(^BMCDX(X,0)),U,6)
..;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10
..;W ?10,$P(^ICD9(BMCD,0),U),?19," - ",$S(BMCDXDOC'="":$E($P(^AUTNPOV(BMCDXDOC,0),U,1),1,50),1:$E($P(^ICD9(BMCD,0),U,3),1,50))
..;W ?10,$P($$ICDDX^ICDCODE(BMCD,0),U,2),?19," - ",$S(BMCDXDOC'="":$E($P(^AUTNPOV(BMCDXDOC,0),U,1),1,50),1:$E($P($$ICDDX^ICDCODE(BMCD,0),U,4),1,50))
..W ?10,$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2),?19," - ",$S(BMCDXDOC'="":$E($P(^AUTNPOV(BMCDXDOC,0),U,1),1,50),1:$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50))
PROC ;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
I $D(^BMCPX("AD",BMCREF)) D I 1
.W !,"Proc:"
.S (C,X)=0
.;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
.;F S X=$O(^BMCPX("AD",BMCREF,X)) Q:X'=+X!(BMCQUIT) S C=C+1,BMCD=+^BMCPX(X,0) D:$Y>(IOSL-3) HEAD Q:BMCQUIT W:C'=1 ! W ?10,$P(^ICPT(BMCD,0),U),?19," - ",$E($P(^ICPT(BMCD,0),U,2),1,50)
.F S X=$O(^BMCPX("AD",BMCREF,X)) Q:X'=+X!(BMCQUIT) S C=C+1,BMCD=+^BMCPX(X,0) D:$Y>(IOSL-3) HEAD Q:BMCQUIT W:C'=1 ! W ?10,$P($$CPT^ICPTCOD(BMCD,0),U,2),?19," - ",$E($P($$CPT^ICPTCOD(BMCD,0),U,3),1,50)
E D
.W !,"Srv Cat:",?10,$$GET1^DIQ(90001,BMCREF,.13)
Q:BMCQUIT
BOC ;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
W !,"Priority: ",$$VAL^XBDIQ1(90001,BMCREF,.32)," CHS Auth Dec: ",$$VAL^XBDIQ1(90001,BMCREF,1112)," MCC Action: ",$$VAL^XBDIQ1(90001,BMCREF,1123)
W !,"Utilization Review by MD: ",$$VAL^XBDIQ1(90001,BMCREF,1125)
LOCAT ;Print Local Categories
I $D(^BMCREF(BMCREF,21,0)) D
. S BMCLOCC=0
.F S BMCLOCC=$O(^BMCREF(BMCREF,21,"B",BMCLOCC)) Q:BMCLOCC'=+BMCLOCC D
..S BMCLOCI=0
..F S BMCLOCI=$O(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI)) Q:BMCLOCI'=+BMCLOCI D
... S BMCLOCP=$P(^BMCREF(BMCREF,21,BMCLOCI,0),U)
... Q:BMCLOCP=""
... S BMCLOCPP=$P(^BMCLCAT(BMCLOCP,0),U)
... W !,"Local Category: "_BMCLOCPP
;
;
BO ;Business office Comments
S BMCCTYP="B"
D:$D(^BMCCOM("AD",BMCREF)) BO^BMCRUTL
Q:BMCQUIT
NEXT ;
W !,"--------------------",!
Q
HEAD ;ENTRY POINT
NEW X,Y,Z,C
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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
S Y=DT D DD^%DT W ?(80-$L(Y)/2),Y,!
W ?21,"**WEEKLY CHS REVIEW LISTING BY DATE**"
S Y=BMCBD D DD^%DT W !,?28,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W !,?28,"END DATE: "_Y
W !,$TR($J(" ",80)," ","-")
Q
BMCRR19P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9,12**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ ADDED PRINTING OF SECONDARY REF AND DX CAT
+3 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+4 ;4.0*9 11.2.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
+5 ;
+6 ;
+7 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRR19",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
GOTO XIT
+8 SET BMCPN=0
SET BMCQUIT=0
+9 SET BMCDATE=""
FOR
SET BMCDATE=$ORDER(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE))
IF BMCDATE=""!(BMCQUIT)
QUIT
DO P
XIT ;
+1 KILL ^XTMP("BMCRR19",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 DO KILL^AUPNPAT
+4 KILL BMCDATE,BMCI,BMCCTYP,BMCRNUMB
+5 QUIT
P ;
+1 SET BMCPN=""
FOR
SET BMCPN=$ORDER(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN))
IF BMCPN=""!(BMCQUIT)
QUIT
DO PRINT
+2 QUIT
PRINT ;print one referral
+1 IF $Y>(IOSL-10)
DO HEAD
IF BMCQUIT
QUIT
+2 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR19",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCREF))
IF BMCREF'=+BMCREF!(BMCQUIT)
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
DO PRINT1
+3 QUIT
PRINT1 ;
+1 SET BMCRNUMB=$PIECE($GET(^BMCREF(BMCREF,0)),U,2)
+2 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+3 SET BMCHRN="????"
IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))
SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
+4 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
+5 WRITE !,"Tribe: ",$EXTRACT($$TRIBE^AUPNPAT(DFN,"E"),1,20),?32,"Req Provider: ",$$VAL^XBDIQ1(90001,BMCREF,.06)
+6 WRITE !,"Referral #: ",BMCRNUMB
WRITE ?32,"Date Referral Initiated: ",$$REFDTI^BMCRLU(BMCREF,"S")
+7 SET BMCC=0
WRITE !,"3RD Party: "
IF $$MCR^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$PIECE(BMCRREC,U)))
WRITE "MEDICARE"
SET BMCC=BMCC+1
+8 IF $$MCD^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$PIECE(BMCRREC,U)))
Begin DoDot:1
+9 IF BMCC
WRITE " "
WRITE "MEDICAID: ",$$MCDPN^AUPNPAT(DFN,$$AVDOS^BMCRLU(BMCREF,"I"),"E")
SET BMCC=BMCC+1
End DoDot:1
+10 IF $$PI^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$PIECE(BMCRREC,U)))
Begin DoDot:1
+11 IF BMCC
WRITE " "
WRITE $$PIN^AUPNPAT(DFN,$$AVDOS^BMCRLU(BMCREF,"I"),"E")
End DoDot:1
+12 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+13 WRITE !,"Refer To:",?10,$EXTRACT($$FACREF^BMCRLU(BMCREF),1,20),?32,$SELECT($$VAL^XBDIQ1(90001,BMCREF,.09)]"":"Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")
SECREF ;Secondary Referral
+1 DO SECREF2^BMCRUTL
PRIPAY ;Primary Payor
+1 IF $PIECE(BMCRREC,U,11)'=""
WRITE !,"Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11)
+2 ;
TYPE ;
+1 IF $PIECE(BMCRREC,U,4)'=""
WRITE ?50,"Referral Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
+2 IF $PIECE(BMCRREC,U,14)="I"
Begin DoDot:1
+3 WRITE !,"Inpatient Admission Date: ",$$AVDOS^BMCRLU(BMCREF,"C"),?45,"LOS: ",$$AVLOS^BMCRLU(BMCREF,"C")
End DoDot:1
IF BMCQUIT
QUIT
IF 1
+4 IF '$TEST
Begin DoDot:1
+5 WRITE !,"Outpatient Services requested for: ",$$AVDOS^BMCRLU(BMCREF,"C")," # of Visits: ",$$VAL^XBDIQ1(90001,BMCREF,1111)
End DoDot:1
PURPOSE ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 KILL BMCP
WRITE !,"Purpose:"
+3 ;BMC*3.1*12 ADDED TR COMMAND
SET BMCP=$$GET1^DIQ(90001,BMCREF,1201,"","BMCP")
SET BMCP=$TRANSLATE(BMCP,"|","")
+4 SET DIWL=1
SET DIWF="C66"
SET X=BMCP
DO ^DIWP
+5 SET (C,Z)=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!(BMCQUIT)
QUIT
SET C=C+1
IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
IF C'=1
WRITE !
WRITE ?10,^UTILITY($JOB,"W",DIWL,Z,0)
+6 IF BMCQUIT
QUIT
+7 KILL DIWL,DIWR,DIWF,Z,^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
PERTMED ;
+1 SET BMCCTYP="M"
+2 IF $DATA(^BMCCOM("AD",BMCREF))
DO BO^BMCRUTL
+3 IF BMCQUIT
QUIT
DX ;Print either prov nar/canned nar
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 WRITE !,"Dx Cat:",?10,$$GET1^DIQ(90001,BMCREF,.12)
+3 IF $DATA(^BMCDX("AD",BMCREF))
Begin DoDot:1
+4 WRITE !,"Dx:"
+5 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+6 SET (C,X)=0
FOR
SET X=$ORDER(^BMCDX("AD",BMCREF,X))
IF X'=+X!(BMCQUIT)
QUIT
SET C=C+1
SET BMCD=+^BMCDX(X,0)
IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
IF C'=1
WRITE !
Begin DoDot:2
+7 SET BMCDXDOC=""
IF $PIECE($GET(^BMCDX(X,0)),U,6)'=""
SET BMCDXDOC=$PIECE($GET(^BMCDX(X,0)),U,6)
+8 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10
+9 ;W ?10,$P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P(^ICD9(BMCD,0),U),?19," - ",$S(BMCDXDOC'="":$E($P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P(^AUTNP_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">POV(BMCDXDOC,0),U,1),1,50),1:$E($P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P(^ICD9(BMCD,0),U,3),1,50))
+10 ;W ?10,$P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P($$ICDDX^ICDCODE(BMCD,0),U,2),?19," - ",$S(BMCDXDOC'="":$E($P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P(^AUTNP_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">POV(BMCDXDOC,0),U,1),1,50),1:$E($P_source.html#xP">P_source.html#xP_source.html#xP">P">P_source.html#xP">P($$ICDDX^ICDCODE(BMCD,0),U,4),1,50))
+11 WRITE ?10,$PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2),?19," - ",$SELECT(BMCDXDOC'="":$EXTRACT($PIECE(^AUTNPOV(BMCDXDOC,0),U,1),1,50),1:$EXTRACT($PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50))
End DoDot:2
End DoDot:1
IF 1
PROC ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 IF $DATA(^BMCPX("AD",BMCREF))
Begin DoDot:1
+3 WRITE !,"Proc:"
+4 SET (C,X)=0
+5 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+6 ;F S X=$O(^BMCP_source.html#xP">PX("AD",BMCREF,X)) Q:X'=+X!(BMCQUIT) S C=C+1,BMCD=+^BMCP_source.html#xP">PX(X,0) D:$Y>(IOSL-3) HEAD Q:BMCQUIT W:C'=1 ! W ?10,$P_source.html#xP">P(^ICP_source.html#xP">PT(BMCD,0),U),?19," - ",$E($P_source.html#xP">P(^ICP_source.html#xP">PT(BMCD,0),U,2),1,50)
+7 FOR
SET X=$ORDER(^BMCPX("AD",BMCREF,X))
IF X'=+X!(BMCQUIT)
QUIT
SET C=C+1
SET BMCD=+^BMCPX(X,0)
IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
IF C'=1
WRITE !
WRITE ?10,$PIECE($$CPT^ICPTCOD(BMCD,0),U,2),?19," - ",$EXTRACT($PIECE($$CPT^ICPTCOD(BMCD,0),U,3),1,50)
End DoDot:1
IF 1
+8 IF '$TEST
Begin DoDot:1
+9 WRITE !,"Srv Cat:",?10,$$GET1^DIQ(90001,BMCREF,.13)
End DoDot:1
+10 IF BMCQUIT
QUIT
BOC ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 WRITE !,"Priority: ",$$VAL^XBDIQ1(90001,BMCREF,.32)," CHS Auth Dec: ",$$VAL^XBDIQ1(90001,BMCREF,1112)," MCC Action: ",$$VAL^XBDIQ1(90001,BMCREF,1123)
+3 WRITE !,"Utilization Review by MD: ",$$VAL^XBDIQ1(90001,BMCREF,1125)
LOCAT ;Print Local Categories
+1 IF $DATA(^BMCREF(BMCREF,21,0))
Begin DoDot:1
+2 SET BMCLOCC=0
+3 FOR
SET BMCLOCC=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC))
IF BMCLOCC'=+BMCLOCC
QUIT
Begin DoDot:2
+4 SET BMCLOCI=0
+5 FOR
SET BMCLOCI=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI))
IF BMCLOCI'=+BMCLOCI
QUIT
Begin DoDot:3
+6 SET BMCLOCP=$PIECE(^BMCREF(BMCREF,21,BMCLOCI,0),U)
+7 IF BMCLOCP=""
QUIT
+8 SET BMCLOCPP=$PIECE(^BMCLCAT(BMCLOCP,0),U)
+9 WRITE !,"Local Category: "_BMCLOCPP
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 ;
BO ;Business office Comments
+1 SET BMCCTYP="B"
+2 IF $DATA(^BMCCOM("AD",BMCREF))
DO BO^BMCRUTL
+3 IF BMCQUIT
QUIT
NEXT ;
+1 WRITE !,"--------------------",!
+2 QUIT
HEAD ;ENTRY POINT
+1 NEW X,Y,Z,C
+2 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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
+4 SET Y=DT
DO DD^%DT
WRITE ?(80-$LENGTH(Y)/2),Y,!
+5 WRITE ?21,"**WEEKLY CHS REVIEW LISTING BY DATE**"
+6 SET Y=BMCBD
DO DD^%DT
WRITE !,?28,"BEG DATE: "_Y
+7 SET Y=BMCED
DO DD^%DT
WRITE !,?28,"END DATE: "_Y
+8 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+9 QUIT
