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

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1DG53415 ;BPFO/JRP - PRE/POST INITS FOR PATCH 415;7/11/2002 ; 11/5/02 12:45pm
2 ;;5.3;Registration;**415**;Aug 13, 1993
3 ;
4 Q
5 ;
6PRE ;Pre-init entry point
7 N JUNK1,JUNK2,SUBFILE
8 ;Delete obsolete sub-files
9 F SUBFILE=2.02,2.06 I $D(^DD(SUBFILE)) D
10 .;Don't delete if the obsolete sub-file isn't there
11 .N DEL,X
12 .S DEL=0
13 .S X=0 F S X=+$O(^DD(2,"SB",SUBFILE,X)) Q:'X D Q:DEL
14 ..I SUBFILE=2.02 S:(X'=2) DEL=1
15 ..I SUBFILE=2.06 S:(X'=6) DEL=1
16 .Q:'DEL
17 .;Remove reference to correct sub-file
18 .S X=$S(SUBFILE=2.02:2,1:6) K ^DD(2,"SB",SUBFILE,X)
19 .;Delete sub-file
20 .S JUNK1(1)=" "
21 .S JUNK1(2)="The new "_$S(SUBFILE=2.02:"RACE",1:"ETHNICITY")_" INFORMATION multiple is contained in"
22 .S JUNK1(3)="an obsolete sub-file that still exists on your system."
23 .S JUNK1(4)="The obsolete sub-file (#"_SUBFILE_") will now be deleted."
24 .S JUNK1(5)=" "
25 .D MES^XPDUTL(.JUNK1) K JUNK1
26 .N DIU
27 .S DIU=SUBFILE
28 .S DIU(0)="DST"
29 .D EN^DIU2
30 ;Delete "bad" B x-reference on RACE file (patch brings in "good" one)
31 S JUNK1(1)=" "
32 S JUNK1(2)="The B cross reference on the RACE file (#10) may be listed"
33 S JUNK1(3)="as the second cross reference of the NAME field (#.01)"
34 S JUNK1(4)="instead of the first. To ensure that the B cross"
35 S JUNK1(5)="reference is listed as the first cross reference, the"
36 S JUNK1(6)="second cross reference of the NAME field will now be"
37 S JUNK1(7)="deleted."
38 S JUNK1(8)=" "
39 D MES^XPDUTL(.JUNK1) K JUNK1
40 D DELIX^DDMOD(10,.01,2,"W","JUNK1","JUNK2")
41 Q
42 ;
43POST ;Post-init entry point
44 N JUNK,DIK,RACES,IEN
45 ;Rebuild B x-reference on RACE file
46 S JUNK(1)=" "
47 S JUNK(2)="The incorrect B cross reference on the RACE file (#10),"
48 S JUNK(3)="which was removed by the pre-init, placed the entire value"
49 S JUNK(4)="of the NAME field (#.01) into the cross reference. The"
50 S JUNK(5)="correct logic for the B cross reference only places the"
51 S JUNK(6)="first thirty characters into the cross reference. To"
52 S JUNK(7)="ensure that the cross referenced values are correct, the"
53 S JUNK(8)="entire B cross reference will now be deleted and then"
54 S JUNK(9)="reindexed."
55 S JUNK(10)=" "
56 D MES^XPDUTL(.JUNK) K JUNK
57 K ^DIC(10,"B")
58 S DIK="^DIC(10,"
59 S DIK(1)=".01^B"
60 D ENALL^DIK K DIK
61 ;Inactivate all races
62 S JUNK(1)=" "
63 S JUNK(2)="Marking all entries in the RACE file (#10) as inactive"
64 S JUNK(3)=" "
65 D MES^XPDUTL(.JUNK) K JUNK
66 S IEN=0
67 F S IEN=+$O(^DIC(10,IEN)) Q:'IEN D
68 .N FDAROOT,MSGROOT,IENS
69 .S IENS=IEN_","
70 .S FDAROOT(10,IENS,200)=1
71 .S FDAROOT(10,IENS,202)=$P($$NOW^XLFDT(),".",1)
72 .D FILE^DIE("K","FDAROOT","MSGROOT")
73 .I $D(MSGROOT) D
74 ..S JUNK(1)=" **"
75 ..S JUNK(2)=" ** ERROR"
76 ..S JUNK(3)=" ** Unable to inactivate entry number "_IEN
77 ..S JUNK(4)=" ** Entry should be inactivated via FileMan"
78 ..S JUNK(5)=" **"
79 ..D MES^XPDUTL(.JUNK) K JUNK
80 ;Create/update national entries
81 S JUNK(1)=" "
82 S JUNK(2)="Creating/updating nationally supported entries in the RACE"
83 S JUNK(3)="file (#10)"
84 S JUNK(4)=" "
85 D MES^XPDUTL(.JUNK) K JUNK
86 D BLDLST(.RACES)
87 S IEN=0
88 F S IEN=+$O(RACES("FDA",IEN)) Q:'IEN D
89 .N FDAROOT,IENROOT,MSGROOT,IENS,TMP
90 .S TMP=RACES("FDA",IEN,.01)
91 .S IENS=+$O(^DIC(10,"B",$E(TMP,1,30),0)) S:'IENS IENS="+1"
92 .S IENS=IENS_","
93 .M FDAROOT(10,IENS)=RACES("FDA",IEN)
94 .D UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
95 .I $D(MSGROOT) D
96 ..S JUNK(1)=" **"
97 ..S JUNK(2)=" ** ERROR"
98 ..S JUNK(3)=" ** Unable to create entry for "_RACES("FDA",IEN,.01)
99 ..S JUNK(4)=" ** Entry should be created via FileMan"
100 ..S JUNK(5)=" ** Name (.01): "_RACES("FDA",IEN,.01)
101 ..S JUNK(6)=" ** Abbrev (2): "_RACES("FDA",IEN,2)
102 ..S JUNK(7)=" ** HL7 Val (3): "_RACES("FDA",IEN,3)
103 ..S JUNK(8)=" ** CDC Val (4): "_RACES("FDA",IEN,4)
104 ..S JUNK(9)=" ** PTF Val (5): "_RACES("FDA",IEN,5)
105 ..S JUNK(10)=" **"
106 ..D MES^XPDUTL(.JUNK) K JUNK
107 ;Delete RACE identifier
108 S JUNK(1)=" "
109 S JUNK(2)="Removing old RACE field (#.06) as an identifier of the"
110 S JUNK(3)="PATIENT file (#2)."
111 S JUNK(4)=" "
112 D MES^XPDUTL(.JUNK) K JUNK
113 K ^DD(2,0,"ID",.06)
114 Q
115 ;
116BLDLST(ARRAY) ;Build list of valid races
117 ;Input : ARRAY - Array to place values into (pass by value)
118 ;Output : ARRAY("FDA",X,Field) = Value
119 ;Notes : ARRAY will be initiallized (killed) on entry
120 ; : Assumes ARRAY is input
121 ;
122 N LOOP,TEXT,STOP,X
123 K ARRAY
124 S (STOP,LOOP)=0
125 F S LOOP=LOOP+1 D Q:STOP
126 .S TEXT=$P($T(RACES+LOOP),";;",2)
127 .S X=$P(TEXT,"^",1)
128 .I X="" S STOP=1 Q
129 .S ARRAY("FDA",LOOP,.01)=X
130 .F X=2:1:5 S ARRAY("FDA",LOOP,X)=$P(TEXT,"^",X)
131 .S ARRAY("FDA",LOOP,200)="@"
132 .S ARRAY("FDA",LOOP,202)="@"
133 Q
134 ;
135RACES ;RACE (#.01)^ABBREVIATION (#2)^HL7 (#3)^CDC (#4)^PTF (#5)
136 ;;AMERICAN INDIAN OR ALASKA NATIVE^3^1002-5^1002-5^3
137 ;;ASIAN^A^2028-9^2028-9^8
138 ;;BLACK OR AFRICAN AMERICAN^B^2054-5^2054-5^9
139 ;;DECLINED TO ANSWER^D^0000-0^^C
140 ;;NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER^H^2076-8^2076-8^A
141 ;;UNKNOWN BY PATIENT^U^9999-4^^D
142 ;;WHITE^W^2106-3^2106-3^B
143 ;;
Note: See TracBrowser for help on using the repository browser.