DGREGTE2 ;ALB/BAJ,TDM,BDB - Temporary & Confidential Address Support Routine; 02/27/2006 ; 22 Mar 2017 1:10 PM
;;5.3;Registration;**688,754,851,1040**;Aug 13, 1993;Build 15
;
Q
;
GETOLD(DGCMP,DFN,TYPE) ;populate array with existing address info
N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,FDESC,FNODE,FPECE,CCNTRY,COUNTRY
S CFORGN=0,FDESC=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTRY",1:"CONFIDENTIAL ADDR COUNTRY")
; get current country
S FNODE=$S(TYPE="TEMP":.122,TYPE="CONF":.141,1:.11)
S FPECE=$S(TYPE="TEMP":3,TYPE="CONF":16,1:10)
S CCIEN=$P($G(^DPT(DFN,FNODE)),U,FPECE)
I CCIEN="" S CCNTRY=$O(^HL(779.004,"D","UNITED STATES",""))
S CFORGN=$$FORIEN^DGADDUTL(CCIEN)
;get current address fields and xlate to ^DIQ format
S CFSTR=$$INPT1(DFN,CFORGN),CFSTR=$TR(CFSTR,",",";")
; Domestic data needs some extra fields
; add country field before lookup
D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E"))
S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY"
S DGCMP("OLD",FCNTRY)=COUNTRY
I 'CFORGN D
. S DGCIEN=$G(DGCURR(2,DFN_",",FCOUNTY,"I"))
. S DGST=$G(DGCURR(2,DFN_",",FSTATE,"I"))
. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
. I DGCNTY=-1 S DGCNTY=""
. S DGCMP("OLD",FCOUNTY)="" I DGCNTY]"" S DGCMP("OLD",FCOUNTY)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
Q
INPT1(DFN,FORGN,PSTR) ; address input prompts
N FSTR
; PSTR contains the full list of address fields to be modified
; FSTR contains the field list based on country
S PSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPROV_","_FPSTAL_","_FCNTRY_","_FPHONE
;S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPHONE
S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FZIP_","_FPHONE ;DG*5.3*851
I FORGN S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FPROV_","_FPSTAL_","_FPHONE
Q FSTR
;
SURE() ; Are you sure prompt
N DIR,X,Y,DUOUT,DTOUT,DIRUT
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")=" SURE YOU WANT TO DELETE"
D ^DIR
Q Y
SKIP(DGN,DGINPUT) ; determine whether or not to skip the prompt
N SKIP,NULL
S SKIP=0
S NULL=($G(DGINPUT(FSLINE1))="")!(($G(DGINPUT(FSLINE1))="@"))
I NULL,(DGN=FSLINE2) S SKIP=1
S NULL=($G(DGINPUT(FSLINE2))="")!(($G(DGINPUT(FSLINE2))="@"))
I NULL,(DGN=FSLINE3) S SKIP=1
Q SKIP
;
INIT ; initialize variables
; This tag reads the table at FLDDAT (below) to set relationship between
; variables and Field numbers.
;
; Set up array of fields needed
N I,T,FTYPE,VNAME,FNUM,RFLD
F I=1:1 S T=$P($T(FLDDAT+I^DGREGTE2),";;",3) Q:T="QUIT" D
. S FTYPE=$P(T,";",1),VNAME=$P(T,";",2),FNUM=$P(T,";",3)
. I FTYPE=TYPE S @VNAME=FNUM
; Set up array of field and prompting rules
K T,I
F I=1:1 S T=$P($T(FLDPRMPT+I^DGREGTE2),";;",2) Q:T="QUIT" D
. S RFLD=$P(T,";",1) I RFLD'="ALL" S RFLD=@RFLD
. S RPROC(RFLD,$P(T,";",2),$P(T,";",3))=$P(T,";",4)
Q
FLDDAT ; Table of field values STRUCTURE --> Description;;Type;Variable Name;Field Number
;;Street Line 1;;TEMP;FSLINE1;.1211
;;Street Line 2;;TEMP;FSLINE2;.1212
;;Street Line 3;;TEMP;FSLINE3;.1213
;;City;;TEMP;FCITY;.1214
;;State;;TEMP;FSTATE;.1215
;;County;;TEMP;FCOUNTY;.12111
;;Zip;;TEMP;FZIP;.12112
;;Phone;;TEMP;FPHONE;.1219
;;Province;;TEMP;FPROV;.1221
;;Postal Code;;TEMP;FPSTAL;.1222
;;Country;;TEMP;FCNTRY;.1223
;;Address Node 1;;TEMP;FNODE1;.121
;;Address Node 2;;TEMP;FNODE2;.122
;;Country data piece;;TEMP;CPEICE;3
;;Street Line 1;;CONF;FSLINE1;.1411
;;Street Line 2;;CONF;FSLINE2;.1412
;;Street Line 3;;CONF;FSLINE3;.1413
;;City;;CONF;FCITY;.1414
;;State;;CONF;FSTATE;.1415
;;County;;CONF;FCOUNTY;.14111
;;Zip;;CONF;FZIP;.1416
;;Phone;;CONF;FPHONE;.1315
;;Province;;CONF;FPROV;.14114
;;Postal Code;;CONF;FPSTAL;.14115
;;Country;;CONF;FCNTRY;.14116
;;Address Node 1;;CONF;FNODE1;.141
;;Address Node 2;;CONF;FNODE2;.141
;;Country data piece;;CONF;CPEICE;16
;;QUIT;;QUIT
;;
; DG*5.3*1040; Change NULL FSLINE1 to REPEAT response code instead of REVERSE
FLDPRMPT ;Table of prompts and responses STRUCTURE --> Description;;Field;Old Value;New Value;Response Code
;;ALL;NULL;UPCAR;REPEAT
;;ALL;NULL;DELETE;QUES
;;ALL;NULL;VALUE;OK
;;ALL;VALUE;UPCAR;REPEAT
;;ALL;VALUE;NULL;OK
;;ALL;VALUE;VALUE;OK
;;FSLINE1;NULL;NULL;REPEAT
;;FSLINE2;NULL;NULL;OK
;;FSLINE3;NULL;NULL;OK
;;FCITY;NULL;NULL;REVERSE
;;FSTATE;NULL;NULL;REVERSE
;;FZIP;NULL;NULL;REVERSE
;;FCOUNTY;NULL;NULL;REVERSE
;;FPROV;NULL;NULL;OK
;;FPSTAL;NULL;NULL;OK
;;FCNTRY;NULL;NULL;REVERSE
;;FSLINE1;VALUE;DELETE;INSTRUCT
;;FSLINE2;VALUE;DELETE;CONFIRM
;;FSLINE3;VALUE;DELETE;CONFIRM
;;FCITY;VALUE;DELETE;INSTRUCT
;;FSTATE;VALUE;DELETE;INSTRUCT
;;FZIP;VALUE;DELETE;INSTRUCT
;;FCOUNTY;VALUE;DELETE;INSTRUCT
;;FPROV;VALUE;DELETE;CONFIRM
;;FPSTAL;VALUE;DELETE;CONFIRM
;;FCNTRY;VALUE;DELETE;REVERSE
;;QUIT
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREGTE2 4990 printed Sep 23, 2025@20:30:57 Page 2
DGREGTE2 ;ALB/BAJ,TDM,BDB - Temporary & Confidential Address Support Routine; 02/27/2006 ; 22 Mar 2017 1:10 PM
+1 ;;5.3;Registration;**688,754,851,1040**;Aug 13, 1993;Build 15
+2 ;
+3 QUIT
+4 ;
GETOLD(DGCMP,DFN,TYPE) ;populate array with existing address info
+1 NEW CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,FDESC,FNODE,FPECE,CCNTRY,COUNTRY
+2 SET CFORGN=0
SET FDESC=$SELECT(TYPE="TEMP":"TEMPORARY ADDRESS COUNTRY",1:"CONFIDENTIAL ADDR COUNTRY")
+3 ; get current country
+4 SET FNODE=$SELECT(TYPE="TEMP":.122,TYPE="CONF":.141,1:.11)
+5 SET FPECE=$SELECT(TYPE="TEMP":3,TYPE="CONF":16,1:10)
+6 SET CCIEN=$PIECE($GET(^DPT(DFN,FNODE)),U,FPECE)
+7 IF CCIEN=""
SET CCNTRY=$ORDER(^HL(779.004,"D","UNITED STATES",""))
+8 SET CFORGN=$$FORIEN^DGADDUTL(CCIEN)
+9 ;get current address fields and xlate to ^DIQ format
+10 SET CFSTR=$$INPT1(DFN,CFORGN)
SET CFSTR=$TRANSLATE(CFSTR,",",";")
+11 ; Domestic data needs some extra fields
+12 ; add country field before lookup
+13 DO GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR")
+14 FOR L=1:1:$LENGTH(CFSTR,";")
SET T=$PIECE(CFSTR,";",L)
SET DGCMP("OLD",T)=$GET(DGCURR(2,DFN_",",T,"E"))
+15 SET COUNTRY=$$CNTRYI^DGADDUTL(CCIEN)
IF COUNTRY=-1
SET COUNTRY="UNKNOWN COUNTRY"
+16 SET DGCMP("OLD",FCNTRY)=COUNTRY
+17 IF 'CFORGN
Begin DoDot:1
+18 SET DGCIEN=$GET(DGCURR(2,DFN_",",FCOUNTY,"I"))
+19 SET DGST=$GET(DGCURR(2,DFN_",",FSTATE,"I"))
+20 SET DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
+21 IF DGCNTY=-1
SET DGCNTY=""
+22 SET DGCMP("OLD",FCOUNTY)=""
IF DGCNTY]""
SET DGCMP("OLD",FCOUNTY)=$PIECE(DGCNTY,U)_" "_$PIECE(DGCNTY,U,3)
End DoDot:1
+23 QUIT
INPT1(DFN,FORGN,PSTR) ; address input prompts
+1 NEW FSTR
+2 ; PSTR contains the full list of address fields to be modified
+3 ; FSTR contains the field list based on country
+4 SET PSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPROV_","_FPSTAL_","_FCNTRY_","_FPHONE
+5 ;S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPHONE
+6 ;DG*5.3*851
SET FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FZIP_","_FPHONE
+7 IF FORGN
SET FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FPROV_","_FPSTAL_","_FPHONE
+8 QUIT FSTR
+9 ;
SURE() ; Are you sure prompt
+1 NEW DIR,X,Y,DUOUT,DTOUT,DIRUT
+2 SET DIR(0)="Y"
+3 SET DIR("B")="NO"
+4 SET DIR("A")=" SURE YOU WANT TO DELETE"
+5 DO ^DIR
+6 QUIT Y
SKIP(DGN,DGINPUT) ; determine whether or not to skip the prompt
+1 NEW SKIP,NULL
+2 SET SKIP=0
+3 SET NULL=($GET(DGINPUT(FSLINE1))="")!(($GET(DGINPUT(FSLINE1))="@"))
+4 IF NULL
IF (DGN=FSLINE2)
SET SKIP=1
+5 SET NULL=($GET(DGINPUT(FSLINE2))="")!(($GET(DGINPUT(FSLINE2))="@"))
+6 IF NULL
IF (DGN=FSLINE3)
SET SKIP=1
+7 QUIT SKIP
+8 ;
INIT ; initialize variables
+1 ; This tag reads the table at FLDDAT (below) to set relationship between
+2 ; variables and Field numbers.
+3 ;
+4 ; Set up array of fields needed
+5 NEW I,T,FTYPE,VNAME,FNUM,RFLD
+6 FOR I=1:1
SET T=$PIECE($TEXT(FLDDAT+I^DGREGTE2),";;",3)
if T="QUIT"
QUIT
Begin DoDot:1
+7 SET FTYPE=$PIECE(T,";",1)
SET VNAME=$PIECE(T,";",2)
SET FNUM=$PIECE(T,";",3)
+8 IF FTYPE=TYPE
SET @VNAME=FNUM
End DoDot:1
+9 ; Set up array of field and prompting rules
+10 KILL T,I
+11 FOR I=1:1
SET T=$PIECE($TEXT(FLDPRMPT+I^DGREGTE2),";;",2)
if T="QUIT"
QUIT
Begin DoDot:1
+12 SET RFLD=$PIECE(T,";",1)
IF RFLD'="ALL"
SET RFLD=@RFLD
+13 SET RPROC(RFLD,$PIECE(T,";",2),$PIECE(T,";",3))=$PIECE(T,";",4)
End DoDot:1
+14 QUIT
FLDDAT ; Table of field values STRUCTURE --> Description;;Type;Variable Name;Field Number
+1 ;;Street Line 1;;TEMP;FSLINE1;.1211
+2 ;;Street Line 2;;TEMP;FSLINE2;.1212
+3 ;;Street Line 3;;TEMP;FSLINE3;.1213
+4 ;;City;;TEMP;FCITY;.1214
+5 ;;State;;TEMP;FSTATE;.1215
+6 ;;County;;TEMP;FCOUNTY;.12111
+7 ;;Zip;;TEMP;FZIP;.12112
+8 ;;Phone;;TEMP;FPHONE;.1219
+9 ;;Province;;TEMP;FPROV;.1221
+10 ;;Postal Code;;TEMP;FPSTAL;.1222
+11 ;;Country;;TEMP;FCNTRY;.1223
+12 ;;Address Node 1;;TEMP;FNODE1;.121
+13 ;;Address Node 2;;TEMP;FNODE2;.122
+14 ;;Country data piece;;TEMP;CPEICE;3
+15 ;;Street Line 1;;CONF;FSLINE1;.1411
+16 ;;Street Line 2;;CONF;FSLINE2;.1412
+17 ;;Street Line 3;;CONF;FSLINE3;.1413
+18 ;;City;;CONF;FCITY;.1414
+19 ;;State;;CONF;FSTATE;.1415
+20 ;;County;;CONF;FCOUNTY;.14111
+21 ;;Zip;;CONF;FZIP;.1416
+22 ;;Phone;;CONF;FPHONE;.1315
+23 ;;Province;;CONF;FPROV;.14114
+24 ;;Postal Code;;CONF;FPSTAL;.14115
+25 ;;Country;;CONF;FCNTRY;.14116
+26 ;;Address Node 1;;CONF;FNODE1;.141
+27 ;;Address Node 2;;CONF;FNODE2;.141
+28 ;;Country data piece;;CONF;CPEICE;16
+29 ;;QUIT;;QUIT
+30 ;;
+31 ; DG*5.3*1040; Change NULL FSLINE1 to REPEAT response code instead of REVERSE
FLDPRMPT ;Table of prompts and responses STRUCTURE --> Description;;Field;Old Value;New Value;Response Code
+1 ;;ALL;NULL;UPCAR;REPEAT
+2 ;;ALL;NULL;DELETE;QUES
+3 ;;ALL;NULL;VALUE;OK
+4 ;;ALL;VALUE;UPCAR;REPEAT
+5 ;;ALL;VALUE;NULL;OK
+6 ;;ALL;VALUE;VALUE;OK
+7 ;;FSLINE1;NULL;NULL;REPEAT
+8 ;;FSLINE2;NULL;NULL;OK
+9 ;;FSLINE3;NULL;NULL;OK
+10 ;;FCITY;NULL;NULL;REVERSE
+11 ;;FSTATE;NULL;NULL;REVERSE
+12 ;;FZIP;NULL;NULL;REVERSE
+13 ;;FCOUNTY;NULL;NULL;REVERSE
+14 ;;FPROV;NULL;NULL;OK
+15 ;;FPSTAL;NULL;NULL;OK
+16 ;;FCNTRY;NULL;NULL;REVERSE
+17 ;;FSLINE1;VALUE;DELETE;INSTRUCT
+18 ;;FSLINE2;VALUE;DELETE;CONFIRM
+19 ;;FSLINE3;VALUE;DELETE;CONFIRM
+20 ;;FCITY;VALUE;DELETE;INSTRUCT
+21 ;;FSTATE;VALUE;DELETE;INSTRUCT
+22 ;;FZIP;VALUE;DELETE;INSTRUCT
+23 ;;FCOUNTY;VALUE;DELETE;INSTRUCT
+24 ;;FPROV;VALUE;DELETE;CONFIRM
+25 ;;FPSTAL;VALUE;DELETE;CONFIRM
+26 ;;FCNTRY;VALUE;DELETE;REVERSE
+27 ;;QUIT
+28 ;;
