DGREGDD1 ;ALB/REW/BRM - REGISTRATION PATIENT FILE MUMPS X-REF ; 10/22/02 2:17pm
;;5.3;Registration;**454,522**;Aug 13, 1993
;
; VARIABLES FOR TAGS SZIP,KFIELD:
; INPUT:
; DFN IEN OF PATIENT FILE - 1ST PARAMETER (REQUIRED)
; DGFLD: NEW FIELD# (SET/KILLED BY X-REF)
; DGNODE: NODE OF NEW FIELD
; DGPIECE: PC # OF NEW FIELD
; X: STORED VALUE OF NEW FIELD
; USED:
; DGIX: X-REF#
; DGRGFL1: FLAG TO PREVENT INFINITE LOOP
; DGRGX: STORED VALUE OF X
;
SET(DFN,DGFLD,DGNODE,DGPIECE,X) ; SET NEW FIELD & DO SET X-REFS
Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")
N DGIX,DGRGFL1,DGRGX
S DGRGX=X,DGRGFL1=1
S $P(^DPT(DFN,DGNODE),U,DGPIECE)=DGRGX
F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,1)
Q
;
KILL(DFN,DGFLD,DGNODE,DGPIECE,X) ; KILL OLD FIELD & DO KILL X-REFS
Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")
N DGIX,DGRGFL1,DGRGX
S DGRGX=X,DGRGFL1=1
S $P(^DPT(DFN,DGNODE),U,DGPIECE)=""
F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,2)
Q
SETMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; SET
; SETSNEW FIELD & DOES SET X-REFS
Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")!('$G(MULTNUM))!(MULTNODE']"")!('$G(DFN))!($G(DFN1)']"")
N DGIX,DGRGFL1,DGRGX
S DGRGX=X,DGRGFL1=1
S $P(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=DGRGX
F DGIX=0:0 S DGIX=$O(^DD(MULTNUM,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,1)
Q
KILLMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; KILL
;KILLS OLD FIELD & DOES KILL X-REF
Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")!('$G(MULTNUM))!(MULTNODE']"")!('$G(DFN))!($G(DFN1)']"")
N DGIX,DGRGFL1,DGRGX
S DGRGX=X,DGRGFL1=1
S DGRGX=$P($G(^DPT(DFN,MULTNODE,DFN1,DGNODE)),U,DGPIECE)
S $P(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=""
F DGIX=0:0 S DGIX=$O(^DD(MULTNUM,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,2)
Q
;
ZIP(DA,ZIP,CITY) ; update city, state and county based on zip code change
;
; This tag will be used to link the patient's zip code
; with the associated city, state, and county code as
; established by the US Postal Service. The 'AZIPLINK' and
; 'AZIPLNK' new style x-refs on the Patient (#2) file call
; this tag if the Zip+4 (.1112) or Zip Code (.116) fields change.
;
; Input:
; DA - Patient File (#2) Patient record DFN
; ZIP - ZIP+4 (.1112) or ZIP CODE (.116) field of the Patient
; File (#2) entry that is being edited
;
; Output:
; 1 - The values in the following fields were updated with the
; USPS data associated with the new zipcode:
; CITY field (.114) of the Patient File (#2)
; STATE field (.115) of the Patient File (#2)
; COUNTY field (.117) of the Patient File (#2)
; 0 - the above fields were NOT updated
;
I 'DA!$G(ZIP)="" K EASZIPLK Q 0
I '$D(EASZIPLK) Q 0
N EASDATA,FDA,MSG,DGN,CNTYIEN
S EASDO2=1
I '$$MLT(ZIP) K EASZIPLK Q 0
I $$FOREIGN^DGREGAZL() K EASZIPLK Q 0
D POSTAL^XIPUTIL(ZIP,.EASDATA)
; accomodate 15 character limit on the city in the patient file
; set FDA array to be filed in the Patient (#2) file
S CNTYIEN=""
S:$G(EASDATA("STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(EASDATA("STATE POINTER"))_",","MOXQ",$E($G(EASDATA("FIPS CODE")),3,5),"C")
D:'CNTYIEN ;could be duplicate county codes in subfile #5.01
.Q:'$D(^DIC(5,+$G(EASDATA("STATE POINTER")),1))
.Q:$E($G(EASDATA("FIPS CODE")),3,5)=""
.S CNTYIEN=$O(^DIC(5,$G(EASDATA("STATE POINTER")),1,"C",$E($G(EASDATA("FIPS CODE")),3,5),""))
S FDA(2,DA_",",.115)=$S(CNTYIEN:$G(EASDATA("STATE POINTER")),1:$G(EASDATA("STATE")))
S FDA(2,DA_",",.117)=$S(CNTYIEN:CNTYIEN,1:$G(EASDATA("COUNTY")))
; file data
D FILE^DIE($S(CNTYIEN:"",1:"E"),"FDA","MSG")
K EASZIPLK
Q '$D(MSG)
KEY(DUZ,DFN) ; determine if a security key is necessary for editing
; a patient's state and county fields. If it is necessary,
; determine if this user holds it.
;
; INPUT:
; DUZ - ien for the #200 file of the user
; DFN - ien of the #2 file for the patient
;
K EASDO2 ;kill zip code linking flag (AZIPLINK and AZIPLNK x-refs)
Q:'$D(DUZ)!('$D(DFN)) 0
N ZIP,DGR
S ZIP=$E($$GET1^DIQ(2,DFN_",",.1112),1,5)
S DGR=$$ALWEDT(DUZ,ZIP)
Q DGR
ALWEDT(DUZ,ZIP) ; determine if a security key is necessary for editing
; Input: zip code
; Output: 1: allow edit state and county
; 0: don't allow edit state and county
N EASDATA
I $G(ZIP)="" Q 0
I '$D(DUZ) Q 0
I '$$MLT(ZIP) Q 1 ; > 1 state or county for the zip - allow edit
I $$FOREIGN^DGREGAZL() Q 1 ; Foreign location - allow edit
D POSTAL^XIPUTIL(ZIP,.EASDATA)
Q:$D(EASDATA("ERROR")) 1 ;zip code does not exist - allow editing
Q:'$D(EASDATA("FIPS CODE")) 1 ;cnty code does not exist - allow edit
Q:'$D(EASDATA("STATE")) 1 ;state does not exist - allow editing
Q:$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) 1 ;user holds security key
W !,"STATE: ",$G(EASDATA("STATE"))
W !,"COUNTY: ",$G(EASDATA("COUNTY"))
Q 0
;
MLT(ZIP) ;Determine if a zip correspond to multiple state and\or county
;Output: 0: >1 state and\or county for this zip
; 1: 1 state and 1 county for this zip
N DGN,DGFIPS,DGDATA,POP,DGCNTY,DGST
S (DGN,DGST,DGCNTY,DGFIPS)=""
S POP=0
D POSTALB^XIPUTIL(ZIP,.DGDATA)
I $D(DGDATA("ERROR")) Q 0
S DGN=$O(DGDATA(DGN))
S DGFIPS=$G(DGDATA(DGN,"FIPS CODE"))
F S DGN=$O(DGDATA(DGN)) Q:(DGN="")!POP D
. I $G(DGDATA(DGN,"FIPS CODE"))'=DGFIPS S POP=1 Q
I POP=1 Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREGDD1 5654 printed Sep 23, 2025@20:30:51 Page 2
DGREGDD1 ;ALB/REW/BRM - REGISTRATION PATIENT FILE MUMPS X-REF ; 10/22/02 2:17pm
+1 ;;5.3;Registration;**454,522**;Aug 13, 1993
+2 ;
+3 ; VARIABLES FOR TAGS SZIP,KFIELD:
+4 ; INPUT:
+5 ; DFN IEN OF PATIENT FILE - 1ST PARAMETER (REQUIRED)
+6 ; DGFLD: NEW FIELD# (SET/KILLED BY X-REF)
+7 ; DGNODE: NODE OF NEW FIELD
+8 ; DGPIECE: PC # OF NEW FIELD
+9 ; X: STORED VALUE OF NEW FIELD
+10 ; USED:
+11 ; DGIX: X-REF#
+12 ; DGRGFL1: FLAG TO PREVENT INFINITE LOOP
+13 ; DGRGX: STORED VALUE OF X
+14 ;
SET(DFN,DGFLD,DGNODE,DGPIECE,X) ; SET NEW FIELD & DO SET X-REFS
+1 if $GET(DGRGFL1)!'$GET(DGFLD)!'$GET(DGPIECE)!($GET(X)']"")!($GET(DGNODE)']"")
QUIT
+2 NEW DGIX,DGRGFL1,DGRGX
+3 SET DGRGX=X
SET DGRGFL1=1
+4 SET $PIECE(^DPT(DFN,DGNODE),U,DGPIECE)=DGRGX
+5 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(2,DGFLD,1,DGIX))
if 'DGIX
QUIT
SET X=DGRGX
XECUTE ^(DGIX,1)
+6 QUIT
+7 ;
KILL(DFN,DGFLD,DGNODE,DGPIECE,X) ; KILL OLD FIELD & DO KILL X-REFS
+1 if $GET(DGRGFL1)!'$GET(DGFLD)!'$GET(DGPIECE)!($GET(X)']"")!($GET(DGNODE)']"")
QUIT
+2 NEW DGIX,DGRGFL1,DGRGX
+3 SET DGRGX=X
SET DGRGFL1=1
+4 SET $PIECE(^DPT(DFN,DGNODE),U,DGPIECE)=""
+5 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(2,DGFLD,1,DGIX))
if 'DGIX
QUIT
SET X=DGRGX
XECUTE ^(DGIX,2)
+6 QUIT
SETMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; SET
+1 ; SETSNEW FIELD & DOES SET X-REFS
+2 if $GET(DGRGFL1)!'$GET(DGFLD)!'$GET(DGPIECE)!($GET(X)']"")!($GET(DGNODE)']"")!('$GET(MULTNUM))!(MULTNODE']"")!('$GET(DFN))!($GET(DFN1)']"")
QUIT
+3 NEW DGIX,DGRGFL1,DGRGX
+4 SET DGRGX=X
SET DGRGFL1=1
+5 SET $PIECE(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=DGRGX
+6 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(MULTNUM,DGFLD,1,DGIX))
if 'DGIX
QUIT
SET X=DGRGX
XECUTE ^(DGIX,1)
+7 QUIT
KILLMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; KILL
+1 ;KILLS OLD FIELD & DOES KILL X-REF
+2 if $GET(DGRGFL1)!'$GET(DGFLD)!'$GET(DGPIECE)!($GET(X)']"")!($GET(DGNODE)']"")!('$GET(MULTNUM))!(MULTNODE']"")!('$GET(DFN))!($GET(DFN1)']"")
QUIT
+3 NEW DGIX,DGRGFL1,DGRGX
+4 SET DGRGX=X
SET DGRGFL1=1
+5 SET DGRGX=$PIECE($GET(^DPT(DFN,MULTNODE,DFN1,DGNODE)),U,DGPIECE)
+6 SET $PIECE(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=""
+7 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(MULTNUM,DGFLD,1,DGIX))
if 'DGIX
QUIT
SET X=DGRGX
XECUTE ^(DGIX,2)
+8 QUIT
+9 ;
ZIP(DA,ZIP,CITY) ; update city, state and county based on zip code change
+1 ;
+2 ; This tag will be used to link the patient's zip code
+3 ; with the associated city, state, and county code as
+4 ; established by the US Postal Service. The 'AZIPLINK' and
+5 ; 'AZIPLNK' new style x-refs on the Patient (#2) file call
+6 ; this tag if the Zip+4 (.1112) or Zip Code (.116) fields change.
+7 ;
+8 ; Input:
+9 ; DA - Patient File (#2) Patient record DFN
+10 ; ZIP - ZIP+4 (.1112) or ZIP CODE (.116) field of the Patient
+11 ; File (#2) entry that is being edited
+12 ;
+13 ; Output:
+14 ; 1 - The values in the following fields were updated with the
+15 ; USPS data associated with the new zipcode:
+16 ; CITY field (.114) of the Patient File (#2)
+17 ; STATE field (.115) of the Patient File (#2)
+18 ; COUNTY field (.117) of the Patient File (#2)
+19 ; 0 - the above fields were NOT updated
+20 ;
+21 IF 'DA!$GET(ZIP)=""
KILL EASZIPLK
QUIT 0
+22 IF '$DATA(EASZIPLK)
QUIT 0
+23 NEW EASDATA,FDA,MSG,DGN,CNTYIEN
+24 SET EASDO2=1
+25 IF '$$MLT(ZIP)
KILL EASZIPLK
QUIT 0
+26 IF $$FOREIGN^DGREGAZL()
KILL EASZIPLK
QUIT 0
+27 DO POSTAL^XIPUTIL(ZIP,.EASDATA)
+28 ; accomodate 15 character limit on the city in the patient file
+29 ; set FDA array to be filed in the Patient (#2) file
+30 SET CNTYIEN=""
+31 if $GET(EASDATA("STATE POINTER"))'=""
SET CNTYIEN=$$FIND1^DIC(5.01,","_$GET(EASDATA("STATE POINTER"))_",","MOXQ",$EXTRACT($GET(EASDATA("FIPS CODE")),3,5),"C")
+32 ;could be duplicate county codes in subfile #5.01
if 'CNTYIEN
Begin DoDot:1
+33 if '$DATA(^DIC(5,+$GET(EASDATA("STATE POINTER")),1))
QUIT
+34 if $EXTRACT($GET(EASDATA("FIPS CODE")),3,5)=""
QUIT
+35 SET CNTYIEN=$ORDER(^DIC(5,$GET(EASDATA("STATE POINTER")),1,"C",$EXTRACT($GET(EASDATA("FIPS CODE")),3,5),""))
End DoDot:1
+36 SET FDA(2,DA_",",.115)=$SELECT(CNTYIEN:$GET(EASDATA("STATE POINTER")),1:$GET(EASDATA("STATE")))
+37 SET FDA(2,DA_",",.117)=$SELECT(CNTYIEN:CNTYIEN,1:$GET(EASDATA("COUNTY")))
+38 ; file data
+39 DO FILE^DIE($SELECT(CNTYIEN:"",1:"E"),"FDA","MSG")
+40 KILL EASZIPLK
+41 QUIT '$DATA(MSG)
KEY(DUZ,DFN) ; determine if a security key is necessary for editing
+1 ; a patient's state and county fields. If it is necessary,
+2 ; determine if this user holds it.
+3 ;
+4 ; INPUT:
+5 ; DUZ - ien for the #200 file of the user
+6 ; DFN - ien of the #2 file for the patient
+7 ;
+8 ;kill zip code linking flag (AZIPLINK and AZIPLNK x-refs)
KILL EASDO2
+9 if '$DATA(DUZ)!('$DATA(DFN))
QUIT 0
+10 NEW ZIP,DGR
+11 SET ZIP=$EXTRACT($$GET1^DIQ(2,DFN_",",.1112),1,5)
+12 SET DGR=$$ALWEDT(DUZ,ZIP)
+13 QUIT DGR
ALWEDT(DUZ,ZIP) ; determine if a security key is necessary for editing
+1 ; Input: zip code
+2 ; Output: 1: allow edit state and county
+3 ; 0: don't allow edit state and county
+4 NEW EASDATA
+5 IF $GET(ZIP)=""
QUIT 0
+6 IF '$DATA(DUZ)
QUIT 0
+7 ; > 1 state or county for the zip - allow edit
IF '$$MLT(ZIP)
QUIT 1
+8 ; Foreign location - allow edit
IF $$FOREIGN^DGREGAZL()
QUIT 1
+9 DO POSTAL^XIPUTIL(ZIP,.EASDATA)
+10 ;zip code does not exist - allow editing
if $DATA(EASDATA("ERROR"))
QUIT 1
+11 ;cnty code does not exist - allow edit
if '$DATA(EASDATA("FIPS CODE"))
QUIT 1
+12 ;state does not exist - allow editing
if '$DATA(EASDATA("STATE"))
QUIT 1
+13 ;user holds security key
if $DATA(^XUSEC("EAS GMT COUNTY EDIT",+DUZ))
QUIT 1
+14 WRITE !,"STATE: ",$GET(EASDATA("STATE"))
+15 WRITE !,"COUNTY: ",$GET(EASDATA("COUNTY"))
+16 QUIT 0
+17 ;
MLT(ZIP) ;Determine if a zip correspond to multiple state and\or county
+1 ;Output: 0: >1 state and\or county for this zip
+2 ; 1: 1 state and 1 county for this zip
+3 NEW DGN,DGFIPS,DGDATA,POP,DGCNTY,DGST
+4 SET (DGN,DGST,DGCNTY,DGFIPS)=""
+5 SET POP=0
+6 DO POSTALB^XIPUTIL(ZIP,.DGDATA)
+7 IF $DATA(DGDATA("ERROR"))
QUIT 0
+8 SET DGN=$ORDER(DGDATA(DGN))
+9 SET DGFIPS=$GET(DGDATA(DGN,"FIPS CODE"))
+10 FOR
SET DGN=$ORDER(DGDATA(DGN))
if (DGN="")!POP
QUIT
Begin DoDot:1
+11 IF $GET(DGDATA(DGN,"FIPS CODE"))'=DGFIPS
SET POP=1
QUIT
End DoDot:1
+12 IF POP=1
QUIT 0
+13 QUIT 1
