DGREGCP1 ;ALB/CLT,ARF,JAM - ADDRESS COPY UTILITIES ; 18 May 2017 2:54 PM
;;5.3;Registration;**941,1010,1040,1056,1143**;Aug 13, 1993;Build 36
;
RESDISP(DFN) ;DISPLAY THE RESIDENTIAL ADDRESS
N DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP
N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
;DG*5.3*1056 remove Permanent from the message following displayed message
W !,"Residential Address to copy to the Mailing Address:",!
I $G(^DPT(DFN,.115))="" D Q
.W !?5,"NO RESIDENTIAL ADDRESS"
;DISPLAY THE CURRENT RESIDENTIAL ADDRESS
S DGXX=^DPT(DFN,.115),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
S DGA9=$P(DGXX,"^",9)
S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
;FORDISP ;DISPLAY FOREIGN ADDRESS
I DGA1="" W !
I 'DGFORGN D
. W ?43,"County: "
. I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q
. I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D
.. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7)
.. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
E D
. W ?43,"Province: "
. W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN")
;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
I DGFORGN W !?3,DGA4_" "_DGA9 ;DG*1010 - display postal code last
I 'DGFORGN W !?3,DGA4 D
. I $D(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0),"^",2)
. S DGZIP=$P(^DPT(DFN,.115),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
. W " ",DGZIP
W !?3,DGCNTRY,!
Q
;
PERMDISP(DFN) ;DISPLAY MAILING ADDRESS
N DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP
N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
;DG*5.3*1056 remove Permanent from the message following display messages and comment
W !,"Mailing Address to copy to Residential Address:",!
I $G(^DPT(DFN,.11))="" D Q
.W !?5,"NO MAILING ADDRESS"
;DISPLAY THE CURRENT MAILING ADDRESS
S DGXX=^DPT(DFN,.11),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
S DGA9=$P(DGXX,"^",9)
S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
;FORGNCHK ;CHECK FOR FOREIGN ADDRESS
I DGA1="" W !
I 'DGFORGN D
. W ?43,"County: "
. I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q
. I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D
.. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7)
.. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
E D
. W ?43,"Province: "
. W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN")
;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
I DGFORGN W !?3,DGA4_" "_DGA9 ;DG*1010 - display postal code last
I 'DGFORGN W !?3,DGA4 D
. I $D(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0),"^",2)
. S DGZIP=$P(^DPT(DFN,.11),"^",12) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
. W " ",DGZIP
W !?3,DGCNTRY,!
Q
;
RESMVQ(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
; If Real-time address updates are active, copy using local arrays holding the data
I $G(DGRTAON)=1 D RESMVQRTA(DFN) Q
;
I $G(^DPT(DFN,.115))="" Q
N DIR,X,Y,DTOUT,DUOUT
;DG*5.3*1056 remove Permanent from the message following displayed prompts
S DIR(0)="Y",DIR("A")="Copy the Residential Address to the Mailing Address",DIR("B")="NO"
S DIR("?",1)="Enter 'YES' to copy the Residential Address ",DIR("?")="to the Mailing Address."
D ^DIR
; DG*5.3*1040 - Check for timeout of the Copy prompt
I $D(DTOUT) S DGTMOT=1 Q
I $G(Y)=1 D
. W !
. D RESDISP(DFN)
. S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
. S DIR("?",1)="If you answer 'YES' the current Residential Address will be copied",DIR("?")="to the Permanent Mailing Address."
. D ^DIR
. ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
. I $D(DTOUT) S DGTMOT=1 Q
. ; DG*5.3*1040 - QUIT if variable Y = 0
. Q:$G(Y)=0
. I $D(DUOUT)!$D(DIROUT) Q
. D R2P^DGREGCOP(DFN)
. W !,"Copy completed."
. D EOP
Q
;
PERMMVQ(DFN) ;DISPLAY MAILING ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
; If Real-time address updates are active, copy using local arrays holding the data
I $G(DGRTAON)=1 D PERMMVQRTA(DFN) Q
;
; First check for a valid Mailing Address that can be copied to residential address
N DGXX,DGA10,DFORGN
S DGXX=$G(^DPT(DFN,.11))
; Quit if nothing in Perm address line 1 field
I $P(DGXX,"^",1)="" Q
; Quit if nothing in Perm address City field
I $P(DGXX,"^",4)="" Q
; Quit if no Perm address zip code defined for a domestic address
S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
S DGFORGN=$$FORIEN^DGADDUTL(DGA10)
I 'DGFORGN&($P(DGXX,"^",6)="") Q
; required address fields exist for copying to Residential address
; now check for PO Box or General Delivery and notify user if not valid for residential address and quit
; DG*5.3*1143 - Collect line 1 and state
N DGADD,DIR,X,Y,DGRESADD,DGRESX,DGA5,DGLINE1
K DIRUT
S DGLINE1=$P(DGXX,"^",1),DGA5=$P(DGXX,"^",5)
; DG*5.3*1143 - Pass line 1, state and country to function
I $$POBOXPM^DGREGCP2(DGLINE1,DGA5,DGA10) D Q
. W !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address." W !
. ;DG*5.3*1056 remove Permanent from the following message displayed messages
. W !,"Because the Mailing Address line 1 contains P.O. Box"
. W " or General",!,"Delivery the Mailing Address cannot be copied to"
. W !,"the Residential Address."
. D EOP
. ; DG*5.3*1040 - Check for timeout
. Q:+$G(DGTMOT)
; Perm address is valid for use as a Residential address
ASK ;
W !
;DG*5.3*1056 remove Permanent from the following message displayed message and prompt
S DIR(0)="Y",DIR("A")="Copy the Mailing Address to the Residential Address"
S DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Mailing Address",DIR("?")="to the Residential Address."
S DIR("B")="NO"
D ^DIR
I X="Y"!(X="YES") S Y=1,Y(0)="YES"
; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
I $D(DTOUT) S DGTMOT=1 Q
; DG*5.3*1040 - QUIT if Y = 0
Q:$G(Y)=0
I $D(DUOUT)!$D(DIROUT) Q
I $D(DIRUT) G ASK
I Y=1 D
. W !
. D PERMDISP(DFN) ;; W !! D RESDISP(DFN) W !
. S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
. ;DG*5.3*1056 remove Permanent from the following message displayed prompt
. S DIR("?",1)="If you answer 'YES' the current Mailing Address will be copied",DIR("?")="to the Residential Address."
. D ^DIR
. ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
. I $D(DTOUT) S DGTMOT=1 Q
. ; DG*5.3*1040 - QUIT if Y = 0
. Q:$G(Y)=0
. I $D(DUOUT)!$D(DIROUT) Q
. D P2R^DGREGCOP(DFN)
. W !,"Copy completed."
. D EOP
; DG*5.3*1040 - Check for timeout
Q:+$G(DGTMOT)
Q
EOP ;End of page prompt
N DIR,DTOUT,DUOUT,DIROUT,X,Y
S DIR(0)="E"
S DIR("A")="Press ENTER to continue"
D ^DIR
; DG*5.3*1040 - Set variable DGTMOT=1 to track timeout
I $D(DTOUT) S DGTMOT=1 Q
Q
;
; DG*5.3*1043 - Copy operation for Real-time address update
RESMVQRTA(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
; If both the local array and database LINE1 fields for Residential address are not defined, quit
I $G(DGADDGRP1(.1151))=""&($P($G(^DPT(DFN,.115)),"^",1)="") Q
N DIR,X,Y,DTOUT,DUOUT
S DIR(0)="Y",DIR("A")="Copy the Residential Address to the Mailing Address",DIR("B")="NO"
S DIR("?",1)="Enter 'YES' to copy the Residential Address ",DIR("?")="to the Mailing Address."
D ^DIR
K DIR
I $D(DTOUT) S DGTMOT=1 Q
I $G(Y)=1 D
. W !
. ; If local array not defined, display address from the database fields, otherwise display using local array
. I $G(DGADDGRP1(.1151))="" D RESDISP(DFN)
. E D RESDISPRTA(DFN)
. S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
. S DIR("?",1)="If you answer 'YES' the current Residential Address will be copied",DIR("?")="to the Permanent Mailing Address."
. D ^DIR
. I $D(DTOUT) S DGTMOT=1 Q
. Q:$G(Y)=0
. I $D(DUOUT)!$D(DIROUT) Q
. D R2PLOCAL^DGREGCOP(DFN)
. W !,"Copy completed."
. D EOP
Q
;
RESDISPRTA(DFN) ;DG*5.3*1043 - Residential address display operation for Real-time address update
N DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP
N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
W !,"Residential Address to copy to the Mailing Address:",!
;DISPLAY THE CURRENT RESIDENTIAL ADDRESS FROM THE LOCAL ARRAY DGADDGRP1
S DGA1=DGADDGRP1(.1151),DGA2=DGADDGRP1(.1152),DGA3=DGADDGRP1(.1153),DGA4=DGADDGRP1(.1154)
; Postal Code
S DGA9=$G(DGADDGRP1(.11572))
S DGA10=$G(DGADDGRP1(.11573)) S:'DGA10 DGA10=""
S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
;FORDISP ;DISPLAY FOREIGN ADDRESS
I DGA1="" W !
I 'DGFORGN D
. W ?43,"County: "
. ; Check for State and County
. I $G(DGADDGRP1(.1155))=""!($G(DGADDGRP1(.1157))="") W "UNKNOWN" Q
. I $G(DGADDGRP1(.1157))'="" I $D(^DIC(5,$G(DGADDGRP1(.1155)),1,DGADDGRP1(.1157),0)) D
.. S DGST=DGADDGRP1(.1155),DGCIEN=DGADDGRP1(.1157)
.. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
E D
. W ?43,"Province: "
. W $S($G(DGADDGRP1(.11571))'="":DGADDGRP1(.11571),1:"UNKNOWN")
I DGFORGN W !?3,DGA4_" "_DGA9
I 'DGFORGN W !?3,DGA4 D
. I $D(^DIC(5,DGADDGRP1(.1155),0)) W ",",$P(^DIC(5,DGADDGRP1(.1155),0),"^",2)
. S DGZIP=$G(DGADDGRP1(.1156)) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
. W " ",DGZIP
W !?3,DGCNTRY,!
Q
;
; DG*5.3*1043 - Copy operation for Real-time address update
PERMMVQRTA(DFN) ;DISPLAY MAILING ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
; If both the local array line 1 and database line 1 field for Mailing address are not defined, quit
I $G(DGADDGRP2(.111))=""&($P($G(^DPT(DFN,.11)),"^",1)="") Q
;
N DGA10,DGA1,DGA5,DFORGN
; If local array defined, get fields
I $G(DGADDGRP2(.111))'="" D
.; Get Country, Address Line 1 and State
.S DGA10=$G(DGADDGRP2(.1173)) S:'DGA10 DGA10=""
.S DGFORGN=$$FORIEN^DGADDUTL(DGA10)
.S DGA1=DGADDGRP2(.111)
.S DGA5=$G(DGADDGRP2(.115))
;
; If local array does not exist, get address data from the DB
I $G(DGADDGRP2(.111))="" D
.N DGXX
.S DGXX=$G(^DPT(DFN,.11))
.; Get Country, Address Line 1 and State
.S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10=""
.S DGFORGN=$$FORIEN^DGADDUTL(DGA10)
.S DGA1=$P(DGXX,"^",1)
.S DGA5=$P(DGXX,"^",5)
;
; Check for PO Box or General Delivery - notify user if not valid for residential address and quit
I $$POBOXPM^DGREGCP2(DGA1,DGA5,DGA10) D Q
. W !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address." W !
. W !,"Because the Mailing Address line 1 contains P.O. Box"
. W " or General",!,"Delivery the Mailing Address cannot be copied to the Residential Address."
. D EOP
;
; Mailing address is valid for use as a Residential address
RTAASK ;
N DIR,X,Y,DTOUT,DUOUT
S DIR(0)="Y",DIR("A")="Copy the Mailing Address to the Residential Address"
S DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Mailing Address",DIR("?")="to the Residential Address."
S DIR("B")="NO"
D ^DIR
K DIR
I X="Y"!(X="YES") S Y=1,Y(0)="YES"
I $D(DTOUT) S DGTMOT=1 Q
Q:$G(Y)=0
I $D(DUOUT)!$D(DIROUT) Q
I $D(DIRUT) G RTAASK
I Y=1 D
. W !
. ; If local array not defined, display address from the database fields, otherwise display using local array
. I $G(DGADDGRP2(.111))="" D PERMDISP(DFN)
. I $G(DGADDGRP2(.111))'="" D PERMDISPRTA(DFN)
. S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")=""
. S DIR("?",1)="If you answer 'YES' the current Mailing Address will be copied",DIR("?")="to the Residential Address."
. D ^DIR
. I $D(DTOUT) S DGTMOT=1 Q
. Q:$G(Y)=0
. I $D(DUOUT)!$D(DIROUT) Q
. D P2RLOCAL^DGREGCOP(DFN)
. W !,"Copy completed."
. D EOP
Q
;
PERMDISPRTA(DFN) ;DG*5.3*1143 - Display Mailing Address operation for Real-time address update
N DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP
N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
W !,"Mailing Address to copy to Residential Address:",!
;DISPLAY THE CURRENT MAILING ADDRESS FROM THE LOCAL ARRAY DGADDGRP2
S DGA1=DGADDGRP2(.111),DGA2=$G(DGADDGRP2(.112)),DGA3=$G(DGADDGRP2(.113)),DGA4=$G(DGADDGRP2(.114))
; Postal Code
S DGA9=$G(DGADDGRP2(.1172))
; Country
S DGA10=$G(DGADDGRP2(.1173)) S:'DGA10 DGA10=""
S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10)
I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3
;FORGNCHK ;CHECK FOR FOREIGN ADDRESS
I DGA1="" W !
I 'DGFORGN D
. W ?43,"County: "
. ; Check for State and County
. I $G(DGADDGRP2(.115))=""!($G(DGADDGRP2(.117))="") W "UNKNOWN" Q
. I $G(DGADDGRP2(.117))'="" I $D(^DIC(5,$G(DGADDGRP2(.115)),1,DGADDGRP2(.117),0)) D
.. S DGST=$G(DGADDGRP2(.115)),DGCIEN=DGADDGRP2(.117)
.. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")"
E D
. W ?43,"Province: "
. W $S($G(DGADDGRP2(.1171))'="":$G(DGADDGRP2(.1171)),1:"UNKNOWN")
;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
I DGFORGN W !?3,DGA4_" "_DGA9 ;DG*1010 - display postal code last
I 'DGFORGN W !?3,DGA4 D
. I $D(^DIC(5,+$G(DGADDGRP2(.115)),0)) W ",",$P(^DIC(5,+DGADDGRP2(.115),0),"^",2)
. S DGZIP=$G(DGADDGRP2(.1112)) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
. W " ",DGZIP
W !?3,DGCNTRY,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREGCP1 13911 printed May 25, 2026@12:58:51 Page 2
DGREGCP1 ;ALB/CLT,ARF,JAM - ADDRESS COPY UTILITIES ; 18 May 2017 2:54 PM
+1 ;;5.3;Registration;**941,1010,1040,1056,1143**;Aug 13, 1993;Build 36
+2 ;
RESDISP(DFN) ;DISPLAY THE RESIDENTIAL ADDRESS
+1 NEW DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP
+2 NEW DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
+3 ;DG*5.3*1056 remove Permanent from the message following displayed message
+4 WRITE !,"Residential Address to copy to the Mailing Address:",!
+5 IF $GET(^DPT(DFN,.115))=""
Begin DoDot:1
+6 WRITE !?5,"NO RESIDENTIAL ADDRESS"
End DoDot:1
QUIT
+7 ;DISPLAY THE CURRENT RESIDENTIAL ADDRESS
+8 SET DGXX=^DPT(DFN,.115)
SET DGA1=$PIECE(DGXX,"^",1)
SET DGA2=$PIECE(DGXX,"^",2)
SET DGA3=$PIECE(DGXX,"^",3)
SET DGA4=$PIECE(DGXX,"^",4)
+9 SET DGA9=$PIECE(DGXX,"^",9)
+10 SET DGA10=$PIECE(DGXX,"^",10)
if 'DGA10
SET DGA10=""
+11 SET DGCNTRY=$EXTRACT($$CNTRYI^DGADDUTL(DGA10),1,25)
SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+12 IF DGCNTRY=-1
SET DGCNTRY="UNKNOWN COUNTRY"
+13 if DGA1'=""
WRITE !?3,DGA1
if $GET(DGA2)'=""
WRITE !?3,DGA2
if $GET(DGA3)'=""
WRITE !?3,DGA3
+14 ;FORDISP ;DISPLAY FOREIGN ADDRESS
+15 IF DGA1=""
WRITE !
+16 IF 'DGFORGN
Begin DoDot:1
+17 WRITE ?43,"County: "
+18 IF $PIECE(DGXX,U,5)=""!($PIECE(DGXX,U,7)="")
WRITE "UNKNOWN"
QUIT
+19 IF $PIECE(DGXX,U,7)'=""
IF $DATA(^DIC(5,$PIECE(DGXX,U,5),1,$PIECE(DGXX,U,7),0))
Begin DoDot:2
+20 SET DGST=$PIECE(DGXX,U,5)
SET DGCIEN=$PIECE(DGXX,U,7)
+21 SET DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
WRITE $PIECE(DGCNTY,"^",1),"(",$PIECE(DGCNTY,"^",3),")"
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 WRITE ?43,"Province: "
+24 WRITE $SELECT($PIECE(DGXX,U,8)'="":$PIECE(DGXX,U,8),1:"UNKNOWN")
End DoDot:1
+25 ;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
+26 ;DG*1010 - display postal code last
IF DGFORGN
WRITE !?3,DGA4_" "_DGA9
+27 IF 'DGFORGN
WRITE !?3,DGA4
Begin DoDot:1
+28 IF $DATA(^DIC(5,+$PIECE(^DPT(DFN,.115),"^",5),0))
WRITE ",",$PIECE(^DIC(5,+$PIECE(^DPT(DFN,.115),"^",5),0),"^",2)
+29 SET DGZIP=$PIECE(^DPT(DFN,.115),"^",6)
IF $LENGTH(DGZIP)>5
SET DGZIP=$EXTRACT(DGZIP,1,5)_"-"_$EXTRACT(DGZIP,6,12)
+30 WRITE " ",DGZIP
End DoDot:1
+31 WRITE !?3,DGCNTRY,!
+32 QUIT
+33 ;
PERMDISP(DFN) ;DISPLAY MAILING ADDRESS
+1 NEW DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP
+2 NEW DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
+3 ;DG*5.3*1056 remove Permanent from the message following display messages and comment
+4 WRITE !,"Mailing Address to copy to Residential Address:",!
+5 IF $GET(^DPT(DFN,.11))=""
Begin DoDot:1
+6 WRITE !?5,"NO MAILING ADDRESS"
End DoDot:1
QUIT
+7 ;DISPLAY THE CURRENT MAILING ADDRESS
+8 SET DGXX=^DPT(DFN,.11)
SET DGA1=$PIECE(DGXX,"^",1)
SET DGA2=$PIECE(DGXX,"^",2)
SET DGA3=$PIECE(DGXX,"^",3)
SET DGA4=$PIECE(DGXX,"^",4)
+9 SET DGA9=$PIECE(DGXX,"^",9)
+10 SET DGA10=$PIECE(DGXX,"^",10)
if 'DGA10
SET DGA10=""
+11 SET DGCNTRY=$EXTRACT($$CNTRYI^DGADDUTL(DGA10),1,25)
SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+12 IF DGCNTRY=-1
SET DGCNTRY="UNKNOWN COUNTRY"
+13 if DGA1'=""
WRITE !?3,DGA1
if $GET(DGA2)'=""
WRITE !?3,DGA2
if $GET(DGA3)'=""
WRITE !?3,DGA3
+14 ;FORGNCHK ;CHECK FOR FOREIGN ADDRESS
+15 IF DGA1=""
WRITE !
+16 IF 'DGFORGN
Begin DoDot:1
+17 WRITE ?43,"County: "
+18 IF $PIECE(DGXX,U,5)=""!($PIECE(DGXX,U,7)="")
WRITE "UNKNOWN"
QUIT
+19 IF $PIECE(DGXX,U,7)'=""
IF $DATA(^DIC(5,$PIECE(DGXX,U,5),1,$PIECE(DGXX,U,7),0))
Begin DoDot:2
+20 SET DGST=$PIECE(DGXX,U,5)
SET DGCIEN=$PIECE(DGXX,U,7)
+21 SET DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
WRITE $PIECE(DGCNTY,"^",1),"(",$PIECE(DGCNTY,"^",3),")"
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 WRITE ?43,"Province: "
+24 WRITE $SELECT($PIECE(DGXX,U,8)'="":$PIECE(DGXX,U,8),1:"UNKNOWN")
End DoDot:1
+25 ;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
+26 ;DG*1010 - display postal code last
IF DGFORGN
WRITE !?3,DGA4_" "_DGA9
+27 IF 'DGFORGN
WRITE !?3,DGA4
Begin DoDot:1
+28 IF $DATA(^DIC(5,+$PIECE(^DPT(DFN,.11),"^",5),0))
WRITE ",",$PIECE(^DIC(5,+$PIECE(^DPT(DFN,.11),"^",5),0),"^",2)
+29 SET DGZIP=$PIECE(^DPT(DFN,.11),"^",12)
IF $LENGTH(DGZIP)>5
SET DGZIP=$EXTRACT(DGZIP,1,5)_"-"_$EXTRACT(DGZIP,6,12)
+30 WRITE " ",DGZIP
End DoDot:1
+31 WRITE !?3,DGCNTRY,!
+32 QUIT
+33 ;
RESMVQ(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
+1 ; If Real-time address updates are active, copy using local arrays holding the data
+2 IF $GET(DGRTAON)=1
DO RESMVQRTA(DFN)
QUIT
+3 ;
+4 IF $GET(^DPT(DFN,.115))=""
QUIT
+5 NEW DIR,X,Y,DTOUT,DUOUT
+6 ;DG*5.3*1056 remove Permanent from the message following displayed prompts
+7 SET DIR(0)="Y"
SET DIR("A")="Copy the Residential Address to the Mailing Address"
SET DIR("B")="NO"
+8 SET DIR("?",1)="Enter 'YES' to copy the Residential Address "
SET DIR("?")="to the Mailing Address."
+9 DO ^DIR
+10 ; DG*5.3*1040 - Check for timeout of the Copy prompt
+11 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+12 IF $GET(Y)=1
Begin DoDot:1
+13 WRITE !
+14 DO RESDISP(DFN)
+15 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+16 SET DIR("?",1)="If you answer 'YES' the current Residential Address will be copied"
SET DIR("?")="to the Permanent Mailing Address."
+17 DO ^DIR
+18 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+19 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+20 ; DG*5.3*1040 - QUIT if variable Y = 0
+21 if $GET(Y)=0
QUIT
+22 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+23 DO R2P^DGREGCOP(DFN)
+24 WRITE !,"Copy completed."
+25 DO EOP
End DoDot:1
+26 QUIT
+27 ;
PERMMVQ(DFN) ;DISPLAY MAILING ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
+1 ; If Real-time address updates are active, copy using local arrays holding the data
+2 IF $GET(DGRTAON)=1
DO PERMMVQRTA(DFN)
QUIT
+3 ;
+4 ; First check for a valid Mailing Address that can be copied to residential address
+5 NEW DGXX,DGA10,DFORGN
+6 SET DGXX=$GET(^DPT(DFN,.11))
+7 ; Quit if nothing in Perm address line 1 field
+8 IF $PIECE(DGXX,"^",1)=""
QUIT
+9 ; Quit if nothing in Perm address City field
+10 IF $PIECE(DGXX,"^",4)=""
QUIT
+11 ; Quit if no Perm address zip code defined for a domestic address
+12 SET DGA10=$PIECE(DGXX,"^",10)
if 'DGA10
SET DGA10=""
+13 SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+14 IF 'DGFORGN&($PIECE(DGXX,"^",6)="")
QUIT
+15 ; required address fields exist for copying to Residential address
+16 ; now check for PO Box or General Delivery and notify user if not valid for residential address and quit
+17 ; DG*5.3*1143 - Collect line 1 and state
+18 NEW DGADD,DIR,X,Y,DGRESADD,DGRESX,DGA5,DGLINE1
+19 KILL DIRUT
+20 SET DGLINE1=$PIECE(DGXX,"^",1)
SET DGA5=$PIECE(DGXX,"^",5)
+21 ; DG*5.3*1143 - Pass line 1, state and country to function
+22 IF $$POBOXPM^DGREGCP2(DGLINE1,DGA5,DGA10)
Begin DoDot:1
+23 WRITE !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address."
WRITE !
+24 ;DG*5.3*1056 remove Permanent from the following message displayed messages
+25 WRITE !,"Because the Mailing Address line 1 contains P.O. Box"
+26 WRITE " or General",!,"Delivery the Mailing Address cannot be copied to"
+27 WRITE !,"the Residential Address."
+28 DO EOP
+29 ; DG*5.3*1040 - Check for timeout
+30 if +$GET(DGTMOT)
QUIT
End DoDot:1
QUIT
+31 ; Perm address is valid for use as a Residential address
ASK ;
+1 WRITE !
+2 ;DG*5.3*1056 remove Permanent from the following message displayed message and prompt
+3 SET DIR(0)="Y"
SET DIR("A")="Copy the Mailing Address to the Residential Address"
+4 SET DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Mailing Address"
SET DIR("?")="to the Residential Address."
+5 SET DIR("B")="NO"
+6 DO ^DIR
+7 IF X="Y"!(X="YES")
SET Y=1
SET Y(0)="YES"
+8 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+9 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+10 ; DG*5.3*1040 - QUIT if Y = 0
+11 if $GET(Y)=0
QUIT
+12 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+13 IF $DATA(DIRUT)
GOTO ASK
+14 IF Y=1
Begin DoDot:1
+15 WRITE !
+16 ;; W !! D RESDISP(DFN) W !
DO PERMDISP(DFN)
+17 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+18 ;DG*5.3*1056 remove Permanent from the following message displayed prompt
+19 SET DIR("?",1)="If you answer 'YES' the current Mailing Address will be copied"
SET DIR("?")="to the Residential Address."
+20 DO ^DIR
+21 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+22 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+23 ; DG*5.3*1040 - QUIT if Y = 0
+24 if $GET(Y)=0
QUIT
+25 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+26 DO P2R^DGREGCOP(DFN)
+27 WRITE !,"Copy completed."
+28 DO EOP
End DoDot:1
+29 ; DG*5.3*1040 - Check for timeout
+30 if +$GET(DGTMOT)
QUIT
+31 QUIT
EOP ;End of page prompt
+1 NEW DIR,DTOUT,DUOUT,DIROUT,X,Y
+2 SET DIR(0)="E"
+3 SET DIR("A")="Press ENTER to continue"
+4 DO ^DIR
+5 ; DG*5.3*1040 - Set variable DGTMOT=1 to track timeout
+6 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+7 QUIT
+8 ;
+9 ; DG*5.3*1043 - Copy operation for Real-time address update
RESMVQRTA(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
+1 ; If both the local array and database LINE1 fields for Residential address are not defined, quit
+2 IF $GET(DGADDGRP1(.1151))=""&($PIECE($GET(^DPT(DFN,.115)),"^",1)="")
QUIT
+3 NEW DIR,X,Y,DTOUT,DUOUT
+4 SET DIR(0)="Y"
SET DIR("A")="Copy the Residential Address to the Mailing Address"
SET DIR("B")="NO"
+5 SET DIR("?",1)="Enter 'YES' to copy the Residential Address "
SET DIR("?")="to the Mailing Address."
+6 DO ^DIR
+7 KILL DIR
+8 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+9 IF $GET(Y)=1
Begin DoDot:1
+10 WRITE !
+11 ; If local array not defined, display address from the database fields, otherwise display using local array
+12 IF $GET(DGADDGRP1(.1151))=""
DO RESDISP(DFN)
+13 IF '$TEST
DO RESDISPRTA(DFN)
+14 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+15 SET DIR("?",1)="If you answer 'YES' the current Residential Address will be copied"
SET DIR("?")="to the Permanent Mailing Address."
+16 DO ^DIR
+17 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+18 if $GET(Y)=0
QUIT
+19 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+20 DO R2PLOCAL^DGREGCOP(DFN)
+21 WRITE !,"Copy completed."
+22 DO EOP
End DoDot:1
+23 QUIT
+24 ;
RESDISPRTA(DFN) ;DG*5.3*1043 - Residential address display operation for Real-time address update
+1 NEW DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP
+2 NEW DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
+3 WRITE !,"Residential Address to copy to the Mailing Address:",!
+4 ;DISPLAY THE CURRENT RESIDENTIAL ADDRESS FROM THE LOCAL ARRAY DGADDGRP1
+5 SET DGA1=DGADDGRP1(.1151)
SET DGA2=DGADDGRP1(.1152)
SET DGA3=DGADDGRP1(.1153)
SET DGA4=DGADDGRP1(.1154)
+6 ; Postal Code
+7 SET DGA9=$GET(DGADDGRP1(.11572))
+8 SET DGA10=$GET(DGADDGRP1(.11573))
if 'DGA10
SET DGA10=""
+9 SET DGCNTRY=$EXTRACT($$CNTRYI^DGADDUTL(DGA10),1,25)
SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+10 IF DGCNTRY=-1
SET DGCNTRY="UNKNOWN COUNTRY"
+11 if DGA1'=""
WRITE !?3,DGA1
if $GET(DGA2)'=""
WRITE !?3,DGA2
if $GET(DGA3)'=""
WRITE !?3,DGA3
+12 ;FORDISP ;DISPLAY FOREIGN ADDRESS
+13 IF DGA1=""
WRITE !
+14 IF 'DGFORGN
Begin DoDot:1
+15 WRITE ?43,"County: "
+16 ; Check for State and County
+17 IF $GET(DGADDGRP1(.1155))=""!($GET(DGADDGRP1(.1157))="")
WRITE "UNKNOWN"
QUIT
+18 IF $GET(DGADDGRP1(.1157))'=""
IF $DATA(^DIC(5,$GET(DGADDGRP1(.1155)),1,DGADDGRP1(.1157),0))
Begin DoDot:2
+19 SET DGST=DGADDGRP1(.1155)
SET DGCIEN=DGADDGRP1(.1157)
+20 SET DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
WRITE $PIECE(DGCNTY,"^",1),"(",$PIECE(DGCNTY,"^",3),")"
End DoDot:2
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 WRITE ?43,"Province: "
+23 WRITE $SELECT($GET(DGADDGRP1(.11571))'="":DGADDGRP1(.11571),1:"UNKNOWN")
End DoDot:1
+24 IF DGFORGN
WRITE !?3,DGA4_" "_DGA9
+25 IF 'DGFORGN
WRITE !?3,DGA4
Begin DoDot:1
+26 IF $DATA(^DIC(5,DGADDGRP1(.1155),0))
WRITE ",",$PIECE(^DIC(5,DGADDGRP1(.1155),0),"^",2)
+27 SET DGZIP=$GET(DGADDGRP1(.1156))
IF $LENGTH(DGZIP)>5
SET DGZIP=$EXTRACT(DGZIP,1,5)_"-"_$EXTRACT(DGZIP,6,12)
+28 WRITE " ",DGZIP
End DoDot:1
+29 WRITE !?3,DGCNTRY,!
+30 QUIT
+31 ;
+32 ; DG*5.3*1043 - Copy operation for Real-time address update
PERMMVQRTA(DFN) ;DISPLAY MAILING ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
+1 ; If both the local array line 1 and database line 1 field for Mailing address are not defined, quit
+2 IF $GET(DGADDGRP2(.111))=""&($PIECE($GET(^DPT(DFN,.11)),"^",1)="")
QUIT
+3 ;
+4 NEW DGA10,DGA1,DGA5,DFORGN
+5 ; If local array defined, get fields
+6 IF $GET(DGADDGRP2(.111))'=""
Begin DoDot:1
+7 ; Get Country, Address Line 1 and State
+8 SET DGA10=$GET(DGADDGRP2(.1173))
if 'DGA10
SET DGA10=""
+9 SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+10 SET DGA1=DGADDGRP2(.111)
+11 SET DGA5=$GET(DGADDGRP2(.115))
End DoDot:1
+12 ;
+13 ; If local array does not exist, get address data from the DB
+14 IF $GET(DGADDGRP2(.111))=""
Begin DoDot:1
+15 NEW DGXX
+16 SET DGXX=$GET(^DPT(DFN,.11))
+17 ; Get Country, Address Line 1 and State
+18 SET DGA10=$PIECE(DGXX,"^",10)
if 'DGA10
SET DGA10=""
+19 SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+20 SET DGA1=$PIECE(DGXX,"^",1)
+21 SET DGA5=$PIECE(DGXX,"^",5)
End DoDot:1
+22 ;
+23 ; Check for PO Box or General Delivery - notify user if not valid for residential address and quit
+24 IF $$POBOXPM^DGREGCP2(DGA1,DGA5,DGA10)
Begin DoDot:1
+25 WRITE !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address."
WRITE !
+26 WRITE !,"Because the Mailing Address line 1 contains P.O. Box"
+27 WRITE " or General",!,"Delivery the Mailing Address cannot be copied to the Residential Address."
+28 DO EOP
End DoDot:1
QUIT
+29 ;
+30 ; Mailing address is valid for use as a Residential address
RTAASK ;
+1 NEW DIR,X,Y,DTOUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Copy the Mailing Address to the Residential Address"
+3 SET DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Mailing Address"
SET DIR("?")="to the Residential Address."
+4 SET DIR("B")="NO"
+5 DO ^DIR
+6 KILL DIR
+7 IF X="Y"!(X="YES")
SET Y=1
SET Y(0)="YES"
+8 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+9 if $GET(Y)=0
QUIT
+10 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+11 IF $DATA(DIRUT)
GOTO RTAASK
+12 IF Y=1
Begin DoDot:1
+13 WRITE !
+14 ; If local array not defined, display address from the database fields, otherwise display using local array
+15 IF $GET(DGADDGRP2(.111))=""
DO PERMDISP(DFN)
+16 IF $GET(DGADDGRP2(.111))'=""
DO PERMDISPRTA(DFN)
+17 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+18 SET DIR("?",1)="If you answer 'YES' the current Mailing Address will be copied"
SET DIR("?")="to the Residential Address."
+19 DO ^DIR
+20 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+21 if $GET(Y)=0
QUIT
+22 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+23 DO P2RLOCAL^DGREGCOP(DFN)
+24 WRITE !,"Copy completed."
+25 DO EOP
End DoDot:1
+26 QUIT
+27 ;
PERMDISPRTA(DFN) ;DG*5.3*1143 - Display Mailing Address operation for Real-time address update
+1 NEW DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP
+2 NEW DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY
+3 WRITE !,"Mailing Address to copy to Residential Address:",!
+4 ;DISPLAY THE CURRENT MAILING ADDRESS FROM THE LOCAL ARRAY DGADDGRP2
+5 SET DGA1=DGADDGRP2(.111)
SET DGA2=$GET(DGADDGRP2(.112))
SET DGA3=$GET(DGADDGRP2(.113))
SET DGA4=$GET(DGADDGRP2(.114))
+6 ; Postal Code
+7 SET DGA9=$GET(DGADDGRP2(.1172))
+8 ; Country
+9 SET DGA10=$GET(DGADDGRP2(.1173))
if 'DGA10
SET DGA10=""
+10 SET DGCNTRY=$EXTRACT($$CNTRYI^DGADDUTL(DGA10),1,25)
SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+11 IF DGCNTRY=-1
SET DGCNTRY="UNKNOWN COUNTRY"
+12 if DGA1'=""
WRITE !?3,DGA1
if $GET(DGA2)'=""
WRITE !?3,DGA2
if $GET(DGA3)'=""
WRITE !?3,DGA3
+13 ;FORGNCHK ;CHECK FOR FOREIGN ADDRESS
+14 IF DGA1=""
WRITE !
+15 IF 'DGFORGN
Begin DoDot:1
+16 WRITE ?43,"County: "
+17 ; Check for State and County
+18 IF $GET(DGADDGRP2(.115))=""!($GET(DGADDGRP2(.117))="")
WRITE "UNKNOWN"
QUIT
+19 IF $GET(DGADDGRP2(.117))'=""
IF $DATA(^DIC(5,$GET(DGADDGRP2(.115)),1,DGADDGRP2(.117),0))
Begin DoDot:2
+20 SET DGST=$GET(DGADDGRP2(.115))
SET DGCIEN=DGADDGRP2(.117)
+21 SET DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
WRITE $PIECE(DGCNTY,"^",1),"(",$PIECE(DGCNTY,"^",3),")"
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 WRITE ?43,"Province: "
+24 WRITE $SELECT($GET(DGADDGRP2(.1171))'="":$GET(DGADDGRP2(.1171)),1:"UNKNOWN")
End DoDot:1
+25 ;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out
+26 ;DG*1010 - display postal code last
IF DGFORGN
WRITE !?3,DGA4_" "_DGA9
+27 IF 'DGFORGN
WRITE !?3,DGA4
Begin DoDot:1
+28 IF $DATA(^DIC(5,+$GET(DGADDGRP2(.115)),0))
WRITE ",",$PIECE(^DIC(5,+DGADDGRP2(.115),0),"^",2)
+29 SET DGZIP=$GET(DGADDGRP2(.1112))
IF $LENGTH(DGZIP)>5
SET DGZIP=$EXTRACT(DGZIP,1,5)_"-"_$EXTRACT(DGZIP,6,12)
+30 WRITE " ",DGZIP
End DoDot:1
+31 WRITE !?3,DGCNTRY,!
+32 QUIT
