- 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
