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