AGED4.m

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