AMHRLU ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - GEN RETR UTILITIES 03 Jun 2009 12:08 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
CASE ;EP - called from BH REPORT SORT
K X
Q:'$G(P)
S Y=0 F S Y=$O(^AMHPCASE("C",DFN,Y)) Q:Y'=+Y S D=$P(^AMHPCASE(Y,0),U,P) D
.Q:'$$ALLOWCD^AMHLCD(DUZ,Y)
.Q:D=""
.Q:$P(^AMHTRPT(AMHRPT,11,AMHI,11,1,0),U)]D
.Q:D]$P(^AMHTRPT(AMHRPT,11,AMHI,11,1,0),U,2)
.S X(D)=""
.Q
K P,D,Y
Q
MCR(P,D) ;EP is patient medicare eligible on this date
NEW AMHMIFN,AMHFLG
S AMHFLG=0
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
S AMHMIFN=0 F S AMHMIFN=$O(^AUPNMCR(P,11,AMHMIFN)) Q:AMHMIFN'=+AMHMIFN D
.Q:$P(^AUPNMCR(P,11,AMHMIFN,0),U)>D
.I $P(^AUPNMCR(P,11,AMHMIFN,0),U,2)]"",$P(^(0),U,2)<D Q
.S AMHFLG=1
.Q
MCRX ;
Q AMHFLG
;
MCD(P,D) ;EP
NEW AMHMIFN,AMHNIFN,AMHFLG
S AMHFLG=0
I '$D(^DPT(P,0)) G MCRX
I $P(^DPT(P,0),U,19) G MCRX
I '$D(^AUPNPAT(P,0)) G MCDX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
S AMHMIFN=0 F S AMHMIFN=$O(^AUPNMCD("B",P,AMHMIFN)) Q:AMHMIFN'=+AMHMIFN D
.Q:'$D(^AUPNMCD(AMHMIFN,11))
.S AMHNIFN=0 F S AMHNIFN=$O(^AUPNMCD(AMHMIFN,11,AMHNIFN)) Q:AMHNIFN'=+AMHNIFN D
..Q:AMHNIFN>D
..I $P(^AUPNMCD(AMHMIFN,11,AMHNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
..S AMHFLG=1
..Q
.Q
;
MCDX ;
Q AMHFLG
;
PI(P,D) ;EP
NEW AMHMIFN,AMHFLG
S AMHFLG=0
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 AMHMIFN=0 F S AMHMIFN=$O(^AUPNPRVT(P,11,AMHMIFN)) Q:AMHMIFN'=+AMHMIFN D
.Q:$P(^AUPNPRVT(P,11,AMHMIFN,0),U)=""
.S AMHNAME=$P(^AUPNPRVT(P,11,AMHMIFN,0),U) Q:AMHNAME=""
.Q:$P(^AUTNINS(AMHNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,AMHMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,AMHMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S AMHFLG=1
.Q
PIX ;
Q AMHFLG
AMHRLU ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - GEN RETR UTILITIES 03 Jun 2009 12:08 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
CASE ;EP - called from BH REPORT SORT
+1 KILL X
+2 IF '$GET(P)
QUIT
+3 SET Y=0
FOR
SET Y=$ORDER(^AMHPCASE("C",DFN,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AMHPCASE(Y,0),U,P)
Begin DoDot:1
+4 IF '$$ALLOWCD^AMHLCD(DUZ,Y)
QUIT
+5 IF D=""
QUIT
+6 IF $PIECE(^AMHTRPT(AMHRPT,11,AMHI,11,1,0),U)]D
QUIT
+7 IF D]$PIECE(^AMHTRPT(AMHRPT,11,AMHI,11,1,0),U,2)
QUIT
+8 SET X(D)=""
+9 QUIT
End DoDot:1
+10 KILL P,D,Y
+11 QUIT
MCR(P,D) ;EP is patient medicare eligible on this date
+1 NEW AMHMIFN,AMHFLG
+2 SET AMHFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO MCRX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+6 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+7 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+8 SET AMHMIFN=0
FOR
SET AMHMIFN=$ORDER(^AUPNMCR(P,11,AMHMIFN))
IF AMHMIFN'=+AMHMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNMCR(P,11,AMHMIFN,0),U)>D
QUIT
+10 IF $PIECE(^AUPNMCR(P,11,AMHMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET AMHFLG=1
+12 QUIT
End DoDot:1
MCRX ;
+1 QUIT AMHFLG
+2 ;
MCD(P,D) ;EP
+1 NEW AMHMIFN,AMHNIFN,AMHFLG
+2 SET AMHFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO MCRX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+7 SET AMHMIFN=0
FOR
SET AMHMIFN=$ORDER(^AUPNMCD("B",P,AMHMIFN))
IF AMHMIFN'=+AMHMIFN
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNMCD(AMHMIFN,11))
QUIT
+9 SET AMHNIFN=0
FOR
SET AMHNIFN=$ORDER(^AUPNMCD(AMHMIFN,11,AMHNIFN))
IF AMHNIFN'=+AMHNIFN
QUIT
Begin DoDot:2
+10 IF AMHNIFN>D
QUIT
+11 IF $PIECE(^AUPNMCD(AMHMIFN,11,AMHNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+12 SET AMHFLG=1
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDX ;
+1 QUIT AMHFLG
+2 ;
PI(P,D) ;EP
+1 NEW AMHMIFN,AMHFLG
+2 SET AMHFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO PIX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+6 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+7 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+8 SET AMHMIFN=0
FOR
SET AMHMIFN=$ORDER(^AUPNPRVT(P,11,AMHMIFN))
IF AMHMIFN'=+AMHMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNPRVT(P,11,AMHMIFN,0),U)=""
QUIT
+10 SET AMHNAME=$PIECE(^AUPNPRVT(P,11,AMHMIFN,0),U)
IF AMHNAME=""
QUIT
+11 IF $PIECE(^AUTNINS(AMHNAME,0),U)["AHCCCS"
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,AMHMIFN,0),U,6)>D
QUIT
+13 IF $PIECE(^AUPNPRVT(P,11,AMHMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+14 SET AMHFLG=1
+15 QUIT
End DoDot:1
PIX ;
+1 QUIT AMHFLG
