BMCRUTL.m

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       ;