- BMCRCHS3 ; IHS/PHXAO/TMJ - LIST ACTIVE REFERRALS CHS DENIED ;
- ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
- ;IHS/ITSC/FCJ ADDED BEG AND END DATE SELECTION TO REPORT
- ;
- ; This routine lists active referrals that were denied by CHS.
- ;
- START ;
- W !!,"This report prints out a list of all referrals that were denied by CHS",!,"but are still active. These may reflect referrals that either have been",!,"or should be referred under some other mechanism, e.g. alternative resources"
- W !,"or another IHS facility, etc.",!!
- W "Report will include both Primary and Secondary Referrals.",!
- BD ;GET BEG AND END DATE OF REPORT
- D BD^BMCRUTL
- G:$D(DIRUT) EOJ
- 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("BMCRCHS3",BMCJOB,BMCBT):1
- . E S BMCBT=""
- K ^XTMP("BMCRCHS3",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^BMCRCHS3",XBRC="REFCHK^BMCRCHS3",XBRX="EOJ^BMCRCHS3",XBNS="BMC"
- D ^XBDBQUE
- Q
- ;
- BROWSE ;
- S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS3"")"
- S XBRC="REFCHK^BMCRCHS3",XBRX="EOJ^BMCRCHS3",XBNS="BMC",XBIOP=0
- D ^XBDBQUE
- Q
- ;
- REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
- ;
- 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("BMCRCHS3",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
- . S BMCHIT=1
- . Q:$P($G(^BMCREF(BMCRIEN,11)),U,12)="D"
- . S BMCHIT=0
- Q
- ;
- REFPRT ; PRINT REFERRALS SELECTED
- S $P(BMC80E,"=",80)=""
- S $P(BMC80D,"-",80)=""
- D REFPRT2
- K ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- Q
- ;
- REFPRT2 ;
- S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRCHS3",BMCJOB,BMCBT)) W !,"No referrals to report",! D PAUSE^BMC Q
- S BMCRIEN=0 K BMCQUIT
- F S BMCRIEN=$O(^XTMP("BMCRCHS3",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 ?12,$E(BMCREC("PAT NAME"),1,18)
- S BMCHRN="????" I $D(^AUPNPAT(BMCDFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(BMCDFN,41,DUZ(2),0),U,2)
- W ?32,BMCHRN
- W ?43,$S($P(BMCRREC,U,6):$$PROVINI^XBFUNC1($P(BMCRREC,U,6)),1:"--")
- W ?49,$$TOFAC^BMC(BMCRIEN)
- 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,!
- W $$CTR^BMC("CHS REFERRALS DENIED STILL ACTIVE",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," HRN",?43,"PROV",?49,"FACILITY REF TO"
- W !,BMC80D
- W !
- Q
- ;
- EOJ ; END OF JOB
- LOCK -^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- K ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD
- D ^BMCKILL
- Q
- BMCRCHS3 ; IHS/PHXAO/TMJ - LIST ACTIVE REFERRALS CHS DENIED ;
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
- +2 ;IHS/ITSC/FCJ ADDED BEG AND END DATE SELECTION TO REPORT
- +3 ;
- +4 ; This routine lists active referrals that were denied by CHS.
- +5 ;
- START ;
- +1 WRITE !!,"This report prints out a list of all referrals that were denied by CHS",!,"but are still active. These may reflect referrals that either have been",!,"or should be referred under some other mechanism, e.g. alternative resources"
- +2 WRITE !,"or another IHS facility, etc.",!!
- +3 WRITE "Report will include both Primary and Secondary Referrals.",!
- BD ;GET BEG AND END DATE OF REPORT
- +1 DO BD^BMCRUTL
- +2 IF $DATA(DIRUT)
- GOTO EOJ
- +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("BMCRCHS3",BMCJOB,BMCBT):1
- +7 IF '$TEST
- SET BMCBT=""
- End DoDot:1
- IF BMCBT]""
- QUIT
- +8 KILL ^XTMP("BMCRCHS3",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^BMCRCHS3"
- SET XBRC="REFCHK^BMCRCHS3"
- SET XBRX="EOJ^BMCRCHS3"
- SET XBNS="BMC"
- +7 DO ^XBDBQUE
- +8 QUIT
- +9 ;
- BROWSE ;
- +1 SET XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS3"")"
- +2 SET XBRC="REFCHK^BMCRCHS3"
- SET XBRX="EOJ^BMCRCHS3"
- SET XBNS="BMC"
- SET XBIOP=0
- +3 DO ^XBDBQUE
- +4 QUIT
- +5 ;
- REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
- +1 ;
- +2 SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))
- IF BMCODAT=""
- SET BMCET=$HOROLOG
- QUIT
- +3 SET BMCODAT=BMCSD_".9999"
- FOR
- SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))
- IF BMCODAT=""!((BMCODAT\1)>BMCED)
- QUIT
- DO R1
- +4 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 BMCHIT=1
- +6 IF $PIECE($GET(^BMCREF(BMCRIEN,11)),U,12)="D"
- QUIT
- +7 SET BMCHIT=0
- End DoDot:1
- IF BMCHIT
- SET ^XTMP("BMCRCHS3",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
- +8 QUIT
- +9 ;
- REFPRT ; PRINT REFERRALS SELECTED
- +1 SET $PIECE(BMC80E,"=",80)=""
- +2 SET $PIECE(BMC80D,"-",80)=""
- +3 DO REFPRT2
- +4 KILL ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- +5 QUIT
- +6 ;
- REFPRT2 ;
- +1 SET BMCPG=0
- DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
- IF '$DATA(^XTMP("BMCRCHS3",BMCJOB,BMCBT))
- WRITE !,"No referrals to report",!
- DO PAUSE^BMC
- QUIT
- +2 SET BMCRIEN=0
- KILL BMCQUIT
- +3 FOR
- SET BMCRIEN=$ORDER(^XTMP("BMCRCHS3",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 ?12,$EXTRACT(BMCREC("PAT NAME"),1,18)
- +7 SET BMCHRN="????"
- IF $DATA(^AUPNPAT(BMCDFN,41,DUZ(2)))
- SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(BMCDFN,41,DUZ(2),0),U,2)
- +8 WRITE ?32,BMCHRN
- +9 WRITE ?43,$SELECT($PIECE(BMCRREC,U,6):$$PROVINI^XBFUNC1($PIECE(BMCRREC,U,6)),1:"--")
- +10 WRITE ?49,$$TOFAC^BMC(BMCRIEN)
- +11 WRITE !
- +12 ;no purpose of referral
- IF $PIECE($GET(^BMCREF(BMCRIEN,12)),U)=""
- QUIT
- +13 SET X=$PIECE(^BMCREF(BMCRIEN,12),U)
- SET DIWF=""
- SET DIWL=10
- SET DIWR=70
- DO ^DIWP
- +14 SET Z=0
- FOR
- SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
- IF Z'=+Z
- QUIT
- WRITE ?10,^UTILITY($JOB,"W",DIWL,Z,0),!
- +15 KILL DIWL,DIWR,DIWF,Z
- +16 KILL ^UTILITY($JOB,"W")
- +17 WRITE !
- +18 QUIT
- +19 ;
- 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("CHS REFERRALS DENIED STILL ACTIVE",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," HRN",?43,"PROV",?49,"FACILITY REF TO"
- +8 WRITE !,BMC80D
- +9 WRITE !
- +10 QUIT
- +11 ;
- EOJ ; END OF JOB
- +1 LOCK -^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- +2 KILL ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
- +3 KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD
- +4 DO ^BMCKILL
- +5 QUIT