AGED6 ; IHS/ASDS/EFG -EDIT PG 6 RAILROAD RETIREMENT;
;;7.1;PATIENT REGISTRATION;**1,2,3,13**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
;
EN(AGSELECT) ;EP
S:$G(AGSELECT)="" AGSELECT="",NEWENTRY=1
VAR ;
S AG("PG")="4RRA"
HDR ;
S ROUTID=$P($T(+1)," ")
W $$S^AGVDF("IOF"),!
D PROGVIEW^AGUTILS(DUZ,$P(AGSELECT,U,11))
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?30,"RAILROAD RETIREMENT"
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(DFN)
I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
;GET ELIGIBILITY STATUS
S AGELSTS=$P($G(^AUPNPAT(DFN,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 "================================== RAILROAD PART A AND B DATA ONLY =======================" ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
S DA=DFN
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(DFN) W !,"PATIENT MUST HAVE RAILROAD PART A OR B BEFORE ADDING PART D" H 3 Q
D ADDNEW^AG6
I '$O(^AUPNRRE(DFN,11,0)) K ADDCHK W !,"No eligibility date was entered!" H 3 D CLEANZER(DFN) Q
D UPDATE1^AGED(DUZ(2),DFN,4,"")
S NEWENTRY=0
G VAR
CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DATES
K DIK,DA
S DIK="^AUPNRRE(",DA=WD0 D ^DIK
Q
NOPARTAB(DFN) ;EP - DETERMINE IF PATIENT ALREADY HAS EITHER RR PART A OR B
N DTREC,NOPARTAB
S DTREC=0,NOPARTAB=1 ;ASSUME THEY DON'T HAVE IT
F S DTREC=$O(^AUPNRRE(DFN,11,DTREC)) Q:'DTREC D Q:'NOPARTAB
.I $P($G(^AUPNRRE(DFN,11,DTREC,0)),U,3)="A" S NOPARTAB=0 Q
.I $P($G(^AUPNRRE(DFN,11,DTREC,0)),U,3)="B" S NOPARTAB=0 Q
Q NOPARTAB
DISP ;
K AGMSPDT,AGMSPIEN,AGMSP,AGMSPR
S AGMSPDT=$O(^AUPNMSP("C",AUPNPAT,""),-1)
I $G(AGMSPDT)'="" S AGMSPIEN=$O(^AUPNMSP("C",AUPNPAT,AGMSPDT,""),-1)
I $G(AGMSPIEN)'="" S AGMSP=$G(^AUPNMSP(AGMSPIEN,0))
;MSP patient
W !,"1.MSP Patient(Y/N) : "
W $P($G(AGMSP),U,3)
W ?30,"Date signature obtained: "
S Y=$P($G(AGMSP),U)
D DD^%DT
W Y
W !,?2,"MSP Reason : "
S AGMSPR=$P($G(AGMSP),U,4)
S AGMSPFLG=0,AGMSPRT=0
F AGMSPRT=1:1 Q:AGMSPFLG=1 D
. S AGTEST=$P($T(AGREASON+AGMSPRT),";",3)
. I AGTEST="Q" S AGMSPFLG=1 Q
. I AGTEST=AGMSPR S AGMSPR=$P($T(AGREASON+AGMSPRT),";",4),AGMSPFLG=1
W AGMSPR
K AGTEST,AGMSPFLG,AGMSPRT
;QMB/SLMB
S DIC=9000005,DR=.08
W !,"2.QMB/SLMB : "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
S DIC=9000001,DR=.04
W !,"3.Med. Release Date: "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
W !
;F AG("CTR")=1:1:80 W "."
W "........................ RAILROAD PART A AND B DATA ONLY ........................" ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
;railroad name
S DIC=9000005,DR=2101
D ^AGDICLK
W ?4,"4.Railroad Name : ",$G(AG("LKPRINT"))
;;prefix
;S DIC=9000005,DR=.03
;W ?49,"5.Railroad Number: "
;D ^AGDICLK
;I '$D(AG("LKERR")) W AG("LKPRINT")
;;railroad number
;S DIC=9000005,DR=.04
;D ^AGDICLK
;I '$D(AG("LKERR")) W AG("LKPRINT")
W ?49,"5.Railroad Number: ",$$GETRRE^AGUTL(AGPATDFN) ;IHS/OIT/NKD AG*7.1*13
W !
;primary care provider
S DIC=9000005,DR=.14
W ?4,"6.Prim. Care Prv: "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
;
;railroad dob
S DIC=9000005
I $$ISREQ^AGFLDREQ(9000005,.2102) S DIE("NO^")="",DR="2102R"
E S DR="2102"
D ^AGDICLK
W ?49,"7.Date of Birth : "
I '$D(AG("LKERR")) W AG("LKPRINT")
W !
;cc on file
S DIC=9000005,DR=.15
W ?4,"8.CC on file : "
D ^AGDICLK
I '$D(AG("LKERR")) W AG("LKPRINT")
I $G(AG("LKPRINT"))["Y" D
.S DIC=9000005,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=9000005.11
;S AG("TOTAL")=0
;S AG("N")=9
;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")+8
;W AGLINE("-")
;REPLACE OLD CODE
;BEGIN NEW CODE AG*7.1*3 IM23591
S AG("N")=8 ;THERE ARE 8 ITEMS IN DISPLAY ABOVE
S REC=0
F CNT=1:1 S REC=$O(^AUPNRRE(AGPATDFN,11,REC)) Q:'REC D
.S IENS=REC_","_AGPATDFN_","
.W !,CNT+8,".",?6,$$GET1^DIQ(9000005.11,IENS,.01,"E")
.I CNT=1 D
..I $$GET1^DIQ(9000005,AGPATDFN_",",.07,"E")'="" W ?26,$$GET1^DIQ(9000005,AGPATDFN_",",.07,"E")
.W ?43,$$GET1^DIQ(9000005.11,IENS,.03,"E")
.W ?48,$$GET1^DIQ(9000005.11,IENS,.04,"E")
.W ?68,$$GET1^DIQ(9000005.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
;S:$G(AGSELECT)'="" AGSELECT=$$FINDRRE^AGINSUPD(AGSELECT)
I '$G(NEWENTRY),($G(COMPIEN)'="") S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=$S($G(AUPNPAT)'="":AUPNPAT,1:$G(DFN)),MYVARS("FINDCALL")="FINDRRE",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
I $D(AGSEENLY) D ^DIR,READ^AGED1 G END
G:$G(NEWENTRY) NONE
EDIT K DIR
W !
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
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)
L5A I Y="E" D
.S DIR("A")="Enter field number to edit"
.D ^DIR
Q:Y=AGOPT("ESCAPE")
G:Y="" VAR
S AG("SEL")=+Y,AG("INDEX")=+Y-8
S AGBILL=$$USED^AGED51(DFN,$P($G(^AUPNRRE(DFN,0)),U,2),4,AG("SEL")-8)
I $L(AGBILL) D
. S X="IORVON;IORVOFF"
. D ENDR^%ZISS,HELP^XBHELP("USED","AGED51"),KILL^%ZISS
. KILL AGBILL
. G:'$$DIR^XBDIR("Y","Proceed with edit of Date Record","N") VAR
KILL 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(^AUPNRRE(DFN,0)),U,3)="" E3^AGED61 D:$P($G(^AUPNRRE(DFN,0)),U,4)="" E4^AGED61 D ADDCOV^AG6,UPDATE1^AGED(DUZ(2),DFN,4,"") G VAR
L6 I Y="A" S (AG("EDIT"),AG("COV"),COVTYP)="" D:$$GETRRE^AGUTL(DFN)="" E5^AGED61 D ADDCOV^AG6,UPDATE1^AGED(DUZ(2),DFN,4,"") G VAR ;IHS/OIT/NKD AG*7.1*13
L6A G L7:AG("SEL")<9
;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
S COMPIEN=AUPNPAT_",11,"_(AG(AG("SEL")-8))_",0"
S COVTYP=$P($G(@("^AUPNRRE("_COMPIEN_")")),U,3)
I COVTYP="D" D EN^AGED6PD(COMPIEN) G VAR
;END NEW CODE
S DIC=9000005.11
I $G(AG(AG("SEL")-8))="" S Y="E" W !,"Use ""A"" to Add an eligibility date." G L5A
F DR=.01,.03,.02 D
. S AG("DRENT1")=$G(AG(AG("SEL")-8))
. W !,$S(DR=.01:" 9. ELIGIBILITY DATE: ",DR=.03:"10. COVERAGE TYPE: ",DR=.02:"11. ELIG. END DATE : ")
. D ^AGDICLK
. I '$D(AG("LKERR")) W AG("LKPRINT")
L6B K DIR
W !!
S DIR("A")=" Change which? (9-11) "
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 +$G(Y)<9!(+$G(Y)>11) W !,"Use the numbers 9, 10, or 11.",! G L6B
S AG("SEL")=+$G(Y)
L7 D ^AGED61,UPDATE1^AGED(DUZ(2),DFN,4,"")
G VAR
END ;EP
I $D(DTOUT) S AGTOUT=""
I '$D(AGSEENLY),('$O(^AUPNRRE(DFN,11,0))) S DIK="^AUPNRRE(",DA=DFN 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 AG,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 DUOUT,DIROUT Q
K DIR
Q
PRINT ;
S AG("DRENT1")=AG(AG("I"))
;elig date
S DIC=9000005.11
S DA=DFN,DR=.01
D ^AGDICLK
W AG("I")+8,".",?6,AG("LKPRINT")
;last updated
;S DIC=9000005
;S DA=DFN,DR=.07
;D ^AGDICLK
;I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
I AG("I")=1 D
.S DIC=9000005
.S DA=DFN,DR=.07
.D ^AGDICLK
.I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
;END NEW CODE
;coverage type
S DIC=9000005.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
;elig end date
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
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=DFN,DIK="^AUPNRRE(" D ^DIK W !!,"The COMPLETE eligibility record has been deleted" H 2 G END
W !!,"Delete which of these coverages? (9 - ",AG("I")+8,") " D READ^AGED1 G END:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!$D(DUOUT)
I $D(DQOUT)!(+Y<9)!(+Y>(AG("I")+8)) W !!,"To delete an eligibility record, enter a number from 9 to ",AG("I")+8,". (Press RETURN for ""NO DELETE"".)" D READ^AGED1 G KILL
K DIR
S DA(1)=DFN,AG("COUNT")=0,AG("SEL")=0,AG("DELELIG")=0
F S AG("SEL")=$O(^AUPNRRE(DA(1),11,AG("SEL"))) Q:AG("COUNT")>(Y-8) D
. S AG("COUNT")=AG("COUNT")+1
. I AG("COUNT")=(Y-8) S AG("DELELIG")=AG("SEL")
K AG("SEL"),AG("COUNT")
I +Y>8&(+Y<(AG("I")+8)+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 ;IHS/OIT/NKD AG*7.1*13 BUG FIX
I $P($G(^AUPNRRE(DA(1),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)=DFN,DA=AG("I"),DIK="^AUPNRRE("_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),DFN)) ^(DFN)=""
Q:'$D(^AUPNRRE(DFN,11,0)) Q:'$O(^AUPNRRE(DFN,11,0))
Q:$P($G(^AUPNRRE(DFN,11,AG("I"),0)),U,3)=""
;S ^AGPATCH(AGDTS,DUZ(2),DFN,$P(^AUPNRRE(DFN,11,AG("I"),0),U,3))="RROAD^"_$P($G(^AUPNRRE(DFN,0)),U,3,4)_U_$G(^AUPNRRE(DFN,11,AG("I"),0)) ;IHS/OIT/NKD AG*7.1*13
S ^AGPATCH(AGDTS,DUZ(2),DFN,$P(^AUPNRRE(DFN,11,AG("I"),0),U,3))="RROAD^"_$$GETRRE^AGUTL(DFN)_U_$G(^AUPNRRE(DFN,11,AG("I"),0))
S:$P($G(^AUPNRRE(DFN,11,AG("I"),0)),U,2)="" $P(^AGPATCH(AGDTS,DUZ(2),DFN,$P(^AUPNRRE(DFN,11,AG("I"),0),U,3)),U,5)=DT
K AGDTS Q
AGREASON ;
;;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
AGED6 ; IHS/ASDS/EFG -EDIT PG 6 RAILROAD RETIREMENT;
+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 ;
EN(AGSELECT) ;EP
+1 IF $GET(AGSELECT)=""
SET AGSELECT=""
SET NEWENTRY=1
VAR ;
+1 SET AG("PG")="4RRA"
HDR ;
+1 SET ROUTID=$PIECE($TEXT(+1)," ")
+2 WRITE $$S^AGVDF("IOF"),!
+3 DO PROGVIEW^AGUTILS(DUZ,$PIECE(AGSELECT,U,11))
+4 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+5 WRITE ?30,"RAILROAD RETIREMENT"
+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(DFN)
+12 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+13 ;GET ELIGIBILITY STATUS
+14 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,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 "================================== RAILROAD PART A AND B DATA ONLY ======================="
+18 SET DA=DFN
+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(DFN)
WRITE !,"PATIENT MUST HAVE RAILROAD PART A OR B BEFORE ADDING PART D"
HANG 3
QUIT
+5 DO ADDNEW^AG6
+6 IF '$ORDER(^AUPNRRE(DFN,11,0))
KILL ADDCHK
WRITE !,"No eligibility date was entered!"
HANG 3
DO CLEANZER(DFN)
QUIT
+7 DO UPDATE1^AGED(DUZ(2),DFN,4,"")
+8 SET NEWENTRY=0
+9 GOTO VAR
CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DATES
+1 KILL DIK,DA
+2 SET DIK="^AUPNRRE("
SET DA=WD0
DO ^DIK
+3 QUIT
NOPARTAB(DFN) ;EP - DETERMINE IF PATIENT ALREADY HAS EITHER RR 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(^AUPNRRE(DFN,11,DTREC))
IF 'DTREC
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNRRE(DFN,11,DTREC,0)),U,3)="A"
SET NOPARTAB=0
QUIT
+5 IF $PIECE($GET(^AUPNRRE(DFN,11,DTREC,0)),U,3)="B"
SET NOPARTAB=0
QUIT
End DoDot:1
IF 'NOPARTAB
QUIT
+6 QUIT NOPARTAB
DISP ;
+1 KILL AGMSPDT,AGMSPIEN,AGMSP,AGMSPR
+2 SET AGMSPDT=$ORDER(^AUPNMSP("C",AUPNPAT,""),-1)
+3 IF $GET(AGMSPDT)'=""
SET AGMSPIEN=$ORDER(^AUPNMSP("C",AUPNPAT,AGMSPDT,""),-1)
+4 IF $GET(AGMSPIEN)'=""
SET AGMSP=$GET(^AUPNMSP(AGMSPIEN,0))
+5 ;MSP patient
+6 WRITE !,"1.MSP Patient(Y/N) : "
+7 WRITE $PIECE($GET(AGMSP),U,3)
+8 WRITE ?30,"Date signature obtained: "
+9 SET Y=$PIECE($GET(AGMSP),U)
+10 DO DD^%DT
+11 WRITE Y
+12 WRITE !,?2,"MSP Reason : "
+13 SET AGMSPR=$PIECE($GET(AGMSP),U,4)
+14 SET AGMSPFLG=0
SET AGMSPRT=0
+15 FOR AGMSPRT=1:1
IF AGMSPFLG=1
QUIT
Begin DoDot:1
+16 SET AGTEST=$PIECE($TEXT(AGREASON+AGMSPRT),";",3)
+17 IF AGTEST="Q"
SET AGMSPFLG=1
QUIT
+18 IF AGTEST=AGMSPR
SET AGMSPR=$PIECE($TEXT(AGREASON+AGMSPRT),";",4)
SET AGMSPFLG=1
End DoDot:1
+19 WRITE AGMSPR
+20 KILL AGTEST,AGMSPFLG,AGMSPRT
+21 ;QMB/SLMB
+22 SET DIC=9000005
SET DR=.08
+23 WRITE !,"2.QMB/SLMB : "
+24 DO ^AGDICLK
+25 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+26 SET DIC=9000001
SET DR=.04
+27 WRITE !,"3.Med. Release Date: "
+28 DO ^AGDICLK
+29 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+30 WRITE !
+31 ;F AG("CTR")=1:1:80 W "."
+32 ;IHS/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
WRITE "........................ RAILROAD PART A AND B DATA ONLY ........................"
+33 ;railroad name
+34 SET DIC=9000005
SET DR=2101
+35 DO ^AGDICLK
+36 WRITE ?4,"4.Railroad Name : ",$GET(AG("LKPRINT"))
+37 ;;prefix
+38 ;S DIC=9000005,DR=.03
+39 ;W ?49,"5.Railroad Number: "
+40 ;D ^AGDICLK
+41 ;I '$D(AG("LKERR")) W AG("LKPRINT")
+42 ;;railroad number
+43 ;S DIC=9000005,DR=.04
+44 ;D ^AGDICLK
+45 ;I '$D(AG("LKERR")) W AG("LKPRINT")
+46 ;IHS/OIT/NKD AG*7.1*13
WRITE ?49,"5.Railroad Number: ",$$GETRRE^AGUTL(AGPATDFN)
+47 WRITE !
+48 ;primary care provider
+49 SET DIC=9000005
SET DR=.14
+50 WRITE ?4,"6.Prim. Care Prv: "
+51 DO ^AGDICLK
+52 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+53 ;
+54 ;railroad dob
+55 SET DIC=9000005
+56 IF $$ISREQ^AGFLDREQ(9000005,.2102)
SET DIE("NO^")=""
SET DR="2102R"
+57 IF '$TEST
SET DR="2102"
+58 DO ^AGDICLK
+59 WRITE ?49,"7.Date of Birth : "
+60 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+61 WRITE !
+62 ;cc on file
+63 SET DIC=9000005
SET DR=.15
+64 WRITE ?4,"8.CC on file : "
+65 DO ^AGDICLK
+66 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
+67 IF $GET(AG("LKPRINT"))["Y"
Begin DoDot:1
+68 ;date cc obtained
SET DIC=9000005
SET DR=.16
+69 WRITE ?28,"Date obtained: "
+70 DO ^AGDICLK
+71 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
End DoDot:1
+72 WRITE !!
+73 ;W ?5,"ELIG DATE BEGIN",?29,"(updated)",?48,"Coverage",?65,"ELIG END",!
+74 ;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",!
+75 FOR AG("CTR")=1:1:80
WRITE "."
+76 ;W !
ELIG ;
+1 ;REPLACE THIS OLD CODE
+2 ;S DIC=9000005.11
+3 ;S AG("TOTAL")=0
+4 ;S AG("N")=9
+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")+8
+15 ;W AGLINE("-")
+16 ;REPLACE OLD CODE
+17 ;BEGIN NEW CODE AG*7.1*3 IM23591
+18 ;THERE ARE 8 ITEMS IN DISPLAY ABOVE
SET AG("N")=8
+19 SET REC=0
+20 FOR CNT=1:1
SET REC=$ORDER(^AUPNRRE(AGPATDFN,11,REC))
IF 'REC
QUIT
Begin DoDot:1
+21 SET IENS=REC_","_AGPATDFN_","
+22 WRITE !,CNT+8,".",?6,$$GET1^DIQ(9000005.11,IENS,.01,"E")
+23 IF CNT=1
Begin DoDot:2
+24 IF $$GET1^DIQ(9000005,AGPATDFN_",",.07,"E")'=""
WRITE ?26,$$GET1^DIQ(9000005,AGPATDFN_",",.07,"E")
End DoDot:2
+25 WRITE ?43,$$GET1^DIQ(9000005.11,IENS,.03,"E")
+26 WRITE ?48,$$GET1^DIQ(9000005.11,IENS,.04,"E")
+27 WRITE ?68,$$GET1^DIQ(9000005.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 ;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS
+33 ;CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
+34 ;S:$G(AGSELECT)'="" AGSELECT=$$FINDRRE^AGINSUPD(AGSELECT)
+35 ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
IF '$GET(NEWENTRY)
IF ($GET(COMPIEN)'="")
SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$PIECE(AGSELECT,U,2))
+36 KILL MYERRS,MYVARS
+37 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+38 SET MYVARS("DFN")=$SELECT($GET(AUPNPAT)'="":AUPNPAT,1:$GET(DFN))
SET MYVARS("FINDCALL")="FINDRRE"
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+39 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+40 IF $DATA(AGSEENLY)
DO ^DIR
DO READ^AGED1
GOTO END
+41 IF $GET(NEWENTRY)
GOTO NONE
EDIT KILL DIR
+1 WRITE !
+2 IF $DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+3 SET DIR("A")="(Edit = ""E"" Add = ""A"" Delete = ""D"") Type E, A, or D"
End DoDot:1
+4 IF '$DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+5 SET DIR("A")="Edit = ""E"" Add = ""A"") Type E or A"
End DoDot:1
+6 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
+7 SET DIR(0)="FO"
+8 DO ^DIR
+9 IF $DATA(^XUSEC("AGZMGR",DUZ))&(Y="D")
GOTO KILL
+10 IF '$DATA(^XUSEC("AGZMGR",DUZ))&(Y="D")
GOTO EDIT
+11 IF $DATA(DTOUT)
QUIT
+12 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+13 IF Y=""
SET DLOUT=""
+14 IF Y="^"
SET (DUOUT,Y)=""
+15 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+16 IF Y="A"
GOTO L6
+17 WRITE !
+18 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)!($DATA(DIROUT))
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+19 IF Y'="E"&(Y'="A")&(Y'="D")
GOTO EDIT
L5 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
L5A IF Y="E"
Begin DoDot:1
+1 SET DIR("A")="Enter field number to edit"
+2 DO ^DIR
End DoDot:1
+3 IF Y=AGOPT("ESCAPE")
QUIT
+4 IF Y=""
GOTO VAR
+5 SET AG("SEL")=+Y
SET AG("INDEX")=+Y-8
+6 SET AGBILL=$$USED^AGED51(DFN,$PIECE($GET(^AUPNRRE(DFN,0)),U,2),4,AG("SEL")-8)
+7 IF $LENGTH(AGBILL)
Begin DoDot:1
+8 SET X="IORVON;IORVOFF"
+9 DO ENDR^%ZISS
DO HELP^XBHELP("USED","AGED51")
DO KILL^%ZISS
+10 KILL AGBILL
+11 IF '$$DIR^XBDIR("Y","Proceed with edit of Date Record","N")
GOTO VAR
End DoDot:1
+12 KILL AGBILL
+13 IF $DATA(DUOUT)!$DATA(DFOUT)
GOTO END
+14 IF $DATA(DQOUT)!(+$GET(Y)<1)!(+$GET(Y)>$GET(AG("N")))
WRITE !,"You must enter from 1 - ",$GET(AG("N"))
GOTO EDIT
+15 ;L6 I Y="A" S AG("EDIT")="" D:$P($G(^AUPNRRE(DFN,0)),U,3)="" E3^AGED61 D:$P($G(^AUPNRRE(DFN,0)),U,4)="" E4^AGED61 D ADDCOV^AG6,UPDATE1^AGED(DUZ(2),DFN,4,"") G VAR
L6 ;IHS/OIT/NKD AG*7.1*13
IF Y="A"
SET (AG("EDIT"),AG("COV"),COVTYP)=""
IF $$GETRRE^AGUTL(DFN)=""
DO E5^AGED61
DO ADDCOV^AG6
DO UPDATE1^AGED(DUZ(2),DFN,4,"")
GOTO VAR
L6A IF AG("SEL")<9
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 SET COMPIEN=AUPNPAT_",11,"_(AG(AG("SEL")-8))_",0"
+4 SET COVTYP=$PIECE($GET(@("^AUPNRRE("_COMPIEN_")")),U,3)
+5 IF COVTYP="D"
DO EN^AGED6PD(COMPIEN)
GOTO VAR
+6 ;END NEW CODE
+7 SET DIC=9000005.11
+8 IF $GET(AG(AG("SEL")-8))=""
SET Y="E"
WRITE !,"Use ""A"" to Add an eligibility date."
GOTO L5A
+9 FOR DR=.01,.03,.02
Begin DoDot:1
+10 SET AG("DRENT1")=$GET(AG(AG("SEL")-8))
+11 WRITE !,$SELECT(DR=.01:" 9. ELIGIBILITY DATE: ",DR=.03:"10. COVERAGE TYPE: ",DR=.02:"11. ELIG. END DATE : ")
+12 DO ^AGDICLK
+13 IF '$DATA(AG("LKERR"))
WRITE AG("LKPRINT")
End DoDot:1
L6B KILL DIR
+1 WRITE !!
+2 SET DIR("A")=" Change which? (9-11) "
+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 +$GET(Y)<9!(+$GET(Y)>11)
WRITE !,"Use the numbers 9, 10, or 11.",!
GOTO L6B
+14 SET AG("SEL")=+$GET(Y)
L7 DO ^AGED61
DO UPDATE1^AGED(DUZ(2),DFN,4,"")
+1 GOTO VAR
END ;EP
+1 IF $DATA(DTOUT)
SET AGTOUT=""
+2 IF '$DATA(AGSEENLY)
IF ('$ORDER(^AUPNRRE(DFN,11,0)))
SET DIK="^AUPNRRE("
SET DA=DFN
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 AG,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 DUOUT,DIROUT
QUIT
+9 KILL DIR
+10 QUIT
PRINT ;
+1 SET AG("DRENT1")=AG(AG("I"))
+2 ;elig date
+3 SET DIC=9000005.11
+4 SET DA=DFN
SET DR=.01
+5 DO ^AGDICLK
+6 WRITE AG("I")+8,".",?6,AG("LKPRINT")
+7 ;last updated
+8 ;S DIC=9000005
+9 ;S DA=DFN,DR=.07
+10 ;D ^AGDICLK
+11 ;I $G(AG("LKPRINT"))'="" W ?26,"("_AG("LKPRINT")_")"
+12 IF AG("I")=1
Begin DoDot:1
+13 SET DIC=9000005
+14 SET DA=DFN
SET DR=.07
+15 DO ^AGDICLK
+16 IF $GET(AG("LKPRINT"))'=""
WRITE ?26,"("_AG("LKPRINT")_")"
End DoDot:1
+17 ;END NEW CODE
+18 ;coverage type
+19 SET DIC=9000005.11
+20 SET AG("DRENT1")=AG(AG("I"))
SET DR=.03
+21 DO ^AGDICLK
+22 ;W ?41,$J(AG("LKPRINT"),11)
+23 ;IHS/SD/TPF 12/2/2005 AG*7.1*1
WRITE ?43,AG("LKPRINT")
+24 ;BEGIN NEW CODE ADD AG/SD/TPF 12/2/2005 AG*7.1*1
+25 ;DISPLAY PLAN NAME
+26 SET AG("DRENT1")=AG(AG("I"))
SET DR=.04
+27 DO ^AGDICLK
+28 WRITE ?48,$EXTRACT($GET(AG("LKPRINT")),1,18)
+29 ;END NEW CODE
+30 ;elig end date
+31 SET AG("DRENT1")=AG(AG("I"))
SET DR=.02
+32 DO ^AGDICLK
+33 ;W ?65,$J(AG("LKPRINT"),11),!
+34 ;IHS/SD/TPF 12/2/2005 AG*71.*1
WRITE ?68,AG("LKPRINT"),!
+35 QUIT
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=DFN
SET DIK="^AUPNRRE("
DO ^DIK
WRITE !!,"The COMPLETE eligibility record has been deleted"
HANG 2
GOTO END
+5 WRITE !!,"Delete which of these coverages? (9 - ",AG("I")+8,") "
DO READ^AGED1
IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)
GOTO END
+6 IF $DATA(DQOUT)!(+Y<9)!(+Y>(AG("I")+8))
WRITE !!,"To delete an eligibility record, enter a number from 9 to ",AG("I")+8,". (Press RETURN for ""NO DELETE"".)"
DO READ^AGED1
GOTO KILL
+7 KILL DIR
+8 SET DA(1)=DFN
SET AG("COUNT")=0
SET AG("SEL")=0
SET AG("DELELIG")=0
+9 FOR
SET AG("SEL")=$ORDER(^AUPNRRE(DA(1),11,AG("SEL")))
IF AG("COUNT")>(Y-8)
QUIT
Begin DoDot:1
+10 SET AG("COUNT")=AG("COUNT")+1
+11 IF AG("COUNT")=(Y-8)
SET AG("DELELIG")=AG("SEL")
End DoDot:1
+12 KILL AG("SEL"),AG("COUNT")
+13 IF +Y>8&(+Y<(AG("I")+8)+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 ;I $P($G(^AUPNMCR(AGPATDFN,11,AG("I"),0)),U,3)="" D G VAR ;IHS/OIT/NKD AG*7.1*13 BUG FIX
+18 IF $PIECE($GET(^AUPNRRE(DA(1),11,AG("I"),0)),U,3)=""
Begin DoDot:1
+19 WRITE !,"COVERAGE TYPE FIELD IS NOT POPULATED"
+20 WRITE !,"AN UPDATE TO NPIRS CAN NOT BE DONE PROPERLY"
+21 WRITE !,"UNLESS THIS FIELD IS POPULATED"
+22 KILL DIR
+23 SET DIR(0)="E"
+24 DO ^DIR
End DoDot:1
GOTO VAR
+25 DO PATCH
+26 SET DA(1)=DFN
SET DA=AG("I")
SET DIK="^AUPNRRE("_DA(1)_",11,"
+27 DO ^DIK
+28 WRITE !!,"That eligibility record is deleted."
HANG 2
+29 GOTO VAR
PATCH DO NOW^%DTC
SET AGDTS=%
+1 IF '$DATA(^AGPATCH(AGDTS,DUZ(2),DFN))
SET ^(DFN)=""
+2 IF '$DATA(^AUPNRRE(DFN,11,0))
QUIT
IF '$ORDER(^AUPNRRE(DFN,11,0))
QUIT
+3 IF $PIECE($GET(^AUPNRRE(DFN,11,AG("I"),0)),U,3)=""
QUIT
+4 ;S ^AGPATCH(AGDTS,DUZ(2),DFN,$P(^AUPNRRE(DFN,11,AG("I"),0),U,3))="RROAD^"_$P($G(^AUPNRRE(DFN,0)),U,3,4)_U_$G(^AUPNRRE(DFN,11,AG("I"),0)) ;IHS/OIT/NKD AG*7.1*13
+5 SET ^AGPATCH(AGDTS,DUZ(2),DFN,$PIECE(^AUPNRRE(DFN,11,AG("I"),0),U,3))="RROAD^"_$$GETRRE^AGUTL(DFN)_U_$GET(^AUPNRRE(DFN,11,AG("I"),0))
+6 IF $PIECE($GET(^AUPNRRE(DFN,11,AG("I"),0)),U,2)=""
SET $PIECE(^AGPATCH(AGDTS,DUZ(2),DFN,$PIECE(^AUPNRRE(DFN,11,AG("I"),0),U,3)),U,5)=DT
+7 KILL AGDTS
QUIT
AGREASON ;
+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
