Routine: DGREGTE2

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

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)

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)

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  Feb 19, 2025@00:21:06                                                                                                                                                                                                    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      ;;

DGREGTE2.m