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

BMCRR61.m

Go to the documentation of this file.
  1. BMCRR61 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
  1. ;IHS/ITSC/FCJ ADDED TEST FOR SR
  1. ;
  1. ;
  1. ;
  1. START ;
  1. S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0
  1. D PROCESS,END
  1. Q
  1. ;
  1. PROCESS ;
  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 R1
  1. Q
  1. ;
  1. END ;
  1. S BMCET=$H
  1. Q
  1. R1 ;
  1. S BMCREF="" F S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF S BMCRREC=^BMCREF(BMCREF,0) D PROCR
  1. Q
  1. PROCR ;
  1. Q:$P(BMCRREC,U,4)="N"
  1. Q:$P(BMCRREC,U,15)'="C1" ;must be a completed-action done referral
  1. Q:$P($G(^BMCREF(BMCREF,1)),U)'="" ;QUIT IF SR
  1. S BMCSVCD=$$AVEOS^BMCRLU(BMCREF,"I")
  1. Q:BMCSVCD="" ;quit if no end date of service is available
  1. S BMCF=$$FACREF^BMCRLU(BMCREF)
  1. I '$D(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF)) D
  1. .F %=1:1:6 S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=0
  1. S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U)=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U)+1
  1. S BMCD=$P(BMCRREC,U,18)
  1. I BMCD="" S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)+1 Q
  1. S X=$$FMDIFF^XLFDT(BMCD,BMCSVCD,1)
  1. S %=$S(X>181:6,X>94:5,X>32:4,1:3)
  1. S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)+1
  1. Q