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

BMCRR11.m

Go to the documentation of this file.
  1. BMCRR11 ; 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. START ;
  1. S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0
  1. D PROCESS,END
  1. Q
  1. ;
  1. PROCESS ;
  1. S BMCREF=0 F S BMCREF=$O(^BMCREF(BMCREF)) Q:BMCREF'=+BMCREF D PROC
  1. Q
  1. ;
  1. END ;
  1. S BMCET=$H
  1. Q
  1. PROC ;
  1. K BMCSPEC
  1. S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3)
  1. ;Q:$P(BMCRREC,U,4)="C" ;Quit if not a CHS Type Referral
  1. Q:$P(BMCRREC,U,18)'="" ;Quit if Letter has been received
  1. Q:$P(BMCRREC,U,4)="N"
  1. Q:$P($G(^BMCREF(BMCREF,1)),U)'="" ;QUIT IF SR
  1. ;Get Referred To Facility IEN Number
  1. S BMCFAC1=$S($P(BMCRREC,U,7)'="":$P(BMCRREC,U,7),$P(BMCRREC,U,8)'="":$P(BMCRREC,U,8),$P(BMCRREC,U,9)'="":$P(BMCRREC,U,9),1:"")
  1. Q:'BMCFAC1
  1. Q:BMCFAC'=""&(BMCFAC'=BMCFAC1) ;Quit if Selected Fac no match
  1. Q:$P(BMCRREC,U,29)]""
  1. ;Q:$P($G(^BMCREF(BMCREF,11)),U,8)="" ;no actual end date of service commented out per Stan 9/9/96
  1. ;Q:$P(BMCRREC,U,15)'="C1"
  1. I $P(BMCRREC,U,15)'="A"&($P(BMCRREC,U,15)'="C1") Q
  1. I BMCTIME>$$FMDIFF^XLFDT(DT,$P($G(^BMCREF(BMCREF,11)),U,8)) Q
  1. ;check for medical and/or cost
  1. ;get sort value
  1. D @BMCSTYPE
  1. I BMCSORT="" S BMCSORT="??"
  1. S ^TMP("BMCRR1",BMCJOB,BMCBTH,"DATA HITS",BMCSORT,BMCREF)="",BMCRCNT=BMCRCNT+1
  1. Q
  1. F ;
  1. ;S BMCSORT=$P($G(^AUTTVNDR(BMCFAC1,0)),U)
  1. S BMCSORT=$$FACREF^BMCRLU(BMCREF)
  1. Q
  1. T ;
  1. S BMCSORT=$$FMDIFF^XLFDT(DT,$P($G(^BMCREF(BMCREF,11)),U,8))
  1. S BMCSORT=BMCSORT\30
  1. S BMCSORT=$S(BMCSORT>6:1,BMCSORT>3:2,BMCSORT>1:3,1:4)
  1. Q