source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGDD1.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1DGREGDD1 ;ALB/REW/BRM - REGISTRATION PATIENT FILE MUMPS X-REF ; 10/22/02 2:17pm
2 ;;5.3;Registration;**454,522**;Aug 13, 1993
3 ;
4 ; VARIABLES FOR TAGS SZIP,KFIELD:
5 ; INPUT:
6 ; DFN IEN OF PATIENT FILE - 1ST PARAMETER (REQUIRED)
7 ; DGFLD: NEW FIELD# (SET/KILLED BY X-REF)
8 ; DGNODE: NODE OF NEW FIELD
9 ; DGPIECE: PC # OF NEW FIELD
10 ; X: STORED VALUE OF NEW FIELD
11 ; USED:
12 ; DGIX: X-REF#
13 ; DGRGFL1: FLAG TO PREVENT INFINITE LOOP
14 ; DGRGX: STORED VALUE OF X
15 ;
16SET(DFN,DGFLD,DGNODE,DGPIECE,X) ; SET NEW FIELD & DO SET X-REFS
17 Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")
18 N DGIX,DGRGFL1,DGRGX
19 S DGRGX=X,DGRGFL1=1
20 S $P(^DPT(DFN,DGNODE),U,DGPIECE)=DGRGX
21 F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,1)
22 Q
23 ;
24KILL(DFN,DGFLD,DGNODE,DGPIECE,X) ; KILL OLD FIELD & DO KILL X-REFS
25 Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")
26 N DGIX,DGRGFL1,DGRGX
27 S DGRGX=X,DGRGFL1=1
28 S $P(^DPT(DFN,DGNODE),U,DGPIECE)=""
29 F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,2)
30 Q
31SETMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; SET
32 ; SETSNEW FIELD & DOES SET X-REFS
33 Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")!('$G(MULTNUM))!(MULTNODE']"")!('$G(DFN))!($G(DFN1)']"")
34 N DGIX,DGRGFL1,DGRGX
35 S DGRGX=X,DGRGFL1=1
36 S $P(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=DGRGX
37 F DGIX=0:0 S DGIX=$O(^DD(MULTNUM,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,1)
38 Q
39KILLMULT(DFN,DFN1,MULTNUM,MULTNODE,DGFLD,DGNODE,DGPIECE,X) ; KILL
40 ;KILLS OLD FIELD & DOES KILL X-REF
41 Q:$G(DGRGFL1)!'$G(DGFLD)!'$G(DGPIECE)!($G(X)']"")!($G(DGNODE)']"")!('$G(MULTNUM))!(MULTNODE']"")!('$G(DFN))!($G(DFN1)']"")
42 N DGIX,DGRGFL1,DGRGX
43 S DGRGX=X,DGRGFL1=1
44 S DGRGX=$P($G(^DPT(DFN,MULTNODE,DFN1,DGNODE)),U,DGPIECE)
45 S $P(^DPT(DFN,MULTNODE,DFN1,DGNODE),U,DGPIECE)=""
46 F DGIX=0:0 S DGIX=$O(^DD(MULTNUM,DGFLD,1,DGIX)) Q:'DGIX S X=DGRGX X ^(DGIX,2)
47 Q
48 ;
49ZIP(DA,ZIP,CITY) ; update city, state and county based on zip code change
50 ;
51 ; This tag will be used to link the patient's zip code
52 ; with the associated city, state, and county code as
53 ; established by the US Postal Service. The 'AZIPLINK' and
54 ; 'AZIPLNK' new style x-refs on the Patient (#2) file call
55 ; this tag if the Zip+4 (.1112) or Zip Code (.116) fields change.
56 ;
57 ; Input:
58 ; DA - Patient File (#2) Patient record DFN
59 ; ZIP - ZIP+4 (.1112) or ZIP CODE (.116) field of the Patient
60 ; File (#2) entry that is being edited
61 ;
62 ; Output:
63 ; 1 - The values in the following fields were updated with the
64 ; USPS data associated with the new zipcode:
65 ; CITY field (.114) of the Patient File (#2)
66 ; STATE field (.115) of the Patient File (#2)
67 ; COUNTY field (.117) of the Patient File (#2)
68 ; 0 - the above fields were NOT updated
69 ;
70 I 'DA!$G(ZIP)="" K EASZIPLK Q 0
71 I '$D(EASZIPLK) Q 0
72 N EASDATA,FDA,MSG,DGN,CNTYIEN
73 S EASDO2=1
74 I '$$MLT(ZIP) K EASZIPLK Q 0
75 I $$FOREIGN^DGREGAZL() K EASZIPLK Q 0
76 D POSTAL^XIPUTIL(ZIP,.EASDATA)
77 ; accomodate 15 character limit on the city in the patient file
78 ; set FDA array to be filed in the Patient (#2) file
79 S CNTYIEN=""
80 S:$G(EASDATA("STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(EASDATA("STATE POINTER"))_",","MOXQ",$E($G(EASDATA("FIPS CODE")),3,5),"C")
81 D:'CNTYIEN ;could be duplicate county codes in subfile #5.01
82 .Q:'$D(^DIC(5,+$G(EASDATA("STATE POINTER")),1))
83 .Q:$E($G(EASDATA("FIPS CODE")),3,5)=""
84 .S CNTYIEN=$O(^DIC(5,$G(EASDATA("STATE POINTER")),1,"C",$E($G(EASDATA("FIPS CODE")),3,5),""))
85 S FDA(2,DA_",",.115)=$S(CNTYIEN:$G(EASDATA("STATE POINTER")),1:$G(EASDATA("STATE")))
86 S FDA(2,DA_",",.117)=$S(CNTYIEN:CNTYIEN,1:$G(EASDATA("COUNTY")))
87 ; file data
88 D FILE^DIE($S(CNTYIEN:"",1:"E"),"FDA","MSG")
89 K EASZIPLK
90 Q '$D(MSG)
91KEY(DUZ,DFN) ; determine if a security key is necessary for editing
92 ; a patient's state and county fields. If it is necessary,
93 ; determine if this user holds it.
94 ;
95 ; INPUT:
96 ; DUZ - ien for the #200 file of the user
97 ; DFN - ien of the #2 file for the patient
98 ;
99 K EASDO2 ;kill zip code linking flag (AZIPLINK and AZIPLNK x-refs)
100 Q:'$D(DUZ)!('$D(DFN)) 0
101 N ZIP,DGR
102 S ZIP=$E($$GET1^DIQ(2,DFN_",",.1112),1,5)
103 S DGR=$$ALWEDT(DUZ,ZIP)
104 Q DGR
105ALWEDT(DUZ,ZIP) ; determine if a security key is necessary for editing
106 ; Input: zip code
107 ; Output: 1: allow edit state and county
108 ; 0: don't allow edit state and county
109 N EASDATA
110 I $G(ZIP)="" Q 0
111 I '$D(DUZ) Q 0
112 I '$$MLT(ZIP) Q 1 ; > 1 state or county for the zip - allow edit
113 I $$FOREIGN^DGREGAZL() Q 1 ; Foreign location - allow edit
114 D POSTAL^XIPUTIL(ZIP,.EASDATA)
115 Q:$D(EASDATA("ERROR")) 1 ;zip code does not exist - allow editing
116 Q:'$D(EASDATA("FIPS CODE")) 1 ;cnty code does not exist - allow edit
117 Q:'$D(EASDATA("STATE")) 1 ;state does not exist - allow editing
118 Q:$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) 1 ;user holds security key
119 W !,"STATE: ",$G(EASDATA("STATE"))
120 W !,"COUNTY: ",$G(EASDATA("COUNTY"))
121 Q 0
122 ;
123MLT(ZIP) ;Determine if a zip correspond to multiple state and\or county
124 ;Output: 0: >1 state and\or county for this zip
125 ; 1: 1 state and 1 county for this zip
126 N DGN,DGFIPS,DGDATA,POP,DGCNTY,DGST
127 S (DGN,DGST,DGCNTY,DGFIPS)=""
128 S POP=0
129 D POSTALB^XIPUTIL(ZIP,.DGDATA)
130 I $D(DGDATA("ERROR")) Q 0
131 S DGN=$O(DGDATA(DGN))
132 S DGFIPS=$G(DGDATA(DGN,"FIPS CODE"))
133 F S DGN=$O(DGDATA(DGN)) Q:(DGN="")!POP D
134 . I $G(DGDATA(DGN,"FIPS CODE"))'=DGFIPS S POP=1 Q
135 I POP=1 Q 0
136 Q 1
Note: See TracBrowser for help on using the repository browser.