BCHRLU ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - GEN RETR UTILITIES ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;Patch 11 added $$LOC call
;
;IHS/CMI/LAB - patch 6 replace BCHACE with D in MCR and PI
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
MCR(P,D) ;is patient medicare eligible on this date
NEW BCHMIFN,BCHFLG
S BCHFLG=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 BCHMIFN=0 F S BCHMIFN=$O(^AUPNMCR(P,11,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN D
.Q:$P(^AUPNMCR(P,11,BCHMIFN,0),U)>D
.I $P(^AUPNMCR(P,11,BCHMIFN,0),U,2)]"",$P(^(0),U,2)<D Q ;IHS/CMI/LAB - changed BCHACE to D patch 6 9/21/98
.S BCHFLG=1
.Q
MCRX ;
Q BCHFLG
;
MCD(P,D) ;
NEW BCHMIFN,BCHNIFN,BCHFLG
S BCHFLG=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 BCHMIFN=0 F S BCHMIFN=$O(^AUPNMCD("B",P,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN D
.Q:'$D(^AUPNMCD(BCHMIFN,11))
.S BCHNIFN=0 F S BCHNIFN=$O(^AUPNMCD(BCHMIFN,11,BCHNIFN)) Q:BCHNIFN'=+BCHNIFN D
..Q:BCHNIFN>D
..I $P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
..S BCHFLG=1
..Q
.Q
;
MCDX ;
Q BCHFLG
;
PI(P,D) ;
NEW BCHMIFN,BCHFLG
S BCHFLG=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 BCHMIFN=0 F S BCHMIFN=$O(^AUPNPRVT(P,11,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN D
.Q:$P(^AUPNPRVT(P,11,BCHMIFN,0),U)=""
.S BCHNAME=$P(^AUPNPRVT(P,11,BCHMIFN,0),U) Q:BCHNAME=""
.Q:$P(^AUTNINS(BCHNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,BCHMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]"",$P(^(0),U,7)<D Q ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98
.S BCHFLG=1
.Q
PIX ;
Q BCHFLG
BCHRLU ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - GEN RETR UTILITIES ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;Patch 11 added $$LOC call
+3 ;
+4 ;IHS/CMI/LAB - patch 6 replace BCHACE with D in MCR and PI
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
MCR(P,D) ;is patient medicare eligible on this date
+1 NEW BCHMIFN,BCHFLG
+2 SET BCHFLG=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 BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNMCR(P,11,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U)>D
QUIT
+10 ;IHS/CMI/LAB - changed BCHACE to D patch 6 9/21/98
IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET BCHFLG=1
+12 QUIT
End DoDot:1
MCRX ;
+1 QUIT BCHFLG
+2 ;
MCD(P,D) ;
+1 NEW BCHMIFN,BCHNIFN,BCHFLG
+2 SET BCHFLG=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 BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNMCD("B",P,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNMCD(BCHMIFN,11))
QUIT
+9 SET BCHNIFN=0
FOR
SET BCHNIFN=$ORDER(^AUPNMCD(BCHMIFN,11,BCHNIFN))
IF BCHNIFN'=+BCHNIFN
QUIT
Begin DoDot:2
+10 IF BCHNIFN>D
QUIT
+11 IF $PIECE(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+12 SET BCHFLG=1
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDX ;
+1 QUIT BCHFLG
+2 ;
PI(P,D) ;
+1 NEW BCHMIFN,BCHFLG
+2 SET BCHFLG=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 BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNPRVT(P,11,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U)=""
QUIT
+10 SET BCHNAME=$PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U)
IF BCHNAME=""
QUIT
+11 IF $PIECE(^AUTNINS(BCHNAME,0),U)["AHCCCS"
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U,6)>D
QUIT
+13 ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98
IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+14 SET BCHFLG=1
+15 QUIT
End DoDot:1
PIX ;
+1 QUIT BCHFLG
