AGED2 ; IHS/ASDS/EFG - EDIT PG 2 - RELIGION/TRIBAL DATA/EMPLOYMENT DATA ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**2,3,7,8,10**;AUG 25, 2005;Build 7
;
;AG*7.1*7 - Sections of this routine were re-written to accomplish the following:
; 1) Modified code to allow for the new page 10
; 2) Ethnicity, Race, Internet, and Household Information are now asked on Page 10
; (Edit tags are still located in this routine however)
;
;AG*7.1*8 - Sections of thsi routine were re-written to accomplish the following:
; 1) Added Father/Mother Email/Cell/Alt Phone fields and prompts
; 2) Modified code better handle display - line #, tabs, label display/length, field call handling
;AG*7.1*10- Put in validity check on user field selection prompt
N CLLST
I "YC"[AGOPT(14) S AG("SVELIG")=""
I $D(^AUPNPAT(DFN,11)) S AG("SVELIG")=$P($G(^AUPNPAT(DFN,11)),U,12)
VAR ;
;S CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,MOTHER,EMPLR,SPSEMP,FEMPL,MEMPL" ;AG*7.1*7
D DRAW
W !,AGLINE("EQ")
K AG("ER")
D ^AGDATCK
;I ($D(AG("ER",13))!$D(AG("ER","TEMPHRN"))!$D(AG("ER",2))) W *7,!!,"Patient must first have a VALID/permanent HRN prior to editing !" K DIR S DIR(0)="E" D ^DIR S DUOUT=1 K AG("ER") G END
K AG("ER")
D:"YC"[AGOPT(14) CKELIG^AGED1 S AGWM=1 D ^AGELCHK W:$D(AG("ER",9)) *7,!,?10,"Corrections are to be made: " K DIR 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
Q:Y=AGOPT("ESCAPE")
I $D(AG("ER",9)) I (($D(DFOUT))!($D(DLOUT))!(Y["N")!($D(DUOUT))!($D(AG("ED")))) D G VAR
. W !,"The corrections must be made !",*7
G END:$D(DLOUT)!(Y["N")!$D(DUOUT)
G VAR:$D(AG("ERR"))
G:$D(AG("ED"))&('$D(AGXTERN)) @("^AGED"_AG("ED"))
Q:$D(DTOUT)!$D(DFOUT)
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
S AGY=Y
;AG*7.1*8 - Replaced existing logic with next 3 lines
S AGY=Y
;AG*7.1*10;Added next line to stop bad user entry errors
I $TR(AGY,",")'?1N.N W !!,"Invalid entry - Enter a line number or line numbers separated by a ',' to edit" H 3 G VAR
F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("E")) D
. D @(CLLST(AG("SEL")))
D UPDATE1^AGED(DUZ(2),DFN,2,"")
G VAR
END ;
K AG,AGI,AGIO,AGY,CLLST,DLOUT,DQOUT,DFOUT,DTOUT,DA,AGSCRN,Y,QUAN,TRIBE
K ROUTID
Q:$D(AGXTERN)
Q:$D(DIROUT)
G VAR^AGED1:$D(DUOUT)
G ^AGED3
ELIG ;
I AGOPT(14)'="Y" D ELIG^AG2A Q
W !!,"You can only change a patient's eligibility"
W !,"by altering their Community of Residence,"
W !,"Tribe of Membership, or Indian Quantum."
W !,"Press return to continue"
W *7
D READ
Q
DRAW ;EP
S CLLST=0
S CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,FCPH,FEML,FAPH,MOTHER,MCPH,MEML,MAPH,EMPLR,SPSEMP,FEMPL,MEMPL" ;AG*7.1*7
S AG("PG")=2
S AG("N")=19 ;AG*7.1*8
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
S DA=DFN
D ^AGED ;Main editor routine
K ^UTILITY("DIQ1",$J)
I AGOPT(14)="Y" D
. D ^AGBIC2C ;Compute eligibility status
. S DIC=9000001
. S DR=1124
. S $P(AGSCRN,";;")=""
. W !,"1. ",$P($G(^DD(DIC,DR,0)),U)," : "
. W $$GET1^DIQ(DIC,DFN,DR)
F AG=1:1:AG("N") D
. N AGSCRN,LBL,LEN,CLM,DIC,DR,VLEN,VALUE ;AG*7.1*8
. S AGSCRN=$P($T(@1+AG),";;",2,17)
. S LBL=$P(AGSCRN,U) ;AG*7.1*8 - Added LBL,LEN,CLM
. S LEN=$P(AGSCRN,U,2)
. S CLM=$P(AGSCRN,U,3)
. S DIC=$P(AGSCRN,U,4)
. S DR=$P(AGSCRN,U,5)
. S VLEN=$P(AGSCRN,U,6)
. ;
. ;Prompt position ;AG*7.1*8
. I CLM="" W !
. E W ?CLM
. ;
. ;Display Number ;AG*7.1*8
. S CLLST=CLLST+1,CLLST(CLLST)=$P(CALLS,",",AG),AG("E")=CLLST
. W CLLST,". "
. ;
. ;Display label AG*7.1*8
. W $J(LBL,LEN),": "
. ;
. ;D
. ;. I AG=16,$$GET1^DIQ(9009061,DUZ(2)_",",502,"I") W $E($$GET1^DIQ(DIC,DFN,DR),1,15) Q ;AG*7.1*8 - Changed AG value to 16
. S VALUE=$$GET1^DIQ(DIC,DFN,DR)
. S:VLEN>0 VALUE=$E(VALUE,1,VLEN)
. W VALUE
. I AG=3 D
.. I $P($G(^AUPNPAT(DFN,11)),U,8)'="" D
... S Y=$$GET1^DIQ(DIC,DFN,DR)
... D TRBCHK
. I AG=7,'$D(^AUPNPAT(DFN,43)) D
.. W ?33,"* NONE LISTED *"
. I AG=7 D OTHER W !,AGLINE("-")
. I AG=15 W !,AGLINE("-") ;AG*7.1*8 - Changed AG value to 15
;
W !,AGLINE("-")
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
Q
READ ;EP
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT
S DIR("?")="Enter free text"
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(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: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"
... 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
Q
TRBCHK ;
I $P($G(^AUTTTRI($O(^AUTTTRI("B",$E(Y,1,30),0)),0)),U,4)="Y" D Q
. W:$X<50 ?50
. W:$X>50 !?33
. W $$S^AGVDF("RVN"),"(OLD UNUSED TRIBE NAME)",$$S^AGVDF("RVF")
I $P($G(^AUTTTRI($O(^AUTTTRI("B",$E(Y,1,30),0)),0)),U,2)=999 D Q
. W $$S^AGVDF("RVN")," <- PLEASE SPECIFY IF KNOWN",$$S^AGVDF("RVF")
I "YC"[AGOPT(14) D
. S DR=1119
. K AGRES
. S TEMPDIC=DIC
. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
. S DIC=TEMPDIC
. W $G(AGRES(DIC,DFN,DR,"E"))
. K AGRES,TEMPDIC,AGRES
Q
EMPLR ;EP - Patient's Employer.
S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4)
W !
K DIR,DIE,DR,DIC
S DIE="^AUPNPAT("
;IF EMPLOYMENT STATUS FULL OR PART TIME
I ($P($G(^AUPNPAT(DFN,0)),U,21)=1!($P($G(^AUPNPAT(DFN,0)),U,21)=2)),$$ISREQ^AGFLDREQ(9000001,.19) S DIE("NO^")="",DR=".19R"
E S DR=.19
S DA=DFN
D ^DIE
I $P($G(^AUPNPAT(DFN,0)),U,19)="",$P($G(^(0)),U,21)]"","39"'[$P($G(^(0)),U,21) D
. S DR=".21///@"
. D ^DIE
. K DIE,DIC,DR
Q:$P($G(^AUPNPAT(DFN,0)),U,19)=""
S AGEL("EMP")=$P($G(^AUPNPAT(DFN,0)),U,19)
D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
EMST ;GET PATIENT'S EMPLOYMENT STATUS
W !
S DIE="^AUPNPAT("
S DA=DFN
S DR=.21
D ^DIE
K DIC,DR,DIE
K AGEL("EMP")
K AGEL("ONUM")
Q
EMPL ;
S DIE="^AUTNEMPL("
S DA=AGEL("EMP")
W !!,"<----------EMPLOYER DEMOGRAPHIC INFO---------->"
S DR=".02 Street...: ;.03 City.....: ;.04 State....: ;.05 Zip......: ;.06 Phone....: ;.07 Abbrev...: "
D ^DIE
Q
SPSEMP ;EP - Spouse's Employer.
S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4)
W !
S DIE="^AUPNPAT("
S DR=.22
S DA=DFN
D ^DIE
Q:$P($G(^AUPNPAT(DFN,0)),U,22)=""
S AGEL("EMP")=$P($G(^AUPNPAT(DFN,0)),U,22)
D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
K AGEL("EMP")
K AGEL("ONUM")
K DIE,DIC,DR
Q
FEMPL ;FATHER'S EMPLOYER INFO
S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4) ;NUMBER OF ENTRIES IN FILE
W !
S DIE="^AUPNPAT("
I $$AGE^AUPNPAT(DFN)>17 S DR=2701
I $$AGE^AUPNPAT(DFN)<18,$P($G(^AUPNPAT(DFN,27)),U,2)="" S DR="2701R"
E S DR=2701
S DA=DFN
D ^DIE
Q:$P($G(^AUPNPAT(DFN,27)),U)=""
S AGEL("EMP")=$P($G(^AUPNPAT(DFN,27)),U)
D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
K AGEL("EMP")
K AGEL("ONUM")
K DIE,DIC,DR
Q
MEMPL ;MOTHER'S EMPLOYER INFO
K DIE,DIC,DR
S AGEL("ONUM")=$P($G(^AUTNEMPL(0)),U,4) ;# OF ENTRIES IN FILE
W !
S DIE="^AUPNPAT("
I $$AGE^AUPNPAT(DFN)>17 S DR=2702
I $$AGE^AUPNPAT(DFN)<18,$P($G(^AUPNPAT(DFN,27)),U)="" S DR="2702R"
E S DR=2702
S DA=DFN
D ^DIE
Q:$P($G(^AUPNPAT(DFN,27)),U,2)=""
S AGEL("EMP")=$P($G(^AUPNPAT(DFN,27)),U,2)
D:$P($G(^AUTNEMPL(0)),U,4)'=AGEL("ONUM") EMPL
K AGEL("EMP")
K AGEL("ONUM")
K DIE,DIC,DR
Q
OTHER ;DISPLAY LAST OTHER TRIBE AND QUANTUM
S D1=0
S TRIBE="",QUAN=""
F S D1=$O(^AUPNPAT(DFN,43,D1)) Q:'D1 D
. S TRIBE=$P($G(^AUTTTRI($P($G(^AUPNPAT(DFN,43,D1,0)),U),0)),U)
. S QUAN=$P($G(^AUPNPAT(DFN,43,D1,0)),U,2)
W ?32,TRIBE
W ?73,$E(QUAN,1,6)
Q
OTHERT ;ALLOW ADD AND EDIT OF OTHER TRIBES AND QUANTUMS
Q:AGOPT(8)'="Y"
W !!,"OTHER TRIBES:",?50,"QUANTUM:",!
S D1=0
F S D1=$O(^AUPNPAT(DFN,43,D1)) Q:'D1 D
. S TRIPTR=$P($G(^AUPNPAT(DFN,43,D1,0)),U)
. S OTRIBE=$P($G(^AUTTTRI(TRIPTR,0)),U)
. S OQUAN=$P($G(^AUPNPAT(DFN,43,D1,0)),U,2)
. W !,OTRIBE,?50,OQUAN
W !!
K DIC,DIE,DR
S DIE="^AUPNPAT("
S DR=4301
S DA=DFN
D ^DIE
D UPDATE1^AGED(DUZ(2),DFN,12,"")
I '$O(^AUPNPAT(DFN,43,0)) K ^AUPNPAT(DFN,43)
K DIC,DIE,DR
Q
FATHER ;GET FATHER'S NAME, CITY AND STATE OF BIRTH
K DUOUT
K DIE
S DIE="^DPT("
S DA=DFN
W !
S DR=.2401
D ^DIE
S:$D(Y) DUOUT=""
K DIE,DIC,DR,DUOUT
I $P($G(^DPT(DFN,.24)),U)="" D
. I $P($G(^AUPNPAT(DFN,26)),U,2)'="" S $P(^AUPNPAT(DFN,26),U,2)=""
. I $P($G(^AUPNPAT(DFN,26)),U,3)'="" S $P(^AUPNPAT(DFN,26),U,3)=""
I $P($G(^DPT(DFN,.24)),U)'="" D
. S DIE="^AUPNPAT("
. W !
. S DR="2602;2603"
. D ^DIE
. S:$D(Y) DUOUT=""
. K DIE,DIC,DR
Q
;
MOTHER ;GET MOTHER'S NAME, CITY AND STATE OF BIRTH
K DUOUT,DIE
S DIE="^DPT("
S DA=DFN
W !
S DR=.2403
D ^DIE
S:$D(Y) DUOUT=""
K DUOUT
I $P($G(^DPT(DFN,.24)),U,3)="" D
. I $P($G(^AUPNPAT(DFN,26)),U,5)'="" S $P(^AUPNPAT(DFN,26),U,5)=""
. I $P($G(^AUPNPAT(DFN,26)),U,6)'="" S $P(^AUPNPAT(DFN,26),U,6)=""
I $P($G(^DPT(DFN,.24)),U,3)'="" D
. S DIE="^AUPNPAT("
. W !
. S DR="2605;2606"
. D ^DIE
. S:$D(Y) DUOUT=""
. K DIE,DIC,DR
Q
;
;AG*7.1*8 - Added FCPH, FEML, FAPH, MCPH, MEML, MAPH, and DIE tags
;
FCPH ;EP - Edit Father's Cell Phone
N DR
S DR=2903
D DIE
Q
;
FEML ;EP - Edit Father's Email Address
N DR
S DR=2901
D DIE
Q
;
FAPH ;EP - Edit Father's Alternate Phone
N DR
S DR="2902FATHER'S ALT. PHONE"
D DIE
Q
;
MCPH ;EP - Edit Mother's Cell Phone
N DR
S DR=3003
D DIE
Q
;
MEML ;EP - Edit Mother's Email Address
N DR
S DR=3001
D DIE
Q
;
MAPH ;EP - Edit Mother's Alternate Phone
N DR
S DR="3002MOTHER'S ALT. PHONE"
D DIE
Q
;
DIE ; Do Field Edit
N DA,DIE,DUOUT
S DIE="^AUPNPAT("
S DA=DFN
D ^DIE
Q
;
;AG*7.1*8 - Added Father/Mother Cell phone/Email/Alt Phone
;
; ****************************************************************
; ON LINES BELOW:
; PIECE 1= FLD LBL
; PIECE 2= FLD LENGTH
; PIECE 3= POSITION ON LINE TO DISP FLD, IF BLANK NEW LINE
; PIECE 4= FILE #
; PIECE 5= FLD #
; PIECE 6= Length (optional)
1 ;
;;RELIGIOUS PREFERENCE ^27^^2^.08
;;CLASSIFICATION/BENEFICIARY ^27^^9000001^1111
;;TRIBE OF MEMBERSHIP ^27^^9000001^1108
;;TRIBE QUANTUM ^14^^9000001^1109
;;INDIAN BLOOD QUANTUM ^^40^9000001^1110
;;TRIBAL ENROLLMENT NO. ^27^^9000001^.07
;;OTHER TRIBE ^27^^9000001^4301
;;FATHER'S NAME ^14^^2^.2401^29
;;CELL PHONE^12^49^9000001^2903
;;EMAIL ADDRESS^12^^9000001^2901^29
;;ALT.PHONE^11^49^9000001^2902
;;MOTHER'S MAIDEN NAME ^21^^2^.2403^20
;;CELL PHONE^12^48^9000001^3003
;;EMAIL ADDRESS^12^^9000001^3001^29
;;ALT.PHONE^11^49^9000001^3002
;;EMPLOYER NAME ^27^^9000001^.19
;;SPOUSE'S EMPLOYER NAME ^27^^9000001^.22
;;FATHER'S EMPLOYER NAME ^27^^9000001^2701
;;MOTHER'S EMPLOYER NAME ^27^^9000001^2702
AGED2 ; IHS/ASDS/EFG - EDIT PG 2 - RELIGION/TRIBAL DATA/EMPLOYMENT DATA ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**2,3,7,8,10**;AUG 25, 2005;Build 7
+2 ;
+3 ;AG*7.1*7 - Sections of this routine were re-written to accomplish the following:
+4 ; 1) Modified code to allow for the new page 10
+5 ; 2) Ethnicity, Race, Internet, and Household Information are now asked on Page 10
+6 ; (Edit tags are still located in this routine however)
+7 ;
+8 ;AG*7.1*8 - Sections of thsi routine were re-written to accomplish the following:
+9 ; 1) Added Father/Mother Email/Cell/Alt Phone fields and prompts
+10 ; 2) Modified code better handle display - line #, tabs, label display/length, field call handling
+11 ;AG*7.1*10- Put in validity check on user field selection prompt
+12 NEW CLLST
+13 IF "YC"[AGOPT(14)
SET AG("SVELIG")=""
+14 IF $DATA(^AUPNPAT(DFN,11))
SET AG("SVELIG")=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
VAR ;
+1 ;S CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,MOTHER,EMPLR,SPSEMP,FEMPL,MEMPL" ;AG*7.1*7
+2 DO DRAW
+3 WRITE !,AGLINE("EQ")
+4 KILL AG("ER")
+5 DO ^AGDATCK
+6 ;I ($D(AG("ER",13))!$D(AG("ER","TEMPHRN"))!$D(AG("ER",2))) W *7,!!,"Patient must first have a VALID/permanent HRN prior to editing !" K DIR S DIR(0)="E" D ^DIR S DUOUT=1 K AG("ER") G END
+7 KILL AG("ER")
+8 IF "YC"[AGOPT(14)
DO CKELIG^AGED1
SET AGWM=1
DO ^AGELCHK
IF $DATA(AG("ER",9))
WRITE *7,!,?10,"Corrections are to be made: "
KILL DIR
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 IF Y=AGOPT("ESCAPE")
QUIT
+11 IF $DATA(AG("ER",9))
IF (($DATA(DFOUT))!($DATA(DLOUT))!(Y["N")!($DATA(DUOUT))!($DATA(AG("ED"))))
Begin DoDot:1
+12 WRITE !,"The corrections must be made !",*7
End DoDot:1
GOTO VAR
+13 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
+14 IF $DATA(AG("ERR"))
GOTO VAR
+15 IF $DATA(AG("ED"))&('$DATA(AGXTERN))
GOTO @("^AGED"_AG("ED"))
+16 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+17 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
+18 SET AGY=Y
+19 ;AG*7.1*8 - Replaced existing logic with next 3 lines
+20 SET AGY=Y
+21 ;AG*7.1*10;Added next line to stop bad user entry errors
+22 IF $TRANSLATE(AGY,",")'?1N.N
WRITE !!,"Invalid entry - Enter a line number or line numbers separated by a ',' to edit"
HANG 3
GOTO VAR
+23 FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,",",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("E"))
QUIT
Begin DoDot:1
+24 DO @(CLLST(AG("SEL")))
End DoDot:1
+25 DO UPDATE1^AGED(DUZ(2),DFN,2,"")
+26 GOTO VAR
END ;
+1 KILL AG,AGI,AGIO,AGY,CLLST,DLOUT,DQOUT,DFOUT,DTOUT,DA,AGSCRN,Y,QUAN,TRIBE
+2 KILL ROUTID
+3 IF $DATA(AGXTERN)
QUIT
+4 IF $DATA(DIROUT)
QUIT
+5 IF $DATA(DUOUT)
GOTO VAR^AGED1
+6 GOTO ^AGED3
ELIG ;
+1 IF AGOPT(14)'="Y"
DO ELIG^AG2A
QUIT
+2 WRITE !!,"You can only change a patient's eligibility"
+3 WRITE !,"by altering their Community of Residence,"
+4 WRITE !,"Tribe of Membership, or Indian Quantum."
+5 WRITE !,"Press return to continue"
+6 WRITE *7
+7 DO READ
+8 QUIT
DRAW ;EP
+1 SET CLLST=0
+2 ;AG*7.1*7
SET CALLS="REL^AG8A,BENED^AG2A,TRIBE^AG2A,TQTM^AGOPT2,IQTM^AG2A,TRINUM^AGOPT2,OTHERT,FATHER,FCPH,FEML,FAPH,MOTHER,MCPH,MEML,MAPH,EMPLR,SPSEMP,FEMPL,MEMPL"
+3 SET AG("PG")=2
+4 ;AG*7.1*8
SET AG("N")=19
+5 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+6 SET DA=DFN
+7 ;Main editor routine
DO ^AGED
+8 KILL ^UTILITY("DIQ1",$JOB)
+9 IF AGOPT(14)="Y"
Begin DoDot:1
+10 ;Compute eligibility status
DO ^AGBIC2C
+11 SET DIC=9000001
+12 SET DR=1124
+13 SET $PIECE(AGSCRN,";;")=""
+14 WRITE !,"1. ",$PIECE($GET(^DD(DIC,DR,0)),U)," : "
+15 WRITE $$GET1^DIQ(DIC,DFN,DR)
End DoDot:1
+16 FOR AG=1:1:AG("N")
Begin DoDot:1
+17 ;AG*7.1*8
NEW AGSCRN,LBL,LEN,CLM,DIC,DR,VLEN,VALUE
+18 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,17)
+19 ;AG*7.1*8 - Added LBL,LEN,CLM
SET LBL=$PIECE(AGSCRN,U)
+20 SET LEN=$PIECE(AGSCRN,U,2)
+21 SET CLM=$PIECE(AGSCRN,U,3)
+22 SET DIC=$PIECE(AGSCRN,U,4)
+23 SET DR=$PIECE(AGSCRN,U,5)
+24 SET VLEN=$PIECE(AGSCRN,U,6)
+25 ;
+26 ;Prompt position ;AG*7.1*8
+27 IF CLM=""
WRITE !
+28 IF '$TEST
WRITE ?CLM
+29 ;
+30 ;Display Number ;AG*7.1*8
+31 SET CLLST=CLLST+1
SET CLLST(CLLST)=$PIECE(CALLS,",",AG)
SET AG("E")=CLLST
+32 WRITE CLLST,". "
+33 ;
+34 ;Display label AG*7.1*8
+35 WRITE $JUSTIFY(LBL,LEN),": "
+36 ;
+37 ;D
+38 ;. I AG=16,$$GET1^DIQ(9009061,DUZ(2)_",",502,"I") W $E($$GET1^DIQ(DIC,DFN,DR),1,15) Q ;AG*7.1*8 - Changed AG value to 16
+39 SET VALUE=$$GET1^DIQ(DIC,DFN,DR)
+40 IF VLEN>0
SET VALUE=$EXTRACT(VALUE,1,VLEN)
+41 WRITE VALUE
+42 IF AG=3
Begin DoDot:2
+43 IF $PIECE($GET(^AUPNPAT(DFN,11)),U,8)'=""
Begin DoDot:3
+44 SET Y=$$GET1^DIQ(DIC,DFN,DR)
+45 DO TRBCHK
End DoDot:3
End DoDot:2
+46 IF AG=7
IF '$DATA(^AUPNPAT(DFN,43))
Begin DoDot:2
+47 WRITE ?33,"* NONE LISTED *"
End DoDot:2
+48 IF AG=7
DO OTHER
WRITE !,AGLINE("-")
+49 ;AG*7.1*8 - Changed AG value to 15
IF AG=15
WRITE !,AGLINE("-")
End DoDot:1
+50 ;
+51 WRITE !,AGLINE("-")
+52 KILL MYERRS,MYVARS
+53 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+54 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+55 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+56 QUIT
READ ;EP
+1 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT
+2 SET DIR("?")="Enter free text"
+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(0)="FO"
+8 DO ^DIR
+9 IF $DATA(DTOUT)
QUIT
+10 IF Y="/.,"!(Y="^^")
SET DFOUT=""
+11 IF Y=""
SET DLOUT=""
+12 IF Y="^"
SET (DUOUT,Y)=""
+13 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+14 IF Y="P"
QUIT
+15 IF $EXTRACT(Y,1)="p"
SET $EXTRACT(Y,1)="P"
+16 IF $EXTRACT(Y,1)="P"&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)'="")
Begin DoDot:1
+17 SET AG("ED")=+$PIECE($EXTRACT(Y,2,99),".")
+18 ;AG*7.1*7
IF AG("ED")<1!(AG("ED")>10)
Begin DoDot:2
+19 ;AG*7.1*7
WRITE *7,!!,"Use only pages 1 through 10."
+20 HANG 2
+21 KILL AG("ED")
+22 SET AG("ERR")=""
End DoDot:2
+23 IF $DATA(AG("ED"))
Begin DoDot:2
+24 ;AG*7.1*7
IF AG("ED")>0&(AG("ED")<11)
Begin DoDot:3
+25 IF AG("ED")=4
SET AG("ED")="4A"
+26 IF AG("ED")=5
SET AG("ED")="BEA"
+27 IF AG("ED")=6
SET AG("ED")=13
+28 IF AG("ED")=8
SET AG("ED")=11
+29 IF AG("ED")=7
SET AG("ED")=8
+30 IF AG("ED")=9
SET AG("ED")="11A"
+31 ;AG*7.1*7
IF AG("ED")=10
SET AG("ED")="10A"
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
TRBCHK ;
+1 IF $PIECE($GET(^AUTTTRI($ORDER(^AUTTTRI("B",$EXTRACT(Y,1,30),0)),0)),U,4)="Y"
Begin DoDot:1
+2 IF $X<50
WRITE ?50
+3 IF $X>50
WRITE !?33
+4 WRITE $$S^AGVDF("RVN"),"(OLD UNUSED TRIBE NAME)",$$S^AGVDF("RVF")
End DoDot:1
QUIT
+5 IF $PIECE($GET(^AUTTTRI($ORDER(^AUTTTRI("B",$EXTRACT(Y,1,30),0)),0)),U,2)=999
Begin DoDot:1
+6 WRITE $$S^AGVDF("RVN")," <- PLEASE SPECIFY IF KNOWN",$$S^AGVDF("RVF")
End DoDot:1
QUIT
+7 IF "YC"[AGOPT(14)
Begin DoDot:1
+8 SET DR=1119
+9 KILL AGRES
+10 SET TEMPDIC=DIC
+11 SET DIQ="AGRES"
SET DIQ(0)="E"
DO EN^DIQ1
+12 SET DIC=TEMPDIC
+13 WRITE $GET(AGRES(DIC,DFN,DR,"E"))
+14 KILL AGRES,TEMPDIC,AGRES
End DoDot:1
+15 QUIT
EMPLR ;EP - Patient's Employer.
+1 SET AGEL("ONUM")=$PIECE($GET(^AUTNEMPL(0)),U,4)
+2 WRITE !
+3 KILL DIR,DIE,DR,DIC
+4 SET DIE="^AUPNPAT("
+5 ;IF EMPLOYMENT STATUS FULL OR PART TIME
+6 IF ($PIECE($GET(^AUPNPAT(DFN,0)),U,21)=1!($PIECE($GET(^AUPNPAT(DFN,0)),U,21)=2))
IF $$ISREQ^AGFLDREQ(9000001,.19)
SET DIE("NO^")=""
SET DR=".19R"
+7 IF '$TEST
SET DR=.19
+8 SET DA=DFN
+9 DO ^DIE
+10 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,19)=""
IF $PIECE($GET(^(0)),U,21)]""
IF "39"'[$PIECE($GET(^(0)),U,21)
Begin DoDot:1
+11 SET DR=".21///@"
+12 DO ^DIE
+13 KILL DIE,DIC,DR
End DoDot:1
+14 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,19)=""
QUIT
+15 SET AGEL("EMP")=$PIECE($GET(^AUPNPAT(DFN,0)),U,19)
+16 IF $PIECE($GET(^AUTNEMPL(0)),U,4)'=AGEL("ONUM")
DO EMPL
EMST ;GET PATIENT'S EMPLOYMENT STATUS
+1 WRITE !
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 SET DR=.21
+5 DO ^DIE
+6 KILL DIC,DR,DIE
+7 KILL AGEL("EMP")
+8 KILL AGEL("ONUM")
+9 QUIT
EMPL ;
+1 SET DIE="^AUTNEMPL("
+2 SET DA=AGEL("EMP")
+3 WRITE !!,"<----------EMPLOYER DEMOGRAPHIC INFO---------->"
+4 SET DR=".02 Street...: ;.03 City.....: ;.04 State....: ;.05 Zip......: ;.06 Phone....: ;.07 Abbrev...: "
+5 DO ^DIE
+6 QUIT
SPSEMP ;EP - Spouse's Employer.
+1 SET AGEL("ONUM")=$PIECE($GET(^AUTNEMPL(0)),U,4)
+2 WRITE !
+3 SET DIE="^AUPNPAT("
+4 SET DR=.22
+5 SET DA=DFN
+6 DO ^DIE
+7 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,22)=""
QUIT
+8 SET AGEL("EMP")=$PIECE($GET(^AUPNPAT(DFN,0)),U,22)
+9 IF $PIECE($GET(^AUTNEMPL(0)),U,4)'=AGEL("ONUM")
DO EMPL
+10 KILL AGEL("EMP")
+11 KILL AGEL("ONUM")
+12 KILL DIE,DIC,DR
+13 QUIT
FEMPL ;FATHER'S EMPLOYER INFO
+1 ;NUMBER OF ENTRIES IN FILE
SET AGEL("ONUM")=$PIECE($GET(^AUTNEMPL(0)),U,4)
+2 WRITE !
+3 SET DIE="^AUPNPAT("
+4 IF $$AGE^AUPNPAT(DFN)>17
SET DR=2701
+5 IF $$AGE^AUPNPAT(DFN)<18
IF $PIECE($GET(^AUPNPAT(DFN,27)),U,2)=""
SET DR="2701R"
+6 IF '$TEST
SET DR=2701
+7 SET DA=DFN
+8 DO ^DIE
+9 IF $PIECE($GET(^AUPNPAT(DFN,27)),U)=""
QUIT
+10 SET AGEL("EMP")=$PIECE($GET(^AUPNPAT(DFN,27)),U)
+11 IF $PIECE($GET(^AUTNEMPL(0)),U,4)'=AGEL("ONUM")
DO EMPL
+12 KILL AGEL("EMP")
+13 KILL AGEL("ONUM")
+14 KILL DIE,DIC,DR
+15 QUIT
MEMPL ;MOTHER'S EMPLOYER INFO
+1 KILL DIE,DIC,DR
+2 ;# OF ENTRIES IN FILE
SET AGEL("ONUM")=$PIECE($GET(^AUTNEMPL(0)),U,4)
+3 WRITE !
+4 SET DIE="^AUPNPAT("
+5 IF $$AGE^AUPNPAT(DFN)>17
SET DR=2702
+6 IF $$AGE^AUPNPAT(DFN)<18
IF $PIECE($GET(^AUPNPAT(DFN,27)),U)=""
SET DR="2702R"
+7 IF '$TEST
SET DR=2702
+8 SET DA=DFN
+9 DO ^DIE
+10 IF $PIECE($GET(^AUPNPAT(DFN,27)),U,2)=""
QUIT
+11 SET AGEL("EMP")=$PIECE($GET(^AUPNPAT(DFN,27)),U,2)
+12 IF $PIECE($GET(^AUTNEMPL(0)),U,4)'=AGEL("ONUM")
DO EMPL
+13 KILL AGEL("EMP")
+14 KILL AGEL("ONUM")
+15 KILL DIE,DIC,DR
+16 QUIT
OTHER ;DISPLAY LAST OTHER TRIBE AND QUANTUM
+1 SET D1=0
+2 SET TRIBE=""
SET QUAN=""
+3 FOR
SET D1=$ORDER(^AUPNPAT(DFN,43,D1))
IF 'D1
QUIT
Begin DoDot:1
+4 SET TRIBE=$PIECE($GET(^AUTTTRI($PIECE($GET(^AUPNPAT(DFN,43,D1,0)),U),0)),U)
+5 SET QUAN=$PIECE($GET(^AUPNPAT(DFN,43,D1,0)),U,2)
End DoDot:1
+6 WRITE ?32,TRIBE
+7 WRITE ?73,$EXTRACT(QUAN,1,6)
+8 QUIT
OTHERT ;ALLOW ADD AND EDIT OF OTHER TRIBES AND QUANTUMS
+1 IF AGOPT(8)'="Y"
QUIT
+2 WRITE !!,"OTHER TRIBES:",?50,"QUANTUM:",!
+3 SET D1=0
+4 FOR
SET D1=$ORDER(^AUPNPAT(DFN,43,D1))
IF 'D1
QUIT
Begin DoDot:1
+5 SET TRIPTR=$PIECE($GET(^AUPNPAT(DFN,43,D1,0)),U)
+6 SET OTRIBE=$PIECE($GET(^AUTTTRI(TRIPTR,0)),U)
+7 SET OQUAN=$PIECE($GET(^AUPNPAT(DFN,43,D1,0)),U,2)
+8 WRITE !,OTRIBE,?50,OQUAN
End DoDot:1
+9 WRITE !!
+10 KILL DIC,DIE,DR
+11 SET DIE="^AUPNPAT("
+12 SET DR=4301
+13 SET DA=DFN
+14 DO ^DIE
+15 DO UPDATE1^AGED(DUZ(2),DFN,12,"")
+16 IF '$ORDER(^AUPNPAT(DFN,43,0))
KILL ^AUPNPAT(DFN,43)
+17 KILL DIC,DIE,DR
+18 QUIT
FATHER ;GET FATHER'S NAME, CITY AND STATE OF BIRTH
+1 KILL DUOUT
+2 KILL DIE
+3 SET DIE="^DPT("
+4 SET DA=DFN
+5 WRITE !
+6 SET DR=.2401
+7 DO ^DIE
+8 IF $DATA(Y)
SET DUOUT=""
+9 KILL DIE,DIC,DR,DUOUT
+10 IF $PIECE($GET(^DPT(DFN,.24)),U)=""
Begin DoDot:1
+11 IF $PIECE($GET(^AUPNPAT(DFN,26)),U,2)'=""
SET $PIECE(^AUPNPAT(DFN,26),U,2)=""
+12 IF $PIECE($GET(^AUPNPAT(DFN,26)),U,3)'=""
SET $PIECE(^AUPNPAT(DFN,26),U,3)=""
End DoDot:1
+13 IF $PIECE($GET(^DPT(DFN,.24)),U)'=""
Begin DoDot:1
+14 SET DIE="^AUPNPAT("
+15 WRITE !
+16 SET DR="2602;2603"
+17 DO ^DIE
+18 IF $DATA(Y)
SET DUOUT=""
+19 KILL DIE,DIC,DR
End DoDot:1
+20 QUIT
+21 ;
MOTHER ;GET MOTHER'S NAME, CITY AND STATE OF BIRTH
+1 KILL DUOUT,DIE
+2 SET DIE="^DPT("
+3 SET DA=DFN
+4 WRITE !
+5 SET DR=.2403
+6 DO ^DIE
+7 IF $DATA(Y)
SET DUOUT=""
+8 KILL DUOUT
+9 IF $PIECE($GET(^DPT(DFN,.24)),U,3)=""
Begin DoDot:1
+10 IF $PIECE($GET(^AUPNPAT(DFN,26)),U,5)'=""
SET $PIECE(^AUPNPAT(DFN,26),U,5)=""
+11 IF $PIECE($GET(^AUPNPAT(DFN,26)),U,6)'=""
SET $PIECE(^AUPNPAT(DFN,26),U,6)=""
End DoDot:1
+12 IF $PIECE($GET(^DPT(DFN,.24)),U,3)'=""
Begin DoDot:1
+13 SET DIE="^AUPNPAT("
+14 WRITE !
+15 SET DR="2605;2606"
+16 DO ^DIE
+17 IF $DATA(Y)
SET DUOUT=""
+18 KILL DIE,DIC,DR
End DoDot:1
+19 QUIT
+20 ;
+21 ;AG*7.1*8 - Added FCPH, FEML, FAPH, MCPH, MEML, MAPH, and DIE tags
+22 ;
FCPH ;EP - Edit Father's Cell Phone
+1 NEW DR
+2 SET DR=2903
+3 DO DIE
+4 QUIT
+5 ;
FEML ;EP - Edit Father's Email Address
+1 NEW DR
+2 SET DR=2901
+3 DO DIE
+4 QUIT
+5 ;
FAPH ;EP - Edit Father's Alternate Phone
+1 NEW DR
+2 SET DR="2902FATHER'S ALT. PHONE"
+3 DO DIE
+4 QUIT
+5 ;
MCPH ;EP - Edit Mother's Cell Phone
+1 NEW DR
+2 SET DR=3003
+3 DO DIE
+4 QUIT
+5 ;
MEML ;EP - Edit Mother's Email Address
+1 NEW DR
+2 SET DR=3001
+3 DO DIE
+4 QUIT
+5 ;
MAPH ;EP - Edit Mother's Alternate Phone
+1 NEW DR
+2 SET DR="3002MOTHER'S ALT. PHONE"
+3 DO DIE
+4 QUIT
+5 ;
DIE ; Do Field Edit
+1 NEW DA,DIE,DUOUT
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 DO ^DIE
+5 QUIT
+6 ;
+7 ;AG*7.1*8 - Added Father/Mother Cell phone/Email/Alt Phone
+8 ;
+9 ; ****************************************************************
+10 ; ON LINES BELOW:
+11 ; PIECE 1= FLD LBL
+12 ; PIECE 2= FLD LENGTH
+13 ; PIECE 3= POSITION ON LINE TO DISP FLD, IF BLANK NEW LINE
+14 ; PIECE 4= FILE #
+15 ; PIECE 5= FLD #
+16 ; PIECE 6= Length (optional)
1 ;
+1 ;;RELIGIOUS PREFERENCE ^27^^2^.08
+2 ;;CLASSIFICATION/BENEFICIARY ^27^^9000001^1111
+3 ;;TRIBE OF MEMBERSHIP ^27^^9000001^1108
+4 ;;TRIBE QUANTUM ^14^^9000001^1109
+5 ;;INDIAN BLOOD QUANTUM ^^40^9000001^1110
+6 ;;TRIBAL ENROLLMENT NO. ^27^^9000001^.07
+7 ;;OTHER TRIBE ^27^^9000001^4301
+8 ;;FATHER'S NAME ^14^^2^.2401^29
+9 ;;CELL PHONE^12^49^9000001^2903
+10 ;;EMAIL ADDRESS^12^^9000001^2901^29
+11 ;;ALT.PHONE^11^49^9000001^2902
+12 ;;MOTHER'S MAIDEN NAME ^21^^2^.2403^20
+13 ;;CELL PHONE^12^48^9000001^3003
+14 ;;EMAIL ADDRESS^12^^9000001^3001^29
+15 ;;ALT.PHONE^11^49^9000001^3002
+16 ;;EMPLOYER NAME ^27^^9000001^.19
+17 ;;SPOUSE'S EMPLOYER NAME ^27^^9000001^.22
+18 ;;FATHER'S EMPLOYER NAME ^27^^9000001^2701
+19 ;;MOTHER'S EMPLOYER NAME ^27^^9000001^2702
