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

BMCRCHS4.m

Go to the documentation of this file. 
  1. 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
  1.  ;4.0 IHS/ITSC/FCJ ADDED SUFFIX AND REF#
  1.  ;
  1.  ; This routine lists CHS referrals, User can select date range
  1.  ; and status of referral: Pending, Approved, Denied or All and
  1.  ; select if document is closed, active or both.
  1.  ;
  1. START ;
  1.  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.",!
  1.  W "Report will include Primary and Secondary referrals.",!
  1.  D INIT
  1.  Q:BMCQ
  1.  D GETDATES^BMCRUTL Q:$D(DIRUT)!$D(DTOUT)
  1.  D STATUS Q:$D(DIRUT)!$D(DTOUT)
  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("BMCRCHS4",BMCJOB,BMCBT):1
  1.  . E  S BMCBT=""
  1.  K ^XTMP("BMCRCHS4",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^BMCRCHS4",XBRC="REFCHK^BMCRCHS4",XBRX="EOJ^BMCRCHS4",XBNS="BMC"
  1.  D ^XBDBQUE
  1.  Q
  1.  ;
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS4"")"
  1.  S XBRC="REFCHK^BMCRCHS4",XBRX="EOJ^BMCRCHS4",XBNS="BMC",XBIOP=0
  1.  D ^XBDBQUE
  1.  Q
  1.  ;
  1. STATUS ;CHS STATUS AND STATUS OF REFERRAL
  1.  S DIR(0)="S^P:Pending;A:Approved;D:Denied;AL:All"
  1.  S DIR("A")="Enter the CHS status of the Referral for the Report",DIR("B")="P"
  1.  D ^DIR K DIR Q:$D(DIRUT)
  1.  S BMCCST=Y
  1.  S BMCRTYP=$S(Y="P":"PENDING APPROVAL",Y="A":"APPROVED",Y="D":"DENIED",Y="AL":"PENDING, APPROVED AND DENIED",1:"")
  1.  ;DOCUMENT STATUS ACTIVE/CLOSED OR BOTH
  1.  S DIR(0)="S^A:Active;C:Closed;B:Both"
  1.  S DIR("A")="Enter the Status of the Referral for the Report",DIR("B")="A"
  1.  D ^DIR K DIR Q:$D(DIRUT)
  1.  S BMCSTA=Y
  1.  S BMCRTYPS=$S(Y="A":"ACTIVE",Y="C":"CLOSED",Y="B":"ACTIVE AND CLOSED",1:"")
  1.  Q
  1. REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL
  1.  S BMCBDT=BMCBD-1
  1.  F  S BMCBDT=$O(^BMCREF("B",BMCBDT)) Q:('BMCBDT)!(BMCBDT>BMCED)  D
  1.  .S BMCRIEN=0
  1.  .F  S BMCRIEN=$O(^BMCREF("B",BMCBDT,BMCRIEN)) Q:'BMCRIEN  D
  1.  .. S X=^BMCREF(BMCRIEN,0)
  1.  ..;I BMCSTA'="B",BMCSTA="A",$P(X,U,15)'="A" Q  ;BMC*4.0*9 IHS.OIT.FCJ 
  1.  ..I BMCSTA'="B",BMCSTA="A",(($P(X,U,15)="C1")!($P(X,U,15)="X")) Q   ;BMC*4.0*9 IHS.OIT.FCJ
  1.  ..;I BMCSTA'="B",BMCSTA="C",$P(X,U,15)="A" Q   ;BMC*4.0*9 IHS.OIT.FCJ
  1.  ..I BMCSTA'="B",BMCSTA="C",(($P(X,U,15)="A")!($P(X,U,15)="A1")) Q   ;BMC*4.0*9 IHS.OIT.FCJ
  1.  .. I $P(X,U,4)="C" D
  1.  ... I BMCCST="AL" D HIT Q
  1.  ... I $P($G(^BMCREF(BMCRIEN,11)),U,12)=BMCCST D HIT Q
  1.  Q
  1. HIT S ^XTMP("BMCRCHS4",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""
  1.  Q
  1.  ;
  1. REFPRT ; PRINT REFERRALS SELECTED
  1.  S $P(BMC80E,"=",80)=""
  1.  S $P(BMC80D,"-",80)=""
  1.  D REFPRT2
  1.  K ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
  1.  Q
  1.  ;
  1. REFPRT2 ;
  1.  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
  1.  S BMCRIEN=0 K BMCQUIT
  1.  F  S BMCRIEN=$O(^XTMP("BMCRCHS4",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 ?11,$E(BMCREC("PAT NAME"),1,18)
  1.  ;4.0*2 9-21-06 IHS/OIT/FCJ CHNGD $G TO $D IN NXT LINE
  1.  W ?30,$P(BMCRREC,U,2) W:$D(^BMCREF(BMCRIEN,1)) $P(^BMCREF(BMCRIEN,1),U)
  1.  W ?46,$P(^BMCREF(BMCRIEN,11),U,12)_"/"_$P(BMCRREC,U,15)
  1.  W ?51,$S($P(BMCRREC,U,6):$$PROVINI^XBFUNC1($P(BMCRREC,U,6)),1:"--")
  1.  W ?55,$E($$TOFAC^BMC(BMCRIEN),1,25)
  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.  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 $$CTR^BMC("CHS REFERRALS: "_BMCRTYP,80),!
  1.  W $$CTR^BMC("REFERRALS STATUS: "_BMCRTYPS,80),!
  1.  W !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?44,"STATUS",?51,"PRV",?55,"FACILITY REF TO"
  1.  W !,BMC80D
  1.  W !
  1.  Q
  1.  ;
  1. EOJ ; END OF JOB
  1.  LOCK -^XTMP("BMCRCHS4",BMCJOB,BMCBT)
  1.  K ^XTMP("BMCRCHS4",BMCJOB,BMCBT)
  1.  D ^BMCKILL
  1.  K BMC80E,BMC80D,BMCBD,BMCBDD,BMCBDT,BMCBT,BMCHRN,BMCOPT,BMCPG,BMCJOB
  1.  K BMCCST,BMCED,BMCEDD,BMCREC,BMCSD,BMCRREC,BMCRSTAT,BMCRTYP,BMCRTYPS
  1.  K BMCSTA
  1.  Q