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

BMCRR31.m

Go to the documentation of this file.
  1. BMCRR31 ; IHS/OHPRD/TMJ - PROCESS REFERRAL LIST ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
  1. ;IHS/ITSC/FCJ TEST FOR SR, SKIP SINCE NO COST DATA IS ENTERED
  1. ;
  1. ;
  1. START ;
  1. S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0
  1. D PROCESS,END
  1. Q
  1. ;
  1. PROCESS ;
  1. ;
  1. V ; Run by visit date
  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 PROC
  1. Q
  1. ;
  1. END ;
  1. S BMCET=$H
  1. Q
  1. PROC ;
  1. S BMCREF="" F S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PROCR
  1. Q
  1. ;
  1. PROCR ;
  1. Q:$P(BMCRREC,U,4)="N"
  1. Q:$P($G(^BMCREF(BMCREF,1)),U)'=""
  1. I '$D(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN)) S ^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN)=""
  1. I BMCCOST="I" S BMCDOLL=$$AVICOST^BMCRLU(BMCREF)
  1. I BMCCOST="T" S BMCDOLL=$$AVTCOST^BMCRLU(BMCREF)
  1. S $P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN),U)=$P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN),U)+1
  1. S $P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN),U,2)=$P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",$P(^DPT(DFN,0),U),DFN),U,2)+BMCDOLL
  1. Q