AGED41 ; IHS/ASDS/EFG - EDIT - PAGE 4 (2 OF 2) (MEDICARE) ;
;;7.1;PATIENT REGISTRATION;**1,2,13**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
;
D @($P("E1,E2,E3,E4,E5,E6,E7,E8,E9,E10,E11,E12,",",",AG("SEL"))) Q
E1 ;EP - MCR REL DATE
S DIE="^AUPNPAT("
S DA=DFN
S DR=".04R"
W !
D ^DIE
D UPDATE
Q
E2 ;QBM/SLMB
S DIE="^AUPNMCR("
S DA=DFN
S DR=.08
W !
D ^DIE
D UPDATE
Q
E3 ;EP - IMP MSG FORM MCR SIG OBTAINED
S DIE="^AUPNMCR("
S DA=DFN
S DR=1201
W !
D ^DIE
D UPDATE
Q
E4 ;EP - ADVANCE BENEFICIARY NOTICE
S DIE="^AUPNMCR("
S DA=DFN
S DR=1301
W !
D ^DIE
D UPDATE
Q
E5 ;EP - MEDICARE NAME
S DIE="^AUPNMCR("
S DA=DFN
S DR="2101R"
W !
D ^DIE
D UPDATE
Q
E6 ;MCR NUMBER AND SUFFIX
D EDITMCR^AGUTL(DFN) ;IHS/OIT/NKD AG*7.1*13
;S DIE="^AUPNMCR("
;S DR=".03R;.04R"
;S DA=DFN
;W !,"The SUFFIX will be prompted for immediately after the number!",!
;D ^DIE
;I $P($G(^AUPNMCR(DFN,0)),U,3)="" D
;. S DA=DFN
;. S DR=".01///@"
;. S DIE="^AUPNMCR("
;. D ^DIE
;. W !!,"Medicare coverage is deleted." H 3
D UPDATE
Q
E7 ;PRIMARY CARE PROVIDER
S DIE="^AUPNMCR("
S DA=DFN
S DR=.14
W !
D ^DIE
D UPDATE
Q
E8 ;MEDICARE DOB
S DIE="^AUPNMCR("
S DA=DFN
S DR="2102R"
W !
D ^DIE
D UPDATE
Q
E9 ;CARD COPY ON FILE AND DATE OBTAINED
S DIE="^AUPNMCR("
S DA=DFN
S DR=.15
W !
D ^DIE
I X["Y" D
.;S DR=.16
.S DR=".16R",DIE("NO^")="" ;IHS/SD/TPF AG*7.1*1 ITEM 4
.W !
.D ^DIE
I X["N" D
.S DR=".16////@"
.W !
.D ^DIE
D UPDATE
Q
E10 ;ELIGIBILITY DATE
S DA(1)=DFN
S DIE="^AUPNMCR("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S DR=".01R"
W !
D ^DIE
D UPDATE
Q
E11 ;COVERAGE TYPE
N OLDVALUE,NOCHANGE
S DA(1)=DFN
S DIE="^AUPNMCR("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S NOCHANGE=0
S OLDVALUE=$P($G(^AUPNMCR(DA(1),11,DA,0)),U,3)
I OLDVALUE="A"!(OLDVALUE="B") D
.S NOCHANGE=1
S DR=.03
W !
D ^DIE
I $P($G(^AUPNMCR(DA(1),11,DA,0)),U,3)="D",(NOCHANGE) S $P(^AUPNMCR(DA(1),11,DA,0),U,3)=OLDVALUE D G E11
.W !,"DO NOT CHANGE AN EXISTING PART A OR B COVERAGE TO PART D"
.W !,"REVIEW THE PATCH 1 ADDENDUM TO SET UP PART D COVERAGE"
.H 3
D UPDATE
Q
E12 ;ELIGIBILITY END DATE
S DA(1)=DFN
S DIE="^AUPNMCR("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S DR=.02
W !
D ^DIE
D UPDATE
Q
UPDATE ;
S DIE="^AUPNMCR("
S DA=DFN
S DR=".07////"_DT
W !
D ^DIE
Q
AGED41 ; IHS/ASDS/EFG - EDIT - PAGE 4 (2 OF 2) (MEDICARE) ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,13**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
+3 ;
+4 DO @($PIECE("E1,E2,E3,E4,E5,E6,E7,E8,E9,E10,E11,E12,",",",AG("SEL")))
QUIT
E1 ;EP - MCR REL DATE
+1 SET DIE="^AUPNPAT("
+2 SET DA=DFN
+3 SET DR=".04R"
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E2 ;QBM/SLMB
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=.08
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E3 ;EP - IMP MSG FORM MCR SIG OBTAINED
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=1201
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E4 ;EP - ADVANCE BENEFICIARY NOTICE
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=1301
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E5 ;EP - MEDICARE NAME
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR="2101R"
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E6 ;MCR NUMBER AND SUFFIX
+1 ;IHS/OIT/NKD AG*7.1*13
DO EDITMCR^AGUTL(DFN)
+2 ;S DIE="^AUPNMCR("
+3 ;S DR=".03R;.04R"
+4 ;S DA=DFN
+5 ;W !,"The SUFFIX will be prompted for immediately after the number!",!
+6 ;D ^DIE
+7 ;I $P($G(^AUPNMCR(DFN,0)),U,3)="" D
+8 ;. S DA=DFN
+9 ;. S DR=".01///@"
+10 ;. S DIE="^AUPNMCR("
+11 ;. D ^DIE
+12 ;. W !!,"Medicare coverage is deleted." H 3
+13 DO UPDATE
+14 QUIT
E7 ;PRIMARY CARE PROVIDER
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=.14
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E8 ;MEDICARE DOB
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR="2102R"
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E9 ;CARD COPY ON FILE AND DATE OBTAINED
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=.15
+4 WRITE !
+5 DO ^DIE
+6 IF X["Y"
Begin DoDot:1
+7 ;S DR=.16
+8 ;IHS/SD/TPF AG*7.1*1 ITEM 4
SET DR=".16R"
SET DIE("NO^")=""
+9 WRITE !
+10 DO ^DIE
End DoDot:1
+11 IF X["N"
Begin DoDot:1
+12 SET DR=".16////@"
+13 WRITE !
+14 DO ^DIE
End DoDot:1
+15 DO UPDATE
+16 QUIT
E10 ;ELIGIBILITY DATE
+1 SET DA(1)=DFN
+2 SET DIE="^AUPNMCR("_DA(1)_",11,"
+3 SET DA=AG(AG("INDEX"))
+4 SET DR=".01R"
+5 WRITE !
+6 DO ^DIE
+7 DO UPDATE
+8 QUIT
E11 ;COVERAGE TYPE
+1 NEW OLDVALUE,NOCHANGE
+2 SET DA(1)=DFN
+3 SET DIE="^AUPNMCR("_DA(1)_",11,"
+4 SET DA=AG(AG("INDEX"))
+5 SET NOCHANGE=0
+6 SET OLDVALUE=$PIECE($GET(^AUPNMCR(DA(1),11,DA,0)),U,3)
+7 IF OLDVALUE="A"!(OLDVALUE="B")
Begin DoDot:1
+8 SET NOCHANGE=1
End DoDot:1
+9 SET DR=.03
+10 WRITE !
+11 DO ^DIE
+12 IF $PIECE($GET(^AUPNMCR(DA(1),11,DA,0)),U,3)="D"
IF (NOCHANGE)
SET $PIECE(^AUPNMCR(DA(1),11,DA,0),U,3)=OLDVALUE
Begin DoDot:1
+13 WRITE !,"DO NOT CHANGE AN EXISTING PART A OR B COVERAGE TO PART D"
+14 WRITE !,"REVIEW THE PATCH 1 ADDENDUM TO SET UP PART D COVERAGE"
+15 HANG 3
End DoDot:1
GOTO E11
+16 DO UPDATE
+17 QUIT
E12 ;ELIGIBILITY END DATE
+1 SET DA(1)=DFN
+2 SET DIE="^AUPNMCR("_DA(1)_",11,"
+3 SET DA=AG(AG("INDEX"))
+4 SET DR=.02
+5 WRITE !
+6 DO ^DIE
+7 DO UPDATE
+8 QUIT
UPDATE ;
+1 SET DIE="^AUPNMCR("
+2 SET DA=DFN
+3 SET DR=".07////"_DT
+4 WRITE !
+5 DO ^DIE
+6 QUIT
