- 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
