source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACPRE17.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1QACPRE17 ;ALB/ERC - PRE-INSTALL FOR PATCH QAC*2*17 ;3/6/02
2 ;;2.0;Patient Representative:**17**;07/25/1995
3 ;
4 ;This routine will perform the de-activation of the existing Issue
5 ;Codes from file 745.2. Allowable Issue Codes will now be restricted
6 ;to those being imported with this patch. Two existing codes, ED01 and
7 ;ED02 will be retained.
8EN ;
9 D INACT
10 D ED
11 D CSS
12 D RENAME
13 Q
14INACT ;inactivate current codes
15 N QACQ
16 D INSTALL^QACENV17
17 Q:$G(QACQ)=1
18 N QAC,QACC,QACFDA,QACNODE
19 S QAC=0
20 F S QAC=$O(^QA(745.2,QAC)) Q:QAC'>0 D
21 . Q:'$D(^QA(745.2,QAC,0))
22 . S QACNODE=^QA(745.2,QAC,0)
23 . ;ED01 and ED02 will still be in use
24 . Q:$P(QACNODE,U)="ED01"!($P(QACNODE,U)="ED02")
25 . I $P(QACNODE,U,6)']"" D
26 . . S QACFDA(745.2,QAC_",",4)=1
27 . . S QACFDA(745.2,QAC_",",6)=DT
28 . . D FILE^DIE(,"QACFDA","QACERR")
29 Q
30ED ;check to see if the ED01 and ED02 entries are current. These two
31 ;codes are already in existence, and are being retained
32 ;if these codes are not in the file, add them
33 N QACC,QACD,QACN,QACNM,QACNN,QACNNN
34 S QACD=0
35 F QACC="ED01","ED02" D
36 . S QACD=$O(^QA(745.2,"B",QACC,QACD)) Q:QACC']"" D
37 . . I '$D(^QA(745.2,QACD,0)) D DIC Q
38 . . S QACN=$P(^QA(745.2,QACD,0),U,3)
39 . . S QACNN=$TR(QACN," ")
40 . . S QACNNN=$E($$UP^XLFSTR(QACN),1,60)
41 . . S QACNM=$S(QACC="ED01":"DIAGNOSIS / CARE / PREVENTION",1:"PURPOSE/SIDE EFFECTS OF MEDICATION")
42 . . I $G(QACNM)'=QACN,($G(QACNM)'=QACNNN),($G(QACNM)'=(QACNNN)) D ADD
43 Q
44RENAME ;check for duplicates. If there are any, rename them
45 N QACQ
46 D INSTALL^QACENV17
47 Q:$G(QACQ)=1
48 N QACE,QACIEN,QACODE,QACPRE,QAX
49 S QACIEN=0
50 S QAX=""
51 S QACODE="^SC^AC^OP^PR^EM^PC^CO^TR^FI^RI^LL^EV^RG^IF^CP^"
52 F S QAX=$O(^QA(745.2,"B",QAX)) Q:QAX']"" D
53 . S QACIEN=$O(^QA(745.2,"B",QAX,QACIEN)) Q:QACIEN'>0 D
54 . . S QACE="^"_$E(QAX,1,2)_"^"
55 . . I QACODE[QACE D
56 . . . S QACPRE=$E(QAX,1,2)
57 . . . D CODE(QAX,QACPRE,QACIEN)
58 Q
59CODE(QAC,QACPRE,QACIEN) ;check for specific code, if a duplicate, call DIE
60 N QACQUIT,QACR,QACTXT,QAXX
61 Q:$G(QAC)']""
62 F QAXX=1:1 S QACTXT=$P($T(@QACPRE+QAXX),";;",2) Q:$G(QACTXT)']""!($G(QACQUIT)=1) D
63 . I $G(QAC)=$G(QACTXT) D
64 . . S QACIEN(QACIEN)=""
65 . . S QACQUIT=1
66 I $O(QACIEN(0))'>0 D ZZ
67 Q
68ZZ ;rename duplicate code entries (add "Z" to beginning of code)
69 N DA,DIK,QACDR,QACN,QACNN
70 S QACN=0
71 S DIK="^QA(745.2,"
72 F S QACN=$O(QACIEN(QACN)) Q:QACN'>0 D
73 . S QACNN=$P(^QA(745.2,QACN,0),U)
74 . Q:$G(QACNN)']""
75 . S QACDR="Z"_QACNN
76 . S $P(^QA(745.2,QACN,0),U)=$G(QACDR)
77 . Q:$G(QACDR)']""!('$D(^QA(745.2,QACN,0)))
78 . S DA=QACN
79 . S DIK(1)=".01^B^BU"
80 . D EN^DIK
81 . K ^QA(745.2,"B",QACNN,QACN)
82 . K ^QA(745.2,"BU",QACNN,QACN)
83 Q
84ADD ;update entries ED01 and ED02
85 N DA,DIE,DR
86 S DIE="^QA(745.2,",DA=QACD
87 S DR="2///^S X=$S(QACC=""ED01"":""Diagnosis / care / prevention"",1:""Purpose/side effects of medication"");4///^S X=""N"";6///@;7///^S X=7"
88 D ^DIE
89 Q
90DIC ;if ED01 or ED02 not in file, add it
91 N DA,DIC,Y
92 S DIC="^QA(745.2,",DA=QACD
93 D ^DIC
94 I +Y>0 S DA=+Y
95 D ADD
96 Q
97SC ;
98 ;;SC01
99 ;;SC02
100 Q
101AC ;
102 ;;AC01
103 ;;AC02
104 ;;AC03
105 ;;AC04
106 ;;AC05
107 ;;AC06
108 ;;AC07
109 ;;AC08
110 ;;AC09
111 ;;AC10
112 ;;AC11
113 ;;AC12
114 Q
115OP ;
116 ;;OP01
117 ;;OP02
118 Q
119PR ;
120 ;;PR01
121 ;;PR02
122 ;;PR03
123 ;;PR04
124 Q
125EM ;
126 ;;EM01
127 ;;EM02
128 ;;EM03
129 Q
130PC ;
131 ;;PC01
132 ;;PC02
133 Q
134CO ;
135 ;;CO01
136 ;;CO02
137 ;;CO03
138 ;;CO04
139 Q
140TR ;
141 ;;TR01
142 Q
143FI ;
144 ;;FI01
145 Q
146RI ;
147 ;;RI01
148 ;;RI02
149 ;;RI03
150 ;;RI04
151 ;;RI05
152 Q
153RE ;
154 ;;RE01
155 Q
156LL ;
157 ;;LL01
158 ;;LL02
159 ;;LL03
160 ;;LL04
161 Q
162EV ;
163 ;;EV01
164 ;;EV02
165 ;;EV03
166 Q
167RG ;
168 ;;RG01
169 ;;RG02
170 ;;RG03
171 Q
172IF ;
173 ;;IF01
174 ;;IF02
175 ;;IF04
176 ;;IF05
177 ;;IF06
178 ;;IF07
179 ;;IF08
180 ;;IF09
181 ;;IF10
182 Q
183CP ;
184 ;;CP01
185 Q
186CSS ;edit any Name fields that differ from the exported version, as FM will
187 ;create new entries is they are not the same
188 N DA,DIE,DR,QAC,QACNAME,QACZERO,X
189 S QACNAME="Staff Courtesy^Access/Timeliness^One Provider^Decisions/Preferences^Emotional Needs^Coordination of Care^Patient Education^Family Involvement^Physical Comfort^Transitions"
190 S QAC=0
191 F S QAC=$O(^QA(745.6,QAC)) Q:QAC'>0!(QAC>10) D
192 . S QACZERO=^QA(745.6,QAC,0)
193 . I QAC'=$P(QACZERO,U) S QAC(QAC)=""
194 . I $P(QACZERO,U,2)'=$P(QACNAME,U,QAC) S QAC(QAC)=""
195 Q:$O(QAC(0))'>0
196 S QAC=0
197 S DIE="^QA(745.6,"
198 F S QAC=$O(QAC(QAC)) Q:QAC'>0 D
199 . S DA=QAC,DR=".01///^S X=QAC;1///^S X=$P(QACNAME,U,QAC)"
200 . D ^DIE
201 Q
Note: See TracBrowser for help on using the repository browser.