AGED61 ; IHS/ASDS/EFG - EDIT - PAGE 6 (2 OF 2) (RR) ;
;;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 ;
S DIC="^AUPNMSP("
S DIC(0)="AELQMZ"
S DIC("DR")=""
S DIC("S")="I $P($G(^AUPNMSP(Y,0)),U,2)=$G(AUPNPAT)"
D ^DIC
Q:Y<0
S DIE=DIC
K DR,DIC,DIR
S DA=+Y
;S DR=".01;.02////"_AUPNPAT_";.03;.04"
S DR=".02////"_AUPNPAT_";.03;.04"
D ^DIE
D UPDATE
Q
E2 ;
S DIE="^AUPNRRE("
S DA=DFN
S DR=.08
W !
D ^DIE
D UPDATE
Q
E3 ;EP
S DIE="^AUPNPAT("
S DA=DFN
S DR=.04
W !
D ^DIE
D UPDATE
Q
E4 ;EP
S DIE="^AUPNRRE("
S DA=DFN
S DR=2101
W !
D ^DIE
I $D(^AUPNRRE(DFN,21)),$P($G(^AUPNRRE(DFN,21)),U)]"" D
. S DIE="^DPT("
.S DA=DFN,DR="1///"_$P($G(^AUPNRRE(DFN,21)),U),DR(2,2.01)=.01
. D ^DIE
D UPDATE
Q
E5 ;
D EDITRRE^AGUTL(DFN) ;IHS/OIT/NKD AG*7.1*13
;S DIE="^AUPNRRE("
;S DR=".03;.04"
;S DA=DFN
;W !,"The NUMBER will be prompted for immediately after the PREFIX",!
;D ^DIE
;I $P($G(^AUPNRRE(DFN,0)),U,3)="" D
;. S DA=DFN
;. S DR=".01///@"
;. S DIE="^AUPNRRE("
;. D ^DIE
;. W !!,"Railroad coverage is deleted." H 3
D UPDATE
Q
E6 S DIE="^AUPNRRE("
S DA=DFN
S DR=.14
W !
D ^DIE
D UPDATE
Q
E7 S DIE="^AUPNRRE("
S DA=DFN
S DR=2102
W !
D ^DIE
D UPDATE
Q
E8 ;
S DIE="^AUPNRRE("
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 5
.W !
.D ^DIE
I X["N" D
.S DR=".16////@"
.W !
.D ^DIE
D UPDATE
Q
E9 ;
S DA(1)=DFN
S DIE="^AUPNRRE("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S DR=.01
W !
D ^DIE
D UPDATE
Q
E10 ;
N OLDVALUE,NOCHANGE
S DA(1)=DFN
S DIE="^AUPNRRE("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S NOCHANGE=0
S OLDVALUE=$P($G(^AUPNRRE(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(^AUPNRRE(DA(1),11,DA,0)),U,3)="D",(NOCHANGE) S $P(^AUPNRRE(DA(1),11,DA,0),U,3)=OLDVALUE D G E10
.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
E11 ;
S DA(1)=DFN
S DIE="^AUPNRRE("_DA(1)_",11,"
S DA=AG(AG("INDEX"))
S DR=.02
W !
D ^DIE
D UPDATE
Q
UPDATE ;
S DIE="^AUPNRRE("
S DA=DFN
S DR=".07////"_DT
W !
D ^DIE
Q
AGED61 ; IHS/ASDS/EFG - EDIT - PAGE 6 (2 OF 2) (RR) ;
+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 ;
+1 SET DIC="^AUPNMSP("
+2 SET DIC(0)="AELQMZ"
+3 SET DIC("DR")=""
+4 SET DIC("S")="I $P($G(^AUPNMSP(Y,0)),U,2)=$G(AUPNPAT)"
+5 DO ^DIC
+6 IF Y<0
QUIT
+7 SET DIE=DIC
+8 KILL DR,DIC,DIR
+9 SET DA=+Y
+10 ;S DR=".01;.02////"_AUPNPAT_";.03;.04"
+11 SET DR=".02////"_AUPNPAT_";.03;.04"
+12 DO ^DIE
+13 DO UPDATE
+14 QUIT
E2 ;
+1 SET DIE="^AUPNRRE("
+2 SET DA=DFN
+3 SET DR=.08
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E3 ;EP
+1 SET DIE="^AUPNPAT("
+2 SET DA=DFN
+3 SET DR=.04
+4 WRITE !
+5 DO ^DIE
+6 DO UPDATE
+7 QUIT
E4 ;EP
+1 SET DIE="^AUPNRRE("
+2 SET DA=DFN
+3 SET DR=2101
+4 WRITE !
+5 DO ^DIE
+6 IF $DATA(^AUPNRRE(DFN,21))
IF $PIECE($GET(^AUPNRRE(DFN,21)),U)]""
Begin DoDot:1
+7 SET DIE="^DPT("
+8 SET DA=DFN
SET DR="1///"_$PIECE($GET(^AUPNRRE(DFN,21)),U)
SET DR(2,2.01)=.01
+9 DO ^DIE
End DoDot:1
+10 DO UPDATE
+11 QUIT
E5 ;
+1 ;IHS/OIT/NKD AG*7.1*13
DO EDITRRE^AGUTL(DFN)
+2 ;S DIE="^AUPNRRE("
+3 ;S DR=".03;.04"
+4 ;S DA=DFN
+5 ;W !,"The NUMBER will be prompted for immediately after the PREFIX",!
+6 ;D ^DIE
+7 ;I $P($G(^AUPNRRE(DFN,0)),U,3)="" D
+8 ;. S DA=DFN
+9 ;. S DR=".01///@"
+10 ;. S DIE="^AUPNRRE("
+11 ;. D ^DIE
+12 ;. W !!,"Railroad coverage is deleted." H 3
+13 DO UPDATE
+14 QUIT
E6 SET DIE="^AUPNRRE("
+1 SET DA=DFN
+2 SET DR=.14
+3 WRITE !
+4 DO ^DIE
+5 DO UPDATE
+6 QUIT
E7 SET DIE="^AUPNRRE("
+1 SET DA=DFN
+2 SET DR=2102
+3 WRITE !
+4 DO ^DIE
+5 DO UPDATE
+6 QUIT
E8 ;
+1 SET DIE="^AUPNRRE("
+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 5
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
E9 ;
+1 SET DA(1)=DFN
+2 SET DIE="^AUPNRRE("_DA(1)_",11,"
+3 SET DA=AG(AG("INDEX"))
+4 SET DR=.01
+5 WRITE !
+6 DO ^DIE
+7 DO UPDATE
+8 QUIT
E10 ;
+1 NEW OLDVALUE,NOCHANGE
+2 SET DA(1)=DFN
+3 SET DIE="^AUPNRRE("_DA(1)_",11,"
+4 SET DA=AG(AG("INDEX"))
+5 SET NOCHANGE=0
+6 SET OLDVALUE=$PIECE($GET(^AUPNRRE(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(^AUPNRRE(DA(1),11,DA,0)),U,3)="D"
IF (NOCHANGE)
SET $PIECE(^AUPNRRE(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 E10
+16 DO UPDATE
+17 QUIT
E11 ;
+1 SET DA(1)=DFN
+2 SET DIE="^AUPNRRE("_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="^AUPNRRE("
+2 SET DA=DFN
+3 SET DR=".07////"_DT
+4 WRITE !
+5 DO ^DIE
+6 QUIT
