- 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
