[1635] | 1 | KIDS Distribution saved on Mar 23, 2014@10:18:31
|
---|
| 2 | World VistA
|
---|
| 3 | **KIDS**:VWGUIR_UPDATE_03232014*1.0T*1^
|
---|
| 4 |
|
---|
| 5 | **INSTALL NAME**
|
---|
| 6 | VWGUIR_UPDATE_03232014*1.0T*1
|
---|
| 7 | "BLD",8495,0)
|
---|
| 8 | VWGUIR_UPDATE_03232014*1.0T*1^^0^3140323^n
|
---|
| 9 | "BLD",8495,1,0)
|
---|
| 10 | ^^2^2^3140323^
|
---|
| 11 | "BLD",8495,1,1,0)
|
---|
| 12 | Contains routine updates, pat inquiry display, enables making an
|
---|
| 13 | "BLD",8495,1,2,0)
|
---|
| 14 | input template through the GUI.
|
---|
| 15 | "BLD",8495,4,0)
|
---|
| 16 | ^9.64PA^^
|
---|
| 17 | "BLD",8495,6.3)
|
---|
| 18 | 1
|
---|
| 19 | "BLD",8495,"KRN",0)
|
---|
| 20 | ^9.67PA^779.2^20
|
---|
| 21 | "BLD",8495,"KRN",.4,0)
|
---|
| 22 | .4
|
---|
| 23 | "BLD",8495,"KRN",.401,0)
|
---|
| 24 | .401
|
---|
| 25 | "BLD",8495,"KRN",.402,0)
|
---|
| 26 | .402
|
---|
| 27 | "BLD",8495,"KRN",.402,"NM",0)
|
---|
| 28 | ^9.68A^^0
|
---|
| 29 | "BLD",8495,"KRN",.403,0)
|
---|
| 30 | .403
|
---|
| 31 | "BLD",8495,"KRN",.5,0)
|
---|
| 32 | .5
|
---|
| 33 | "BLD",8495,"KRN",.84,0)
|
---|
| 34 | .84
|
---|
| 35 | "BLD",8495,"KRN",3.6,0)
|
---|
| 36 | 3.6
|
---|
| 37 | "BLD",8495,"KRN",3.8,0)
|
---|
| 38 | 3.8
|
---|
| 39 | "BLD",8495,"KRN",3.8,"NM",0)
|
---|
| 40 | ^9.68A^^0
|
---|
| 41 | "BLD",8495,"KRN",9.2,0)
|
---|
| 42 | 9.2
|
---|
| 43 | "BLD",8495,"KRN",9.8,0)
|
---|
| 44 | 9.8
|
---|
| 45 | "BLD",8495,"KRN",9.8,"NM",0)
|
---|
| 46 | ^9.68A^11^4
|
---|
| 47 | "BLD",8495,"KRN",9.8,"NM",8,0)
|
---|
| 48 | VWREGIT^^0^B129809193
|
---|
| 49 | "BLD",8495,"KRN",9.8,"NM",9,0)
|
---|
| 50 | VWREGIT2^^0^B100003944
|
---|
| 51 | "BLD",8495,"KRN",9.8,"NM",10,0)
|
---|
| 52 | VWREGIT3^^0^B43452100
|
---|
| 53 | "BLD",8495,"KRN",9.8,"NM",11,0)
|
---|
| 54 | VWREGIT4^^0^B43791810
|
---|
| 55 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT",8)
|
---|
| 56 |
|
---|
| 57 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT2",9)
|
---|
| 58 |
|
---|
| 59 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT3",10)
|
---|
| 60 |
|
---|
| 61 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT4",11)
|
---|
| 62 |
|
---|
| 63 | "BLD",8495,"KRN",19,0)
|
---|
| 64 | 19
|
---|
| 65 | "BLD",8495,"KRN",19,"NM",0)
|
---|
| 66 | ^9.68A^^0
|
---|
| 67 | "BLD",8495,"KRN",19.1,0)
|
---|
| 68 | 19.1
|
---|
| 69 | "BLD",8495,"KRN",101,0)
|
---|
| 70 | 101
|
---|
| 71 | "BLD",8495,"KRN",101,"NM",0)
|
---|
| 72 | ^9.68A^^0
|
---|
| 73 | "BLD",8495,"KRN",409.61,0)
|
---|
| 74 | 409.61
|
---|
| 75 | "BLD",8495,"KRN",771,0)
|
---|
| 76 | 771
|
---|
| 77 | "BLD",8495,"KRN",771,"NM",0)
|
---|
| 78 | ^9.68A^^0
|
---|
| 79 | "BLD",8495,"KRN",779.2,0)
|
---|
| 80 | 779.2
|
---|
| 81 | "BLD",8495,"KRN",870,0)
|
---|
| 82 | 870
|
---|
| 83 | "BLD",8495,"KRN",8989.51,0)
|
---|
| 84 | 8989.51
|
---|
| 85 | "BLD",8495,"KRN",8989.51,"NM",0)
|
---|
| 86 | ^9.68A^^0
|
---|
| 87 | "BLD",8495,"KRN",8989.52,0)
|
---|
| 88 | 8989.52
|
---|
| 89 | "BLD",8495,"KRN",8994,0)
|
---|
| 90 | 8994
|
---|
| 91 | "BLD",8495,"KRN",8994,"NM",0)
|
---|
| 92 | ^9.68A^10^1
|
---|
| 93 | "BLD",8495,"KRN",8994,"NM",10,0)
|
---|
| 94 | VW REG PATINQ^^0
|
---|
| 95 | "BLD",8495,"KRN",8994,"NM","B","VW REG PATINQ",10)
|
---|
| 96 |
|
---|
| 97 | "BLD",8495,"KRN","B",.4,.4)
|
---|
| 98 |
|
---|
| 99 | "BLD",8495,"KRN","B",.401,.401)
|
---|
| 100 |
|
---|
| 101 | "BLD",8495,"KRN","B",.402,.402)
|
---|
| 102 |
|
---|
| 103 | "BLD",8495,"KRN","B",.403,.403)
|
---|
| 104 |
|
---|
| 105 | "BLD",8495,"KRN","B",.5,.5)
|
---|
| 106 |
|
---|
| 107 | "BLD",8495,"KRN","B",.84,.84)
|
---|
| 108 |
|
---|
| 109 | "BLD",8495,"KRN","B",3.6,3.6)
|
---|
| 110 |
|
---|
| 111 | "BLD",8495,"KRN","B",3.8,3.8)
|
---|
| 112 |
|
---|
| 113 | "BLD",8495,"KRN","B",9.2,9.2)
|
---|
| 114 |
|
---|
| 115 | "BLD",8495,"KRN","B",9.8,9.8)
|
---|
| 116 |
|
---|
| 117 | "BLD",8495,"KRN","B",19,19)
|
---|
| 118 |
|
---|
| 119 | "BLD",8495,"KRN","B",19.1,19.1)
|
---|
| 120 |
|
---|
| 121 | "BLD",8495,"KRN","B",101,101)
|
---|
| 122 |
|
---|
| 123 | "BLD",8495,"KRN","B",409.61,409.61)
|
---|
| 124 |
|
---|
| 125 | "BLD",8495,"KRN","B",771,771)
|
---|
| 126 |
|
---|
| 127 | "BLD",8495,"KRN","B",779.2,779.2)
|
---|
| 128 |
|
---|
| 129 | "BLD",8495,"KRN","B",870,870)
|
---|
| 130 |
|
---|
| 131 | "BLD",8495,"KRN","B",8989.51,8989.51)
|
---|
| 132 |
|
---|
| 133 | "BLD",8495,"KRN","B",8989.52,8989.52)
|
---|
| 134 |
|
---|
| 135 | "BLD",8495,"KRN","B",8994,8994)
|
---|
| 136 |
|
---|
| 137 | "BLD",8495,"QDEF")
|
---|
| 138 | ^^^^NO^^^^NO^^NO
|
---|
| 139 | "BLD",8495,"QUES",0)
|
---|
| 140 | ^9.62^^
|
---|
| 141 | "BLD",8495,"REQB",0)
|
---|
| 142 | ^9.611^^
|
---|
| 143 | "KRN",8994,2596,-1)
|
---|
| 144 | 0^10
|
---|
| 145 | "KRN",8994,2596,0)
|
---|
| 146 | VW REG PATINQ^DEMOG^VWREGIT4^2^P^^^0^1
|
---|
| 147 | "KRN",8994,2596,1,0)
|
---|
| 148 | ^8994.01^1^1^3140313^^
|
---|
| 149 | "KRN",8994,2596,1,1,0)
|
---|
| 150 | Returns all existing demographic (non-clinical) data on a patient
|
---|
| 151 | "KRN",8994,2596,2,0)
|
---|
| 152 | ^8994.02A^1^1
|
---|
| 153 | "KRN",8994,2596,2,1,0)
|
---|
| 154 | IDATA^1^^1^1
|
---|
| 155 | "KRN",8994,2596,2,"B","IDATA",1)
|
---|
| 156 |
|
---|
| 157 | "KRN",8994,2596,2,"PARAMSEQ",1,1)
|
---|
| 158 |
|
---|
| 159 | "MBREQ")
|
---|
| 160 | 0
|
---|
| 161 | "ORD",16,8994)
|
---|
| 162 | 8994;16;1;;;;;;;RPCDEL^XPDIA1
|
---|
| 163 | "ORD",16,8994,0)
|
---|
| 164 | REMOTE PROCEDURE
|
---|
| 165 | "QUES","XPF1",0)
|
---|
| 166 | Y
|
---|
| 167 | "QUES","XPF1","??")
|
---|
| 168 | ^D REP^XPDH
|
---|
| 169 | "QUES","XPF1","A")
|
---|
| 170 | Shall I write over your |FLAG| File
|
---|
| 171 | "QUES","XPF1","B")
|
---|
| 172 | YES
|
---|
| 173 | "QUES","XPF1","M")
|
---|
| 174 | D XPF1^XPDIQ
|
---|
| 175 | "QUES","XPF2",0)
|
---|
| 176 | Y
|
---|
| 177 | "QUES","XPF2","??")
|
---|
| 178 | ^D DTA^XPDH
|
---|
| 179 | "QUES","XPF2","A")
|
---|
| 180 | Want my data |FLAG| yours
|
---|
| 181 | "QUES","XPF2","B")
|
---|
| 182 | YES
|
---|
| 183 | "QUES","XPF2","M")
|
---|
| 184 | D XPF2^XPDIQ
|
---|
| 185 | "QUES","XPI1",0)
|
---|
| 186 | YO
|
---|
| 187 | "QUES","XPI1","??")
|
---|
| 188 | ^D INHIBIT^XPDH
|
---|
| 189 | "QUES","XPI1","A")
|
---|
| 190 | Want KIDS to INHIBIT LOGONs during the install
|
---|
| 191 | "QUES","XPI1","B")
|
---|
| 192 | NO
|
---|
| 193 | "QUES","XPI1","M")
|
---|
| 194 | D XPI1^XPDIQ
|
---|
| 195 | "QUES","XPM1",0)
|
---|
| 196 | PO^VA(200,:EM
|
---|
| 197 | "QUES","XPM1","??")
|
---|
| 198 | ^D MG^XPDH
|
---|
| 199 | "QUES","XPM1","A")
|
---|
| 200 | Enter the Coordinator for Mail Group '|FLAG|'
|
---|
| 201 | "QUES","XPM1","B")
|
---|
| 202 |
|
---|
| 203 | "QUES","XPM1","M")
|
---|
| 204 | D XPM1^XPDIQ
|
---|
| 205 | "QUES","XPO1",0)
|
---|
| 206 | Y
|
---|
| 207 | "QUES","XPO1","??")
|
---|
| 208 | ^D MENU^XPDH
|
---|
| 209 | "QUES","XPO1","A")
|
---|
| 210 | Want KIDS to Rebuild Menu Trees Upon Completion of Install
|
---|
| 211 | "QUES","XPO1","B")
|
---|
| 212 | NO
|
---|
| 213 | "QUES","XPO1","M")
|
---|
| 214 | D XPO1^XPDIQ
|
---|
| 215 | "QUES","XPZ1",0)
|
---|
| 216 | Y
|
---|
| 217 | "QUES","XPZ1","??")
|
---|
| 218 | ^D OPT^XPDH
|
---|
| 219 | "QUES","XPZ1","A")
|
---|
| 220 | Want to DISABLE Scheduled Options, Menu Options, and Protocols
|
---|
| 221 | "QUES","XPZ1","B")
|
---|
| 222 | NO
|
---|
| 223 | "QUES","XPZ1","M")
|
---|
| 224 | D XPZ1^XPDIQ
|
---|
| 225 | "QUES","XPZ2",0)
|
---|
| 226 | Y
|
---|
| 227 | "QUES","XPZ2","??")
|
---|
| 228 | ^D RTN^XPDH
|
---|
| 229 | "QUES","XPZ2","A")
|
---|
| 230 | Want to MOVE routines to other CPUs
|
---|
| 231 | "QUES","XPZ2","B")
|
---|
| 232 | NO
|
---|
| 233 | "QUES","XPZ2","M")
|
---|
| 234 | D XPZ2^XPDIQ
|
---|
| 235 | "RTN")
|
---|
| 236 | 4
|
---|
| 237 | "RTN","VWREGIT")
|
---|
| 238 | 0^8^B129809193
|
---|
| 239 | "RTN","VWREGIT",1,0)
|
---|
| 240 | VWREGIT ;VWEHR/BFProd - Jim Bell, et al... - World VistA Patient Registration Utility
|
---|
| 241 | "RTN","VWREGIT",2,0)
|
---|
| 242 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
| 243 | "RTN","VWREGIT",3,0)
|
---|
| 244 | ;
|
---|
| 245 | "RTN","VWREGIT",4,0)
|
---|
| 246 | ;This routine utility is for Patient specific fields and
|
---|
| 247 | "RTN","VWREGIT",5,0)
|
---|
| 248 | ; calls a Fileman input template.
|
---|
| 249 | "RTN","VWREGIT",6,0)
|
---|
| 250 | ;
|
---|
| 251 | "RTN","VWREGIT",7,0)
|
---|
| 252 | ;GNU License: See WVLIC.txt
|
---|
| 253 | "RTN","VWREGIT",8,0)
|
---|
| 254 | ;Modified FOIA VISTA,
|
---|
| 255 | "RTN","VWREGIT",9,0)
|
---|
| 256 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
| 257 | "RTN","VWREGIT",10,0)
|
---|
| 258 | Q
|
---|
| 259 | "RTN","VWREGIT",11,0)
|
---|
| 260 | ;
|
---|
| 261 | "RTN","VWREGIT",12,0)
|
---|
| 262 | ;S IDSTR="REG(1733)^^L^^"
|
---|
| 263 | "RTN","VWREGIT",13,0)
|
---|
| 264 | ;
|
---|
| 265 | "RTN","VWREGIT",14,0)
|
---|
| 266 | MV(PAT,SUBD,FLDS) ;Get the listing of multiple values in external format
|
---|
| 267 | "RTN","VWREGIT",15,0)
|
---|
| 268 | S VAL=""
|
---|
| 269 | "RTN","VWREGIT",16,0)
|
---|
| 270 | Q
|
---|
| 271 | "RTN","VWREGIT",17,0)
|
---|
| 272 | ;
|
---|
| 273 | "RTN","VWREGIT",18,0)
|
---|
| 274 | GDOBT(PATIENT) ;Get date of birth with time
|
---|
| 275 | "RTN","VWREGIT",19,0)
|
---|
| 276 | N DOB,Y
|
---|
| 277 | "RTN","VWREGIT",20,0)
|
---|
| 278 | S Y=$P(^DPT(PATIENT,0),"^",3)+$G(^DPT(PATIENT,540000))
|
---|
| 279 | "RTN","VWREGIT",21,0)
|
---|
| 280 | X ^DD("DD")
|
---|
| 281 | "RTN","VWREGIT",22,0)
|
---|
| 282 | Q Y
|
---|
| 283 | "RTN","VWREGIT",23,0)
|
---|
| 284 | ;
|
---|
| 285 | "RTN","VWREGIT",24,0)
|
---|
| 286 | MM ;Mis-match IDs belong to someone other than client input
|
---|
| 287 | "RTN","VWREGIT",25,0)
|
---|
| 288 | S RESULT(0)="MM^-1"
|
---|
| 289 | "RTN","VWREGIT",26,0)
|
---|
| 290 | S RESULT(1)="ID belongs to "_ARR("DILIST",1,1)
|
---|
| 291 | "RTN","VWREGIT",27,0)
|
---|
| 292 | Q
|
---|
| 293 | "RTN","VWREGIT",28,0)
|
---|
| 294 | ;
|
---|
| 295 | "RTN","VWREGIT",29,0)
|
---|
| 296 | FIELDS ;Get field numbers/labels/titles at ^DIE(TNUM...
|
---|
| 297 | "RTN","VWREGIT",30,0)
|
---|
| 298 | K XR
|
---|
| 299 | "RTN","VWREGIT",31,0)
|
---|
| 300 | S RESULT($$INR)="[FLDS]"
|
---|
| 301 | "RTN","VWREGIT",32,0)
|
---|
| 302 | S FSET=$G(^DIE(TNUM,"DR",1,2))
|
---|
| 303 | "RTN","VWREGIT",33,0)
|
---|
| 304 | S C=0 ;Keep order of template
|
---|
| 305 | "RTN","VWREGIT",34,0)
|
---|
| 306 | F I=1:1:$L(FSET,";")-1 D
|
---|
| 307 | "RTN","VWREGIT",35,0)
|
---|
| 308 | . S MF=+$P(^DD(XFILE,+$P(FSET,";",I),0),"^",2)
|
---|
| 309 | "RTN","VWREGIT",36,0)
|
---|
| 310 | . D:MF
|
---|
| 311 | "RTN","VWREGIT",37,0)
|
---|
| 312 | .. S MFS=$G(^DIE(TNUM,"DR",2,MF))
|
---|
| 313 | "RTN","VWREGIT",38,0)
|
---|
| 314 | .. I $L(MFS) F J=1:1:$L(MFS,";")-1 D
|
---|
| 315 | "RTN","VWREGIT",39,0)
|
---|
| 316 | ... S C=C+1
|
---|
| 317 | "RTN","VWREGIT",40,0)
|
---|
| 318 | ... S XR(C,MF,+$P(MFS,";",J))=$P(^DD(MF,+$P(MFS,";",J),0),"^")_"^"_MF_";"_+$P(MFS,";",J)_"^^^"
|
---|
| 319 | "RTN","VWREGIT",41,0)
|
---|
| 320 | ... I $P(^DD(MF,+$P(MFS,";",J),0),"^",2)["P" S $P(XR(C,MF,+$P(MFS,";",J)),"^",5)=$P(^DD(MF,+$P(MFS,";",J),0),"^",3)
|
---|
| 321 | "RTN","VWREGIT",42,0)
|
---|
| 322 | . Q:MF
|
---|
| 323 | "RTN","VWREGIT",43,0)
|
---|
| 324 | . S C=C+1,XR(C,+$P(FSET,";",I))=$P(^DD(XFILE,+$P(FSET,";",I),0),"^")_"^"_+$P(FSET,";",I)_"^^"_$$HINT(XFILE,+$P(FSET,";",I))_"^"_$P(^DD(XFILE,+$P(FSET,";",I),0),"^",3)
|
---|
| 325 | "RTN","VWREGIT",44,0)
|
---|
| 326 | S X="XR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
| 327 | "RTN","VWREGIT",45,0)
|
---|
| 328 | ;For county help listing until DB is fixed /jeb 9/15/2013 @ 08:43
|
---|
| 329 | "RTN","VWREGIT",46,0)
|
---|
| 330 | S N=0 F S N=$O(RESULT(N)) Q:'+N I $P(RESULT(N),"^",2)=.117 S $P(RESULT(N),"^",5)="VIC(5.1,"
|
---|
| 331 | "RTN","VWREGIT",47,0)
|
---|
| 332 | K XR
|
---|
| 333 | "RTN","VWREGIT",48,0)
|
---|
| 334 | S DIET=TNUM D GET^DIETED("AR"),PREFLAB^VWREGIT3
|
---|
| 335 | "RTN","VWREGIT",49,0)
|
---|
| 336 | Q
|
---|
| 337 | "RTN","VWREGIT",50,0)
|
---|
| 338 | ;
|
---|
| 339 | "RTN","VWREGIT",51,0)
|
---|
| 340 | GETTD(RESULT,XDESC) ;Get template description
|
---|
| 341 | "RTN","VWREGIT",52,0)
|
---|
| 342 | K RESULT
|
---|
| 343 | "RTN","VWREGIT",53,0)
|
---|
| 344 | N N,TNUM
|
---|
| 345 | "RTN","VWREGIT",54,0)
|
---|
| 346 | S TNUM=+$P(XDESC,"(",2)
|
---|
| 347 | "RTN","VWREGIT",55,0)
|
---|
| 348 | I '$O(^DIE(TNUM,"%D",0)) S RESULT(0)="No description on file" Q
|
---|
| 349 | "RTN","VWREGIT",56,0)
|
---|
| 350 | S N=0 F S N=$O(^DIE(TNUM,"%D",N)) Q:'+N S RESULT($$INR)=^(N,0)
|
---|
| 351 | "RTN","VWREGIT",57,0)
|
---|
| 352 | Q
|
---|
| 353 | "RTN","VWREGIT",58,0)
|
---|
| 354 | ;
|
---|
| 355 | "RTN","VWREGIT",59,0)
|
---|
| 356 | ME(X) ;mail to group
|
---|
| 357 | "RTN","VWREGIT",60,0)
|
---|
| 358 | S GROUP=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
|
---|
| 359 | "RTN","VWREGIT",61,0)
|
---|
| 360 | S TITLE=X
|
---|
| 361 | "RTN","VWREGIT",62,0)
|
---|
| 362 | S INFO=1
|
---|
| 363 | "RTN","VWREGIT",63,0)
|
---|
| 364 | S FM=DUZ
|
---|
| 365 | "RTN","VWREGIT",64,0)
|
---|
| 366 | D MSG^BFPMAIL
|
---|
| 367 | "RTN","VWREGIT",65,0)
|
---|
| 368 | Q
|
---|
| 369 | "RTN","VWREGIT",66,0)
|
---|
| 370 | ;
|
---|
| 371 | "RTN","VWREGIT",67,0)
|
---|
| 372 | COUNTY ;Special listing for county (re: Saturday 9/14/2013 WV discussion)
|
---|
| 373 | "RTN","VWREGIT",68,0)
|
---|
| 374 | K RESULT,XR
|
---|
| 375 | "RTN","VWREGIT",69,0)
|
---|
| 376 | S RESULT(0)=0
|
---|
| 377 | "RTN","VWREGIT",70,0)
|
---|
| 378 | S PFILE="^"_PFILE
|
---|
| 379 | "RTN","VWREGIT",71,0)
|
---|
| 380 | S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S X=^(N,0) D
|
---|
| 381 | "RTN","VWREGIT",72,0)
|
---|
| 382 | . S STATE=$P(X,"^",2)
|
---|
| 383 | "RTN","VWREGIT",73,0)
|
---|
| 384 | . S COUNTY=$P(X,"^")
|
---|
| 385 | "RTN","VWREGIT",74,0)
|
---|
| 386 | . S STATE=$P($G(^DIC(5,STATE,0)),"^")
|
---|
| 387 | "RTN","VWREGIT",75,0)
|
---|
| 388 | . S STATE=$S(STATE="":"UNKNOWN",1:STATE)
|
---|
| 389 | "RTN","VWREGIT",76,0)
|
---|
| 390 | . S XR(STATE,COUNTY)=COUNTY_"~"_STATE
|
---|
| 391 | "RTN","VWREGIT",77,0)
|
---|
| 392 | S X="XR" F S X=$Q(@X) Q:X="" S Y=@X,RESULT($$INR)=Y
|
---|
| 393 | "RTN","VWREGIT",78,0)
|
---|
| 394 | S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
|
---|
| 395 | "RTN","VWREGIT",79,0)
|
---|
| 396 | K XR
|
---|
| 397 | "RTN","VWREGIT",80,0)
|
---|
| 398 | Q
|
---|
| 399 | "RTN","VWREGIT",81,0)
|
---|
| 400 | ;
|
---|
| 401 | "RTN","VWREGIT",82,0)
|
---|
| 402 | PSF(RESULT,XLINE) ;Pointer/Set of Codes values
|
---|
| 403 | "RTN","VWREGIT",83,0)
|
---|
| 404 | ;W " ;Intentionally "instantiated" hard failure - jeb
|
---|
| 405 | "RTN","VWREGIT",84,0)
|
---|
| 406 | K RESULT
|
---|
| 407 | "RTN","VWREGIT",85,0)
|
---|
| 408 | N XFILE,XFIELD,XDATA,XIT,PFILE
|
---|
| 409 | "RTN","VWREGIT",86,0)
|
---|
| 410 | S RESULT(0)=0
|
---|
| 411 | "RTN","VWREGIT",87,0)
|
---|
| 412 | S DFN=$P(XLINE,"^",7)
|
---|
| 413 | "RTN","VWREGIT",88,0)
|
---|
| 414 | S PFILE=$P(XLINE,"^",6) ;POINTED TO FILE
|
---|
| 415 | "RTN","VWREGIT",89,0)
|
---|
| 416 | I PFILE="VIC(5.1," D COUNTY Q ;Work around until DB is fixed /jeb 9/15/2013
|
---|
| 417 | "RTN","VWREGIT",90,0)
|
---|
| 418 | S XIT=+$P(XLINE,"(",2) Q:'XIT
|
---|
| 419 | "RTN","VWREGIT",91,0)
|
---|
| 420 | S XFILE=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";"),1:$P(^DIE(XIT,0),"^",4))
|
---|
| 421 | "RTN","VWREGIT",92,0)
|
---|
| 422 | S XFIELD=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";",2),1:$P(XLINE,"^",3))
|
---|
| 423 | "RTN","VWREGIT",93,0)
|
---|
| 424 | S XFIELD=$S($L(XFIELD):XFIELD,1:+$P(XLINE,"^",3)) Q:'XFIELD
|
---|
| 425 | "RTN","VWREGIT",94,0)
|
---|
| 426 | Q:$P(^DD(XFILE,XFIELD,0),"^",2)'["S"&($P(^DD(XFILE,XFIELD,0),"^",2)'["P")
|
---|
| 427 | "RTN","VWREGIT",95,0)
|
---|
| 428 | I $P(^DD(XFILE,XFIELD,0),"^",2)["S" D S RESULT(0)=$O(RESULT(" "),-1) Q
|
---|
| 429 | "RTN","VWREGIT",96,0)
|
---|
| 430 | . S XDATA=$P(^(0),"^",3)
|
---|
| 431 | "RTN","VWREGIT",97,0)
|
---|
| 432 | . S XDATA=$E(XDATA,1,$L(XDATA)-1)
|
---|
| 433 | "RTN","VWREGIT",98,0)
|
---|
| 434 | . F I=1:1:$L(XDATA,";") S RESULT($$INR)=$P($P(XDATA,";",I),":",2)
|
---|
| 435 | "RTN","VWREGIT",99,0)
|
---|
| 436 | Q:'$L(PFILE) ;No pointer to reference
|
---|
| 437 | "RTN","VWREGIT",100,0)
|
---|
| 438 | S PFILE="^"_PFILE
|
---|
| 439 | "RTN","VWREGIT",101,0)
|
---|
| 440 | S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S RESULT($$INR)=$S(PFILE[779.004:$P(^(N,0),"^")_"~"_$P(^(0),"^",2),1:$P(^(N,0),"^"))
|
---|
| 441 | "RTN","VWREGIT",102,0)
|
---|
| 442 | S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
|
---|
| 443 | "RTN","VWREGIT",103,0)
|
---|
| 444 | Q
|
---|
| 445 | "RTN","VWREGIT",104,0)
|
---|
| 446 | ;
|
---|
| 447 | "RTN","VWREGIT",105,0)
|
---|
| 448 | HINT(FILE,FLD) ;
|
---|
| 449 | "RTN","VWREGIT",106,0)
|
---|
| 450 | N X,N,Y
|
---|
| 451 | "RTN","VWREGIT",107,0)
|
---|
| 452 | Q:'$L(FLD) ;...hmmmm...
|
---|
| 453 | "RTN","VWREGIT",108,0)
|
---|
| 454 | S X="",N=0 F S N=$O(^DD(FILE,FLD,21,N)) Q:'+N D
|
---|
| 455 | "RTN","VWREGIT",109,0)
|
---|
| 456 | . S Y=$G(^DD(FILE,FLD,21,N,0))_$S($O(^DD(FILE,FLD,21,N)):" ",1:"")
|
---|
| 457 | "RTN","VWREGIT",110,0)
|
---|
| 458 | . S X=X_$TR(Y,"'","")
|
---|
| 459 | "RTN","VWREGIT",111,0)
|
---|
| 460 | I X="" S X="<No hint for this field. Press the ? at the top of the form for full demographic data>"
|
---|
| 461 | "RTN","VWREGIT",112,0)
|
---|
| 462 | Q X
|
---|
| 463 | "RTN","VWREGIT",113,0)
|
---|
| 464 | ;
|
---|
| 465 | "RTN","VWREGIT",114,0)
|
---|
| 466 | GETMULTS(MN) ;
|
---|
| 467 | "RTN","VWREGIT",115,0)
|
---|
| 468 | Q:'MN
|
---|
| 469 | "RTN","VWREGIT",116,0)
|
---|
| 470 | F I=1:1:$L(FSETM(MN),";")-1 D
|
---|
| 471 | "RTN","VWREGIT",117,0)
|
---|
| 472 | . S MNF=$P(FSETM(MN),";",I)
|
---|
| 473 | "RTN","VWREGIT",118,0)
|
---|
| 474 | . S RESULT($$INR)=$P(^DD(MN,MNF,0),"^")_"^"_MN_";"_MNF
|
---|
| 475 | "RTN","VWREGIT",119,0)
|
---|
| 476 | Q
|
---|
| 477 | "RTN","VWREGIT",120,0)
|
---|
| 478 | ;
|
---|
| 479 | "RTN","VWREGIT",121,0)
|
---|
| 480 | VPAR(SUBD) ;
|
---|
| 481 | "RTN","VWREGIT",122,0)
|
---|
| 482 | N X
|
---|
| 483 | "RTN","VWREGIT",123,0)
|
---|
| 484 | S X=""
|
---|
| 485 | "RTN","VWREGIT",124,0)
|
---|
| 486 | I $D(PAR(SUBD)) S X=@$Q(PAR(SUBD))
|
---|
| 487 | "RTN","VWREGIT",125,0)
|
---|
| 488 | Q X
|
---|
| 489 | "RTN","VWREGIT",126,0)
|
---|
| 490 | ;
|
---|
| 491 | "RTN","VWREGIT",127,0)
|
---|
| 492 | INC(C) Q C=C+1
|
---|
| 493 | "RTN","VWREGIT",128,0)
|
---|
| 494 | ;
|
---|
| 495 | "RTN","VWREGIT",129,0)
|
---|
| 496 | INR() Q $O(RESULT(" "),-1)+1
|
---|
| 497 | "RTN","VWREGIT",130,0)
|
---|
| 498 | ;
|
---|
| 499 | "RTN","VWREGIT",131,0)
|
---|
| 500 | CLNNUM(NUM) ;Clean NUM
|
---|
| 501 | "RTN","VWREGIT",132,0)
|
---|
| 502 | Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
|
---|
| 503 | "RTN","VWREGIT",133,0)
|
---|
| 504 | ;
|
---|
| 505 | "RTN","VWREGIT",134,0)
|
---|
| 506 | ALABEL(FL,FI) ;
|
---|
| 507 | "RTN","VWREGIT",135,0)
|
---|
| 508 | Q $S($D(^DIE(TNUM,"DIAB",FL,0,FI,0)):$TR($P(^(0),";",2),"""",""),1:$P(^DD(FI,$P(FSET,";",FL),0),"^"))
|
---|
| 509 | "RTN","VWREGIT",136,0)
|
---|
| 510 | ;
|
---|
| 511 | "RTN","VWREGIT",137,0)
|
---|
| 512 | SETMULTS ;
|
---|
| 513 | "RTN","VWREGIT",138,0)
|
---|
| 514 | K FSETM
|
---|
| 515 | "RTN","VWREGIT",139,0)
|
---|
| 516 | S FSET=$g(^DIE(TNUM,"DR",1,2))
|
---|
| 517 | "RTN","VWREGIT",140,0)
|
---|
| 518 | Q:FSET=""
|
---|
| 519 | "RTN","VWREGIT",141,0)
|
---|
| 520 | ;S N=1 F S N=$O(^DIE(TNUM,"DR",N)) Q:'+N S N1=0 F S N1=$O(^DIE(TNUM,"DR",N,N1)) Q:'+N1 S FSETM(N1)=$E(^(N1),1,$L(^(N1))-1)
|
---|
| 521 | "RTN","VWREGIT",142,0)
|
---|
| 522 | S N=0 F S N=$O(^DIE(TNUM,"DR",2,N)) Q:'+N S X=^(N) S:$E(X,$L(X))=";" X=$E(X,1,$L(X)-1) S FSETM(N)=X
|
---|
| 523 | "RTN","VWREGIT",143,0)
|
---|
| 524 | ;S FSET=$E(FSET,1,$L(FSET)-1)
|
---|
| 525 | "RTN","VWREGIT",144,0)
|
---|
| 526 | F I=1:1:$L(FSET,";") S XF=$P(FSET,";",I) D
|
---|
| 527 | "RTN","VWREGIT",145,0)
|
---|
| 528 | . S FSETNUM(+XF)=$P(^DD(XFILE,+XF,0),"^")_"^"_$TR($P($G(^DIE(TNUM,"DIAB",I,0,XFILE,0)),";",2),"""","")
|
---|
| 529 | "RTN","VWREGIT",146,0)
|
---|
| 530 | . I +$P(^DD(2,+XF,0),"^",2) S $P(FSETNUM(+XF),"^",2)=+$P(^(0),"^",2)
|
---|
| 531 | "RTN","VWREGIT",147,0)
|
---|
| 532 | S N=0 F S N=$O(FSETNUM(N)) Q:'+N S FSETMAT($P(FSETNUM(N),"^"))=""
|
---|
| 533 | "RTN","VWREGIT",148,0)
|
---|
| 534 | S N=0 F S N=$O(FSETM(N)) Q:'+N S FSTRING=FSETM(N) D
|
---|
| 535 | "RTN","VWREGIT",149,0)
|
---|
| 536 | . F I=1:1:$L(FSTRING,";") S MF=$P(FSTRING,";",I),FSETMM(N,$P(^DD(N,MF,0),"^"))=""
|
---|
| 537 | "RTN","VWREGIT",150,0)
|
---|
| 538 | Q
|
---|
| 539 | "RTN","VWREGIT",151,0)
|
---|
| 540 | ;
|
---|
| 541 | "RTN","VWREGIT",152,0)
|
---|
| 542 | PID(DFN,TID,XID) ;Patient ID
|
---|
| 543 | "RTN","VWREGIT",153,0)
|
---|
| 544 | N C,XHRN
|
---|
| 545 | "RTN","VWREGIT",154,0)
|
---|
| 546 | K PAR
|
---|
| 547 | "RTN","VWREGIT",155,0)
|
---|
| 548 | D FIND^DIC(XFILE,"",".01;.02;.03;.09;.363;391","CM",$S($G(DFN):"`"_DFN,1:$G(XID)),"","B^AVWPID^SSN","","","ARR","LUERR")
|
---|
| 549 | "RTN","VWREGIT",156,0)
|
---|
| 550 | I '$O(ARR("DILIST",0)) S RESULT(1)="-1^NEW" Q
|
---|
| 551 | "RTN","VWREGIT",157,0)
|
---|
| 552 | PIDS I '$O(ARR("DILIST",2,1)) D Q
|
---|
| 553 | "RTN","VWREGIT",158,0)
|
---|
| 554 | . S:'DFN DFN=$G(ARR("DILIST",2,1)) D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
| 555 | "RTN","VWREGIT",159,0)
|
---|
| 556 | . S NAME=$G(ARR("DILIST",1,1))
|
---|
| 557 | "RTN","VWREGIT",160,0)
|
---|
| 558 | . S XSSN=$G(ARR("DILIST","ID",1,.09)) D:'$L(XSSN)
|
---|
| 559 | "RTN","VWREGIT",161,0)
|
---|
| 560 | .. S DA=DFN
|
---|
| 561 | "RTN","VWREGIT",162,0)
|
---|
| 562 | .. D PSEU^DGRPDD1
|
---|
| 563 | "RTN","VWREGIT",163,0)
|
---|
| 564 | .. S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""
|
---|
| 565 | "RTN","VWREGIT",164,0)
|
---|
| 566 | . ;S DOB=$G(ARR("DILIST","ID",1,.03))
|
---|
| 567 | "RTN","VWREGIT",165,0)
|
---|
| 568 | . S DOB=$$GDOBT(DFN)
|
---|
| 569 | "RTN","VWREGIT",166,0)
|
---|
| 570 | . S SEX=$E($G(ARR("DILIST","ID",1,.02)))
|
---|
| 571 | "RTN","VWREGIT",167,0)
|
---|
| 572 | . S XID=$G(ARR("DILIST","ID",1,.363))
|
---|
| 573 | "RTN","VWREGIT",168,0)
|
---|
| 574 | . I '$L($G(XHRN)),TID="HRN" S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
|
---|
| 575 | "RTN","VWREGIT",169,0)
|
---|
| 576 | . ;D GETS^DIQ(XFILE,DFN_",",FSET,"NIER","PAR","ERR") ;unused code
|
---|
| 577 | "RTN","VWREGIT",170,0)
|
---|
| 578 | . ;Note: "**" used to gain all fields in multiples in the file - shotgun technique .vs focused/jeb 2013
|
---|
| 579 | "RTN","VWREGIT",171,0)
|
---|
| 580 | . D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
|
---|
| 581 | "RTN","VWREGIT",172,0)
|
---|
| 582 | . D:$D(PAR(2,DFN_",","COUNTY","I"))
|
---|
| 583 | "RTN","VWREGIT",173,0)
|
---|
| 584 | .. S COUNTY=$G(PAR(2,DFN_",","COUNTY","I")),STATE=$G(PAR(2,DFN_",","STATE","I"))
|
---|
| 585 | "RTN","VWREGIT",174,0)
|
---|
| 586 | .. I STATE S PAR(2,DFN_",","COUNTY","E")=$P(^DIC(5,STATE,1,COUNTY,0),"^")
|
---|
| 587 | "RTN","VWREGIT",175,0)
|
---|
| 588 | . S RESULT($$INR)=DFN_"^"_XID_"^"_$P(NAME,",",2)_"^"_$P(NAME,",")_"^"_DOB_"^"_$E(SEX)_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
|
---|
| 589 | "RTN","VWREGIT",176,0)
|
---|
| 590 | . D FIELDS
|
---|
| 591 | "RTN","VWREGIT",177,0)
|
---|
| 592 | . S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
|
---|
| 593 | "RTN","VWREGIT",178,0)
|
---|
| 594 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
| 595 | "RTN","VWREGIT",179,0)
|
---|
| 596 | .. S F=$P(RESULT(N),"^")
|
---|
| 597 | "RTN","VWREGIT",180,0)
|
---|
| 598 | .. S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
|
---|
| 599 | "RTN","VWREGIT",181,0)
|
---|
| 600 | .. S $P(RESULT(N),"^",3)=FDATA
|
---|
| 601 | "RTN","VWREGIT",182,0)
|
---|
| 602 | .. S $P(RESULT(N),"^",4)=$$HINT(XFILE,$P(RESULT(N),"^",2))
|
---|
| 603 | "RTN","VWREGIT",183,0)
|
---|
| 604 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N)
|
---|
| 605 | "RTN","VWREGIT",184,0)
|
---|
| 606 | .. S SN=+RESULT(N) Q:'$D(FSETM(SN))
|
---|
| 607 | "RTN","VWREGIT",185,0)
|
---|
| 608 | .. S SNFLDS=FSETM(SN)
|
---|
| 609 | "RTN","VWREGIT",186,0)
|
---|
| 610 | .. S IX=.1
|
---|
| 611 | "RTN","VWREGIT",187,0)
|
---|
| 612 | .. F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR(SN)_"^^",IX=IX+.1
|
---|
| 613 | "RTN","VWREGIT",188,0)
|
---|
| 614 | . S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N)
|
---|
| 615 | "RTN","VWREGIT",189,0)
|
---|
| 616 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
| 617 | "RTN","VWREGIT",190,0)
|
---|
| 618 | .. I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
|
---|
| 619 | "RTN","VWREGIT",191,0)
|
---|
| 620 | .. I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)=$$MV(DFN,$P($P(RESULT(N),"^",2),";"),$G(^DIE(TNUM,"DR",2,$P($P(RESULT(N),"^",2),";"))
|
---|
| 621 | "RTN","VWREGIT",192,0)
|
---|
| 622 | . S MATCH=1,$P(RESULT(0),"^",2)=1
|
---|
| 623 | "RTN","VWREGIT",193,0)
|
---|
| 624 | ;Below - list of possibles found
|
---|
| 625 | "RTN","VWREGIT",194,0)
|
---|
| 626 | PIDM S (C,N)=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N D
|
---|
| 627 | "RTN","VWREGIT",195,0)
|
---|
| 628 | . S DFN=ARR("DILIST",2,N),C=C+1
|
---|
| 629 | "RTN","VWREGIT",196,0)
|
---|
| 630 | . S XID=$P($G(^DPT(DFN,.36)),"^",3)
|
---|
| 631 | "RTN","VWREGIT",197,0)
|
---|
| 632 | . S XSSN=ARR("DILIST","ID",N,.09)
|
---|
| 633 | "RTN","VWREGIT",198,0)
|
---|
| 634 | . S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
|
---|
| 635 | "RTN","VWREGIT",199,0)
|
---|
| 636 | . S XNAME=ARR("DILIST",1,N)
|
---|
| 637 | "RTN","VWREGIT",200,0)
|
---|
| 638 | . S XDOB=ARR("DILIST","ID",N,.03)
|
---|
| 639 | "RTN","VWREGIT",201,0)
|
---|
| 640 | . S XID=$S($L(XID):XID,$L(XSSN):XSSN,1:"")
|
---|
| 641 | "RTN","VWREGIT",202,0)
|
---|
| 642 | . S RESULT($$INR)=$S($L(XID):XID,1:$L(XHRN),1:"")_"~"_XNAME_"~"_XDOB_"~"_$P(^DPT(DFN,0),"^",2)_"~"_DFN
|
---|
| 643 | "RTN","VWREGIT",203,0)
|
---|
| 644 | . S $P(RESULT(0),"^",2)=C
|
---|
| 645 | "RTN","VWREGIT",204,0)
|
---|
| 646 | Q
|
---|
| 647 | "RTN","VWREGIT",205,0)
|
---|
| 648 | ;
|
---|
| 649 | "RTN","VWREGIT",206,0)
|
---|
| 650 | EN(RESULT) ;Template name and ID labels
|
---|
| 651 | "RTN","VWREGIT",207,0)
|
---|
| 652 | ;Parse stuff into Fileman-ese
|
---|
| 653 | "RTN","VWREGIT",208,0)
|
---|
| 654 | ;Testing - D EN^VWREGIT(.RESULT,"REG(1767)^^LEMON^^")
|
---|
| 655 | "RTN","VWREGIT",209,0)
|
---|
| 656 | ;;M ^TMP("IDSTR",1)=IDSTR
|
---|
| 657 | "RTN","VWREGIT",210,0)
|
---|
| 658 | ;;S RESULT(0)="[ID]"
|
---|
| 659 | "RTN","VWREGIT",211,0)
|
---|
| 660 | ;;S RESULT(1)="-1^NEW"
|
---|
| 661 | "RTN","VWREGIT",212,0)
|
---|
| 662 | ;;Q
|
---|
| 663 | "RTN","VWREGIT",213,0)
|
---|
| 664 | ;end testing
|
---|
| 665 | "RTN","VWREGIT",214,0)
|
---|
| 666 | ;
|
---|
| 667 | "RTN","VWREGIT",215,0)
|
---|
| 668 | ;Get the input template list
|
---|
| 669 | "RTN","VWREGIT",216,0)
|
---|
| 670 | ;housekeeping
|
---|
| 671 | "RTN","VWREGIT",217,0)
|
---|
| 672 | S DTIME=99999
|
---|
| 673 | "RTN","VWREGIT",218,0)
|
---|
| 674 | ;end housekeeping
|
---|
| 675 | "RTN","VWREGIT",219,0)
|
---|
| 676 | ;
|
---|
| 677 | "RTN","VWREGIT",220,0)
|
---|
| 678 | K AR,RESULT
|
---|
| 679 | "RTN","VWREGIT",221,0)
|
---|
| 680 | N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO
|
---|
| 681 | "RTN","VWREGIT",222,0)
|
---|
| 682 | S RESULT(0)=$$CONTROL^VWREGIT2()
|
---|
| 683 | "RTN","VWREGIT",223,0)
|
---|
| 684 | S RESULT(1)="-1^No templates found"
|
---|
| 685 | "RTN","VWREGIT",224,0)
|
---|
| 686 | S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
| 687 | "RTN","VWREGIT",225,0)
|
---|
| 688 | S FILE="regit.txt"
|
---|
| 689 | "RTN","VWREGIT",226,0)
|
---|
| 690 | S P4=1
|
---|
| 691 | "RTN","VWREGIT",227,0)
|
---|
| 692 | S P5=""
|
---|
| 693 | "RTN","VWREGIT",228,0)
|
---|
| 694 | S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
|
---|
| 695 | "RTN","VWREGIT",229,0)
|
---|
| 696 | I 'X K T,TITLE D Q ;Error report - home dir not found
|
---|
| 697 | "RTN","VWREGIT",230,0)
|
---|
| 698 | . S TITLE=$P(RESULT(1),"^")
|
---|
| 699 | "RTN","VWREGIT",231,0)
|
---|
| 700 | . S T(1)="The home directory could not be located."
|
---|
| 701 | "RTN","VWREGIT",232,0)
|
---|
| 702 | . S T(2)="End of data error message"
|
---|
| 703 | "RTN","VWREGIT",233,0)
|
---|
| 704 | . D ME(X)
|
---|
| 705 | "RTN","VWREGIT",234,0)
|
---|
| 706 | . K T,X
|
---|
| 707 | "RTN","VWREGIT",235,0)
|
---|
| 708 | S:+RESULT(0) $P(RESULT(0),"^",2)=HD
|
---|
| 709 | "RTN","VWREGIT",236,0)
|
---|
| 710 | I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
|
---|
| 711 | "RTN","VWREGIT",237,0)
|
---|
| 712 | S N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
| 713 | "RTN","VWREGIT",238,0)
|
---|
| 714 | . Q:$E(AR(N))="*"
|
---|
| 715 | "RTN","VWREGIT",239,0)
|
---|
| 716 | . Q:'+$P(AR(N),"(",2)
|
---|
| 717 | "RTN","VWREGIT",240,0)
|
---|
| 718 | . Q:$P(^DIE(+$P(AR(N),"(",2),0),"^",4)'=2 ;must be pat file
|
---|
| 719 | "RTN","VWREGIT",241,0)
|
---|
| 720 | . S RESULT($$INR)=AR(N)
|
---|
| 721 | "RTN","VWREGIT",242,0)
|
---|
| 722 | S RESULT($$INR)="[ID]"
|
---|
| 723 | "RTN","VWREGIT",243,0)
|
---|
| 724 | S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N)
|
---|
| 725 | "RTN","VWREGIT",244,0)
|
---|
| 726 | I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
|
---|
| 727 | "RTN","VWREGIT",245,0)
|
---|
| 728 | K AR
|
---|
| 729 | "RTN","VWREGIT",246,0)
|
---|
| 730 | Q
|
---|
| 731 | "RTN","VWREGIT",247,0)
|
---|
| 732 | ;
|
---|
| 733 | "RTN","VWREGIT",248,0)
|
---|
| 734 | PAT(RESULT,IDSTR) ;
|
---|
| 735 | "RTN","VWREGIT",249,0)
|
---|
| 736 | ; **********************************************************
|
---|
| 737 | "RTN","VWREGIT",250,0)
|
---|
| 738 | ; *IDSTR____Template(IEN)^ID/HRN/SSN:ID#^NAME^DOB^GENDER *
|
---|
| 739 | "RTN","VWREGIT",251,0)
|
---|
| 740 | ; * ^NEW<-EMPTY IF NOT NEW PT *
|
---|
| 741 | "RTN","VWREGIT",252,0)
|
---|
| 742 | ; *Action___Execute patient look up first with HRN/ID, *
|
---|
| 743 | "RTN","VWREGIT",253,0)
|
---|
| 744 | ; * then NAME; DOB is confirming ID if found *
|
---|
| 745 | "RTN","VWREGIT",254,0)
|
---|
| 746 | ; * If not found RESULT(0)="-1^NEW" *
|
---|
| 747 | "RTN","VWREGIT",255,0)
|
---|
| 748 | ; **********************************************************
|
---|
| 749 | "RTN","VWREGIT",256,0)
|
---|
| 750 | ;
|
---|
| 751 | "RTN","VWREGIT",257,0)
|
---|
| 752 | N DFN,FN,FSET,J,LABEL,MATCH,N,PID,TNUM,XAID,XDOB,XF,XFILE,XFLD,XHRN,XLABEL,XNAME,XUNM,XUMOV,XUFAM,XUOUT,XUREST,XUSP
|
---|
| 753 | "RTN","VWREGIT",258,0)
|
---|
| 754 | N NAME,XDOB,SEX,FAIL,STR,TID,FAIL,TID,IEN
|
---|
| 755 | "RTN","VWREGIT",259,0)
|
---|
| 756 | K RESULT,PAR,ARR,SPAR,LUERR,ERR
|
---|
| 757 | "RTN","VWREGIT",260,0)
|
---|
| 758 | S RESULT(0)="[ID]^0"
|
---|
| 759 | "RTN","VWREGIT",261,0)
|
---|
| 760 | S TNUM=+$P(IDSTR,"(",2)
|
---|
| 761 | "RTN","VWREGIT",262,0)
|
---|
| 762 | Q:'TNUM ;No template name from client
|
---|
| 763 | "RTN","VWREGIT",263,0)
|
---|
| 764 | I '$D(^DIE(TNUM)) S RESULT(0)="-1^Template not found" G XOUT
|
---|
| 765 | "RTN","VWREGIT",264,0)
|
---|
| 766 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
| 767 | "RTN","VWREGIT",265,0)
|
---|
| 768 | S MATCH=0
|
---|
| 769 | "RTN","VWREGIT",266,0)
|
---|
| 770 | S DFN=0
|
---|
| 771 | "RTN","VWREGIT",267,0)
|
---|
| 772 | ;D SETMULTS
|
---|
| 773 | "RTN","VWREGIT",268,0)
|
---|
| 774 | S XEC=$$CFDFN^VWREGIT2(IDSTR)
|
---|
| 775 | "RTN","VWREGIT",269,0)
|
---|
| 776 | I $L(XEC) D:XEC'="XOUT" @XEC G XOUT ;Found DFN(s)...
|
---|
| 777 | "RTN","VWREGIT",270,0)
|
---|
| 778 | S DFN=+$P($P(IDSTR,"^",3),"(",2)
|
---|
| 779 | "RTN","VWREGIT",271,0)
|
---|
| 780 | I 'DFN,$P(IDSTR,"^",6) D D NEWPAT,FIELDS Q
|
---|
| 781 | "RTN","VWREGIT",272,0)
|
---|
| 782 | . S TID=$P($P(IDSTR,"^",2),":"),ID=$P($P(IDSTR,"^",2),":",2)
|
---|
| 783 | "RTN","VWREGIT",273,0)
|
---|
| 784 | . K:TID="SSN" VWREG ;Allow triggers and xfrs for the USA | jeb 2013
|
---|
| 785 | "RTN","VWREGIT",274,0)
|
---|
| 786 | . S ID=$S($L(ID):$$CLNNUM(ID),1:"")
|
---|
| 787 | "RTN","VWREGIT",275,0)
|
---|
| 788 | . S NAME=$$UP^XLFSTR($P(IDSTR,"^",3))
|
---|
| 789 | "RTN","VWREGIT",276,0)
|
---|
| 790 | . S XDOB=$P(IDSTR,"^",4)
|
---|
| 791 | "RTN","VWREGIT",277,0)
|
---|
| 792 | . S GENDER=$$UP^XLFSTR($P(IDSTR,"^",5))
|
---|
| 793 | "RTN","VWREGIT",278,0)
|
---|
| 794 | . ;1901,.301,391 From Sam Habiel's UJOPTREG c 2010,2011 by permission
|
---|
| 795 | "RTN","VWREGIT",279,0)
|
---|
| 796 | . S DATA(XFILE,"+1,",1901)="NO" ; Veteran?
|
---|
| 797 | "RTN","VWREGIT",280,0)
|
---|
| 798 | . S DATA(XFILE,"+1,",.301)="NO" ; Service Connected
|
---|
| 799 | "RTN","VWREGIT",281,0)
|
---|
| 800 | . S DATA(XFILE,"+1,",391)="NON-VETERAN (OTHER)" ; Type of Patient
|
---|
| 801 | "RTN","VWREGIT",282,0)
|
---|
| 802 | . S DATA(XFILE,"+1,",.01)=NAME
|
---|
| 803 | "RTN","VWREGIT",283,0)
|
---|
| 804 | . S DATA(XFILE,"+1,",.02)=GENDER
|
---|
| 805 | "RTN","VWREGIT",284,0)
|
---|
| 806 | . S DATA(XFILE,"+1,",.03)=XDOB
|
---|
| 807 | "RTN","VWREGIT",285,0)
|
---|
| 808 | . S DATA(XFILE,"+1,",.09)=$S(TID="SSN":ID,1:"")
|
---|
| 809 | "RTN","VWREGIT",286,0)
|
---|
| 810 | . S DATA(XFILE,"+1,",.363)=ID
|
---|
| 811 | "RTN","VWREGIT",287,0)
|
---|
| 812 | . D UPDATE^DIE("E","DATA","IEN","VWERR")
|
---|
| 813 | "RTN","VWREGIT",288,0)
|
---|
| 814 | . Q:$D(VWERR)
|
---|
| 815 | "RTN","VWREGIT",289,0)
|
---|
| 816 | . S DFN=IEN(1) D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
| 817 | "RTN","VWREGIT",290,0)
|
---|
| 818 | . ;Set up IHS Patient file (9000001)
|
---|
| 819 | "RTN","VWREGIT",291,0)
|
---|
| 820 | . D NOW^%DTC
|
---|
| 821 | "RTN","VWREGIT",292,0)
|
---|
| 822 | . S AUPN=IEN(1),$P(AUPN,"^",2)=X,$P(AUPN,"^",11)=DUZ,$P(AUPN,"^",12)=X
|
---|
| 823 | "RTN","VWREGIT",293,0)
|
---|
| 824 | . S ^AUPNPAT(+IEN(1))=AUPN,^AUPNPAT("B",+IEN(1),+IEN(1))=""
|
---|
| 825 | "RTN","VWREGIT",294,0)
|
---|
| 826 | . I TID="HRN",'$O(^AUPNPAT("D",+IEN(1),ID,0)) D
|
---|
| 827 | "RTN","VWREGIT",295,0)
|
---|
| 828 | .. S ^AUPNPAT(+IEN(1),41,1,0)="1^"_ID
|
---|
| 829 | "RTN","VWREGIT",296,0)
|
---|
| 830 | .. S $P(^AUPNPAT(+IEN(1),41,0),"^",3)=ID,$P(^(0),"^",4)=$P(^(0),"^",4)+1
|
---|
| 831 | "RTN","VWREGIT",297,0)
|
---|
| 832 | LAUP . L ^AUPNPAT(0):1 G LAUP:'$T D L
|
---|
| 833 | "RTN","VWREGIT",298,0)
|
---|
| 834 | .. S $P(^AUPNPAT(0),"^",3)=+IEN(1)
|
---|
| 835 | "RTN","VWREGIT",299,0)
|
---|
| 836 | .. S $P(^AUPNPAT(0),"^",4)=$P(^(0),"^",4)+1
|
---|
| 837 | "RTN","VWREGIT",300,0)
|
---|
| 838 | D PID(DFN,$P($P(IDSTR,"^",2),":"),$P($P(IDSTR,"^",2),":",2))
|
---|
| 839 | "RTN","VWREGIT",301,0)
|
---|
| 840 | ;D:'MATCH&($P(RESULT(0),"^",2)<2) FIELDS
|
---|
| 841 | "RTN","VWREGIT",302,0)
|
---|
| 842 | XOUT K PAR,ARR,ERR,SPAR,LUERR Q
|
---|
| 843 | "RTN","VWREGIT",303,0)
|
---|
| 844 | ;
|
---|
| 845 | "RTN","VWREGIT",304,0)
|
---|
| 846 | NEWPAT ;Set up new patient data return
|
---|
| 847 | "RTN","VWREGIT",305,0)
|
---|
| 848 | S $P(RESULT(0),"^",2)=1
|
---|
| 849 | "RTN","VWREGIT",306,0)
|
---|
| 850 | ;S DFN=$G(IEN(1))
|
---|
| 851 | "RTN","VWREGIT",307,0)
|
---|
| 852 | I TID'="SSN" D
|
---|
| 853 | "RTN","VWREGIT",308,0)
|
---|
| 854 | . S DA=DFN
|
---|
| 855 | "RTN","VWREGIT",309,0)
|
---|
| 856 | . D PSEU^DGRPDD1
|
---|
| 857 | "RTN","VWREGIT",310,0)
|
---|
| 858 | . S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""
|
---|
| 859 | "RTN","VWREGIT",311,0)
|
---|
| 860 | S RESULT($$INR)=DFN_"^"_ID_"^"_NAME_"^"_XDOB_"^"_GENDER_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"N/A")
|
---|
| 861 | "RTN","VWREGIT",312,0)
|
---|
| 862 | Q
|
---|
| 863 | "RTN","VWREGIT",313,0)
|
---|
| 864 | ;
|
---|
| 865 | "RTN","VWREGIT2")
|
---|
| 866 | 0^9^B100003944
|
---|
| 867 | "RTN","VWREGIT2",1,0)
|
---|
| 868 | VWREGIT2 ;VWEHR/Jim Bell, et al... - World VistA Input Template Utility
|
---|
| 869 | "RTN","VWREGIT2",2,0)
|
---|
| 870 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
| 871 | "RTN","VWREGIT2",3,0)
|
---|
| 872 | ;
|
---|
| 873 | "RTN","VWREGIT2",4,0)
|
---|
| 874 | ;Continued from VWREGIT
|
---|
| 875 | "RTN","VWREGIT2",5,0)
|
---|
| 876 | ;
|
---|
| 877 | "RTN","VWREGIT2",6,0)
|
---|
| 878 | ;GNU License: See WVLIC.txt
|
---|
| 879 | "RTN","VWREGIT2",7,0)
|
---|
| 880 | ;Modified FOIA VISTA,
|
---|
| 881 | "RTN","VWREGIT2",8,0)
|
---|
| 882 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
| 883 | "RTN","VWREGIT2",9,0)
|
---|
| 884 | Q
|
---|
| 885 | "RTN","VWREGIT2",10,0)
|
---|
| 886 | ;
|
---|
| 887 | "RTN","VWREGIT2",11,0)
|
---|
| 888 | PI ;Post Installation install
|
---|
| 889 | "RTN","VWREGIT2",12,0)
|
---|
| 890 | ;; NOTE: The parameter definition is installed but there is no installation for
|
---|
| 891 | "RTN","VWREGIT2",13,0)
|
---|
| 892 | ;;the actual parameter and value. Do it here.
|
---|
| 893 | "RTN","VWREGIT2",14,0)
|
---|
| 894 | ;parameter value attempt
|
---|
| 895 | "RTN","VWREGIT2",15,0)
|
---|
| 896 | ;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/"
|
---|
| 897 | "RTN","VWREGIT2",16,0)
|
---|
| 898 | S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
|
---|
| 899 | "RTN","VWREGIT2",17,0)
|
---|
| 900 | I PARD D
|
---|
| 901 | "RTN","VWREGIT2",18,0)
|
---|
| 902 | . L +^XTV(8989.5,0):1 D L -^XTV(8989.5,0)
|
---|
| 903 | "RTN","VWREGIT2",19,0)
|
---|
| 904 | .. S NEW=$O(^XTV(8989.5," "),-1)+1
|
---|
| 905 | "RTN","VWREGIT2",20,0)
|
---|
| 906 | .. S $P(^XTV(8989.5,0),"^",3)=NEW
|
---|
| 907 | "RTN","VWREGIT2",21,0)
|
---|
| 908 | .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
|
---|
| 909 | "RTN","VWREGIT2",22,0)
|
---|
| 910 | .. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4,"
|
---|
| 911 | "RTN","VWREGIT2",23,0)
|
---|
| 912 | .. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD
|
---|
| 913 | "RTN","VWREGIT2",24,0)
|
---|
| 914 | .. S $P(^XTV(8989.5,NEW,0),"^",3)=1
|
---|
| 915 | "RTN","VWREGIT2",25,0)
|
---|
| 916 | .. S ^XTV(8989.5,NEW,1)="/home/vista/regparam/"
|
---|
| 917 | "RTN","VWREGIT2",26,0)
|
---|
| 918 | .. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK
|
---|
| 919 | "RTN","VWREGIT2",27,0)
|
---|
| 920 | .. S NEW2=$O(^XTV(8989.5," "),-1)+1
|
---|
| 921 | "RTN","VWREGIT2",28,0)
|
---|
| 922 | .. S $P(^XTV(8989.5,0),"^",3)=NEW2
|
---|
| 923 | "RTN","VWREGIT2",29,0)
|
---|
| 924 | .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
|
---|
| 925 | "RTN","VWREGIT2",30,0)
|
---|
| 926 | .. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2,"
|
---|
| 927 | "RTN","VWREGIT2",31,0)
|
---|
| 928 | .. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD
|
---|
| 929 | "RTN","VWREGIT2",32,0)
|
---|
| 930 | .. S $P(^XTV(8989.5,NEW2,0),"^",3)=1
|
---|
| 931 | "RTN","VWREGIT2",33,0)
|
---|
| 932 | .. S ^XTV(8989.5,NEW2,1)="/home/vista/regparam/"
|
---|
| 933 | "RTN","VWREGIT2",34,0)
|
---|
| 934 | .. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK
|
---|
| 935 | "RTN","VWREGIT2",35,0)
|
---|
| 936 | .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1)="/home/vista/regparam/"
|
---|
| 937 | "RTN","VWREGIT2",36,0)
|
---|
| 938 | .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1,NE)=""
|
---|
| 939 | "RTN","VWREGIT2",37,0)
|
---|
| 940 | .. ;S ^XTV(8989.5,"B","1;DIC(4,",NE)=""
|
---|
| 941 | "RTN","VWREGIT2",38,0)
|
---|
| 942 | ;
|
---|
| 943 | "RTN","VWREGIT2",39,0)
|
---|
| 944 | ;Mailgroup VW REG ERROR REPORT - add programmer's email
|
---|
| 945 | "RTN","VWREGIT2",40,0)
|
---|
| 946 | S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
|
---|
| 947 | "RTN","VWREGIT2",41,0)
|
---|
| 948 | Q:'DA(1)
|
---|
| 949 | "RTN","VWREGIT2",42,0)
|
---|
| 950 | S DIC="^XMB(3.8,"_DA(1)_",6,"
|
---|
| 951 | "RTN","VWREGIT2",43,0)
|
---|
| 952 | S X="jbellco65@gmail.com"
|
---|
| 953 | "RTN","VWREGIT2",44,0)
|
---|
| 954 | S DIC(0)="LZ"
|
---|
| 955 | "RTN","VWREGIT2",45,0)
|
---|
| 956 | D FILE^DICN
|
---|
| 957 | "RTN","VWREGIT2",46,0)
|
---|
| 958 | Q
|
---|
| 959 | "RTN","VWREGIT2",47,0)
|
---|
| 960 | ;
|
---|
| 961 | "RTN","VWREGIT2",48,0)
|
---|
| 962 | ABSDFN(RESULT,IDSTR) ;Absolute DFN
|
---|
| 963 | "RTN","VWREGIT2",49,0)
|
---|
| 964 | N TNUM,DFN,XFILE
|
---|
| 965 | "RTN","VWREGIT2",50,0)
|
---|
| 966 | K ERR,RESULT,PAR,FSET,FSETMAT
|
---|
| 967 | "RTN","VWREGIT2",51,0)
|
---|
| 968 | S RESULT(0)="ID^-1"
|
---|
| 969 | "RTN","VWREGIT2",52,0)
|
---|
| 970 | S TNUM=+$P($P(IDSTR,"^"),"(",2) I 'TNUM S RESULT(1)="Template not supplied. Please retry..." Q
|
---|
| 971 | "RTN","VWREGIT2",53,0)
|
---|
| 972 | S DFN=$P(IDSTR,"^",2) I 'DFN S RESULT(1)="Patient not supplied. Please try again..." Q
|
---|
| 973 | "RTN","VWREGIT2",54,0)
|
---|
| 974 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
| 975 | "RTN","VWREGIT2",55,0)
|
---|
| 976 | ;D SETMULTS^VWREGIT
|
---|
| 977 | "RTN","VWREGIT2",56,0)
|
---|
| 978 | D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
| 979 | "RTN","VWREGIT2",57,0)
|
---|
| 980 | D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
|
---|
| 981 | "RTN","VWREGIT2",58,0)
|
---|
| 982 | S $P(RESULT(0),"^",2)=1
|
---|
| 983 | "RTN","VWREGIT2",59,0)
|
---|
| 984 | S $P(RESULT(1),"^",1)=DFN
|
---|
| 985 | "RTN","VWREGIT2",60,0)
|
---|
| 986 | S $P(RESULT(1),"^",2)=$G(ARR("DILIST","ID",1,.363))
|
---|
| 987 | "RTN","VWREGIT2",61,0)
|
---|
| 988 | S $P(RESULT(1),"^",3)=$G(ARR("DILIST","ID",1,.01))
|
---|
| 989 | "RTN","VWREGIT2",62,0)
|
---|
| 990 | ;S $P(RESULT(1),"^",4)=$G(ARR("DILIST","ID",1,.03))
|
---|
| 991 | "RTN","VWREGIT2",63,0)
|
---|
| 992 | S $P(RESULT(1),"^",4)=$$GDOBT^VWREGIT(DFN)
|
---|
| 993 | "RTN","VWREGIT2",64,0)
|
---|
| 994 | S $P(RESULT(1),"^",5)=$E($G(ARR("DILIST","ID",1,.02)))
|
---|
| 995 | "RTN","VWREGIT2",65,0)
|
---|
| 996 | S $P(RESULT(1),"^",6)=$S($G(^DPT(DFN,.1)):^(.1),1:"N/A")_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
|
---|
| 997 | "RTN","VWREGIT2",66,0)
|
---|
| 998 | S $P(RESULT(1),"^",7)=$G(ARR("DILIST",1,.09))
|
---|
| 999 | "RTN","VWREGIT2",67,0)
|
---|
| 1000 | D FIELDS^VWREGIT
|
---|
| 1001 | "RTN","VWREGIT2",68,0)
|
---|
| 1002 | S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
|
---|
| 1003 | "RTN","VWREGIT2",69,0)
|
---|
| 1004 | S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
| 1005 | "RTN","VWREGIT2",70,0)
|
---|
| 1006 | . S F=$P(RESULT(N),"^")
|
---|
| 1007 | "RTN","VWREGIT2",71,0)
|
---|
| 1008 | . S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
|
---|
| 1009 | "RTN","VWREGIT2",72,0)
|
---|
| 1010 | . S $P(RESULT(N),"^",3)=FDATA
|
---|
| 1011 | "RTN","VWREGIT2",73,0)
|
---|
| 1012 | . S $P(RESULT(N),"^",4)=$$HINT^VWREGIT(XFILE,$P(RESULT(N),"^",2))
|
---|
| 1013 | "RTN","VWREGIT2",74,0)
|
---|
| 1014 | S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N)
|
---|
| 1015 | "RTN","VWREGIT2",75,0)
|
---|
| 1016 | . S SN=+RESULT(N) Q:'$D(FSETM(SN))
|
---|
| 1017 | "RTN","VWREGIT2",76,0)
|
---|
| 1018 | . S SNFLDS=FSETM(SN)
|
---|
| 1019 | "RTN","VWREGIT2",77,0)
|
---|
| 1020 | . S IX=.1
|
---|
| 1021 | "RTN","VWREGIT2",78,0)
|
---|
| 1022 | . F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR^VWREGIT(SN)_"^^",IX=IX+.1
|
---|
| 1023 | "RTN","VWREGIT2",79,0)
|
---|
| 1024 | S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N)
|
---|
| 1025 | "RTN","VWREGIT2",80,0)
|
---|
| 1026 | S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
| 1027 | "RTN","VWREGIT2",81,0)
|
---|
| 1028 | . I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
|
---|
| 1029 | "RTN","VWREGIT2",82,0)
|
---|
| 1030 | . I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)="NOW"
|
---|
| 1031 | "RTN","VWREGIT2",83,0)
|
---|
| 1032 | Q
|
---|
| 1033 | "RTN","VWREGIT2",84,0)
|
---|
| 1034 | ;
|
---|
| 1035 | "RTN","VWREGIT2",85,0)
|
---|
| 1036 | CFDFN(STRING) ;Check for a DFN
|
---|
| 1037 | "RTN","VWREGIT2",86,0)
|
---|
| 1038 | ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
---|
| 1039 | "RTN","VWREGIT2",87,0)
|
---|
| 1040 | ; | STRING___TEMPLATE(IEN)^ID^NAME^DOB^GENDER |
|
---|
| 1041 | "RTN","VWREGIT2",88,0)
|
---|
| 1042 | ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
---|
| 1043 | "RTN","VWREGIT2",89,0)
|
---|
| 1044 | ;
|
---|
| 1045 | "RTN","VWREGIT2",90,0)
|
---|
| 1046 | N NAME,ID
|
---|
| 1047 | "RTN","VWREGIT2",91,0)
|
---|
| 1048 | S ID=$$CLNNUM^VWREGIT($P($P(STRING,"^",2),":",2))
|
---|
| 1049 | "RTN","VWREGIT2",92,0)
|
---|
| 1050 | S TID=$P($P(STRING,"^",2),":")
|
---|
| 1051 | "RTN","VWREGIT2",93,0)
|
---|
| 1052 | I TID="HRN" S DFN=$O(^AUPNPAT("D",ID,0)) S $P(IDSTR,"^",2)=DFN D ABSDFN(.RESULT,IDSTR) Q "XOUT"
|
---|
| 1053 | "RTN","VWREGIT2",94,0)
|
---|
| 1054 | S NAME=$$UP^XLFSTR($P(STRING,"^",3))
|
---|
| 1055 | "RTN","VWREGIT2",95,0)
|
---|
| 1056 | D FIND^DIC(2,"",".01;.02;.03;.09;.363","CM",$S(+ID:ID,1:NAME),"","B^SSN^AVWPID","","","ARR","LUERR")
|
---|
| 1057 | "RTN","VWREGIT2",96,0)
|
---|
| 1058 | I '$O(ARR("DILIST",0)) Q ""
|
---|
| 1059 | "RTN","VWREGIT2",97,0)
|
---|
| 1060 | ;I '$O(ARR("DILIST",1,1)),$L(NAME),ARR("DILIST",1,1)'=NAME Q "MM"
|
---|
| 1061 | "RTN","VWREGIT2",98,0)
|
---|
| 1062 | I $O(ARR("DILIST",1,1)) Q "PIDM" ;multiple found
|
---|
| 1063 | "RTN","VWREGIT2",99,0)
|
---|
| 1064 | I '$O(ARR("DILIST",1,1)) D D ABSDFN(.RESULT,IDSTR) Q "XOUT" ;Single found
|
---|
| 1065 | "RTN","VWREGIT2",100,0)
|
---|
| 1066 | . S $P(IDSTR,"^",2)=ARR("DILIST",2,1)
|
---|
| 1067 | "RTN","VWREGIT2",101,0)
|
---|
| 1068 | Q ""
|
---|
| 1069 | "RTN","VWREGIT2",102,0)
|
---|
| 1070 | ;
|
---|
| 1071 | "RTN","VWREGIT2",103,0)
|
---|
| 1072 | ST(TN) ;Screen these templates for PATIENT FILE(#2):1,1:0
|
---|
| 1073 | "RTN","VWREGIT2",104,0)
|
---|
| 1074 | I $E($P(^DIE(TN,0),"^"))="*" Q 0
|
---|
| 1075 | "RTN","VWREGIT2",105,0)
|
---|
| 1076 | I $P(^DIE(TN,0),"^",4)'=2 Q 0
|
---|
| 1077 | "RTN","VWREGIT2",106,0)
|
---|
| 1078 | Q 1
|
---|
| 1079 | "RTN","VWREGIT2",107,0)
|
---|
| 1080 | ;
|
---|
| 1081 | "RTN","VWREGIT2",108,0)
|
---|
| 1082 | INR() Q $O(RESULT(" "),-1)+1
|
---|
| 1083 | "RTN","VWREGIT2",109,0)
|
---|
| 1084 | ;
|
---|
| 1085 | "RTN","VWREGIT2",110,0)
|
---|
| 1086 | CLNNUM(NUM) ;Clean NUM
|
---|
| 1087 | "RTN","VWREGIT2",111,0)
|
---|
| 1088 | Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
|
---|
| 1089 | "RTN","VWREGIT2",112,0)
|
---|
| 1090 | ;
|
---|
| 1091 | "RTN","VWREGIT2",113,0)
|
---|
| 1092 | CONTROL() ;Check for CONTROL status
|
---|
| 1093 | "RTN","VWREGIT2",114,0)
|
---|
| 1094 | N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
|
---|
| 1095 | "RTN","VWREGIT2",115,0)
|
---|
| 1096 | I 'X Q 0 ;Ain't no option there
|
---|
| 1097 | "RTN","VWREGIT2",116,0)
|
---|
| 1098 | Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
|
---|
| 1099 | "RTN","VWREGIT2",117,0)
|
---|
| 1100 | ;
|
---|
| 1101 | "RTN","VWREGIT2",118,0)
|
---|
| 1102 | GETHD(RESULT) ;Get home directory for set up
|
---|
| 1103 | "RTN","VWREGIT2",119,0)
|
---|
| 1104 | S RESULT(0)=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
| 1105 | "RTN","VWREGIT2",120,0)
|
---|
| 1106 | Q
|
---|
| 1107 | "RTN","VWREGIT2",121,0)
|
---|
| 1108 | ;
|
---|
| 1109 | "RTN","VWREGIT2",122,0)
|
---|
| 1110 | SAVEHD(RESULT,NHD) ;Saves Home Directory changes to PARAMETER file
|
---|
| 1111 | "RTN","VWREGIT2",123,0)
|
---|
| 1112 | ; Called from Remote Procedure VW REG SAVE HD
|
---|
| 1113 | "RTN","VWREGIT2",124,0)
|
---|
| 1114 | ; NHD_____New Home Directory
|
---|
| 1115 | "RTN","VWREGIT2",125,0)
|
---|
| 1116 | ;
|
---|
| 1117 | "RTN","VWREGIT2",126,0)
|
---|
| 1118 | I NHD="" S RESULT(0)="-1^No data from client" Q
|
---|
| 1119 | "RTN","VWREGIT2",127,0)
|
---|
| 1120 | K RESULT,SCRATCH
|
---|
| 1121 | "RTN","VWREGIT2",128,0)
|
---|
| 1122 | N HDIEN,N
|
---|
| 1123 | "RTN","VWREGIT2",129,0)
|
---|
| 1124 | S HDIEN=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
|
---|
| 1125 | "RTN","VWREGIT2",130,0)
|
---|
| 1126 | I 'HDIEN D Q
|
---|
| 1127 | "RTN","VWREGIT2",131,0)
|
---|
| 1128 | . S T(1)="Error reported from routine SAVEHD^VWREGIT:"
|
---|
| 1129 | "RTN","VWREGIT2",132,0)
|
---|
| 1130 | . S T(2)="The PARAMETER DEFINITION ""VW GUI REG TEMPLATE DIRECTORY"" was"
|
---|
| 1131 | "RTN","VWREGIT2",133,0)
|
---|
| 1132 | . S T(3)="not found."
|
---|
| 1133 | "RTN","VWREGIT2",134,0)
|
---|
| 1134 | . D ME^VWREGIT("NO PARAMETER DEFINITION")
|
---|
| 1135 | "RTN","VWREGIT2",135,0)
|
---|
| 1136 | . S RESULT(0)="-1^Error sent to VW REG mail group"
|
---|
| 1137 | "RTN","VWREGIT2",136,0)
|
---|
| 1138 | S X="^XTV(8989.5,""AC"","_HDIEN_")" F S X=$Q(@X) Q:+$P(X,",",3)'=HDIEN S:$L(X,",")>6 SCRATCH(+$P(X,",",7))=""
|
---|
| 1139 | "RTN","VWREGIT2",137,0)
|
---|
| 1140 | S N=0 F S N=$O(SCRATCH(N)) Q:'+N D S RESULT(0)=1
|
---|
| 1141 | "RTN","VWREGIT2",138,0)
|
---|
| 1142 | . S ^XTV(8989.5,N,1)=NHD
|
---|
| 1143 | "RTN","VWREGIT2",139,0)
|
---|
| 1144 | . S DA=N,DIK="^XTV(8989.5," D IX^DIK
|
---|
| 1145 | "RTN","VWREGIT2",140,0)
|
---|
| 1146 | . K DIC,DA,DIK
|
---|
| 1147 | "RTN","VWREGIT2",141,0)
|
---|
| 1148 | Q
|
---|
| 1149 | "RTN","VWREGIT2",142,0)
|
---|
| 1150 | ;
|
---|
| 1151 | "RTN","VWREGIT2",143,0)
|
---|
| 1152 | SAVE(RESULT,FLDS) ;Template fields being returned with values
|
---|
| 1153 | "RTN","VWREGIT2",144,0)
|
---|
| 1154 | ;UPCASE everything!
|
---|
| 1155 | "RTN","VWREGIT2",145,0)
|
---|
| 1156 | ;;Testing
|
---|
| 1157 | "RTN","VWREGIT2",146,0)
|
---|
| 1158 | ;;S RESULT(0)="-1 Q
|
---|
| 1159 | "RTN","VWREGIT2",147,0)
|
---|
| 1160 | ;;End Testing
|
---|
| 1161 | "RTN","VWREGIT2",148,0)
|
---|
| 1162 | K AR,ERR,MFLD,DIERR
|
---|
| 1163 | "RTN","VWREGIT2",149,0)
|
---|
| 1164 | N N,TNUM,XFILE,C,PLID,COUNTY,PSSN,DA,DIE,DIC,DR,STR,VAFCA08
|
---|
| 1165 | "RTN","VWREGIT2",150,0)
|
---|
| 1166 | ;W " ;Used for "instantiating" a hard error
|
---|
| 1167 | "RTN","VWREGIT2",151,0)
|
---|
| 1168 | S C=0,RESULT(0)=""
|
---|
| 1169 | "RTN","VWREGIT2",152,0)
|
---|
| 1170 | S X="FLDS" F S X=$Q(@X) Q:X="" S STR=@X,@X=$$UP^XLFSTR(STR)
|
---|
| 1171 | "RTN","VWREGIT2",153,0)
|
---|
| 1172 | S VWREG=$S($P(FLDS(0),"^",2)="VWRGUI":1,1:0)
|
---|
| 1173 | "RTN","VWREGIT2",154,0)
|
---|
| 1174 | S VAFCA08=1 ;Prevents execution xfrs 991 and 992 of field 1901 and related other fields
|
---|
| 1175 | "RTN","VWREGIT2",155,0)
|
---|
| 1176 | S TNUM=+$P(FLDS(0),"(",2)
|
---|
| 1177 | "RTN","VWREGIT2",156,0)
|
---|
| 1178 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
| 1179 | "RTN","VWREGIT2",157,0)
|
---|
| 1180 | S $P(FLDS(4),"^",2)=$$CLNNUM($P(FLDS(4),"^",2))
|
---|
| 1181 | "RTN","VWREGIT2",158,0)
|
---|
| 1182 | ;VA abnormal anomalies not experienced in the outside world
|
---|
| 1183 | "RTN","VWREGIT2",159,0)
|
---|
| 1184 | S N=0 F S N=$O(FLDS(N)) Q:'+N D
|
---|
| 1185 | "RTN","VWREGIT2",160,0)
|
---|
| 1186 | . S LFILE=$S($P(FLDS(N),"^")[";":+FLDS(N),1:XFILE)
|
---|
| 1187 | "RTN","VWREGIT2",161,0)
|
---|
| 1188 | . S LFLD=$P(FLDS(N),"^")
|
---|
| 1189 | "RTN","VWREGIT2",162,0)
|
---|
| 1190 | . S LFLD=$S(LFLD[";":$P($P(LFLD,"^"),";",2),1:LFLD)
|
---|
| 1191 | "RTN","VWREGIT2",163,0)
|
---|
| 1192 | . I $P(^DD(LFILE,+LFLD,0),"^")="PRIMARY LONG ID" S PLID=1
|
---|
| 1193 | "RTN","VWREGIT2",164,0)
|
---|
| 1194 | . I $P(^DD(LFILE,+LFLD,0),"^")["COUNTY" S COUNTY=FLDS(N) K FLDS(N)
|
---|
| 1195 | "RTN","VWREGIT2",165,0)
|
---|
| 1196 | ;End VA abnormal anomalies
|
---|
| 1197 | "RTN","VWREGIT2",166,0)
|
---|
| 1198 | S DFN=+$P(FLDS(1),"(",2)
|
---|
| 1199 | "RTN","VWREGIT2",167,0)
|
---|
| 1200 | DFN ;
|
---|
| 1201 | "RTN","VWREGIT2",168,0)
|
---|
| 1202 | ;Check standard ID fields (ID = NOT in the VA meaning): .01,.02,.03,.36^3 for outside the U.S. or 0^9 in the U.S.
|
---|
| 1203 | "RTN","VWREGIT2",169,0)
|
---|
| 1204 | I $P(^DPT(DFN,0),"^")'=$P($P(FLDS(1),"^",2),"(") S AR(XFILE,DFN_",",$P(FLDS(1),"^"))=$P($P(FLDS(1),"^",2),"(")
|
---|
| 1205 | "RTN","VWREGIT2",170,0)
|
---|
| 1206 | I $P(^DPT(DFN,0),"^",2)'=$P(FLDS(2),"^") S AR(XFILE,DFN_",",$P(FLDS(2),"^"))=$S($P(FLDS(2),"^",2)="F":"FEMALE",1:"MALE")
|
---|
| 1207 | "RTN","VWREGIT2",171,0)
|
---|
| 1208 | S X=$P(FLDS(3),"^",2) D ^%DT I $P(^DPT(DFN,0),"^",3)'=Y S AR(XFILE,DFN_",",$P(FLDS(3),"^"))=$P(FLDS(3),"^",2)
|
---|
| 1209 | "RTN","VWREGIT2",172,0)
|
---|
| 1210 | ;S FLD=$P(FLDS(4),"^"),PIECE=$S(FLD=.363:3,1:9),SUBS=$S(FLD=.363:.36,1:0)
|
---|
| 1211 | "RTN","VWREGIT2",173,0)
|
---|
| 1212 | ;I $P(^DPT(DFN,SUBS),"^",PIECE)'=$P(FLDS(4),"^",2) S AR(XFILE,DFN_",",FLD)=$P(FLDS(4),"^",2)
|
---|
| 1213 | "RTN","VWREGIT2",174,0)
|
---|
| 1214 | S N=4 F S N=$O(FLDS(N)) Q:'+N S:FLDS(N)'[";" AR(XFILE,DFN_",",$P(FLDS(N),"^"))=$P(FLDS(N),"^",2) D:FLDS(N)[";"
|
---|
| 1215 | "RTN","VWREGIT2",175,0)
|
---|
| 1216 | . I '$D(MFLD($P(FLDS(N),";"))) S MFLD=$P(FLDS(N),";"),MFLD(MFLD)=FLDS(N)
|
---|
| 1217 | "RTN","VWREGIT2",176,0)
|
---|
| 1218 | . E S MFLD($P(FLDS(N),";"))=MFLD($P(FLDS(N),";"))_"~"_$P(FLDS(N),";",2)
|
---|
| 1219 | "RTN","VWREGIT2",177,0)
|
---|
| 1220 | I $D(MFLD) S C=1,N=0 F S N=$O(MFLD(N)) Q:'+N S C=C+1,CN=0 F I=1:1:$L(MFLD(N),"~") S CN=CN+1,X=$P($P(MFLD(N),";",2),"~",I),AR(N,"+"_C_","_DFN_",",$P(X,"^"))=$P(X,"^",2)
|
---|
| 1221 | "RTN","VWREGIT2",178,0)
|
---|
| 1222 | D UPDATE^DIE("E","AR","","ERR") ;Edit existing entries noted by $D(DFN)
|
---|
| 1223 | "RTN","VWREGIT2",179,0)
|
---|
| 1224 | N Y,X,% D NOW^%DTC S Y=% X ^DD("DD")
|
---|
| 1225 | "RTN","VWREGIT2",180,0)
|
---|
| 1226 | S RESULT(0)=1_"^"_Y
|
---|
| 1227 | "RTN","VWREGIT2",181,0)
|
---|
| 1228 | SOUT Q
|
---|
| 1229 | "RTN","VWREGIT2",182,0)
|
---|
| 1230 | ;
|
---|
| 1231 | "RTN","VWREGIT2",183,0)
|
---|
| 1232 | UTF(RESULT,UTFLIST) ;Update Linux Template file (regit.txt)
|
---|
| 1233 | "RTN","VWREGIT2",184,0)
|
---|
| 1234 | I $O(UTFLIST(" "),-1)=0 S RESULT(0)="-1" Q
|
---|
| 1235 | "RTN","VWREGIT2",185,0)
|
---|
| 1236 | K RESULT
|
---|
| 1237 | "RTN","VWREGIT2",186,0)
|
---|
| 1238 | N HD,DOTHIS,N,NF
|
---|
| 1239 | "RTN","VWREGIT2",187,0)
|
---|
| 1240 | S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
| 1241 | "RTN","VWREGIT2",188,0)
|
---|
| 1242 | I +$P($G(^%ZOSF("OS")),"^",2)=19 D
|
---|
| 1243 | "RTN","VWREGIT2",189,0)
|
---|
| 1244 | . S DOTHIS="rm -f "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Remove the prior copy
|
---|
| 1245 | "RTN","VWREGIT2",190,0)
|
---|
| 1246 | . S DOTHIS="cp "_HD_"regit.txt"_" "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Copy the main regit file for safekeeping
|
---|
| 1247 | "RTN","VWREGIT2",191,0)
|
---|
| 1248 | . S DOTHIS="rm -f "_HD_"regit.txt" ZSYSTEM DOTHIS ;Kill the main regit template file
|
---|
| 1249 | "RTN","VWREGIT2",192,0)
|
---|
| 1250 | S RESULT(1)="[TEMPLATES]",N=0 F S N=$O(UTFLIST(N)) Q:'+N S RESULT($$INR)=UTFLIST(N)
|
---|
| 1251 | "RTN","VWREGIT2",193,0)
|
---|
| 1252 | S RESULT($$INR)="[ID]"
|
---|
| 1253 | "RTN","VWREGIT2",194,0)
|
---|
| 1254 | S X=$$GTF^%ZISH($NA(RESULT(1)),1,HD,"regit.txt")
|
---|
| 1255 | "RTN","VWREGIT2",195,0)
|
---|
| 1256 | Q
|
---|
| 1257 | "RTN","VWREGIT2",196,0)
|
---|
| 1258 | ;
|
---|
| 1259 | "RTN","VWREGIT2",197,0)
|
---|
| 1260 | GT(RESULT,XHOW) ;Get Templates from INPUT TEMPLATE FILE (.402)
|
---|
| 1261 | "RTN","VWREGIT2",198,0)
|
---|
| 1262 | ; *********************************************
|
---|
| 1263 | "RTN","VWREGIT2",199,0)
|
---|
| 1264 | ; * XHOW____ALL, DUZ, NAMESPACE, USER/NUM *
|
---|
| 1265 | "RTN","VWREGIT2",200,0)
|
---|
| 1266 | ; * RETURN ARRAY__List of template names(IEN) *
|
---|
| 1267 | "RTN","VWREGIT2",201,0)
|
---|
| 1268 | ; *********************************************
|
---|
| 1269 | "RTN","VWREGIT2",202,0)
|
---|
| 1270 | K RESULT,AR
|
---|
| 1271 | "RTN","VWREGIT2",203,0)
|
---|
| 1272 | N IEN,NAME,N,USER
|
---|
| 1273 | "RTN","VWREGIT2",204,0)
|
---|
| 1274 | S XHOW=$$UP^XLFSTR(XHOW) ;UPCASE EVERYTHING!
|
---|
| 1275 | "RTN","VWREGIT2",205,0)
|
---|
| 1276 | I XHOW="" D Q
|
---|
| 1277 | "RTN","VWREGIT2",206,0)
|
---|
| 1278 | . S RESULT(0)="I could not complete your request."
|
---|
| 1279 | "RTN","VWREGIT2",207,0)
|
---|
| 1280 | . S RESULT(1)="Ensure that one of the check boxes is checked."
|
---|
| 1281 | "RTN","VWREGIT2",208,0)
|
---|
| 1282 | . S RESULT(2)="Thank you, the Management."
|
---|
| 1283 | "RTN","VWREGIT2",209,0)
|
---|
| 1284 | I XHOW="ALL" D Q
|
---|
| 1285 | "RTN","VWREGIT2",210,0)
|
---|
| 1286 | . S RESULT(0)="Number of Templates: "
|
---|
| 1287 | "RTN","VWREGIT2",211,0)
|
---|
| 1288 | . S (C,N)=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=$P(^(N,0),"^") S:$$ST(N) AR(X,I)=X_"("_N_")"
|
---|
| 1289 | "RTN","VWREGIT2",212,0)
|
---|
| 1290 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X,C=C+1
|
---|
| 1291 | "RTN","VWREGIT2",213,0)
|
---|
| 1292 | . K AR
|
---|
| 1293 | "RTN","VWREGIT2",214,0)
|
---|
| 1294 | . S $P(RESULT(0),": ",2)=C K C
|
---|
| 1295 | "RTN","VWREGIT2",215,0)
|
---|
| 1296 | I XHOW="DUZ" D Q
|
---|
| 1297 | "RTN","VWREGIT2",216,0)
|
---|
| 1298 | . S RESULT(0)="Number of templates: "
|
---|
| 1299 | "RTN","VWREGIT2",217,0)
|
---|
| 1300 | . S (C,IEN)=0 F S IEN=$O(^DIE(IEN)) Q:'+IEN I $P(^(IEN,0),"^",5)=DUZ,$$ST(IEN) D
|
---|
| 1301 | "RTN","VWREGIT2",218,0)
|
---|
| 1302 | .. S C=C+1
|
---|
| 1303 | "RTN","VWREGIT2",219,0)
|
---|
| 1304 | .. S NAME=$P(^(0),"^")_"("_IEN_")"
|
---|
| 1305 | "RTN","VWREGIT2",220,0)
|
---|
| 1306 | .. S RESULT($$INR)=NAME
|
---|
| 1307 | "RTN","VWREGIT2",221,0)
|
---|
| 1308 | . S $P(RESULT(0),":",2)=C
|
---|
| 1309 | "RTN","VWREGIT2",222,0)
|
---|
| 1310 | I +XHOW D Q
|
---|
| 1311 | "RTN","VWREGIT2",223,0)
|
---|
| 1312 | . S RESULT(0)="Number of templates: "
|
---|
| 1313 | "RTN","VWREGIT2",224,0)
|
---|
| 1314 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=^(N,0) D
|
---|
| 1315 | "RTN","VWREGIT2",225,0)
|
---|
| 1316 | .. Q:$P(X,"^",5)'=XHOW
|
---|
| 1317 | "RTN","VWREGIT2",226,0)
|
---|
| 1318 | .. Q:'$$ST(N)
|
---|
| 1319 | "RTN","VWREGIT2",227,0)
|
---|
| 1320 | .. S AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
|
---|
| 1321 | "RTN","VWREGIT2",228,0)
|
---|
| 1322 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
| 1323 | "RTN","VWREGIT2",229,0)
|
---|
| 1324 | . K AR
|
---|
| 1325 | "RTN","VWREGIT2",230,0)
|
---|
| 1326 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
| 1327 | "RTN","VWREGIT2",231,0)
|
---|
| 1328 | I $L(XHOW,"^")>1,$P(XHOW,"^")="NS" D Q
|
---|
| 1329 | "RTN","VWREGIT2",232,0)
|
---|
| 1330 | . S RESULT(0)="Templates by Namespace: "
|
---|
| 1331 | "RTN","VWREGIT2",233,0)
|
---|
| 1332 | . S N=$P(XHOW,"^",2) F I=1:1 S N=$O(^DIE("B",N)) Q:N'[$P(XHOW,"^",2) S AR(N,I)=N_"("_$O(^DIE("B",N,0))_")"
|
---|
| 1333 | "RTN","VWREGIT2",234,0)
|
---|
| 1334 | . S X="AR" F S X=$Q(@X) Q:X="" S Y=@X S:$$ST(+$P(Y,"(",2)) RESULT($$INR)=Y
|
---|
| 1335 | "RTN","VWREGIT2",235,0)
|
---|
| 1336 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
| 1337 | "RTN","VWREGIT2",236,0)
|
---|
| 1338 | I $L(XHOW,"^")>1,$P(XHOW,"^")="U",+$P(XHOW,"^",2) D Q
|
---|
| 1339 | "RTN","VWREGIT2",237,0)
|
---|
| 1340 | . S RESULT(0)="Templates from: "
|
---|
| 1341 | "RTN","VWREGIT2",238,0)
|
---|
| 1342 | . S USER=+$P(XHOW,"^",2)
|
---|
| 1343 | "RTN","VWREGIT2",239,0)
|
---|
| 1344 | . I '$D(^VA(200,USER)) S RESULT(0)="I Cannot ID that user number." Q
|
---|
| 1345 | "RTN","VWREGIT2",240,0)
|
---|
| 1346 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S NAME=$P(^(N,0),"^") I $P(^(0),"^",5)=USER S AR(NAME,I)=NAME_"("_N_")"
|
---|
| 1347 | "RTN","VWREGIT2",241,0)
|
---|
| 1348 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
| 1349 | "RTN","VWREGIT2",242,0)
|
---|
| 1350 | . S $P(RESULT(0),": ",2)=$P(^VA(200,USER,0),"^")_" - "_$O(RESULT(" "),-1)
|
---|
| 1351 | "RTN","VWREGIT2",243,0)
|
---|
| 1352 | . K AR
|
---|
| 1353 | "RTN","VWREGIT2",244,0)
|
---|
| 1354 | I $L(XHOW,"^")>1,$P(XHOW,"^")="U",'+$P(XHOW,"^",2) D Q
|
---|
| 1355 | "RTN","VWREGIT2",245,0)
|
---|
| 1356 | . S NAME=$P(XHOW,"^",2)
|
---|
| 1357 | "RTN","VWREGIT2",246,0)
|
---|
| 1358 | . K LUERR,ARR D FIND^DIC(200,"",".01;","CM",NAME,"","B","","","ARR","LUERR")
|
---|
| 1359 | "RTN","VWREGIT2",247,0)
|
---|
| 1360 | . I $O(ARR("DILIST",2,1)) D Q
|
---|
| 1361 | "RTN","VWREGIT2",248,0)
|
---|
| 1362 | .. S RESULT(0)="LIST"
|
---|
| 1363 | "RTN","VWREGIT2",249,0)
|
---|
| 1364 | .. S RESULT(1)="[Instruction: double-click to select; right-click to close]"
|
---|
| 1365 | "RTN","VWREGIT2",250,0)
|
---|
| 1366 | .. S N=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N S RESULT($$INR)=ARR("DILIST",2,N)_"^"_ARR("DILIST",1,N)
|
---|
| 1367 | "RTN","VWREGIT2",251,0)
|
---|
| 1368 | . S IEN=ARR("DILIST",2,1) K ARR
|
---|
| 1369 | "RTN","VWREGIT2",252,0)
|
---|
| 1370 | . S RESULT(0)="Templates from: "
|
---|
| 1371 | "RTN","VWREGIT2",253,0)
|
---|
| 1372 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N!('$$ST(N)) S X=^(N,0) S:$P(X,"^",5)=IEN AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
|
---|
| 1373 | "RTN","VWREGIT2",254,0)
|
---|
| 1374 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
| 1375 | "RTN","VWREGIT2",255,0)
|
---|
| 1376 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
| 1377 | "RTN","VWREGIT2",256,0)
|
---|
| 1378 | . K AR
|
---|
| 1379 | "RTN","VWREGIT2",257,0)
|
---|
| 1380 | Q
|
---|
| 1381 | "RTN","VWREGIT2",258,0)
|
---|
| 1382 | ;
|
---|
| 1383 | "RTN","VWREGIT2",259,0)
|
---|
| 1384 |
|
---|
| 1385 | "RTN","VWREGIT3")
|
---|
| 1386 | 0^10^B43452100
|
---|
| 1387 | "RTN","VWREGIT3",1,0)
|
---|
| 1388 | VWREGIT ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
|
---|
| 1389 | "RTN","VWREGIT3",2,0)
|
---|
| 1390 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
| 1391 | "RTN","VWREGIT3",3,0)
|
---|
| 1392 | ;
|
---|
| 1393 | "RTN","VWREGIT3",4,0)
|
---|
| 1394 | ;This routine utility is for patient specific fields and
|
---|
| 1395 | "RTN","VWREGIT3",5,0)
|
---|
| 1396 | ;is used to build input templates for registration
|
---|
| 1397 | "RTN","VWREGIT3",6,0)
|
---|
| 1398 | ;
|
---|
| 1399 | "RTN","VWREGIT3",7,0)
|
---|
| 1400 | ;GNU License: See WVLIC.txt
|
---|
| 1401 | "RTN","VWREGIT3",8,0)
|
---|
| 1402 | ;Modified FOIA VISTA,
|
---|
| 1403 | "RTN","VWREGIT3",9,0)
|
---|
| 1404 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
| 1405 | "RTN","VWREGIT3",10,0)
|
---|
| 1406 | Q
|
---|
| 1407 | "RTN","VWREGIT3",11,0)
|
---|
| 1408 | ;
|
---|
| 1409 | "RTN","VWREGIT3",12,0)
|
---|
| 1410 | PREFLAB ;Preferred label extract
|
---|
| 1411 | "RTN","VWREGIT3",13,0)
|
---|
| 1412 | N FIELD,LABEL,N,I,CUSLAB
|
---|
| 1413 | "RTN","VWREGIT3",14,0)
|
---|
| 1414 | S N=0 F S N=$O(RESULT(N)) Q:'+N D
|
---|
| 1415 | "RTN","VWREGIT3",15,0)
|
---|
| 1416 | . S LABEL=$P(RESULT(N),"^")
|
---|
| 1417 | "RTN","VWREGIT3",16,0)
|
---|
| 1418 | . S FIELD=$P(RESULT(N),"^",2)
|
---|
| 1419 | "RTN","VWREGIT3",17,0)
|
---|
| 1420 | . S I=0 F S I=$O(AR(I)) Q:'+I D:RESULT(N)'[";"
|
---|
| 1421 | "RTN","VWREGIT3",18,0)
|
---|
| 1422 | .. Q:AR(I)'[";"
|
---|
| 1423 | "RTN","VWREGIT3",19,0)
|
---|
| 1424 | .. I $P(AR(I),";")=LABEL!($P(AR(I),";")=FIELD) D
|
---|
| 1425 | "RTN","VWREGIT3",20,0)
|
---|
| 1426 | ... S CUSLAB=$P(AR(I),";",2)
|
---|
| 1427 | "RTN","VWREGIT3",21,0)
|
---|
| 1428 | ... S CUSLAB=$TR(CUSLAB,"""","")
|
---|
| 1429 | "RTN","VWREGIT3",22,0)
|
---|
| 1430 | ... S $P(RESULT(N),"^")=CUSLAB
|
---|
| 1431 | "RTN","VWREGIT3",23,0)
|
---|
| 1432 | Q
|
---|
| 1433 | "RTN","VWREGIT3",24,0)
|
---|
| 1434 | ;
|
---|
| 1435 | "RTN","VWREGIT3",25,0)
|
---|
| 1436 | PARSE(STRING) ;Extract necessary data components in the string
|
---|
| 1437 | "RTN","VWREGIT3",26,0)
|
---|
| 1438 | N VAL,PIECE,LABEL,PREFLAB,FLDSN
|
---|
| 1439 | "RTN","VWREGIT3",27,0)
|
---|
| 1440 | S VAL=-1 I STRING="" G POUT
|
---|
| 1441 | "RTN","VWREGIT3",28,0)
|
---|
| 1442 | ;I $E(STRING)=">" S VAL="" G POUT
|
---|
| 1443 | "RTN","VWREGIT3",29,0)
|
---|
| 1444 | S PIECE=$S(STRING["(Multiple)":2,$L(STRING,"(")>2:3,1:2)
|
---|
| 1445 | "RTN","VWREGIT3",30,0)
|
---|
| 1446 | I $E(STRING)=">" D G POUT
|
---|
| 1447 | "RTN","VWREGIT3",31,0)
|
---|
| 1448 | . S SUBF=+$P(STRING,";",2),MAR(SUBF)=""
|
---|
| 1449 | "RTN","VWREGIT3",32,0)
|
---|
| 1450 | . S MAR(SUBF)=MAR(SUBF)_+$P(STRING,"(",PIECE)
|
---|
| 1451 | "RTN","VWREGIT3",33,0)
|
---|
| 1452 | . S VAL=""
|
---|
| 1453 | "RTN","VWREGIT3",34,0)
|
---|
| 1454 | S LABEL=$P(STRING,"~")
|
---|
| 1455 | "RTN","VWREGIT3",35,0)
|
---|
| 1456 | S PREFLAB=$S($P(STRING,"~",2)="(Multiple)":"",1:$P(STRING,"~",2))
|
---|
| 1457 | "RTN","VWREGIT3",36,0)
|
---|
| 1458 | S FLDN=+$P(STRING,"(",PIECE)
|
---|
| 1459 | "RTN","VWREGIT3",37,0)
|
---|
| 1460 | I '+FLDN,$G(DUZ(0))="@" S VAL=STRING G POUT
|
---|
| 1461 | "RTN","VWREGIT3",38,0)
|
---|
| 1462 | S VAL=FLDN_PREFLAB_"~"_$S('$L(PREFLAB):"",1:$P(LABEL,"(",1,PIECE-1)_"^"_PREFLAB)
|
---|
| 1463 | "RTN","VWREGIT3",39,0)
|
---|
| 1464 | POUT Q VAL
|
---|
| 1465 | "RTN","VWREGIT3",40,0)
|
---|
| 1466 | ;
|
---|
| 1467 | "RTN","VWREGIT3",41,0)
|
---|
| 1468 | NEXT(XAR) ;Get next subscript
|
---|
| 1469 | "RTN","VWREGIT3",42,0)
|
---|
| 1470 | Q $O(XAR(" "),-1)+1
|
---|
| 1471 | "RTN","VWREGIT3",43,0)
|
---|
| 1472 | ;
|
---|
| 1473 | "RTN","VWREGIT3",44,0)
|
---|
| 1474 | REJECT(FIELD,IEN) ;Reject Asterisked and Computed fields
|
---|
| 1475 | "RTN","VWREGIT3",45,0)
|
---|
| 1476 | I FIELD["COMPONENTS" Q 1 ;Pain in the butt!
|
---|
| 1477 | "RTN","VWREGIT3",46,0)
|
---|
| 1478 | I $E(FIELD)="*" Q 1 ;field marked for deletion
|
---|
| 1479 | "RTN","VWREGIT3",47,0)
|
---|
| 1480 | I $E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1 ;computed field
|
---|
| 1481 | "RTN","VWREGIT3",48,0)
|
---|
| 1482 | Q 0 ;Passed
|
---|
| 1483 | "RTN","VWREGIT3",49,0)
|
---|
| 1484 | ;
|
---|
| 1485 | "RTN","VWREGIT3",50,0)
|
---|
| 1486 | GTNUM ;
|
---|
| 1487 | "RTN","VWREGIT3",51,0)
|
---|
| 1488 | K AR,RESULT S RESULT(0)=-1
|
---|
| 1489 | "RTN","VWREGIT3",52,0)
|
---|
| 1490 | M AR=^DIE(TNUM)
|
---|
| 1491 | "RTN","VWREGIT3",53,0)
|
---|
| 1492 | Q:'$D(AR(0)) ;Huh, no template?
|
---|
| 1493 | "RTN","VWREGIT3",54,0)
|
---|
| 1494 | S RESULT(0)=TNAME
|
---|
| 1495 | "RTN","VWREGIT3",55,0)
|
---|
| 1496 | S FLDS=AR("DR",1,2)
|
---|
| 1497 | "RTN","VWREGIT3",56,0)
|
---|
| 1498 | F I=1:1:$L(FLDS,";")-1 S FN=$P(FLDS,";",I) D
|
---|
| 1499 | "RTN","VWREGIT3",57,0)
|
---|
| 1500 | . S FDATA=$S(+FN:$P(^DD(2,FN,0),"^",1,2),1:FN)
|
---|
| 1501 | "RTN","VWREGIT3",58,0)
|
---|
| 1502 | . S RESULT($$NEXT(.RESULT))=$S(+FN:$P(FDATA,"^")_"("_FN_")",1:FN)_$S(+$P(FDATA,"^",2):"~(Multiple)",1:"")
|
---|
| 1503 | "RTN","VWREGIT3",59,0)
|
---|
| 1504 | . I +$P(FDATA,"^",2) S SFN=AR("DR",2,+$P(FDATA,"^",2)) D
|
---|
| 1505 | "RTN","VWREGIT3",60,0)
|
---|
| 1506 | .. F J=1:1:$L(SFN,";")-1 D
|
---|
| 1507 | "RTN","VWREGIT3",61,0)
|
---|
| 1508 | ... S SDF=$P(SFN,";",J)
|
---|
| 1509 | "RTN","VWREGIT3",62,0)
|
---|
| 1510 | ... S SDFDATA=$P(^DD(+$P(FDATA,"^",2),+SDF,0),"^",1,2)
|
---|
| 1511 | "RTN","VWREGIT3",63,0)
|
---|
| 1512 | ... S RESULT($$NEXT(.RESULT))=">>>>> "_$P(SDFDATA,"^")_"("_SDF_";"_+$P(FDATA,"^",2)_")"_$S(+$P(SDFDATA,"^",2):"~(Multiple)",1:"")
|
---|
| 1513 | "RTN","VWREGIT3",64,0)
|
---|
| 1514 | ... I +$P(SDFDATA,"^",2) S SF3=AR("DR",2,+$P(SDFDATA,"^",2)) D
|
---|
| 1515 | "RTN","VWREGIT3",65,0)
|
---|
| 1516 | .... F K=1:1:$L(SF3,";")-1 S SF3DATA=$P(^DD(+$P(SDFDATA,"^",2),SF3,0),"^",1,2) D
|
---|
| 1517 | "RTN","VWREGIT3",66,0)
|
---|
| 1518 | ..... S RESULT($$NEXT(.RESULT))=">>>>>>>>>> "_SF3_"~"_$P(SF3DATA,"^")_$S(+$P(SF3DATA,"^",2):"~(Multiple)",1:"")
|
---|
| 1519 | "RTN","VWREGIT3",67,0)
|
---|
| 1520 | Q
|
---|
| 1521 | "RTN","VWREGIT3",68,0)
|
---|
| 1522 | ;
|
---|
| 1523 | "RTN","VWREGIT3",69,0)
|
---|
| 1524 | NFT(SUBS) ;Patient file fields into scratch global
|
---|
| 1525 | "RTN","VWREGIT3",70,0)
|
---|
| 1526 | Q $O(^UTILITY(SUBS," "),-1)+1 ;Next suscript
|
---|
| 1527 | "RTN","VWREGIT3",71,0)
|
---|
| 1528 | ;
|
---|
| 1529 | "RTN","VWREGIT3",72,0)
|
---|
| 1530 | SD ;SUB-DICS
|
---|
| 1531 | "RTN","VWREGIT3",73,0)
|
---|
| 1532 | N N,FLD,X
|
---|
| 1533 | "RTN","VWREGIT3",74,0)
|
---|
| 1534 | K ^UTILITY("SFT")
|
---|
| 1535 | "RTN","VWREGIT3",75,0)
|
---|
| 1536 | S X="^DD(2,""SB"")"
|
---|
| 1537 | "RTN","VWREGIT3",76,0)
|
---|
| 1538 | F S X=$Q(@X) Q:X'["SB" D
|
---|
| 1539 | "RTN","VWREGIT3",77,0)
|
---|
| 1540 | . S N=+$P(X,",",3)
|
---|
| 1541 | "RTN","VWREGIT3",78,0)
|
---|
| 1542 | . S FLD=+$P(X,",",4)
|
---|
| 1543 | "RTN","VWREGIT3",79,0)
|
---|
| 1544 | . S ^UTILITY("SFT",FLD,N)=""
|
---|
| 1545 | "RTN","VWREGIT3",80,0)
|
---|
| 1546 | Q
|
---|
| 1547 | "RTN","VWREGIT3",81,0)
|
---|
| 1548 | ;
|
---|
| 1549 | "RTN","VWREGIT3",82,0)
|
---|
| 1550 | LF(RESULT,TNAME) ;Full list of patient fields
|
---|
| 1551 | "RTN","VWREGIT3",83,0)
|
---|
| 1552 | K RESULT
|
---|
| 1553 | "RTN","VWREGIT3",84,0)
|
---|
| 1554 | S TNUM=+$P(TNAME,"(",2) D:TNUM GTNUM ;Existing template
|
---|
| 1555 | "RTN","VWREGIT3",85,0)
|
---|
| 1556 | ; Add patient file fields
|
---|
| 1557 | "RTN","VWREGIT3",86,0)
|
---|
| 1558 | S RESULT($$NEXT(.RESULT))="[PF]"
|
---|
| 1559 | "RTN","VWREGIT3",87,0)
|
---|
| 1560 | K ^UTILITY("FT") D SD
|
---|
| 1561 | "RTN","VWREGIT3",88,0)
|
---|
| 1562 | S FLD="" F S FLD=$O(^DD(2,"B",FLD)) Q:FLD="" D
|
---|
| 1563 | "RTN","VWREGIT3",89,0)
|
---|
| 1564 | . S N=0 F S N=$O(^DD(2,"B",FLD,N)) Q:'+N D:'$$REJECT(FLD,N)
|
---|
| 1565 | "RTN","VWREGIT3",90,0)
|
---|
| 1566 | .. S ^UTILITY("FT",$$NFT("FT"))=FLD_"("_N_")"_"~"_$S($D(^UTILITY("SFT",N)):"(Multiple)",1:" ")
|
---|
| 1567 | "RTN","VWREGIT3",91,0)
|
---|
| 1568 | .. S SDD=$O(^UTILITY("SFT",N,0)) Q:'SDD
|
---|
| 1569 | "RTN","VWREGIT3",92,0)
|
---|
| 1570 | .. S SDFLD="" F S SDFLD=$O(^DD(SDD,"B",SDFLD)) Q:SDFLD="" D
|
---|
| 1571 | "RTN","VWREGIT3",93,0)
|
---|
| 1572 | ... S SDN=0 F S SDN=$O(^DD(SDD,"B",SDFLD,SDN)) Q:'+SDN I '$$REJECT(SDFLD,SDN) S ^UTILITY("FT",$$NFT("FT"))=">>>>> "_SDFLD_"("_SDN_";"_SDD_")"
|
---|
| 1573 | "RTN","VWREGIT3",94,0)
|
---|
| 1574 | K ^UTILITY("SFT")
|
---|
| 1575 | "RTN","VWREGIT3",95,0)
|
---|
| 1576 | I '$O(^UTILITY("FT",0)) Q
|
---|
| 1577 | "RTN","VWREGIT3",96,0)
|
---|
| 1578 | S X="^UTILITY(""FT"")"
|
---|
| 1579 | "RTN","VWREGIT3",97,0)
|
---|
| 1580 | F I=1:1 S X=$Q(@X) Q:X'["FT" S RESULT($$NEXT(.RESULT))=@X
|
---|
| 1581 | "RTN","VWREGIT3",98,0)
|
---|
| 1582 | K ^UTILITY("FT")
|
---|
| 1583 | "RTN","VWREGIT3",99,0)
|
---|
| 1584 | Q
|
---|
| 1585 | "RTN","VWREGIT3",100,0)
|
---|
| 1586 | ;
|
---|
| 1587 | "RTN","VWREGIT3",101,0)
|
---|
| 1588 | SAVE(RESULT,FLDS) ;
|
---|
| 1589 | "RTN","VWREGIT3",102,0)
|
---|
| 1590 | ;W " ;Intentional "Instantiated" Screw Job
|
---|
| 1591 | "RTN","VWREGIT3",103,0)
|
---|
| 1592 | Q:'$D(FLDS)
|
---|
| 1593 | "RTN","VWREGIT3",104,0)
|
---|
| 1594 | K ^UTILITY("FLDS") M ^UTILITY("FLDS")=FLDS
|
---|
| 1595 | "RTN","VWREGIT3",105,0)
|
---|
| 1596 | N TNUM,TNAME,DIC,DATA,FX,N,X,Y,DIE,NEWTEMP,PIECE
|
---|
| 1597 | "RTN","VWREGIT3",106,0)
|
---|
| 1598 | ;Clean FLDS or subscripts with empty values
|
---|
| 1599 | "RTN","VWREGIT3",107,0)
|
---|
| 1600 | I '$L(FLDS(0)) K FLDS(0)
|
---|
| 1601 | "RTN","VWREGIT3",108,0)
|
---|
| 1602 | S N=0 F S N=$O(FLDS(N)) Q:'+N D
|
---|
| 1603 | "RTN","VWREGIT3",109,0)
|
---|
| 1604 | . I '$L(FLDS(N)) K FLDS(N)
|
---|
| 1605 | "RTN","VWREGIT3",110,0)
|
---|
| 1606 | . S Y=$P(FLDS(N),"~",2)
|
---|
| 1607 | "RTN","VWREGIT3",111,0)
|
---|
| 1608 | . I $E(Y)=" " S $P(FLDS(N),"~",2)=$P(Y," ",2)
|
---|
| 1609 | "RTN","VWREGIT3",112,0)
|
---|
| 1610 | ;End cleaning
|
---|
| 1611 | "RTN","VWREGIT3",113,0)
|
---|
| 1612 | S NEWTEMP=0
|
---|
| 1613 | "RTN","VWREGIT3",114,0)
|
---|
| 1614 | S TNUM=+$P(FLDS(0),"(",2)
|
---|
| 1615 | "RTN","VWREGIT3",115,0)
|
---|
| 1616 | I 'TNUM S TNAME=$P(FLDS(0),"(")
|
---|
| 1617 | "RTN","VWREGIT3",116,0)
|
---|
| 1618 | S TNUM=$O(^DIE("B",TNAME,0))
|
---|
| 1619 | "RTN","VWREGIT3",117,0)
|
---|
| 1620 | I 'TNUM K DATA D ;File a new entry
|
---|
| 1621 | "RTN","VWREGIT3",118,0)
|
---|
| 1622 | . D NOW^%DTC
|
---|
| 1623 | "RTN","VWREGIT3",119,0)
|
---|
| 1624 | . S DIC="^DIE("
|
---|
| 1625 | "RTN","VWREGIT3",120,0)
|
---|
| 1626 | . S DATA(.402,"+1,",.01)=TNAME
|
---|
| 1627 | "RTN","VWREGIT3",121,0)
|
---|
| 1628 | . S DATA(.402,"+1,",2)=%
|
---|
| 1629 | "RTN","VWREGIT3",122,0)
|
---|
| 1630 | . S DATA(.402,"+1,",3)=$G(DUZ(0))
|
---|
| 1631 | "RTN","VWREGIT3",123,0)
|
---|
| 1632 | . S DATA(.402,"+1,",4)=2
|
---|
| 1633 | "RTN","VWREGIT3",124,0)
|
---|
| 1634 | . S DATA(.402,"+1,",5)=DUZ
|
---|
| 1635 | "RTN","VWREGIT3",125,0)
|
---|
| 1636 | . S DATA(.402,"+1,",6)=$G(DUZ(0))
|
---|
| 1637 | "RTN","VWREGIT3",126,0)
|
---|
| 1638 | . D UPDATE^DIE("","DATA","IEN","ERR")
|
---|
| 1639 | "RTN","VWREGIT3",127,0)
|
---|
| 1640 | . S TNUM=IEN(1) D RECALL^DILFD(.402,TNUM_",",DUZ)
|
---|
| 1641 | "RTN","VWREGIT3",128,0)
|
---|
| 1642 | . S NEWTEMP=1
|
---|
| 1643 | "RTN","VWREGIT3",129,0)
|
---|
| 1644 | ;Primary fields
|
---|
| 1645 | "RTN","VWREGIT3",130,0)
|
---|
| 1646 | ;K DATA,^DIE(TNUM,"DR")
|
---|
| 1647 | "RTN","VWREGIT3",131,0)
|
---|
| 1648 | K DATA,^UTILITY("DIETED",$J),^UTILITY("DIETEDIAB",$J)
|
---|
| 1649 | "RTN","VWREGIT3",132,0)
|
---|
| 1650 | K AR S N=0 F S N=$O(FLDS(N)) Q:'+N S X=$$PARSE(FLDS(N)) S:$L(X) AR(N)=X
|
---|
| 1651 | "RTN","VWREGIT3",133,0)
|
---|
| 1652 | S FX="",N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
| 1653 | "RTN","VWREGIT3",134,0)
|
---|
| 1654 | . I AR(N)'["~" S FX=FX_AR(N)_";" Q
|
---|
| 1655 | "RTN","VWREGIT3",135,0)
|
---|
| 1656 | . S FLDN=+$P(AR(N),"~")
|
---|
| 1657 | "RTN","VWREGIT3",136,0)
|
---|
| 1658 | . S PREFLAB=$P($P(AR(N),FLDN,2),"~")
|
---|
| 1659 | "RTN","VWREGIT3",137,0)
|
---|
| 1660 | . S FX=FX_FLDN_$S($L(PREFLAB):PREFLAB_"~",1:"")_";"
|
---|
| 1661 | "RTN","VWREGIT3",138,0)
|
---|
| 1662 | S ^UTILITY("DIETED",$J,1,2)=FX
|
---|
| 1663 | "RTN","VWREGIT3",139,0)
|
---|
| 1664 | ;Set up the preferred labels
|
---|
| 1665 | "RTN","VWREGIT3",140,0)
|
---|
| 1666 | S N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
| 1667 | "RTN","VWREGIT3",141,0)
|
---|
| 1668 | . S LABS=$P(AR(N),"~",2) Q:'$L(LABS)
|
---|
| 1669 | "RTN","VWREGIT3",142,0)
|
---|
| 1670 | . S ^UTILITY("DIETEDIAB",$J,N,0,2,0)=$P(LABS,"^")_";"_""""_$P(LABS,"^",2)_""""
|
---|
| 1671 | "RTN","VWREGIT3",143,0)
|
---|
| 1672 | Q ;TESTING
|
---|
| 1673 | "RTN","VWREGIT3",144,0)
|
---|
| 1674 | ;Sub-fields of primaries
|
---|
| 1675 | "RTN","VWREGIT3",145,0)
|
---|
| 1676 | K AR
|
---|
| 1677 | "RTN","VWREGIT3",146,0)
|
---|
| 1678 | S N=0 F S N=$O(FLDS(N)) Q:'+N Q:$E(FLDS(N))=">"
|
---|
| 1679 | "RTN","VWREGIT3",147,0)
|
---|
| 1680 | G REGIT:'+N ;No sub-fields found for primaries
|
---|
| 1681 | "RTN","VWREGIT3",148,0)
|
---|
| 1682 | S N=$G(N)-1 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">"
|
---|
| 1683 | "RTN","VWREGIT3",149,0)
|
---|
| 1684 | . S PIECE=$L(FLDS(N),"(")
|
---|
| 1685 | "RTN","VWREGIT3",150,0)
|
---|
| 1686 | . S X=$P($P(FLDS(N),"(",PIECE),")")
|
---|
| 1687 | "RTN","VWREGIT3",151,0)
|
---|
| 1688 | . S SUBDIC=+$P(X,";",2),SUBFLD=+$P(X,";")
|
---|
| 1689 | "RTN","VWREGIT3",152,0)
|
---|
| 1690 | . I '$D(AR(SUBDIC)) S AR(SUBDIC)=""
|
---|
| 1691 | "RTN","VWREGIT3",153,0)
|
---|
| 1692 | . S AR(SUBDIC)=AR(SUBDIC)_SUBFLD_";"
|
---|
| 1693 | "RTN","VWREGIT3",154,0)
|
---|
| 1694 | M ^DIE(TNUM,"DR",2)=AR
|
---|
| 1695 | "RTN","VWREGIT3",155,0)
|
---|
| 1696 | REGIT I NEWTEMP D ;Update HD/regit.txt
|
---|
| 1697 | "RTN","VWREGIT3",156,0)
|
---|
| 1698 | . S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
| 1699 | "RTN","VWREGIT3",157,0)
|
---|
| 1700 | . S FILE="regit.txt"
|
---|
| 1701 | "RTN","VWREGIT3",158,0)
|
---|
| 1702 | . S P4=1
|
---|
| 1703 | "RTN","VWREGIT3",159,0)
|
---|
| 1704 | . S P5=""
|
---|
| 1705 | "RTN","VWREGIT3",160,0)
|
---|
| 1706 | . S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
|
---|
| 1707 | "RTN","VWREGIT3",161,0)
|
---|
| 1708 | . S N=0 F S N=$O(AR(N)) Q:'+N Q:AR(N)["[ID"
|
---|
| 1709 | "RTN","VWREGIT3",162,0)
|
---|
| 1710 | . K AR(N) S AR(N)=TNAME_"("_IEN(1)_")"
|
---|
| 1711 | "RTN","VWREGIT3",163,0)
|
---|
| 1712 | . S AR(N+1)="[ID]"
|
---|
| 1713 | "RTN","VWREGIT3",164,0)
|
---|
| 1714 | . ZWR AR
|
---|
| 1715 | "RTN","VWREGIT3",165,0)
|
---|
| 1716 | . S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt")
|
---|
| 1717 | "RTN","VWREGIT3",166,0)
|
---|
| 1718 | SOUT S RESULT(0)=$S($G(IEN(1)):TNAME_"("_IEN(1)_")",1:-1)
|
---|
| 1719 | "RTN","VWREGIT3",167,0)
|
---|
| 1720 | Q
|
---|
| 1721 | "RTN","VWREGIT3",168,0)
|
---|
| 1722 | ;
|
---|
| 1723 | "RTN","VWREGIT3",169,0)
|
---|
| 1724 | HELP(RESULT,DATA) ;Get help for Fileman Fields
|
---|
| 1725 | "RTN","VWREGIT3",170,0)
|
---|
| 1726 | ; ***************************************************
|
---|
| 1727 | "RTN","VWREGIT3",171,0)
|
---|
| 1728 | ; *Incoming DATA__FILE^IEN[O]^FIELD^FLAGS^MSG_ROOT) *
|
---|
| 1729 | "RTN","VWREGIT3",172,0)
|
---|
| 1730 | ; ***************************************************
|
---|
| 1731 | "RTN","VWREGIT3",173,0)
|
---|
| 1732 | K RESULT,@$P(DATA,"^",5)
|
---|
| 1733 | "RTN","VWREGIT3",174,0)
|
---|
| 1734 | N FILE,IEN,FLD,FLAGS,X
|
---|
| 1735 | "RTN","VWREGIT3",175,0)
|
---|
| 1736 | S X="FILE^IEN^FLD^FLAGS"
|
---|
| 1737 | "RTN","VWREGIT3",176,0)
|
---|
| 1738 | F I=1:1:4 S @$P(X,"^",I)=$P(DATA,"^",I)
|
---|
| 1739 | "RTN","VWREGIT3",177,0)
|
---|
| 1740 | D HELP^DIE(FILE,IEN,FLD,FLAGS,$P(DATA,"^",5))
|
---|
| 1741 | "RTN","VWREGIT3",178,0)
|
---|
| 1742 | F I=1:1:AR("DIHELP") S RESULT(I)=AR("DIHELP",I)
|
---|
| 1743 | "RTN","VWREGIT3",179,0)
|
---|
| 1744 | K @$P(DATA,"^",5),DATA
|
---|
| 1745 | "RTN","VWREGIT3",180,0)
|
---|
| 1746 | Q
|
---|
| 1747 | "RTN","VWREGIT3",181,0)
|
---|
| 1748 | ;
|
---|
| 1749 | "RTN","VWREGIT3",182,0)
|
---|
| 1750 | FP(RESULT,FLDS) ;Disassociated kids
|
---|
| 1751 | "RTN","VWREGIT3",183,0)
|
---|
| 1752 | ;W " ;Intentional "instantiated" failure
|
---|
| 1753 | "RTN","VWREGIT3",184,0)
|
---|
| 1754 | K RESULT,PAR
|
---|
| 1755 | "RTN","VWREGIT3",185,0)
|
---|
| 1756 | N N,FIELD,SUBDIC,PARENT,X
|
---|
| 1757 | "RTN","VWREGIT3",186,0)
|
---|
| 1758 | S N=0 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">"
|
---|
| 1759 | "RTN","VWREGIT3",187,0)
|
---|
| 1760 | . S FIELD=$P($P(FLDS(N),"(",2),";")
|
---|
| 1761 | "RTN","VWREGIT3",188,0)
|
---|
| 1762 | . S SUBDIC=$P($P(FLDS(N),";",2),")")
|
---|
| 1763 | "RTN","VWREGIT3",189,0)
|
---|
| 1764 | . S PARENT=$O(^DD(2,"SB",SUBDIC,0))
|
---|
| 1765 | "RTN","VWREGIT3",190,0)
|
---|
| 1766 | . Q:'PARENT
|
---|
| 1767 | "RTN","VWREGIT3",191,0)
|
---|
| 1768 | . S PAR(PARENT)=$P(^DD(2,PARENT,0),"^")_"("_PARENT_")~(Multiple)"
|
---|
| 1769 | "RTN","VWREGIT3",192,0)
|
---|
| 1770 | . S PAR(PARENT,$O(PAR(PARENT," "),-1)+1)=FLDS(N)
|
---|
| 1771 | "RTN","VWREGIT3",193,0)
|
---|
| 1772 | . K FLDS(N)
|
---|
| 1773 | "RTN","VWREGIT3",194,0)
|
---|
| 1774 | S X="PAR" F S X=$Q(@X) Q:X="" S FLDS($$NEXT(.FLDS))=@X
|
---|
| 1775 | "RTN","VWREGIT3",195,0)
|
---|
| 1776 | K PAR
|
---|
| 1777 | "RTN","VWREGIT3",196,0)
|
---|
| 1778 | S N=0 F S N=$O(FLDS(N)) Q:'+N S RESULT($$NEXT(.RESULT))=FLDS(N)
|
---|
| 1779 | "RTN","VWREGIT3",197,0)
|
---|
| 1780 | K FLDS
|
---|
| 1781 | "RTN","VWREGIT3",198,0)
|
---|
| 1782 | Q
|
---|
| 1783 | "RTN","VWREGIT3",199,0)
|
---|
| 1784 | ;
|
---|
| 1785 | "RTN","VWREGIT4")
|
---|
| 1786 | 0^11^B43791810
|
---|
| 1787 | "RTN","VWREGIT4",1,0)
|
---|
| 1788 | VWREGIT4 ;VWEHR/BFPro-Jim Bell, et al-World VistA Patient Registration Utility
|
---|
| 1789 | "RTN","VWREGIT4",2,0)
|
---|
| 1790 | ;;1.0;WorldVistA;BellFelder Productions;** **;Build 1;
|
---|
| 1791 | "RTN","VWREGIT4",3,0)
|
---|
| 1792 | ;
|
---|
| 1793 | "RTN","VWREGIT4",4,0)
|
---|
| 1794 | ;This routine utility is for all known patient data fields
|
---|
| 1795 | "RTN","VWREGIT4",5,0)
|
---|
| 1796 | ;
|
---|
| 1797 | "RTN","VWREGIT4",6,0)
|
---|
| 1798 | ;GNU License: See WVLIC.txt
|
---|
| 1799 | "RTN","VWREGIT4",7,0)
|
---|
| 1800 | ;Modified FOIA VISTA,
|
---|
| 1801 | "RTN","VWREGIT4",8,0)
|
---|
| 1802 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
| 1803 | "RTN","VWREGIT4",9,0)
|
---|
| 1804 | Q
|
---|
| 1805 | "RTN","VWREGIT4",10,0)
|
---|
| 1806 | ;
|
---|
| 1807 | "RTN","VWREGIT4",11,0)
|
---|
| 1808 | INR() Q $O(RESULT(" "),-1)+1
|
---|
| 1809 | "RTN","VWREGIT4",12,0)
|
---|
| 1810 | ;
|
---|
| 1811 | "RTN","VWREGIT4",13,0)
|
---|
| 1812 | CLEAN ;Remove VA Specific nodes
|
---|
| 1813 | "RTN","VWREGIT4",14,0)
|
---|
| 1814 | ;S X="AR" F S X=$Q(@X) Q:X="" I $P(X,",",$L(X,",")-1)["<LABEL HERE>" K @X
|
---|
| 1815 | "RTN","VWREGIT4",15,0)
|
---|
| 1816 | ;COMPONENTS
|
---|
| 1817 | "RTN","VWREGIT4",16,0)
|
---|
| 1818 | ;ENTERED BY
|
---|
| 1819 | "RTN","VWREGIT4",17,0)
|
---|
| 1820 | ;NEXT AVA. APPT. INDICATOR
|
---|
| 1821 | "RTN","VWREGIT4",18,0)
|
---|
| 1822 | ;DATA ENTRY CLERK
|
---|
| 1823 | "RTN","VWREGIT4",19,0)
|
---|
| 1824 | ;DESIRED DATE OF APPOINTMENT
|
---|
| 1825 | "RTN","VWREGIT4",20,0)
|
---|
| 1826 | ;DATE APPT. MADE
|
---|
| 1827 | "RTN","VWREGIT4",21,0)
|
---|
| 1828 | Q
|
---|
| 1829 | "RTN","VWREGIT4",22,0)
|
---|
| 1830 | ;
|
---|
| 1831 | "RTN","VWREGIT4",23,0)
|
---|
| 1832 | DEMOG(RESULT,IDATA) ;
|
---|
| 1833 | "RTN","VWREGIT4",24,0)
|
---|
| 1834 | K RESULT
|
---|
| 1835 | "RTN","VWREGIT4",25,0)
|
---|
| 1836 | Q:'$L(IDATA)
|
---|
| 1837 | "RTN","VWREGIT4",26,0)
|
---|
| 1838 | S XFN=$P(IDATA,"^")
|
---|
| 1839 | "RTN","VWREGIT4",27,0)
|
---|
| 1840 | S PAT=+$P(IDATA,"^",2)
|
---|
| 1841 | "RTN","VWREGIT4",28,0)
|
---|
| 1842 | Q:'PAT!('XFN) ;Huh? No patient! No File!
|
---|
| 1843 | "RTN","VWREGIT4",29,0)
|
---|
| 1844 | D GETS^DIQ(XFN,PAT_",","**","NIER","AR","ERR")
|
---|
| 1845 | "RTN","VWREGIT4",30,0)
|
---|
| 1846 | ;
|
---|
| 1847 | "RTN","VWREGIT4",31,0)
|
---|
| 1848 | N X,Y,AGE,XAGE,XDATA,XX,XPID,IDOB,DOB,LINE
|
---|
| 1849 | "RTN","VWREGIT4",32,0)
|
---|
| 1850 | I '$G(DT) S X="T" D ^%DT S DT=Y
|
---|
| 1851 | "RTN","VWREGIT4",33,0)
|
---|
| 1852 | DID S XDATA=""
|
---|
| 1853 | "RTN","VWREGIT4",34,0)
|
---|
| 1854 | ;Q ;testing
|
---|
| 1855 | "RTN","VWREGIT4",35,0)
|
---|
| 1856 | S $P(LINE,"-",78)=""
|
---|
| 1857 | "RTN","VWREGIT4",36,0)
|
---|
| 1858 | F I="NAME","PRIMARY LONG ID","DATE OF BIRTH","SEX" D
|
---|
| 1859 | "RTN","VWREGIT4",37,0)
|
---|
| 1860 | . I I="NAME" S XDATA=$G(AR(XFN,PAT_",",I,"E")) Q
|
---|
| 1861 | "RTN","VWREGIT4",38,0)
|
---|
| 1862 | . I I="PRIMARY LONG ID" S XPID=$G(AR(XFN,PAT_",",I,"E")) D Q
|
---|
| 1863 | "RTN","VWREGIT4",39,0)
|
---|
| 1864 | .. S XX=$E(XPID,1,$L(XPID)-4)
|
---|
| 1865 | "RTN","VWREGIT4",40,0)
|
---|
| 1866 | .. S XX=$TR(XX,"0123456789","#")
|
---|
| 1867 | "RTN","VWREGIT4",41,0)
|
---|
| 1868 | .. S XPID=XX_$E(XPID,$L(XPID)-3,$L(XPID))
|
---|
| 1869 | "RTN","VWREGIT4",42,0)
|
---|
| 1870 | .. S $P(XDATA," ",2)="IDN: "_XPID
|
---|
| 1871 | "RTN","VWREGIT4",43,0)
|
---|
| 1872 | . I I="DATE OF BIRTH" S DOB=$G(AR(PAT,XFN,PAT_",",I,"E")) D S $P(XDATA," ",3)="DOB: "_DOB_" ("_AGE_" old "_$G(AR(XFN,PAT_",","SEX","E"))_")" Q
|
---|
| 1873 | "RTN","VWREGIT4",44,0)
|
---|
| 1874 | .. S IDOB=$G(AR(XFN,PAT_",",I,"I"))
|
---|
| 1875 | "RTN","VWREGIT4",45,0)
|
---|
| 1876 | .. S DOBT=$G(AR(XFN,PAT_",",540000.1))
|
---|
| 1877 | "RTN","VWREGIT4",46,0)
|
---|
| 1878 | .. Q:'IDOB&'DOBT
|
---|
| 1879 | "RTN","VWREGIT4",47,0)
|
---|
| 1880 | .. S X1=DT,X2=IDOB D ^%DTC
|
---|
| 1881 | "RTN","VWREGIT4",48,0)
|
---|
| 1882 | .. I X=0,DOBT D S AGE=HOURS+MIN_" Hours"
|
---|
| 1883 | "RTN","VWREGIT4",49,0)
|
---|
| 1884 | ... S HOURS=$E($P(DOBT,".",2),1,2)
|
---|
| 1885 | "RTN","VWREGIT4",50,0)
|
---|
| 1886 | ... S MIN=$E($P(DOBT,".",2),3,99)/60
|
---|
| 1887 | "RTN","VWREGIT4",51,0)
|
---|
| 1888 | .. I X=0,'DOBT S XAGE=$P($H,",",2)/60/60,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Hours" Q
|
---|
| 1889 | "RTN","VWREGIT4",52,0)
|
---|
| 1890 | .. S AGE=$S(X<60:X_" Days",1:"")
|
---|
| 1891 | "RTN","VWREGIT4",53,0)
|
---|
| 1892 | .. I 'AGE,X<365 S XAGE=X/30.4,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Months"
|
---|
| 1893 | "RTN","VWREGIT4",54,0)
|
---|
| 1894 | .. I 'AGE S XAGE=X/365.25,AGE=$P(XAGE,".")_$E($P(XAGE,".",2))_" Years"
|
---|
| 1895 | "RTN","VWREGIT4",55,0)
|
---|
| 1896 | S RESULT(0)=XDATA
|
---|
| 1897 | "RTN","VWREGIT4",56,0)
|
---|
| 1898 | ADD D S RESULT($$INR)="Address: "_ST1
|
---|
| 1899 | "RTN","VWREGIT4",57,0)
|
---|
| 1900 | . S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (CIVIL)","E"))
|
---|
| 1901 | "RTN","VWREGIT4",58,0)
|
---|
| 1902 | . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
|
---|
| 1903 | "RTN","VWREGIT4",59,0)
|
---|
| 1904 | . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
|
---|
| 1905 | "RTN","VWREGIT4",60,0)
|
---|
| 1906 | . Q:'$l(ST1)
|
---|
| 1907 | "RTN","VWREGIT4",61,0)
|
---|
| 1908 | . S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 2 (CIVIL)","E"))
|
---|
| 1909 | "RTN","VWREGIT4",62,0)
|
---|
| 1910 | . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
|
---|
| 1911 | "RTN","VWREGIT4",63,0)
|
---|
| 1912 | . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
|
---|
| 1913 | "RTN","VWREGIT4",64,0)
|
---|
| 1914 | . S ST1=ST1_" "_ST2_", "
|
---|
| 1915 | "RTN","VWREGIT4",65,0)
|
---|
| 1916 | . S CIT=$G(AR(XFN,PAT_",","CITY (CIVIL)","E"))
|
---|
| 1917 | "RTN","VWREGIT4",66,0)
|
---|
| 1918 | . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY (VA)","E"))
|
---|
| 1919 | "RTN","VWREGIT4",67,0)
|
---|
| 1920 | . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY","E"))
|
---|
| 1921 | "RTN","VWREGIT4",68,0)
|
---|
| 1922 | . S ST1=ST1_$S('$L(CIT):"<City not listed>",1:CIT)_", "
|
---|
| 1923 | "RTN","VWREGIT4",69,0)
|
---|
| 1924 | . S STATE=$G(AR(XFN,PAT_",","STATE (CIVIL)","E"))
|
---|
| 1925 | "RTN","VWREGIT4",70,0)
|
---|
| 1926 | . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE (VA)","E"))
|
---|
| 1927 | "RTN","VWREGIT4",71,0)
|
---|
| 1928 | . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE","E"))
|
---|
| 1929 | "RTN","VWREGIT4",72,0)
|
---|
| 1930 | . S ST1=ST1_$S('$L(STATE):"<State/province not listed>",1:STATE)
|
---|
| 1931 | "RTN","VWREGIT4",73,0)
|
---|
| 1932 | . S PC=$G(AR(XFN,PAT_",","POSTAL CODE","E"))
|
---|
| 1933 | "RTN","VWREGIT4",74,0)
|
---|
| 1934 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (CIVIL)","E"))
|
---|
| 1935 | "RTN","VWREGIT4",75,0)
|
---|
| 1936 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (VA)","E"))
|
---|
| 1937 | "RTN","VWREGIT4",76,0)
|
---|
| 1938 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP CODE","E"))
|
---|
| 1939 | "RTN","VWREGIT4",77,0)
|
---|
| 1940 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (VA)","E"))
|
---|
| 1941 | "RTN","VWREGIT4",78,0)
|
---|
| 1942 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (CIVIL)","E"))
|
---|
| 1943 | "RTN","VWREGIT4",79,0)
|
---|
| 1944 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4","E"))
|
---|
| 1945 | "RTN","VWREGIT4",80,0)
|
---|
| 1946 | . S ST1=ST1_" "_PC
|
---|
| 1947 | "RTN","VWREGIT4",81,0)
|
---|
| 1948 | S RESULT($$INR)=LINE
|
---|
| 1949 | "RTN","VWREGIT4",82,0)
|
---|
| 1950 | NOK D S RESULT($$INR)="Next of Kin: "_$S($L(NK):NK,1:"<No listing>")
|
---|
| 1951 | "RTN","VWREGIT4",83,0)
|
---|
| 1952 | . S NK="" Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
|
---|
| 1953 | "RTN","VWREGIT4",84,0)
|
---|
| 1954 | . S NK=$G(AR(XFN,PAT_",","K-NAME OF PRIMARY NOK","E"))
|
---|
| 1955 | "RTN","VWREGIT4",85,0)
|
---|
| 1956 | . S NKDAT=$G(AR(XFN,PAT_",","K-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
|
---|
| 1957 | "RTN","VWREGIT4",86,0)
|
---|
| 1958 | . S NKDAT=$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 1]","E"))
|
---|
| 1959 | "RTN","VWREGIT4",87,0)
|
---|
| 1960 | . I $L($G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))
|
---|
| 1961 | "RTN","VWREGIT4",88,0)
|
---|
| 1962 | . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
|
---|
| 1963 | "RTN","VWREGIT4",89,0)
|
---|
| 1964 | D I $L($G(NK)) S RESULT($$INR)="Next of Kin: "_NK
|
---|
| 1965 | "RTN","VWREGIT4",90,0)
|
---|
| 1966 | . Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
|
---|
| 1967 | "RTN","VWREGIT4",91,0)
|
---|
| 1968 | . Q:'$L($G(AR(XFN,PAT_",","K2-NAME","E")))
|
---|
| 1969 | "RTN","VWREGIT4",92,0)
|
---|
| 1970 | . S NK=$G(AR(XFN,PAT_",","K2-NAME OF PRIMARY NOK","E"))
|
---|
| 1971 | "RTN","VWREGIT4",93,0)
|
---|
| 1972 | . S NKDAT=$G(AR(XFN,PAT_",","K2-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
|
---|
| 1973 | "RTN","VWREGIT4",94,0)
|
---|
| 1974 | . S NKDAT=$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 1]","E"))
|
---|
| 1975 | "RTN","VWREGIT4",95,0)
|
---|
| 1976 | . I $L($G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))
|
---|
| 1977 | "RTN","VWREGIT4",96,0)
|
---|
| 1978 | . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
|
---|
| 1979 | "RTN","VWREGIT4",97,0)
|
---|
| 1980 | ICE ;
|
---|
| 1981 | "RTN","VWREGIT4",98,0)
|
---|
| 1982 | I '$L($G(AR(XFN,PAT_",","E-NAME","E"))) S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_"<No listing>" G ICEOUT
|
---|
| 1983 | "RTN","VWREGIT4",99,0)
|
---|
| 1984 | S ICE=$G(AR(XFN,PAT_",","E-NAME","E"))
|
---|
| 1985 | "RTN","VWREGIT4",100,0)
|
---|
| 1986 | S EADD=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 1]","E"))
|
---|
| 1987 | "RTN","VWREGIT4",101,0)
|
---|
| 1988 | S EAD2=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 2]","E"))
|
---|
| 1989 | "RTN","VWREGIT4",102,0)
|
---|
| 1990 | S ECITY=$G(AR(XFN,PAT_",","E-CITY","E"))
|
---|
| 1991 | "RTN","VWREGIT4",103,0)
|
---|
| 1992 | S ESTATE=$G(AR(XFN,PAT_",","E-STATE","E"))
|
---|
| 1993 | "RTN","VWREGIT4",104,0)
|
---|
| 1994 | S EZIP=$G(AR(XFN,PAT_",","E-ZIP+4","E"))
|
---|
| 1995 | "RTN","VWREGIT4",105,0)
|
---|
| 1996 | S IPHONE=$G(AR(XFN,PAT_",","E-PHONE NUMBER","E"))
|
---|
| 1997 | "RTN","VWREGIT4",106,0)
|
---|
| 1998 | S WPHONE=$G(AR(XFN,PAT_",","E-WORK PHONE NUMBER","E"))
|
---|
| 1999 | "RTN","VWREGIT4",107,0)
|
---|
| 2000 | S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_ICE
|
---|
| 2001 | "RTN","VWREGIT4",108,0)
|
---|
| 2002 | S RESULT($$INR)=$J("Address: ",$L("NEXT OF KIN: "))_$S($L(EADD):EADD_$S($L(EAD2):" "_EAD2,1:""),1:"<No listing>")
|
---|
| 2003 | "RTN","VWREGIT4",109,0)
|
---|
| 2004 | S RESULT($$INR)=$J("City: ",$L("NEXT OF KIN: "))_ECITY
|
---|
| 2005 | "RTN","VWREGIT4",110,0)
|
---|
| 2006 | S RESULT($$INR)=$J("State: ",$L("NEXT OF KIN: "))_ESTATE
|
---|
| 2007 | "RTN","VWREGIT4",111,0)
|
---|
| 2008 | S RESULT($$INR)=$J("Zip: ",$L("NEXT OF KIN: "))_EZIP
|
---|
| 2009 | "RTN","VWREGIT4",112,0)
|
---|
| 2010 | S RESULT($$INR)=$J("Phone: ",$L("NEXT OF KIN: "))_IPHONE
|
---|
| 2011 | "RTN","VWREGIT4",113,0)
|
---|
| 2012 | S RESULT($$INR)=$J("Work: ",$L("NEXT OF KIN: "))_WPHONE
|
---|
| 2013 | "RTN","VWREGIT4",114,0)
|
---|
| 2014 | ICEOUT S RESULT($$INR)=LINE
|
---|
| 2015 | "RTN","VWREGIT4",115,0)
|
---|
| 2016 | INS D S RESULT($$INR)="Insurance/Coverage: "_$S($L(IC):IC,1:"<No listing>")
|
---|
| 2017 | "RTN","VWREGIT4",116,0)
|
---|
| 2018 | . K AR(2.312) ;Get it from the horse's mouth
|
---|
| 2019 | "RTN","VWREGIT4",117,0)
|
---|
| 2020 | . S IC="" S N=0 F S N=$O(^DPT(PAT,.312,N)) Q:'+N S IC=IC_$P(^DIC(36,+^(N,0),0),"^")_$S($O(^DPT(PAT,.312,N)):", ",1:"")
|
---|
| 2021 | "RTN","VWREGIT4",118,0)
|
---|
| 2022 | S RESULT($$INR)=LINE
|
---|
| 2023 | "RTN","VWREGIT4",119,0)
|
---|
| 2024 | ER S HEADER="Walk-in/ER",$P(HEADER," ",2)="Date/Time"
|
---|
| 2025 | "RTN","VWREGIT4",120,0)
|
---|
| 2026 | S $P(HEADER," ",3)="Type of Benefit"
|
---|
| 2027 | "RTN","VWREGIT4",121,0)
|
---|
| 2028 | S RESULT($$INR)=HEADER
|
---|
| 2029 | "RTN","VWREGIT4",122,0)
|
---|
| 2030 | S N=0 F S N=$O(^DPT(PAT,"DIS",N)) Q:'+N S XDIS=^(N,0) D
|
---|
| 2031 | "RTN","VWREGIT4",123,0)
|
---|
| 2032 | . S Y=+XDIS X ^DD("DD") S $P(WER," ",2)=Y
|
---|
| 2033 | "RTN","VWREGIT4",124,0)
|
---|
| 2034 | . S $P(WER," ",3)=$P($P($P(^DD(2.101,2,0),"^",3),";",$P(XDIS,"^",3)),":",2),RESULT($$INR)=WER,WER=""
|
---|
| 2035 | "RTN","VWREGIT4",125,0)
|
---|
| 2036 | S RESULT($$INR)=WER
|
---|
| 2037 | "RTN","VWREGIT4",126,0)
|
---|
| 2038 | S RESULT($$INR)=LINE
|
---|
| 2039 | "RTN","VWREGIT4",127,0)
|
---|
| 2040 | APPT S HEADER="Sched. Appts",$P(HEADER," ",2)="Date/Time",$P(HEADER," ",3)="Clinic"
|
---|
| 2041 | "RTN","VWREGIT4",128,0)
|
---|
| 2042 | S RESULT($$INR)=HEADER
|
---|
| 2043 | "RTN","VWREGIT4",129,0)
|
---|
| 2044 | S N=0 F S N=$O(^DPT(PAT,"S",N)) Q:'+N S XDIS=^(N,0) D
|
---|
| 2045 | "RTN","VWREGIT4",130,0)
|
---|
| 2046 | . S Y=N X ^DD("DD") S $P(WER," ",2)=Y
|
---|
| 2047 | "RTN","VWREGIT4",131,0)
|
---|
| 2048 | . S $P(WER," ",3)=$P(^SC(+XDIS,0),"^")
|
---|
| 2049 | "RTN","VWREGIT4",132,0)
|
---|
| 2050 | . S RESULT($$INR)=WER
|
---|
| 2051 | "RTN","VWREGIT4",133,0)
|
---|
| 2052 | S RESULT($$INR)=LINE
|
---|
| 2053 | "RTN","VWREGIT4",134,0)
|
---|
| 2054 | ADM S HEADER="Admit",$P(HEADER," ",2)="Discharge"
|
---|
| 2055 | "RTN","VWREGIT4",135,0)
|
---|
| 2056 | S RESULT($$INR)=HEADER
|
---|
| 2057 | "RTN","VWREGIT4",136,0)
|
---|
| 2058 | K WER
|
---|
| 2059 | "RTN","VWREGIT4",137,0)
|
---|
| 2060 | S N=0 F S N=$O(^DGPM("C",PAT,N)) Q:'+N S XDIS=^(N,0) D
|
---|
| 2061 | "RTN","VWREGIT4",138,0)
|
---|
| 2062 | . S Y=+XDIS X ^DD("DD") S WER=Y
|
---|
| 2063 | "RTN","VWREGIT4",139,0)
|
---|
| 2064 | . S DMOV=$P(XDIS,"^",17)
|
---|
| 2065 | "RTN","VWREGIT4",140,0)
|
---|
| 2066 | . S:DMOV Y=+^DGPM(DMOV,0) X ^DD("DD") S $P(WER," ",2)=Y
|
---|
| 2067 | "RTN","VWREGIT4",141,0)
|
---|
| 2068 | . S RESULT($$INR)=WER,WER=""
|
---|
| 2069 | "RTN","VWREGIT4",142,0)
|
---|
| 2070 | I '$L($G(WER)) S RESULT($$INR)="No admissions of file"
|
---|
| 2071 | "RTN","VWREGIT4",143,0)
|
---|
| 2072 | S RESULT($$INR)=LINE
|
---|
| 2073 | "RTN","VWREGIT4",144,0)
|
---|
| 2074 | XIT K AR,CIT,DIC,DOBT,EAD2,EADD,ECITY,ESTATE,EZIP,HEADER,I,IC,ICE
|
---|
| 2075 | "RTN","VWREGIT4",145,0)
|
---|
| 2076 | K IPHONE,N,NK,PAT,PC,XFN,ST1,ST2,STATE,WPHONE
|
---|
| 2077 | "RTN","VWREGIT4",146,0)
|
---|
| 2078 | Q
|
---|
| 2079 | "VER")
|
---|
| 2080 | 8.0^22.0
|
---|
| 2081 | **END**
|
---|
| 2082 | **END**
|
---|