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
+82 SET HOM=$$CHOM(AGPATDFN)
+83 WRITE $PIECE($PIECE(HOM,U,3),":",2)
+84 WRITE ?32,"Type: ",$EXTRACT($PIECE($PIECE(HOM,U,4),":",2),1,23)
+85 SET UPD=$PIECE($PIECE(HOM,U,2),":",2)
WRITE ?63
IF UPD]""
WRITE $JUSTIFY("(upd "_UPD_")",17)
End DoDot:2
QUIT
+86 ;
+87 ;Display Internet Access
+88 IF AG=7
Begin DoDot:2
+89 NEW LSTUPD,LSTREC,ACCESS,WHERE,Y,WIEN
+90 SET (LSTUPD,ACCESS,WHERE)=""
+91 ;
+92 ;Pull latest entry
+93 Begin DoDot:3
+94 SET LSTUPD=$ORDER(^AUPNPAT(DFN,81,"B",""),-1)
+95 IF LSTUPD=""
QUIT
+96 SET LSTREC=$ORDER(^AUPNPAT(DFN,81,"B",LSTUPD,""),-1)
+97 IF LSTREC=""
QUIT
+98 SET ACCESS=$$GET1^DIQ(9000001.81,LSTREC_","_DFN_",",.02,"E")
+99 ;
+100 ;Get list of WHERE values
+101 SET WHERE=""
SET WIEN=0
FOR
SET WIEN=$ORDER(^AUPNPAT(DFN,81,LSTREC,1,WIEN))
IF 'WIEN
QUIT
Begin DoDot:4
+102 SET WHERE=WHERE_$SELECT(WHERE="":"",1:", ")_$$GET1^DIQ(9000001.811,WIEN_","_LSTREC_","_DFN_",",.01,"I")
End DoDot:4
+103 ;S WHERE=$$GET1^DIQ(9000001.81,LSTREC_","_DFN_",",.03)
+104 SET Y=LSTUPD
XECUTE ^DD("DD")
SET LSTUPD=Y
End DoDot:3
+105 WRITE ?25,ACCESS
+106 WRITE ?32,"Where: ",$EXTRACT(WHERE,1,23)
+107 ;AG*7.1*8 - Disabled
WRITE ?63
IF LSTUPD]""
WRITE $JUSTIFY("(upd "_LSTUPD_")",17)
End DoDot:2
QUIT
+108 ;
+109 ;Email Address
+110 IF AG=8
WRITE $$GET1^DIQ(9000001,DFN_",",1802)
+111 ;
+112 ;Generic Health Permission
+113 IF AG=9
WRITE $$GET1^DIQ(9000001,DFN_",",4001)
+114 ;
+115 ;Preferred Method
+116 IF AG=10
WRITE $$GET1^DIQ(9000001,DFN_",",4002)
+117 ;
+118 ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS - START NEW CODE
+119 ;PHR Access/Handout
+120 IF AG=11
WRITE $$PHRAP^AGPHROPT(DFN)
+121 IF AG=12
WRITE $$PHRHP^AGPHROPT(DFN)
+122 ;IHS/OIT/NKD AG*7.1*11 END NEW CODE
+123 ;
+124 ;Number in Household/Total Household Income/Household Income Period
+125 ;I AG=11!(AG=12),AGOPT(22)="Y" W $$GET1^DIQ(DIC,DFN_",",DR,"E") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS
+126 IF AG=13!(AG=14)
IF AGOPT(22)="Y"
WRITE $$GET1^DIQ(DIC,DFN_",",DR,"E")
+127 ;I AG=12,AGOPT(22)="Y" W ?40,"/ ",$$GET1^DIQ(9000001,DFN_",",8701,"E") ;IHS/OIT/NKD AG*7.1*11 PHR FIELDS
+128 IF AG=14
IF AGOPT(22)="Y"
WRITE ?40,"/ ",$$GET1^DIQ(9000001,DFN_",",8701,"E")
End DoDot:1
+129 ;
+130 WRITE !,AGLINE("-")
+131 ;
+132 ;Error Checking/Display
+133 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+134 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+135 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+136 QUIT
+137 ;
READ ;EP
+1 SET DIR("?")="Enter free text"
+2 SET DIR("?",1)="You may enter the item number of the field you wish to edit,"
+3 SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
+4 SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
+5 SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
+6 SET DIR(0)="FO"
+7 DO ^DIR
+8 IF $DATA(DTOUT)
QUIT
+9 IF Y="/.,"!(Y="^^")
SET DFOUT=1
+10 IF Y=""
SET DLOUT=""
+11 IF Y="^"
SET (DUOUT,Y)=""
+12 IF Y?1"?".E!(Y["^")
SET (DQOUT,Y)=""
+13 IF Y="P"
QUIT
+14 IF $EXTRACT(Y,1)="p"
SET $EXTRACT(Y,1)="P"
+15 IF $EXTRACT(Y,1)="P"
Begin DoDot:1
+16 SET AG("ED")=+$PIECE($EXTRACT(Y,2,99),".")
+17 IF AG("ED")<1!(AG("ED")>10)
Begin DoDot:2
+18 WRITE *7,!!,"Use only pages 1 through 10."
+19 HANG 2
+20 KILL AG("ED")
+21 SET AG("ERR")=""
End DoDot:2
+22 IF $DATA(AG("ED"))
Begin DoDot:2
+23 IF AG("ED")>0&(AG("ED")<11)
Begin DoDot:3
+24 IF AG("ED")=4
SET AG("ED")="4A"
+25 IF AG("ED")=5
SET AG("ED")="BEA"
+26 IF AG("ED")=6
SET AG("ED")=13
+27 IF AG("ED")=8
SET AG("ED")=11
+28 IF AG("ED")=7
SET AG("ED")=8
+29 IF AG("ED")=9
SET AG("ED")="11A"
+30 IF AG("ED")=10
SET AG("ED")="10A"
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
MIG ;EP - EDIT Migrant Worker prompts
MIG1 ;
+1 NEW DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y
+2 ;
+3 ;Get current value
+4 SET DEF=$$CMIG(AGPATDFN)
+5 SET MTYP=$PIECE($PIECE(DEF,U,4),":")
+6 SET DEF=$PIECE($PIECE(DEF,U,3),":",2)
+7 IF DEF]""
SET DIR("B")=DEF
+8 ;
+9 SET DIR(0)="SOA^Y:YES;N:NO"
+10 SET DIR("A")="Migrant Worker?: "
DO ^DIR
+11 IF $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 SET MIG=$GET(Y)
+13 ;
+14 ;If Null/Delete and no default show warning and ask again
+15 ;I MIG="",DEF="" W "?? Required" K DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y G MIG1
+16 ;AG*7.1*9 - No longer required
IF MIG=""
IF DEF=""
QUIT
+17 ;
+18 ;Define new entry and save
+19 SET DIC="^AUPNPAT("_AGPATDFN_",84,"
SET DA(1)=AGPATDFN
+20 SET DIC(0)="L"
+21 SET X=DT
+22 SET DLAYGO="9000001.84"
SET DIC("P")=DLAYGO
+23 IF '$DATA(^AUPNPAT(AGPATDFN,84,0))
SET ^AUPNPAT(AGPATDFN,84,0)="^9000001.84D^^"
+24 KILL DO,DD
DO FILE^DICN
+25 SET (MIEN,DA)=+Y
SET DA(1)=AGPATDFN
+26 SET AMIG(9000001.84,DA_","_DA(1)_",",".02")=$SELECT(MIG'="":MIG,1:"@")
+27 SET AMIG(9000001.84,DA_","_DA(1)_",",".03")=$SELECT(((MIG="")!(MIG="N")):"@",1:MTYP)
+28 DO FILE^DIE("","AMIG","ERROR")
+29 ;
+30 ;If a Null/delete ask again
+31 IF MIG=""
SET DEF=""
KILL DEF,DIC,DLAYGO,DIR,AMIG,MIG,MIEN,MTYP,DA,ERROR,X,Y
GOTO MIG1
+32 ;
+33 ;Migrant Worker Type - only do if "YES"
+34 IF MIG="Y"
DO MTYPE(MIEN)
+35 ;
+36 QUIT
+37 ;
MTYPE(MIEN) ;EP - EDIT Migrant Worker Type prompt
MTYPE1 ;
+1 ;
+2 NEW CMTYP,DA,DR,DIE,DTOUT,MTYP,Y
+3 ;
+4 ;Retrieve current value
+5 SET CMTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")
+6 ;
+7 SET DIE="^AUPNPAT("_AGPATDFN_",84,"
+8 SET DA=MIEN
+9 SET DR=".03Type"
+10 DO ^DIE
+11 IF $DATA(DTOUT)!$DATA(Y)
QUIT
+12 ;
+13 SET MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")
+14 IF MTYP=""
IF CMTYP]""
KILL CMTYP,DA,DR,DIE,DTOUT,MTYP,Y
GOTO MTYPE1
+15 ;I MTYP="" K CMTYP,DA,DR,DIE,DTOUT,MTYP,Y W "?? Required" G MTYPE1 ;AG*7.1*9 - No longer required
+16 ;
+17 QUIT
+18 ;
CMIG(AGPATDFN) ;Return the patients most recent Migrant information
+1 ;
+2 NEW MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX,Y
+3 ;
+4 SET (MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX)=""
+5 SET MDT=$ORDER(^AUPNPAT(AGPATDFN,84,"B",""),-1)
+6 IF MDT]""
SET MIEN=$ORDER(^AUPNPAT(AGPATDFN,84,"B",MDT,""),-1)
+7 SET Y=MDT
XECUTE ^DD("DD")
SET MDTX=Y
+8 IF MIEN]""
SET MSTS=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","I")
+9 IF MIEN]""
SET MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")
+10 IF MIEN]""
SET MSTSX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","E")
+11 IF MIEN]""
SET MTYPX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")
+12 ;
+13 QUIT MIEN_U_MDT_":"_MDTX_U_MSTS_":"_MSTSX_U_MTYP_":"_MTYPX
+14 ;
HOM ;EP - EDIT Homeless prompts
HOM1 ;
+1 NEW DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y
+2 ;
+3 ;Get current value
+4 SET DEF=$$CHOM(AGPATDFN)
+5 SET HTYP=$PIECE($PIECE(DEF,U,4),":")
+6 SET DEF=$PIECE($PIECE(DEF,U,3),":",2)
+7 IF DEF]""
SET DIR("B")=DEF
+8 ;
+9 SET DIR(0)="SOA^Y:YES;N:NO"
+10 SET DIR("A")="Homeless?: "
DO ^DIR
+11 IF $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 SET HOM=$GET(Y)
+13 ;
+14 ;If Null/Delete and no default show warning and ask again
+15 ;I HOM="",DEF="" W "?? Required" K DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y G HOM1
+16 ;AG*7.1*9 - No longer required
IF HOM=""
IF DEF=""
QUIT
+17 ;
+18 ;Define new entry and save
+19 SET DIC="^AUPNPAT("_AGPATDFN_",85,"
SET DA(1)=AGPATDFN
+20 SET DIC(0)="L"
+21 SET X=DT
+22 SET DLAYGO="9000001.85"
SET DIC("P")=DLAYGO
+23 IF '$DATA(^AUPNPAT(AGPATDFN,85,0))
SET ^AUPNPAT(AGPATDFN,85,0)="^9000001.85D^^"
+24 KILL DO,DD
DO FILE^DICN
+25 SET (HIEN,DA)=+Y
SET DA(1)=AGPATDFN
+26 SET AHOM(9000001.85,DA_","_DA(1)_",",".02")=$SELECT(HOM'="":HOM,1:"@")
+27 SET AHOM(9000001.85,DA_","_DA(1)_",",".03")=$SELECT(((HOM="")!(HOM="N")):"@",1:HTYP)
+28 DO FILE^DIE("","AHOM","ERROR")
+29 ;
+30 ;If a Null/delete ask again
+31 IF HOM=""
SET DEF=""
KILL DIC,DLAYGO,DIR,AHOM,HOM,HIEN,HTYP,DA,ERROR,X,Y
GOTO HOM1
+32 ;
+33 ;Homeless Type - only do if "YES"
+34 IF HOM="Y"
DO HTYPE(HIEN)
+35 ;
+36 QUIT
+37 ;
HTYPE(HIEN) ;EP - EDIT Homeless Type prompt
HTYPE1 ;
+1 NEW CHTYP,DA,DR,DIE,DTOUT,HTYP,Y
+2 ;
+3 ;Retrieve current value
+4 SET CHTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")
+5 ;
+6 SET DIE="^AUPNPAT("_AGPATDFN_",85,"
+7 SET DA=HIEN
+8 SET DR=".03Type"
+9 DO ^DIE
+10 IF $DATA(DTOUT)!$DATA(Y)
QUIT
+11 ;
+12 SET HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")
+13 IF HTYP=""
IF CHTYP]""
KILL CHTYP,DA,DR,DIE,DTOUT,HTYP,Y
GOTO HTYPE1
+14 ;I HTYP="" K CMTYP,DA,DR,DIE,DTOUT,HTYP,Y W "?? Required" G HTYPE1 ;AG*7.1*9 - No longer required
+15 ;
+16 QUIT
+17 ;
CHOM(AGPATDFN) ;Return the patients most recent Homeless information
+1 ;
+2 NEW HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX,Y
+3 ;
+4 SET (HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX)=""
+5 SET HDT=$ORDER(^AUPNPAT(AGPATDFN,85,"B",""),-1)
+6 IF HDT]""
SET HIEN=$ORDER(^AUPNPAT(AGPATDFN,85,"B",HDT,""),-1)
+7 SET Y=HDT
XECUTE ^DD("DD")
SET HDTX=Y
+8 IF HIEN]""
SET HSTS=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","I")
+9 IF HIEN]""
SET HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")
+10 IF HIEN]""
SET HSTSX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","E")
+11 IF HIEN]""
SET HTYPX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")
+12 ;
+13 QUIT HIEN_U_HDT_":"_HDTX_U_HSTS_":"_HSTSX_U_HTYP_":"_HTYPX
+14 ;
PERM ; EP - Edit GENERIC HEALTH PERMISSION prompt
+1 ;
+2 NEW DIE,DA,DR
+3 SET DIE="^AUPNPAT("
+4 SET DA=DFN
+5 SET DR="4001Do we have permission to send generic health information to your email address?"
+6 DO ^DIE
+7 ;
+8 QUIT
+9 ;
PREF ; EP - Edit PREFERRED METHOD prompt
+1 ;
+2 NEW DIE,DA,DR
+3 SET DIE="^AUPNPAT("
+4 SET DA=DFN
+5 ;IHS/OIT/NKD AG*7.1*11 MU2 CHANGED WORDING ON PREFERRED METHOD
+6 ;S DR="4002WHAT IS YOUR PREFERRED METHOD TO RECEIVE REMINDERS?"
+7 SET DR="4002WHAT IS YOUR PREFERRED METHOD OF COMMUNICATIONS?"
+8 DO ^DIE
+9 ;
+10 QUIT
+11 ;
+12 ; ****************************************************************
+13 ; ON LINES BELOW:
+14 ; PIECE 1= FLD LBL
+15 ; PIECE 2= FILE #
+16 ; PIECE 3= FLD #
1 ;
+1 ;;Ethnicity^2^6
+2 ;;Race^2^2
+3 ;;Primary Language
+4 ;;Preferred Language
+5 ;;Migrant Worker?
+6 ;;Homeless?
+7 ;;Internet Access^9000001.81^.01
+8 ;;EMAIL ADDRESS^9000001^1802
+9 ;;GENERIC HEALTH PERMISSION^9000001^4001
+10 ;;PREFERRED METHOD^9000001^4002
+11 ;;PHR ACCESS
+12 ;;PHR HANDOUT
+13 ;;Number in Household^9000001^.35
+14 ;;Total Household Income^9000001^.36
