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

BMCRLU1.m

Go to the documentation of this file. 
  1. BMCRLU1 ; IHS/PHXAO/TMJ - GEN RETR UTILITIES ; 03 May 2018  4:47 PM
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**3,12,13**;JAN 09, 2006;Build 101
  1.  ;BMC 4.0*3 11/30/06 IHS/OIT/FCJ PRNT POL #
  1.  ;4.0*13 4.1.18 IHS.OIT.FCJ ADDED NEW MBI FOR MEDICARE AND RRR
  1.  ;
  1. MCR ;display all current medicare data
  1.  NEW BMCMIFN,BMCMBI
  1.  I '$D(^DPT(P,0)) G MCRX
  1.  I $P(^DPT(P,0),U,19) G MCRX
  1.  I '$D(^AUPNPAT(P,0)) G MCRX
  1.  I '$D(^AUPNMCR(P,11)) G MCRX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
  1.  ;4.0*13 4.1.18 IHS.OIT.FCJ REWROTE SECTION FOR NEW MBI
  1.  S BMCMBI=$$GETMBI^AUPNMBI(P,DT,0)
  1.  I BMCMBI<1 S BMCMBI=$P($G(^AUPNMCR(P,0)),U,3) I $P(^AUPNMCR(P,0),U,4)'="" S BMCMBI=BMCMBI_$G(^AUTTMCS($P(^AUPNMCR(P,0),U,4),0))
  1.  S BMCMIFN=0 F  S BMCMIFN=$O(^AUPNMCR(P,11,BMCMIFN)) Q:BMCMIFN'=+BMCMIFN  D
  1.  .Q:$P(^AUPNMCR(P,11,BMCMIFN,0),U)>D
  1.  .I $P(^AUPNMCR(P,11,BMCMIFN,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  .;S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=$P(^AUPNMCR(DFN,0),U,3)_" ["_$S($P(^(0),U,4)]"":$P(^AUTTMCS($P(^(0),U,4),0),U),1:"-")_"]"
  1.  .;TEST FOR COV "D"
  1.  .S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=$S($P(^AUPNMCR(P,11,BMCMIFN,0),U,3)="D":$P(^(0),U,6),1:BMCMBI)
  1.  .S BMCPCNT=BMCPCNT+1,Y=$P(^AUPNMCR(DFN,11,BMCMIFN,0),U),Z=$P(^(0),U,2),BMCPRNM(BMCPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_"-" I Z]"" S BMCPRNM(BMCPCNT)=BMCPRNM(BMCPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_($E(Y,1,3)+1700)
  1. MCRX ;
  1.  K Y,Z
  1.  Q
  1.  ;
  1. MCD ;
  1.  NEW BMCMIFN,BMCNIFN
  1.  I '$D(^DPT(P,0)) G MCDX
  1.  I $P(^DPT(P,0),U,19) G MCDX
  1.  I '$D(^AUPNPAT(P,0)) G MCDX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
  1.  S BMCMIFN=0 F  S BMCMIFN=$O(^AUPNMCD("B",P,BMCMIFN)) Q:BMCMIFN'=+BMCMIFN  D
  1.  .Q:'$D(^AUPNMCD(BMCMIFN,11))
  1.  .S BMCNIFN=0 F  S BMCNIFN=$O(^AUPNMCD(BMCMIFN,11,BMCNIFN)) Q:BMCNIFN'=+BMCNIFN  D
  1.  ..Q:BMCNIFN>D
  1.  ..I $P(^AUPNMCD(BMCMIFN,11,BMCNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  ..S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=$P(^AUPNMCD(BMCMIFN,0),U,3)_"/"_$S($P(^AUPNMCD(BMCMIFN,0),U,2)]"":$P(^AUTNINS($P(^AUPNMCD(BMCMIFN,0),U,2),0),U),1:"<>")
  1.  ..S BMCPCNT=BMCPCNT+1,Y=$P(^AUPNMCD(BMCMIFN,11,BMCNIFN,0),U),Z=$P(^(0),U,2),BMCPRNM(BMCPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_"-" I Z]"" S BMCPRNM(BMCPCNT)=BMCPRNM(BMCPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_($E(Z,1,3)+1700)
  1.  ;
  1. MCDX ;
  1.  Q
  1.  ;
  1. PI ; EP
  1.  NEW BMCMIFN,BMCFLG
  1.  I '$D(^DPT(P,0)) G PIX
  1.  I $P(^DPT(P,0),U,19) G PIX
  1.  I '$D(^AUPNPAT(P,0)) G PIX
  1.  I '$D(^AUPNPRVT(P,11)) G PIX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
  1.  S BMCMIFN=0 F  S BMCMIFN=$O(^AUPNPRVT(P,11,BMCMIFN)) Q:BMCMIFN'=+BMCMIFN  D
  1.  .Q:$P(^AUPNPRVT(P,11,BMCMIFN,0),U)=""
  1.  .S BMCNAME=$P(^AUPNPRVT(DFN,11,BMCMIFN,0),U) Q:BMCNAME=""
  1.  .Q:$P(^AUTNINS(BMCNAME,0),U)["AHCCCS"
  1.  .Q:$P(^AUPNPRVT(P,11,BMCMIFN,0),U,6)>D
  1.  .I $P(^AUPNPRVT(P,11,BMCMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
  1.  .;BMC 4.0*3 11/30/06 IHS/OIT/FCJ PRNT POL #
  1.  .;S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,BMCMIFN,0),U),0),U)_" - "_$P(^AUPNPRVT(P,11,BMCMIFN,0),U,2)
  1.  .S BMCPCNT=BMCPCNT+1
  1.  .S BMCPRNM(BMCPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,BMCMIFN,0),U),0),U)_" - "_$P($G(^AUPN3PPH($P(^AUPNPRVT(P,11,BMCMIFN,0),U,8),0)),U,4)
  1.  .I '$G(BMCFLAG) S BMCPCNT=BMCPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BMCMIFN,0),U,6),Z=$P(^(0),U,7),BMCPRNM(BMCPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_"-" I Z]"" S BMCPRNM(BMCPCNT)=BMCPRNM(BMCPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_($E(Y,1,3)+1700)
  1.  ;
  1. PIX ;
  1.  Q
  1. ML ;EP - set up mailing address print array
  1.  S BMCPCNT=0 K BMCPRNM
  1.  F X=1:1:3 S Y=$P($G(^DPT(DFN,.11)),U,X) I Y]"" S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=Y
  1.  S X=$P($G(^DPT(DFN,.11)),U,4)_", "
  1.  S Y="",Y=$P($G(^DPT(DFN,.11)),U,5) I Y S Y=$P(^DIC(5,Y,0),U)
  1.  S X=X_$S(Y]"":Y,1:"  ")
  1.  S X=X_" "_$P($G(^DPT(DFN,.11)),U,6)
  1.  S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=X
  1.  Q
  1.  ;
  1. RRR(P,D) ;EP Railroad Retirement 
  1.  ;P = PATIENT
  1.  ;D = DATE
  1.  ; I = IEN
  1.  ; Y = 1:yes, 0:no
  1.  I '$G(P) Q 0
  1.  I '$G(D) Q 0
  1.  NEW I,Y,J
  1.  S Y=0,U="^"
  1.  I '$D(^DPT(P,0)) Q Y
  1.  I $P(^DPT(P,0),U,19) Q Y
  1.  I '$D(^AUPNPAT(P,0)) Q Y
  1.  I '$D(^AUPNRRE(P,11)) Q Y
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D Q Y
  1.  I $$GETMBI^AUPNMBI(P,D,0)>0 S Y=1 Q Y  ;BMC*4.0*13 TEST FOR NEW MBI
  1.  S I=0 F  S I=$O(^AUPNRRE(P,11,I)) Q:I'=+I  D
  1.  . Q:$P(^AUPNRRE(P,11,I,0),U)=""
  1.  . Q:$P(^AUPNRRE(P,11,I,0),U,1)>D
  1.  . I $P(^AUPNRRE(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  . S Y=1
  1.  Q Y
  1.  ;BMC*3.1*12;IHS/OIT/FCJ FACREQ NEW
  1. FACREQ(R) ;EP return facility requesting referral
  1.  N BMCF,BMCFDA
  1.  S BMCFDA=0,BMCF=""
  1.  S BMCF=$E($P(^BMCREF(R,0),U,2),1,6),BMCFDA=$O(^AUTTLOC("C",BMCF,BMCFDA))
  1.  Q BMCFDA