Routine: BMCRTC1

BMCRTC1 ; IHS/OIT/FCJ- LIST APPROVED REFERRALS WITH TOC PENDING; 15 Mar 2013  9:02 AM

 ;;4.0;REFERRED CARE INFO SYSTEM;**8,12**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ PATCH 8 NEW ROUTINE

 ; This routine lists approved referrals where the TOC status is pending

START ;

 W !!,"This report prints out a list of all approved referrals for which the status",!,"of the transition of care document is pending.",!!

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

 S BMCJOB=$J

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 EOJ

 S (BMCBD,BMCSD)=Y

 D INIT

 Q:BMCQ

 D DBQUE

INIT ; INITIALIZAION

 S BMCQ=0

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

 F  D  Q:BMCBT]""

 . S BMCBT=$H

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

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^BMCRTC1",XBRC="REFCHK^BMCRTC1",XBRX="EOJ^BMCRTC1",XBNS="BMC"

 D ^XBDBQUE

BROWSE ;

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

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

 D ^XBDBQUE

REFCHK ; CHECK FOR PENDING TOC AND APPROVED

 Q:'$D(^BMCREF("TOC","P"))

 S BMCODAT=BMCSD-1

 S BMCUSVN="" I $D(^AUTTVNDR("B","UNSPECIFIED")) S BMCUSVN=$O(^AUTTVNDR("B","UNSPECIFIED",0))  ;BMC*4.0*12

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

 .S (BMCRIEN,BMCPROV,BMCPDIR)="" F  S BMCRIEN=$O(^BMCREF("B",BMCODAT,BMCRIEN)) Q:BMCRIEN'=+BMCRIEN  D

 ..Q:$P(^BMCREF(BMCRIEN,0),U,4)="N"  ;BMC*4.0*12

 ..;BMC*4.0*12 IHS/OIT/FCJ NO LONGER CHECKING FOR TOC PENDING AND APPROVED, NOW ONLY CHECKNG FOR PRINTED OR TRANSMITTED

 ..;I $D(^BMCREF("TOC","P",BMCRIEN)),$P(^BMCREF(BMCRIEN,0),U,15)="A1"  D

 ..S CT=0 I $D(^BMCREF(BMCRIEN,6)) S L=0,CT=0 F  S L=$O(^BMCREF(BMCRIEN,6,L)) Q:L'?1N.N  S CT=CT+1

 ..I CT=0 D

 ...S BMCPROV=$P(^BMCREF(BMCRIEN,0),U,7)

 ...I BMCPROV="" Q:'BMCUSVN  S BMCPROV=BMCUSVN  ;BMC*4.0*12

 ...S BMCPDIR=$S($P($G(^AUTTVNDR(BMCPROV,21)),U,4)'="":$$VAL^XBDIQ1(9999999.11,BMCPROV,2104),1:"NO")

 ...S ^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV,BMCRIEN)=""

 K CT,L

REFPRT ; PRINT REFERRALS SELECTED

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

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

 D REFPRT2

 K ^XTMP("BMCRTC1",BMCJOB)

REFPRT2 ;

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

 S BMCPDIR=0

 F  S BMCPDIR=$O(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR)) Q:BMCPDIR=""!($D(BMCQUIT))  D

 .S BMCPROV=0 F  S BMCPROV=$O(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV)) Q:BMCPROV=""!($D(BMCQUIT))  D PRINT

 Q:$D(BMCQUIT)

 D PAUSE^BMC

PRINT ;Print Prov

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

 W !,$S(BMCPDIR="YES":"Direct ",1:""),"Provider:  ",$$VAL^XBDIQ1(9999999.11,BMCPROV,.01),!

 S BMCRIEN=0

 F  S BMCRIEN=$O(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV,BMCRIEN)) Q:BMCRIEN=""!($D(BMCQUIT))  D PRINTR

PRINTR ;Print Ref

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

 S BMCRREC=^BMCREF(BMCRIEN,0)

 S Y=BMCRIEN

 D ^BMCREF

 W BMCRNUMB_BMCSUF

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

 W ?48,$$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

 D ^DIWW

W !

HEAD ;

 D PAUSE^BMC

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

 D HEAD1

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("APPROVED REFERRALS WHERE TRANSITION OF CARE DOCUMENT IS PENDING",80),!  ;BMC*4.0*12 IHS/OIT/FCJ

 W $$CTR^BMC("TRANSITION OF CARE DOCUMENT PENDING PRINTED OR TRANSMITTED",80),!  ;BMC*4.0*12 IHS/OIT/FCJ

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

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

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

 W !,"REFERRAL #",?16,"PATIENT NAME",?45,"REFERRAL-DATE"

 W !,BMC80D

W !

EOJ ; END OF JOB

 K ^XTMP("BMCRTC1",BMCJOB)

 D ^BMCKILL

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

 K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD,BMCUSVN

BMCRTC1   ; IHS/OIT/FCJ- LIST APPROVED REFERRALS WITH TOC PENDING; 15 Mar 2013  9:02 AM

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**8,12**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ PATCH 8 NEW ROUTINE

 +3       ;

 +4       ; This routine lists approved referrals where the TOC status is pending

 +5       ;

 +6       ;

START     ;

 +1        WRITE !!,"This report prints out a list of all approved referrals for which the status",!,"of the transition of care document is pending.",!!

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

 +3        SET BMCJOB=$JOB

 +4       ;

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 EOJ

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

               Begin DoDot:1

 +4                SET BMCBT=$HOROLOG

               End DoDot:1

               IF BMCBT]""

                   QUIT

 +5        KILL ^XTMP("BMCRTC1",$JOB,BMCBT)

 +6        QUIT

 +7       ;

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^BMCRTC1"

           SET XBRC="REFCHK^BMCRTC1"

           SET XBRX="EOJ^BMCRTC1"

           SET XBNS="BMC"

 +7        DO ^XBDBQUE

 +8        QUIT

 +9       ;

BROWSE    ;

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

 +2        SET XBRC="REFCHK^BMCRTC1"

           SET XBRX="EOJ^BMCRTC1"

           SET XBNS="BMC"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT

 +5       ;

REFCHK    ; CHECK FOR PENDING TOC AND APPROVED

 +1        IF '$DATA(^BMCREF("TOC","P"))

               QUIT

 +2        SET BMCODAT=BMCSD-1

 +3       ;BMC*4.0*12

           SET BMCUSVN=""

           IF $DATA(^AUTTVNDR("B","UNSPECIFIED"))

               SET BMCUSVN=$ORDER(^AUTTVNDR("B","UNSPECIFIED",0))

 +4        FOR

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

               IF BMCODAT=""

                   QUIT

               Begin DoDot:1

 +5                SET (BMCRIEN,BMCPROV,BMCPDIR)=""

FOR

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

                       IF BMCRIEN'=+BMCRIEN

                           QUIT

                       Begin DoDot:2

 +6       ;BMC*4.0*12

                           IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="N"

                               QUIT

 +7       ;BMC*4.0*12 IHS/OIT/FCJ NO LONGER CHECKING FOR TOC PENDING AND APPROVED, NOW ONLY CHECKNG FOR PRINTED OR TRANSMITTED

 +8       ;I $D(^BMCREF("TOC","P",BMCRIEN)),$P(^BMCREF(BMCRIEN,0),U,15)="A1"  D

 +9                        SET CT=0

                           IF $DATA(^BMCREF(BMCRIEN,6))

                               SET L=0

                               SET CT=0

FOR

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

                                   IF L'?1N.N

                                       QUIT

                                   SET CT=CT+1

 +10                       IF CT=0

                               Begin DoDot:3

 +11                               SET BMCPROV=$PIECE(^BMCREF(BMCRIEN,0),U,7)

 +12      ;BMC*4.0*12

                                   IF BMCPROV=""

                                       IF 'BMCUSVN

                                           QUIT

                                       SET BMCPROV=BMCUSVN

 +13                               SET BMCPDIR=$SELECT($PIECE($GET(^AUTTVNDR(BMCPROV,21)),U,4)'="":$$VAL^XBDIQ1(9999999.11,BMCPROV,2104),1:"NO")

 +14                               SET ^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV,BMCRIEN)=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15       KILL CT,L

 +16       QUIT

 +17      ;

REFPRT    ; PRINT REFERRALS SELECTED

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

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

 +3        DO REFPRT2

 +4        KILL ^XTMP("BMCRTC1",BMCJOB)

 +5        QUIT

 +6       ;

REFPRT2   ;

 +1        SET BMCPG=0

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

           IF '$DATA(^XTMP("BMCRTC1",BMCJOB,"DATA HITS"))

               WRITE !,"No referrals to report",!

               DO PAUSE^BMC

               QUIT

 +2        SET BMCPDIR=0

 +3        FOR

               SET BMCPDIR=$ORDER(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR))

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

                   QUIT

               Begin DoDot:1

 +4                SET BMCPROV=0

FOR

                       SET BMCPROV=$ORDER(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV))

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

                           QUIT

                       DO PRINT

               End DoDot:1

 +5        IF $DATA(BMCQUIT)

               QUIT

 +6        DO PAUSE^BMC

 +7        QUIT

 +8       ;

PRINT     ;Print Prov

 +1        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT

 +2        WRITE !,$SELECT(BMCPDIR="YES":"Direct ",1:""),"Provider:  ",$$VAL^XBDIQ1(9999999.11,BMCPROV,.01),!

 +3        SET BMCRIEN=0

 +4        FOR

               SET BMCRIEN=$ORDER(^XTMP("BMCRTC1",BMCJOB,"DATA HITS",BMCPDIR,BMCPROV,BMCRIEN))

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

                   QUIT

               DO PRINTR

 +5        QUIT

 +6       ;

PRINTR    ;Print Ref

 +1        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT

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

 +3        SET Y=BMCRIEN

 +4        DO ^BMCREF

 +5        WRITE BMCRNUMB_BMCSUF

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

 +7        WRITE ?48,$$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

               End DoDot:1

 +13       DO ^DIWW

 +14       WRITE !

 +15       QUIT

 +16      ;

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       ;W $$CTR^BMC("APPROVED REFERRALS WHERE TRANSITION OF CARE DOCUMENT IS PENDING",80),!  ;BMC*4.0*12 IHS/OIT/FCJ

 +5       ;BMC*4.0*12 IHS/OIT/FCJ

           WRITE $$CTR^BMC("TRANSITION OF CARE DOCUMENT PENDING PRINTED OR TRANSMITTED",80),!

 +6        SET Y=BMCBD

           DO DD^%DT

           WRITE ?17,"BEG DATE: "_Y

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

 +8        SET Y=DT

           DO DD^%DT

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

 +9        WRITE !,"REFERRAL #",?16,"PATIENT NAME",?45,"REFERRAL-DATE"

 +10       WRITE !,BMC80D

 +11       WRITE !

 +12       QUIT

 +13      ;

EOJ       ; END OF JOB

 +1        KILL ^XTMP("BMCRTC1",BMCJOB)

 +2        DO ^BMCKILL

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

 +4        KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD,BMCUSVN

 +5        QUIT

BMCRTC1.m