source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53672E.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: 7.3 KB
Line 
1DG53672E ;ALB/BRM,ERC - DG*5.3*672 Post-install Updates ; 8/19/05 1:48pm
2 ;;5.3;Registration;**672**;Aug 13, 1993
3 ;
4PRE ; Rename/Inactivate eligibility codes and enrollment statuses
5 ;
6 N ELCODE,ENSTAT,NEWSTAT,NEWCODE
7 K XPDABORT
8 S ENSTAT="PENDING; NO ELIGIBILITY CODE IN VIVA"
9 S NEWSTAT="PENDING; NO ELIGIBILITY CODE"
10 D RENAM(ENSTAT,NEWSTAT,1)
11 D CHKIEN("PENDING; NO ELIGIBILITY CODE",15) Q:$G(XPDABORT)
12 D CHKIEN("PENDING; ELIGIBILITY STATUS IS UNVERIFIED",17) Q:$G(XPDABORT)
13 S ELCODE="TRICARE/CHAMPUS",NEWCODE="TRICARE"
14 D RENAM(ELCODE,NEWCODE,0)
15 S ELCODE="MEXICAN BORDER WAR" D INACT(ELCODE)
16 S ELCODE="REIMBURSABLE INSURANCE" D INACT(ELCODE)
17 D MAP1010
18 Q
19 ;
20RENAM(OLD,NEW,FLG) ; Rename Eligibility Code or Enrollment Status Code
21 ;
22 ; OLD - Old Name for Enrollment Status or Eligibility Code
23 ; NEW - New Name for Enrollment Status or Eligibility Code
24 ; FLG - Positive value if renaming Enrollment Status (optional)
25 ;
26 N NAMEX,NAMEX1
27 I $G(FLG) D Q ;rename enrollment status
28 .S NAMEX=$E(OLD,1,30),NAMEX1=$E(NEW,1,30),DGIEN=""
29 .I '$O(^DGEN(27.15,"B",NAMEX,"")),'$O(^DGEN(27.15,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" does not exist in file #27.15 - Please contact EVS for assistance.") Q
30 .I '$O(^DIC(27.15,"B",NAMEX,"")),$O(^DIC(27.15,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" has already been renamed in file #27.15") Q
31 .F S DGIEN=$O(^DGEN(27.15,"B",NAMEX,DGIEN)) Q:'DGIEN D
32 ..I $P($G(^DGEN(27.15,DGIEN,0)),"^")=NEW D BMES^XPDUTL(OLD_" has already been renamed in file #27.15.") Q
33 ..S DGFDA(27.15,DGIEN_",",.01)=NEW
34 ..D FILE^DIE("K","DGFDA","DGERR")
35 ..I $D(DGERR) D ERRDISP(.DGERR,"Failed to Rename "_OLD_" in ENROLLMENT STATUS file (#27.15).") Q
36 ..D BMES^XPDUTL(OLD_" renamed to "_NEW_" in file #27.15")
37 ;
38 ; rename eligibility code in file #8
39 S NAMEX=$E(OLD,1,30),NAMEX1=$E(NEW,1,30),DGIEN=""
40 D ; attempt rename in file #8.1 even if file #8 fails
41 .I '$O(^DIC(8,"B",NAMEX,"")),'$O(^DIC(8,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" does not exist in file #8 - Please contact EVS for assistance.") Q
42 .I '$O(^DIC(8,"B",NAMEX,"")),$O(^DIC(8,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" has already been renamed in file #8") Q
43 .F S DGIEN=$O(^DIC(8,"B",NAMEX,DGIEN)) Q:'DGIEN D
44 ..I $P($G(^DIC(8,DGIEN,0)),"^")=NEW D BMES^XPDUTL(OLD_" has already been renamed in file #8") Q
45 ..S DGFDA(8,DGIEN_",",.01)=NEW
46 ..D FILE^DIE("K","DGFDA","DGERR")
47 ..I $D(DGERR) D ERRDISP(.DGERR,"Failed to Rename "_OLD_" in ELIGIBILITY CODE file (#8).") Q
48 ..D BMES^XPDUTL(OLD_" renamed to "_NEW_" in file #8")
49 ;
50 ; rename eligibility code in file #8.1
51 K DGFDA,DGERR
52 I '$O(^DIC(8.1,"B",NAMEX,"")),'$O(^DIC(8.1,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" does not exist in file #8.1 - Please contact EVS for assistance.") Q
53 I '$O(^DIC(8.1,"B",NAMEX,"")),$O(^DIC(8.1,"B",NAMEX1,"")) D BMES^XPDUTL(OLD_" has already been renamed in file #8.1") Q
54 S DGIEN="" F S DGIEN=$O(^DIC(8.1,"B",NAMEX,DGIEN)) Q:'DGIEN D
55 .I $P($G(^DIC(8.1,DGIEN,0)),"^")=NEW D BMES^XPDUTL(OLD_" has already been renamed in file #8.1") Q
56 .S DGFDA(8.1,DGIEN_",",.01)=NEW
57 .D FILE^DIE("K","DGFDA","DGERR")
58 .I $D(DGERR) D ERRDISP(.DGERR,"Failed to Rename "_OLD_" in MAS ELIGIBILITY CODE file (#8.1).") Q
59 .D BMES^XPDUTL(OLD_" renamed to "_NEW_" in file #8.1")
60 Q
61CHKIEN(ENSTAT,ENIEN) ; Verify IEN of records in the Enrollment Status file (#27.15)
62 Q:$G(ENSTAT)="" Q:$G(ENIEN)=""
63 I $O(^DGEN(27.15,"B",$E(ENSTAT,1,30),""))=ENIEN Q
64 ; The enrollment status is missing or has the wrong IEN, abort install
65 S XPDABORT=2
66 D BMES^XPDUTL(">>> ERROR IN ENROLLMENT STATUS FILE #27.15 <<<")
67 D BMES^XPDUTL("Enrollment Status '"_ENSTAT_"' should be record #"_ENIEN)
68 D BMES^XPDUTL("Please contact EVS for assistance")
69 D BMES^XPDUTL(">>>>>> INSTALLATION ABORTED <<<<<<")
70 Q
71INACT(ELCODE) ; Inactivate Eligibility Codes
72 N DGIEN,DGERR,DGFDA,NAMEX
73 ; This code is in the ELIGIBILITY CODE file (#8).
74 D ; allow file #8.1 checks to occur even if error msg for file #8
75 .S NAMEX=$E(ELCODE,1,30),DGIEN=""
76 .I '$O(^DIC(8,"B",NAMEX,"")) D BMES^XPDUTL(ELCODE_" does not exist in file #8 - Please contact EVS for assistance.")
77 .F S DGIEN=$O(^DIC(8,"B",NAMEX,DGIEN)) Q:'DGIEN D
78 ..I $P($G(^DIC(8,DGIEN,0)),"^",7) D BMES^XPDUTL(ELCODE_" has already been deactivated in file #8.") Q
79 ..S DGFDA(8,DGIEN_",",6)=1
80 ..D FILE^DIE("K","DGFDA","DGERR")
81 ..I $D(DGERR) D ERRDISP(.DGERR,"Failed to Inactivate "_ELCODE_" in ELIGIBILITY CODE file (#8).") Q
82 ..D BMES^XPDUTL(ELCODE_" successfully deactivated in file #8")
83 ;
84 ; This code is in the MAS ELIGIBILITY CODE file (#8.1).
85 K DGFDA,DGERR
86 I '$O(^DIC(8.1,"B",NAMEX,"")) D BMES^XPDUTL(ELCODE_" does not exist in #8.1 - Please contact EVS for assistance.") Q
87 S DGIEN="" F S DGIEN=$O(^DIC(8.1,"B",NAMEX,DGIEN)) Q:'DGIEN D
88 .D OTHR8(DGIEN)
89 .I $P($G(^DIC(8.1,DGIEN,0)),"^",7) D BMES^XPDUTL(ELCODE_" has already been deactivated in file #8.1.") Q
90 .S DGFDA(8.1,DGIEN_",",6)=1
91 .D FILE^DIE("K","DGFDA","DGERR")
92 .I $D(DGERR) D ERRDISP(.DGERR,"Failed to Inactivate "_ELCODE_" in MAS ELIGIBILITY CODE file (#8.1).") Q
93 .D BMES^XPDUTL(ELCODE_" successfully deactivated in file #8.1")
94 Q
95 ;
96OTHR8(IEN) ; find all site-specific eligibility codes pointing to ELCODE
97 ;
98 Q:'$G(IEN)
99 N IEN2,NAME,DGFDA,DGERR
100 S IEN2="" F S IEN2=$O(^DIC(8,"D",IEN,IEN2)) Q:'IEN2 D
101 .S NAME=$P($G(^DIC(8,IEN2,0)),"^")
102 .Q:NAME=$P($G(^DIC(8.1,IEN,0)),"^")
103 .I $P($G(^DIC(8,IEN2,0)),"^",7) D BMES^XPDUTL(NAME_" has already been deactivated in file #8.") Q
104 .S DGFDA(8,IEN2_",",6)=1
105 .D FILE^DIE("K","DGFDA","DGERR")
106 .I $D(DGERR) D ERRDISP(.DGERR,"Failed to Inactivate "_NAME_" in ELIGIBILITY CODE file (#8).") Q
107 .D BMES^XPDUTL(NAME_" successfully deactivated in file #8")
108 Q
109ERRDISP(DGERR,TXT) ; Display FM error message.
110 N ERR,LINE
111 S (ERR,LINE)=0
112 D BMES^XPDUTL(TXT)
113 F S ERR=$O(DGERR("DIERR",ERR)) Q:'ERR F S LINE=$O(DGERR("DIERR",ERR,"TEXT",LINE)) Q:LINE']"" D BMES^XPDUTL(" "_DGERR("DIERR",ERR,"TEXT",LINE))
114 D BMES^XPDUTL("Please contact EVS for assistance")
115 Q
116MAP1010 ;the 1010EZ Mapping file (#711) links a 1010EZ field with the Patient
117 ;file field to which it maps. DG*5.3*672 changes the mapping of the
118 ;DISABILITY RETIREMENT FROM MILITARY field from .362 - DISABILITY RET.
119 ;FROM MILITARY? to .3602 - REC'ING MILITARY RETIREMENT? and from
120 ;1010.158 - DISABILITY DISCHARGE ON 1010EZ to .3603 - DISCH. DUE TO
121 ;DISABILITY?
122 N DG1010,DG362,DGFDA,DGFLD,DGMES,DGPARAM,ERR
123 S DG1010=$O(^EAS(711,"B","DISABILITY DISCHARGE CLAIMED",0))
124 S DG362=$O(^EAS(711,"B","DISABILITY RETIREMENT FROM MIL",0))
125 I $G(DG362)]"" S DGFDA(711,DG362_",",4)=.3602
126 I $G(DG1010)]"" S DGFDA(711,DG1010_",",4)=.3603
127 D FILE^DIE("S","DGFDA","DGERR")
128 S ERR=""
129 F S ERR=$O(DGERR("DIERR",ERR)) Q:'ERR D
130 . F S LINE=$O(DGERR("DIERR",ERR,"TEXT",LINE)) Q:LINE']"" D
131 . . D BMES^XPDUTL(" "_DGERR("DIERR",ERR,"TEXT",LINE))
132 . . D BMES^XPDUTL("Please contact EVS for assistance")
133 . . S DGPARAM(ERR)=$G(DGERR("DIERR",ERR,"PARAM",1))
134 I $G(DGPARAM(2)) Q ;if there are 2 params, then both failed
135 I '$D(DGPARAM) D FLD3602,FLD3603 ;if there are no params, then neither failed
136 ;only one field failed, so determine which one and send success message
137 ;for the other
138 I $G(DGPARAM(1))=.3602 D FLD3603
139 I $G(DGPARAM(1))=.3603 D FLD3602
140 I $D(DGMES) D BMES^XPDUTL(.DGMES)
141 Q
142FLD3602 ;
143 S DGFLD="DISABILITY RETIREMENT FROM MILITARY"
144 S DGMES(1)="Changed mapping of "_DGFLD_" in file #711 from .362 to .3602"
145 Q
146FLD3603 ;
147 S DGFLD="DISABILITY DISCHARGE CLAIMED"
148 S DGMES(2)="Changed mapping of "_DGFLD_" in file #711 from 1010.158 to .3603"
149 Q
Note: See TracBrowser for help on using the repository browser.