AGED4 ; IHS/ASDS/EFG -EDIT PG 4 ;
;;7.1;PATIENT REGISTRATION;**1,2,3,13**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
;
;IHS/SD/TPF AG*7.1*1 REPLACE DFN WITH AGPATDFN TO AVOID DFN CHANGES AFTER ^DIC CALLS
EN(AGSELECT) ;EP
S:$G(AGSELECT)="" AGSELECT="",NEWENTRY=1
VAR ;
S AG("PG")="4MCRA"
HDR ;
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
W $$S^AGVDF("IOF"),!
D PROGVIEW^AGUTILS(DUZ)
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?36,"MEDICARE"
W ?80-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
S AGLINE("-")=$TR($J(" ",80)," ","-")
S AGLINE("EQ")=$TR($J(" ",80)," ","=")
W !,AGLINE("EQ")
W !,$E(AGPAT,1,23)
W ?23,$$DTEST^AGUTILS(AGPATDFN)
I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
;GET ELIGIBILITY STATUS
S AGELSTS=$P($G(^AUPNPAT(AGPATDFN,11)),U,12)
W ?56,"(",$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
;W !,AGLINE("EQ")
W "================================== MEDICARE PART A AND B DATA ONLY =======================" ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
S DA=AGPATDFN
K AG("EDIT")
G DISP
NONE ;
Q:$D(AGSEENLY)
S AG("EDIT")=""
;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
I AGTYPE="MD" I $$NOPARTAB(AGPATDFN) W !,"PATIENT MUST HAVE MEDICARE PART A OR B BEFORE ADDING PART D" H 3 Q
;
D ADDNEW^AG4 ;THIS IS WHERE THE NEW ENTRY IS ACTUALLY ADDED
I '$O(^AUPNMCR(AGPATDFN,11,0)) K ADDCHK W !,"No eligibility date was entered!" H 3 D CLEANZER(AGPATDFN) Q
D UPDATE1^AGED(DUZ(2),AGPATDFN,4,"")
S NEWENTRY=0
G VAR
CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DATES
K DIK,DA
S DIK="^AUPNMCR(",DA=WD0 D ^DIK
Q
NOPARTAB(AGPATDFN) ;EP - AG*7.1*1 ITEM 2 DETERMINE IF PATIENT ALREADY HAS EITHER MCR PART A OR B
N DTREC,NOPARTAB
S DTREC=0,NOPARTAB=1 ;ASSUME THEY DON'T HAVE IT
F S DTREC=$O(^AUPNMCR(AGPATDFN,11,DTREC)) Q:'DTREC D Q:'NOPARTAB
.I $P($G(^AUPNMCR(AGPATDFN,11,DTREC,0)),U,3)="A" S NOPARTAB=0 Q
.I $P($G(^AUPNMCR(AGPATDFN,11,DTREC,0)),U,3)="B" S NOPARTAB=0 Q
Q NOPARTAB
DISP ;
S DIC=9000001,DR=.04
W !,"1.Med. Release Date: "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
S DIC=9000003,DR=.08 ;QMB/SLMB
W !,"2.QMB/SLMB : "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
W !,"3.IMP MSG FORM MCR SIG OBTAINED: ",$$IMPMSG(DA)
W !,"4.ADVANCE BENEFICIARY NOTICE: ",$$ABN(DA)
W !
;F AG("CTR")=1:1:80 W "."
W "........................ MEDICARE PART A AND B DATA ONLY ........................" ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
S DIC=9000003,DR=2101 ;medicare name
D ^AGDICLK
W ?4,"5.Medicare Name : ",$G(AG("LKPRINT"))
;S DIC=9000003,DR=.03 ;medicare number
;W ?49,"6.Medicare Number: "
;D ^AGDICLK
;I '$D(AG("LKERR")) W AG("LKPRINT")
;S DIC=9000003,DR=.04 ;suffix
;D ^AGDICLK
;I '$D(AG("LKERR")) W AG("LKPRINT")
W ?49,"6.Medicare Number: ",$$GETMCR^AGUTL(AGPATDFN) ;IHS/OIT/NKD AG*7.1*13
W !
S DIC=9000003,DR=.14 ;primary care provider
W ?4,"7.Prim. Care Prv: "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
S DIC=9000003,DR=2102 ;medicare dob
W ?49,"8.Date of Birth : "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
W !
S DIC=9000003,DR=.15 ;cc on file
W ?4,"9.CC on file : "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
I $G(AG("LKPRINT"))["Y" D
.S DIC=9000003,DR=.16 ;date cc obtained
.W ?28,"Date obtained: "
.D ^AGDICLK
.I '$D(AG("LKERR")) W AG("LKPRINT")
W !!
;W ?5,"ELIG DATE BEGIN",?29,"(updated)",?48,"Coverage",?65,"ELIG END",!
W ?5,"ELIG DATE BEGIN",?29,"(updated)",?42,"Cov",?47,"Plan Name",?70,"ELIG END",! ;IHS/SD/TPF 12/2/2005 AG*7.1*1
F AG("CTR")=1:1:80 W "."
;W !
ELIG ;
;REPLACE THIS OLD CODE
;S DIC=9000003.11
;S AG("TOTAL")=0
;S AG("N")=5
;F AG("I")=1:1 D Q:$D(AG("LKERR"))
;. S AG("DRENT")=AG("I"),DR=.02
;. D ^AGDICLK
;. Q:$D(AG("LKERR"))
;. S AG("TOTAL")=AG("TOTAL")+1
;. S AG(AG("TOTAL"))=$P(AGL,",",3)
;I AG("TOTAL")>0 D
;. F AG("I")=1:1:AG("TOTAL") D
;.. D PRINT
;.. S AG("N")=AG("I")+9
;W AGLINE("-")
;REPLACE OLD CODE
;BEGIN NEW CODE AG*7.1*3 IM23591
S AG("N")=9 ;THERE ARE 5 ITMES IN DISPLAY ABOVE
S REC=0
F CNT=1:1 S REC=$O(^AUPNMCR(AGPATDFN,11,REC)) Q:'REC D
.S IENS=REC_","_AGPATDFN_","
.W !,CNT+9,".",?6,$$GET1^DIQ(9000003.11,IENS,.01,"E")
.I CNT=1 D
..I $$GET1^DIQ(9000003,AGPATDFN_",",.07,"E")'="" W ?26,$$GET1^DIQ(9000003,AGPATDFN_",",.07,"E")
.W ?43,$$GET1^DIQ(9000003.11,IENS,.03,"E")
.W ?48,$$GET1^DIQ(9000003.11,IENS,.04,"E")
.W ?68,$$GET1^DIQ(9000003.11,IENS,.02,"E")
.S AG(CNT)=REC
S AG("N")=AG("N")+CNT-1
W !,AGLINE("-")
;END NEW CODE
;
;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
;I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS("FINDMCR",.AGINS,COMPIEN)
;I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P($G(AGSELECT),U,2)) ;AG*7.1*2 AGSELECT UNDEF AT ALPHA SITE
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
;IHS/SD/TPF 3/3/2006 AG*7.1*1
;S MYVARS("DFN")=$S($G(AUPNPAT)'="":AUPNPAT,1:$G(DFN))
S MYVARS("DFN")=$G(AGPATDFN)
S MYVARS("FINDCALL")="FINDMCR",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
I $D(AGSEENLY) S DIR("A")="Press RETURN" D ^DIR,READ^AGED1 G END
G:$G(NEWENTRY) NONE
EDIT K DIR
S DIR("?")="Enter your choice now."
S DIR("?",1)="You may enter an 'E' to Edit, an 'A' to Add or a 'D' to delete if you have"
S DIR("?",2)="the right key OR RETURN to go to page B of the medicare edit screen."
I $D(^XUSEC("AGZMGR",DUZ)) D
. S DIR("A")="(Edit = ""E"" Add = ""A"" Delete = ""D"") Type E, A, or D"
I '$D(^XUSEC("AGZMGR",DUZ)) D
. S DIR("A")="(Edit = ""E"" Add = ""A"") Type E or A"
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
S DIR(0)="FO"
D ^DIR
Q:Y=AGOPT("ESCAPE")
I $D(^XUSEC("AGZMGR",DUZ))&(Y="D") G KILL
I '$D(^XUSEC("AGZMGR",DUZ))&(Y="D") G EDIT
Q:$D(DTOUT)
S:Y="/.,"!(Y="^^") DFOUT=""
S:Y="" DLOUT=""
S:Y="^" (DUOUT,Y)=""
S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
G L6:Y="A"
W !
G END:$D(DLOUT)!(Y["N")!$D(DUOUT)!($D(DIROUT)),VAR:$D(AG("ERR"))
G EDIT:Y'="E"&(Y'="A")&(Y'="D")
L5 Q:$D(DFOUT)!$D(DTOUT)
I Y="E" D
.S DIR("?")="Enter your choice now."
.S DIR("?",1)="You may enter the item number of the field you wish to edit,"
.S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
.S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
.S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
.S DIR("A")="CHANGE which item? (1-"_$G(AG("N"))_") NONE// "
.D ^DIR
G:Y="" VAR
S AG("SEL")=+Y,AG("INDEX")=+Y-9
S AGBILL=$$USED^AGED51(AGPATDFN,$P($G(^AUPNMCR(AGPATDFN,0)),U,2),4,AG("SEL")-9)
I $L(AGBILL) D
. S X="IORVON;IORVOFF"
. D ENDR^%ZISS,HELP^XBHELP("USED","AGED51"),KILL^%ZISS
. K AGBILL
. G:'$$DIR^XBDIR("Y","Proceed with edit of Date Record","N") VAR
K AGBILL
G END:$D(DUOUT)!$D(DFOUT)
I $D(DQOUT)!(+$G(Y)<1)!(+$G(Y)>$G(AG("N"))) W !,"You must enter from 1 - ",$G(AG("N")) G EDIT
;L6 I Y="A" S AG("EDIT")="" D:$P($G(^AUPNMCR(AGPATDFN,0)),U,3)="" E3^AGED41 D:$P($G(^AUPNMCR(AGPATDFN,0)),U,4)="" E4^AGED41 D ADDCOV^AG4,UPDATE1^AGED(DUZ(2),AGPATDFN,4,"") G VAR
L6 I Y="A" S (AG("EDIT"),AG("COV"),COVTYP)="" D:$$GETMCR^AGUTL(AGPATDFN)="" E6^AGED41 D ADDCOV^AG4,UPDATE1^AGED(DUZ(2),AGPATDFN,4,"") G VAR ;IHS/OIT/NKD AG*7.1*13
L6A G L7:AG("SEL")<10
;BEGIN NEW CODE IHS/SD/TPF 12/5/05 AG*7.1*1 ITEM 1
;CHECK FOR COVTYP="D" IF IT IS GO TO THE MEDICARE PHARMACY PAGE
;I $G(AGSELECT)'="" D
;.S COVTYP=$P($G(AGSELECT),U,4)
;.S COMPIEN=$P($G(AGSELECT),U,11)
S COMPIEN=$G(AGPATDFN)_",11,"_(AG(AG("SEL")-9))_",0"
S COVTYP=$P($G(@("^AUPNMCR("_COMPIEN_")")),U,3)
I COVTYP="D" D EN^AGED4PD(COMPIEN) G VAR
;END NEW CODE
S DIC=9000003.11
F DR=.01,.03,.02 D
. S AG("DRENT1")=AG(AG("SEL")-9)
. W !,$S(DR=.01:" 10. ELIGIBILITY DATE: ",DR=.03:"11. COVERAGE TYPE: ",DR=.02:"12. ELIG. END DATE : ")
. D ^AGDICLK
. I '$D(AG("LKERR")) W AG("LKPRINT")
L6B K DIR
W !!
S DIR("A")=" Change which? (10-12) "
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
S DIR(0)="FO"
D ^DIR
G:$D(DTOUT) VAR
S:Y="/.,"!(Y="^^") DFOUT=""
S:Y="" DLOUT=""
S:Y="^" (DUOUT,Y)=""
S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
G:$D(DFOUT)!$D(DLOUT)!$D(DUOUT) VAR
G:$D(DTOUT) VAR
I +Y<9!(+Y>12) W !,"Use the numbers 10, 11, or 12.",! G L6B
S AG("SEL")=+Y
L7 D ^AGED41,UPDATE1^AGED(DUZ(2),AGPATDFN,4,"")
G VAR
END ;EP
I $D(DTOUT) S AGTOUT=""
I '$D(AGSEENLY),('$O(^AUPNMCR(AGPATDFN,11,0))) S DIK="^AUPNMCR(",DA=AGPATDFN D ^DIK K ADDCHK Q
I '$D(AGSEENLY) I ($D(MYERRS("C","E"))&(Y'?1N.N)),(Y'["V"),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
Q:Y=$G(AGOPT("ESCAPE"))
K DFOUT,DTOUT,DQOUT,DLOUT,DA,DIC,DIE,DR,DRENT,AG("DRENT1"),AGL
K AG("LKERR"),AG("LKPRINT"),Y
Q:$D(AGXTERN)
I $D(DIROUT)!$D(DUOUT) K DIROUT,DUOUT Q
K DIR
Q
PRINT ;
S AG("DRENT1")=AG(AG("I"))
S DIC=9000003.11
S DA=AGPATDFN,DR=.01
D ^AGDICLK
W AG("I")+9,".",?6,AG("LKPRINT")
;S DIC=9000003
;S DA=DFN,DR=.07
;D ^AGDICLK
;I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
;BEGIN CODE CHANGE PER ADRIAN 12/13/2005 IHS/SD/TPF AG*7.1*1
I AG("I")=1 D
.S DIC=9000003
.S DA=AGPATDFN,DR=.07
.D ^AGDICLK
.I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
;END NEW CODE
;Q
S DIC=9000003.11
S AG("DRENT1")=AG(AG("I")),DR=.03
D ^AGDICLK
;W ?41,$J(AG("LKPRINT"),11)
W ?43,AG("LKPRINT") ;IHS/SD/TPF 12/2/2005 AG*7.1*1
;BEGIN NEW CODE ADD AG/SD/TPF 12/2/2005 AG*7.1*1
;DISPLAY PLAN NAME
S AG("DRENT1")=AG(AG("I")),DR=.04
D ^AGDICLK
W ?48,$E($G(AG("LKPRINT")),1,18)
;END NEW CODE
S AG("DRENT1")=AG(AG("I")),DR=.02
D ^AGDICLK
;W ?65,$J(AG("LKPRINT"),11),!
W ?68,AG("LKPRINT"),! ;IHS/SD/TPF 12/2/2005 AG*71.*1
Q
IMPMSG(DAX) ;GET LAST DATE ENTERED FOR IMPORTANT MESSAGE FROM MEDICARE
N AGIEN,X,Y
S AGIEN=$O(^AUPNMCR(DAX,12,"B",""),-1)
I 'AGIEN Q ""
S Y=AGIEN
X ^DD("DD")
Q Y
ABN(DAX) ;
N AGIEN,X,Y
S AGIEN=$O(^AUPNMCR(DAX,13,"B",""),-1)
I 'AGIEN Q ""
S Y=AGIEN
X ^DD("DD")
Q Y
KILL ;
K DIR
S AG("I")=CNT-1 ;GET TOTAL NUMBER OF ELIG DATES FROM NEW DISPLAY AG*7.1*3 IM23591
I AG("I")=1 S DIR("A")="Are you sure you want to DELETE the COMPLETE record ? (Y/N) " S DIR(0)="Y",DIR("B")="NO" D ^DIR I Y'=1 K DIR G VAR
I AG("I")=1 S Y=11 D PATCH S DA=AGPATDFN,DIK="^AUPNMCR(" D ^DIK W !!,"The COMPLETE eligibility record has been deleted" H 2 G END
W !!,"Delete which of these coverages? (10 - ",AG("I")+9,") " D READ^AGED1 G END:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!$D(DUOUT)
I $D(DQOUT)!(+Y<10)!(+Y>(AG("I")+9)) W !!,"To delete an eligibility record, enter a number from 10 to ",AG("I")+9,". (Press RETURN for ""NO DELETE"".)" D READ^AGED1 G KILL
K DIR
S DA(1)=AGPATDFN,AG("COUNT")=0,AG("SEL")=0,AG("DELELIG")=0
F S AG("SEL")=$O(^AUPNMCR(DA(1),11,AG("SEL"))) Q:AG("COUNT")>(Y-9) D
. S AG("COUNT")=AG("COUNT")+1
. I AG("COUNT")=(Y-9) S AG("DELELIG")=AG("SEL")
K AG("SEL"),AG("COUNT")
I +Y>9&(+Y<(AG("I")+9)+1) S DIR("A")="Are you sure you want to DELETE this eligibility record ? (Y/N) " S DIR(0)="Y",DIR("B")="NO" D ^DIR I Y'=1 K DIR G VAR
S AG("I")=AG("DELELIG")
K AG("DELELIG")
;IHS/SD/TPF 8/2/2006 AG*7.1*2 IM21544
I $P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3)="" D G VAR
.W !,"COVERAGE TYPE FIELD IS NOT POPULATED"
.W !,"AN UPDATE TO NPIRS CAN NOT BE DONE PROPERLY"
.W !,"UNLESS THIS FIELD IS POPULATED"
.K DIR
.S DIR(0)="E"
.D ^DIR
D PATCH
S DA(1)=AGPATDFN,DA=AG("I"),DIK="^AUPNMCR("_DA(1)_",11,"
D ^DIK
W !!,"That Eligibility record is deleted." H 2
G VAR
PATCH D NOW^%DTC S AGDTS=%
S:'$D(^AGPATCH(AGDTS,DUZ(2),AGPATDFN)) ^(AGPATDFN)=""
Q:'$D(^AUPNMCR(AGPATDFN,11,0)) Q:'$O(^AUPNMCR(AGPATDFN,11,0))
Q:'$D(^AUPNMCR(AGPATDFN,11,AG("I"),0))
;S ^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3))="MCARE^"_$P($G(^AUPNMCR(AGPATDFN,0)),U,3,4)_U_$G(^AUPNMCR(AGPATDFN,11,AG("I"),0)) ;IHS/OIT/NKD AG*7.1*13
S ^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3))="MCARE^"_$$GETMCR^AGUTL(AGPATDFN)_U_$G(^AUPNMCR(AGPATDFN,11,AG("I"),0))
S:$P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,2)="" $P(^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$P(^AUPNMCR(AGPATDFN,11,AG("I"),0),U,3)),U,5)=DT
K AGDTS Q
12 ;
;;E;EMPLOYER GROUP HEALTH PLAN (EGHP)
;;L;LARGE GROUP HEALTH PLAN (LGHP)
;;D;END STAGE RENAL DISEASE (ESRD)
;;V;VETERANS ADMINSTRATION (VA)
;;W;WORKMANS COMPENSATION
;;B;BLACK LUNG
;;A;AUTOMOBILE/NO-FAULT
Q
AGED4 ; IHS/ASDS/EFG -EDIT PG 4 ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,3,13**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
+3 ;
+4 ;IHS/SD/TPF AG*7.1*1 REPLACE DFN WITH AGPATDFN TO AVOID DFN CHANGES AFTER ^DIC CALLS
EN(AGSELECT) ;EP
+1 IF $GET(AGSELECT)=""
SET AGSELECT=""
SET NEWENTRY=1
VAR ;
+1 SET AG("PG")="4MCRA"
HDR ;
+1 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+2 WRITE $$S^AGVDF("IOF"),!
+3 DO PROGVIEW^AGUTILS(DUZ)
+4 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+5 WRITE ?36,"MEDICARE"
+6 WRITE ?80-$LENGTH($PIECE($GET(^DIC(4,DUZ(2),0)),U)),$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+7 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+8 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+9 WRITE !,AGLINE("EQ")
+10 WRITE !,$EXTRACT(AGPAT,1,23)
+11 WRITE ?23,$$DTEST^AGUTILS(AGPATDFN)
+12 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+13 ;GET ELIGIBILITY STATUS
+14 SET AGELSTS=$PIECE($GET(^AUPNPAT(AGPATDFN,11)),U,12)
+15 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+16 ;W !,AGLINE("EQ")
+17 ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
WRITE "================================== MEDICARE PART A AND B DATA ONLY ======================="
+18 SET DA=AGPATDFN
+19 KILL AG("EDIT")
+20 GOTO DISP
NONE ;
+1 IF $DATA(AGSEENLY)
QUIT
+2 SET AG("EDIT")=""
+3 ;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
+4 IF AGTYPE="MD"
IF $$NOPARTAB(AGPATDFN)
WRITE !,"PATIENT MUST HAVE MEDICARE PART A OR B BEFORE ADDING PART D"
HANG 3
QUIT
+5 ;
+6 ;THIS IS WHERE THE NEW ENTRY IS ACTUALLY ADDED
DO ADDNEW^AG4
+7 IF '$ORDER(^AUPNMCR(AGPATDFN,11,0))
KILL ADDCHK
WRITE !,"No eligibility date was entered!"
HANG 3
DO CLEANZER(AGPATDFN)
QUIT
+8 DO UPDATE1^AGED(DUZ(2),AGPATDFN,4,"")
+9 SET NEWENTRY=0
+10 GOTO VAR
CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DATES
+1 KILL DIK,DA
+2 SET DIK="^AUPNMCR("
SET DA=WD0
DO ^DIK
+3 QUIT
NOPARTAB(AGPATDFN) ;EP - AG*7.1*1 ITEM 2 DETERMINE IF PATIENT ALREADY HAS EITHER MCR PART A OR B
+1 NEW DTREC,NOPARTAB
+2 ;ASSUME THEY DON'T HAVE IT
SET DTREC=0
SET NOPARTAB=1
+3 FOR
SET DTREC=$ORDER(^AUPNMCR(AGPATDFN,11,DTREC))
IF 'DTREC
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNMCR(AGPATDFN,11,DTREC,0)),U,3)="A"
SET NOPARTAB=0
QUIT
+5 IF $PIECE($GET(^AUPNMCR(AGPATDFN,11,DTREC,0)),U,3)="B"
SET NOPARTAB=0
QUIT
End DoDot:1
IF 'NOPARTAB
QUIT
+6 QUIT NOPARTAB
DISP ;
+1 SET DIC=9000001
SET DR=.04
+2 WRITE !,"1.Med. Release Date: "
+3 DO ^AGDICLK
+4 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+5 ;QMB/SLMB
SET DIC=9000003
SET DR=.08
+6 WRITE !,"2.QMB/SLMB : "
+7 DO ^AGDICLK
+8 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+9 WRITE !,"3.IMP MSG FORM MCR SIG OBTAINED: ",$$IMPMSG(DA)
+10 WRITE !,"4.ADVANCE BENEFICIARY NOTICE: ",$$ABN(DA)
+11 WRITE !
+12 ;F AG("CTR")=1:1:80 W "."
+13 ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
WRITE "........................ MEDICARE PART A AND B DATA ONLY ........................"
+14 ;medicare name
SET DIC=9000003
SET DR=2101
+15 DO ^AGDICLK
+16 WRITE ?4,"5.Medicare Name : ",$GET(AG("LKPRINT"))
+17 ;S DIC=9000003,DR=.03 ;medicare number
+18 ;W ?49,"6.Medicare Number: "
+19 ;D ^AGDICLK
+20 ;I '$D(AG("LKERR")) W AG("LKPRINT")
+21 ;S DIC=9000003,DR=.04 ;suffix
+22 ;D ^AGDICLK
+23 ;I '$D(AG("LKERR")) W AG("LKPRINT")
+24 ;IHS/OIT/NKD AG*7.1*13
WRITE ?49,"6.Medicare Number: ",$$GETMCR^AGUTL(AGPATDFN)
+25 WRITE !
+26 ;primary care provider
SET DIC=9000003
SET DR=.14
+27 WRITE ?4,"7.Prim. Care Prv: "
+28 DO ^AGDICLK
+29 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+30 ;medicare dob
SET DIC=9000003
SET DR=2102
+31 WRITE ?49,"8.Date of Birth : "
+32 DO ^AGDICLK
+33 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+34 WRITE !
+35 ;cc on file
SET DIC=9000003
SET DR=.15
+36 WRITE ?4,"9.CC on file : "
+37 DO ^AGDICLK
+38 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+39 IF $GET(AG("LKPRINT"))["Y"
Begin DoDot:1
+40 ;date cc obtained
SET DIC=9000003
SET DR=.16
+41 WRITE ?28,"Date obtained: "
+42 DO ^AGDICLK
+43 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
End DoDot:1
+44 WRITE !!
+45 ;W ?5,"ELIG DATE BEGIN",?29,"(updated)",?48,"Coverage",?65,"ELIG END",!
+46 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
WRITE ?5,"ELIG DATE BEGIN",?29,"(updated)",?42,"Cov",?47,"Plan Name",?70,"ELIG END",!
+47 FOR AG("CTR")=1:1:80
WRITE "."
+48 ;W !
ELIG ;
+1 ;REPLACE THIS OLD CODE
+2 ;S DIC=9000003.11
+3 ;S AG("TOTAL")=0
+4 ;S AG("N")=5
+5 ;F AG("I")=1:1 D Q:$D(AG("LKERR"))
+6 ;. S AG("DRENT")=AG("I"),DR=.02
+7 ;. D ^AGDICLK
+8 ;. Q:$D(AG("LKERR"))
+9 ;. S AG("TOTAL")=AG("TOTAL")+1
+10 ;. S AG(AG("TOTAL"))=$P(AGL,",",3)
+11 ;I AG("TOTAL")>0 D
+12 ;. F AG("I")=1:1:AG("TOTAL") D
+13 ;.. D PRINT
+14 ;.. S AG("N")=AG("I")+9
+15 ;W AGLINE("-")
+16 ;REPLACE OLD CODE
+17 ;BEGIN NEW CODE AG*7.1*3 IM23591
+18 ;THERE ARE 5 ITMES IN DISPLAY ABOVE
SET AG("N")=9
+19 SET REC=0
+20 FOR CNT=1:1
SET REC=$ORDER(^AUPNMCR(AGPATDFN,11,REC))
IF 'REC
QUIT
Begin DoDot:1
+21 SET IENS=REC_","_AGPATDFN_","
+22 WRITE !,CNT+9,".",?6,$$GET1^DIQ(9000003.11,IENS,.01,"E")
+23 IF CNT=1
Begin DoDot:2
+24 IF $$GET1^DIQ(9000003,AGPATDFN_",",.07,"E")'=""
WRITE ?26,$$GET1^DIQ(9000003,AGPATDFN_",",.07,"E")
End DoDot:2
+25 WRITE ?43,$$GET1^DIQ(9000003.11,IENS,.03,"E")
+26 WRITE ?48,$$GET1^DIQ(9000003.11,IENS,.04,"E")
+27 WRITE ?68,$$GET1^DIQ(9000003.11,IENS,.02,"E")
+28 SET AG(CNT)=REC
End DoDot:1
+29 SET AG("N")=AG("N")+CNT-1
+30 WRITE !,AGLINE("-")
+31 ;END NEW CODE
+32 ;
+33 ;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
+34 ;I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS("FINDMCR",.AGINS,COMPIEN)
+35 ;I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
+36 ;AG*7.1*2 AGSELECT UNDEF AT ALPHA SITE
IF '$GET(NEWENTRY)
IF ($GET(COMPIEN)'="")
SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$PIECE($GET(AGSELECT),U,2))
+37 KILL MYERRS,MYVARS
+38 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+39 ;IHS/SD/TPF 3/3/2006 AG*7.1*1
+40 ;S MYVARS("DFN")=$S($G(AUPNPAT)'="":AUPNPAT,1:$G(DFN))
+41 SET MYVARS("DFN")=$GET(AGPATDFN)
+42 SET MYVARS("FINDCALL")="FINDMCR"
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+43 IF '$GET(NEWENTRY)
DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+44 IF $DATA(AGSEENLY)
SET DIR("A")="Press RETURN"
DO ^DIR
DO READ^AGED1
GOTO END
+45 IF $GET(NEWENTRY)
GOTO NONE
EDIT KILL DIR
+1 SET DIR("?")="Enter your choice now."
+2 SET DIR("?",1)="You may enter an 'E' to Edit, an 'A' to Add or a 'D' to delete if you have"
+3 SET DIR("?",2)="the right key OR RETURN to go to page B of the medicare edit screen."
+4 IF $DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+5 SET DIR("A")="(Edit = ""E"" Add = ""A"" Delete = ""D"") Type E, A, or D"
End DoDot:1
+6 IF '$DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+7 SET DIR("A")="(Edit = ""E"" Add = ""A"") Type E or A"
End DoDot:1
+8 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
+9 SET DIR(0)="FO"
+10 DO ^DIR
+11 IF Y=AGOPT("ESCAPE")
QUIT
+12 IF $DATA(^XUSEC("AGZMGR",DUZ))&(Y="D")
GOTO KILL
+13 IF '$DATA(^XUSEC("AGZMGR",DUZ))&(Y="D")
GOTO EDIT
+14 IF $DATA(DTOUT)
QUIT
+15 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+16 IF Y=""
SET DLOUT=""
+17 IF Y="^"
SET (DUOUT,Y)=""
+18 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+19 IF Y="A"
GOTO L6
+20 WRITE !
+21 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)!($DATA(DIROUT))
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+22 IF Y'="E"&(Y'="A")&(Y'="D")
GOTO EDIT
L5 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+1 IF Y="E"
Begin DoDot:1
+2 SET DIR("?")="Enter your choice now."
+3 SET DIR("?",1)="You may enter the item number of the field you wish to edit,"
+4 SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
+5 SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
+6 SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
+7 SET DIR("A")="CHANGE which item? (1-"_$GET(AG("N"))_") NONE// "
+8 DO ^DIR
End DoDot:1
+9 IF Y=""
GOTO VAR
+10 SET AG("SEL")=+Y
SET AG("INDEX")=+Y-9
+11 SET AGBILL=$$USED^AGED51(AGPATDFN,$PIECE($GET(^AUPNMCR(AGPATDFN,0)),U,2),4,AG("SEL")-9)
+12 IF $LENGTH(AGBILL)
Begin DoDot:1
+13 SET X="IORVON;IORVOFF"
+14 DO ENDR^%ZISS
DO HELP^XBHELP("USED","AGED51")
DO KILL^%ZISS
+15 KILL AGBILL
+16 IF '$$DIR^XBDIR("Y","Proceed with edit of Date Record","N")
GOTO VAR
End DoDot:1
+17 KILL AGBILL
+18 IF $DATA(DUOUT)!$DATA(DFOUT)
GOTO END
+19 IF $DATA(DQOUT)!(+$GET(Y)<1)!(+$GET(Y)>$GET(AG("N")))
WRITE !,"You must enter from 1 - ",$GET(AG("N"))
GOTO EDIT
+20 ;L6 I Y="A" S AG("EDIT")="" D:$P($G(^AUPNMCR(AGPATDFN,0)),U,3)="" E3^AGED41 D:$P($G(^AUPNMCR(AGPATDFN,0)),U,4)="" E4^AGED41 D ADDCOV^AG4,UPDATE1^AGED(DUZ(2),AGPATDFN,4,"") G VAR
L6 ;IHS/OIT/NKD AG*7.1*13
IF Y="A"
SET (AG("EDIT"),AG("COV"),COVTYP)=""
IF $$GETMCR^AGUTL(AGPATDFN)=""
DO E6^AGED41
DO ADDCOV^AG4
DO UPDATE1^AGED(DUZ(2),AGPATDFN,4,"")
GOTO VAR
L6A IF AG("SEL")<10
GOTO L7
+1 ;BEGIN NEW CODE IHS/SD/TPF 12/5/05 AG*7.1*1 ITEM 1
+2 ;CHECK FOR COVTYP="D" IF IT IS GO TO THE MEDICARE PHARMACY PAGE
+3 ;I $G(AGSELECT)'="" D
+4 ;.S COVTYP=$P($G(AGSELECT),U,4)
+5 ;.S COMPIEN=$P($G(AGSELECT),U,11)
+6 SET COMPIEN=$GET(AGPATDFN)_",11,"_(AG(AG("SEL")-9))_",0"
+7 SET COVTYP=$PIECE($GET(@("^AUPNMCR("_COMPIEN_")")),U,3)
+8 IF COVTYP="D"
DO EN^AGED4PD(COMPIEN)
GOTO VAR
+9 ;END NEW CODE
+10 SET DIC=9000003.11
+11 FOR DR=.01,.03,.02
Begin DoDot:1
+12 SET AG("DRENT1")=AG(AG("SEL")-9)
+13 WRITE !,$SELECT(DR=.01:" 10. ELIGIBILITY DATE: ",DR=.03:"11. COVERAGE TYPE: ",DR=.02:"12. ELIG. END DATE : ")
+14 DO ^AGDICLK
+15 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
End DoDot:1
L6B KILL DIR
+1 WRITE !!
+2 SET DIR("A")=" Change which? (10-12) "
+3 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
+4 SET DIR(0)="FO"
+5 DO ^DIR
+6 IF $DATA(DTOUT)
GOTO VAR
+7 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+8 IF Y=""
SET DLOUT=""
+9 IF Y="^"
SET (DUOUT,Y)=""
+10 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+11 IF $DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)
GOTO VAR
+12 IF $DATA(DTOUT)
GOTO VAR
+13 IF +Y<9!(+Y>12)
WRITE !,"Use the numbers 10, 11, or 12.",!
GOTO L6B
+14 SET AG("SEL")=+Y
L7 DO ^AGED41
DO UPDATE1^AGED(DUZ(2),AGPATDFN,4,"")
+1 GOTO VAR
END ;EP
+1 IF $DATA(DTOUT)
SET AGTOUT=""
+2 IF '$DATA(AGSEENLY)
IF ('$ORDER(^AUPNMCR(AGPATDFN,11,0)))
SET DIK="^AUPNMCR("
SET DA=AGPATDFN
DO ^DIK
KILL ADDCHK
QUIT
+3 IF '$DATA(AGSEENLY)
IF ($DATA(MYERRS("C","E"))&(Y'?1N.N))
IF (Y'["V")
IF (Y'=AGOPT("ESCAPE"))
WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"
HANG 3
GOTO VAR
+4 IF Y=$GET(AGOPT("ESCAPE"))
QUIT
+5 KILL DFOUT,DTOUT,DQOUT,DLOUT,DA,DIC,DIE,DR,DRENT,AG("DRENT1"),AGL
+6 KILL AG("LKERR"),AG("LKPRINT"),Y
+7 IF $DATA(AGXTERN)
QUIT
+8 IF $DATA(DIROUT)!$DATA(DUOUT)
KILL DIROUT,DUOUT
QUIT
+9 KILL DIR
+10 QUIT
PRINT ;
+1 SET AG("DRENT1")=AG(AG("I"))
+2 SET DIC=9000003.11
+3 SET DA=AGPATDFN
SET DR=.01
+4 DO ^AGDICLK
+5 WRITE AG("I")+9,".",?6,AG("LKPRINT")
+6 ;S DIC=9000003
+7 ;S DA=DFN,DR=.07
+8 ;D ^AGDICLK
+9 ;I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
+10 ;BEGIN CODE CHANGE PER ADRIAN 12/13/2005 IHS/SD/TPF AG*7.1*1
+11 IF AG("I")=1
Begin DoDot:1
+12 SET DIC=9000003
+13 SET DA=AGPATDFN
SET DR=.07
+14 DO ^AGDICLK
+15 IF $GET(AG("LKPRINT"))'=""
WRITE ?26,"("_AG("LKPRINT")_")"
End DoDot:1
+16 ;END NEW CODE
+17 ;Q
+18 SET DIC=9000003.11
+19 SET AG("DRENT1")=AG(AG("I"))
SET DR=.03
+20 DO ^AGDICLK
+21 ;W ?41,$J(AG("LKPRINT"),11)
+22 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
WRITE ?43,AG("LKPRINT")
+23 ;BEGIN NEW CODE ADD AG/SD/TPF 12/2/2005 AG*7.1*1
+24 ;DISPLAY PLAN NAME
+25 SET AG("DRENT1")=AG(AG("I"))
SET DR=.04
+26 DO ^AGDICLK
+27 WRITE ?48,$EXTRACT($GET(AG("LKPRINT")),1,18)
+28 ;END NEW CODE
+29 SET AG("DRENT1")=AG(AG("I"))
SET DR=.02
+30 DO ^AGDICLK
+31 ;W ?65,$J(AG("LKPRINT"),11),!
+32 ;IHS/SD/TPF 12/2/2005 AG*71.*1
WRITE ?68,AG("LKPRINT"),!
+33 QUIT
IMPMSG(DAX) ;GET LAST DATE ENTERED FOR IMPORTANT MESSAGE FROM MEDICARE
+1 NEW AGIEN,X,Y
+2 SET AGIEN=$ORDER(^AUPNMCR(DAX,12,"B",""),-1)
+3 IF 'AGIEN
QUIT ""
+4 SET Y=AGIEN
+5 XECUTE ^DD("DD")
+6 QUIT Y
ABN(DAX) ;
+1 NEW AGIEN,X,Y
+2 SET AGIEN=$ORDER(^AUPNMCR(DAX,13,"B",""),-1)
+3 IF 'AGIEN
QUIT ""
+4 SET Y=AGIEN
+5 XECUTE ^DD("DD")
+6 QUIT Y
KILL ;
+1 KILL DIR
+2 ;GET TOTAL NUMBER OF ELIG DATES FROM NEW DISPLAY AG*7.1*3 IM23591
SET AG("I")=CNT-1
+3 IF AG("I")=1
SET DIR("A")="Are you sure you want to DELETE the COMPLETE record ? (Y/N) "
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
IF Y'=1
KILL DIR
GOTO VAR
+4 IF AG("I")=1
SET Y=11
DO PATCH
SET DA=AGPATDFN
SET DIK="^AUPNMCR("
DO ^DIK
WRITE !!,"The COMPLETE eligibility record has been deleted"
HANG 2
GOTO END
+5 WRITE !!,"Delete which of these coverages? (10 - ",AG("I")+9,") "
DO READ^AGED1
IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)
GOTO END
+6 IF $DATA(DQOUT)!(+Y<10)!(+Y>(AG("I")+9))
WRITE !!,"To delete an eligibility record, enter a number from 10 to ",AG("I")+9,". (Press RETURN for ""NO DELETE"".)"
DO READ^AGED1
GOTO KILL
+7 KILL DIR
+8 SET DA(1)=AGPATDFN
SET AG("COUNT")=0
SET AG("SEL")=0
SET AG("DELELIG")=0
+9 FOR
SET AG("SEL")=$ORDER(^AUPNMCR(DA(1),11,AG("SEL")))
IF AG("COUNT")>(Y-9)
QUIT
Begin DoDot:1
+10 SET AG("COUNT")=AG("COUNT")+1
+11 IF AG("COUNT")=(Y-9)
SET AG("DELELIG")=AG("SEL")
End DoDot:1
+12 KILL AG("SEL"),AG("COUNT")
+13 IF +Y>9&(+Y<(AG("I")+9)+1)
SET DIR("A")="Are you sure you want to DELETE this eligibility record ? (Y/N) "
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
IF Y'=1
KILL DIR
GOTO VAR
+14 SET AG("I")=AG("DELELIG")
+15 KILL AG("DELELIG")
+16 ;IHS/SD/TPF 8/2/2006 AG*7.1*2 IM21544
+17 IF $PIECE($GET(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3)=""
Begin DoDot:1
+18 WRITE !,"COVERAGE TYPE FIELD IS NOT POPULATED"
+19 WRITE !,"AN UPDATE TO NPIRS CAN NOT BE DONE PROPERLY"
+20 WRITE !,"UNLESS THIS FIELD IS POPULATED"
+21 KILL DIR
+22 SET DIR(0)="E"
+23 DO ^DIR
End DoDot:1
GOTO VAR
+24 DO PATCH
+25 SET DA(1)=AGPATDFN
SET DA=AG("I")
SET DIK="^AUPNMCR("_DA(1)_",11,"
+26 DO ^DIK
+27 WRITE !!,"That Eligibility record is deleted."
HANG 2
+28 GOTO VAR
PATCH DO NOW^%DTC
SET AGDTS=%
+1 IF '$DATA(^AGPATCH(AGDTS,DUZ(2),AGPATDFN))
SET ^(AGPATDFN)=""
+2 IF '$DATA(^AUPNMCR(AGPATDFN,11,0))
QUIT
IF '$ORDER(^AUPNMCR(AGPATDFN,11,0))
QUIT
+3 IF '$DATA(^AUPNMCR(AGPATDFN,11,AG("I"),0))
QUIT
+4 ;S ^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3))="MCARE^"_$P($G(^AUPNMCR(AGPATDFN,0)),U,3,4)_U_$G(^AUPNMCR(AGPATDFN,11,AG("I"),0)) ;IHS/OIT/NKD AG*7.1*13
+5 SET ^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$PIECE($GET(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3))="MCARE^"_$$GETMCR^AGUTL(AGPATDFN)_U_$GET(^AUPNMCR(AGPATDFN,11,AG("I"),0))
+6 IF $PIECE($GET(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,2)=""
SET $PIECE(^AGPATCH(AGDTS,DUZ(2),AGPATDFN,$PIECE(^AUPNMCR(AGPATDFN,11,AG("I"),0),U,3)),U,5)=DT
+7 KILL AGDTS
QUIT
12 ;
+1 ;;E;EMPLOYER GROUP HEALTH PLAN (EGHP)
+2 ;;L;LARGE GROUP HEALTH PLAN (LGHP)
+3 ;;D;END STAGE RENAL DISEASE (ESRD)
+4 ;;V;VETERANS ADMINSTRATION (VA)
+5 ;;W;WORKMANS COMPENSATION
+6 ;;B;BLACK LUNG
+7 ;;A;AUTOMOBILE/NO-FAULT
+8 QUIT
