AGED1 ; IHS/ASDS/EFG - EDIT PG 1 - ELIG/IDENTIFIERS ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**2,4,5,7,8,12**;AUG 25, 2005;Build 1
;
;AG*7.1*7 - Modified code to allow the new page 10 to be called
;IHS/OIT/NKD AG*7.1*12 PATIENT RESIDENCE
;
I "YC"[AGOPT(14) S AG("SVELIG")=""
S AG("SVELIG")=$P($G(^AUPNPAT(DFN,11)),U,12)
N OLDST,NEWST,OLDADDR2,NEWADDR2,OLDADDR3,NEWADDR3,OLDCITY,NEWCITY,OLDSTATE ;AG*7.1*4
N NEWSTATE,OLDZIP,NEWZIP,OLDHPH,NEWHPH,TEMPY ;AG*7.1*4
;
VAR ;EP
Q:'$D(^DPT(DFN,0))
S AG("PG")=1
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
S AGPAT=$P($G(^DPT(DFN,0)),U)
S AGCHRT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:"xxxxx")
S AG("AUPN")=""
S:$D(^AUPNPAT(DFN,0)) AG("AUPN")=^(0)
W ?36,$$DTEST^AGUTILS(DFN)
S AGLINE("-")=$TR($J(" ",78)," ","-")
S AGLINE("EQ")=$TR($J(" ",78)," ","=")
S $P(AGLINE("PGLN"),"=",81)=""
VAR2 ;
D DRAW
W:'$D(AGSEENLY) !,AGLINE("PGLN")
Q:$D(AGSEENLY)
SSNA ;Ver=add ask if patient has verified SSN
I $P($G(^AUPNPAT(DFN,0)),U,23)]"",$D(^AUTTSSN($P(^(0),U,23),0)),"A"[$P($G(^(0)),U) D
. W !!,*7
. K DIR
. S DIR(0)="Y"
. S DIR("A")="Has the patient verified the SSN added by SSA "
. S DIR("B")="NO"
. D ^DIR
. K DIR
. Q:Y=0
. K DR
. S DIE="^AUPNPAT("
. S DA=DFN
. S DR=".23///V"
. D ^DIE
. K DR
ESSNA . D DRAW
D CKELIG:"YC"[AGOPT(14)
K DIR
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-"_AG("N")_") NONE//" D READ
I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
S TEMPY=Y I +Y'=Y D ASKADD^AG3A S Y=TEMPY K TEMPY ;AG*7.1*4
Q:Y=AGOPT("ESCAPE")
Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)
G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
G END:$D(DLOUT)!(Y["N"),VAR:$D(AG("ERR"))
I $D(DQOUT)!(+Y<1)!(+Y>AG("N"))&($P($G(^AUPNPAT(DFN,11)),U,12)'="") W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH"
;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH,WEB" ;AG*7.1*2 ITEM 5 PAGE 11
;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,LOC,ALLADDR^AG3A,OPH^AG3A,MSGPH,WEB,EDEMAIL" ;AG*7.1*4
;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH,EDEMAIL" ;AG*7.1*7
;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH" ;AG*7.1*8
S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,PRES^AG3A,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH" ;AG*7.1*12
I '$D(AGSEENLY) D C
G VAR
END ;
K AG,DA,DIC,DR,DUOUT,DLOUT,DQOUT,DTOUT,DFOUT,AGSCRN,Y,DIR,ROUTID
Q:$D(AGXTERN)
I $P($G(^AUPNPAT(DFN,11)),U,12)="" W *7,!!,"Eligibility Status must be entered." H 2 G VAR
G ^AGED2
READ ;EP
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),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)=""
S X=Y,Y=$$UP^XLFSTR(X)
Q:Y="P"
I $E(Y,1)="p" S $E(Y,1)="P"
I $E(Y,1)="P"&($P($G(^AUPNPAT(DFN,11)),U,12)'="") D
. S AG("ED")=+$P($E(Y,2,99),".")
. I AG("ED")<1!(AG("ED")>10) D ;AG*7.1*7
.. W *7,!!,"Use only pages 1 through 10." ;AG*7.1*7
.. H 2
.. K AG("ED")
.. S AG("ERR")=""
. I $D(AG("ED")) D
.. I AG("ED")>0&(AG("ED")<11) D ;AG*7.1*7
... I AG("ED")=4 S AG("ED")="4A"
... I AG("ED")=5 S AG("ED")="BEA" ;REPLACE OLD PG 5A WITH BENEFITS COORD SCREEN
... I AG("ED")=6 S AG("ED")=13
... I AG("ED")=8 S AG("ED")=11
... I AG("ED")=7 S AG("ED")=8
... I AG("ED")=9 S AG("ED")="11A"
... I AG("ED")=10 S AG("ED")="10A" ;AG*7.1*7
I $E(Y,1)="P"&($P($G(^AUPNPAT(DFN,11)),U,12)="") D
. W *7,!!,"Eligibility Status must be entered." H 2
Q
C ;EP - Edit multiple fields on a Reg edit page.
S AGY=Y
F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N")) D @($P(AG("C"),",",AG("SEL")))
D UPDATE1^AGED(DUZ(2),DFN,1,"")
K AGI,AGY
EC ;
Q
MSTAT ;GET MARITAL STATUS FROM VA PATIENT FILE
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.05
D ^DIE
S:$D(Y) DUOUT=""
K DIC("S"),DIC("W"),DIC("A"),DIC("B")
Q
ADDR2 ;GET ADDRESS LINE 2 FROM VA PATIENT FILE
S OLDADDR2=$$GET1^DIQ(2,DFN_",",.112) ;AG*7.1*4
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.112
D ^DIE
S:$D(Y) DUOUT=""
K DIC("S"),DIC("W"),DIC("A"),DIC("B")
S NEWADDR2=$$GET1^DIQ(2,DFN_",",.112) ;AG*7.1*4
Q
ADDR3 ;GET ADDRESS LINE 3 FROM VA PATIENT FILE
S OLDADDR3=$$GET1^DIQ(2,DFN_",",.113) ;AG*7.1*4
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.113
D ^DIE
S:$D(Y) DUOUT=""
K DIC("S"),DIC("W"),DIC("A"),DIC("B")
S NEWADDR3=$$GET1^DIQ(2,DFN_",",.113) ;AG*7.1*4
Q
LOC ;GET LOCATION OF HOME FROM PATIENT FILE
K DUOUT
S DIE="^AUPNPAT("
S DA=DFN
S DR=1201
D ^DIE
S:$D(Y) DUOUT=""
K DIC("S"),DIC("W"),DIC("A"),DIC("B")
Q
MSGPH ;GET MESSAGE PHONE FROM PATIENT FILE
K DUOUT
S DIE="^AUPNPAT("
S DA=DFN
S DR=1801
D ^DIE
S:$D(Y) DUOUT=""
K DIC
Q
;AG*7.1*8 - Entire tag reworked to handle new multiple field
WEB ;EP - INTERNET ACCESS QUESTION
N DIC,DA,DIC,X,Y,OIEN,NIEN
;
;Get latest entry ien
S OIEN=$O(^AUPNPAT(DFN,81,"B"),-1)
;
;Define new entry and save
S DIC="^AUPNPAT("_DFN_",81,",DA(1)=DFN
S DIC(0)="L"
S X=DT
S DLAYGO="9000001.81",DIC("P")=DLAYGO
I '$D(^AUPNPAT(DFN,81,0)) S ^AUPNPAT(DFN,81,0)="^9000001.81D^^"
K DO,DD D FILE^DICN
K DIC,DA,DIC,X
Q:+Y<1
;
;Copy existing entry into current one
I OIEN]"" M ^AUPNPAT(DFN,81,+Y)=^AUPNPAT(DFN,81,OIEN)
;
N DIE,DIR,DIC,DA,DR
S (NIEN,DA)=+Y
S DA(1)=DFN
S DIE="^AUPNPAT("_DA(1)_",81,"
S DEF=$$GET1^DIQ(9000001.81,NIEN_","_DFN_",",.02,"Y")
S DR=.02 S:DEF]"" DR=DR_"//"_DEF
D ^DIE
K DIE,DIR,DIC,DA,DR
;
;If No Internet Access, Remove the Where value
I '$P($G(^AUPNPAT(DFN,81,NIEN,0)),U,2) D Q
. N AGVAR,ERROR,WIEN
. S AGVAR(9000001.81,NIEN_","_DFN_",",".03")="@"
. S WIEN=0 F S WIEN=$O(^AUPNPAT(DFN,81,NIEN,1,WIEN)) Q:'WIEN D
.. S AGVAR(9000001.811,WIEN_","_NIEN_","_DFN_",",.01)="@"
. D FILE^DIE("","AGVAR","ERROR")
;
N DIE,DIR,DIC,DR,DA
S DA(1)=DFN,DA=NIEN
S DIE="^AUPNPAT("_DA(1)_",81,"
S DR=".04"
D ^DIE
;
Q
;
;NEW CODE AG*7.1*4
EDEMAIL ;EP - EDIT CURRENT EMAIL ADDRESS
W !!
N OLDEMAIL
S OLDEMAIL=$$GET1^DIQ(9000001,DFN_",",1802)
K DIE,DIC,DR,DA,DIR
S DIE="^AUPNPAT("
S DA=DFN
S DR=1802
D ^DIE
Q:$D(Y)
Q:$$GET1^DIQ(9000001,DFN_",",1802)=""
Q:OLDEMAIL=$$GET1^DIQ(9000001,DFN_",",1802) ;NO CHANGE
K DIR
S DIR(0)="Y"
S DIR("A")="Should this new email address be added to the historical addresses"
S DIR("B")="Y"
D ^DIR
Q:'Y!$D(DTOUT)!$D(DUOUT)
W !!,"Adding to PREVIOUS EMAIL FIELD...." H 2
D UPDTEMAL^AGUTILS(DFN)
;END NEW CODE
Q
;
QUES ;EP
W !!,"To change an item, enter a number from 1 to ",AG("N")
W ". (Press RETURN for ""NO-CHANGE"".)"
D READ
Q
CKELIG ;EP
I $D(^AUPNPAT(DFN,11)),$P($G(^(11)),U,12)'=AG("SVELIG") D Q
. S AG("SVELIG")=$P($G(^AUPNPAT(DFN,11)),U,12)
. D CALCELIG^AGBIC2
. W *7,!,"This patient's Eligibility has been changed to "
. W $P(AG("NARR1"),":",2)
Q
DRAW ;DRAW PAGE 1
S AG("PG")=1
S AG("N")=19 ;AG*7.1*8/AG*7.1*12
S DA=DFN
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
D ^AGED
K ^UTILITY("DIQ1",$J)
;OUTPUT OPTION NUMBER,FIELD NAME, AND DATA
F AG=1:1:AG("N") D
. S AGSCRN=$P($T(@1+AG),";;",2,19)
. S DIC=$P(AGSCRN,U,3) ;FILE NUMBER
. S DR=$P(AGSCRN,U,4) ;FIELD NUMBER
. I AG'=4&(AG'=14)&(AG'=18)&(AG'=15) W ?1,AG,".",?(27-$L($P($G(^DD(DIC,DR,0)),U))),$P($G(^DD(DIC,DR,0)),U)," : " ;AG*7.1*4/AG*7.1*12
. I AG=18 W ?45,AG,".",$P(AGSCRN,U)," : " ;AG*7.1*2 ITEM 5 PAGE 11/AG*7.1*12
. I AG=4 W " ",AG,".",$P(AGSCRN,U)," : "
. I AG=14 W " ",AG,".",$P(AGSCRN,U)," : " ;AG*7.1*12
. ;I AG=14 W ?54,AG,". ZIP CODE : " ;AG*7.1*4
. I AG=15 W ?($S($D(DPTFLAG):58,1:56)),AG,".ZIP",$S($D(DPTFLAG):"+4",1:" CODE")," : " S:$D(DPTFLAG) DR=.1112 ;AG*7.1*5 H4532/AG*7.1*12
. ;DISPLAY MSG BELOW IF THERE ARE DIRECTIONS TO PATIENT'S HOME
. I AG=16&($D(^AUPNPAT(DFN,12,1,0))) D ;AG*7.1*12
.. I '$D(AGSEENLY) W "LOCATION OF HOME CONTAINS DATA"
.. I $D(AGSEENLY) D
... S HOME=$P($G(^AUPNPAT(DFN,12,1,0)),U)
... S AG("Y")=$L(HOME),LNCNT=0
... F S AG("K")=$E(HOME,1,49) Q:$L(AG("K"))=0 D
.... S HOME=$E(HOME,50,AG("Y"))
.... I LNCNT>0 W !
.... W ?30,AG("K")
.... S LNCNT=LNCNT+1
... K HOME,AG("Y"),AG("K"),LNCNT
. I AG'=16&(AG'=4)&(AG'=14) D ;AG*7.1*12
.. K AGRES
.. S TEMPDIC=DIC
.. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
.. S DIC=TEMPDIC
.. ;W $G(AGRES(DIC,DFN,DR,"E"))
.. ;BEGIN NEW CODE FOR ABOVE LINE IHS/SD/TPF AG*7.1*4
.. N HIT
.. D EN^AGSECCHK("AGZVIEWSSN",.HIT)
.. I DIC=2,(DR=.09) D
... I HIT="Y" W $$GET1^DIQ(2,DFN_",",.09) Q
... I ($$GET1^DIQ(9000001,DFN_",",.23,"E")="V") W $$GET1^DIQ(9000001,DFN_",",1107.3)
... E W $$GET1^DIQ(2,DFN_",",.09)
.. E W $G(AGRES(DIC,DFN,DR,"E"))
.. ;END NEW CODE
.. K AGRES,TEMPDIC,AGRES
. ;I AG=19 W !?1,AG,"." W ?15,"EMAIL ADDRESS: ",$$GET1^DIQ(9000001,DFN_",",1802)
. I AG=4 D
.. K AGRES
.. S TEMPDIC=DIC
.. S DIQ="AGRES",DIQ(0)="I" D EN^DIQ1
.. S DIC=TEMPDIC
.. I $G(AGRES(DIC,DFN,DR,"I"))'="" W $P($G(^DIC(5,$G(AGRES(DIC,DFN,DR,"I")),0)),U,2)
.. K AGRES,TEMPDIC,AGRES
. I AG=14 D ;AG*7.1*12
.. K AGRES
.. S TEMPDIC=DIC
.. S DIQ="AGRES",DIQ(0)="I" D EN^DIQ1
.. S DIC=TEMPDIC
.. I $G(AGRES(DIC,DFN,DR,"I"))'="" W $P($G(^DIC(5,$G(AGRES(DIC,DFN,DR,"I")),0)),U,2)
.. K AGRES,TEMPDIC,AGRES
. ;SHOW SSN VERIFICATION STATUS NEXT TO THE SSN FIELD
. I AG=6 D
.. I $P($G(^DPT(DFN,0)),U,9)="" D
... S AGSSNCHK=$P($G(^AUPNPAT(DFN,0)),U,24)
... I AGSSNCHK=1 W "Not Available"
... I AGSSNCHK=2 W "Patient refused"
... I AGSSNCHK=3 W "Patient will submit"
... I AGSSNCHK="" W "Reason for no SSN not yet entered"
.. I $P($G(^AUPNPAT(DFN,0)),U,23)'="",$D(^AUTTSSN($P($G(^(0)),U,23),0)) W "(",$P($G(^(0)),U,2),")"
.. I $P($G(^DPT(DFN,0)),U,9)'=""&($P($G(^AUPNPAT(DFN,0)),U,23)="") W "(Not yet verified by the SSA)"
. I AG'=3&(AG'=13)&(AG'=19)&(AG'=17)&(AG'=14) W ! ;AG*7.1*4/AG*7.1*8/AG*7.1*12
. I AG=9!(AG=16) D ;AG*7.1*12
.. W AGLINE("-"),!
S AG("N")=19 ;AG*7.1*8/AG*7.1*12
W !,AGLINE("-")
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="",MYVARS("SITE")=DUZ(2)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
Q
;***************************************************************
; ON LINES BELOW:
; PIECE 1= FLD LBL
; PIECE 2= POSITION ON LINE TO DISP FLD
; PIECE 3= FILE #
; PIECE 4= FLD #
1 ;
;;ELIGIBILITY STATUS^10^9000001^1112
;;DOB^25^2^.03
;;CITY OF BIRTH^15^2^.092
;;ST^62^2^.093
;;SEX^25^2^.02
;;SSN^25^2^.09
;;MARITAL STATUS^14^2^.05
;;CURRENT COMMUNITY^11^9000001^1118
;;PATIENT RESIDENCE^12^9000001^1803
;;MAILING ADDRESS-STREET^6^2^.111
;;STREET ADDRESS [LINE 2]^5^2^.112
;;STREET ADDRESS [LINE 3]^5^2^.113
;;MAILING ADDRESS-CITY^8^2^.114
;;ST^62^2^.115
;;MAILING ADDRESS-ZIP^9^2^.116
;;LOCATION OF HOME^12^9000001^1201
;;HOME PHONE^16^2^.131
;;WORK PHONE^17^2^.132
;;MESSAGE PHONE^18^9000001^1801
AGED1 ; IHS/ASDS/EFG - EDIT PG 1 - ELIG/IDENTIFIERS ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**2,4,5,7,8,12**;AUG 25, 2005;Build 1
+2 ;
+3 ;AG*7.1*7 - Modified code to allow the new page 10 to be called
+4 ;IHS/OIT/NKD AG*7.1*12 PATIENT RESIDENCE
+5 ;
+6 IF "YC"[AGOPT(14)
SET AG("SVELIG")=""
+7 SET AG("SVELIG")=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+8 ;AG*7.1*4
NEW OLDST,NEWST,OLDADDR2,NEWADDR2,OLDADDR3,NEWADDR3,OLDCITY,NEWCITY,OLDSTATE
+9 ;AG*7.1*4
NEW NEWSTATE,OLDZIP,NEWZIP,OLDHPH,NEWHPH,TEMPY
+10 ;
VAR ;EP
+1 IF '$DATA(^DPT(DFN,0))
QUIT
+2 SET AG("PG")=1
+3 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+4 SET AGPAT=$PIECE($GET(^DPT(DFN,0)),U)
+5 SET AGCHRT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:"xxxxx")
+6 SET AG("AUPN")=""
+7 IF $DATA(^AUPNPAT(DFN,0))
SET AG("AUPN")=^(0)
+8 WRITE ?36,$$DTEST^AGUTILS(DFN)
+9 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+10 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",78)," ","=")
+11 SET $PIECE(AGLINE("PGLN"),"=",81)=""
VAR2 ;
+1 DO DRAW
+2 IF '$DATA(AGSEENLY)
WRITE !,AGLINE("PGLN")
+3 IF $DATA(AGSEENLY)
QUIT
SSNA ;Ver=add ask if patient has verified SSN
+1 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,23)]""
IF $DATA(^AUTTSSN($PIECE(^(0),U,23),0))
IF "A"[$PIECE($GET(^(0)),U)
Begin DoDot:1
+2 WRITE !!,*7
+3 KILL DIR
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Has the patient verified the SSN added by SSA "
+6 SET DIR("B")="NO"
+7 DO ^DIR
+8 KILL DIR
+9 IF Y=0
QUIT
+10 KILL DR
+11 SET DIE="^AUPNPAT("
+12 SET DA=DFN
+13 SET DR=".23///V"
+14 DO ^DIE
+15 KILL DR
ESSNA DO DRAW
End DoDot:1
+1 IF "YC"[AGOPT(14)
DO CKELIG
+2 KILL DIR
+3 SET DIR("?")="Enter your choice now."
+4 SET DIR("?",1)="You may enter the item number of the field you wish to edit,"
+5 SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
+6 SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
+7 SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
+8 SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE//"
DO READ
+9 IF $DATA(MYERRS("C","E"))
IF (Y'?1N.N)
IF (Y'=AGOPT("ESCAPE"))
WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"
HANG 3
GOTO VAR
+10 ;AG*7.1*4
SET TEMPY=Y
IF +Y'=Y
DO ASKADD^AG3A
SET Y=TEMPY
KILL TEMPY
+11 IF Y=AGOPT("ESCAPE")
QUIT
+12 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
QUIT
+13 IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+14 IF $DATA(DLOUT)!(Y["N")
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+15 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)'="")
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
+16 ;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH"
+17 ;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH,WEB" ;AG*7.1*2 ITEM 5 PAGE 11
+18 ;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,ALLADDR^AG3A,LOC,ALLADDR^AG3A,OPH^AG3A,MSGPH,WEB,EDEMAIL" ;AG*7.1*4
+19 ;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH,EDEMAIL" ;AG*7.1*7
+20 ;S AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH" ;AG*7.1*8
+21 ;AG*7.1*12
SET AG("C")="ELIG^AG2A,DOB^AG2A,COB^AG3A,SOB^AG3A,SEX^AG2A,SSN^AG3A,MSTAT,EDCOM^AG2B,PRES^AG3A,ST^AG3A,ADDR2,ADDR3,CITY^AG3A,STATE^AG3A,ZIP^AG3A,LOC,HPH^AG3A,OPH^AG3A,MSGPH"
+22 IF '$DATA(AGSEENLY)
DO C
+23 GOTO VAR
END ;
+1 KILL AG,DA,DIC,DR,DUOUT,DLOUT,DQOUT,DTOUT,DFOUT,AGSCRN,Y,DIR,ROUTID
+2 IF $DATA(AGXTERN)
QUIT
+3 IF $PIECE($GET(^AUPNPAT(DFN,11)),U,12)=""
WRITE *7,!!,"Eligibility Status must be entered."
HANG 2
GOTO VAR
+4 GOTO ^AGED2
READ ;EP
+1 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),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 SET X=Y
SET Y=$$UP^XLFSTR(X)
+10 IF Y="P"
QUIT
+11 IF $EXTRACT(Y,1)="p"
SET $EXTRACT(Y,1)="P"
+12 IF $EXTRACT(Y,1)="P"&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)'="")
Begin DoDot:1
+13 SET AG("ED")=+$PIECE($EXTRACT(Y,2,99),".")
+14 ;AG*7.1*7
IF AG("ED")<1!(AG("ED")>10)
Begin DoDot:2
+15 ;AG*7.1*7
WRITE *7,!!,"Use only pages 1 through 10."
+16 HANG 2
+17 KILL AG("ED")
+18 SET AG("ERR")=""
End DoDot:2
+19 IF $DATA(AG("ED"))
Begin DoDot:2
+20 ;AG*7.1*7
IF AG("ED")>0&(AG("ED")<11)
Begin DoDot:3
+21 IF AG("ED")=4
SET AG("ED")="4A"
+22 ;REPLACE OLD PG 5A WITH BENEFITS COORD SCREEN
IF AG("ED")=5
SET AG("ED")="BEA"
+23 IF AG("ED")=6
SET AG("ED")=13
+24 IF AG("ED")=8
SET AG("ED")=11
+25 IF AG("ED")=7
SET AG("ED")=8
+26 IF AG("ED")=9
SET AG("ED")="11A"
+27 ;AG*7.1*7
IF AG("ED")=10
SET AG("ED")="10A"
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF $EXTRACT(Y,1)="P"&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)="")
Begin DoDot:1
+29 WRITE *7,!!,"Eligibility Status must be entered."
HANG 2
End DoDot:1
+30 QUIT
C ;EP - Edit multiple fields on a Reg edit page.
+1 SET AGY=Y
+2 FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,",",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("N"))
QUIT
DO @($PIECE(AG("C"),",",AG("SEL")))
+3 DO UPDATE1^AGED(DUZ(2),DFN,1,"")
+4 KILL AGI,AGY
EC ;
+1 QUIT
MSTAT ;GET MARITAL STATUS FROM VA PATIENT FILE
+1 KILL DUOUT
+2 SET DIE="^DPT("
+3 SET DA=DFN
+4 SET DR=.05
+5 DO ^DIE
+6 IF $DATA(Y)
SET DUOUT=""
+7 KILL DIC("S"),DIC("W"),DIC("A"),DIC("B")
+8 QUIT
ADDR2 ;GET ADDRESS LINE 2 FROM VA PATIENT FILE
+1 ;AG*7.1*4
SET OLDADDR2=$$GET1^DIQ(2,DFN_",",.112)
+2 KILL DUOUT
+3 SET DIE="^DPT("
+4 SET DA=DFN
+5 SET DR=.112
+6 DO ^DIE
+7 IF $DATA(Y)
SET DUOUT=""
+8 KILL DIC("S"),DIC("W"),DIC("A"),DIC("B")
+9 ;AG*7.1*4
SET NEWADDR2=$$GET1^DIQ(2,DFN_",",.112)
+10 QUIT
ADDR3 ;GET ADDRESS LINE 3 FROM VA PATIENT FILE
+1 ;AG*7.1*4
SET OLDADDR3=$$GET1^DIQ(2,DFN_",",.113)
+2 KILL DUOUT
+3 SET DIE="^DPT("
+4 SET DA=DFN
+5 SET DR=.113
+6 DO ^DIE
+7 IF $DATA(Y)
SET DUOUT=""
+8 KILL DIC("S"),DIC("W"),DIC("A"),DIC("B")
+9 ;AG*7.1*4
SET NEWADDR3=$$GET1^DIQ(2,DFN_",",.113)
+10 QUIT
LOC ;GET LOCATION OF HOME FROM PATIENT FILE
+1 KILL DUOUT
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 SET DR=1201
+5 DO ^DIE
+6 IF $DATA(Y)
SET DUOUT=""
+7 KILL DIC("S"),DIC("W"),DIC("A"),DIC("B")
+8 QUIT
MSGPH ;GET MESSAGE PHONE FROM PATIENT FILE
+1 KILL DUOUT
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 SET DR=1801
+5 DO ^DIE
+6 IF $DATA(Y)
SET DUOUT=""
+7 KILL DIC
+8 QUIT
+9 ;AG*7.1*8 - Entire tag reworked to handle new multiple field
WEB ;EP - INTERNET ACCESS QUESTION
+1 NEW DIC,DA,DIC,X,Y,OIEN,NIEN
+2 ;
+3 ;Get latest entry ien
+4 SET OIEN=$ORDER(^AUPNPAT(DFN,81,"B"),-1)
+5 ;
+6 ;Define new entry and save
+7 SET DIC="^AUPNPAT("_DFN_",81,"
SET DA(1)=DFN
+8 SET DIC(0)="L"
+9 SET X=DT
+10 SET DLAYGO="9000001.81"
SET DIC("P")=DLAYGO
+11 IF '$DATA(^AUPNPAT(DFN,81,0))
SET ^AUPNPAT(DFN,81,0)="^9000001.81D^^"
+12 KILL DO,DD
DO FILE^DICN
+13 KILL DIC,DA,DIC,X
+14 IF +Y<1
QUIT
+15 ;
+16 ;Copy existing entry into current one
+17 IF OIEN]""
MERGE ^AUPNPAT(DFN,81,+Y)=^AUPNPAT(DFN,81,OIEN)
+18 ;
+19 NEW DIE,DIR,DIC,DA,DR
+20 SET (NIEN,DA)=+Y
+21 SET DA(1)=DFN
+22 SET DIE="^AUPNPAT("_DA(1)_",81,"
+23 SET DEF=$$GET1^DIQ(9000001.81,NIEN_","_DFN_",",.02,"Y")
+24 SET DR=.02
IF DEF]""
SET DR=DR_"//"_DEF
+25 DO ^DIE
+26 KILL DIE,DIR,DIC,DA,DR
+27 ;
+28 ;If No Internet Access, Remove the Where value
+29 IF '$PIECE($GET(^AUPNPAT(DFN,81,NIEN,0)),U,2)
Begin DoDot:1
+30 NEW AGVAR,ERROR,WIEN
+31 SET AGVAR(9000001.81,NIEN_","_DFN_",",".03")="@"
+32 SET WIEN=0
FOR
SET WIEN=$ORDER(^AUPNPAT(DFN,81,NIEN,1,WIEN))
IF 'WIEN
QUIT
Begin DoDot:2
+33 SET AGVAR(9000001.811,WIEN_","_NIEN_","_DFN_",",.01)="@"
End DoDot:2
+34 DO FILE^DIE("","AGVAR","ERROR")
End DoDot:1
QUIT
+35 ;
+36 NEW DIE,DIR,DIC,DR,DA
+37 SET DA(1)=DFN
SET DA=NIEN
+38 SET DIE="^AUPNPAT("_DA(1)_",81,"
+39 SET DR=".04"
+40 DO ^DIE
+41 ;
+42 QUIT
+43 ;
+44 ;NEW CODE AG*7.1*4
EDEMAIL ;EP - EDIT CURRENT EMAIL ADDRESS
+1 WRITE !!
+2 NEW OLDEMAIL
+3 SET OLDEMAIL=$$GET1^DIQ(9000001,DFN_",",1802)
+4 KILL DIE,DIC,DR,DA,DIR
+5 SET DIE="^AUPNPAT("
+6 SET DA=DFN
+7 SET DR=1802
+8 DO ^DIE
+9 IF $DATA(Y)
QUIT
+10 IF $$GET1^DIQ(9000001,DFN_",",1802)=""
QUIT
+11 ;NO CHANGE
IF OLDEMAIL=$$GET1^DIQ(9000001,DFN_",",1802)
QUIT
+12 KILL DIR
+13 SET DIR(0)="Y"
+14 SET DIR("A")="Should this new email address be added to the historical addresses"
+15 SET DIR("B")="Y"
+16 DO ^DIR
+17 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+18 WRITE !!,"Adding to PREVIOUS EMAIL FIELD...."
HANG 2
+19 DO UPDTEMAL^AGUTILS(DFN)
+20 ;END NEW CODE
+21 QUIT
+22 ;
QUES ;EP
+1 WRITE !!,"To change an item, enter a number from 1 to ",AG("N")
+2 WRITE ". (Press RETURN for ""NO-CHANGE"".)"
+3 DO READ
+4 QUIT
CKELIG ;EP
+1 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE($GET(^(11)),U,12)'=AG("SVELIG")
Begin DoDot:1
+2 SET AG("SVELIG")=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+3 DO CALCELIG^AGBIC2
+4 WRITE *7,!,"This patient's Eligibility has been changed to "
+5 WRITE $PIECE(AG("NARR1"),":",2)
End DoDot:1
QUIT
+6 QUIT
DRAW ;DRAW PAGE 1
+1 SET AG("PG")=1
+2 ;AG*7.1*8/AG*7.1*12
SET AG("N")=19
+3 SET DA=DFN
+4 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+5 DO ^AGED
+6 KILL ^UTILITY("DIQ1",$JOB)
+7 ;OUTPUT OPTION NUMBER,FIELD NAME, AND DATA
+8 FOR AG=1:1:AG("N")
Begin DoDot:1
+9 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,19)
+10 ;FILE NUMBER
SET DIC=$PIECE(AGSCRN,U,3)
+11 ;FIELD NUMBER
SET DR=$PIECE(AGSCRN,U,4)
+12 ;AG*7.1*4/AG*7.1*12
IF AG'=4&(AG'=14)&(AG'=18)&(AG'=15)
WRITE ?1,AG,".",?(27-$LENGTH($PIECE($GET(^DD(DIC,DR,0)),U))),$PIECE($GET(^DD(DIC,DR,0)),U)," : "
+13 ;AG*7.1*2 ITEM 5 PAGE 11/AG*7.1*12
IF AG=18
WRITE ?45,AG,".",$PIECE(AGSCRN,U)," : "
+14 IF AG=4
WRITE " ",AG,".",$PIECE(AGSCRN,U)," : "
+15 ;AG*7.1*12
IF AG=14
WRITE " ",AG,".",$PIECE(AGSCRN,U)," : "
+16 ;I AG=14 W ?54,AG,". ZIP CODE : " ;AG*7.1*4
+17 ;AG*7.1*5 H4532/AG*7.1*12
IF AG=15
WRITE ?($SELECT($DATA(DPTFLAG):58,1:56)),AG,".ZIP",$SELECT($DATA(DPTFLAG):"+4",1:" CODE")," : "
IF $DATA(DPTFLAG)
SET DR=.1112
+18 ;DISPLAY MSG BELOW IF THERE ARE DIRECTIONS TO PATIENT'S HOME
+19 ;AG*7.1*12
IF AG=16&($DATA(^AUPNPAT(DFN,12,1,0)))
Begin DoDot:2
+20 IF '$DATA(AGSEENLY)
WRITE "LOCATION OF HOME CONTAINS DATA"
+21 IF $DATA(AGSEENLY)
Begin DoDot:3
+22 SET HOME=$PIECE($GET(^AUPNPAT(DFN,12,1,0)),U)
+23 SET AG("Y")=$LENGTH(HOME)
SET LNCNT=0
+24 FOR
SET AG("K")=$EXTRACT(HOME,1,49)
IF $LENGTH(AG("K"))=0
QUIT
Begin DoDot:4
+25 SET HOME=$EXTRACT(HOME,50,AG("Y"))
+26 IF LNCNT>0
WRITE !
+27 WRITE ?30,AG("K")
+28 SET LNCNT=LNCNT+1
End DoDot:4
+29 KILL HOME,AG("Y"),AG("K"),LNCNT
End DoDot:3
End DoDot:2
+30 ;AG*7.1*12
IF AG'=16&(AG'=4)&(AG'=14)
Begin DoDot:2
+31 KILL AGRES
+32 SET TEMPDIC=DIC
+33 SET DIQ="AGRES"
SET DIQ(0)="E"
DO EN^DIQ1
+34 SET DIC=TEMPDIC
+35 ;W $G(AGRES(DIC,DFN,DR,"E"))
+36 ;BEGIN NEW CODE FOR ABOVE LINE IHS/SD/TPF AG*7.1*4
+37 NEW HIT
+38 DO EN^AGSECCHK("AGZVIEWSSN",.HIT)
+39 IF DIC=2
IF (DR=.09)
Begin DoDot:3
+40 IF HIT="Y"
WRITE $$GET1^DIQ(2,DFN_",",.09)
QUIT
+41 IF ($$GET1^DIQ(9000001,DFN_",",.23,"E")="V")
WRITE $$GET1^DIQ(9000001,DFN_",",1107.3)
+42 IF '$TEST
WRITE $$GET1^DIQ(2,DFN_",",.09)
End DoDot:3
+43 IF '$TEST
WRITE $GET(AGRES(DIC,DFN,DR,"E"))
+44 ;END NEW CODE
+45 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
+46 ;I AG=19 W !?1,AG,"." W ?15,"EMAIL ADDRESS: ",$$GET1^DIQ(9000001,DFN_",",1802)
+47 IF AG=4
Begin DoDot:2
+48 KILL AGRES
+49 SET TEMPDIC=DIC
+50 SET DIQ="AGRES"
SET DIQ(0)="I"
DO EN^DIQ1
+51 SET DIC=TEMPDIC
+52 IF $GET(AGRES(DIC,DFN,DR,"I"))'=""
WRITE $PIECE($GET(^DIC(5,$GET(AGRES(DIC,DFN,DR,"I")),0)),U,2)
+53 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
+54 ;AG*7.1*12
IF AG=14
Begin DoDot:2
+55 KILL AGRES
+56 SET TEMPDIC=DIC
+57 SET DIQ="AGRES"
SET DIQ(0)="I"
DO EN^DIQ1
+58 SET DIC=TEMPDIC
+59 IF $GET(AGRES(DIC,DFN,DR,"I"))'=""
WRITE $PIECE($GET(^DIC(5,$GET(AGRES(DIC,DFN,DR,"I")),0)),U,2)
+60 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
+61 ;SHOW SSN VERIFICATION STATUS NEXT TO THE SSN FIELD
+62 IF AG=6
Begin DoDot:2
+63 IF $PIECE($GET(^DPT(DFN,0)),U,9)=""
Begin DoDot:3
+64 SET AGSSNCHK=$PIECE($GET(^AUPNPAT(DFN,0)),U,24)
+65 IF AGSSNCHK=1
WRITE "Not Available"
+66 IF AGSSNCHK=2
WRITE "Patient refused"
+67 IF AGSSNCHK=3
WRITE "Patient will submit"
+68 IF AGSSNCHK=""
WRITE "Reason for no SSN not yet entered"
End DoDot:3
+69 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,23)'=""
IF $DATA(^AUTTSSN($PIECE($GET(^(0)),U,23),0))
WRITE "(",$PIECE($GET(^(0)),U,2),")"
+70 IF $PIECE($GET(^DPT(DFN,0)),U,9)'=""&($PIECE($GET(^AUPNPAT(DFN,0)),U,23)="")
WRITE "(Not yet verified by the SSA)"
End DoDot:2
+71 ;AG*7.1*4/AG*7.1*8/AG*7.1*12
IF AG'=3&(AG'=13)&(AG'=19)&(AG'=17)&(AG'=14)
WRITE !
+72 ;AG*7.1*12
IF AG=9!(AG=16)
Begin DoDot:2
+73 WRITE AGLINE("-"),!
End DoDot:2
End DoDot:1
+74 ;AG*7.1*8/AG*7.1*12
SET AG("N")=19
+75 WRITE !,AGLINE("-")
+76 KILL MYERRS,MYVARS
+77 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+78 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SITE")=DUZ(2)
+79 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+80 QUIT
+81 ;***************************************************************
+82 ; ON LINES BELOW:
+83 ; PIECE 1= FLD LBL
+84 ; PIECE 2= POSITION ON LINE TO DISP FLD
+85 ; PIECE 3= FILE #
+86 ; PIECE 4= FLD #
1 ;
+1 ;;ELIGIBILITY STATUS^10^9000001^1112
+2 ;;DOB^25^2^.03
+3 ;;CITY OF BIRTH^15^2^.092
+4 ;;ST^62^2^.093
+5 ;;SEX^25^2^.02
+6 ;;SSN^25^2^.09
+7 ;;MARITAL STATUS^14^2^.05
+8 ;;CURRENT COMMUNITY^11^9000001^1118
+9 ;;PATIENT RESIDENCE^12^9000001^1803
+10 ;;MAILING ADDRESS-STREET^6^2^.111
+11 ;;STREET ADDRESS [LINE 2]^5^2^.112
+12 ;;STREET ADDRESS [LINE 3]^5^2^.113
+13 ;;MAILING ADDRESS-CITY^8^2^.114
+14 ;;ST^62^2^.115
+15 ;;MAILING ADDRESS-ZIP^9^2^.116
+16 ;;LOCATION OF HOME^12^9000001^1201
+17 ;;HOME PHONE^16^2^.131
+18 ;;WORK PHONE^17^2^.132
+19 ;;MESSAGE PHONE^18^9000001^1801
