EASAILK1 ;ALB/BRM,ERC,JAM,ARF - Patient Address Inquiry ;18 Jul 2017 4:03 PM
;;1.0;ENROLLMENT APPLICATION SYSTEM;**13,29,39,70,151,203**;Mar 15, 2001;Build 17
;
;*151*; JAM - Add Residential Address and modify Permanent, Confidential, and Temporary address field labels and reformat the output
;
PATADDR ;view patient address
;
N PATNAM,IENS,ZTSAVE
N DTOUT,DUOUT,DIRUT,DIROUT,%ZIS,DIC,DA,DIQ,DLAYGO,Y,X
;
; prompt user for patient name and device
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC
Q:($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!(Y=-1))
S %ZIS="Q"
S IENS=+Y_",",PATNAM=$P(Y,"^",2)
S ZTSAVE("IENS")="",ZTSAVE("PATNAM")=""
D EN^XUTMDEVQ("QUE^EASAILK1","PATIENT ADDRESS INQUIRY",.ZTSAVE,.%ZIS)
Q
QUE ;
N DGC,CONOK,PATOK,TMPOK,FLD,CONARR,TMPARR,PATARR,CONERR,TMPERR,PATERR
N CONSTR,TMPSTR,PATSTR,TYPE,CONFARR,TEMPARR
;
PAT ;patient address
N PATOK
D GETS^DIQ(2,IENS,".111:.121","E","PATARR","PATERR")
W !?23,"Patient Name: ",?37,PATNAM
; exit if error occurs during DIQ call
; EAS*1.0*151; JAM; Change label to Permanent Mailing Address
; EAS*1.0*203; ARF; Removed Permanent from the following message
I $D(PATERR) W !!?11,"There is invalid data in the Mailing Address",!?11,"Please use Registration options to edit",!! G CON
;
; exit if there is no address for patient
S FLD="",PATOK=0
D OK(.PATARR,.PATOK)
; EAS*1.0*151; JAM; Change label to Permanent Mailing Address
; EAS*1.0*203; ARF; Removed Permanent from the following message
I 'PATOK W !!?11,"*** No Mailing Address On File For This Patient ***",!! G CON
;set a string of the field numbers needed for the patient address
S PATSTR=".111^.112^.113^.114^.115^.1112^.1173^.121^.118^.119^.12^^^.1171^.1172"
N STRARR
D STRG(PATSTR,.STRARR) ;place the fld numbers into an array
; EAS*1.0*151; JAM; Change TYPE to "Permanent Mailing" (from "Patient")
; EAS*1.0*203; ARF; Removed "Permanent" from the following TYPE variable
S TYPE=" Mailing"
S DGC=1
;display the patient address information
D DISP(TYPE,.PATARR,.STRARR)
;
CON ;confidential address
N CONARR,CONERR,CONOK,DGJ
S CONOK=0
D GETS^DIQ(2,IENS,".141*;.14105;.1411:.142","IE","CONARR","CONERR")
I $D(CONERR) S CONOK=-1 G TMP
S FLD=""
D OK(.CONARR,.CONOK) ;checking for presence of confid address array
I $G(CONARR(2,IENS,.14105,"E"))'="YES" S CONOK=0 G TMP
;treat null end date as if in the future
I DT'<$G(CONARR(2,IENS,.1417,"I")),$G(CONARR(2,IENS,.1418,"I"))']"" G CON2
I DT>$G(CONARR(2,IENS,.1418,"I")) S CONOK=0 G TMP ;if date range in the past, don't display
I DT<$G(CONARR(2,IENS,.1417,"I")) S CONOK=0 G TMP ;if date range in the future, dont display
CON2 ;
S DGJ=""
S CONOK=0 ;now check for active E/E confid address
F S DGJ=$O(CONARR(2.141,DGJ)) Q:DGJ']"" D
. I CONARR(2.141,DGJ,.01,"E")["ELIG" D
. . I CONARR(2.141,DGJ,1,"E")="YES" S CONOK=1
I 'CONOK G TMP
;set string of the field numbers needed for the confidential address
S CONSTR=".1411^.1412^.1413^.1414^.1415^.1416^.14116^^.14112^^.14113^.1417^.1418^.14114^.14115"
N CONFARR
D STRG(.CONSTR,.CONFARR) ;place field numbers into an array
;
TMP ;temporary address
N TMPARR,TMPERR,TMPOK
S TMPOK=0
D GETS^DIQ(2,IENS,".12105;.1211:.1219;.1221:.1223","IE","TMPARR","TMPERR")
; EAS*1.0*151; JAM; Add Residential Address
I $D(TMPERR) S TMPOK=-1 G RES
S FLD=""
D OK(.TMPARR,.TMPOK) ;check for presence of temp address array
I 'TMPOK G RES
I $G(TMPARR(2,IENS,.12105,"E"))'="YES" S TMPOK=0 G RES
;treat null end date as if in the future
I DT'<$G(TMPARR(2,IENS,.1217,"I")),($G(TMPARR(2,IENS,.1218,"I")))']"" G TMP2
I DT>$G(TMPARR(2,IENS,.1218,"I")) S TMPOK=0 ;if date range in the past, don't display
TMP2 ;
; EAS*1.0*151; JAM; Add Residential Address
I 'TMPOK G RES
N TEMPARR
;set string of the field numbers needed for the temporary address
S TMPSTR=".1211^.1212^.1213^.1214^.1215^.12112^.1223^^.12113^^.12114^.1217^.1218^.1221^.1222"
D STRG(.TMPSTR,.TEMPARR) ;place field numbers into an array
;
; EAS*1.0*151; JAM; Add Residential Address
RES ;gather residential address
N RESARR,RESERR,RESOK,RESSTR
S RESOK=0
D GETS^DIQ(2,IENS,".1151:.11582","IE","RESARR","RESERR")
;D GETS^DIQ(2,IENS,".115*;.14105;.1411:.142","IE","CONARR","CONERR")
I $D(RESERR) S RESOK=-1 G OPT
S FLD=""
D OK(.RESARR,.RESOK) ;checking for presence of residential address array
;treat null end date as if in the future
I DT'<$G(RESARR(2,IENS,.1161,"I")),$G(RESARR(2,IENS,.1162,"I"))']"" G RES2
I DT>$G(RESARR(2,IENS,.1162,"I")) S RESOK=0 G OPT ;if date range in the past, don't display
I DT<$G(RESARR(2,IENS,.1161,"I")) S RESOK=0 G OPT ;if date range in the future, dont display
RES2 ;
I 'RESOK G OPT
;set string of the field numbers needed for the residential address
S RESSTR=".1151^.1152^.1153^.1154^.1155^.1156^.11573^^.1158^.11582^.11581^.1161^.1162^.11571^.11572"
N RESIDARR
D STRG(.RESSTR,.RESIDARR) ;place field numbers into an array
;
OPT ;let user decide to see confid. a/o temp address, residential address if disp. on screen
N DGELIG,DGEND,DGOPT,DGPROMPT,DIR,DGRET
S DGEND=0
; EAS*1.0*151; JAM; Add Residential Address to address choices
I RESOK'=1 D
.S DGOPT=$S(CONOK=1&(TMPOK=1):3,CONOK=1&(TMPOK=0):2,TMPOK=1&(CONOK=0):1,1:"")
E D
.S DGOPT=$S(CONOK=1&(TMPOK=1):4,CONOK=1&(TMPOK=0):5,TMPOK=1&(CONOK=0):6,1:7)
I DGOPT']"" S DGOPT=$S(CONOK=-1&(TMPOK=-1):8,CONOK=-1:9,TMPOK=-1:10,1:"")
; EAS*1.0*151; JAM; Change label to Confidential and add Residential Address
I $G(DGOPT)="" W !?5,PATNAM_" has no Temporary, Confidential or ",!?5,"Residential Address." W !! G END
I $G(DGOPT)>7 D
. W !?11,"There is invalid data in the "_$S(DGOPT=8:"Temporary and Confidential ",DGOPT=9:"Confidential ",10:"Temporary ")_"address"_$S(DGOPT=8:"es.",1:".")
. W !?11,"Please use Registration options to edit.",!!
I $E(IOST,1,2)["C-" D
. S DIR(0)="YAO",DIR("B")="Yes"
. ; EAS*1.0*151; JAM; - change labels from "Elig/Enroll Confidential" to "Conf Mailing" and "Temporary" to "Temp Mailing"
. ; and add Residential Address (add logic to test for residential address and add to prompt)
. S DGELIG="Conf Mailing"
. S DGPROMPT=$S(DGOPT=3:DGELIG_" and Temp Mailing",DGOPT=2:DGELIG,DGOPT=1:"Temporary Mailing",DGOPT=4:DGELIG_", Temp Mailing and Residential",DGOPT=5:DGELIG_" and Residential",1:"")
. I $G(DGPROMPT)="" S DGPROMPT=$S(DGOPT=6:"Temporary Mailing and Residential",DGOPT=7:"Residential",1:"")
. I $G(DGPROMPT)="" S DGEND=1 Q
. S DIR("A")="Would you like to view the "_DGPROMPT_" Address"_$S((DGOPT>2&(DGOPT<7)):"es",1:"")_"? "
. D ^DIR K DIR
. I Y'=1 S DGEND=1
I DGEND=1 G END
S DGC=2
;
;if displayed on screen offer to show addresses and do a page break for readability.
I DGC>1 D
. I $E(IOST,1,2)["C-" W @IOF
. W !!?23,"Patient Name: ",?37,PATNAM
;display the addresses that are populated
; EAS*1.0*151; JAM; Modify address labels to Confid Mailing and Temp Mailing and add Residential address
I CONOK=1 S TYPE=" Confid Mailing" D DISP(TYPE,.CONARR,.CONFARR)
I TMPOK=1 S TYPE=" Temp Mailing" D DISP(TYPE,.TMPARR,.TEMPARR)
; DGOPT=4 means all 3 addresses are present, so we should paginate the display prior to displaying residential address
I DGOPT=4 I $G(IOST)["C-" R !,"Enter <RETURN> to continue.",DGRET:DTIME W !
I RESOK=1 S TYPE=" Residential" D DISP(TYPE,.RESARR,.RESIDARR)
; EAS*1.0*151; JAM; Modify messages to "Confidential Mailing Address" and "Temporary Mailing" and add Residential Address message
I 'CONOK W !?8,"Patient "_PATNAM_" has no Confidential Mailing Address."
I 'TMPOK W !?8,"Patient "_PATNAM_" has no Temporary Mailing Address."
I 'RESOK W !?8,"Patient "_PATNAM_" has no Residential Address."
W !
G END
;
OK(ARR,OK) ;check for presence of an array
F S FLD=$O(ARR(2,IENS,FLD)) Q:'FLD!(OK) S:$G(ARR(2,IENS,FLD,"E"))]"" OK=1
Q
;
STRG(STR,STRARR) ;set the field string into an array
N DGD
F DGD=1:1:15 S STRARR(DGD)=$P(STR,U,DGD)
Q
;
;display address information
DISP(TYPE,ARR,STR) ;
N DGCNTRY,DGUSA
S DGUSA=0 ;I country=USA or "" display state/zip, E prov/postal code
S:$G(ARR(2,IENS,$G(STR(7)),"E"))="USA" DGUSA=1
S:$G(ARR(2,IENS,$G(STR(7)),"E"))']"" DGUSA=1
W !?10,TYPE_" Address: ",?37,$S($G(ARR(2,IENS,$G(STR(1)),"E"))]"":ARR(2,IENS,STR(1),"E"),1:"UNKNOWN STREET ADDRESS")
W:$G(ARR(2,IENS,$G(STR(2)),"E"))]"" !?37,ARR(2,IENS,STR(2),"E")
W:$G(ARR(2,IENS,STR(3),"E"))]"" !?37,ARR(2,IENS,STR(3),"E")
I DGUSA D ;US address or null country which defaults to US
. W !?37,$S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
. W $S($G(ARR(2,IENS,STR(5),"E"))]"":ARR(2,IENS,STR(5),"E"),1:"UNKNOWN STATE")_" "
. W:$G(ARR(2,IENS,STR(6),"E"))]"" ARR(2,IENS,STR(6),"E")
I 'DGUSA D ;foreign address
. W !?37,""
. W:$G(ARR(2,IENS,STR(15),"E"))]"" ARR(2,IENS,STR(15),"E")_" "
. W $S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
. W $S($G(ARR(2,IENS,STR(14),"E"))]"":ARR(2,IENS,STR(14),"E"),1:"UNKNOWN PROVINCE")_" "
I $G(ARR(2,IENS,STR(7),"E"))]"" D
. S DGCNTRY=ARR(2,IENS,STR(7),"E")
. S DGCNTRY=$$COUNTRY^DGADDUTL(.DGCNTRY)
. W !?37,DGCNTRY
; EAS*1.0*151; JAM; TYPE is modified from "Patient" to "Permanent Mailing" and new address type "Residential"
; EAS*1.0*203 ; ARF; TYPE is modified from "Permanent" to " Mailing"
I TYPE[" Mailing" W !?14,"Bad Address Indicator: ",?37,$G(ARR(2,IENS,STR(8),"E"))
W !?2,TYPE_" Add Change Date: ",?37,$G(ARR(2,IENS,STR(9),"E"))
I TYPE[" Mailing" W !?10,"Mailing Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
I TYPE["Residential" W !,TYPE_" Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
I TYPE[" Mailing" W:$G(ARR(2,IENS,STR(10),"E"))="VAMC" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
I TYPE'[" Mailing" W:$G(ARR(2,IENS,STR(11),"E"))]"" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
I TYPE'[" Mailing",TYPE'["Residential" W !?3,TYPE_" Add Start Date: ",?37,$G(ARR(2,IENS,STR(12),"E"))
I TYPE'[" Mailing",TYPE'["Residential" W !?5,TYPE_" Add End Date: ",?37,$G(ARR(2,IENS,STR(13),"E"))
W !
Q
;
END ; common exit point - reset device and prompt user for another name
K %ZIS D ^%ZISC,HOME^%ZIS
G PATADDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASAILK1 10326 printed Sep 23, 2025@19:29:45 Page 2
EASAILK1 ;ALB/BRM,ERC,JAM,ARF - Patient Address Inquiry ;18 Jul 2017 4:03 PM
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**13,29,39,70,151,203**;Mar 15, 2001;Build 17
+2 ;
+3 ;*151*; JAM - Add Residential Address and modify Permanent, Confidential, and Temporary address field labels and reformat the output
+4 ;
PATADDR ;view patient address
+1 ;
+2 NEW PATNAM,IENS,ZTSAVE
+3 NEW DTOUT,DUOUT,DIRUT,DIROUT,%ZIS,DIC,DA,DIQ,DLAYGO,Y,X
+4 ;
+5 ; prompt user for patient name and device
+6 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
+7 if ($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)!(Y=-1))
QUIT
+8 SET %ZIS="Q"
+9 SET IENS=+Y_","
SET PATNAM=$PIECE(Y,"^",2)
+10 SET ZTSAVE("IENS")=""
SET ZTSAVE("PATNAM")=""
+11 DO EN^XUTMDEVQ("QUE^EASAILK1","PATIENT ADDRESS INQUIRY",.ZTSAVE,.%ZIS)
+12 QUIT
QUE ;
+1 NEW DGC,CONOK,PATOK,TMPOK,FLD,CONARR,TMPARR,PATARR,CONERR,TMPERR,PATERR
+2 NEW CONSTR,TMPSTR,PATSTR,TYPE,CONFARR,TEMPARR
+3 ;
PAT ;patient address
+1 NEW PATOK
+2 DO GETS^DIQ(2,IENS,".111:.121","E","PATARR","PATERR")
+3 WRITE !?23,"Patient Name: ",?37,PATNAM
+4 ; exit if error occurs during DIQ call
+5 ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address
+6 ; EAS*1.0*203; ARF; Removed Permanent from the following message
+7 IF $DATA(PATERR)
WRITE !!?11,"There is invalid data in the Mailing Address",!?11,"Please use Registration options to edit",!!
GOTO CON
+8 ;
+9 ; exit if there is no address for patient
+10 SET FLD=""
SET PATOK=0
+11 DO OK(.PATARR,.PATOK)
+12 ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address
+13 ; EAS*1.0*203; ARF; Removed Permanent from the following message
+14 IF 'PATOK
WRITE !!?11,"*** No Mailing Address On File For This Patient ***",!!
GOTO CON
+15 ;set a string of the field numbers needed for the patient address
+16 SET PATSTR=".111^.112^.113^.114^.115^.1112^.1173^.121^.118^.119^.12^^^.1171^.1172"
+17 NEW STRARR
+18 ;place the fld numbers into an array
DO STRG(PATSTR,.STRARR)
+19 ; EAS*1.0*151; JAM; Change TYPE to "Permanent Mailing" (from "Patient")
+20 ; EAS*1.0*203; ARF; Removed "Permanent" from the following TYPE variable
+21 SET TYPE=" Mailing"
+22 SET DGC=1
+23 ;display the patient address information
+24 DO DISP(TYPE,.PATARR,.STRARR)
+25 ;
CON ;confidential address
+1 NEW CONARR,CONERR,CONOK,DGJ
+2 SET CONOK=0
+3 DO GETS^DIQ(2,IENS,".141*;.14105;.1411:.142","IE","CONARR","CONERR")
+4 IF $DATA(CONERR)
SET CONOK=-1
GOTO TMP
+5 SET FLD=""
+6 ;checking for presence of confid address array
DO OK(.CONARR,.CONOK)
+7 IF $GET(CONARR(2,IENS,.14105,"E"))'="YES"
SET CONOK=0
GOTO TMP
+8 ;treat null end date as if in the future
+9 IF DT'<$GET(CONARR(2,IENS,.1417,"I"))
IF $GET(CONARR(2,IENS,.1418,"I"))']""
GOTO CON2
+10 ;if date range in the past, don't display
IF DT>$GET(CONARR(2,IENS,.1418,"I"))
SET CONOK=0
GOTO TMP
+11 ;if date range in the future, dont display
IF DT<$GET(CONARR(2,IENS,.1417,"I"))
SET CONOK=0
GOTO TMP
CON2 ;
+1 SET DGJ=""
+2 ;now check for active E/E confid address
SET CONOK=0
+3 FOR
SET DGJ=$ORDER(CONARR(2.141,DGJ))
if DGJ']""
QUIT
Begin DoDot:1
+4 IF CONARR(2.141,DGJ,.01,"E")["ELIG"
Begin DoDot:2
+5 IF CONARR(2.141,DGJ,1,"E")="YES"
SET CONOK=1
End DoDot:2
End DoDot:1
+6 IF 'CONOK
GOTO TMP
+7 ;set string of the field numbers needed for the confidential address
+8 SET CONSTR=".1411^.1412^.1413^.1414^.1415^.1416^.14116^^.14112^^.14113^.1417^.1418^.14114^.14115"
+9 NEW CONFARR
+10 ;place field numbers into an array
DO STRG(.CONSTR,.CONFARR)
+11 ;
TMP ;temporary address
+1 NEW TMPARR,TMPERR,TMPOK
+2 SET TMPOK=0
+3 DO GETS^DIQ(2,IENS,".12105;.1211:.1219;.1221:.1223","IE","TMPARR","TMPERR")
+4 ; EAS*1.0*151; JAM; Add Residential Address
+5 IF $DATA(TMPERR)
SET TMPOK=-1
GOTO RES
+6 SET FLD=""
+7 ;check for presence of temp address array
DO OK(.TMPARR,.TMPOK)
+8 IF 'TMPOK
GOTO RES
+9 IF $GET(TMPARR(2,IENS,.12105,"E"))'="YES"
SET TMPOK=0
GOTO RES
+10 ;treat null end date as if in the future
+11 IF DT'<$GET(TMPARR(2,IENS,.1217,"I"))
IF ($GET(TMPARR(2,IENS,.1218,"I")))']""
GOTO TMP2
+12 ;if date range in the past, don't display
IF DT>$GET(TMPARR(2,IENS,.1218,"I"))
SET TMPOK=0
TMP2 ;
+1 ; EAS*1.0*151; JAM; Add Residential Address
+2 IF 'TMPOK
GOTO RES
+3 NEW TEMPARR
+4 ;set string of the field numbers needed for the temporary address
+5 SET TMPSTR=".1211^.1212^.1213^.1214^.1215^.12112^.1223^^.12113^^.12114^.1217^.1218^.1221^.1222"
+6 ;place field numbers into an array
DO STRG(.TMPSTR,.TEMPARR)
+7 ;
+8 ; EAS*1.0*151; JAM; Add Residential Address
RES ;gather residential address
+1 NEW RESARR,RESERR,RESOK,RESSTR
+2 SET RESOK=0
+3 DO GETS^DIQ(2,IENS,".1151:.11582","IE","RESARR","RESERR")
+4 ;D GETS^DIQ(2,IENS,".115*;.14105;.1411:.142","IE","CONARR","CONERR")
+5 IF $DATA(RESERR)
SET RESOK=-1
GOTO OPT
+6 SET FLD=""
+7 ;checking for presence of residential address array
DO OK(.RESARR,.RESOK)
+8 ;treat null end date as if in the future
+9 IF DT'<$GET(RESARR(2,IENS,.1161,"I"))
IF $GET(RESARR(2,IENS,.1162,"I"))']""
GOTO RES2
+10 ;if date range in the past, don't display
IF DT>$GET(RESARR(2,IENS,.1162,"I"))
SET RESOK=0
GOTO OPT
+11 ;if date range in the future, dont display
IF DT<$GET(RESARR(2,IENS,.1161,"I"))
SET RESOK=0
GOTO OPT
RES2 ;
+1 IF 'RESOK
GOTO OPT
+2 ;set string of the field numbers needed for the residential address
+3 SET RESSTR=".1151^.1152^.1153^.1154^.1155^.1156^.11573^^.1158^.11582^.11581^.1161^.1162^.11571^.11572"
+4 NEW RESIDARR
+5 ;place field numbers into an array
DO STRG(.RESSTR,.RESIDARR)
+6 ;
OPT ;let user decide to see confid. a/o temp address, residential address if disp. on screen
+1 NEW DGELIG,DGEND,DGOPT,DGPROMPT,DIR,DGRET
+2 SET DGEND=0
+3 ; EAS*1.0*151; JAM; Add Residential Address to address choices
+4 IF RESOK'=1
Begin DoDot:1
+5 SET DGOPT=$SELECT(CONOK=1&(TMPOK=1):3,CONOK=1&(TMPOK=0):2,TMPOK=1&(CONOK=0):1,1:"")
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET DGOPT=$SELECT(CONOK=1&(TMPOK=1):4,CONOK=1&(TMPOK=0):5,TMPOK=1&(CONOK=0):6,1:7)
End DoDot:1
+8 IF DGOPT']""
SET DGOPT=$SELECT(CONOK=-1&(TMPOK=-1):8,CONOK=-1:9,TMPOK=-1:10,1:"")
+9 ; EAS*1.0*151; JAM; Change label to Confidential and add Residential Address
+10 IF $GET(DGOPT)=""
WRITE !?5,PATNAM_" has no Temporary, Confidential or ",!?5,"Residential Address."
WRITE !!
GOTO END
+11 IF $GET(DGOPT)>7
Begin DoDot:1
+12 WRITE !?11,"There is invalid data in the "_$SELECT(DGOPT=8:"Temporary and Confidential ",DGOPT=9:"Confidential ",10:"Temporary ")_"address"_$SELECT(DGOPT=8:"es.",1:".")
+13 WRITE !?11,"Please use Registration options to edit.",!!
End DoDot:1
+14 IF $EXTRACT(IOST,1,2)["C-"
Begin DoDot:1
+15 SET DIR(0)="YAO"
SET DIR("B")="Yes"
+16 ; EAS*1.0*151; JAM; - change labels from "Elig/Enroll Confidential" to "Conf Mailing" and "Temporary" to "Temp Mailing"
+17 ; and add Residential Address (add logic to test for residential address and add to prompt)
+18 SET DGELIG="Conf Mailing"
+19 SET DGPROMPT=$SELECT(DGOPT=3:DGELIG_" and Temp Mailing",DGOPT=2:DGELIG,DGOPT=1:"Temporary Mailing",DGOPT=4:DGELIG_", Temp Mailing and Residential",DGOPT=5:DGELIG_" and Residential",1:"")
+20 IF $GET(DGPROMPT)=""
SET DGPROMPT=$SELECT(DGOPT=6:"Temporary Mailing and Residential",DGOPT=7:"Residential",1:"")
+21 IF $GET(DGPROMPT)=""
SET DGEND=1
QUIT
+22 SET DIR("A")="Would you like to view the "_DGPROMPT_" Address"_$SELECT((DGOPT>2&(DGOPT<7)):"es",1:"")_"? "
+23 DO ^DIR
KILL DIR
+24 IF Y'=1
SET DGEND=1
End DoDot:1
+25 IF DGEND=1
GOTO END
+26 SET DGC=2
+27 ;
+28 ;if displayed on screen offer to show addresses and do a page break for readability.
+29 IF DGC>1
Begin DoDot:1
+30 IF $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
+31 WRITE !!?23,"Patient Name: ",?37,PATNAM
End DoDot:1
+32 ;display the addresses that are populated
+33 ; EAS*1.0*151; JAM; Modify address labels to Confid Mailing and Temp Mailing and add Residential address
+34 IF CONOK=1
SET TYPE=" Confid Mailing"
DO DISP(TYPE,.CONARR,.CONFARR)
+35 IF TMPOK=1
SET TYPE=" Temp Mailing"
DO DISP(TYPE,.TMPARR,.TEMPARR)
+36 ; DGOPT=4 means all 3 addresses are present, so we should paginate the display prior to displaying residential address
+37 IF DGOPT=4
IF $GET(IOST)["C-"
READ !,"Enter <RETURN> to continue.",DGRET:DTIME
WRITE !
+38 IF RESOK=1
SET TYPE=" Residential"
DO DISP(TYPE,.RESARR,.RESIDARR)
+39 ; EAS*1.0*151; JAM; Modify messages to "Confidential Mailing Address" and "Temporary Mailing" and add Residential Address message
+40 IF 'CONOK
WRITE !?8,"Patient "_PATNAM_" has no Confidential Mailing Address."
+41 IF 'TMPOK
WRITE !?8,"Patient "_PATNAM_" has no Temporary Mailing Address."
+42 IF 'RESOK
WRITE !?8,"Patient "_PATNAM_" has no Residential Address."
+43 WRITE !
+44 GOTO END
+45 ;
OK(ARR,OK) ;check for presence of an array
+1 FOR
SET FLD=$ORDER(ARR(2,IENS,FLD))
if 'FLD!(OK)
QUIT
if $GET(ARR(2,IENS,FLD,"E"))]""
SET OK=1
+2 QUIT
+3 ;
STRG(STR,STRARR) ;set the field string into an array
+1 NEW DGD
+2 FOR DGD=1:1:15
SET STRARR(DGD)=$PIECE(STR,U,DGD)
+3 QUIT
+4 ;
+5 ;display address information
DISP(TYPE,ARR,STR) ;
+1 NEW DGCNTRY,DGUSA
+2 ;I country=USA or "" display state/zip, E prov/postal code
SET DGUSA=0
+3 if $GET(ARR(2,IENS,$GET(STR(7)),"E"))="USA"
SET DGUSA=1
+4 if $GET(ARR(2,IENS,$GET(STR(7)),"E"))']""
SET DGUSA=1
+5 WRITE !?10,TYPE_" Address: ",?37,$SELECT($GET(ARR(2,IENS,$GET(STR(1)),"E"))]"":ARR(2,IENS,STR(1),"E"),1:"UNKNOWN STREET ADDRESS")
+6 if $GET(ARR(2,IENS,$GET(STR(2)),"E"))]""
WRITE !?37,ARR(2,IENS,STR(2),"E")
+7 if $GET(ARR(2,IENS,STR(3),"E"))]""
WRITE !?37,ARR(2,IENS,STR(3),"E")
+8 ;US address or null country which defaults to US
IF DGUSA
Begin DoDot:1
+9 WRITE !?37,$SELECT($GET(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
+10 WRITE $SELECT($GET(ARR(2,IENS,STR(5),"E"))]"":ARR(2,IENS,STR(5),"E"),1:"UNKNOWN STATE")_" "
+11 if $GET(ARR(2,IENS,STR(6),"E"))]""
WRITE ARR(2,IENS,STR(6),"E")
End DoDot:1
+12 ;foreign address
IF 'DGUSA
Begin DoDot:1
+13 WRITE !?37,""
+14 if $GET(ARR(2,IENS,STR(15),"E"))]""
WRITE ARR(2,IENS,STR(15),"E")_" "
+15 WRITE $SELECT($GET(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
+16 WRITE $SELECT($GET(ARR(2,IENS,STR(14),"E"))]"":ARR(2,IENS,STR(14),"E"),1:"UNKNOWN PROVINCE")_" "
End DoDot:1
+17 IF $GET(ARR(2,IENS,STR(7),"E"))]""
Begin DoDot:1
+18 SET DGCNTRY=ARR(2,IENS,STR(7),"E")
+19 SET DGCNTRY=$$COUNTRY^DGADDUTL(.DGCNTRY)
+20 WRITE !?37,DGCNTRY
End DoDot:1
+21 ; EAS*1.0*151; JAM; TYPE is modified from "Patient" to "Permanent Mailing" and new address type "Residential"
+22 ; EAS*1.0*203 ; ARF; TYPE is modified from "Permanent" to " Mailing"
+23 IF TYPE[" Mailing"
WRITE !?14,"Bad Address Indicator: ",?37,$GET(ARR(2,IENS,STR(8),"E"))
+24 WRITE !?2,TYPE_" Add Change Date: ",?37,$GET(ARR(2,IENS,STR(9),"E"))
+25 IF TYPE[" Mailing"
WRITE !?10,"Mailing Add Change Source: ",?37,$GET(ARR(2,IENS,STR(10),"E"))
+26 IF TYPE["Residential"
WRITE !,TYPE_" Add Change Source: ",?37,$GET(ARR(2,IENS,STR(10),"E"))
+27 IF TYPE[" Mailing"
if $GET(ARR(2,IENS,STR(10),"E"))="VAMC"
WRITE !?2,TYPE_" Add Change Site: ",?37,$GET(ARR(2,IENS,STR(11),"E"))
+28 IF TYPE'[" Mailing"
if $GET(ARR(2,IENS,STR(11),"E"))]""
WRITE !?2,TYPE_" Add Change Site: ",?37,$GET(ARR(2,IENS,STR(11),"E"))
+29 IF TYPE'[" Mailing"
IF TYPE'["Residential"
WRITE !?3,TYPE_" Add Start Date: ",?37,$GET(ARR(2,IENS,STR(12),"E"))
+30 IF TYPE'[" Mailing"
IF TYPE'["Residential"
WRITE !?5,TYPE_" Add End Date: ",?37,$GET(ARR(2,IENS,STR(13),"E"))
+31 WRITE !
+32 QUIT
+33 ;
END ; common exit point - reset device and prompt user for another name
+1 KILL %ZIS
DO ^%ZISC
DO HOME^%ZIS
+2 GOTO PATADDR
+3 QUIT
