AGED10A.m

AGED10A ; VNGT/HS/BEE - EDIT PG 10 - ETHNICITY/RACE/LANGUAGE/MIGRANT/HOMELESS/INTERNET/HOUSEHOLD INFO ; MAR 19, 2010   

 ;;7.1;PATIENT REGISTRATION;**7,8,9,10,11**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES

 ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD

 ;IHS/OIT/NKD AG*7.1*11 MU2 PHR FIELDS

 ;

VAR N AG,AGI,AGY,CLLST,DFOUT,DIR,DIROUT,DLOUT,DQOUT,DTOUT,DUOUT,DIRUT,DOTS,MYERRS,MYVARS,ROUTID,Y

 ;

 ;Initialize variables

 S ROUTID=$P($T(+1)," ")  ;SET ROUTINE ID FOR PROGRAMMER VIEW

 S $P(DOTS,".",22)="."

 ;

 ;Draw the page

 D DRAW

 ;

 ;Quit if View Mode

 Q:$D(AGSEENLY)

 ;

 ;Print Header

 W !,AGLINE("EQ")

 ;

 K AG("ER")

 ;

 ;Prompt user for input

 K DIR S DIR("A")="CHANGE which item? (1-"_AG("E")_") NONE//" D READ

 I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) D  H 3 D KILL G VAR

 . W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"

 ;

 ;Quit on "^^" entry

 I Y=AGOPT("ESCAPE") S DIROUT=1 G END

 ;

 ;Additional exit handling

 I $D(DFOUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)!$D(DLOUT)!(Y["N") G END

 ;

 ;Loop if there is still an error

 I $D(AG("ERR")) D KILL G VAR

 ;

 ;Switch Pages

 I $D(AG("ED"))&('$D(AGXTERN)) N PAGE S PAGE=AG("ED") D KILL S AG("ED")=PAGE K PAGE G @("^AGED"_AG("ED"))

 ;

 ;Edit field(s)

 I $D(DQOUT)!(+Y<1)!(+Y>AG("E")) W !!,"You must enter a number from 1 to ",AG("E") H 2 D KILL G VAR

 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,"")

 D KILL

 G VAR

END ;

 I $D(AGXTERN)!$D(DIROUT)!$D(DTOUT)!$D(DFOUT) D KILL Q

 I $D(DUOUT) D KILL G ^AGED11A

 D KILL

 Q

 ;

 ;Variable clean up

KILL K AG,AGI,AGY,CLLST,DFOUT,DIR,DIROUT,DLOUT,DQOUT,DTOUT,DUOUT,DIRUT,DOTS,MYERRS,MYVARS,ROUTID,Y

 Q

 ;

DRAW ;EP

 N CALLS

 ;S CALLS="ETHNIC^AGED10B,RACE^AGED10B,LANG^AGED10B,PREF^AGED10B(0),MIG,HOM,WEB^AGED1,EDEMAIL^AGED1,PERM,PREF,NIH^AGED10B,THI^AGED10B" ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 S CALLS="ETHNIC^AGED10B,RACE^AGED10B,LANG^AGED10B,PREF^AGED10B(0),MIG,HOM,WEB^AGED1,EDEMAIL^AGED1,PERM,PREF,PHRA^AGPHROPT(AGPATDFN),PHRH^AGPHROPT(AGPATDFN),NIH^AGED10B,THI^AGED10B"

 S AG("PG")=10

 ;S AG("N")=12 ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 S AG("N")=14

 ;S AG("E")=12 S:AGOPT(22)="N" AG("E")=10 ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 S AG("E")=14 S:AGOPT(22)="N" AG("E")=12

 S:$G(AGOPT(26))'="Y" AG("E")=AG("E")-1

 S:$G(AGOPT(27))'="Y" AG("E")=AG("E")-1

 S CLLST=0

 ;

 D ^AGED   ;Main editor routine - Print Header

 ;

 F AG=1:1:AG("N") D

 . ;

 . N AGSCRN,LBL,DIC,DR

 . S AGSCRN=$P($T(@1+AG),";;",2,17)

 . S LBL=$P(AGSCRN,U)                ;Label

 . S DIC=$P(AGSCRN,U,2)              ;File

 . S DR=$P(AGSCRN,U,3)               ;Field #

 . ;

 . ;Draw line

 . I (AG=5),($G(AGOPT(26))="Y"!($G(AGOPT(27))="Y")) W !,AGLINE("-")

 . I AG=7 W !,AGLINE("-")

 . ;I (AG=11),AGOPT(22)'="N" W !,AGLINE("-") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 . I (AG=13),AGOPT(22)'="N" W !,AGLINE("-")

 . ;

 . ;I (AG=11)!(AG=12),AGOPT(22)="N" Q ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 . I (AG=13)!(AG=14),AGOPT(22)="N" Q

 . I AG=5,$G(AGOPT(26))'="Y" Q

 . I AG=6,$G(AGOPT(27))'="Y" Q

 . ;

 . S CLLST=CLLST+1,CLLST(CLLST)=$P(CALLS,",",AG)

 . ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS - START OLD CODE

 . ;I AG=10 W ?38,CLLST,". ",LBL,": " 

 . ;E  W !,CLLST,". ",LBL,$E(DOTS,1,22-$L(LBL)),": "

 . ;IHS/OIT/NKD AG*7.1*11 END OLD CODE - START NEW CODE

 . I (AG=10)!(AG=12) W ?38,CLLST,". ",LBL,": "

 . E  W !,CLLST,". ",LBL,$S(AG=11:"",1:$E(DOTS,1,22-$L(LBL))),": "

 . ;IHS/OIT/NKD AG*7.1*11 END NEW CODE

 . ;

 . ;Special code for Ethnicity

 . I AG=1 D  Q

 .. N ETHNIC S ETHNIC=$O(^DPT(DFN,.06,0))

 .. I ETHNIC S ETHNIC=$$GET1^DIQ(2.06,ETHNIC_","_DFN_",",".01","E")

 .. W $E($G(ETHNIC),1,25)

 . ;

 . ;Display Race

 . ;IHS/OIT/NKD AG*7.1*11 MU2 - CHANGED DISPLAY TO USE MULTIPLE FIELD - START NEW CODE

 . ;I AG=2 W $$GET1^DIQ(DIC,DFN,DR) Q

 . I AG=2 D  Q

 .. N RACE S RACE=$$RACE^AGUTL(DFN)

 .. Q:+RACE<1

 .. ;IF MORE THAN ONE RACE IN MULTIPLE, DISPLAY "MORE THAN ONE RACE"

 .. W $S(+RACE>1:"MORE THAN ONE RACE",1:$P(RACE,"^",2))

 . ;IHS/OIT/NKD AG*7.1*11 END NEW CODE

 . ;

 . ;Display Some Language Information

 . I AG=3 D  Q

 .. N LNG,OLNG

 .. S LNG=$$CLANG^AGED10B(AGPATDFN,.OLNG)

 .. W $E($P($P(LNG,U,2),":",2),1,21)

 .. ;

 .. W ?50,"Interpreter required? ",$P($P(LNG,U,3),":",2)

 .. W !,?5,"Other languages spoken: ",$P(LNG,U,5)

 . ;

 . ;Display Preferred Language

 . I AG=4 W $P($P($$CLANG^AGED10B(AGPATDFN),U,4),":",2) Q

 . ;

 . ;Display Migrant information

 . I AG=5,$G(AGOPT(26))="Y" D  Q  ;AG*7.1*9 - Added reg parameter check

 .. N MIG,UPD

 .. S MIG=$$CMIG(AGPATDFN)

 .. W $P($P(MIG,U,3),":",2)

 .. W ?32,"Type: ",$E($P($P(MIG,U,4),":",2),1,23)

 .. S UPD=$P($P(MIG,U,2),":",2) W ?63 W:UPD]"" $J("(upd "_UPD_")",17)

 . ;

 . ;Display Homeless information

 . I AG=6,$G(AGOPT(27))="Y" D  Q  ;AG*7.1*9 - Added reg parameter check

 .. N HOM,UPD

 .. S HOM=$$CHOM(AGPATDFN)

 .. W $P($P(HOM,U,3),":",2)

 .. W ?32,"Type: ",$E($P($P(HOM,U,4),":",2),1,23)

 .. S UPD=$P($P(HOM,U,2),":",2) W ?63 W:UPD]"" $J("(upd "_UPD_")",17)

 . ;

 . ;Display Internet Access

 . I AG=7 D  Q

 .. N LSTUPD,LSTREC,ACCESS,WHERE,Y,WIEN

 .. S (LSTUPD,ACCESS,WHERE)=""

 .. ;

 .. ;Pull latest entry

 .. D

 ... S LSTUPD=$O(^AUPNPAT(DFN,81,"B",""),-1)

 ... Q:LSTUPD=""

 ... S LSTREC=$O(^AUPNPAT(DFN,81,"B",LSTUPD,""),-1)

 ... Q:LSTREC=""

 ... S ACCESS=$$GET1^DIQ(9000001.81,LSTREC_","_DFN_",",.02,"E")

 ... ;

 ... ;Get list of WHERE values

 ... S WHERE="",WIEN=0 F  S WIEN=$O(^AUPNPAT(DFN,81,LSTREC,1,WIEN)) Q:'WIEN  D

 .... S WHERE=WHERE_$S(WHERE="":"",1:", ")_$$GET1^DIQ(9000001.811,WIEN_","_LSTREC_","_DFN_",",.01,"I")

 ... ;S WHERE=$$GET1^DIQ(9000001.81,LSTREC_","_DFN_",",.03)

 ... S Y=LSTUPD X ^DD("DD") S LSTUPD=Y

 .. W ?25,ACCESS

 .. W ?32,"Where: ",$E(WHERE,1,23)

 .. W ?63 W:LSTUPD]"" $J("(upd "_LSTUPD_")",17)  ;AG*7.1*8 - Disabled

 . ;

 . ;Email Address

 . I AG=8 W $$GET1^DIQ(9000001,DFN_",",1802)

 . ;

 . ;Generic Health Permission

 . I AG=9 W $$GET1^DIQ(9000001,DFN_",",4001)

 . ;

 . ;Preferred Method

 . I AG=10 W $$GET1^DIQ(9000001,DFN_",",4002)

 . ;

 . ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS - START NEW CODE

 . ;PHR Access/Handout

 . I AG=11 W $$PHRAP^AGPHROPT(DFN)

 . I AG=12 W $$PHRHP^AGPHROPT(DFN)

 . ;IHS/OIT/NKD AG*7.1*11 END NEW CODE

 . ;

 . ;Number in Household/Total Household Income/Household Income Period

 . ;I AG=11!(AG=12),AGOPT(22)="Y" W $$GET1^DIQ(DIC,DFN_",",DR,"E") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 . I AG=13!(AG=14),AGOPT(22)="Y" W $$GET1^DIQ(DIC,DFN_",",DR,"E")

 . ;I AG=12,AGOPT(22)="Y" W ?40,"/  ",$$GET1^DIQ(9000001,DFN_",",8701,"E") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 . I AG=14,AGOPT(22)="Y" W ?40,"/  ",$$GET1^DIQ(9000001,DFN_",",8701,"E")

 ;

 W !,AGLINE("-")

 ;

 ;Error Checking/Display

 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

 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=1

 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" D

 . S AG("ED")=+$P($E(Y,2,99),".")

 . I AG("ED")<1!(AG("ED")>10) D

 .. W *7,!!,"Use only pages 1 through 10."

 .. H 2

 .. K AG("ED")

 .. S AG("ERR")=""

 . I $D(AG("ED"))  D

 .. I AG("ED")>0&(AG("ED")<11)  D

 ... 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"

 Q

 ;

MIG ;EP - EDIT Migrant Worker prompts

MIG1 ;

 N DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y

 ;

 ;Get current value

 S DEF=$$CMIG(AGPATDFN)

 S MTYP=$P($P(DEF,U,4),":")

 S DEF=$P($P(DEF,U,3),":",2)

 S:DEF]"" DIR("B")=DEF

 ;

 S DIR(0)="SOA^Y:YES;N:NO"

 S DIR("A")="Migrant Worker?: " D ^DIR

 I $D(DIROUT)!$D(DTOUT)!$D(DUOUT) Q

 S MIG=$G(Y)

 ;

 ;If Null/Delete and no default show warning and ask again

 ;I MIG="",DEF="" W "??  Required" K DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y G MIG1

 I MIG="",DEF="" Q   ;AG*7.1*9 - No longer required

 ;

 ;Define new entry and save

 S DIC="^AUPNPAT("_AGPATDFN_",84,",DA(1)=AGPATDFN

 S DIC(0)="L"

 S X=DT

 S DLAYGO="9000001.84",DIC("P")=DLAYGO

 I '$D(^AUPNPAT(AGPATDFN,84,0)) S ^AUPNPAT(AGPATDFN,84,0)="^9000001.84D^^"

 K DO,DD D FILE^DICN

 S (MIEN,DA)=+Y,DA(1)=AGPATDFN

 S AMIG(9000001.84,DA_","_DA(1)_",",".02")=$S(MIG'="":MIG,1:"@")

 S AMIG(9000001.84,DA_","_DA(1)_",",".03")=$S(((MIG="")!(MIG="N")):"@",1:MTYP)

 D FILE^DIE("","AMIG","ERROR")

 ;

 ;If a Null/delete ask again

 I MIG="" S DEF="" K DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y G MIG1

 ;

 ;Migrant Worker Type - only do if "YES"

 I MIG="Y" D MTYPE(MIEN)

 ;

 Q

 ;

MTYPE(MIEN) ;EP - EDIT Migrant Worker Type prompt

MTYPE1 ;

 ;

 N CMTYP,DA,DR,DIE,DTOUT,MTYP,Y

 ;

 ;Retrieve current value

 S CMTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")

 ;

 S DIE="^AUPNPAT("_AGPATDFN_",84,"

 S DA=MIEN

 S DR=".03Type"

 D ^DIE

 I $D(DTOUT)!$D(Y) Q

 ;

 S MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")

 I MTYP="",CMTYP]"" K CMTYP,DA,DR,DIE,DTOUT,MTYP,Y G MTYPE1

 ;I MTYP="" K CMTYP,DA,DR,DIE,DTOUT,MTYP,Y W "??  Required" G MTYPE1  ;AG*7.1*9 - No longer required

 ;

 Q

 ;

CMIG(AGPATDFN) ;Return the patients most recent Migrant information

 ;

 N MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX,Y

 ;

 S (MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX)=""

 S MDT=$O(^AUPNPAT(AGPATDFN,84,"B",""),-1)

 I MDT]"" S MIEN=$O(^AUPNPAT(AGPATDFN,84,"B",MDT,""),-1)

 S Y=MDT X ^DD("DD") S MDTX=Y

 I MIEN]"" S MSTS=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","I")

 I MIEN]"" S MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")

 I MIEN]"" S MSTSX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","E")

 I MIEN]"" S MTYPX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")

 ;

 Q MIEN_U_MDT_":"_MDTX_U_MSTS_":"_MSTSX_U_MTYP_":"_MTYPX

 ;

HOM ;EP - EDIT Homeless prompts

HOM1 ;

 N DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y

 ;

 ;Get current value

 S DEF=$$CHOM(AGPATDFN)

 S HTYP=$P($P(DEF,U,4),":")

 S DEF=$P($P(DEF,U,3),":",2)

 S:DEF]"" DIR("B")=DEF

 ;

 S DIR(0)="SOA^Y:YES;N:NO"

 S DIR("A")="Homeless?: " D ^DIR

 I $D(DIROUT)!$D(DTOUT)!$D(DUOUT) Q

 S HOM=$G(Y)

 ;

 ;If Null/Delete and no default show warning and ask again

 ;I HOM="",DEF="" W "??  Required" K DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y G HOM1

 I HOM="",DEF="" Q   ;AG*7.1*9 - No longer required

 ;

 ;Define new entry and save

 S DIC="^AUPNPAT("_AGPATDFN_",85,",DA(1)=AGPATDFN

 S DIC(0)="L"

 S X=DT

 S DLAYGO="9000001.85",DIC("P")=DLAYGO

 I '$D(^AUPNPAT(AGPATDFN,85,0)) S ^AUPNPAT(AGPATDFN,85,0)="^9000001.85D^^"

 K DO,DD D FILE^DICN

 S (HIEN,DA)=+Y,DA(1)=AGPATDFN

 S AHOM(9000001.85,DA_","_DA(1)_",",".02")=$S(HOM'="":HOM,1:"@")

 S AHOM(9000001.85,DA_","_DA(1)_",",".03")=$S(((HOM="")!(HOM="N")):"@",1:HTYP)

 D FILE^DIE("","AHOM","ERROR")

 ;

 ;If a Null/delete ask again

 I HOM="" S DEF="" K DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y G HOM1

 ;

 ;Homeless Type - only do if "YES"

 I HOM="Y" D HTYPE(HIEN)

 ;

 Q

 ;

HTYPE(HIEN) ;EP - EDIT Homeless Type prompt

HTYPE1 ;

 N CHTYP,DA,DR,DIE,DTOUT,HTYP,Y

 ;

 ;Retrieve current value

 S CHTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")

 ;

 S DIE="^AUPNPAT("_AGPATDFN_",85,"

 S DA=HIEN

 S DR=".03Type"

 D ^DIE

 I $D(DTOUT)!$D(Y) Q

 ;

 S HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")

 I HTYP="",CHTYP]"" K CHTYP,DA,DR,DIE,DTOUT,HTYP,Y G HTYPE1

 ;I HTYP="" K CMTYP,DA,DR,DIE,DTOUT,HTYP,Y W "?? Required" G HTYPE1  ;AG*7.1*9 - No longer required

 ;

 Q

 ;

CHOM(AGPATDFN) ;Return the patients most recent Homeless information

 ;

 N HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX,Y

 ;

 S (HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX)=""

 S HDT=$O(^AUPNPAT(AGPATDFN,85,"B",""),-1)

 I HDT]"" S HIEN=$O(^AUPNPAT(AGPATDFN,85,"B",HDT,""),-1)

 S Y=HDT X ^DD("DD") S HDTX=Y

 I HIEN]"" S HSTS=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","I")

 I HIEN]"" S HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")

 I HIEN]"" S HSTSX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","E")

 I HIEN]"" S HTYPX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")

 ;

 Q HIEN_U_HDT_":"_HDTX_U_HSTS_":"_HSTSX_U_HTYP_":"_HTYPX

 ;

PERM ; EP - Edit GENERIC HEALTH PERMISSION prompt

 ;

 N DIE,DA,DR

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR="4001Do we have permission to send generic health information to your email address?"

 D ^DIE

 ;

 Q

 ;

PREF ; EP - Edit PREFERRED METHOD prompt

 ;

 N DIE,DA,DR

 S DIE="^AUPNPAT("

 S DA=DFN

 ;IHS/OIT/NKD AG*7.1*11 MU2 CHANGED WORDING ON PREFERRED METHOD

 ;S DR="4002WHAT IS YOUR PREFERRED METHOD TO RECEIVE REMINDERS?"

 S DR="4002WHAT IS YOUR PREFERRED METHOD OF COMMUNICATIONS?"

 D ^DIE

 ;

 Q

 ;

 ; ****************************************************************

 ; ON LINES BELOW:

 ; PIECE 1= FLD LBL

 ; PIECE 2= FILE #

 ; PIECE 3= FLD #

1 ;

 ;;Ethnicity^2^6

 ;;Race^2^2

 ;;Primary Language

 ;;Preferred Language

 ;;Migrant Worker?

 ;;Homeless?

 ;;Internet Access^9000001.81^.01

 ;;EMAIL ADDRESS^9000001^1802

 ;;GENERIC HEALTH PERMISSION^9000001^4001

 ;;PREFERRED METHOD^9000001^4002

 ;;PHR ACCESS

 ;;PHR HANDOUT

 ;;Number in Household^9000001^.35

 ;;Total Household Income^9000001^.36

AGED10A   ; VNGT/HS/BEE - EDIT PG 10 - ETHNICITY/RACE/LANGUAGE/MIGRANT/HOMELESS/INTERNET/HOUSEHOLD INFO ; MAR 19, 2010   

 +1       ;;7.1;PATIENT REGISTRATION;**7,8,9,10,11**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES

 +3       ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD

 +4       ;IHS/OIT/NKD AG*7.1*11 MU2 PHR FIELDS

 +5       ;

VAR        NEW AG,AGI,AGY,CLLST,DFOUT,DIR,DIROUT,DLOUT,DQOUT,DTOUT,DUOUT,DIRUT,DOTS,MYERRS,MYVARS,ROUTID,Y

 +1       ;

 +2       ;Initialize variables

 +3       ;SET ROUTINE ID FOR PROGRAMMER VIEW

           SET ROUTID=$PIECE($TEXT(+1)," ")

 +4        SET $PIECE(DOTS,".",22)="."

 +5       ;

 +6       ;Draw the page

 +7        DO DRAW

 +8       ;

 +9       ;Quit if View Mode

 +10       IF $DATA(AGSEENLY)

               QUIT 

 +11      ;

 +12      ;Print Header

 +13       WRITE !,AGLINE("EQ")

 +14      ;

 +15       KILL AG("ER")

 +16      ;

 +17      ;Prompt user for input

 +18       KILL DIR

           SET DIR("A")="CHANGE which item? (1-"_AG("E")_") NONE//"

           DO READ

 +19       IF $DATA(MYERRS("C","E"))

               IF (Y'?1N.N)

                   IF (Y'=AGOPT("ESCAPE"))

                       Begin DoDot:1

 +20                       WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"

                       End DoDot:1

                       HANG 3

                       DO KILL

                       GOTO VAR

 +21      ;

 +22      ;Quit on "^^" entry

 +23       IF Y=AGOPT("ESCAPE")

               SET DIROUT=1

               GOTO END

 +24      ;

 +25      ;Additional exit handling

 +26       IF $DATA(DFOUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DLOUT)!(Y["N")

               GOTO END

 +27      ;

 +28      ;Loop if there is still an error

 +29       IF $DATA(AG("ERR"))

               DO KILL

               GOTO VAR

 +30      ;

 +31      ;Switch Pages

 +32       IF $DATA(AG("ED"))&('$DATA(AGXTERN))

               NEW PAGE

               SET PAGE=AG("ED")

               DO KILL

               SET AG("ED")=PAGE

               KILL PAGE

               GOTO @("^AGED"_AG("ED"))

 +33      ;

 +34      ;Edit field(s)

 +35       IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("E"))

               WRITE !!,"You must enter a number from 1 to ",AG("E")

               HANG 2

               DO KILL

               GOTO VAR

 +36       SET AGY=Y

 +37      ;AG*7.1*10;Added next line to stop bad user entry errors

 +38       IF $TRANSLATE(AGY,",")'?1N.N

               WRITE !!,"Invalid entry - Enter a line number or line numbers separated by a ',' to edit"

               HANG 3

               GOTO VAR

 +39       FOR AGI=1:1

               SET AG("SEL")=+$PIECE(AGY,",",AGI)

               IF AG("SEL")<1!(AG("SEL")>AG("E"))

                   QUIT 

               Begin DoDot:1

 +40               DO @(CLLST(AG("SEL")))

               End DoDot:1

 +41       DO UPDATE1^AGED(DUZ(2),DFN,2,"")

 +42       DO KILL

 +43       GOTO VAR

END       ;

 +1        IF $DATA(AGXTERN)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DFOUT)

               DO KILL

               QUIT 

 +2        IF $DATA(DUOUT)

               DO KILL

               GOTO ^AGED11A

 +3        DO KILL

 +4        QUIT 

 +5       ;

 +6       ;Variable clean up

KILL       KILL AG,AGI,AGY,CLLST,DFOUT,DIR,DIROUT,DLOUT,DQOUT,DTOUT,DUOUT,DIRUT,DOTS,MYERRS,MYVARS,ROUTID,Y

 +1        QUIT 

 +2       ;

DRAW      ;EP

 +1        NEW CALLS

 +2       ;S CALLS="ETHNIC^AGED10B,RACE^AGED10B,LANG^AGED10B,PREF^AGED10B(0),MIG,HOM,WEB^AGED1,EDEMAIL^AGED1,PERM,PREF,NIH^AGED10B,THI^AGED10B" ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 +3        SET CALLS="ETHNIC^AGED10B,RACE^AGED10B,LANG^AGED10B,PREF^AGED10B(0),MIG,HOM,WEB^AGED1,EDEMAIL^AGED1,PERM,PREF,PHRA^AGPHROPT(AGPATDFN),PHRH^AGPHROPT(AGPATDFN),NIH^AGED10B,THI^AGED10B"

 +4        SET AG("PG")=10

 +5       ;S AG("N")=12 ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 +6        SET AG("N")=14

 +7       ;S AG("E")=12 S:AGOPT(22)="N" AG("E")=10 ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 +8        SET AG("E")=14

           IF AGOPT(22)="N"

               SET AG("E")=12

 +9        IF $GET(AGOPT(26))'="Y"

               SET AG("E")=AG("E")-1

 +10       IF $GET(AGOPT(27))'="Y"

               SET AG("E")=AG("E")-1

 +11       SET CLLST=0

 +12      ;

 +13      ;Main editor routine - Print Header

           DO ^AGED

 +14      ;

 +15       FOR AG=1:1:AG("N")

               Begin DoDot:1

 +16      ;

 +17               NEW AGSCRN,LBL,DIC,DR

 +18               SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,17)

 +19      ;Label

                   SET LBL=$PIECE(AGSCRN,U)

 +20      ;File

                   SET DIC=$PIECE(AGSCRN,U,2)

 +21      ;Field #

                   SET DR=$PIECE(AGSCRN,U,3)

 +22      ;

 +23      ;Draw line

 +24               IF (AG=5)

                       IF ($GET(AGOPT(26))="Y"!($GET(AGOPT(27))="Y"))

                           WRITE !,AGLINE("-")

 +25               IF AG=7

                       WRITE !,AGLINE("-")

 +26      ;I (AG=11),AGOPT(22)'="N" W !,AGLINE("-") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 +27               IF (AG=13)

                       IF AGOPT(22)'="N"

                           WRITE !,AGLINE("-")

 +28      ;

 +29      ;I (AG=11)!(AG=12),AGOPT(22)="N" Q ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS

 +30               IF (AG=13)!(AG=14)

                       IF AGOPT(22)="N"

                           QUIT 

 +31               IF AG=5

                       IF $GET(AGOPT(26))'="Y"

                           QUIT 

 +32               IF AG=6

                       IF $GET(AGOPT(27))'="Y"

                           QUIT 

 +33      ;

 +34               SET CLLST=CLLST+1

                   SET CLLST(CLLST)=$PIECE(CALLS,",",AG)

 +35      ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS - START OLD CODE

 +36      ;I AG=10 W ?38,CLLST,". ",LBL,": " 

 +37      ;E  W !,CLLST,". ",LBL,$E(DOTS,1,22-$L(LBL)),": "

 +38      ;IHS/OIT/NKD AG*7.1*11 END OLD CODE - START NEW CODE

 +39               IF (AG=10)!(AG=12)

                       WRITE ?38,CLLST,". ",LBL,": "

 +40              IF '$TEST

                       WRITE !,CLLST,". ",LBL,$SELECT(AG=11:"",1:$EXTRACT(DOTS,1,22-$LENGTH(LBL))),": "

 +41      ;IHS/OIT/NKD AG*7.1*11 END NEW CODE

 +42      ;

 +43      ;Special code for Ethnicity

 +44               IF AG=1

                       Begin DoDot:2

 +45                       NEW ETHNIC

                           SET ETHNIC=$ORDER(^DPT(DFN,.06,0))

 +46                       IF ETHNIC

                               SET ETHNIC=$$GET1^DIQ(2.06,ETHNIC_","_DFN_",",".01","E")

 +47                       WRITE $EXTRACT($GET(ETHNIC),1,25)

                       End DoDot:2

                       QUIT 

 +48      ;

 +49      ;Display Race

 +50      ;IHS/OIT/NKD AG*7.1*11 MU2 - CHANGED DISPLAY TO USE MULTIPLE FIELD - START NEW CODE

 +51      ;I AG=2 W $$GET1^DIQ(DIC,DFN,DR) Q

 +52               IF AG=2

                       Begin DoDot:2

 +53                       NEW RACE

                           SET RACE=$$RACE^AGUTL(DFN)

 +54                       IF +RACE<1

                               QUIT 

 +55      ;IF MORE THAN ONE RACE IN MULTIPLE, DISPLAY "MORE THAN ONE RACE"

 +56                       WRITE $SELECT(+RACE>1:"MORE THAN ONE RACE",1:$PIECE(RACE,"^",2))

                       End DoDot:2

                       QUIT 

 +57      ;IHS/OIT/NKD AG*7.1*11 END NEW CODE

 +58      ;

 +59      ;Display Some Language Information

 +60               IF AG=3

                       Begin DoDot:2

 +61                       NEW LNG,OLNG

 +62                       SET LNG=$$CLANG^AGED10B(AGPATDFN,.OLNG)

 +63                       WRITE $EXTRACT($PIECE($PIECE(LNG,U,2),":",2),1,21)

 +64      ;

 +65                       WRITE ?50,"Interpreter required? ",$PIECE($PIECE(LNG,U,3),":",2)

 +66                       WRITE !,?5,"Other languages spoken: ",$PIECE(LNG,U,5)

                       End DoDot:2

                       QUIT 

 +67      ;

 +68      ;Display Preferred Language

 +69               IF AG=4

                       WRITE $PIECE($PIECE($$CLANG^AGED10B(AGPATDFN),U,4),":",2)

                       QUIT 

 +70      ;

 +71      ;Display Migrant information

 +72      ;AG*7.1*9 - Added reg parameter check

                   IF AG=5

                       IF $GET(AGOPT(26))="Y"

                           Begin DoDot:2

 +73                           NEW MIG,UPD

 +74                           SET MIG=$$CMIG(AGPATDFN)

 +75                           WRITE $PIECE($PIECE(MIG,U,3),":",2)

 +76                           WRITE ?32,"Type: ",$EXTRACT($PIECE($PIECE(MIG,U,4),":",2),1,23)

 +77                           SET UPD=$PIECE($PIECE(MIG,U,2),":",2)

                               WRITE ?63

                               IF UPD]""

                                   WRITE $JUSTIFY("(upd "_UPD_")",17)

                           End DoDot:2

                           QUIT 

 +78      ;

 +79      ;Display Homeless information

 +80      ;AG*7.1*9 - Added reg parameter check

                   IF AG=6

                       IF $GET(AGOPT(27))="Y"

                           Begin DoDot:2

 +81                           NEW HOM,UPD