- 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
