BCHRLU1 ; IHS/CMI/LAB - GEN RET UTIL ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - patch 7 Y2K
;
;IHS/CMI/LAB - PATCH 6 9/21/98
;IHS/CMI/LAB - patch 9 fixes variable Y to Z
MCR ;display all current medicare data
NEW BCHMIFN
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 - patch 6 replaced BCHACE with D 9/21/98
.S BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUPNMCR(DFN,0),U,3)_" ["_$S($P(^(0),U,4)]"":$P(^AUTTMCS($P(^(0),U,4),0),U),1:"-")_"]"
.;begin Y2K
.;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
.S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_"-" ;Y2000
.I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000
.;end Y2K
.Q
MCRX ;
K Y,Z
Q
;
MCD ;
NEW BCHMIFN,BCHNIFN
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 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 BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUPNMCD(BCHMIFN,0),U,3)_"/"_$S($P(^AUPNMCD(BCHMIFN,0),U,2)]"":$P(^AUTNINS($P(^AUPNMCD(BCHMIFN,0),U,2),0),U),1:"<>")
..;begin Y2K
..;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
..S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))_"-" ;Y2000
..I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000
..;end Y2K
..Q
.Q
;
MCDX ;
Q
;
PI ;
NEW BCHMIFN,BCHFLG
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(DFN,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 BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,BCHMIFN,0),U),0),U)
.;begin Y2K
.;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
.S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))_"-" ;Y2000
.I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000
.;end Y2K
.Q
PIX ;
Q
BCHRLU1 ; IHS/CMI/LAB - GEN RET UTIL ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - patch 7 Y2K
+3 ;
+4 ;IHS/CMI/LAB - PATCH 6 9/21/98
+5 ;IHS/CMI/LAB - patch 9 fixes variable Y to Z
MCR ;display all current medicare data
+1 NEW BCHMIFN
+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 SET BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNMCR(P,11,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U)>D
QUIT
+9 ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98
IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+10 SET BCHPCNT=BCHPCNT+1
SET BCHPRNM(BCHPCNT)=$PIECE(^AUPNMCR(DFN,0),U,3)_" ["_$SELECT($PIECE(^(0),U,4)]"":$PIECE(^AUTTMCS($PIECE(^(0),U,4),0),U),1:"-")_"]"
+11 ;begin Y2K
+12 ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
+13 ;Y2000
SET BCHPCNT=BCHPCNT+1
SET Y=$PIECE(^AUPNMCR(DFN,11,BCHMIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)_"-"
+14 ;Y2000
IF Z]""
SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))
+15 ;end Y2K
+16 QUIT
End DoDot:1
MCRX ;
+1 KILL Y,Z
+2 QUIT
+3 ;
MCD ;
+1 NEW BCHMIFN,BCHNIFN
+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 BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNMCD("B",P,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNMCD(BCHMIFN,11))
QUIT
+8 SET BCHNIFN=0
FOR
SET BCHNIFN=$ORDER(^AUPNMCD(BCHMIFN,11,BCHNIFN))
IF BCHNIFN'=+BCHNIFN
QUIT
Begin DoDot:2
+9 IF BCHNIFN>D
QUIT
+10 IF $PIECE(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET BCHPCNT=BCHPCNT+1
SET BCHPRNM(BCHPCNT)=$PIECE(^AUPNMCD(BCHMIFN,0),U,3)_"/"_$SELECT($PIECE(^AUPNMCD(BCHMIFN,0),U,2)]"":$PIECE(^AUTNINS($PIECE(^AUPNMCD(BCHMIFN,0),U,2),0),U),1:"<>")
+12 ;begin Y2K
+13 ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
+14 ;Y2000
SET BCHPCNT=BCHPCNT+1
SET Y=$PIECE(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))_"-"
+15 ;Y2000
IF Z]""
SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))
+16 ;end Y2K
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 ;
MCDX ;
+1 QUIT
+2 ;
PI ;
+1 NEW BCHMIFN,BCHFLG
+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 BCHMIFN=0
FOR
SET BCHMIFN=$ORDER(^AUPNPRVT(P,11,BCHMIFN))
IF BCHMIFN'=+BCHMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U)=""
QUIT
+9 SET BCHNAME=$PIECE(^AUPNPRVT(DFN,11,BCHMIFN,0),U)
IF BCHNAME=""
QUIT
+10 IF $PIECE(^AUTNINS(BCHNAME,0),U)["AHCCCS"
QUIT
+11 IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U,6)>D
QUIT
+12 ;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
+13 SET BCHPCNT=BCHPCNT+1
SET BCHPRNM(BCHPCNT)=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U),0),U)
+14 ;begin Y2K
+15 ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000
+16 ;Y2000
SET BCHPCNT=BCHPCNT+1
SET Y=$PIECE(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6)
SET Z=$PIECE(^(0),U,7)
SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))_"-"
+17 ;Y2000
IF Z]""
SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))
+18 ;end Y2K
+19 QUIT
End DoDot:1
PIX ;
+1 QUIT
