BMCRUTL ; IHS/ITSC/FCJ - REPORT UTILITES ;
;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
;
GETDATES ;EP
BD ;EP;get beginning date
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Referral Date" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G EXIT
S BMCBD=Y
ED ;get ending date
W ! S DIR(0)="DA^"_BMCBD_":DT:EP",DIR("A")="Enter ending Referral Date: " S Y=BMCBD D DD^%DT S Y="" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S BMCED=Y
S X1=BMCBD,X2=-1 D C^%DTC S BMCSD=X
S Y=BMCBD D DD^%DT S BMCBDD=Y S Y=BMCED D DD^%DT S BMCEDD=Y
;
Q
DT ;EP;FORMAT DATE
S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$S($E(Y,1,3)>299:20_$E(Y,2,3),1:(19_$E(Y,2,3)))
Q
SECREF ;EP;Secondary Referral
I $D(^BMCPROV("AD",BMCREF)) S BMCSRIEN=0 D
.F S BMCSRIEN=$O(^BMCPROV("AD",BMCREF,BMCSRIEN)) Q:BMCSRIEN'?1N.N D
..S Y=$P(^BMCPROV(BMCSRIEN,0),U) D DT^BMCRUTL S BMCSREF=" SEC "_Y
..S Y=$P(^BMCPROV(BMCSRIEN,0),U,6) D DT^BMCRUTL S BMCSREF=BMCSREF_" DOS "_Y
..W !,BMCSREF,?32,$E($$VAL^XBDIQ1(90001.04,BMCSRIEN,.07),1,22)
..S Y=$P($G(^BMCPROV(BMCSRIEN,2)),U,2)
..W ?55,$E($S(Y="C":$$VAL^XBDIQ1(90001.04,BMCSRIEN,.05),Y=I:$$VAL^XBDIQ1(90001.04,BMCSRIEN,.12),1:""),1,25)
K BMCRIEN,BMCSREF Q
SECREF2 ;EP;Secondary Referral
Q:BMCRNUMB=""
I $D(^BMCREF("S",BMCRNUMB)) S BMCSUF=0 D
.F S BMCSUF=$O(^BMCREF("S",BMCRNUMB,BMCSUF)) Q:BMCSUF'?1A.N D
..Q:$G(BMCSTST)=BMCSUF
..S BMCSRIEN=0
..F S BMCSRIEN=$O(^BMCREF("S",BMCRNUMB,BMCSUF,BMCSRIEN)) Q:BMCSRIEN'?1N.N D
...S Y=$P(^BMCREF(BMCSRIEN,0),U) D DT^BMCRUTL S BMCSREF=" SEC "_BMCSUF_" "_Y
...S Y=$S($P(^BMCREF(BMCSRIEN,11),U,6)'="":$P(^BMCREF(BMCSRIEN,11),U,6),1:$P(^BMCREF(BMCSRIEN,11),U,5)) D DT^BMCRUTL S BMCSREF=BMCSREF_" DOS "_Y
...W !,BMCSREF,?34,$E($$VAL^XBDIQ1(90001,BMCSRIEN,1201),1,21) ;FCJ CHG LENGHT FROM 22 TO 21
...S Y=$P($G(^BMCREF(BMCSRIEN,0)),U,4)
...W ?56,$E($S(Y="C":$$VAL^XBDIQ1(90001,BMCSRIEN,.07),Y="I":$$VAL^XBDIQ1(90001,BMCSRIEN,.08),1:""),1,24)
K BMCSUF,BMCSRIEN,BMCSREF Q
;
BO ;EP;PRINT BO COMMENTS
S BMCI=0,Y=0
F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'?1N.N D Q:BMCQUIT
.Q:$P(^BMCCOM(BMCI,0),U,5)'=BMCCTYP
.I Y=0,BMCCTYP="B" W !,"Business Office Comments:"
.S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCI D WP^BMCFDR K BMCIOM
.S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
..I $Y>(IOSL-3) D HEAD^BMCRR14P Q:BMCQUIT
..W !?5,BMCWP(Y)
Q
ZIS ;EP;call to XBDBQUE
K BMCOPT
W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) S BMCQUIT="" Q
S BMCOPT=Y
Q
EXIT ;
Q
;
BMCRUTL ; IHS/ITSC/FCJ - REPORT UTILITES ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
+2 ;
GETDATES ;EP
BD ;EP;get beginning date
+1 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Referral Date"
DO ^DIR
IF $DATA(DUOUT)
SET DIRUT=1
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO EXIT
+3 SET BMCBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="DA^"_BMCBD_":DT:EP"
SET DIR("A")="Enter ending Referral Date: "
SET Y=BMCBD
DO DD^%DT
SET Y=""
DO ^DIR
IF $DATA(DUOUT)
SET DIRUT=1
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET BMCED=Y
+4 SET X1=BMCBD
SET X2=-1
DO C^%DTC
SET BMCSD=X
+5 SET Y=BMCBD
DO DD^%DT
SET BMCBDD=Y
SET Y=BMCED
DO DD^%DT
SET BMCEDD=Y
+6 ;
+7 QUIT
DT ;EP;FORMAT DATE
+1 SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$SELECT($EXTRACT(Y,1,3)>299:20_$EXTRACT(Y,2,3),1:(19_$EXTRACT(Y,2,3)))
+2 QUIT
SECREF ;EP;Secondary Referral
+1 IF $DATA(^BMCPROV("AD",BMCREF))
SET BMCSRIEN=0
Begin DoDot:1
+2 FOR
SET BMCSRIEN=$ORDER(^BMCPROV("AD",BMCREF,BMCSRIEN))
IF BMCSRIEN'?1N.N
QUIT
Begin DoDot:2
+3 SET Y=$PIECE(^BMCPROV(BMCSRIEN,0),U)
DO DT^BMCRUTL
SET BMCSREF=" SEC "_Y
+4 SET Y=$PIECE(^BMCPROV(BMCSRIEN,0),U,6)
DO DT^BMCRUTL
SET BMCSREF=BMCSREF_" DOS "_Y
+5 WRITE !,BMCSREF,?32,$EXTRACT($$VAL^XBDIQ1(90001.04,BMCSRIEN,.07),1,22)
+6 SET Y=$PIECE($GET(^BMCPROV(BMCSRIEN,2)),U,2)
+7 WRITE ?55,$EXTRACT($SELECT(Y="C":$$VAL^XBDIQ1(90001.04,BMCSRIEN,.05),Y=I:$$VAL^XBDIQ1(90001.04,BMCSRIEN,.12),1:""),1,25)
End DoDot:2
End DoDot:1
+8 KILL BMCRIEN,BMCSREF
QUIT
SECREF2 ;EP;Secondary Referral
+1 IF BMCRNUMB=""
QUIT
+2 IF $DATA(^BMCREF("S",BMCRNUMB))
SET BMCSUF=0
Begin DoDot:1
+3 FOR
SET BMCSUF=$ORDER(^BMCREF("S",BMCRNUMB,BMCSUF))
IF BMCSUF'?1A.N
QUIT
Begin DoDot:2
+4 IF $GET(BMCSTST)=BMCSUF
QUIT
+5 SET BMCSRIEN=0
+6 FOR
SET BMCSRIEN=$ORDER(^BMCREF("S",BMCRNUMB,BMCSUF,BMCSRIEN))
IF BMCSRIEN'?1N.N
QUIT
Begin DoDot:3
+7 SET Y=$PIECE(^BMCREF(BMCSRIEN,0),U)
DO DT^BMCRUTL
SET BMCSREF=" SEC "_BMCSUF_" "_Y
+8 SET Y=$SELECT($PIECE(^BMCREF(BMCSRIEN,11),U,6)'="":$PIECE(^BMCREF(BMCSRIEN,11),U,6),1:$PIECE(^BMCREF(BMCSRIEN,11),U,5))
DO DT^BMCRUTL
SET BMCSREF=BMCSREF_" DOS "_Y
+9 ;FCJ CHG LENGHT FROM 22 TO 21
WRITE !,BMCSREF,?34,$EXTRACT($$VAL^XBDIQ1(90001,BMCSRIEN,1201),1,21)
+10 SET Y=$PIECE($GET(^BMCREF(BMCSRIEN,0)),U,4)
+11 WRITE ?56,$EXTRACT($SELECT(Y="C":$$VAL^XBDIQ1(90001,BMCSRIEN,.07),Y="I":$$VAL^XBDIQ1(90001,BMCSRIEN,.08),1:""),1,24)
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL BMCSUF,BMCSRIEN,BMCSREF
QUIT
+13 ;
BO ;EP;PRINT BO COMMENTS
+1 SET BMCI=0
SET Y=0
+2 FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'?1N.N
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCI,0),U,5)'=BMCCTYP
QUIT
+4 IF Y=0
IF BMCCTYP="B"
WRITE !,"Business Office Comments:"
+5 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCI
DO WP^BMCFDR
KILL BMCIOM
+6 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO HEAD^BMCRR14P
IF BMCQUIT
QUIT
+8 WRITE !?5,BMCWP(Y)
End DoDot:2
End DoDot:1
IF BMCQUIT
QUIT
+9 QUIT
ZIS ;EP;call to XBDBQUE
+1 KILL BMCOPT
+2 WRITE !
SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET BMCQUIT=""
QUIT
+4 SET BMCOPT=Y
+5 QUIT
EXIT ;
+1 QUIT
+2 ;
