BMCRCHS4 ; IHS/ITSC/FCJ - STATUS REPORT FOR CHS REFERRALS; [ 09/27/2006 2:21 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
;4.0 IHS/ITSC/FCJ ADDED SUFFIX AND REF#
;
; This routine lists CHS referrals, User can select date range
; and status of referral: Pending, Approved, Denied or All and
; select if document is closed, active or both.
;
START ;
W !!,"This report prints out a list of all Active CHS referrals. ",!,"The user can select a date range by Date initiated, and Status of Referral.",!,"and CHS status of Referral.",!
W "Report will include Primary and Secondary referrals.",!
D INIT
Q:BMCQ
D GETDATES^BMCRUTL Q:$D(DIRUT)!$D(DTOUT)
D STATUS Q:$D(DIRUT)!$D(DTOUT)
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("BMCRCHS4",BMCJOB,BMCBT):1
. E S BMCBT=""
K ^XTMP("BMCRCHS4",BMCJOB,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^BMCRCHS4",XBRC="REFCHK^BMCRCHS4",XBRX="EOJ^BMCRCHS4",XBNS="BMC"
D ^XBDBQUE
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS4"")"
S XBRC="REFCHK^BMCRCHS4",XBRX="EOJ^BMCRCHS4",XBNS="BMC",XBIOP=0
D ^XBDBQUE
Q
;
STATUS ;CHS STATUS AND STATUS OF REFERRAL
S DIR(0)="S^P:Pending;A:Approved;D:Denied;AL:All"
S DIR("A")="Enter the CHS status of the Referral for the Report",DIR("B")="P"
D ^DIR K DIR Q:$D(DIRUT)
S BMCCST=Y
S BMCRTYP=$S(Y="P":"PENDING APPROVAL",Y="A":"APPROVED",Y="D":"DENIED",Y="AL":"PENDING, APPROVED AND DENIED",1:"")
;DOCUMENT STATUS ACTIVE/CLOSED OR BOTH
S DIR(0)="S^A:Active;C:Closed;B:Both"
S DIR("A")="Enter the Status of the Referral for the Report",DIR("B")="A"
D ^DIR K DIR Q:$D(DIRUT)
S BMCSTA=Y
S BMCRTYPS=$S(Y="A":"ACTIVE",Y="C":"CLOSED",Y="B":"ACTIVE AND CLOSED",1:"")
Q
REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
S BMCBDT=BMCBD-1
F S BMCBDT=$O(^BMCREF("B",BMCBDT)) Q:('BMCBDT)!(BMCBDT>BMCED) D
.S BMCRIEN=0
.F S BMCRIEN=$O(^BMCREF("B",BMCBDT,BMCRIEN)) Q:'BMCRIEN D
.. S X=^BMCREF(BMCRIEN,0)
..;I BMCSTA'="B",BMCSTA="A",$P(X,U,15)'="A" Q ;BMC*4.0*9 IHS.OIT.FCJ
..I BMCSTA'="B",BMCSTA="A",(($P(X,U,15)="C1")!($P(X,U,15)="X")) Q ;BMC*4.0*9 IHS.OIT.FCJ
..;I BMCSTA'="B",BMCSTA="C",$P(X,U,15)="A" Q ;BMC*4.0*9 IHS.OIT.FCJ
..I BMCSTA'="B",BMCSTA="C",(($P(X,U,15)="A")!($P(X,U,15)="A1")) Q ;BMC*4.0*9 IHS.OIT.FCJ
.. I $P(X,U,4)="C" D
... I BMCCST="AL" D HIT Q
... I $P($G(^BMCREF(BMCRIEN,11)),U,12)=BMCCST D HIT Q
Q
HIT S ^XTMP("BMCRCHS4",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
Q
;
REFPRT ; PRINT REFERRALS SELECTED
S $P(BMC80E,"=",80)=""
S $P(BMC80D,"-",80)=""
D REFPRT2
K ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
Q
;
REFPRT2 ;
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRCHS4",BMCJOB,BMCBT)) W !,"No referrals to report",! D PAUSE^BMC Q
S BMCRIEN=0 K BMCQUIT
F S BMCRIEN=$O(^XTMP("BMCRCHS4",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 $$FMTE^XLFDT($P(BMCRREC,U),"5D")
W ?11,$E(BMCREC("PAT NAME"),1,18)
;4.0*2 9-21-06 IHS/OIT/FCJ CHNGD $G TO $D IN NXT LINE
W ?30,$P(BMCRREC,U,2) W:$D(^BMCREF(BMCRIEN,1)) $P(^BMCREF(BMCRIEN,1),U)
W ?46,$P(^BMCREF(BMCRIEN,11),U,12)_"/"_$P(BMCRREC,U,15)
W ?51,$S($P(BMCRREC,U,6):$$PROVINI^XBFUNC1($P(BMCRREC,U,6)),1:"--")
W ?55,$E($$TOFAC^BMC(BMCRIEN),1,25)
W !
I $P($G(^BMCREF(BMCRIEN,12)),U)="" Q ;no purpose of referral
S X=$P(^BMCREF(BMCRIEN,12),U),DIWF="",DIWL=10,DIWR=70 D ^DIWP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z W ?10,^UTILITY($J,"W",DIWL,Z,0),!
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W")
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,!
S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
W $$CTR^BMC("CHS REFERRALS: "_BMCRTYP,80),!
W $$CTR^BMC("REFERRALS STATUS: "_BMCRTYPS,80),!
W !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?44,"STATUS",?51,"PRV",?55,"FACILITY REF TO"
W !,BMC80D
W !
Q
;
EOJ ; END OF JOB
LOCK -^XTMP("BMCRCHS4",BMCJOB,BMCBT)
K ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
D ^BMCKILL
K BMC80E,BMC80D,BMCBD,BMCBDD,BMCBDT,BMCBT,BMCHRN,BMCOPT,BMCPG,BMCJOB
K BMCCST,BMCED,BMCEDD,BMCREC,BMCSD,BMCRREC,BMCRSTAT,BMCRTYP,BMCRTYPS
K BMCSTA
Q
BMCRCHS4 ; IHS/ITSC/FCJ - STATUS REPORT FOR CHS REFERRALS; [ 09/27/2006 2:21 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
+2 ;4.0 IHS/ITSC/FCJ ADDED SUFFIX AND REF#
+3 ;
+4 ; This routine lists CHS referrals, User can select date range
+5 ; and status of referral: Pending, Approved, Denied or All and
+6 ; select if document is closed, active or both.
+7 ;
START ;
+1 WRITE !!,"This report prints out a list of all Active CHS referrals. ",!,"The user can select a date range by Date initiated, and Status of Referral.",!,"and CHS status of Referral.",!
+2 WRITE "Report will include Primary and Secondary referrals.",!
+3 DO INIT
+4 IF BMCQ
QUIT
+5 DO GETDATES^BMCRUTL
IF $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+6 DO STATUS
IF $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+7 DO DBQUE
+8 QUIT
+9 ;
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("BMCRCHS4",BMCJOB,BMCBT):1
+7 IF '$TEST
SET BMCBT=""
End DoDot:1
IF BMCBT]""
QUIT
+8 KILL ^XTMP("BMCRCHS4",BMCJOB,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^BMCRCHS4"
SET XBRC="REFCHK^BMCRCHS4"
SET XBRX="EOJ^BMCRCHS4"
SET XBNS="BMC"
+7 DO ^XBDBQUE
+8 QUIT
+9 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS4"")"
+2 SET XBRC="REFCHK^BMCRCHS4"
SET XBRX="EOJ^BMCRCHS4"
SET XBNS="BMC"
SET XBIOP=0
+3 DO ^XBDBQUE
+4 QUIT
+5 ;
STATUS ;CHS STATUS AND STATUS OF REFERRAL
+1 SET DIR(0)="S^P:Pending;A:Approved;D:Denied;AL:All"
+2 SET DIR("A")="Enter the CHS status of the Referral for the Report"
SET DIR("B")="P"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+4 SET BMCCST=Y
+5 SET BMCRTYP=$SELECT(Y="P":"PENDING APPROVAL",Y="A":"APPROVED",Y="D":"DENIED",Y="AL":"PENDING, APPROVED AND DENIED",1:"")
+6 ;DOCUMENT STATUS ACTIVE/CLOSED OR BOTH
+7 SET DIR(0)="S^A:Active;C:Closed;B:Both"
+8 SET DIR("A")="Enter the Status of the Referral for the Report"
SET DIR("B")="A"
+9 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+10 SET BMCSTA=Y
+11 SET BMCRTYPS=$SELECT(Y="A":"ACTIVE",Y="C":"CLOSED",Y="B":"ACTIVE AND CLOSED",1:"")
+12 QUIT
REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
+1 SET BMCBDT=BMCBD-1
+2 FOR
SET BMCBDT=$ORDER(^BMCREF("B",BMCBDT))
IF ('BMCBDT)!(BMCBDT>BMCED)
QUIT
Begin DoDot:1
+3 SET BMCRIEN=0
+4 FOR
SET BMCRIEN=$ORDER(^BMCREF("B",BMCBDT,BMCRIEN))
IF 'BMCRIEN
QUIT
Begin DoDot:2
+5 SET X=^BMCREF(BMCRIEN,0)
+6 ;I BMCSTA'="B",BMCSTA="A",$P(X,U,15)'="A" Q ;BMC*4.0*9 IHS.OIT.FCJ
+7 ;BMC*4.0*9 IHS.OIT.FCJ
IF BMCSTA'="B"
IF BMCSTA="A"
IF (($PIECE(X,U,15)="C1")!($PIECE(X,U,15)="X"))
QUIT
+8 ;I BMCSTA'="B",BMCSTA="C",$P(X,U,15)="A" Q ;BMC*4.0*9 IHS.OIT.FCJ
+9 ;BMC*4.0*9 IHS.OIT.FCJ
IF BMCSTA'="B"
IF BMCSTA="C"
IF (($PIECE(X,U,15)="A")!($PIECE(X,U,15)="A1"))
QUIT
+10 IF $PIECE(X,U,4)="C"
Begin DoDot:3
+11 IF BMCCST="AL"
DO HIT
QUIT
+12 IF $PIECE($GET(^BMCREF(BMCRIEN,11)),U,12)=BMCCST
DO HIT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
HIT SET ^XTMP("BMCRCHS4",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
+1 QUIT
+2 ;
REFPRT ; PRINT REFERRALS SELECTED
+1 SET $PIECE(BMC80E,"=",80)=""
+2 SET $PIECE(BMC80D,"-",80)=""
+3 DO REFPRT2
+4 KILL ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
+5 QUIT
+6 ;
REFPRT2 ;
+1 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRCHS4",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
DO PAUSE^BMC
QUIT
+2 SET BMCRIEN=0
KILL BMCQUIT
+3 FOR
SET BMCRIEN=$ORDER(^XTMP("BMCRCHS4",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 $$FMTE^XLFDT($PIECE(BMCRREC,U),"5D")
+6 WRITE ?11,$EXTRACT(BMCREC("PAT NAME"),1,18)
+7 ;4.0*2 9-21-06 IHS/OIT/FCJ CHNGD $G TO $D IN NXT LINE
+8 WRITE ?30,$PIECE(BMCRREC,U,2)
IF $DATA(^BMCREF(BMCRIEN,1))
WRITE $PIECE(^BMCREF(BMCRIEN,1),U)
+9 WRITE ?46,$PIECE(^BMCREF(BMCRIEN,11),U,12)_"/"_$PIECE(BMCRREC,U,15)
+10 WRITE ?51,$SELECT($PIECE(BMCRREC,U,6):$$PROVINI^XBFUNC1($PIECE(BMCRREC,U,6)),1:"--")
+11 WRITE ?55,$EXTRACT($$TOFAC^BMC(BMCRIEN),1,25)
+12 WRITE !
+13 ;no purpose of referral
IF $PIECE($GET(^BMCREF(BMCRIEN,12)),U)=""
QUIT
+14 SET X=$PIECE(^BMCREF(BMCRIEN,12),U)
SET DIWF=""
SET DIWL=10
SET DIWR=70
DO ^DIWP
+15 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
WRITE ?10,^UTILITY($JOB,"W",DIWL,Z,0),!
+16 KILL DIWL,DIWR,DIWF,Z
+17 KILL ^UTILITY($JOB,"W")
+18 WRITE !
+19 QUIT
+20 ;
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 SET Y=BMCBD
DO DD^%DT
WRITE ?17,"BEG DATE: "_Y
+5 SET Y=BMCED
DO DD^%DT
WRITE ?40,"END DATE: "_Y,!
+6 WRITE $$CTR^BMC("CHS REFERRALS: "_BMCRTYP,80),!
+7 WRITE $$CTR^BMC("REFERRALS STATUS: "_BMCRTYPS,80),!
+8 WRITE !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?44,"STATUS",?51,"PRV",?55,"FACILITY REF TO"
+9 WRITE !,BMC80D
+10 WRITE !
+11 QUIT
+12 ;
EOJ ; END OF JOB
+1 LOCK -^XTMP("BMCRCHS4",BMCJOB,BMCBT)
+2 KILL ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
+3 DO ^BMCKILL
+4 KILL BMC80E,BMC80D,BMCBD,BMCBDD,BMCBDT,BMCBT,BMCHRN,BMCOPT,BMCPG,BMCJOB
+5 KILL BMCCST,BMCED,BMCEDD,BMCREC,BMCSD,BMCRREC,BMCRSTAT,BMCRTYP,BMCRTYPS
+6 KILL BMCSTA
+7 QUIT
