Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCRCHS3

BMCRCHS3.m

Go to the documentation of this file.
  1. BMCRCHS3 ; IHS/PHXAO/TMJ - LIST ACTIVE REFERRALS CHS DENIED ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
  1. ;IHS/ITSC/FCJ ADDED BEG AND END DATE SELECTION TO REPORT
  1. ;
  1. ; This routine lists active referrals that were denied by CHS.
  1. ;
  1. START ;
  1. 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"
  1. W !,"or another IHS facility, etc.",!!
  1. W "Report will include both Primary and Secondary Referrals.",!
  1. BD ;GET BEG AND END DATE OF REPORT
  1. D BD^BMCRUTL
  1. G:$D(DIRUT) EOJ
  1. D INIT
  1. Q:BMCQ
  1. D DBQUE
  1. Q
  1. ;
  1. INIT ; INITIALIZAION
  1. S BMCQ=0
  1. D:$G(BMCPARM)="" PARMSET^BMC
  1. S BMCJOB=$J
  1. F D Q:BMCBT]""
  1. . S BMCBT=$H
  1. . LOCK +^XTMP("BMCRCHS3",BMCJOB,BMCBT):1
  1. . E S BMCBT=""
  1. K ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
  1. Q
  1. ;
  1. DBQUE ;call to XBDBQUE
  1. K BMCOPT
  1. 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
  1. I $D(DIRUT) S BMCQUIT=1 Q
  1. S BMCOPT=Y
  1. I $G(BMCOPT)="B" D BROWSE Q
  1. S XBRP="REFPRT^BMCRCHS3",XBRC="REFCHK^BMCRCHS3",XBRX="EOJ^BMCRCHS3",XBNS="BMC"
  1. D ^XBDBQUE
  1. Q
  1. ;
  1. BROWSE ;
  1. S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS3"")"
  1. S XBRC="REFCHK^BMCRCHS3",XBRX="EOJ^BMCRCHS3",XBNS="BMC",XBIOP=0
  1. D ^XBDBQUE
  1. Q
  1. ;
  1. REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
  1. ;
  1. S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q
  1. S BMCODAT=BMCSD_".9999" F S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED) D R1
  1. Q
  1. R1 ;
  1. S BMCRIEN="" F S BMCRIEN=$O(^BMCREF("B",BMCODAT,BMCRIEN)) Q:BMCRIEN'=+BMCRIEN S BMCRREC=^BMCREF(BMCRIEN,0) D PROC
  1. Q
  1. ;
  1. PROC ;
  1. ;Q:$P(BMCRREC,U,15)'="A" ;QUIT IF NOT ACTIVE ;BMC*4.0*9 IHS.OIT.FCJ
  1. Q:($P(BMCRREC,U,15)="C1")!($P(BMCRREC,U,15)="X") ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ
  1. S X=^BMCREF(BMCRIEN,0)
  1. I $P(X,U,4)="C" D S:BMCHIT ^XTMP("BMCRCHS3",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
  1. . S BMCHIT=1
  1. . Q:$P($G(^BMCREF(BMCRIEN,11)),U,12)="D"
  1. . S BMCHIT=0
  1. Q
  1. ;
  1. REFPRT ; PRINT REFERRALS SELECTED
  1. S $P(BMC80E,"=",80)=""
  1. S $P(BMC80D,"-",80)=""
  1. D REFPRT2
  1. K ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
  1. Q
  1. ;
  1. REFPRT2 ;
  1. 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
  1. S BMCRIEN=0 K BMCQUIT
  1. F S BMCRIEN=$O(^XTMP("BMCRCHS3",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)) Q:BMCRIEN=""!($D(BMCQUIT)) D PRINT
  1. Q:$D(BMCQUIT)
  1. D PAUSE^BMC
  1. Q
  1. ;
  1. PRINT ;print one referral
  1. S BMCRREC=^BMCREF(BMCRIEN,0)
  1. S Y=BMCRIEN
  1. D ^BMCREF
  1. I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
  1. W $$FMTE^XLFDT($P(BMCRREC,U),"5D")
  1. W ?12,$E(BMCREC("PAT NAME"),1,18)
  1. 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)
  1. W ?32,BMCHRN
  1. W ?43,$S($P(BMCRREC,U,6):$$PROVINI^XBFUNC1($P(BMCRREC,U,6)),1:"--")
  1. W ?49,$$TOFAC^BMC(BMCRIEN)
  1. W !
  1. I $P($G(^BMCREF(BMCRIEN,12)),U)="" Q ;no purpose of referral
  1. S X=$P(^BMCREF(BMCRIEN,12),U),DIWF="",DIWL=10,DIWR=70 D ^DIWP
  1. S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z W ?10,^UTILITY($J,"W",DIWL,Z,0),!
  1. K DIWL,DIWR,DIWF,Z
  1. K ^UTILITY($J,"W")
  1. W !
  1. Q
  1. ;
  1. D PAUSE^BMC
  1. I $D(DIRUT) S BMCQUIT="" Q
  1. D HEAD1
  1. Q
  1. ;
  1. HEAD1 ;
  1. W:$D(IOF) @IOF
  1. HEAD2 ; WRITE HEADER
  1. S BMCPG=BMCPG+1
  1. W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
  1. W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
  1. W $$CTR^BMC("CHS REFERRALS DENIED STILL ACTIVE",80),!
  1. S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
  1. S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
  1. W !,"REF DATE",?11,"PATIENT NAME",?32," HRN",?43,"PROV",?49,"FACILITY REF TO"
  1. W !,BMC80D
  1. W !
  1. Q
  1. ;
  1. EOJ ; END OF JOB
  1. LOCK -^XTMP("BMCRCHS3",BMCJOB,BMCBT)
  1. K ^XTMP("BMCRCHS3",BMCJOB,BMCBT)
  1. K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD
  1. D ^BMCKILL
  1. Q