DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM,ARF - PATIENT ADDRESS ; 19 Jul 2017 3:03 PM
;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941,1010,1040,1056**;Aug 13, 1993;Build 18
Q
ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option)
N %,QUIT,DIC,Y,DFN,USERSEL
ADDRLOOP ;
N X,DGLN,DGCNT,DGLINE,DIWL,DIWR,DIWF ;DG*5.3*1056
W !!
K DIC,Y,DFN,USERSEL
S DIC="^DPT(",DIC(0)="AEMZQ",DIC("A")="Veteran Name/SSN: " D ^DIC
I $D(DTOUT)!($D(DUOUT)) Q
Q:Y'>0
;
S DFN=+Y,QUIT=0
L +^DPT(DFN):3 E W !!,"Patient is being edited. Try again later." G ADDR
F D Q:QUIT
.; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing"
.; Patch DG*5.3*1056 Remove (P)ermanent from the following prompt, changed to (M)ailing
.W !!
.S X="Do you want to update the (M)ailing Address, (T)emporary Mailing Address, or (B)oth? "
. ;Patch DG*5.3*1056 - use DIWP to format the prompt
.K ^UTILITY($J,"W") S DIWL=0,DIWR=79,DIWF="" D ^DIWP
.S DGCNT=^UTILITY($J,"W",0)
.F DGLN=1:1:DGCNT S DGLINE=$TR(^UTILITY($J,"W",0,DGLN,0),"_"," ") W !,DGLINE
.K ^UTILITY($J,"W")
.R USERSEL:300
.I '$T S USERSEL="^"
.I USERSEL["^"!(USERSEL="") S QUIT=1 Q
.S USERSEL=$TR(USERSEL,"mtb","MTB") ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
.I USERSEL'="M",USERSEL'="T",USERSEL'="B" D Q ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
..W !,"Invalid selection!"
.I (USERSEL="M")!(USERSEL="B") W ! D UPDATE(DFN,"PERM") ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
.I USERSEL="T"!(USERSEL="B") D UPDATE(DFN,"TEMP")
.S QUIT=1
L -^DPT(DFN)
G ADDRLOOP
ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
; Input -- DFN
;
; DG*5.3*1040 - New variable DGADDFG to track called from entry point ADD
N RETVAL,ADDYN,DGADDFG S DGADDFG=1
;Display the mailing address (DG*5.3*851)
D DISPADD^DGADDUT2(DFN)
S (RETVAL,ADDYN)=0
F D Q:ADDYN
.;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address:
.;DG*5.3*1056 removed Permanent from the following prompt
.S ADDYN=$$ADDYN("Do you want to edit the Patient's Mailing Address")
.S RETVAL=ADDYN
.I ADDYN'=1,ADDYN'=2 S (ADDYN,RETVAL)=0
.I 'ADDYN W !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
I ADDYN=1,$G(DFN)'="",$D(^DPT(DFN,0)) D
.D UPDATE(DFN,"PERM")
.; DG*5.3*1040 - Check if DGTMOT exists and return -1
.I +$G(DGTMOT) S RETVAL=-1
.E S RETVAL=1
Q RETVAL
ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
; Input -- None
; Output -- 1 = YES
; 2 = NO
; -1 = Aborted
;
N %
W !,PROMPT
D YN^DICN
Q %
UPDATE(DFN,TYPE) ; Update the Address
; Input -- TYPE = "PERM" for Permanent Address
; = "TEMP" for Temporary Address
; Output -- None
;
I TYPE'="PERM",TYPE'="TEMP" Q
I TYPE="PERM" D
.W !
.; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here
.N FLG S FLG(1)=0,FLG(2)=1
.D ADDRED(DFN,.FLG)
;
I TYPE="TEMP" D
.D EDITTADR(DFN)
;
Q
UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
;
D UPDDTTM^DGADDUT2(DFN,TYPE)
Q
ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
;Input:
; DFN (required) - Internal Entry # of Patient File (#2)
; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
; FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
; FLG(2) - if 1, display before & after address for user confirmation
N SRC,%,DGINPUT,I,X,Y
I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
S SRC="ADDUTL"
D EN^DGREGAED(DFN,.FLG,SRC)
;
; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!!
;
; Update the Date/Time Stamp
;The next line was disabled to fix problem of Date/Time stamp being
;updated even if no changes were made (DG*5.3*851).
;D UPDDTTM(DFN,TYPE)
Q
GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR")
F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173 D
. S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
M DGPRIOR=DGARRY("OLD")
Q
GETUPDTS(DFN,DGINPUT) ; Get current address fields.
N DGCURR,DGN,DGARRY
D GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
F DGN=.118,.119,.12,.122 D
. S DGARRY("NEW",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
M DGINPUT=DGARRY("NEW")
Q
FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
N RETVAL
S RETVAL=0
D
.I DGOLD(.111)'=$G(DGNEW(.111)) S RETVAL=1 Q
.I DGOLD(.112)'=$G(DGNEW(.112)) S RETVAL=1 Q
.I DGOLD(.113)'=$G(DGNEW(.113)) S RETVAL=1 Q
.I DGOLD(.114)'=$G(DGNEW(.114)) S RETVAL=1 Q
.I DGOLD(.115)'=$P($G(DGNEW(.115)),"^",2) S RETVAL=1 Q
.I DGOLD(.1112)'=$G(DGNEW(.1112)) S RETVAL=1 Q
.I DGOLD(.117)'=$P($G(DGNEW(.117)),"^",2) S RETVAL=1 Q
.I DGOLD(.131)'=$G(DGNEW(.131)) S RETVAL=1 Q
.I DGOLD(.1171)'=$G(DGNEW(.1171)) S RETVAL=1 Q
.I DGOLD(.1172)'=$G(DGNEW(.1172)) S RETVAL=1 Q
.I DGOLD(.1173)'=$P($G(DGNEW(.1173)),"^",2) S RETVAL=1 Q
.I DGOLD(.121)'=$G(DGNEW(.121)) S RETVAL=1 Q
Q RETVAL
FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
; ** NOTE we have to default the value for "US" into the prompt if it is blank
N FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
S:'$G(FILE) FILE=2 I '$G(FIELD) S FIELD=.1173
S DIR(0)=FILE_","_FIELD,DONE=0 S:DFN DA=DFN
S DIR("B")=$E($$CNTRYI^DGADDUTL(CIEN),1,19) I DIR("B")=-1 S DIR("B")="UNKNOWN COUNTRY"
F D Q:DONE
. D ^DIR
. I $D(DTOUT) S DONE=1,FORGN=-1 Q
. I $D(DUOUT)!$D(DIROUT) W !,"EXIT NOT ALLOWED" Q
. I $D(DIRUT) W !,"This is a required response." Q
. S COUNTRY=$P($G(Y),"^",2),FORGN=$$FORIEN($P($G(Y),"^")),DONE=1
Q FORGN
UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
;
D UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
Q
EDITTADR(DFN) ; Edit Temporary Address
N DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
I $G(DFN)="" Q
;I ($G(DFN)'?.N) Q
;
; Get the current Temporary Address and display it
D GETTADR(DFN,.DGPRIOR)
D DISPTADR(DFN,.DGPRIOR)
W !!
;
I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
;
; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5)
;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
S DGCH=3,DGRPAN="1,2,3,4,5",DGDR="",DGRPS=1.1
D CHOICE^DGRPP
D ^DGRPE
; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!! Q
; Update the Date/Time Stamp
D UPDDTTM(DFN,TYPE)
Q
GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
D GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR")
F DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223 D
.S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
M DGPRIOR=DGARRY("OLD")
Q
DISPTADR(DFN,DGARRY) ; Display Temporary Address
N DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
N DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
;
S DGADRACT=$G(DGARRY(.12105))
S DGADR1=$G(DGARRY(.1211))
S DGADR2=$G(DGARRY(.1212))
S DGADR3=$G(DGARRY(.1213))
S DGCITY=$G(DGARRY(.1214))
S DGSTATE=$G(DGARRY(.1215))
S DGZIP=$G(DGARRY(.1216))
S DGCOUNTY=$G(DGARRY(.12111))
I DGCOUNTY'="",DGSTATE'="",$D(^DIC(5,DGSTATE,1,DGCOUNTY,0)) D
.S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$S($P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"")
;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872
;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)
I DGADRACT'="Y" S DGCOUNTY="NOT APPLICABLE"
I DGSTATE'="",$D(^DIC(5,DGSTATE,0)) S DGSTATE=$P(^DIC(5,DGSTATE,0),"^",2)
S DGPROV=$G(DGARRY(.1221))
S DGPCODE=$G(DGARRY(.1222))
S DGCNTRY=$G(DGARRY(.1223))
S DGFORN=$$FORIEN(DGCNTRY)
I DGCNTRY]"" S DGCNTRY=$$CNTRYI(DGCNTRY)
S DGPHONE=$G(DGARRY(.1219))
S DGFROMDT=$$FMTE^XLFDT($G(DGARRY(.1217)))
S DGTODT=$$FMTE^XLFDT($G(DGARRY(.1218)))
;
;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address:
W !!,"Temporary Mailing Address: "
I DGADRACT="Y" D
.W:DGADR1'="" !?9,DGADR1
.W:DGADR2'="" !?9,DGADR2
.W:DGADR3'="" !?9,DGADR3
.I DGFORN=0 D
..W !?9,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
.;I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"") ;DG*1010 comment out
.I DGFORN W !?8,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"")_" "_$S(DGPCODE'="":DGPCODE,1:"") ;DG*1010 - display postal code last
;commenting out, causes address to print 2x. Patch 872
;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
;Removing lines from dot structure Patch 872
W !," County: "_DGCOUNTY
W !," Phone: "_DGPHONE
W !,"From/To: "_$P(DGFROMDT,",")_","_$P(DGFROMDT,", ",2)_"-"_$P(DGTODT,",")_","_$P(DGTODT,", ",2)
;
I $G(DGARRY(.12105))="N" D
.W:$G(DGARRY(.1211))="" !?9,"NO TEMPORARY ADDRESS"
.W:$G(DGARRY(.1212))="" !?9,""
.W !," County: NOT APPLICABLE"
.W !," Phone: NOT APPLICABLE"
.W !,"From/To: NOT APPLICABLE"
Q
COUNTRY(DGC) ;
;where DGC is the external value of the country
;return value is in upper case display mode
;if DGC is invalid, return -1
N DGCC,DGIEN
; if input is NULL change to US
I $G(DGC)="" S DGC="USA"
; Get IEN from B index, error if not found
S DGIEN=$O(^HL(779.004,"B",DGC,"")) Q:DGIEN']"" -1
; xlate IEN to POSTAL NAME
S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
; if POSTAL NAME = "<NULL>" return DESCRIPTION
I DGCC="<NULL>" D
. S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
Q DGCC
FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
; DGC is the external value of the country (.01 field of file 779.004)
N DGFOR
S DGFOR=0
I $G(DGC)="" Q DGFOR
I '$D(^HL(779.004,"B",DGC)) Q -1
I DGC'="USA" S DGFOR=1
Q DGFOR
CNTRYI(DGIEN) ;where DGC is the internal value of the country
;return DGC as the display value for the country
;if the input value is not a valid IEN, return -1
;if the input value is null, return null
N DGCC
I $G(DGIEN)="" Q ""
I '$D(^HL(779.004,DGIEN,0)) Q -1
; xlate IEN to POSTAL NAME
S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
; if POSTAL NAME = "<NULL>" return DESCRIPTION
I DGCC="<NULL>" D
. S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
Q DGCC
FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
;DGC is the IEN of the country file (#779.004)
N DGFOR
S DGFOR=0
I $G(DGC)="" Q DGFOR
I DGC'?1.3N Q -1
I '$D(^HL(779.004,DGC,0)) Q -1
I DGC]"",(DGC'=$O(^HL(779.004,"B","USA",""))) S DGFOR=1
Q DGFOR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGADDUTL 11621 printed Sep 23, 2025@20:17:01 Page 2
DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM,ARF - PATIENT ADDRESS ; 19 Jul 2017 3:03 PM
+1 ;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941,1010,1040,1056**;Aug 13, 1993;Build 18
+2 QUIT
ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option)
+1 NEW %,QUIT,DIC,Y,DFN,USERSEL
ADDRLOOP ;
+1 ;DG*5.3*1056
NEW X,DGLN,DGCNT,DGLINE,DIWL,DIWR,DIWF
+2 WRITE !!
+3 KILL DIC,Y,DFN,USERSEL
+4 SET DIC="^DPT("
SET DIC(0)="AEMZQ"
SET DIC("A")="Veteran Name/SSN: "
DO ^DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+6 if Y'>0
QUIT
+7 ;
+8 SET DFN=+Y
SET QUIT=0
+9 LOCK +^DPT(DFN):3
IF '$TEST
WRITE !!,"Patient is being edited. Try again later."
GOTO ADDR
+10 FOR
Begin DoDot:1
+11 ; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing"
+12 ; Patch DG*5.3*1056 Remove (P)ermanent from the following prompt, changed to (M)ailing
+13 WRITE !!
+14 SET X="Do you want to update the (M)ailing Address, (T)emporary Mailing Address, or (B)oth? "
+15 ;Patch DG*5.3*1056 - use DIWP to format the prompt
+16 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=79
SET DIWF=""
DO ^DIWP
+17 SET DGCNT=^UTILITY($JOB,"W",0)
+18 FOR DGLN=1:1:DGCNT
SET DGLINE=$TRANSLATE(^UTILITY($JOB,"W",0,DGLN,0),"_"," ")
WRITE !,DGLINE
+19 KILL ^UTILITY($JOB,"W")
+20 READ USERSEL:300
+21 IF '$TEST
SET USERSEL="^"
+22 IF USERSEL["^"!(USERSEL="")
SET QUIT=1
QUIT
+23 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
SET USERSEL=$TRANSLATE(USERSEL,"mtb","MTB")
+24 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
IF USERSEL'="M"
IF USERSEL'="T"
IF USERSEL'="B"
Begin DoDot:2
+25 WRITE !,"Invalid selection!"
End DoDot:2
QUIT
+26 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
IF (USERSEL="M")!(USERSEL="B")
WRITE !
DO UPDATE(DFN,"PERM")
+27 IF USERSEL="T"!(USERSEL="B")
DO UPDATE(DFN,"TEMP")
+28 SET QUIT=1
End DoDot:1
if QUIT
QUIT
+29 LOCK -^DPT(DFN)
+30 GOTO ADDRLOOP
ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
+1 ; Input -- DFN
+2 ;
+3 ; DG*5.3*1040 - New variable DGADDFG to track called from entry point ADD
+4 NEW RETVAL,ADDYN,DGADDFG
SET DGADDFG=1
+5 ;Display the mailing address (DG*5.3*851)
+6 DO DISPADD^DGADDUT2(DFN)
+7 SET (RETVAL,ADDYN)=0
+8 FOR
Begin DoDot:1
+9 ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address:
+10 ;DG*5.3*1056 removed Permanent from the following prompt
+11 SET ADDYN=$$ADDYN("Do you want to edit the Patient's Mailing Address")
+12 SET RETVAL=ADDYN
+13 IF ADDYN'=1
IF ADDYN'=2
SET (ADDYN,RETVAL)=0
+14 IF 'ADDYN
WRITE !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
End DoDot:1
if ADDYN
QUIT
+15 IF ADDYN=1
IF $GET(DFN)'=""
IF $DATA(^DPT(DFN,0))
Begin DoDot:1
+16 DO UPDATE(DFN,"PERM")
+17 ; DG*5.3*1040 - Check if DGTMOT exists and return -1
+18 IF +$GET(DGTMOT)
SET RETVAL=-1
+19 IF '$TEST
SET RETVAL=1
End DoDot:1
+20 QUIT RETVAL
ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
+1 ; Input -- None
+2 ; Output -- 1 = YES
+3 ; 2 = NO
+4 ; -1 = Aborted
+5 ;
+6 NEW %
+7 WRITE !,PROMPT
+8 DO YN^DICN
+9 QUIT %
UPDATE(DFN,TYPE) ; Update the Address
+1 ; Input -- TYPE = "PERM" for Permanent Address
+2 ; = "TEMP" for Temporary Address
+3 ; Output -- None
+4 ;
+5 IF TYPE'="PERM"
IF TYPE'="TEMP"
QUIT
+6 IF TYPE="PERM"
Begin DoDot:1
+7 WRITE !
+8 ; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here
+9 NEW FLG
SET FLG(1)=0
SET FLG(2)=1
+10 DO ADDRED(DFN,.FLG)
End DoDot:1
+11 ;
+12 IF TYPE="TEMP"
Begin DoDot:1
+13 DO EDITTADR(DFN)
End DoDot:1
+14 ;
+15 QUIT
UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
+1 ;
+2 DO UPDDTTM^DGADDUT2(DFN,TYPE)
+3 QUIT
ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
+1 ;Input:
+2 ; DFN (required) - Internal Entry # of Patient File (#2)
+3 ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
+4 ; FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
+5 ; FLG(2) - if 1, display before & after address for user confirmation
+6 NEW SRC,%,DGINPUT,I,X,Y
+7 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
IF '$GET(DGADDFG)
NEW DGTMOT
SET DGTMOT=0
+8 SET SRC="ADDUTL"
+9 DO EN^DGREGAED(DFN,.FLG,SRC)
+10 ;
+11 ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
+12 IF $GET(DGTMOT)
IF '$GET(DGADDFG)
WRITE @IOF,!!!
+13 ;
+14 ; Update the Date/Time Stamp
+15 ;The next line was disabled to fix problem of Date/Time stamp being
+16 ;updated even if no changes were made (DG*5.3*851).
+17 ;D UPDDTTM(DFN,TYPE)
+18 QUIT
GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
+1 NEW DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
+2 DO GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR")
+3 FOR DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173
Begin DoDot:1
+4 SET DGARRY("OLD",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
End DoDot:1
+5 MERGE DGPRIOR=DGARRY("OLD")
+6 QUIT
GETUPDTS(DFN,DGINPUT) ; Get current address fields.
+1 NEW DGCURR,DGN,DGARRY
+2 DO GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
+3 FOR DGN=.118,.119,.12,.122
Begin DoDot:1
+4 SET DGARRY("NEW",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
End DoDot:1
+5 MERGE DGINPUT=DGARRY("NEW")
+6 QUIT
FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
+1 NEW RETVAL
+2 SET RETVAL=0
+3 Begin DoDot:1
+4 IF DGOLD(.111)'=$GET(DGNEW(.111))
SET RETVAL=1
QUIT
+5 IF DGOLD(.112)'=$GET(DGNEW(.112))
SET RETVAL=1
QUIT
+6 IF DGOLD(.113)'=$GET(DGNEW(.113))
SET RETVAL=1
QUIT
+7 IF DGOLD(.114)'=$GET(DGNEW(.114))
SET RETVAL=1
QUIT
+8 IF DGOLD(.115)'=$PIECE($GET(DGNEW(.115)),"^",2)
SET RETVAL=1
QUIT
+9 IF DGOLD(.1112)'=$GET(DGNEW(.1112))
SET RETVAL=1
QUIT
+10 IF DGOLD(.117)'=$PIECE($GET(DGNEW(.117)),"^",2)
SET RETVAL=1
QUIT
+11 IF DGOLD(.131)'=$GET(DGNEW(.131))
SET RETVAL=1
QUIT
+12 IF DGOLD(.1171)'=$GET(DGNEW(.1171))
SET RETVAL=1
QUIT
+13 IF DGOLD(.1172)'=$GET(DGNEW(.1172))
SET RETVAL=1
QUIT
+14 IF DGOLD(.1173)'=$PIECE($GET(DGNEW(.1173)),"^",2)
SET RETVAL=1
QUIT
+15 IF DGOLD(.121)'=$GET(DGNEW(.121))
SET RETVAL=1
QUIT
End DoDot:1
+16 QUIT RETVAL
FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
+1 ; ** NOTE we have to default the value for "US" into the prompt if it is blank
+2 NEW FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
+3 if '$GET(FILE)
SET FILE=2
IF '$GET(FIELD)
SET FIELD=.1173
+4 SET DIR(0)=FILE_","_FIELD
SET DONE=0
if DFN
SET DA=DFN
+5 SET DIR("B")=$EXTRACT($$CNTRYI^DGADDUTL(CIEN),1,19)
IF DIR("B")=-1
SET DIR("B")="UNKNOWN COUNTRY"
+6 FOR
Begin DoDot:1
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET DONE=1
SET FORGN=-1
QUIT
+9 IF $DATA(DUOUT)!$DATA(DIROUT)
WRITE !,"EXIT NOT ALLOWED"
QUIT
+10 IF $DATA(DIRUT)
WRITE !,"This is a required response."
QUIT
+11 SET COUNTRY=$PIECE($GET(Y),"^",2)
SET FORGN=$$FORIEN($PIECE($GET(Y),"^"))
SET DONE=1
End DoDot:1
if DONE
QUIT
+12 QUIT FORGN
UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
+1 ;
+2 DO UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
+3 QUIT
EDITTADR(DFN) ; Edit Temporary Address
+1 NEW DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
+2 IF $GET(DFN)=""
QUIT
+3 ;I ($G(DFN)'?.N) Q
+4 ;
+5 ; Get the current Temporary Address and display it
+6 DO GETTADR(DFN,.DGPRIOR)
+7 DO DISPTADR(DFN,.DGPRIOR)
+8 WRITE !!
+9 ;
+10 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
IF '$GET(DGADDFG)
NEW DGTMOT
SET DGTMOT=0
+11 ;
+12 ; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5)
+13 ;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
+14 SET DGCH=3
SET DGRPAN="1,2,3,4,5"
SET DGDR=""
SET DGRPS=1.1
+15 DO CHOICE^DGRPP
+16 DO ^DGRPE
+17 ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
+18 IF $GET(DGTMOT)
IF '$GET(DGADDFG)
WRITE @IOF,!!!
QUIT
+19 ; Update the Date/Time Stamp
+20 DO UPDDTTM(DFN,TYPE)
+21 QUIT
GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
+1 NEW DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
+2 DO GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR")
+3 FOR DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223
Begin DoDot:1
+4 SET DGARRY("OLD",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
End DoDot:1
+5 MERGE DGPRIOR=DGARRY("OLD")
+6 QUIT
DISPTADR(DFN,DGARRY) ; Display Temporary Address
+1 NEW DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
+2 NEW DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
+3 ;
+4 SET DGADRACT=$GET(DGARRY(.12105))
+5 SET DGADR1=$GET(DGARRY(.1211))
+6 SET DGADR2=$GET(DGARRY(.1212))
+7 SET DGADR3=$GET(DGARRY(.1213))
+8 SET DGCITY=$GET(DGARRY(.1214))
+9 SET DGSTATE=$GET(DGARRY(.1215))
+10 SET DGZIP=$GET(DGARRY(.1216))
+11 SET DGCOUNTY=$GET(DGARRY(.12111))
+12 IF DGCOUNTY'=""
IF DGSTATE'=""
IF $DATA(^DIC(5,DGSTATE,1,DGCOUNTY,0))
Begin DoDot:1
+13 SET DGCOUNTY=$PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$SELECT($PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"")
End DoDot:1
+14 ;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872
+15 ;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)
+16 IF DGADRACT'="Y"
SET DGCOUNTY="NOT APPLICABLE"
+17 IF DGSTATE'=""
IF $DATA(^DIC(5,DGSTATE,0))
SET DGSTATE=$PIECE(^DIC(5,DGSTATE,0),"^",2)
+18 SET DGPROV=$GET(DGARRY(.1221))
+19 SET DGPCODE=$GET(DGARRY(.1222))
+20 SET DGCNTRY=$GET(DGARRY(.1223))
+21 SET DGFORN=$$FORIEN(DGCNTRY)
+22 IF DGCNTRY]""
SET DGCNTRY=$$CNTRYI(DGCNTRY)
+23 SET DGPHONE=$GET(DGARRY(.1219))
+24 SET DGFROMDT=$$FMTE^XLFDT($GET(DGARRY(.1217)))
+25 SET DGTODT=$$FMTE^XLFDT($GET(DGARRY(.1218)))
+26 ;
+27 ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address:
+28 WRITE !!,"Temporary Mailing Address: "
+29 IF DGADRACT="Y"
Begin DoDot:1
+30 if DGADR1'=""
WRITE !?9,DGADR1
+31 if DGADR2'=""
WRITE !?9,DGADR2
+32 if DGADR3'=""
WRITE !?9,DGADR3
+33 IF DGFORN=0
Begin DoDot:2
+34 WRITE !?9,$SELECT(DGCITY'="":DGCITY,1:"")_$SELECT(DGCITY'="":",",1:" ")_$SELECT(DGSTATE'="":DGSTATE,1:"")_" "_$SELECT(DGZIP'="":DGZIP,1:"")
End DoDot:2
+35 ;I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"") ;DG*1010 comment out
+36 ;DG*1010 - display postal code last
IF DGFORN
WRITE !?8,$SELECT(DGCITY'="":DGCITY,1:"")_$SELECT(DGCITY'="":",",1:" ")_$SELECT(DGPROV'="":DGPROV,1:"")_" "_$SELECT(DGPCODE'="":DGPCODE,1:"")
End DoDot:1
+37 ;commenting out, causes address to print 2x. Patch 872
+38 ;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
+39 ;Removing lines from dot structure Patch 872
+40 WRITE !," County: "_DGCOUNTY
+41 WRITE !," Phone: "_DGPHONE
+42 WRITE !,"From/To: "_$PIECE(DGFROMDT,",")_","_$PIECE(DGFROMDT,", ",2)_"-"_$PIECE(DGTODT,",")_","_$PIECE(DGTODT,", ",2)
+43 ;
+44 IF $GET(DGARRY(.12105))="N"
Begin DoDot:1
+45 if $GET(DGARRY(.1211))=""
WRITE !?9,"NO TEMPORARY ADDRESS"
+46 if $GET(DGARRY(.1212))=""
WRITE !?9,""
+47 WRITE !," County: NOT APPLICABLE"
+48 WRITE !," Phone: NOT APPLICABLE"
+49 WRITE !,"From/To: NOT APPLICABLE"
End DoDot:1
+50 QUIT
COUNTRY(DGC) ;
+1 ;where DGC is the external value of the country
+2 ;return value is in upper case display mode
+3 ;if DGC is invalid, return -1
+4 NEW DGCC,DGIEN
+5 ; if input is NULL change to US
+6 IF $GET(DGC)=""
SET DGC="USA"
+7 ; Get IEN from B index, error if not found
+8 SET DGIEN=$ORDER(^HL(779.004,"B",DGC,""))
if DGIEN']""
QUIT -1
+9 ; xlate IEN to POSTAL NAME
+10 SET DGCC=$PIECE(^HL(779.004,DGIEN,"SDS"),U,3)
+11 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
+12 IF DGCC="<NULL>"
Begin DoDot:1
+13 SET DGCC=$$UPPER^DGUTL($PIECE(^HL(779.004,DGIEN,0),U,2))
End DoDot:1
+14 QUIT DGCC
FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
+1 ; DGC is the external value of the country (.01 field of file 779.004)
+2 NEW DGFOR
+3 SET DGFOR=0
+4 IF $GET(DGC)=""
QUIT DGFOR
+5 IF '$DATA(^HL(779.004,"B",DGC))
QUIT -1
+6 IF DGC'="USA"
SET DGFOR=1
+7 QUIT DGFOR
CNTRYI(DGIEN) ;where DGC is the internal value of the country
+1 ;return DGC as the display value for the country
+2 ;if the input value is not a valid IEN, return -1
+3 ;if the input value is null, return null
+4 NEW DGCC
+5 IF $GET(DGIEN)=""
QUIT ""
+6 IF '$DATA(^HL(779.004,DGIEN,0))
QUIT -1
+7 ; xlate IEN to POSTAL NAME
+8 SET DGCC=$PIECE(^HL(779.004,DGIEN,"SDS"),U,3)
+9 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
+10 IF DGCC="<NULL>"
Begin DoDot:1
+11 SET DGCC=$$UPPER^DGUTL($PIECE(^HL(779.004,DGIEN,0),U,2))
End DoDot:1
+12 QUIT DGCC
FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
+1 ;DGC is the IEN of the country file (#779.004)
+2 NEW DGFOR
+3 SET DGFOR=0
+4 IF $GET(DGC)=""
QUIT DGFOR
+5 IF DGC'?1.3N
QUIT -1
+6 IF '$DATA(^HL(779.004,DGC,0))
QUIT -1
+7 IF DGC]""
IF (DGC'=$ORDER(^HL(779.004,"B","USA","")))
SET DGFOR=1
+8 QUIT DGFOR
