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
Q
;
INIT ; INITIALIZAION
S BMCQ=0
D:$G(BMCPARM)="" PARMSET^BMC
F D Q:BMCBT]""
. S BMCBT=$H
K ^XTMP("BMCRTC1",$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^BMCRTC1",XBRC="REFCHK^BMCRTC1",XBRX="EOJ^BMCRTC1",XBNS="BMC"
D ^XBDBQUE
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""REFPRT^BMCRTC1"")"
S XBRC="REFCHK^BMCRTC1",XBRX="EOJ^BMCRTC1",XBNS="BMC",XBIOP=0
D ^XBDBQUE
Q
;
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
Q
;
REFPRT ; PRINT REFERRALS SELECTED
S $P(BMC80E,"=",80)=""
S $P(BMC80D,"-",80)=""
D REFPRT2
K ^XTMP("BMCRTC1",BMCJOB)
Q
;
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
Q
;
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
Q
;
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 !
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("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 !
Q
;
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
Q
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
