BWGRVLU1 ; IHS/CMI/LAB - GEN RETR UTILITIES ;15-Feb-2003 21:54;PLS
;;2.0;WOMEN'S HEALTH;**6,7,8**;MAY 16, 1996
;
MCR ;MCR display all current medicare data
NEW BWGRMIFN
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 BWGRPCNT=1,BWGRPRNM(BWGRPCNT)=$P(^AUPNMCR(DFN,0),U,3)_" ["_$S($P(^(0),U,4)]"":$P(^AUTTMCS($P(^(0),U,4),0),U),1:"-")_"]"
S BWGRMIFN=0 F S BWGRMIFN=$O(^AUPNMCR(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN D
.Q:$P(^AUPNMCR(P,11,BWGRMIFN,0),U)>D
.I $P(^AUPNMCR(P,11,BWGRMIFN,0),U,2)]"",$P(^(0),U,2)<D Q
.S BWGRPCNT=BWGRPCNT+1,Y=$P(^AUPNMCR(DFN,11,BWGRMIFN,0),U),Z=$P(^(0),U,2),BWGRPRNM(BWGRPCNT)=$P(^(0),U,3)_" "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
.Q
MCRX ;
K Y,Z
Q
;
MCD ;EP
NEW BWGRMIFN,BWGRNIFN
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 BWGRMIFN=0 F S BWGRMIFN=$O(^AUPNMCD("B",P,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN D
.Q:'$D(^AUPNMCD(BWGRMIFN,11))
.S BWGRNIFN=0 F S BWGRNIFN=$O(^AUPNMCD(BWGRMIFN,11,BWGRNIFN)) Q:BWGRNIFN'=+BWGRNIFN D
..Q:BWGRNIFN>D
..I $P(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
..S BWGRPCNT=BWGRPCNT+1,BWGRPRNM(BWGRPCNT)=$P(^AUPNMCD(BWGRMIFN,0),U,3)_"/"_$S($P(^AUPNMCD(BWGRMIFN,0),U,2)]"":$P(^AUTNINS($P(^AUPNMCD(BWGRMIFN,0),U,2),0),U),1:"<>")
..S BWGRPCNT=BWGRPCNT+1,Y=$P(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U),Z=$P(^(0),U,2),BWGRPRNM(BWGRPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
..Q
.Q
;
MCDX ;
Q
;
PI ;EP
NEW BWGRMIFN,BWGRFLG
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 BWGRMIFN=0 F S BWGRMIFN=$O(^AUPNPRVT(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN D
.Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
.S BWGRNAME=$P(^AUPNPRVT(DFN,11,BWGRMIFN,0),U) Q:BWGRNAME=""
.Q:$P(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S BWGRPCNT=BWGRPCNT+1,BWGRPRNM(BWGRPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,BWGRMIFN,0),U),0),U)
.S BWGRPCNT=BWGRPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BWGRMIFN,0),U,6),Z=$P(^(0),U,7),BWGRPRNM(BWGRPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
.Q
PIX ;
Q
PIV ;EP
NEW BWGRMIFN,BWGRFLG
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 BWGRMIFN=0 F S BWGRMIFN=$O(^AUPNPRVT(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN D
.Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
.S BWGRNAME=$P(^AUPNPRVT(DFN,11,BWGRMIFN,0),U) Q:BWGRNAME=""
.Q:$P(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S BWGRPRNT=$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,9) I BWGRPRNT]"" S BWGRPRNT=$$FMTE^XLFDT(BWGRPRNT,"2D")
.Q
PIVX ;
Q
;
ML ;EP - set up mailing address print array
S BWGRPCNT=0 K BWGRPRNM
F X=1:1:3 S Y=$P($G(^DPT(DFN,.11)),U,X) I Y]"" S BWGRPCNT=BWGRPCNT+1,BWGRPRNM(BWGRPCNT)=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 BWGRPCNT=BWGRPCNT+1,BWGRPRNM(BWGRPCNT)=X
Q
BWGRVLU1 ; IHS/CMI/LAB - GEN RETR UTILITIES ;15-Feb-2003 21:54;PLS
+1 ;;2.0;WOMEN'S HEALTH;**6,7,8**;MAY 16, 1996
+2 ;
MCR ;MCR display all current medicare data
+1 NEW BWGRMIFN
+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 BWGRPCNT=1
SET BWGRPRNM(BWGRPCNT)=$PIECE(^AUPNMCR(DFN,0),U,3)_" ["_$SELECT($PIECE(^(0),U,4)]"":$PIECE(^AUTTMCS($PIECE(^(0),U,4),0),U),1:"-")_"]"
+8 SET BWGRMIFN=0
FOR
SET BWGRMIFN=$ORDER(^AUPNMCR(P,11,BWGRMIFN))
IF BWGRMIFN'=+BWGRMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNMCR(P,11,BWGRMIFN,0),U)>D
QUIT
+10 IF $PIECE(^AUPNMCR(P,11,BWGRMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET BWGRPCNT=BWGRPCNT+1
SET Y=$PIECE(^AUPNMCR(DFN,11,BWGRMIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET BWGRPRNM(BWGRPCNT)=$PIECE(^(0),U,3)_" "_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+12 QUIT
End DoDot:1
MCRX ;
+1 KILL Y,Z
+2 QUIT
+3 ;
MCD ;EP
+1 NEW BWGRMIFN,BWGRNIFN
+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 BWGRMIFN=0
FOR
SET BWGRMIFN=$ORDER(^AUPNMCD("B",P,BWGRMIFN))
IF BWGRMIFN'=+BWGRMIFN
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNMCD(BWGRMIFN,11))
QUIT
+8 SET BWGRNIFN=0
FOR
SET BWGRNIFN=$ORDER(^AUPNMCD(BWGRMIFN,11,BWGRNIFN))
IF BWGRNIFN'=+BWGRNIFN
QUIT
Begin DoDot:2
+9 IF BWGRNIFN>D
QUIT
+10 IF $PIECE(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET BWGRPCNT=BWGRPCNT+1
SET BWGRPRNM(BWGRPCNT)=$PIECE(^AUPNMCD(BWGRMIFN,0),U,3)_"/"_$SELECT($PIECE(^AUPNMCD(BWGRMIFN,0),U,2)]"":$PIECE(^AUTNINS($PIECE(^AUPNMCD(BWGRMIFN,0),U,2),0),U),1:"<>")
+12 SET BWGRPCNT=BWGRPCNT+1
SET Y=$PIECE(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET BWGRPRNM(BWGRPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDX ;
+1 QUIT
+2 ;
PI ;EP
+1 NEW BWGRMIFN,BWGRFLG
+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 BWGRMIFN=0
FOR
SET BWGRMIFN=$ORDER(^AUPNPRVT(P,11,BWGRMIFN))
IF BWGRMIFN'=+BWGRMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
QUIT
+9 SET BWGRNAME=$PIECE(^AUPNPRVT(DFN,11,BWGRMIFN,0),U)
IF BWGRNAME=""
QUIT
+10 IF $PIECE(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
QUIT
+11 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+13 SET BWGRPCNT=BWGRPCNT+1
SET BWGRPRNM(BWGRPCNT)=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U),0),U)
+14 SET BWGRPCNT=BWGRPCNT+1
SET Y=$PIECE(^AUPNPRVT(DFN,11,BWGRMIFN,0),U,6)
SET Z=$PIECE(^(0),U,7)
SET BWGRPRNM(BWGRPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET BWGRPRNM(BWGRPCNT)=BWGRPRNM(BWGRPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+15 QUIT
End DoDot:1
PIX ;
+1 QUIT
PIV ;EP
+1 NEW BWGRMIFN,BWGRFLG
+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 BWGRMIFN=0
FOR
SET BWGRMIFN=$ORDER(^AUPNPRVT(P,11,BWGRMIFN))
IF BWGRMIFN'=+BWGRMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
QUIT
+9 SET BWGRNAME=$PIECE(^AUPNPRVT(DFN,11,BWGRMIFN,0),U)
IF BWGRNAME=""
QUIT
+10 IF $PIECE(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
QUIT
+11 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+13 SET BWGRPRNT=$PIECE(^AUPNPRVT(P,11,BWGRMIFN,0),U,9)
IF BWGRPRNT]""
SET BWGRPRNT=$$FMTE^XLFDT(BWGRPRNT,"2D")
+14 QUIT
End DoDot:1
PIVX ;
+1 QUIT
+2 ;
ML ;EP - set up mailing address print array
+1 SET BWGRPCNT=0
KILL BWGRPRNM
+2 FOR X=1:1:3
SET Y=$PIECE($GET(^DPT(DFN,.11)),U,X)
IF Y]""
SET BWGRPCNT=BWGRPCNT+1
SET BWGRPRNM(BWGRPCNT)=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 BWGRPCNT=BWGRPCNT+1
SET BWGRPRNM(BWGRPCNT)=X
+8 QUIT
