AG4 ; IHS/ASDS/EFG - ENTER MEDICARE DATA ;
;;7.1;PATIENT REGISTRATION;**1,2,11,13**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
;
L1 S AG("LT")=$S($D(^AUPNMCR(DFN,0)):"YES",1:"NO")
W !!,"Does this patient have MEDICARE COVERAGE? (Y/N) ",AG("LT"),"// "
D READ^AG
S AG("LT")=$S($E(Y)="Y":"YES",1:"NO")
Q:$D(DTOUT)!$D(DFOUT)
;TESTING USE OF EDIT SCREEN FOR ADDING INSURANCE TO NEW PATIENT 5/13/2005
I $G(^AGFAC(DUZ(2),"NEWADDINS")) I AG("LT")="YES" S AGPAT=$P($G(^DPT(DFN,0)),U) S AGXTERN=1 D EN^AGED4("") K AGXTERN,DUOUT G:$G(NEWENTRY)=0 ^AG5 G L1
I $G(^AGFAC(DUZ(2),"NEWADDINS")),$D(DUOUT) G DUOUT^AG3
I $G(^AGFAC(DUZ(2),"NEWADDINS")),($G(AG("LT"))="NO") G ^AG5
;TESTING
G L2:Y["Y"
G END1:Y["N"!($D(DLOUT)&(AG("LT")="NO"))
G L2:$D(DLOUT)&(AG("LT")="YES") I $D(DUOUT) G DUOUT^AG3
D YN^AG G L1
ADDNEW ;EP - ADD NEW MEDICARE CLIENT.
L2 W !
;BEGIN AG*7.1*2 IM20637
I $$ISMINOR^AGUTILS(DFN) D G:'Y END1
.K DIR
.S DIR(0)="Y"
.S DIR("A")="A MINOR CANNOT BE THE POLICY HOLDER FOR MEDICARE ..DO YOU WISH TO ADD ENTRY?//" ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20637
.S DIR("B")="N"
.D ^DIR
;END AG*7.1*2 IM20637
S NEWENTRY=1 ;IHS/SD/TPF 12/6/2005 AG*7.1*1
I $G(AGTYPE)="MD" G ADDCOV ;IHS/SD/TPF 12/6/2005 AG*7.1*1 ITEM 2
K DIE,DIC,DR,DIR
S DIE="^AUPNPAT("
;REQUIRE MEDICARE REL DATE
S DR=".04R",DA=DFN
D ^DIE Q:$D(Y)&$D(AG("EDIT")) G L1:$D(Y) G L3:$D(^AUPNMCR(DFN,0))
S AG("INS")=$O(^AUTNINS("B","MEDICARE",""))
K DIC,DIE,DR,DIR,D0,DD
S DIC="^AUPNMCR("
S DIC(0)="L"
S X="`"_DFN
D ^DIC
Q:+Y<0
S DA=+Y
S DIE="^AUPNMCR(",DA=DFN,DR=".02///"_AG("INS")
D ^DIE
L3 ;
;W !!,"Enter the MEDICARE INSURANCE NUMBER (""suffix"" will be asked seperately)."
L4 ;REQUIRE MCR NUMBER
;S DR=".03R",DA=DFN
;S DIE="^AUPNMCR("
;D ^DIE
;I $D(Y) G L2
L5 ;
;S DIE="^AUPNMCR("
;REQUIRE SUFFIX
;S DA=DFN,DR=".04R"
;D ^DIE
;I $D(Y) G L4
D EDITMCR^AGUTL(DFN,1) ;IHS/OIT/NKD AG*7.1*13
S DIE="^AUPNMCR(",DA=DFN
S ADDCHK=""
;REQUIRE MCR NAME
S DR="2101R"
I $G(NEWENTRY)!($P($G(^AUPNMCR(DA,21)),U)="") S DR=DR_"//"_$P($G(^DPT(DFN,0)),U)
D ^DIE
I '$D(^AUPNMCR(DFN,21)) G L6
L6 ;REQUIRE MCR DOB
S DR="2102R"
I $G(NEWENTRY)!($P($G(^AUPNMCR(DA,21)),U,2)="") N AGDOB,Y S Y=$P($G(^DPT(DFN,0)),U,3) X ^DD("DD") S AGDOB=Y S DR=DR_"//"_AGDOB K Y
D ^DIE
K AGDOB
QMB S DR=.08,DA=DFN
S DIE="^AUPNMCR("
D ^DIE
IMPMSG ;
S DIC(0)="LMQE"
S DA(1)=DFN
S DIC="^AUPNMCR("_DA(1)_",12,"
D ^DIC
;
PCP S DR=.14,DA=DFN
S DIE="^AUPNMCR("
D ^DIE
CC S DR=.15,DA=DFN
S DIE="^AUPNMCR("
D ^DIE
CCD S DR=.16,DA=DFN
S DIE="^AUPNMCR("
D ^DIE
ADDCOV ;EP - ADD NEW COVERAGE.
L7 W !!,"Enter the ELIGIBILITY DATE: "
D:'$D(AG("EDIT")) DFLT1
D READ^AG
I Y="" W !,"MEDICARE ELIGIBILITY DATE REQUIRED!" H 2 G L7
Q:$D(DUOUT)&$D(AG("EDIT")) G END1:$D(DTOUT)!$D(DFOUT)!($D(DLOUT)&'$D(AG("LT1"))),L5:$D(DUOUT),L8:$D(DLOUT)
S:$D(DQOUT) Y="?"
S X=Y,%DT="EX"
D ^%DT
G L7:Y<2600000!(Y>(DT+20000))
I Y>DT W *7,!!,"SURE ABOUT THE FUTURE START DATE" S %=2 D YN^DICN G:%=2 L7
S AG("DT")=Y
K AG("COV"),COVTYP ;IHS/OIT/NKD AG*7.1*13
;L8 I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
L8 ;I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9 ;IHS/SD/TPF 12/2/2005 AG*7.1*1 ;IHS/OIT/NKD AG*7.1*13
;W !!,"Type of COVERAGE (A, B): "
W !!,"Type of COVERAGE (A, B, D): "
D:'$D(AG("EDIT")) DFLT2
D READ^AG
I Y="D",$$NOPARTAB^AGED4(DFN) W !,"PATIENT MUST HAVE MEDICARE PART A OR B BEFORE BEING ELIGIBLE FOR PART D!" G L8 ;AG*7.1*1 ITEM 2
;I Y="D",(AGELP("INS")=2) W !!,"DO NOT ADD PART D COVERAGE TO A MEDICARE INSURER ENTRY",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8 ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20523
;I Y="D",($P($G(^AUTNINS(AGELP("INS"),2)),U)'="MD") W !!,"CAN NOT ADD PART D COVERAGE TO A NON MEDICARE PART D INSURER",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8
;COVERAGE TYPE IS REQUIRED
;I Y="" W !,"Enter either ""A"" or ""B""." G L8
I Y="" W !,"Enter either ""A"" or ""B"" or ""D""." G L8
G END1:$D(DTOUT)!$D(DFOUT)!($D(DLOUT)&'$D(AG("LT2"))),L7:$D(DUOUT),L9:$D(DLOUT)
;I $D(DQOUT)!((Y'="A")&(Y'="B")) W !,"Enter either ""A"" or ""B""." G L8
I $D(DQOUT)!((Y'="A")&(Y'="B")&(Y'="D")) W !,"Enter either ""A"" or ""B"" or ""D""." G L8
;I $D(DQOUT)!((Y'="A")&(Y'="B")) D H 3 G L8 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
;.I Y'="D" W !,"Enter either ""A"" or ""B""." Q
;.W !,"You cannot Enter a new Part D on this page."
;.W !,"Go to the Summary page and choose a Medicare Part D type of insurer"
S AG("COV")=Y
K AG("MORE")
L9 S DIE="^AUPNMCR("
;IHS/SD/TPF 12/7/05 UNREPORTED BUG FIX PER ADRIAN (updated) COLUMN ON DISPLAY HAS NO DATE
S DR=".07///^S X=DT"
D ^DIE
;END
;LINE BELOW ALLOWS ENTRY OF SAME DATE EVEN THOUGH THIS FIELD IS DINUMED
;THIS IS SO MEDICARE PART A AND B CAN BE ENTERED UNDER THE SAME DATE
S DR="1101///"_$C(34)_AG("DT")_$C(34)
S DR(2,9000003.11)=".03///"_AG("COV")
;IHS/OIT/NKD AG*7.1*11 MU2 - STUFF PT SEX INTO ELIGIBLE SEX FIELD - START NEW CODE
N AGSEX
S AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
S DR(2,9000003.11)=DR(2,9000003.11)_";.08////^S X=AGSEX"
;IHS/OIT/NKD AG*7.1*11 MU2 - END NEW CODE
S DA=DFN
D ^DIE
;BEGIN NEW CODE IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
;S DIE("NO^")="BACK"
I $G(AG("COV"))="D" D ASKPARTD(DFN,D1) S NEWENTRY=0 D EN^AGED4PD(COMPIEN) K AG("MORE") Q:$D(AG("EDIT")) ;AG*7.1*2 REPORTED DURING ALPHA 11/9/2006 AG("EDIT") SHOULD BE DEFINED ONLY WHEN EDITING A PAT.
;E D ^DIE
;END NEW CODE
I $G(GOL8) G L8 ;IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
K DIE,DIC,DR,DA
END Q:$D(AG("EDIT"))
D MORE
G ADDCOV:$D(AG("MORE")) K AG
G ^AG5
END1 G END:'$D(^AUPNMCR(DFN,0))!$D(AG("EDIT"))
S DA=DFN
S DIE="^AUPNMCR("
S DR=".01///@"
D ^DIE
G END
DUOUT ;EP
G L1
DFLT1 K AG("LT1")
Q:'$D(^AUPNMCR(DFN,11,1,0))
S DIC=9000003.11
;REQUIRE ELIG BEGIN DATE
S DR=".01R",DA=DFN,AG("DRENT")=1
D ^AGDICLK
Q:$D(AG("LKERR"))
S AG("LT1")=AG("LKPRINT")
S AG("DT")=AG("LKDATA")
W AG("LKPRINT"),"// "
Q
DFLT2 K AG("LT2")
Q:'$D(^AUPNMCR(DFN,11,1,0))
S (AG("LT2"),AG("COV"))=$P(^AUPNMCR(DFN,11,1,0),U,3)
Q:AG("LT2")=""
W AG("LT2"),"// "
Q
MORE K AG("MORE")
Q:'$D(^AUPNMCR(DFN,11,0))
W !!,"Do you wish to ADD ANOTHER COVERAGE TYPE? (Y/N) NO// "
D READ^AG
Q:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!(Y["N")
G MORE1:Y["Y"
D YN^AG
G MORE
MORE1 S AG("MORE")=""
Q
ASKPARTD(DFN,D1) ;ASK PART D FIELDS
K DIC,DIE,DR,DA
S GOL8=0
S DA=D1
S DA(1)=DFN
S DIE="^AUPNMCR("_DA(1)_",11,"
F04 ;EP
S COMPIEN=DA(1)_",11,"_DA_",0"
;I $G(AGELP("INS"))'="" S DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
I $G(AGELP("INS"))'="",($G(AGELP("INS"))'=2) S DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
E S DR=".04R"
D ^DIE
I $D(Y) S GOL8=1 Q
F05 ;EP
S DR=".05R//^S X=$P($G(^AUPNMCR(DA(1),21)),U)"
D ^DIE
I $D(Y) G F04
F06 ;EP
K DR
;S DR=".06R//^S X=$P($G(^AUPNMCR(DA(1),0)),U,3)"
S DR=".06R//"_$$GETMCR^AGUTL(DFN) ;IHS/OIT/NKD AG*7.1*13
D ^DIE
I $D(Y) G F05
F07 ;EP
S DR=".07"
D ^DIE
I $D(Y) G F06
F08 ;EP
S DR=".08R//^S X=$P($G(^DPT(DA(1),0)),U,2)"
D ^DIE
I $D(Y) G F07
F09 ;EP
S DR=".09R//^S X=$P($G(^DPT(DA(1),0)),U,3)"
D ^DIE
I $D(Y) G F08
F11 ;EP
S DR=".11"
D ^DIE
I $D(Y) G F09
F13 ;EP
S DR=".13R"
D ^DIE
I $D(Y) G F11
Q
AG4 ; IHS/ASDS/EFG - ENTER MEDICARE DATA ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,11,13**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
+3 ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
+4 ;
L1 SET AG("LT")=$SELECT($DATA(^AUPNMCR(DFN,0)):"YES",1:"NO")
+1 WRITE !!,"Does this patient have MEDICARE COVERAGE? (Y/N) ",AG("LT"),"// "
+2 DO READ^AG
+3 SET AG("LT")=$SELECT($EXTRACT(Y)="Y":"YES",1:"NO")
+4 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+5 ;TESTING USE OF EDIT SCREEN FOR ADDING INSURANCE TO NEW PATIENT 5/13/2005
+6 IF $GET(^AGFAC(DUZ(2),"NEWADDINS"))
IF AG("LT")="YES"
SET AGPAT=$PIECE($GET(^DPT(DFN,0)),U)
SET AGXTERN=1
DO EN^AGED4("")
KILL AGXTERN,DUOUT
IF $GET(NEWENTRY)=0
GOTO ^AG5
GOTO L1
+7 IF $GET(^AGFAC(DUZ(2),"NEWADDINS"))
IF $DATA(DUOUT)
GOTO DUOUT^AG3
+8 IF $GET(^AGFAC(DUZ(2),"NEWADDINS"))
IF ($GET(AG("LT"))="NO")
GOTO ^AG5
+9 ;TESTING
+10 IF Y["Y"
GOTO L2
+11 IF Y["N"!($DATA(DLOUT)&(AG("LT")="NO"))
GOTO END1
+12 IF $DATA(DLOUT)&(AG("LT")="YES")
GOTO L2
IF $DATA(DUOUT)
GOTO DUOUT^AG3
+13 DO YN^AG
GOTO L1
ADDNEW ;EP - ADD NEW MEDICARE CLIENT.
L2 WRITE !
+1 ;BEGIN AG*7.1*2 IM20637
+2 IF $$ISMINOR^AGUTILS(DFN)
Begin DoDot:1
+3 KILL DIR
+4 SET DIR(0)="Y"
+5 ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20637
SET DIR("A")="A MINOR CANNOT BE THE POLICY HOLDER FOR MEDICARE ..DO YOU WISH TO ADD ENTRY?//"
+6 SET DIR("B")="N"
+7 DO ^DIR
End DoDot:1
IF 'Y
GOTO END1
+8 ;END AG*7.1*2 IM20637
+9 ;IHS/SD/TPF 12/6/2005 AG*7.1*1
SET NEWENTRY=1
+10 ;IHS/SD/TPF 12/6/2005 AG*7.1*1 ITEM 2
IF $GET(AGTYPE)="MD"
GOTO ADDCOV
+11 KILL DIE,DIC,DR,DIR
+12 SET DIE="^AUPNPAT("
+13 ;REQUIRE MEDICARE REL DATE
+14 SET DR=".04R"
SET DA=DFN
+15 DO ^DIE
IF $DATA(Y)&$DATA(AG("EDIT"))
QUIT
IF $DATA(Y)
GOTO L1
IF $DATA(^AUPNMCR(DFN,0))
GOTO L3
+16 SET AG("INS")=$ORDER(^AUTNINS("B","MEDICARE",""))
+17 KILL DIC,DIE,DR,DIR,D0,DD
+18 SET DIC="^AUPNMCR("
+19 SET DIC(0)="L"
+20 SET X="`"_DFN
+21 DO ^DIC
+22 IF +Y<0
QUIT
+23 SET DA=+Y
+24 SET DIE="^AUPNMCR("
SET DA=DFN
SET DR=".02///"_AG("INS")
+25 DO ^DIE
L3 ;
+1 ;W !!,"Enter the MEDICARE INSURANCE NUMBER (""suffix"" will be asked seperately)."
L4 ;REQUIRE MCR NUMBER
+1 ;S DR=".03R",DA=DFN
+2 ;S DIE="^AUPNMCR("
+3 ;D ^DIE
+4 ;I $D(Y) G L2
L5 ;
+1 ;S DIE="^AUPNMCR("
+2 ;REQUIRE SUFFIX
+3 ;S DA=DFN,DR=".04R"
+4 ;D ^DIE
+5 ;I $D(Y) G L4
+6 ;IHS/OIT/NKD AG*7.1*13
DO EDITMCR^AGUTL(DFN,1)
+7 SET DIE="^AUPNMCR("
SET DA=DFN
+8 SET ADDCHK=""
+9 ;REQUIRE MCR NAME
+10 SET DR="2101R"
+11 IF $GET(NEWENTRY)!($PIECE($GET(^AUPNMCR(DA,21)),U)="")
SET DR=DR_"//"_$PIECE($GET(^DPT(DFN,0)),U)
+12 DO ^DIE
+13 IF '$DATA(^AUPNMCR(DFN,21))
GOTO L6
L6 ;REQUIRE MCR DOB
+1 SET DR="2102R"
+2 IF $GET(NEWENTRY)!($PIECE($GET(^AUPNMCR(DA,21)),U,2)="")
NEW AGDOB,Y
SET Y=$PIECE($GET(^DPT(DFN,0)),U,3)
XECUTE ^DD("DD")
SET AGDOB=Y
SET DR=DR_"//"_AGDOB
KILL Y
+3 DO ^DIE
+4 KILL AGDOB
QMB SET DR=.08
SET DA=DFN
+1 SET DIE="^AUPNMCR("
+2 DO ^DIE
IMPMSG ;
+1 SET DIC(0)="LMQE"
+2 SET DA(1)=DFN
+3 SET DIC="^AUPNMCR("_DA(1)_",12,"
+4 DO ^DIC
+5 ;
PCP SET DR=.14
SET DA=DFN
+1 SET DIE="^AUPNMCR("
+2 DO ^DIE
CC SET DR=.15
SET DA=DFN
+1 SET DIE="^AUPNMCR("
+2 DO ^DIE
CCD SET DR=.16
SET DA=DFN
+1 SET DIE="^AUPNMCR("
+2 DO ^DIE
ADDCOV ;EP - ADD NEW COVERAGE.
L7 WRITE !!,"Enter the ELIGIBILITY DATE: "
+1 IF '$DATA(AG("EDIT"))
DO DFLT1
+2 DO READ^AG
+3 IF Y=""
WRITE !,"MEDICARE ELIGIBILITY DATE REQUIRED!"
HANG 2
GOTO L7
+4 IF $DATA(DUOUT)&$DATA(AG("EDIT"))
QUIT
IF $DATA(DTOUT)!$DATA(DFOUT)!($DATA(DLOUT)&'$DATA(AG("LT1")))
GOTO END1
IF $DATA(DUOUT)
GOTO L5
IF $DATA(DLOUT)
GOTO L8
+5 IF $DATA(DQOUT)
SET Y="?"
+6 SET X=Y
SET %DT="EX"
+7 DO ^%DT
+8 IF Y<2600000!(Y>(DT+20000))
GOTO L7
+9 IF Y>DT
WRITE *7,!!,"SURE ABOUT THE FUTURE START DATE"
SET %=2
DO YN^DICN
IF %=2
GOTO L7
+10 SET AG("DT")=Y
+11 ;IHS/OIT/NKD AG*7.1*13
KILL AG("COV"),COVTYP
+12 ;L8 I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
L8 ;I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9 ;IHS/SD/TPF 12/2/2005 AG*7.1*1 ;IHS/OIT/NKD AG*7.1*13
+1 ;W !!,"Type of COVERAGE (A, B): "
+2 WRITE !!,"Type of COVERAGE (A, B, D): "
+3 IF '$DATA(AG("EDIT"))
DO DFLT2
+4 DO READ^AG
+5 ;AG*7.1*1 ITEM 2
IF Y="D"
IF $$NOPARTAB^AGED4(DFN)
WRITE !,"PATIENT MUST HAVE MEDICARE PART A OR B BEFORE BEING ELIGIBLE FOR PART D!"
GOTO L8
+6 ;I Y="D",(AGELP("INS")=2) W !!,"DO NOT ADD PART D COVERAGE TO A MEDICARE INSURER ENTRY",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8 ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20523
+7 ;I Y="D",($P($G(^AUTNINS(AGELP("INS"),2)),U)'="MD") W !!,"CAN NOT ADD PART D COVERAGE TO A NON MEDICARE PART D INSURER",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8
+8 ;COVERAGE TYPE IS REQUIRED
+9 ;I Y="" W !,"Enter either ""A"" or ""B""." G L8
+10 IF Y=""
WRITE !,"Enter either ""A"" or ""B"" or ""D""."
GOTO L8
+11 IF $DATA(DTOUT)!$DATA(DFOUT)!($DATA(DLOUT)&'$DATA(AG("LT2")))
GOTO END1
IF $DATA(DUOUT)
GOTO L7
IF $DATA(DLOUT)
GOTO L9
+12 ;I $D(DQOUT)!((Y'="A")&(Y'="B")) W !,"Enter either ""A"" or ""B""." G L8
+13 IF $DATA(DQOUT)!((Y'="A")&(Y'="B")&(Y'="D"))
WRITE !,"Enter either ""A"" or ""B"" or ""D""."
GOTO L8
+14 ;I $D(DQOUT)!((Y'="A")&(Y'="B")) D H 3 G L8 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
+15 ;.I Y'="D" W !,"Enter either ""A"" or ""B""." Q
+16 ;.W !,"You cannot Enter a new Part D on this page."
+17 ;.W !,"Go to the Summary page and choose a Medicare Part D type of insurer"
+18 SET AG("COV")=Y
+19 KILL AG("MORE")
L9 SET DIE="^AUPNMCR("
+1 ;IHS/SD/TPF 12/7/05 UNREPORTED BUG FIX PER ADRIAN (updated) COLUMN ON DISPLAY HAS NO DATE
+2 SET DR=".07///^S X=DT"
+3 DO ^DIE
+4 ;END
+5 ;LINE BELOW ALLOWS ENTRY OF SAME DATE EVEN THOUGH THIS FIELD IS DINUMED
+6 ;THIS IS SO MEDICARE PART A AND B CAN BE ENTERED UNDER THE SAME DATE
+7 SET DR="1101///"_$CHAR(34)_AG("DT")_$CHAR(34)
+8 SET DR(2,9000003.11)=".03///"_AG("COV")
+9 ;IHS/OIT/NKD AG*7.1*11 MU2 - STUFF PT SEX INTO ELIGIBLE SEX FIELD - START NEW CODE
+10 NEW AGSEX
+11 SET AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
+12 SET DR(2,9000003.11)=DR(2,9000003.11)_";.08////^S X=AGSEX"
+13 ;IHS/OIT/NKD AG*7.1*11 MU2 - END NEW CODE
+14 SET DA=DFN
+15 DO ^DIE
+16 ;BEGIN NEW CODE IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
+17 ;S DIE("NO^")="BACK"
+18 ;AG*7.1*2 REPORTED DURING ALPHA 11/9/2006 AG("EDIT") SHOULD BE DEFINED ONLY WHEN EDITING A PAT.
IF $GET(AG("COV"))="D"
DO ASKPARTD(DFN,D1)
SET NEWENTRY=0
DO EN^AGED4PD(COMPIEN)
KILL AG("MORE")
IF $DATA(AG("EDIT"))
QUIT
+19 ;E D ^DIE
+20 ;END NEW CODE
+21 ;IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
IF $GET(GOL8)
GOTO L8
+22 KILL DIE,DIC,DR,DA
END IF $DATA(AG("EDIT"))
QUIT
+1 DO MORE
+2 IF $DATA(AG("MORE"))
GOTO ADDCOV
KILL AG
+3 GOTO ^AG5
END1 IF '$DATA(^AUPNMCR(DFN,0))!$DATA(AG("EDIT"))
GOTO END
+1 SET DA=DFN
+2 SET DIE="^AUPNMCR("
+3 SET DR=".01///@"
+4 DO ^DIE
+5 GOTO END
DUOUT ;EP
+1 GOTO L1
DFLT1 KILL AG("LT1")
+1 IF '$DATA(^AUPNMCR(DFN,11,1,0))
QUIT
+2 SET DIC=9000003.11
+3 ;REQUIRE ELIG BEGIN DATE
+4 SET DR=".01R"
SET DA=DFN
SET AG("DRENT")=1
+5 DO ^AGDICLK
+6 IF $DATA(AG("LKERR"))
QUIT
+7 SET AG("LT1")=AG("LKPRINT")
+8 SET AG("DT")=AG("LKDATA")
+9 WRITE AG("LKPRINT"),"// "
+10 QUIT
DFLT2 KILL AG("LT2")
+1 IF '$DATA(^AUPNMCR(DFN,11,1,0))
QUIT
+2 SET (AG("LT2"),AG("COV"))=$PIECE(^AUPNMCR(DFN,11,1,0),U,3)
+3 IF AG("LT2")=""
QUIT
+4 WRITE AG("LT2"),"// "
+5 QUIT
MORE KILL AG("MORE")
+1 IF '$DATA(^AUPNMCR(DFN,11,0))
QUIT
+2 WRITE !!,"Do you wish to ADD ANOTHER COVERAGE TYPE? (Y/N) NO// "
+3 DO READ^AG
+4 IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DLOUT)!(Y["N")
QUIT
+5 IF Y["Y"
GOTO MORE1
+6 DO YN^AG
+7 GOTO MORE
MORE1 SET AG("MORE")=""
+1 QUIT
ASKPARTD(DFN,D1) ;ASK PART D FIELDS
+1 KILL DIC,DIE,DR,DA
+2 SET GOL8=0
+3 SET DA=D1
+4 SET DA(1)=DFN
+5 SET DIE="^AUPNMCR("_DA(1)_",11,"
F04 ;EP
+1 SET COMPIEN=DA(1)_",11,"_DA_",0"
+2 ;I $G(AGELP("INS"))'="" S DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
+3 IF $GET(AGELP("INS"))'=""
IF ($GET(AGELP("INS"))'=2)
SET DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
+4 IF '$TEST
SET DR=".04R"
+5 DO ^DIE
+6 IF $DATA(Y)
SET GOL8=1
QUIT
F05 ;EP
+1 SET DR=".05R//^S X=$P($G(^AUPNMCR(DA(1),21)),U)"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F04
F06 ;EP
+1 KILL DR
+2 ;S DR=".06R//^S X=$P($G(^AUPNMCR(DA(1),0)),U,3)"
+3 ;IHS/OIT/NKD AG*7.1*13
SET DR=".06R//"_$$GETMCR^AGUTL(DFN)
+4 DO ^DIE
+5 IF $DATA(Y)
GOTO F05
F07 ;EP
+1 SET DR=".07"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F06
F08 ;EP
+1 SET DR=".08R//^S X=$P($G(^DPT(DA(1),0)),U,2)"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F07
F09 ;EP
+1 SET DR=".09R//^S X=$P($G(^DPT(DA(1),0)),U,3)"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F08
F11 ;EP
+1 SET DR=".11"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F09
F13 ;EP
+1 SET DR=".13R"
+2 DO ^DIE
+3 IF $DATA(Y)
GOTO F11
+4 QUIT
