source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMP4I1.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1PXRMP4I1 ; SLC/PKR - PXRM*2.0*4 init routine. ;06/28/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;==========================================
5CLEAN(FILENUM,NAME) ;Clean entry NAME in file number FILENUM.
6 N DFDA,ENTRY,FDAIEN,FIELD,GBL,IEN,IENS,IND,LOCK,MSG,REQLIST,SFDA
7 S IEN=$$FIND1^DIC(FILENUM,"","BX",NAME)
8 I IEN=0 Q
9 S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
10 I GBL="" Q
11 S ENTRY=GBL_IEN_")"
12 S IENS=IEN_","
13 S DFDA(FILENUM,IENS,.01)="@"
14 D FILE^DID(FILENUM,"N","REQUIRED IDENTIFIERS","REQLIST","MSG")
15 S IND=0
16 F S IND=$O(REQLIST("REQUIRED IDENTIFIERS",IND)) Q:IND="" D
17 . S FIELD=REQLIST("REQUIRED IDENTIFIERS",IND,"FIELD")
18 . S SFDA(FILENUM,"+1,",FIELD)=$$GET1^DIQ(FILENUM,IENS,FIELD,"","","MSG")
19 S FDAIEN(1)=IEN
20 S LOCK=0
21 F IND=1:1:3 Q:LOCK D
22 . L +@ENTRY:2
23 . S LOCK=$T
24 I LOCK=0 D Q
25 . N TEXT
26 . S TEXT="No lock for file "_FILENUM_" entry "_IEN
27 . D BMES^XPDUTL(.TEXT)
28 D FILE^DIE("","DFDA","MSG")
29 I $D(MSG) D AWRITE^PXRMUTIL("MSG") H 2
30 K MSG
31 D UPDATE^DIE("E","SFDA","FDAIEN","MSG")
32 L -@ENTRY
33 I $D(MSG) D AWRITE^PXRMUTIL("MSG") H 2
34 Q
35 ;
36 ;==========================================
37GECDIA ;
38 ;
39 D BMES^XPDUTL("Re-Setting Heath FactorS Syn. Entries.")
40 N HFIEN,SYN1,SYN0
41 S FHIEN=0
42 S SYN1="GEC3F CARE RECOMMENDATIONS 1"
43 S SYN0="GEC3F CARE RECOMMENDATIONS 0"
44 ;
45 ;**VA-DG GEC PROGNOSIS
46 S FHIEN=$O(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-YES",0))
47 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
48 ;
49 S FHIEN=$O(^AUTTHF("B","GEC EXACERBATION CHR ILLNESS LAST 7D-NO",0)) D SYN0
50 ;
51 S FHIEN=$O(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-YES",0))
52 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
53 ;
54 S FHIEN=$O(^AUTTHF("B","GEC CAPABLE INCREASED INDEPENDENCE-NO",0)) D SYN0
55 ;
56 S FHIEN=$O(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-YES",0))
57 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN1
58 ;
59 S FHIEN=$O(^AUTTHF("B","GEC LIFE EXPECTANCY < 6MO-NO",0)) D SYN0
60 ;
61 ;**VA-DG GEC WEIGHT BEARING
62 S FHIEN=$O(^AUTTHF("B","GEC FULL WEIGHT BEARING",0)) D SYN0
63 ;
64 S FHIEN=$O(^AUTTHF("B","GEC PARTIAL WEIGHT BEARING",0)) D SYN0
65 ;
66 S FHIEN=$O(^AUTTHF("B","GEC NON WEIGHTBEARING",0)) D SYN0
67 ;
68 ;**VA-DG GEC DIET
69 ;
70 S FHIEN=$O(^AUTTHF("B","GEC REGULAR DIET",0)) D SYN0
71 ;
72 S FHIEN=$O(^AUTTHF("B","GEC MODIFIED DIET",0)) D SYN0
73 ;
74 ;**VA-DG GEC PROSTHETIC REQUESTS
75 ;
76 S FHIEN=$O(^AUTTHF("B","GEC HOSPITAL BED",0)) D SYN0
77 ;
78 S FHIEN=$O(^AUTTHF("B","GEC SPECIAL MATTRESS",0)) D SYN0
79 ;
80 S FHIEN=$O(^AUTTHF("B","GEC TRAPEZE",0)) D SYN0
81 ;
82 S FHIEN=$O(^AUTTHF("B","GEC WALKER/ASSISTIVE DEVICE",0)) D SYN0
83 ;
84 S FHIEN=$O(^AUTTHF("B","GEC CANE",0)) D SYN0
85 ;
86 S FHIEN=$O(^AUTTHF("B","GEC WHEELCHAIR",0)) D SYN0
87 ;
88 S FHIEN=$O(^AUTTHF("B","GEC ADL EQUIPMENT",0)) D SYN0
89 ;
90 S FHIEN=$O(^AUTTHF("B","GEC ORTHOTIC/SPLINT",0)) D SYN0
91 ;
92 S FHIEN=$O(^AUTTHF("B","GEC OTHER EQUIPMENT",0)) D SYN0
93 Q
94 ;
95 ;==========================================
96RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
97 ;file number FILENUM.
98 N DA,DIE,DR
99 S DA=$$FIND1^DIC(FILENUM,"","BX",OLDNAME)
100 I DA=0 Q
101 S DIE=FILENUM
102 S DR=".01///^S X=NEWNAME"
103 D ^DIE
104 Q
105 ;
106 ;==========================================
107RELTEMP ;Rename the Extract list templates.
108 N IND,NEWNAME,NUM,OLDNAME
109 D BMES^XPDUTL("Renaming extract List Templates")
110 S NUM=0
111 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT",NEWNAME(NUM)="PXRM COUNT RULE EDIT"
112 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
113 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GRP EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GRP EDIT"
114 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDINGS",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
115 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETERS",NEWNAME(NUM)="PXRM EXTRACT DEFINITIONS"
116 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
117 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY",NEWNAME(NUM)="PXRM EXTRACT DEF DISPLAY"
118 F IND=1:1:NUM D
119 . D RENAME(409.61,OLDNAME(IND),NEWNAME(IND))
120 . D CLEAN(409.61,NEWNAME(IND))
121 D CLEAN(409.61,"PXRM EXTRACT HELP")
122 D CLEAN(409.61,"PXRM EXTRACT HISTORY")
123 D CLEAN(409.61,"PXRM EXTRACT MANAGEMENT")
124 D CLEAN(409.61,"PXRM EXTRACT SUMMARY")
125 D CLEAN(409.61,"PXRM EXTRACT TRANSMISSIONS")
126 D CLEAN(409.61,"PXRM LIST RULE MANAGEMENT")
127 Q
128 ;
129 ;==========================================
130REOPTS ;Rename the Extract options.
131 N IND,NEWNAME,NUM,OLDNAME
132 D BMES^XPDUTL("Renaming extract options")
133 S NUM=0
134 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDINGS",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULES"
135 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
136 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETERS",NEWNAME(NUM)="PXRM EXTRACT DEFINITION"
137 F IND=1:1:NUM D
138 . D RENAME(19,OLDNAME(IND),NEWNAME(IND))
139 . D CLEAN(19,NEWNAME(IND))
140 D CLEAN(19,"PXRM EXTRACT MENU")
141 D CLEAN(19,"PXRM EXTRACT MANAGEMENT")
142 D CLEAN(19,"PXRM EXTRACT PATIENT LIST")
143 D CLEAN(19,"PXRM LIST RULE MANAGEMENT")
144 Q
145 ;
146 ;==========================================
147REPROTS ;Rename the Extract protocols.
148 N IND,NEWNAME,NUM,OLDNAME
149 D BMES^XPDUTL("Renaming extract protocols")
150 S NUM=0
151 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING CREATE",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE CREATE"
152 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY MENU"
153 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE DISPLAY/EDIT"
154 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EDIT"
155 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING EXIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE EXIT"
156 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP CREATE",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP CREATE"
157 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY MENU"
158 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP DISPLAY/EDIT"
159 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EDIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EDIT"
160 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP EXIT",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP EXIT"
161 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP MENU"
162 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUP SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUP SELECT ENTRY"
163 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING GROUPS",NEWNAME(NUM)="PXRM EXTRACT COUNTING GROUPS"
164 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING MENU",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE MENU"
165 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT FINDING SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT COUNTING RULE SELECT ENTRY"
166 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER CREATE",NEWNAME(NUM)="PXRM EXTRACT DEFINITION CREATE"
167 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY MENU",NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY MENU"
168 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER DISPLAY/EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION DISPLAY/EDIT"
169 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EDIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EDIT"
170 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER EXIT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION EXIT"
171 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER MANAGEMENT",NEWNAME(NUM)="PXRM EXTRACT DEFINITION MANAGEMENT"
172 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER MENU",NEWNAME(NUM)="PXRM EXTRACT DEFINITION MENU"
173 S NUM=NUM+1,OLDNAME(NUM)="PXRM EXTRACT PARAMETER SELECT ENTRY",NEWNAME(NUM)="PXRM EXTRACT DEFINITION SELECT ENTRY"
174 F IND=1:1:NUM D
175 . D RENAME(101,OLDNAME(IND),NEWNAME(IND))
176 . D CLEAN(101,NEWNAME(IND))
177 Q
178 ;
179 ;==========================================
180SYN0 ;
181 S $P(^AUTTHF(FHIEN,0),"^",9)=SYN0
182 Q
183 ;
184 ;==========================================
185SLABENOD ;Make sure the enodes are set correctly for lab findings.
186 N DA,FI,IEN,X
187 D BMES^XPDUTL("Setting ENODEs for lab findings.")
188 S IEN=0
189 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
190 . I '$D(^PXD(811.9,IEN,20,"E","LAB(60,")) Q
191 . K ^PXD(811.9,IEN,20,"E","LAB(60,")
192 . S FI=0
193 . F S FI=+$O(^PXD(811.9,IEN,20,FI)) Q:FI=0 D
194 .. S X=$P(^PXD(811.9,IEN,20,FI,0),U,1)
195 .. I $P(X,";",2)'["LAB(60," Q
196 .. S DA=FI,DA(1)=IEN
197 .. D SENODE^PXRMENOD(.X,.DA,811.9)
198 ;
199 S IEN=0
200 F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
201 . I '$D(^PXRMD(811.5,IEN,20,"E","LAB(60,")) Q
202 . K ^PXRMD(811.5,IEN,20,"E","LAB(60,")
203 . S FI=0
204 . F S FI=+$O(^PXRMD(811.5,IEN,20,FI)) Q:FI=0 D
205 .. S X=$P(^PXRMD(811.5,IEN,20,FI,0),U,1)
206 .. I $P(X,";",2)'["LAB(60," Q
207 .. S DA=FI,DA(1)=IEN
208 .. D SENODE^PXRMENOD(.X,.DA,811.5)
209 Q
210 ;
211 ;==========================================
212SNEXTIP ;Set the INCLUDE DECEASED PATIENTS and INCLUDE TEST PATIENTS
213 ;parameters in the the national extracts.
214 N IEN,NAME,SEQ
215 F NAME="VA-IHD QUERI","VA-MH QUERI" D
216 . S IEN=$O(^PXRM(810.2,"B",NAME,""))
217 . S SEQ=0
218 . F S SEQ=+$O(^PXRM(810.2,IEN,10,SEQ)) Q:SEQ=0 D
219 .. S $P(^PXRM(810.2,IEN,10,SEQ,0),U,4,5)=1_U_0
220 Q
221 ;
Note: See TracBrowser for help on using the repository browser.