AGED10B.m

AGED10B ; VNGT/HS/BEE - EDIT PG 10 - ETHNICITY/RACE/LANGUAGE/MIGRANT/HOMELESS/INTERNET/HOUSEHOLD INFO (CONT) ; 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 LOGIC FOR DECLINED TO ANSWER - LANGUAGE

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

 ;

LANG ;EP - EDIT PATIENT'S PRIMARY LANGUAGE

 ;

 N LIEN

LANG1 N CHK,DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,OPRMX,PLANG,PRM,PRMX,Y

 ;

 ;If no current entry selected, add new one

 I $G(LIEN)="" S LIEN=$$NEWLG(AGPATDFN)

 ;

 ;Pull current value

 S DA=LIEN,DA(1)=AGPATDFN,OPRMX=""

 S IENS=$$IENS^DILF(.DA)

 S OPRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 I OPRM]"" S OPRMX=$$GET1^DIQ(9999999.99,OPRM_",",".01","E")

 ;

 ;Edit the PRIMARY LANGUAGE field

 S DIE="^AUPNPAT("_DA(1)_",86,"

 S DR=".02Add the PRIMARY LANGUAGE spoken at home by the patient"

 D ^DIE

 ;

 ;Check for value

 S PRMX="",PRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 I PRM]"" S PRMX=$$GET1^DIQ(9999999.99,PRM_",",".01","E")

 ;

 ;IHS/OIT/NKD AG*7.1*11 MU2 - DECLINED TO ANSWER - START NEW CODE

 ;REMOVE OTHER LANGUAGES ENTRY

 I PRMX="DECLINED TO ANSWER" D

 . N AGRES,AGCNT,Y

 . D GETS^DIQ(9000001.86,IENS,".05*",,"AGRES")

 . S AGCNT=0 F  S AGCNT=$O(AGRES(9000001.8605,AGCNT)) Q:'AGCNT  D

 . . S AGRES(9000001.8605,AGCNT,.01)="@"

 . D UPDATE^DIE(,"AGRES",)

 ;END NEW CODE

 ;

 ;Check Other Languages - Proficiency Handling

 S CHK=$$CHKENG(IENS)

 I $P(CHK,U,2)=0 D

 . I (PRMX'="ENGLISH")!((OPRMX'="ENGLISH")&(PRMX="ENGLISH")) D

 .. N PLANG,ERROR

 .. S PLANG("9000001.86",IENS,".06")="@"

 .. D FILE^DIE("","PLANG","ERROR")

 ;

 ;Erase Interpreter - If primary is blank or set to ENGLISH

 I PRMX=""!(PRMX="ENGLISH") D

 . N PLANG,ERROR

 . S PLANG("9000001.86",IENS,".03")="@"

 . D FILE^DIE("","PLANG","ERROR")

 ;

 ;Remove Preferred if no languages

 I PRMX="",$P(CHK,U)=0 D

 . N PLANG,ERROR

 . S PLANG(9000001.86,IENS,".04")="@"

 . D FILE^DIE("","PLANG","ERROR")

 ;

 ;Quit on "^"

 I $D(Y) G XLANG

 ;

 ;Check for value

 I PRM="",OPRM]"" K DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,PLANG,PRM,PRMX,Y G LANG1

 I PRM="",$$RQPRM^AGEDERR4(DUZ(2)) W "?? Required" K DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,PLANG,PRM,PRMX,Y G LANG1

 ;

 ;English Handling - If English need proficiency, If not English need Interpreter

 ;

 ;PRIMARY is not ENGLISH

 I PRMX'="ENGLISH" D  I $D(DIROUT)!$D(DTOUT)!$D(DUOUT)!$D(DIRUT) G XLANG

 . ;

 . ;Ask for Interpreter

 . D INTRP(LIEN)

 ;

 ;PRIMARY is ENGLISH

 I PRMX="ENGLISH" D  I $G(DTOUT)=1 G XLANG

 . ;

 . ;Ask for Proficiency

 . S DTOUT=$$PROF(LIEN)

 ;

 ;Other Languages Spoken

 ;D OLNG(LIEN)  ;IHS/OIT/NKD AG*7.1*11 MU2 - ASK OTHER LANGUAGES ONLY IF PRIMARY ISN'T DECLINED

 I PRMX'="DECLINED TO ANSWER" D OLNG(LIEN)

 ;

 ;Check if Proficiency needs to be asked (ENGLISH was entered in Other Language Spoken)

 S CHK=$$CHKENG(IENS)

 I $P(CHK,U,2)=1 S DTOUT=$$PROF(LIEN) I $G(DTOUT)=1 G XLANG

 ;

 ;If Other Spoken Language isn't ENGLISH and Primary isn't ENGLISH, set Proficiency to NOT AT ALL

 I $P(CHK,U,2)=0,PRMX'="ENGLISH" D

 . N PLANG,ERROR

 . S PLANG("9000001.86",IENS,".06")="NA"

 . D FILE^DIE("","PLANG","ERROR")

 ;

 ;More than one language, ask preferred

 I $P(CHK,U)>0 D PREF(LIEN) G XLANG

 ;

 ;Only one language entered - fill PRIMARY into PREFERRED

 S PRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 S PLANG(9000001.86,IENS,".04")=$S(+PRM>0:+PRM,1:"@")  ;Preferred

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

 ;

XLANG Q

 ;

NEWLG(AGPATDFN) ;EP - Create a new Language multiple entry and copy in previous responses

 ;

 N ALANG,DA,DEF,DIC,DLAYGO,IENS,INT,LIEN,OLIEN,PRE,PRM,PRO,X,Y

 ;

 ;Pull Current Info

 S DEF=$$CLANG(AGPATDFN,.OLNG)

 S OLIEN=$P(DEF,U)

 S INT=$P($P(DEF,U,3),":")  ;Interpreter

 S PRE=$P($P(DEF,U,4),":")  ;Preferred Language

 S PRM=$P($P(DEF,U,2),":")  ;Primary Language

 S PRO=$P($P(DEF,U,6),":")  ;English Proficiency

 ;

 ;Define new entry and save current information

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

 S DIC(0)="L"

 S X=DT

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

 I '$D(^AUPNPAT(AGPATDFN,86,0)) S ^AUPNPAT(AGPATDFN,86,0)="^9000001.86D^^"

 K DO,DD D FILE^DICN

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

 S IENS=$$IENS^DILF(.DA)

 S ALANG(9000001.86,IENS,".02")=PRM  ;Primary

 S ALANG(9000001.86,IENS,".03")=INT  ;Interpreter

 S ALANG(9000001.86,IENS,".04")=PRE  ;Preferred

 S ALANG(9000001.86,IENS,".06")=PRO  ;English Proficiency

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

 I OLIEN]"" M ^AUPNPAT(AGPATDFN,86,DA,5)=^AUPNPAT(AGPATDFN,86,OLIEN,5)  ;Other Spoken

 Q LIEN

 ;

CHKENG(IENS) ;EP - Get Count of Other Languages Spoken and whether English is one of them

 N CNT,OLNG,ENG,IEN,LNG,ERROR

 D GETS^DIQ(9000001.86,IENS,".05*","E","OLNG","ERROR")

 S ENG=0,IEN="" F CNT=0:1 S IEN=$O(OLNG("9000001.8605",IEN)) Q:IEN=""  D

 . S LNG=$G(OLNG("9000001.8605",IEN,".01","E")) Q:LNG=""

 . I LNG="ENGLISH" S ENG=1

 Q CNT_"^"_ENG

 ;

CLANG(AGPATDFN,OLNG) ;EP - Return the patients most recent language entry IEN and other Language Information

 ;

 N IEN,INT,INTX,LDT,LIEN,OIEN,PRE,PREX,PRM,PRMX,VAR,PRO,PROX

 ;

 S (LDT,LIEN,PRM,PRMX,INT,INTX,PRE,PREX,PRO,PROX,VAR)=""

 S LDT=$O(^AUPNPAT(AGPATDFN,86,"B",""),-1)

 I LDT]"" S LIEN=$O(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)

 I LIEN]"" D

 . S IEN=LIEN_","_AGPATDFN_","

 . D GETS^DIQ(9000001.86,IEN,"**","IE","VAR")

 . S PRM=$G(VAR(9000001.86,IEN,".02","I"))

 . I PRM]"" S PRMX=$$GET1^DIQ(9999999.99,PRM_",",".01","E")

 . S INT=$G(VAR(9000001.86,IEN,".03","I"))

 . S INTX=$G(VAR(9000001.86,IEN,".03","E"))

 . S PRE=$G(VAR(9000001.86,IEN,".04","I"))

 . I PRE]"" S PREX=$$GET1^DIQ(9999999.99,PRE_",",".01","E")

 . S PRO=$G(VAR(9000001.86,IEN,".06","I"))

 . S PROX=$G(VAR(9000001.86,IEN,".06","E"))

 . S IEN="" F  S IEN=$O(VAR(9000001.8605,IEN)) Q:IEN=""  S OIEN=$G(VAR(9000001.8605,IEN,".01","I")) S:OIEN]"" OLNG(OIEN)=OIEN_":"_$$GET1^DIQ(9999999.99,OIEN_",",".01","E")

 ;

 ;Set up Other Language Spoken display field

 S OLNG=$O(OLNG(""))

 I $O(OLNG(OLNG))]"" S OLNG="MORE THAN ONE LANGUAGE"

 E  I OLNG]"" S OLNG=$P(OLNG(OLNG),":",2)

 ;

 Q LIEN_U_PRM_":"_PRMX_U_INT_":"_INTX_U_PRE_":"_PREX_U_OLNG_U_PRO_":"_PROX

 ;

INTRP(LIEN) ;EP - EDIT Interpreter required prompt

INTRP1 N DA,DIE,DR,IENS,INT,OINT,Y

 ;

 ;Pull current value

 S DA=LIEN,DA(1)=AGPATDFN

 S IENS=$$IENS^DILF(.DA)

 S OINT=$$GET1^DIQ(9000001.86,IENS,".03","I")

 ;

 ;Edit the INTERPRETER REQUIRED field

 S DIE="^AUPNPAT("_DA(1)_",86,"

 S DR=".03  Interpreter Required?: "

 D ^DIE I $D(Y) S DTOUT=1 Q

 ;

 ;Check for value

 S INT=$$GET1^DIQ(9000001.86,IENS,".03","I")

 I INT="",OINT]"" K DA,DIE,DR,IENS,INT,OINT G INTRP1

 I INT="",$$RQPRM^AGEDERR4(DUZ(2)) W "?? Required" K DA,DIE,DR,IENS,INT,OINT G INTRP1

 ;

 Q

 ;

OLNG(LIEN) ;EP - EDIT PATIENT'S OTHER LANGUAGE SPOKEN

 ;

 N DA,DR,DIE,DTOUT,Y

 ;

 S DA=LIEN,DA(1)=AGPATDFN,DA(2)=AGPATDFN

 S DIE="^AUPNPAT("_DA(1)_",86,"

 S DR=".05Other Language Spoken"

 S DR(2,9000001.8605)=".01Other Language Spoken"

 D ^DIE

 ;

 Q

 ;

PREF(LIEN) ;EP - EDIT Preferred Language

PREF1 N CHK,DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y

 ;

 I $G(LIEN)'>0 S LIEN=$$NEWLG(AGPATDFN)

 ;

 ;Pull current value

 S DA=LIEN,DA(1)=AGPATDFN

 S IENS=$$IENS^DILF(.DA)

 S OPRE=$$GET1^DIQ(9000001.86,IENS,".04","I")

 ;

 ;Edit the PRIMARY LANGUAGE field

 S DIE="^AUPNPAT("_DA(1)_",86,"

 S DR=".04Indicate Preferred Language"

 D ^DIE I $D(Y) Q

 ;

 ;Check for value

 S PRE=$$GET1^DIQ(9000001.86,IENS,".04","I")

 I PRE="",OPRE]"" K DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y G PREF1

 I PRE="",$$RQPRF^AGEDERR4(DUZ(2)) W "?? Required" K DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y G PREF1

 ;

 Q

PROF(LIEN) ;EP - EDIT ENGLISH PROFICIENCY prompt

PROF1 N CPRF,DA,DR,DIE,DTOUT,PRF,Y

 ;

 ;Pull current value

 S DA=LIEN,DA(1)=AGPATDFN

 S IENS=$$IENS^DILF(.DA)

 S CPRF=$$GET1^DIQ(9000001.86,IENS,".06","I")

 ;

 ;Edit the ENGLISH PROFICIENCY field

 S DIE="^AUPNPAT("_DA(1)_",86,"

 S DR=".06   How proficient is the patient in speaking ENGLISH?"

 D ^DIE I $D(DTOUT)!$D(Y) Q 1

 ;

 ;Check for value

 S PRF=$$GET1^DIQ(9000001.86,IENS,".06","I")

 I PRF="",CPRF]"" K CPRF,DA,DR,DIE,DTOUT,PRF,Y G PROF1

 I PRF="",$$RQPRM^AGEDERR4(DUZ(2)) K CPRF,DA,DR,DIE,DTOUT,PRF,Y W "??  Required" G PROF1

 ;

 Q 0

 ;

 ;GET ETHNICITY INFORMATION.

ETHNIC ;EP

EDETHNIC ;EP

 ;

 N DEF,DIR,DIROUT,DTOUT,DUOUT,DIRUT,ETHNIC,Y

 ;

 S DIR(0)="POr^10.2:EM"

 S DIR("A")="Ethnicity"

 ;

 ;Pull current value

 S DEF=$O(^DPT(AGPATDFN,.06,0))

 I DEF S DEF=$$GET1^DIQ(2.06,DEF_","_AGPATDFN_",",.01,"E")

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

 ;

 ;Prompt for Ethnicity

 S DIR("S")="I '$P($G(^(.02)),U)"

 D ^DIR

 I $D(DIROUT)!($D(DTOUT))!($D(DUOUT)) K DEF,DIR,DIROUT,DTOUT,DDUOUT,DIRUT,ETHNIC,Y G XETHNIC

 S ETHNIC=$G(Y)

 ;

 K DEF,DIR,DIROUT,DTOUT,DUOUT,DIRUT,Y

 ;

 ;Look for current entry - Re-ask if none and a delete or blank

 N DA,MOC

 S DA=$O(^DPT(AGPATDFN,.06,0)) I DA="",ETHNIC=-1,$$RQETH^AGEDERR4(DUZ(2)) W "??  Required" K DA,MOC,ETHNIC G ETHNIC

 ;

 ;Set up default Method of Collection

 S MOC=$$GET1^DIQ(10.3,"1,",".01","E")

 ;

 ;Delete current entry - Necessary as .01 field IEN gets used as the entry IEN

 I DA]"" D  I ETHNIC=-1 K DA,MOC,ETHNIC G ETHNIC

 . S MOC=$$GET1^DIQ(2.06,DA_","_AGPATDFN_",",".02","E")

 . N AGRACE

 . S DA(1)=AGPATDFN

 . S AGRACE(2.06,DA_","_DA(1)_",",".01")="@"

 . D FILE^DIE("","AGRACE","ERROR")

 ;

 ;Define new entry

 N DIC,X,Y

 S DA(1)=AGPATDFN

 S DIC="^DPT("_DA(1)_",.06,"

 S DIC(0)="L"

 S X=$P(ETHNIC,U,2)

 D ^DIC

 S:+Y>0 DA=+Y

 ;

 ;Make sure Eligibility is defined

 I DA=""!(ETHNIC=-1),$$RQETH^AGEDERR4(DUZ(2)) K DA,MOC,DIC,X,Y,ETHNIC G ETHNIC

 ;

 ;Prompt for Method of Collection

 D MOC(.DA,MOC)

 ;

XETHNIC ;

 Q

 ;

 ;Method of Collection

MOC(DA,DEF) N EXIT

 ;

 S EXIT=0

 F  D  Q:EXIT

 . ;

 . N AGRACE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,MOC,X,Y

 . ;

 . S DIR(0)="POr^10.3:E"

 . S DIR("A")="Method of Collection"

 . ;

 . ;Pull current value

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

 . ;

 . ;Prompt for Method of Collection

 . D ^DIR

 . I $D(DIROUT)!($D(DTOUT))!($D(DUOUT)) S EXIT=1 Q

 . ;

 . S MOC=$G(Y)

 . ;

 . ;Save current entry

 . S DA(1)=AGPATDFN

 . S AGRACE(2.06,DA_","_DA(1)_",",".02")=$S(MOC="-1":"@",1:$P(MOC,U))

 . D FILE^DIE("","AGRACE","ERROR")

 . ;

 . I MOC="-1",DEF]"" S DEF="" Q

 . I MOC="-1",$$RQETH^AGEDERR4(DUZ(2)) W "??  Required" Q

 . S EXIT=1

 ;

 Q

 ;

RACE ;EP - DISPLAY PATIENT'S RACE

EDRACE ;EP

 ;IHS/OIT/NKD AG*7.1*11 MU2 - ENTRY OF RACE MULTIPLE - START OLD CODE

 ;N AGRACE,DIE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,DEF,ERROR,Y

 ;I $$RQRACE^AGEDERR4(DUZ(2)) S DIR(0)="Pr^10:M"

 ;S DIR(0)="POr^10:EM"

 ;S DIR("A")="Race"

 ;S DEF=$$GET1^DIQ(2,AGPATDFN_",",".06","E") S:DEF]"" DIR("B")=DEF

 ;S DIR("S")="I '$P($G(^(.02)),U)"

 ;D ^DIR

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

 ;

 ;S AGRACE(2,AGPATDFN_",",".06")=$S(+Y=-1:"@",1:+Y)

 ;D FILE^DIE("","AGRACE","ERROR")

 ;

 ;END OLD CODE - START NEW CODE

 N DA,DR,DIE,DUOUT,Y

 S DIE="^DPT("

 S DA=DFN

 S DR="2Race(s)"

 S DR(2,2.02)=".01;.02"

 D ^DIE

 S:$D(Y) DUOUT=""

 ;

 D CHKRACE

 ;END NEW CODE

 ;Check if Race is required

 ;IHS/OIT/NKD AG*7.1*11 REQUIRED ENTRY CHECK FOR MULTIPLE

 ;I $$GET1^DIQ(2,AGPATDFN_",",".06","I")="",$$RQRACE^AGEDERR4(DUZ(2)) W "??  Required" K AGRACE,DIE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,DEF,ERROR,Y G EDRACE

 I +$$RACE^AGUTL(DFN)<1,$$RQRACE^AGEDERR4(DUZ(2)) W "??  Required" K DA,DR,DIE,DUOUT,Y,AGRACE G EDRACE

 ;

 Q

 ;IHS/OIT/NKD AG*7.1*11 MU2 - START NEW CODE

CHKRACE ;DECLINED/UNKNOWN RACE CHECK

 N AGRACE,AGDEC,AGUNK,AGSTR,AGSCR,AGRES,AGCNT,Y,FDA

 K DIR,DTOUT,DUOUT,DIRUT,DIROUT

 S AGRACE=$$RACE^AGUTL(DFN)

 Q:+AGRACE'>1  ; ONLY APPLIES FOR 2 OR MORE RACES

 S AGDEC=$S(AGRACE["DECLINED":1,1:0),AGUNK=$S(AGRACE["UNKNOWN":1,1:0)

 Q:AGDEC+AGUNK'>0  ; ONLY APPLIES IF AT LEAST ONE IS DECLINED/UNKNOWN

 S AGSTR=$S(AGDEC:"DECLINED TO ANSWER",AGUNK:"UNKNOWN BY PATIENT",1:"")

 W !,"A) Keep "_AGSTR,!,"B) Remove "_AGSTR

 S DIR("A")="Select one of the following: "

 S DIR("?")="additional Race entries must be removed."

 S DIR("?",1)="When either DECLINED TO ANSWER or UNKNOWN BY PATIENT is selected,"

 S DIR(0)="SA^A:Keep "_$P(AGSTR," ")_";B:Remove "_$P(AGSTR," ")

 D ^DIR

 G CHKRACE:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)

 ; SET UP SCREENING LOGIC

 S AGSCR=$S(AGDEC:"""D""",AGUNK:"""U""",1:"")

 ; REMOVE BOTH DECLINED/UNKNOWN ON OPTION B IF THERE ARE OTHER ENTRIES

 S:$G(Y)="B" AGSCR=$S(+AGRACE-AGDEC-AGUNK>0:"""DU""",1:AGSCR)

 ; OPTION A SCREENS DECLINED/UNKNOWN, OPTION B SCREENS OTHER ENTRIES

 S AGSCR="I "_AGSCR_$S($G(Y)="A":"'",1:"")_"[$$GET1^DIQ(10,Y,2)"

 ; RETRIEVE RACES AND DELETE ENTRIES NOT SCREENED

 D LIST^DIC(2.02,","_DFN_",","@;.01I","P",,,,,AGSCR,,"AGRES")

 S AGCNT=0 F  S AGCNT=$O(AGRES("DILIST",AGCNT)) Q:'AGCNT  D

 . S FDA(2.02,$P(AGRES("DILIST",AGCNT,0),U,1)_","_DFN_",",.01)="@"

 D UPDATE^DIE(,"FDA",)

 Q

 ;END NEW CODE

NIH ;EP - DISPLAY NUMBER IN HOUSEHOLD

 K DIC,DR,DIE

 W !

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR=.35

 D ^DIE

 K DIC,DR,DIE

 Q

THI ;EP - DISPLAY TOTAL HOUSEHOLD INCOME

 K DIC,DR,DIE,THI

 W !

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR=".36Total Household Income"

 D ^DIE

 ;

 ;Check Income - If > 0 Ask Period, Otherwise remove Period

 S THI=$$GET1^DIQ(9000001,DFN_",",".36","E")

 I +THI'>0 D  Q

 . N ATHI

 . S ATHI(9000001,DFN_",","8701")=""

 . D FILE^DIE("","ATHI","ERROR")

 ;

 ;

THIP ;EP - EDIT/DISPLAY HOUSEHOLD INCOME PERIOD

 ;

 N CTHIP,DA,DR,DIE,DTOUT,THIP,Y

 ;

 ;Retrieve current value

 S CTHIP=$$GET1^DIQ(9000001,DFN_",",8701,"E")

 ;

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR="8701Household Income Period"

 D ^DIE

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

 ;

 S THIP=$$GET1^DIQ(9000001,DFN_",",8701,"E")

 I THIP="",CTHIP]"" K CTHIP,DA,DR,DIE,DTOUT,THIP,Y G THIP

 I THIP="" K CTHIP,DA,DR,DIE,DTOUT,THIP,Y W "??  Required" G THIP

 ;

 Q

AGED10B   ; VNGT/HS/BEE - EDIT PG 10 - ETHNICITY/RACE/LANGUAGE/MIGRANT/HOMELESS/INTERNET/HOUSEHOLD INFO (CONT) ; 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 LOGIC FOR DECLINED TO ANSWER - LANGUAGE

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

 +4       ;

LANG      ;EP - EDIT PATIENT'S PRIMARY LANGUAGE

 +1       ;

 +2        NEW LIEN

LANG1      NEW CHK,DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,OPRMX,PLANG,PRM,PRMX,Y

 +1       ;

 +2       ;If no current entry selected, add new one

 +3        IF $GET(LIEN)=""

               SET LIEN=$$NEWLG(AGPATDFN)

 +4       ;

 +5       ;Pull current value

 +6        SET DA=LIEN

           SET DA(1)=AGPATDFN

           SET OPRMX=""

 +7        SET IENS=$$IENS^DILF(.DA)

 +8        SET OPRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 +9        IF OPRM]""

               SET OPRMX=$$GET1^DIQ(9999999.99,OPRM_",",".01","E")

 +10      ;

 +11      ;Edit the PRIMARY LANGUAGE field

 +12       SET DIE="^AUPNPAT("_DA(1)_",86,"

 +13       SET DR=".02Add the PRIMARY LANGUAGE spoken at home by the patient"

 +14       DO ^DIE

 +15      ;

 +16      ;Check for value

 +17       SET PRMX=""

           SET PRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 +18       IF PRM]""

               SET PRMX=$$GET1^DIQ(9999999.99,PRM_",",".01","E")

 +19      ;

 +20      ;IHS/OIT/NKD AG*7.1*11 MU2 - DECLINED TO ANSWER - START NEW CODE

 +21      ;REMOVE OTHER LANGUAGES ENTRY

 +22       IF PRMX="DECLINED TO ANSWER"

               Begin DoDot:1

 +23               NEW AGRES,AGCNT,Y

 +24               DO GETS^DIQ(9000001.86,IENS,".05*",,"AGRES")

 +25               SET AGCNT=0

                   FOR 

                       SET AGCNT=$ORDER(AGRES(9000001.8605,AGCNT))

                       IF 'AGCNT

                           QUIT 

                       Begin DoDot:2

 +26                       SET AGRES(9000001.8605,AGCNT,.01)="@"

                       End DoDot:2

 +27               DO UPDATE^DIE(,"AGRES",)

               End DoDot:1

 +28      ;END NEW CODE

 +29      ;

 +30      ;Check Other Languages - Proficiency Handling

 +31       SET CHK=$$CHKENG(IENS)

 +32       IF $PIECE(CHK,U,2)=0

               Begin DoDot:1

 +33               IF (PRMX'="ENGLISH")!((OPRMX'="ENGLISH")&(PRMX="ENGLISH"))

                       Begin DoDot:2

 +34                       NEW PLANG,ERROR

 +35                       SET PLANG("9000001.86",IENS,".06")="@"

 +36                       DO FILE^DIE("","PLANG","ERROR")

                       End DoDot:2

               End DoDot:1

 +37      ;

 +38      ;Erase Interpreter - If primary is blank or set to ENGLISH

 +39       IF PRMX=""!(PRMX="ENGLISH")

               Begin DoDot:1

 +40               NEW PLANG,ERROR

 +41               SET PLANG("9000001.86",IENS,".03")="@"

 +42               DO FILE^DIE("","PLANG","ERROR")

               End DoDot:1

 +43      ;

 +44      ;Remove Preferred if no languages

 +45       IF PRMX=""

               IF $PIECE(CHK,U)=0

                   Begin DoDot:1

 +46                   NEW PLANG,ERROR

 +47                   SET PLANG(9000001.86,IENS,".04")="@"

 +48                   DO FILE^DIE("","PLANG","ERROR")

                   End DoDot:1

 +49      ;

 +50      ;Quit on "^"

 +51       IF $DATA(Y)

               GOTO XLANG

 +52      ;

 +53      ;Check for value

 +54       IF PRM=""

               IF OPRM]""

                   KILL DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,PLANG,PRM,PRMX,Y

                   GOTO LANG1

 +55       IF PRM=""

               IF $$RQPRM^AGEDERR4(DUZ(2))

                   WRITE "?? Required"

                   KILL DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRM,PLANG,PRM,PRMX,Y

                   GOTO LANG1

 +56      ;

 +57      ;English Handling - If English need proficiency, If not English need Interpreter

 +58      ;

 +59      ;PRIMARY is not ENGLISH

 +60       IF PRMX'="ENGLISH"

               Begin DoDot:1

 +61      ;

 +62      ;Ask for Interpreter

 +63               DO INTRP(LIEN)

               End DoDot:1

               IF $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)

                   GOTO XLANG

 +64      ;

 +65      ;PRIMARY is ENGLISH

 +66       IF PRMX="ENGLISH"

               Begin DoDot:1

 +67      ;

 +68      ;Ask for Proficiency

 +69               SET DTOUT=$$PROF(LIEN)

               End DoDot:1

               IF $GET(DTOUT)=1

                   GOTO XLANG

 +70      ;

 +71      ;Other Languages Spoken

 +72      ;D OLNG(LIEN)  ;IHS/OIT/NKD AG*7.1*11 MU2 - ASK OTHER LANGUAGES ONLY IF PRIMARY ISN'T DECLINED

 +73       IF PRMX'="DECLINED TO ANSWER"

               DO OLNG(LIEN)

 +74      ;

 +75      ;Check if Proficiency needs to be asked (ENGLISH was entered in Other Language Spoken)

 +76       SET CHK=$$CHKENG(IENS)

 +77       IF $PIECE(CHK,U,2)=1

               SET DTOUT=$$PROF(LIEN)

               IF $GET(DTOUT)=1

                   GOTO XLANG

 +78      ;

 +79      ;If Other Spoken Language isn't ENGLISH and Primary isn't ENGLISH, set Proficiency to NOT AT ALL

 +80       IF $PIECE(CHK,U,2)=0

               IF PRMX'="ENGLISH"

                   Begin DoDot:1

 +81                   NEW PLANG,ERROR

 +82                   SET PLANG("9000001.86",IENS,".06")="NA"

 +83                   DO FILE^DIE("","PLANG","ERROR")

                   End DoDot:1

 +84      ;

 +85      ;More than one language, ask preferred

 +86       IF $PIECE(CHK,U)>0

               DO PREF(LIEN)

               GOTO XLANG

 +87      ;

 +88      ;Only one language entered - fill PRIMARY into PREFERRED

 +89       SET PRM=$$GET1^DIQ(9000001.86,IENS,".02","I")

 +90      ;Preferred

           SET PLANG(9000001.86,IENS,".04")=$SELECT(+PRM>0:+PRM,1:"@")

 +91       DO FILE^DIE("","PLANG","ERROR")

 +92      ;

XLANG      QUIT 

 +1       ;

NEWLG(AGPATDFN) ;EP - Create a new Language multiple entry and copy in previous responses

 +1       ;

 +2        NEW ALANG,DA,DEF,DIC,DLAYGO,IENS,INT,LIEN,OLIEN,PRE,PRM,PRO,X,Y

 +3       ;

 +4       ;Pull Current Info

 +5        SET DEF=$$CLANG(AGPATDFN,.OLNG)

 +6        SET OLIEN=$PIECE(DEF,U)

 +7       ;Interpreter

           SET INT=$PIECE($PIECE(DEF,U,3),":")

 +8       ;Preferred Language

           SET PRE=$PIECE($PIECE(DEF,U,4),":")

 +9       ;Primary Language

           SET PRM=$PIECE($PIECE(DEF,U,2),":")

 +10      ;English Proficiency

           SET PRO=$PIECE($PIECE(DEF,U,6),":")

 +11      ;

 +12      ;Define new entry and save current information

 +13       SET DIC="^AUPNPAT("_AGPATDFN_",86,"

           SET DA(1)=AGPATDFN

 +14       SET DIC(0)="L"

 +15       SET X=DT

 +16       SET DLAYGO="9000001.86"

           SET DIC("P")=DLAYGO

 +17       IF '$DATA(^AUPNPAT(AGPATDFN,86,0))

               SET ^AUPNPAT(AGPATDFN,86,0)="^9000001.86D^^"

 +18       KILL DO,DD

           DO FILE^DICN

 +19       SET (LIEN,DA)=+Y

           SET DA(1)=AGPATDFN

 +20       SET IENS=$$IENS^DILF(.DA)

 +21      ;Primary

           SET ALANG(9000001.86,IENS,".02")=PRM

 +22      ;Interpreter

           SET ALANG(9000001.86,IENS,".03")=INT

 +23      ;Preferred

           SET ALANG(9000001.86,IENS,".04")=PRE

 +24      ;English Proficiency

           SET ALANG(9000001.86,IENS,".06")=PRO

 +25       DO FILE^DIE("","ALANG","ERROR")

 +26      ;Other Spoken

           IF OLIEN]""

               MERGE ^AUPNPAT(AGPATDFN,86,DA,5)=^AUPNPAT(AGPATDFN,86,OLIEN,5)

 +27       QUIT LIEN

 +28      ;

CHKENG(IENS) ;EP - Get Count of Other Languages Spoken and whether English is one of them

 +1        NEW CNT,OLNG,ENG,IEN,LNG,ERROR

 +2        DO GETS^DIQ(9000001.86,IENS,".05*","E","OLNG","ERROR")

 +3        SET ENG=0

           SET IEN=""

           FOR CNT=0:1

               SET IEN=$ORDER(OLNG("9000001.8605",IEN))

               IF IEN=""

                   QUIT 

               Begin DoDot:1

 +4                SET LNG=$GET(OLNG("9000001.8605",IEN,".01","E"))

                   IF LNG=""

                       QUIT 

 +5                IF LNG="ENGLISH"

                       SET ENG=1

               End DoDot:1

 +6        QUIT CNT_"^"_ENG

 +7       ;

CLANG(AGPATDFN,OLNG) ;EP - Return the patients most recent language entry IEN and other Language Information

 +1       ;

 +2        NEW IEN,INT,INTX,LDT,LIEN,OIEN,PRE,PREX,PRM,PRMX,VAR,PRO,PROX

 +3       ;

 +4        SET (LDT,LIEN,PRM,PRMX,INT,INTX,PRE,PREX,PRO,PROX,VAR)=""

 +5        SET LDT=$ORDER(^AUPNPAT(AGPATDFN,86,"B",""),-1)

 +6        IF LDT]""

               SET LIEN=$ORDER(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)

 +7        IF LIEN]""

               Begin DoDot:1

 +8                SET IEN=LIEN_","_AGPATDFN_","

 +9                DO GETS^DIQ(9000001.86,IEN,"**","IE","VAR")

 +10               SET PRM=$GET(VAR(9000001.86,IEN,".02","I"))

 +11               IF PRM]""

                       SET PRMX=$$GET1^DIQ(9999999.99,PRM_",",".01","E")

 +12               SET INT=$GET(VAR(9000001.86,IEN,".03","I"))

 +13               SET INTX=$GET(VAR(9000001.86,IEN,".03","E"))

 +14               SET PRE=$GET(VAR(9000001.86,IEN,".04","I"))

 +15               IF PRE]""

                       SET PREX=$$GET1^DIQ(9999999.99,PRE_",",".01","E")

 +16               SET PRO=$GET(VAR(9000001.86,IEN,".06","I"))

 +17               SET PROX=$GET(VAR(9000001.86,IEN,".06","E"))

 +18               SET IEN=""

                   FOR 

                       SET IEN=$ORDER(VAR(9000001.8605,IEN))

                       IF IEN=""

                           QUIT 

                       SET OIEN=$GET(VAR(9000001.8605,IEN,".01","I"))

                       IF OIEN]""

                           SET OLNG(OIEN)=OIEN_":"_$$GET1^DIQ(9999999.99,OIEN_",",".01","E")

               End DoDot:1

 +19      ;

 +20      ;Set up Other Language Spoken display field

 +21       SET OLNG=$ORDER(OLNG(""))

 +22       IF $ORDER(OLNG(OLNG))]""

               SET OLNG="MORE THAN ONE LANGUAGE"

 +23      IF '$TEST

               IF OLNG]""

                   SET OLNG=$PIECE(OLNG(OLNG),":",2)

 +24      ;

 +25       QUIT LIEN_U_PRM_":"_PRMX_U_INT_":"_INTX_U_PRE_":"_PREX_U_OLNG_U_PRO_":"_PROX

 +26      ;

INTRP(LIEN) ;EP - EDIT Interpreter required prompt

INTRP1     NEW DA,DIE,DR,IENS,INT,OINT,Y

 +1       ;

 +2       ;Pull current value

 +3        SET DA=LIEN

           SET DA(1)=AGPATDFN

 +4        SET IENS=$$IENS^DILF(.DA)

 +5        SET OINT=$$GET1^DIQ(9000001.86,IENS,".03","I")

 +6       ;

 +7       ;Edit the INTERPRETER REQUIRED field

 +8        SET DIE="^AUPNPAT("_DA(1)_",86,"

 +9        SET DR=".03  Interpreter Required?: "

 +10       DO ^DIE

           IF $DATA(Y)

               SET DTOUT=1

               QUIT 

 +11      ;

 +12      ;Check for value

 +13       SET INT=$$GET1^DIQ(9000001.86,IENS,".03","I")

 +14       IF INT=""

               IF OINT]""

                   KILL DA,DIE,DR,IENS,INT,OINT

                   GOTO INTRP1

 +15       IF INT=""

               IF $$RQPRM^AGEDERR4(DUZ(2))

                   WRITE "?? Required"

                   KILL DA,DIE,DR,IENS,INT,OINT

                   GOTO INTRP1

 +16      ;

 +17       QUIT 

 +18      ;

OLNG(LIEN) ;EP - EDIT PATIENT'S OTHER LANGUAGE SPOKEN

 +1       ;

 +2        NEW DA,DR,DIE,DTOUT,Y

 +3       ;

 +4        SET DA=LIEN

           SET DA(1)=AGPATDFN

           SET DA(2)=AGPATDFN

 +5        SET DIE="^AUPNPAT("_DA(1)_",86,"

 +6        SET DR=".05Other Language Spoken"

 +7        SET DR(2,9000001.8605)=".01Other Language Spoken"

 +8        DO ^DIE

 +9       ;

 +10       QUIT 

 +11      ;

PREF(LIEN) ;EP - EDIT Preferred Language

PREF1      NEW CHK,DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y

 +1       ;

 +2        IF $GET(LIEN)'>0

               SET LIEN=$$NEWLG(AGPATDFN)

 +3       ;

 +4       ;Pull current value

 +5        SET DA=LIEN

           SET DA(1)=AGPATDFN

 +6        SET IENS=$$IENS^DILF(.DA)

 +7        SET OPRE=$$GET1^DIQ(9000001.86,IENS,".04","I")

 +8       ;

 +9       ;Edit the PRIMARY LANGUAGE field

 +10       SET DIE="^AUPNPAT("_DA(1)_",86,"

 +11       SET DR=".04Indicate Preferred Language"

 +12       DO ^DIE

           IF $DATA(Y)

               QUIT 

 +13      ;

 +14      ;Check for value

 +15       SET PRE=$$GET1^DIQ(9000001.86,IENS,".04","I")

 +16       IF PRE=""

               IF OPRE]""

                   KILL DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y

                   GOTO PREF1

 +17       IF PRE=""

               IF $$RQPRF^AGEDERR4(DUZ(2))

                   WRITE "?? Required"

                   KILL DA,DIE,DR,DIROUT,DIRUT,DTOUT,DUOUT,IENS,OPRE,PLANG,PRE,Y

                   GOTO PREF1

 +18      ;

 +19       QUIT 

PROF(LIEN) ;EP - EDIT ENGLISH PROFICIENCY prompt

PROF1      NEW CPRF,DA,DR,DIE,DTOUT,PRF,Y

 +1       ;

 +2       ;Pull current value

 +3        SET DA=LIEN

           SET DA(1)=AGPATDFN

 +4        SET IENS=$$IENS^DILF(.DA)

 +5        SET CPRF=$$GET1^DIQ(9000001.86,IENS,".06","I")

 +6       ;

 +7       ;Edit the ENGLISH PROFICIENCY field

 +8        SET DIE="^AUPNPAT("_DA(1)_",86,"

 +9        SET DR=".06   How proficient is the patient in speaking ENGLISH?"

 +10       DO ^DIE

           IF $DATA(DTOUT)!$DATA(Y)

               QUIT 1

 +11      ;

 +12      ;Check for value

 +13       SET PRF=$$GET1^DIQ(9000001.86,IENS,".06","I")

 +14       IF PRF=""

               IF CPRF]""

                   KILL CPRF,DA,DR,DIE,DTOUT,PRF,Y

                   GOTO PROF1

 +15       IF PRF=""

               IF $$RQPRM^AGEDERR4(DUZ(2))

                   KILL CPRF,DA,DR,DIE,DTOUT,PRF,Y

                   WRITE "??  Required"

                   GOTO PROF1

 +16      ;

 +17       QUIT 0

 +18      ;

 +19      ;GET ETHNICITY INFORMATION.

ETHNIC    ;EP

EDETHNIC  ;EP

 +1       ;

 +2        NEW DEF,DIR,DIROUT,DTOUT,DUOUT,DIRUT,ETHNIC,Y

 +3       ;

 +4        SET DIR(0)="POr^10.2:EM"

 +5        SET DIR("A")="Ethnicity"

 +6       ;

 +7       ;Pull current value

 +8        SET DEF=$ORDER(^DPT(AGPATDFN,.06,0))

 +9        IF DEF

               SET DEF=$$GET1^DIQ(2.06,DEF_","_AGPATDFN_",",.01,"E")

 +10       IF DEF]""

               SET DIR("B")=DEF

 +11      ;

 +12      ;Prompt for Ethnicity

 +13       SET DIR("S")="I '$P($G(^(.02)),U)"

 +14       DO ^DIR

 +15       IF $DATA(DIROUT)!($DATA(DTOUT))!($DATA(DUOUT))

               KILL DEF,DIR,DIROUT,DTOUT,DDUOUT,DIRUT,ETHNIC,Y

               GOTO XETHNIC

 +16       SET ETHNIC=$GET(Y)

 +17      ;

 +18       KILL DEF,DIR,DIROUT,DTOUT,DUOUT,DIRUT,Y

 +19      ;

 +20      ;Look for current entry - Re-ask if none and a delete or blank

 +21       NEW DA,MOC

 +22       SET DA=$ORDER(^DPT(AGPATDFN,.06,0))

           IF DA=""

               IF ETHNIC=-1

                   IF $$RQETH^AGEDERR4(DUZ(2))

                       WRITE "??  Required"

                       KILL DA,MOC,ETHNIC

                       GOTO ETHNIC

 +23      ;

 +24      ;Set up default Method of Collection

 +25       SET MOC=$$GET1^DIQ(10.3,"1,",".01","E")

 +26      ;

 +27      ;Delete current entry - Necessary as .01 field IEN gets used as the entry IEN

 +28       IF DA]""

               Begin DoDot:1

 +29               SET MOC=$$GET1^DIQ(2.06,DA_","_AGPATDFN_",",".02","E")

 +30               NEW AGRACE

 +31               SET DA(1)=AGPATDFN

 +32               SET AGRACE(2.06,DA_","_DA(1)_",",".01")="@"

 +33               DO FILE^DIE("","AGRACE","ERROR")

               End DoDot:1

               IF ETHNIC=-1

                   KILL DA,MOC,ETHNIC

                   GOTO ETHNIC

 +34      ;

 +35      ;Define new entry

 +36       NEW DIC,X,Y

 +37       SET DA(1)=AGPATDFN

 +38       SET DIC="^DPT("_DA(1)_",.06,"

 +39       SET DIC(0)="L"

 +40       SET X=$PIECE(ETHNIC,U,2)

 +41       DO ^DIC

 +42       IF +Y>0

               SET DA=+Y

 +43      ;

 +44      ;Make sure Eligibility is defined

 +45       IF DA=""!(ETHNIC=-1)

               IF $$RQETH^AGEDERR4(DUZ(2))

                   KILL DA,MOC,DIC,X,Y,ETHNIC

                   GOTO ETHNIC

 +46      ;

 +47      ;Prompt for Method of Collection

 +48       DO MOC(.DA,MOC)

 +49      ;

XETHNIC   ;

 +1        QUIT 

 +2       ;

 +3       ;Method of Collection

MOC(DA,DEF)  NEW EXIT

 +1       ;

 +2        SET EXIT=0

 +3        FOR 

               Begin DoDot:1

 +4       ;

 +5                NEW AGRACE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,MOC,X,Y

 +6       ;

 +7                SET DIR(0)="POr^10.3:E"

 +8                SET DIR("A")="Method of Collection"

 +9       ;

 +10      ;Pull current value

 +11               IF DEF]""

                       SET DIR("B")=DEF

 +12      ;

 +13      ;Prompt for Method of Collection

 +14               DO ^DIR

 +15               IF $DATA(DIROUT)!($DATA(DTOUT))!($DATA(DUOUT))

                       SET EXIT=1

                       QUIT 

 +16      ;

 +17               SET MOC=$GET(Y)

 +18      ;

 +19      ;Save current entry

 +20               SET DA(1)=AGPATDFN

 +21               SET AGRACE(2.06,DA_","_DA(1)_",",".02")=$SELECT(MOC="-1":"@",1:$PIECE(MOC,U))

 +22               DO FILE^DIE("","AGRACE","ERROR")

 +23      ;

 +24               IF MOC="-1"

                       IF DEF]""

                           SET DEF=""

                           QUIT 

 +25               IF MOC="-1"

                       IF $$RQETH^AGEDERR4(DUZ(2))

                           WRITE "??  Required"

                           QUIT 

 +26               SET EXIT=1

               End DoDot:1

               IF EXIT

                   QUIT 

 +27      ;

 +28       QUIT 

 +29      ;

RACE      ;EP - DISPLAY PATIENT'S RACE

EDRACE    ;EP

 +1       ;IHS/OIT/NKD AG*7.1*11 MU2 - ENTRY OF RACE MULTIPLE - START OLD CODE

 +2       ;N AGRACE,DIE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,DEF,ERROR,Y

 +3       ;I $$RQRACE^AGEDERR4(DUZ(2)) S DIR(0)="Pr^10:M"

 +4       ;S DIR(0)="POr^10:EM"

 +5       ;S DIR("A")="Race"

 +6       ;S DEF=$$GET1^DIQ(2,AGPATDFN_",",".06","E") S:DEF]"" DIR("B")=DEF

 +7       ;S DIR("S")="I '$P($G(^(.02)),U)"

 +8       ;D ^DIR

 +9       ;I $D(DIROUT)!($D(DTOUT))!($D(DUOUT)) Q

 +10      ;

 +11      ;S AGRACE(2,AGPATDFN_",",".06")=$S(+Y=-1:"@",1:+Y)

 +12      ;D FILE^DIE("","AGRACE","ERROR")

 +13      ;

 +14      ;END OLD CODE - START NEW CODE

 +15       NEW DA,DR,DIE,DUOUT,Y

 +16       SET DIE="^DPT("

 +17       SET DA=DFN

 +18       SET DR="2Race(s)"

 +19       SET DR(2,2.02)=".01;.02"

 +20       DO ^DIE

 +21       IF $DATA(Y)

               SET DUOUT=""

 +22      ;

 +23       DO CHKRACE

 +24      ;END NEW CODE

 +25      ;Check if Race is required

 +26      ;IHS/OIT/NKD AG*7.1*11 REQUIRED ENTRY CHECK FOR MULTIPLE

 +27      ;I $$GET1^DIQ(2,AGPATDFN_",",".06","I")="",$$RQRACE^AGEDERR4(DUZ(2)) W "??  Required" K AGRACE,DIE,DIR,DIROUT,DTOUT,DUOUT,DIRUT,DEF,ERROR,Y G EDRACE

 +28       IF +$$RACE^AGUTL(DFN)<1

               IF $$RQRACE^AGEDERR4(DUZ(2))

                   WRITE "??  Required"

                   KILL DA,DR,DIE,DUOUT,Y,AGRACE

                   GOTO EDRACE

 +29      ;

 +30       QUIT 

 +31      ;IHS/OIT/NKD AG*7.1*11 MU2 - START NEW CODE

CHKRACE   ;DECLINED/UNKNOWN RACE CHECK

 +1        NEW AGRACE,AGDEC,AGUNK,AGSTR,AGSCR,AGRES,AGCNT,Y,FDA

 +2        KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT

 +3        SET AGRACE=$$RACE^AGUTL(DFN)

 +4       ; ONLY APPLIES FOR 2 OR MORE RACES

           IF +AGRACE'>1

               QUIT 

 +5        SET AGDEC=$SELECT(AGRACE["DECLINED":1,1:0)

           SET AGUNK=$SELECT(AGRACE["UNKNOWN":1,1:0)

 +6       ; ONLY APPLIES IF AT LEAST ONE IS DECLINED/UNKNOWN

           IF AGDEC+AGUNK'>0

               QUIT 

 +7        SET AGSTR=$SELECT(AGDEC:"DECLINED TO ANSWER",AGUNK:"UNKNOWN BY PATIENT",1:"")

 +8        WRITE !,"A) Keep "_AGSTR,!,"B) Remove "_AGSTR

 +9        SET DIR("A")="Select one of the following: "

 +10       SET DIR("?")="additional Race entries must be removed."

 +11       SET DIR("?",1)="When either DECLINED TO ANSWER or UNKNOWN BY PATIENT is selected,"

 +12       SET DIR(0)="SA^A:Keep "_$PIECE(AGSTR," ")_";B:Remove "_$PIECE(AGSTR," ")

 +13       DO ^DIR

 +14       IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)

               GOTO CHKRACE

 +15      ; SET UP SCREENING LOGIC

 +16       SET AGSCR=$SELECT(AGDEC:"""D""",AGUNK:"""U""",1:"")

 +17      ; REMOVE BOTH DECLINED/UNKNOWN ON OPTION B IF THERE ARE OTHER ENTRIES

 +18       IF $GET(Y)="B"

               SET AGSCR=$SELECT(+AGRACE-AGDEC-AGUNK>0:"""DU""",1:AGSCR)

 +19      ; OPTION A SCREENS DECLINED/UNKNOWN, OPTION B SCREENS OTHER ENTRIES

 +20       SET AGSCR="I "_AGSCR_$SELECT($GET(Y)="A":"'",1:"")_"[$$GET1^DIQ(10,Y,2)"

 +21      ; RETRIEVE RACES AND DELETE ENTRIES NOT SCREENED

 +22       DO LIST^DIC(2.02,","_DFN_",","@;.01I","P",,,,,AGSCR,,"AGRES")

 +23       SET AGCNT=0

           FOR 

               SET AGCNT=$ORDER(AGRES("DILIST",AGCNT))

               IF 'AGCNT

                   QUIT 

               Begin DoDot:1

 +24               SET FDA(2.02,$PIECE(AGRES("DILIST",AGCNT,0),U,1)_","_DFN_",",.01)="@"

               End DoDot:1

 +25       DO UPDATE^DIE(,"FDA",)

 +26       QUIT 

 +27      ;END NEW CODE

NIH       ;EP - DISPLAY NUMBER IN HOUSEHOLD

 +1        KILL DIC,DR,DIE

 +2        WRITE !

 +3        SET DIE="^AUPNPAT("

 +4        SET DA=DFN

 +5        SET DR=.35

 +6        DO ^DIE

 +7        KILL DIC,DR,DIE

 +8        QUIT 

THI       ;EP - DISPLAY TOTAL HOUSEHOLD INCOME

 +1        KILL DIC,DR,DIE,THI

 +2        WRITE !

 +3        SET DIE="^AUPNPAT("

 +4        SET DA=DFN

 +5        SET DR=".36Total Household Income"

 +6        DO ^DIE

 +7       ;

 +8       ;Check Income - If > 0 Ask Period, Otherwise remove Period

 +9        SET THI=$$GET1^DIQ(9000001,DFN_",",".36","E")

 +10       IF +THI'>0

               Begin DoDot:1

 +11               NEW ATHI

 +12               SET ATHI(9000001,DFN_",","8701")=""

 +13               DO FILE^DIE("","ATHI","ERROR")

               End DoDot:1

               QUIT 

 +14      ;

 +15      ;

THIP      ;EP - EDIT/DISPLAY HOUSEHOLD INCOME PERIOD

 +1       ;

 +2        NEW CTHIP,DA,DR,DIE,DTOUT,THIP,Y

 +3       ;

 +4       ;Retrieve current value

 +5        SET CTHIP=$$GET1^DIQ(9000001,DFN_",",8701,"E")

 +6       ;

 +7        SET DIE="^AUPNPAT("

 +8        SET DA=DFN

 +9        SET DR="8701Household Income Period"

 +10       DO ^DIE

 +11       IF $DATA(DTOUT)!$DATA(Y)

               QUIT 

 +12      ;

 +13       SET THIP=$$GET1^DIQ(9000001,DFN_",",8701,"E")

 +14       IF THIP=""

               IF CTHIP]""

                   KILL CTHIP,DA,DR,DIE,DTOUT,THIP,Y

                   GOTO THIP

 +15       IF THIP=""

               KILL CTHIP,DA,DR,DIE,DTOUT,THIP,Y

               WRITE "??  Required"

               GOTO THIP

 +16      ;

 +17       QUIT