BMCRC32.m

BMCRC32 ; IHS/OIT/FCJ - LIST APPROVED REFERRALS W/O PRINTED C32 ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;**7,9**;JAN 09, 2006;Build 101

 ;BMC*4.0*7 NEW ROUTINE

 ;

 ; This routine prints a list of approved Referrals that a C32 has not be printed for

 ;

START ;

 W !!,"This report prints out a list of Active referrals that",!,"a C32 has not been printed for.",!!

 W "Report will include Primary and Secondary Referrals.",!

BD ;GET BEG DATE OF REPORT

 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 EXT

 S (BMCBD,BMCSD)=Y

 D INIT

 Q:BMCQ

 D DBQUE

 Q

 ;

INIT ; INITIALIZAION

 S BMCQ=0

 D:$G(BMCPARM)="" PARMSET^BMC

 S BMCJOB=$J

 F  D  Q:BMCBT]""

 . S BMCBT=$H

 . LOCK +^XTMP("BMCRC32",BMCJOB,BMCBT):1

 . E  S BMCBT=""

 K ^XTMP("BMCRC32",$J,BMCBT)

 Q

 ;

DBQUE ;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=1 Q

 S BMCOPT=Y

 I $G(BMCOPT)="B" D BROWSE Q

 S XBRP="REFPRT^BMCRC32",XBRC="REFCHK^BMCRC32",XBRX="EOJ^BMCRC32",XBNS="BMC"

 D ^XBDBQUE

 Q

 ;

BROWSE ;

 S XBRP="VIEWR^XBLM(""REFPRT^BMCRC32"")"

 S XBRC="REFCHK^BMCRC32",XBRX="EOJ^BMCRC32",XBNS="BMC",XBIOP=0

 D ^XBDBQUE

 Q

 ;

REFCHK ; CHECK APPROVED REFERRALS SORTED BY DATE INIT

 S BMCODAT=BMCSD-1

 F  S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""  D R1

 Q

R1 ;

 S BMCRIEN="" F  S BMCRIEN=$O(^BMCREF("B",BMCODAT,BMCRIEN)) Q:BMCRIEN'=+BMCRIEN  S BMCRREC=^BMCREF(BMCRIEN,0) D PROC

 Q

 ;

PROC ;

 ;Q:$P(BMCRREC,U,15)'="A"    ;QUIT IF NOT ACTIVE  ;BMC*4.0*9 IHS.OIT.FCJ

 Q:($P(BMCRREC,U,15)="C1")!($P(BMCRREC,U,15)="X")  ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ 

 I '$D(^BMCREF(BMCRIEN,6)) S ^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 E  D  S:'BMCHIT ^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 . S BMCC32=0,BMCHIT=0

 . Q:'$O(^BMCREF(BMCRIEN,6,0))  ;    Not printed

 . F  S BMCC32=$O(^BMCREF(BMCRIEN,6,BMCC32)) Q:'BMCC32  D  Q:BMCHIT

 .. I ^BMCREF(BMCRIEN,6,BMCC32,0)>0 S BMCHIT=1

 Q

 ;

REFPRT ; PRINT REFERRALS SELECTED

 S $P(BMC80E,"=",80)=""

 S $P(BMC80D,"-",80)=""

 D REFPRT2

 K ^XTMP("BMCRC32",BMCJOB,BMCBT)

 Q

 ;

REFPRT2 ;

 S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRC32",BMCJOB,BMCBT)) W !,"No referrals to report",! D PAUSE^BMC Q

 S BMCRIEN=0 K BMCQUIT

 F  S BMCRIEN=$O(^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)) Q:BMCRIEN=""!($D(BMCQUIT))  D PRINT

 Q:$D(BMCQUIT)

 D PAUSE^BMC

 Q

 ;

PRINT ;print one referral

 S BMCRREC=^BMCREF(BMCRIEN,0)

 S Y=BMCRIEN

 D ^BMCREF

 I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)

 W BMCRNUMB_BMCSUF

 W ?17,$E(BMCREC("PAT NAME"),1,25)

 W ?49,$$FMTE^XLFDT($P(BMCRREC,U),"2D")

 ;

 K ^UTILITY($J,"W")

 F BMCL=0:0 S BMCL=$O(^BMCREF(BMCRIEN,1,BMCL)) Q:'BMCL  S X=^(BMCL,0) D

 . S DIWL=10,DIWR=70,DIWF="W"

 . D ^DIWP

 . Q

 D ^DIWW

 W !

 Q

 ;

HEAD ;

 D PAUSE^BMC

 I $D(DIRUT) S BMCQUIT="" Q

 D HEAD1

 Q

 ;

HEAD1 ;

 W:$D(IOF) @IOF

HEAD2 ; WRITE HEADER

 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,!

 W $$CTR^BMC("ACTIVE REFERRALS WHERE A C32 HAS NOT BEEN PRINTED",80),!

 S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y

 S Y=DT D DD^%DT W ?40,"END DATE: "_Y,!

 W !,"REFERRAL #",?17,"PATIENT NAME",?45," REFERRAL DATE"

 W !,BMC80D

 W !

 Q

 ;

EOJ ; END OF JOB

 LOCK -^XTMP("BMCRC32",BMCJOB)

 K ^XTMP("BMCRC32",BMCJOB,BMCBT)

EXT ;

 D ^BMCKILL

 K BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP

 K BMCBD,BMCSD,BMCODT

 Q

BMCRC32   ; IHS/OIT/FCJ - LIST APPROVED REFERRALS W/O PRINTED C32 ;   

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**7,9**;JAN 09, 2006;Build 101

 +2       ;BMC*4.0*7 NEW ROUTINE

 +3       ;

 +4       ; This routine prints a list of approved Referrals that a C32 has not be printed for

 +5       ;

START     ;

 +1        WRITE !!,"This report prints out a list of Active referrals that",!,"a C32 has not been printed for.",!!

 +2        WRITE "Report will include Primary and Secondary Referrals.",!

BD        ;GET BEG DATE OF REPORT

 +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 EXT

 +3        SET (BMCBD,BMCSD)=Y

 +4        DO INIT

 +5        IF BMCQ

               QUIT 

 +6        DO DBQUE

 +7        QUIT 

 +8       ;

INIT      ; INITIALIZAION

 +1        SET BMCQ=0

 +2        IF $GET(BMCPARM)=""

               DO PARMSET^BMC

 +3        SET BMCJOB=$JOB

 +4        FOR 

               Begin DoDot:1

 +5                SET BMCBT=$HOROLOG

 +6                LOCK +^XTMP("BMCRC32",BMCJOB,BMCBT):1

 +7               IF '$TEST

                       SET BMCBT=""

               End DoDot:1

               IF BMCBT]""

                   QUIT 

 +8        KILL ^XTMP("BMCRC32",$JOB,BMCBT)

 +9        QUIT 

 +10      ;

DBQUE     ;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=1

               QUIT 

 +4        SET BMCOPT=Y

 +5        IF $GET(BMCOPT)="B"

               DO BROWSE

               QUIT 

 +6        SET XBRP="REFPRT^BMCRC32"

           SET XBRC="REFCHK^BMCRC32"

           SET XBRX="EOJ^BMCRC32"

           SET XBNS="BMC"

 +7        DO ^XBDBQUE

 +8        QUIT 

 +9       ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""REFPRT^BMCRC32"")"

 +2        SET XBRC="REFCHK^BMCRC32"

           SET XBRX="EOJ^BMCRC32"

           SET XBNS="BMC"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT 

 +5       ;

REFCHK    ; CHECK APPROVED REFERRALS SORTED BY DATE INIT

 +1        SET BMCODAT=BMCSD-1

 +2        FOR 

               SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))

               IF BMCODAT=""

                   QUIT 

               DO R1

 +3        QUIT 

R1        ;

 +1        SET BMCRIEN=""

           FOR 

               SET BMCRIEN=$ORDER(^BMCREF("B",BMCODAT,BMCRIEN))

               IF BMCRIEN'=+BMCRIEN

                   QUIT 

               SET BMCRREC=^BMCREF(BMCRIEN,0)

               DO PROC

 +2        QUIT 

 +3       ;

PROC      ;

 +1       ;Q:$P(BMCRREC,U,15)'="A"    ;QUIT IF NOT ACTIVE  ;BMC*4.0*9 IHS.OIT.FCJ

 +2       ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ 

           IF ($PIECE(BMCRREC,U,15)="C1")!($PIECE(BMCRREC,U,15)="X")

               QUIT 

 +3        IF '$DATA(^BMCREF(BMCRIEN,6))

               SET ^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 +4       IF '$TEST

               Begin DoDot:1

 +5                SET BMCC32=0

                   SET BMCHIT=0

 +6       ;    Not printed

                   IF '$ORDER(^BMCREF(BMCRIEN,6,0))

                       QUIT 

 +7                FOR 

                       SET BMCC32=$ORDER(^BMCREF(BMCRIEN,6,BMCC32))

                       IF 'BMCC32

                           QUIT 

                       Begin DoDot:2

 +8                        IF ^BMCREF(BMCRIEN,6,BMCC32,0)>0

                               SET BMCHIT=1

                       End DoDot:2

                       IF BMCHIT

                           QUIT 

               End DoDot:1

               IF 'BMCHIT

                   SET ^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 +9        QUIT 

 +10      ;

REFPRT    ; PRINT REFERRALS SELECTED

 +1        SET $PIECE(BMC80E,"=",80)=""

 +2        SET $PIECE(BMC80D,"-",80)=""

 +3        DO REFPRT2

 +4        KILL ^XTMP("BMCRC32",BMCJOB,BMCBT)

 +5        QUIT 

 +6       ;

REFPRT2   ;

 +1        SET BMCPG=0

           DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))

           IF '$DATA(^XTMP("BMCRC32",BMCJOB,BMCBT))

               WRITE !,"No referrals to report",!

               DO PAUSE^BMC

               QUIT 

 +2        SET BMCRIEN=0

           KILL BMCQUIT

 +3        FOR 

               SET BMCRIEN=$ORDER(^XTMP("BMCRC32",BMCJOB,BMCBT,"DATA HITS",BMCRIEN))

               IF BMCRIEN=""!($DATA(BMCQUIT))

                   QUIT 

               DO PRINT

 +4        IF $DATA(BMCQUIT)

               QUIT 

 +5        DO PAUSE^BMC

 +6        QUIT 

 +7       ;

PRINT     ;print one referral

 +1        SET BMCRREC=^BMCREF(BMCRIEN,0)

 +2        SET Y=BMCRIEN

 +3        DO ^BMCREF

 +4        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT 

 +5        WRITE BMCRNUMB_BMCSUF

 +6        WRITE ?17,$EXTRACT(BMCREC("PAT NAME"),1,25)

 +7        WRITE ?49,$$FMTE^XLFDT($PIECE(BMCRREC,U),"2D")

 +8       ;

 +9        KILL ^UTILITY($JOB,"W")

 +10       FOR BMCL=0:0

               SET BMCL=$ORDER(^BMCREF(BMCRIEN,1,BMCL))

               IF 'BMCL

                   QUIT 

               SET X=^(BMCL,0)

               Begin DoDot:1

 +11               SET DIWL=10

                   SET DIWR=70

                   SET DIWF="W"

 +12               DO ^DIWP

 +13               QUIT 

               End DoDot:1

 +14       DO ^DIWW

 +15       WRITE !

 +16       QUIT 

 +17      ;

HEAD      ;

 +1        DO PAUSE^BMC

 +2        IF $DATA(DIRUT)

               SET BMCQUIT=""

               QUIT 

 +3        DO HEAD1

 +4        QUIT 

 +5       ;

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

HEAD2     ; WRITE HEADER

 +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        WRITE $$CTR^BMC("ACTIVE REFERRALS WHERE A C32 HAS NOT BEEN PRINTED",80),!

 +5        SET Y=BMCBD

           DO DD^%DT

           WRITE ?17,"BEG DATE: "_Y

 +6        SET Y=DT

           DO DD^%DT

           WRITE ?40,"END DATE: "_Y,!

 +7        WRITE !,"REFERRAL #",?17,"PATIENT NAME",?45," REFERRAL DATE"

 +8        WRITE !,BMC80D

 +9        WRITE !

 +10       QUIT 

 +11      ;

EOJ       ; END OF JOB

 +1        LOCK -^XTMP("BMCRC32",BMCJOB)

 +2        KILL ^XTMP("BMCRC32",BMCJOB,BMCBT)

EXT       ;

 +1        DO ^BMCKILL

 +2        KILL BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP

 +3        KILL BMCBD,BMCSD,BMCODT

 +4        QUIT