DGREGCP1 ;ALB/CLT,ARF - ADDRESS COPY UTILITIES ; 18 May 2017 2:54 PM
;;5.3;Registration;**941,1010,1040,1056**;Aug 13, 1993;Build 18
;
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),"^",6) 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
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
; 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 zipcode 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 address and notify user if not valid address and quit
N DGADD,DIR,X,Y,DGRESADD,DGRESX
K DIRUT
I $$POBOXPM^DGREGCP2(DFN) 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."
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREGCP1 6846 printed Sep 23, 2025@20:30:48 Page 2
DGREGCP1 ;ALB/CLT,ARF - ADDRESS COPY UTILITIES ; 18 May 2017 2:54 PM
+1 ;;5.3;Registration;**941,1010,1040,1056**;Aug 13, 1993;Build 18
+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),"^",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 ;
RESMVQ(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED
+1 IF $GET(^DPT(DFN,.115))=""
QUIT
+2 NEW DIR,X,Y,DTOUT,DUOUT
+3 ;DG*5.3*1056 remove Permanent from the message following displayed prompts
+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 ; DG*5.3*1040 - Check for timeout of the Copy prompt
+8 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+9 IF $GET(Y)=1
Begin DoDot:1
+10 WRITE !
+11 DO RESDISP(DFN)
+12 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+13 SET DIR("?",1)="If you answer 'YES' the current Residential Address will be copied"
SET DIR("?")="to the Permanent Mailing Address."
+14 DO ^DIR
+15 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+16 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+17 ; DG*5.3*1040 - QUIT if variable Y = 0
+18 if $GET(Y)=0
QUIT
+19 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+20 DO R2P^DGREGCOP(DFN)
+21 WRITE !,"Copy completed."
+22 DO EOP
End DoDot:1
+23 QUIT
+24 ;
PERMMVQ(DFN) ;DISPLAY MAILING ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED
+1 ; First check for a valid Mailing Address that can be copied to residential address
+2 NEW DGXX,DGA10,DFORGN
+3 SET DGXX=$GET(^DPT(DFN,.11))
+4 ; Quit if nothing in Perm address line 1 field
+5 IF $PIECE(DGXX,"^",1)=""
QUIT
+6 ; Quit if nothing in Perm address City field
+7 IF $PIECE(DGXX,"^",4)=""
QUIT
+8 ; Quit if no Perm address zipcode defined for a domestic address
+9 SET DGA10=$PIECE(DGXX,"^",10)
if 'DGA10
SET DGA10=""
+10 SET DGFORGN=$$FORIEN^DGADDUTL(DGA10)
+11 IF 'DGFORGN&($PIECE(DGXX,"^",6)="")
QUIT
+12 ; required address fields exist for copying to Residential address
+13 ; now check for PO Box or General Delivery address and notify user if not valid address and quit
+14 NEW DGADD,DIR,X,Y,DGRESADD,DGRESX
+15 KILL DIRUT
+16 IF $$POBOXPM^DGREGCP2(DFN)
Begin DoDot:1
+17 WRITE !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address."
WRITE !
+18 ;DG*5.3*1056 remove Permanent from the following message displayed messages
+19 WRITE !,"Because the Mailing Address line 1 contains P.O. Box"
+20 WRITE " or General",!,"Delivery the Mailing Address cannot be copied to"
+21 WRITE !,"the Residential Address."
+22 DO EOP
+23 ; DG*5.3*1040 - Check for timeout
+24 if +$GET(DGTMOT)
QUIT
End DoDot:1
QUIT
+25 ; 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 DO ^DIR
+6 IF X="Y"!(X="YES")
SET Y=1
SET Y(0)="YES"
+7 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+8 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+9 ; DG*5.3*1040 - QUIT if Y = 0
+10 if $GET(Y)=0
QUIT
+11 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+12 IF $DATA(DIRUT)
GOTO ASK
+13 IF Y=1
Begin DoDot:1
+14 WRITE !
+15 ;; W !! D RESDISP(DFN) W !
DO PERMDISP(DFN)
+16 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to copy"
SET DIR("B")=""
+17 ;DG*5.3*1056 remove Permanent from the following message displayed prompt
+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 ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout
+21 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+22 ; DG*5.3*1040 - QUIT if Y = 0
+23 if $GET(Y)=0
QUIT
+24 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+25 DO P2R^DGREGCOP(DFN)
+26 WRITE !,"Copy completed."
+27 DO EOP
End DoDot:1
+28 ; DG*5.3*1040 - Check for timeout
+29 if +$GET(DGTMOT)
QUIT
+30 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
