BMCRCHS1 ; IHS/PHXAO/TMJ - LIST PAID CHS REFERRALS ; 15 Mar 2013 9:02 AM
;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ ADDED BEG-END DATE REQ FOR REPORT AND RESORT OF DATA
; ADDED AMT PAID AND RMVD PRIM PRV
;
; This routine lists active CHS referrals where all CHS AUTHORIZATIONS
; have been paid.
;
START ;
W !!,"This report prints out a list of all active CHS referrals for which all",!,"authorizations have already been paid.",!!
W "Report will include Primary and Secondary Referrals.",!
BD ;GET BEG AND END DATE OF REPORT
D BD^BMCRUTL
G:$D(DIRUT) EOJ1 ;BMC*4.0*8
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("BMCRCHS1",BMCJOB,BMCBT):1
. E S BMCBT=""
. Q
K ^XTMP("BMCRCHS1",$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^BMCRCHS1",XBRC="REFCHK^BMCRCHS1",XBRX="EOJ^BMCRCHS1",XBNS="BMC"
D ^XBDBQUE
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS1"")"
S XBRC="REFCHK^BMCRCHS1",XBRX="EOJ^BMCRCHS1",XBNS="BMC",XBIOP=0
D ^XBDBQUE
Q
;
REFCHK ; CHECK ACTIVE/CHS REFERRAL SORTED BY DATE INIT
S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q
S BMCODAT=BMCSD_".9999" F S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED) 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
S X=^BMCREF(BMCRIEN,0)
I $P(X,U,4)="C" D S:BMCHIT ^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
. S (BMCAUTH,BMCHIT,BMCSKIP)=0
. Q:'$O(^BMCREF(BMCRIEN,41,0)) ; no authorizations
. F S BMCAUTH=$O(^BMCREF(BMCRIEN,41,BMCAUTH)) Q:'BMCAUTH D Q:BMCSKIP
.. S Y=^BMCREF(BMCRIEN,41,BMCAUTH,0)
.. S:$P(Y,U,3)="" BMCSKIP=1 ; no dollars paid
. S:'BMCSKIP BMCHIT=1
Q
;
REFPRT ; PRINT REFERRALS SELECTED
S $P(BMC80E,"=",80)=""
S $P(BMC80D,"-",80)=""
D REFPRT2
K ^XTMP("BMCRCHS1",BMCJOB,BMCBT)
Q
;
REFPRT2 ;
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRCHS1",BMCJOB,BMCBT)) W !,"No referrals to report",! D PAUSE^BMC Q
S BMCRIEN=0 K BMCQUIT
F S BMCRIEN=$O(^XTMP("BMCRCHS1",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),"2D")
W ?10,$E(BMCREC("PAT NAME"),1,20)
W ?32,$P(BMCRREC,U,2) W:$G(^BMCREF(BMCRIEN,1)) $P(^BMCREF(BMCRIEN,1),U)
W ?48,$E($$TOFAC^BMC(BMCRIEN),1,20)
S I=0 F S I=$O(^BMCREF(BMCRIEN,41,I)) Q:I'?1N.N W ?69,$J($P(^BMCREF(BMCRIEN,41,I,0),U,3),9,2),!
W !
I '$O(^BMCREF(BMCRIEN,12,0)) Q ; no purpose of referral
;
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 CHS REFERRALS WHERE ALL AUTHORIZATIONS PAID",80),!
S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
W !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?48,"FACILITY REF TO",?70,"AMT PAID"
W !,BMC80D
W !
Q
;
EOJ ; END OF JOB
LOCK -^XTMP("BMCRCHS1",BMCJOB,BMCBT)
K ^XTMP("BMCRCHS1",BMCJOB,BMCBT)
EOJ1 ;BMC*4.0*8 ADDED LINE LABEL
D ^BMCKILL
K BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP
K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD
Q
BMCRCHS1 ; IHS/PHXAO/TMJ - LIST PAID CHS REFERRALS ; 15 Mar 2013 9:02 AM
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ ADDED BEG-END DATE REQ FOR REPORT AND RESORT OF DATA
+3 ; ADDED AMT PAID AND RMVD PRIM PRV
+4 ;
+5 ; This routine lists active CHS referrals where all CHS AUTHORIZATIONS
+6 ; have been paid.
+7 ;
START ;
+1 WRITE !!,"This report prints out a list of all active CHS referrals for which all",!,"authorizations have already been paid.",!!
+2 WRITE "Report will include Primary and Secondary Referrals.",!
BD ;GET BEG AND END DATE OF REPORT
+1 DO BD^BMCRUTL
+2 ;BMC*4.0*8
IF $DATA(DIRUT)
GOTO EOJ1
+3 DO INIT
+4 IF BMCQ
QUIT
+5 DO DBQUE
+6 QUIT
+7 ;
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("BMCRCHS1",BMCJOB,BMCBT):1
+7 IF '$TEST
SET BMCBT=""
+8 QUIT
End DoDot:1
IF BMCBT]""
QUIT
+9 KILL ^XTMP("BMCRCHS1",$JOB,BMCBT)
+10 QUIT
+11 ;
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^BMCRCHS1"
SET XBRC="REFCHK^BMCRCHS1"
SET XBRX="EOJ^BMCRCHS1"
SET XBNS="BMC"
+7 DO ^XBDBQUE
+8 QUIT
+9 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS1"")"
+2 SET XBRC="REFCHK^BMCRCHS1"
SET XBRX="EOJ^BMCRCHS1"
SET XBNS="BMC"
SET XBIOP=0
+3 DO ^XBDBQUE
+4 QUIT
+5 ;
REFCHK ; CHECK ACTIVE/CHS REFERRAL SORTED BY DATE INIT
+1 SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))
IF BMCODAT=""
SET BMCET=$HOROLOG
QUIT
+2 SET BMCODAT=BMCSD_".9999"
FOR
SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))
IF BMCODAT=""!((BMCODAT\1)>BMCED)
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 SET X=^BMCREF(BMCRIEN,0)
+4 IF $PIECE(X,U,4)="C"
Begin DoDot:1
+5 SET (BMCAUTH,BMCHIT,BMCSKIP)=0
+6 ; no authorizations
IF '$ORDER(^BMCREF(BMCRIEN,41,0))
QUIT
+7 FOR
SET BMCAUTH=$ORDER(^BMCREF(BMCRIEN,41,BMCAUTH))
IF 'BMCAUTH
QUIT
Begin DoDot:2
+8 SET Y=^BMCREF(BMCRIEN,41,BMCAUTH,0)
+9 ; no dollars paid
IF $PIECE(Y,U,3)=""
SET BMCSKIP=1
End DoDot:2
IF BMCSKIP
QUIT
+10 IF 'BMCSKIP
SET BMCHIT=1
End DoDot:1
IF BMCHIT
SET ^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
+11 QUIT
+12 ;
REFPRT ; PRINT REFERRALS SELECTED
+1 SET $PIECE(BMC80E,"=",80)=""
+2 SET $PIECE(BMC80D,"-",80)=""
+3 DO REFPRT2
+4 KILL ^XTMP("BMCRCHS1",BMCJOB,BMCBT)
+5 QUIT
+6 ;
REFPRT2 ;
+1 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRCHS1",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
DO PAUSE^BMC
QUIT
+2 SET BMCRIEN=0
KILL BMCQUIT
+3 FOR
SET BMCRIEN=$ORDER(^XTMP("BMCRCHS1",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),"2D")
+6 WRITE ?10,$EXTRACT(BMCREC("PAT NAME"),1,20)
+7 WRITE ?32,$PIECE(BMCRREC,U,2)
IF $GET(^BMCREF(BMCRIEN,1))
WRITE $PIECE(^BMCREF(BMCRIEN,1),U)
+8 WRITE ?48,$EXTRACT($$TOFAC^BMC(BMCRIEN),1,20)
+9 SET I=0
FOR
SET I=$ORDER(^BMCREF(BMCRIEN,41,I))
IF I'?1N.N
QUIT
WRITE ?69,$JUSTIFY($PIECE(^BMCREF(BMCRIEN,41,I,0),U,3),9,2),!
+10 WRITE !
+11 ; no purpose of referral
IF '$ORDER(^BMCREF(BMCRIEN,12,0))
QUIT
+12 ;
+13 KILL ^UTILITY($JOB,"W")
+14 FOR BMCL=0:0
SET BMCL=$ORDER(^BMCREF(BMCRIEN,1,BMCL))
IF 'BMCL
QUIT
SET X=^(BMCL,0)
Begin DoDot:1
+15 SET DIWL=10
SET DIWR=70
SET DIWF="W"
+16 DO ^DIWP
+17 QUIT
End DoDot:1
+18 DO ^DIWW
+19 WRITE !
+20 QUIT
+21 ;
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 CHS REFERRALS WHERE ALL AUTHORIZATIONS PAID",80),!
+5 SET Y=BMCBD
DO DD^%DT
WRITE ?17,"BEG DATE: "_Y
+6 SET Y=BMCED
DO DD^%DT
WRITE ?40,"END DATE: "_Y,!
+7 WRITE !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?48,"FACILITY REF TO",?70,"AMT PAID"
+8 WRITE !,BMC80D
+9 WRITE !
+10 QUIT
+11 ;
EOJ ; END OF JOB
+1 LOCK -^XTMP("BMCRCHS1",BMCJOB,BMCBT)
+2 KILL ^XTMP("BMCRCHS1",BMCJOB,BMCBT)
EOJ1 ;BMC*4.0*8 ADDED LINE LABEL
+1 DO ^BMCKILL
+2 KILL BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP
+3 KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD
+4 QUIT
