AGED5 ; IHS/ASDS/EFG -EDIT PAGE 5 (mcd) ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
OPTION ;
Q:AGOPT(4)'="Y"&$D(AGSEENLY)
I AGOPT(4)'="Y" G END
VAR ;EP
S AG("PG")=5
I '$D(AGSEENLY) D
. I $D(AGADDINS),AGADDINS="E" G HDR
. S AG("EDIT")="" D ADDNEW^AG5 Q
Q:$D(DTOUT)!$D(DUOUT)!$D(DFOUT)!$D(DLOUT)
I $D(AGDELETE) K AGDELETE Q
HDR ;
I $P($G(^AUPNMCD(AGELPTR,0)),U,4)="" S AG("STPTR")="" D STATE^AG5 K AG("STPTR")
W $$S^AGVDF("IOF"),!
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?36,"MEDICAID"
W ?80-$L($P(^DIC(4,DUZ(2),0),U)),$P(^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")
K AG("EDIT")
K DIR,DA,D0,AG("MCD")
G L2:$D(^AUPNMCD("AB",DFN))
Q:$D(AGSEENLY)
W !!
S DIR("A")="Do you wish to add MEDICAID? (Y/N) NO// "
D READ^AGED1
K DIR
G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
Q:$D(DTOUT)!$D(DFOUT) I $D(DQOUT)!(Y'["Y") D YN^AG H 2 G VAR
I '$D(^AUPNMCD("AB",DFN)) D
. S AG("EDIT")=""
. D ADDNEW^AG5
. G VAR
L2 K AG("TOT")
S (AG("TOT"),AG("STATE"))=0
W !?3,"STATE NUMBER"
W ?27,"(updated) ELIG DATE COVERAGE ELIG END"
W !,AGLINE("-")
L3 S AG("STATE")=$P($G(^AUPNMCD(AGELPTR,0)),U,4)
G L4:AG("STATE")=""
S AG("TOT")=1
L3A W !,"1.",?4,$P($G(^DIC(5,AG("STATE"),0)),U,2),?9,$P($G(^AUPNMCD(AGELPTR,0)),U,3)
I $D(^AUPNMCD(AGELPTR,0)),$P($G(^AUPNMCD(AGELPTR,0)),U,8)]"" D
. S Y=$P($G(^AUPNMCD(AGELPTR,0)),U,8)
. D DD^%DT
. W ?25,"(",Y,")"
L3B S DIC=9000004.11,DA=AGELPTR
F AG("I")=1:1 Q:$D(AG("LKERR")) D
.S DR=.01,AG("DRENT")=AG("I")
.D ^AGDICLK
.Q:$D(AG("LKERR"))
.W ?37,"2. "
.W:AG("I")>1 !
.W ?40,AG("LKPRINT"),?58,$P(@AGL,U,3)
.S DR=.02,AG("DRENT")=AG("I")
.D ^AGDICLK
.W:$D(AG("LKPRINT")) ?66,AG("LKPRINT")
S DA=AGELPTR,DIC=9000004,DR=2101
D ^AGDICLK
W !!,"3. ","MEDICAID NAME: ",$G(AG("LKPRINT"))
S DA=DFN,DIC=2,DR=.03
D ^AGDICLK
S AGDOB="UNKNOWN"
I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AGDOB=AG("LKPRINT")
S DA=AGELPTR,DIC=9000004,DR=2102
D ^AGDICLK
I $D(AG("LKPRINT")),AG("LKPRINT")="" S AG("LKPRINT")=AGDOB
I '$D(AG("LKPRINT")) S AG("LKPRINT")=AGDOB
K AGDOB
W ?44,"4. ","MED. DATE OF BIRTH: ",AG("LKPRINT")
S DA=AGELPTR,DIC=9000004,DR=.14
D ^AGDICLK
W !,"5. ","PRIM CARE PROV: ",AG("LKPRINT")
;ADD GROUP NAME AND #
W !,"6. ","GROUP NAME: ",?44,"GROUP NUMBER: "
S DIQ="AG(",DIQ(0)="E"
S DIC="^AUPNMCD(",DR=".11;.12"
D EN^DIQ1
K DIQ
W !,"7. ","PLAN NAME: ",AG(9000004,DA,.11,"E")
W !,"8. ","RATE CODE: ",AG(9000004,DA,.12,"E")
S DIC=9000004
S DA=AGELPTR,DR=.15
D ^AGDICLK
W !,"9. ","CC ON FILE: ",AG("LKPRINT")
I $G(AG("LKPRINT"))'="" D
.S DIC=9000004
.S DA=AGELPTR,DR=.16
.D ^AGDICLK
.W ?28,"DATE: ",AG("LKPRINT")
W !,AGLINE("-")
D VERIF^AGUTILS
W !,AGLINE("EQ")
L4 ;
I $D(AGSEENLY) D ^DIR,READ^AGED1 G END
I $D(^XUSEC("AGZMGR",DUZ)) D
.S DIR("A")="ENTER ACTION (<E>dit Data,<D>elete):"
I '$D(^XUSEC("AGZMGR",DUZ)) D
.S DIR("A")="ENTER ACTION (<E>dit Data):"
D READ
I $D(^XUSEC("AGZMGR",DUZ))&(Y="D") G DELETE
G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
G L6:Y?1"Y".E,END:$D(DLOUT)!(Y?1"N".E)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
Q:$D(DFOUT)!$D(AG("EDIT"))
I Y?1U&("EA"[Y) G L6:Y="A",EDIT
G L4:Y'="E"!(Y'="A")!(Y'="D")
W *7 G VAR
L6 S AG("EDIT")=""
G VAR
DELETE S:AG("TOT")=1 Y=1
S DIR("A")="Are you sure you want to DELETE this record ? (Y/N) "
S DIR(0)="Y"
S DIR("B")="NO"
D ^DIR
I Y'=1 K DIR G END
G DELETE1:AG("TOT")=1
DELETE1 S AG("SUBSCRPT")="MCD0",AGNXTSUB="MCD1"
D NOW^%DTC
S AGDTS=%
I $D(^AGPATCH(AGDTS,DUZ(2),DFN,"MCD1")) D
. F AGZ("I")=1:1 Q:AGNXTSUB="" D
.. S AG("SUBSCRPT")=AGNXTSUB
.. S AGNXTSUB=$O(^AGPATCH(AGDTS,DUZ(2),DFN,AGNXTSUB))
S AG("SUBSCRPT")="MCD"_($E(AG("SUBSCRPT"),4,6)+1)
S DA=$O(^AUPNMCD(AGELPTR,11,0))
S:'$D(^AGPATCH(AGDTS,DUZ(2),DFN)) ^(DFN)=""
S ^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))="MCAID^"_$P(^AUPNMCD(AGELPTR,0),U,3,4)
I DA]"" D
. S ^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))=^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))_U_^AUPNMCD(AGELPTR,11,DA,0)
. S:$P(^AUPNMCD(AGELPTR,11,DA,0),U,2)="" $P(^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT")),U,5)=DT
K AGNXTSUB,AG("SUBSCRPT")
S DA=AGELPTR,DR=".01///@",DIE="^AUPNMCD(" D ^DIE W !!!,"The account is deleted.",!,"Press RETURN to continue..." R X:DTIME
S AGDELETE="" Q
EDIT ;
K DIR
EDIT1 ;
S AG("MCD")=AGELPTR
S AG("STATE")=$P(^AUPNMCD(AG("MCD"),0),U,4)
S AG("MNUM")=$P(^AUPNMCD(AG("MCD"),0),U,3)
G EDIT^AGED51
END I $D(DTOUT) S AGTOUT=""
K AG,DA,DIC,DR,DRENT,AG("DRENT1")
K AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AGNUM,AG("STATE")
K AG("MCD")
K Y,AGDTS
Q:$D(AGXTERN)
I $D(DIROUT)!$D(DUOUT) K DIROUT,DUOUT Q
Q
READ ;
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
S DIR(0)="FO"
D ^DIR
Q:$D(DTOUT)
S:Y="/.,"!(Y="^^") DFOUT=""
S:Y="" DLOUT=""
S:Y="^" (DUOUT,Y)=""
S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
Q
UPDATE ;EP
S DA=AG("MCD")
S DR=".08///"_DT
S DIE="^AUPNMCD("
D ^DIE
D UPDATE1^AGED(DUZ(2),DFN,5,DA)
Q
AGED5 ; IHS/ASDS/EFG -EDIT PAGE 5 (mcd) ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
OPTION ;
+1 IF AGOPT(4)'="Y"&$DATA(AGSEENLY)
QUIT
+2 IF AGOPT(4)'="Y"
GOTO END
VAR ;EP
+1 SET AG("PG")=5
+2 IF '$DATA(AGSEENLY)
Begin DoDot:1
+3 IF $DATA(AGADDINS)
IF AGADDINS="E"
GOTO HDR
+4 SET AG("EDIT")=""
DO ADDNEW^AG5
QUIT
End DoDot:1
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DFOUT)!$DATA(DLOUT)
QUIT
+6 IF $DATA(AGDELETE)
KILL AGDELETE
QUIT
HDR ;
+1 IF $PIECE($GET(^AUPNMCD(AGELPTR,0)),U,4)=""
SET AG("STPTR")=""
DO STATE^AG5
KILL AG("STPTR")
+2 WRITE $$S^AGVDF("IOF"),!
+3 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+4 WRITE ?36,"MEDICAID"
+5 WRITE ?80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U)),$PIECE(^DIC(4,DUZ(2),0),U)
+6 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+7 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+8 WRITE !,AGLINE("EQ")
+9 WRITE !,$EXTRACT(AGPAT,1,23)
+10 WRITE ?23,$$DTEST^AGUTILS(DFN)
+11 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+12 ;GET ELIGIBILITY STATUS
+13 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+14 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+15 WRITE !,AGLINE("EQ")
+16 KILL AG("EDIT")
+17 KILL DIR,DA,D0,AG("MCD")
+18 IF $DATA(^AUPNMCD("AB",DFN))
GOTO L2
+19 IF $DATA(AGSEENLY)
QUIT
+20 WRITE !!
+21 SET DIR("A")="Do you wish to add MEDICAID? (Y/N) NO// "
+22 DO READ^AGED1
+23 KILL DIR
+24 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+25 IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+26 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
IF $DATA(DQOUT)!(Y'["Y")
DO YN^AG
HANG 2
GOTO VAR
+27 IF '$DATA(^AUPNMCD("AB",DFN))
Begin DoDot:1
+28 SET AG("EDIT")=""
+29 DO ADDNEW^AG5
+30 GOTO VAR
End DoDot:1
L2 KILL AG("TOT")
+1 SET (AG("TOT"),AG("STATE"))=0
+2 WRITE !?3,"STATE NUMBER"
+3 WRITE ?27,"(updated) ELIG DATE COVERAGE ELIG END"
+4 WRITE !,AGLINE("-")
L3 SET AG("STATE")=$PIECE($GET(^AUPNMCD(AGELPTR,0)),U,4)
+1 IF AG("STATE")=""
GOTO L4
+2 SET AG("TOT")=1
L3A WRITE !,"1.",?4,$PIECE($GET(^DIC(5,AG("STATE"),0)),U,2),?9,$PIECE($GET(^AUPNMCD(AGELPTR,0)),U,3)
+1 IF $DATA(^AUPNMCD(AGELPTR,0))
IF $PIECE($GET(^AUPNMCD(AGELPTR,0)),U,8)]""
Begin DoDot:1
+2 SET Y=$PIECE($GET(^AUPNMCD(AGELPTR,0)),U,8)
+3 DO DD^%DT
+4 WRITE ?25,"(",Y,")"
End DoDot:1
L3B SET DIC=9000004.11
SET DA=AGELPTR
+1 FOR AG("I")=1:1
IF $DATA(AG("LKERR"))
QUIT
Begin DoDot:1
+2 SET DR=.01
SET AG("DRENT")=AG("I")
+3 DO ^AGDICLK
+4 IF $DATA(AG("LKERR"))
QUIT
+5 WRITE ?37,"2. "
+6 IF AG("I")>1
WRITE !
+7 WRITE ?40,AG("LKPRINT"),?58,$PIECE(@AGL,U,3)
+8 SET DR=.02
SET AG("DRENT")=AG("I")
+9 DO ^AGDICLK
+10 IF $DATA(AG("LKPRINT"))
WRITE ?66,AG("LKPRINT")
End DoDot:1
+11 SET DA=AGELPTR
SET DIC=9000004
SET DR=2101
+12 DO ^AGDICLK
+13 WRITE !!,"3. ","MEDICAID NAME: ",$GET(AG("LKPRINT"))
+14 SET DA=DFN
SET DIC=2
SET DR=.03
+15 DO ^AGDICLK
+16 SET AGDOB="UNKNOWN"
+17 IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AGDOB=AG("LKPRINT")
+18 SET DA=AGELPTR
SET DIC=9000004
SET DR=2102
+19 DO ^AGDICLK
+20 IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")=""
SET AG("LKPRINT")=AGDOB
+21 IF '$DATA(AG("LKPRINT"))
SET AG("LKPRINT")=AGDOB
+22 KILL AGDOB
+23 WRITE ?44,"4. ","MED. DATE OF BIRTH: ",AG("LKPRINT")
+24 SET DA=AGELPTR
SET DIC=9000004
SET DR=.14
+25 DO ^AGDICLK
+26 WRITE !,"5. ","PRIM CARE PROV: ",AG("LKPRINT")
+27 ;ADD GROUP NAME AND #
+28 WRITE !,"6. ","GROUP NAME: ",?44,"GROUP NUMBER: "
+29 SET DIQ="AG("
SET DIQ(0)="E"
+30 SET DIC="^AUPNMCD("
SET DR=".11;.12"
+31 DO EN^DIQ1
+32 KILL DIQ
+33 WRITE !,"7. ","PLAN NAME: ",AG(9000004,DA,.11,"E")
+34 WRITE !,"8. ","RATE CODE: ",AG(9000004,DA,.12,"E")
+35 SET DIC=9000004
+36 SET DA=AGELPTR
SET DR=.15
+37 DO ^AGDICLK
+38 WRITE !,"9. ","CC ON FILE: ",AG("LKPRINT")
+39 IF $GET(AG("LKPRINT"))'=""
Begin DoDot:1
+40 SET DIC=9000004
+41 SET DA=AGELPTR
SET DR=.16
+42 DO ^AGDICLK
+43 WRITE ?28,"DATE: ",AG("LKPRINT")
End DoDot:1
+44 WRITE !,AGLINE("-")
+45 DO VERIF^AGUTILS
+46 WRITE !,AGLINE("EQ")
L4 ;
+1 IF $DATA(AGSEENLY)
DO ^DIR
DO READ^AGED1
GOTO END
+2 IF $DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+3 SET DIR("A")="ENTER ACTION (<E>dit Data,<D>elete):"
End DoDot:1
+4 IF '$DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+5 SET DIR("A")="ENTER ACTION (<E>dit Data):"
End DoDot:1
+6 DO READ
+7 IF $DATA(^XUSEC("AGZMGR",DUZ))&(Y="D")
GOTO DELETE
+8 IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+9 IF Y?1"Y".E
GOTO L6
IF $DATA(DLOUT)!(Y?1"N".E)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+10 IF $DATA(DFOUT)!$DATA(AG("EDIT"))
QUIT
+11 IF Y?1U&("EA"[Y)
IF Y="A"
GOTO L6
GOTO EDIT
+12 IF Y'="E"!(Y'="A")!(Y'="D")
GOTO L4
+13 WRITE *7
GOTO VAR
L6 SET AG("EDIT")=""
+1 GOTO VAR
DELETE IF AG("TOT")=1
SET Y=1
+1 SET DIR("A")="Are you sure you want to DELETE this record ? (Y/N) "
+2 SET DIR(0)="Y"
+3 SET DIR("B")="NO"
+4 DO ^DIR
+5 IF Y'=1
KILL DIR
GOTO END
+6 IF AG("TOT")=1
GOTO DELETE1
DELETE1 SET AG("SUBSCRPT")="MCD0"
SET AGNXTSUB="MCD1"
+1 DO NOW^%DTC
+2 SET AGDTS=%
+3 IF $DATA(^AGPATCH(AGDTS,DUZ(2),DFN,"MCD1"))
Begin DoDot:1
+4 FOR AGZ("I")=1:1
IF AGNXTSUB=""
QUIT
Begin DoDot:2
+5 SET AG("SUBSCRPT")=AGNXTSUB
+6 SET AGNXTSUB=$ORDER(^AGPATCH(AGDTS,DUZ(2),DFN,AGNXTSUB))
End DoDot:2
End DoDot:1
+7 SET AG("SUBSCRPT")="MCD"_($EXTRACT(AG("SUBSCRPT"),4,6)+1)
+8 SET DA=$ORDER(^AUPNMCD(AGELPTR,11,0))
+9 IF '$DATA(^AGPATCH(AGDTS,DUZ(2),DFN))
SET ^(DFN)=""
+10 SET ^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))="MCAID^"_$PIECE(^AUPNMCD(AGELPTR,0),U,3,4)
+11 IF DA]""
Begin DoDot:1
+12 SET ^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))=^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT"))_U_^AUPNMCD(AGELPTR,11,DA,0)
+13 IF $PIECE(^AUPNMCD(AGELPTR,11,DA,0),U,2)=""
SET $PIECE(^AGPATCH(AGDTS,DUZ(2),DFN,AG("SUBSCRPT")),U,5)=DT
End DoDot:1
+14 KILL AGNXTSUB,AG("SUBSCRPT")
+15 SET DA=AGELPTR
SET DR=".01///@"
SET DIE="^AUPNMCD("
DO ^DIE
WRITE !!!,"The account is deleted.",!,"Press RETURN to continue..."
READ X:DTIME
+16 SET AGDELETE=""
QUIT
EDIT ;
+1 KILL DIR
EDIT1 ;
+1 SET AG("MCD")=AGELPTR
+2 SET AG("STATE")=$PIECE(^AUPNMCD(AG("MCD"),0),U,4)
+3 SET AG("MNUM")=$PIECE(^AUPNMCD(AG("MCD"),0),U,3)
+4 GOTO EDIT^AGED51
END IF $DATA(DTOUT)
SET AGTOUT=""
+1 KILL AG,DA,DIC,DR,DRENT,AG("DRENT1")
+2 KILL AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AGNUM,AG("STATE")
+3 KILL AG("MCD")
+4 KILL Y,AGDTS
+5 IF $DATA(AGXTERN)
QUIT
+6 IF $DATA(DIROUT)!$DATA(DUOUT)
KILL DIROUT,DUOUT
QUIT
+7 QUIT
READ ;
+1 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,DIROUT
+2 SET DIR(0)="FO"
+3 DO ^DIR
+4 IF $DATA(DTOUT)
QUIT
+5 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+6 IF Y=""
SET DLOUT=""
+7 IF Y="^"
SET (DUOUT,Y)=""
+8 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+9 QUIT
UPDATE ;EP
+1 SET DA=AG("MCD")
+2 SET DR=".08///"_DT
+3 SET DIE="^AUPNMCD("
+4 DO ^DIE
+5 DO UPDATE1^AGED(DUZ(2),DFN,5,DA)
+6 QUIT
