source: mu-stage1-reg-changes/VW_MU_REG_2P0.KID@ 1593

Last change on this file since 1593 was 1593, checked in by Sam Habiel, 12 years ago

Adding registration changes for WorldVistA 2.0 for meeting MU Stage 1.

File size: 111.5 KB
Line 
1KIDS Distribution saved on Nov 07, 2012@17:05:19
2FINAL MU STAGE 1 REG BUILD
3**KIDS**:VW MU REG 2.0^
4
5**INSTALL NAME**
6VW MU REG 2.0
7"BLD",7943,0)
8VW MU REG 2.0^^0^3121107^n
9"BLD",7943,1,0)
10^^10^10^3121107^
11"BLD",7943,1,1,0)
12Created by Sam Habiel. Created on October 4th 2012.
13"BLD",7943,1,2,0)
14
15"BLD",7943,1,3,0)
16License: GPL v2.
17"BLD",7943,1,4,0)
18
19"BLD",7943,1,5,0)
20Description:
21"BLD",7943,1,6,0)
22Adds all MU Registration Fields to WV and changes the registration
23"BLD",7943,1,7,0)
24routines to use them.
25"BLD",7943,1,8,0)
26
27"BLD",7943,1,9,0)
28Full documentation can be found here:
29"BLD",7943,1,10,0)
30http://www.vistapedia.com/index.php/MU_Stage_1_Registration_Enhancements
31"BLD",7943,4,0)
32^9.64PA^200^2
33"BLD",7943,4,2,0)
342
35"BLD",7943,4,2,2,0)
36^9.641^2.0256001^2
37"BLD",7943,4,2,2,2,0)
38PATIENT (File-top level)
39"BLD",7943,4,2,2,2,1,0)
40^9.6411^.351^3
41"BLD",7943,4,2,2,2,1,.351,0)
42DATE OF DEATH
43"BLD",7943,4,2,2,2,1,250043.1,0)
44PRELIMINARY CAUSE OF DEATH
45"BLD",7943,4,2,2,2,1,256000,0)
46LANGUAGE PREFERENCE
47"BLD",7943,4,2,2,2.0256001,0)
48LANGUAGE SKILLS (sub-file)
49"BLD",7943,4,2,2,2.0256001,1,0)
50^9.6411^^0
51"BLD",7943,4,2,222)
52y^n^p^^^^n^^n
53"BLD",7943,4,2,224)
54
55"BLD",7943,4,200,0)
56200
57"BLD",7943,4,200,2,0)
58^9.641^200.0256001^2
59"BLD",7943,4,200,2,200,0)
60NEW PERSON (File-top level)
61"BLD",7943,4,200,2,200,1,0)
62^9.6411^256000^1
63"BLD",7943,4,200,2,200,1,256000,0)
64PREFERRED LANGUAGE
65"BLD",7943,4,200,2,200.0256001,0)
66LANGUAGE SKILLS (sub-file)
67"BLD",7943,4,200,2,200.0256001,1,0)
68^9.6411^^
69"BLD",7943,4,200,222)
70y^n^p^^^^n^^n
71"BLD",7943,4,200,224)
72
73"BLD",7943,4,"APDD",2,2)
74
75"BLD",7943,4,"APDD",2,2,.351)
76
77"BLD",7943,4,"APDD",2,2,250043.1)
78
79"BLD",7943,4,"APDD",2,2,256000)
80
81"BLD",7943,4,"APDD",2,2.0256001)
82
83"BLD",7943,4,"APDD",200,200)
84
85"BLD",7943,4,"APDD",200,200,256000)
86
87"BLD",7943,4,"APDD",200,200.0256001)
88
89"BLD",7943,4,"B",2,2)
90
91"BLD",7943,4,"B",200,200)
92
93"BLD",7943,6.3)
9418
95"BLD",7943,"INIT")
96POST^VWREGPI
97"BLD",7943,"KRN",0)
98^9.67PA^779.2^20
99"BLD",7943,"KRN",.4,0)
100.4
101"BLD",7943,"KRN",.401,0)
102.401
103"BLD",7943,"KRN",.402,0)
104.402
105"BLD",7943,"KRN",.402,"NM",0)
106^9.68A^2^2
107"BLD",7943,"KRN",.402,"NM",1,0)
108VW LOCAL REGISTRATION TEMPLATE FILE #2^2^0
109"BLD",7943,"KRN",.402,"NM",2,0)
110VW PRELIMINARY CAUSE OF DEATH FILE #2^2^0
111"BLD",7943,"KRN",.402,"NM","B","VW LOCAL REGISTRATION TEMPLATE FILE #2",1)
112
113"BLD",7943,"KRN",.402,"NM","B","VW PRELIMINARY CAUSE OF DEATH FILE #2",2)
114
115"BLD",7943,"KRN",.403,0)
116.403
117"BLD",7943,"KRN",.5,0)
118.5
119"BLD",7943,"KRN",.84,0)
120.84
121"BLD",7943,"KRN",3.6,0)
1223.6
123"BLD",7943,"KRN",3.8,0)
1243.8
125"BLD",7943,"KRN",9.2,0)
1269.2
127"BLD",7943,"KRN",9.8,0)
1289.8
129"BLD",7943,"KRN",9.8,"NM",0)
130^9.68A^8^8
131"BLD",7943,"KRN",9.8,"NM",1,0)
132DGREG^^0^B78971450
133"BLD",7943,"KRN",9.8,"NM",2,0)
134DG10^^0^B27855507
135"BLD",7943,"KRN",9.8,"NM",3,0)
136VWUTIL^^0^B42164756
137"BLD",7943,"KRN",9.8,"NM",4,0)
138ORCXPND1^^0^B74010927
139"BLD",7943,"KRN",9.8,"NM",5,0)
140DGRPD^^0^B87299590
141"BLD",7943,"KRN",9.8,"NM",6,0)
142DGDEATH^^0^B43242813
143"BLD",7943,"KRN",9.8,"NM",7,0)
144DGPMV^^0^B19120801
145"BLD",7943,"KRN",9.8,"NM",8,0)
146DGRP2^^0^B19865142
147"BLD",7943,"KRN",9.8,"NM","B","DG10",2)
148
149"BLD",7943,"KRN",9.8,"NM","B","DGDEATH",6)
150
151"BLD",7943,"KRN",9.8,"NM","B","DGPMV",7)
152
153"BLD",7943,"KRN",9.8,"NM","B","DGREG",1)
154
155"BLD",7943,"KRN",9.8,"NM","B","DGRP2",8)
156
157"BLD",7943,"KRN",9.8,"NM","B","DGRPD",5)
158
159"BLD",7943,"KRN",9.8,"NM","B","ORCXPND1",4)
160
161"BLD",7943,"KRN",9.8,"NM","B","VWUTIL",3)
162
163"BLD",7943,"KRN",19,0)
16419
165"BLD",7943,"KRN",19,"NM",0)
166^9.68A^2^2
167"BLD",7943,"KRN",19,"NM",1,0)
168VW ENTER PRELIM CAUSE OF DEATH^^0
169"BLD",7943,"KRN",19,"NM",2,0)
170DG BED CONTROL^^2
171"BLD",7943,"KRN",19,"NM","B","DG BED CONTROL",2)
172
173"BLD",7943,"KRN",19,"NM","B","VW ENTER PRELIM CAUSE OF DEATH",1)
174
175"BLD",7943,"KRN",19.1,0)
17619.1
177"BLD",7943,"KRN",101,0)
178101
179"BLD",7943,"KRN",409.61,0)
180409.61
181"BLD",7943,"KRN",771,0)
182771
183"BLD",7943,"KRN",779.2,0)
184779.2
185"BLD",7943,"KRN",870,0)
186870
187"BLD",7943,"KRN",8989.51,0)
1888989.51
189"BLD",7943,"KRN",8989.52,0)
1908989.52
191"BLD",7943,"KRN",8994,0)
1928994
193"BLD",7943,"KRN","B",.4,.4)
194
195"BLD",7943,"KRN","B",.401,.401)
196
197"BLD",7943,"KRN","B",.402,.402)
198
199"BLD",7943,"KRN","B",.403,.403)
200
201"BLD",7943,"KRN","B",.5,.5)
202
203"BLD",7943,"KRN","B",.84,.84)
204
205"BLD",7943,"KRN","B",3.6,3.6)
206
207"BLD",7943,"KRN","B",3.8,3.8)
208
209"BLD",7943,"KRN","B",9.2,9.2)
210
211"BLD",7943,"KRN","B",9.8,9.8)
212
213"BLD",7943,"KRN","B",19,19)
214
215"BLD",7943,"KRN","B",19.1,19.1)
216
217"BLD",7943,"KRN","B",101,101)
218
219"BLD",7943,"KRN","B",409.61,409.61)
220
221"BLD",7943,"KRN","B",771,771)
222
223"BLD",7943,"KRN","B",779.2,779.2)
224
225"BLD",7943,"KRN","B",870,870)
226
227"BLD",7943,"KRN","B",8989.51,8989.51)
228
229"BLD",7943,"KRN","B",8989.52,8989.52)
230
231"BLD",7943,"KRN","B",8994,8994)
232
233"BLD",7943,"PRET")
234
235"BLD",7943,"QUES",0)
236^9.62^^
237"FIA",2)
238PATIENT
239"FIA",2,0)
240^DPT(
241"FIA",2,0,0)
2422I
243"FIA",2,0,1)
244y^n^p^^^^n^^n
245"FIA",2,0,10)
246
247"FIA",2,0,11)
248
249"FIA",2,0,"RLRO")
250
251"FIA",2,2)
2521
253"FIA",2,2,.351)
254
255"FIA",2,2,250043.1)
256
257"FIA",2,2,256000)
258
259"FIA",2,2,256001)
260
261"FIA",2,2.0256001)
2620
263"FIA",2,2.250043)
2640
265"FIA",200)
266NEW PERSON
267"FIA",200,0)
268^VA(200,
269"FIA",200,0,0)
270200Is
271"FIA",200,0,1)
272y^n^p^^^^n^^n
273"FIA",200,0,10)
274
275"FIA",200,0,11)
276
277"FIA",200,0,"RLRO")
278
279"FIA",200,200)
2801
281"FIA",200,200,256000)
282
283"FIA",200,200,256001)
284
285"FIA",200,200.0256001)
2860
287"INIT")
288POST^VWREGPI
289"IX",2,2,"ADGFM351",0)
2902^ADGFM351^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
291"IX",2,2,"ADGFM351",.1,0)
292^^5^5^3020624
293"IX",2,2,"ADGFM351",.1,1,0)
294This cross reference activates the DG FIELD MONITOR event point.
295"IX",2,2,"ADGFM351",.1,2,0)
296Applications that wish to monitor edit activity related to this field may
297"IX",2,2,"ADGFM351",.1,3,0)
298subscribe to that event point and take action as indicated by the changes
299"IX",2,2,"ADGFM351",.1,4,0)
300that occur. Refer to the DG FIELD MONITOR protocol for a description of
301"IX",2,2,"ADGFM351",.1,5,0)
302the information available at the time of the event.
303"IX",2,2,"ADGFM351",1)
304D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
305"IX",2,2,"ADGFM351",2)
306D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
307"IX",2,2,"ADGFM351",11.1,0)
308^.114IA^1^1
309"IX",2,2,"ADGFM351",11.1,1,0)
3101^F^2^.351^^^F
311"IX",2,2,"ADGFMD351",0)
3122^ADGFMD351^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A
313"IX",2,2,"ADGFMD351",.1,0)
314^^5^5^3020820
315"IX",2,2,"ADGFMD351",.1,1,0)
316This cross reference activates the DG FIELD MONITOR event point.
317"IX",2,2,"ADGFMD351",.1,2,0)
318Applications that wish to monitor edit activity related to this field may
319"IX",2,2,"ADGFMD351",.1,3,0)
320subscribe to that event point and take action as indicated by the changes
321"IX",2,2,"ADGFMD351",.1,4,0)
322that occur. Refer to the DG FIELD MONITOR protocol for a description of
323"IX",2,2,"ADGFMD351",.1,5,0)
324the information available at the time of the event.
325"IX",2,2,"ADGFMD351",1)
326D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
327"IX",2,2,"ADGFMD351",2)
328D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
329"IX",2,2,"ADGFMD351",11.1,0)
330^.114IA^1^1
331"IX",2,2,"ADGFMD351",11.1,1,0)
3321^F^2^.351^^^F
333"KRN",.402,1733,-1)
3340^1
335"KRN",.402,1733,0)
336VW LOCAL REGISTRATION TEMPLATE^3121105.0927^@^2^^@^3121107
337"KRN",.402,1733,"DIAB",1,1,2.019906,0)
338ALL
339"KRN",.402,1733,"DR",1,2)
340W !,"Please Answer these questions";256000;19906;
341"KRN",.402,1733,"DR",2,2.019906)
342.01
343"KRN",.402,1749,-1)
3440^2
345"KRN",.402,1749,0)
346VW PRELIMINARY CAUSE OF DEATH^3121106.1458^^2^^^3121107
347"KRN",.402,1749,"DR",1,2)
348I '+$G(^DPT(D0,.35)) W !,"Date of Death not entered. Quitting.",! S Y="@999";250043.1;@999;
349"KRN",19,1893,-1)
3502^2
351"KRN",19,1893,0)
352DG BED CONTROL^Bed Control Menu^^M^.5^^^^^^^47^y
353"KRN",19,1893,10,0)
354^19.01IP^18^17
355"KRN",19,1893,10,18,0)
35611084
357"KRN",19,1893,10,18,"^")
358VW ENTER PRELIM CAUSE OF DEATH
359"KRN",19,1893,"U")
360BED CONTROL MENU
361"KRN",19,11084,-1)
3620^1
363"KRN",19,11084,0)
364VW ENTER PRELIM CAUSE OF DEATH^Enter preliminary cause of death for a patient^^E^^^^^^^^
365"KRN",19,11084,1,0)
366^^6^6^3121106^
367"KRN",19,11084,1,1,0)
368This option allows you to enter/edit a preliminary cause of death for a
369"KRN",19,11084,1,2,0)
370patient. This is especially useful if the patient was discharged to DEATH
371"KRN",19,11084,1,3,0)
372and the death date was filled automatically.
373"KRN",19,11084,1,4,0)
374
375"KRN",19,11084,1,5,0)
376'Death Entry' will allow you to enter the preliminary cause of death for
377"KRN",19,11084,1,6,0)
378a patient as well.
379"KRN",19,11084,30)
380DPT(
381"KRN",19,11084,31)
382AEMQ
383"KRN",19,11084,50)
384DPT(
385"KRN",19,11084,51)
386[VW PRELIMINARY CAUSE OF DEATH]
387"KRN",19,11084,"U")
388ENTER PRELIMINARY CAUSE OF DEA
389"MBREQ")
3900
391"ORD",7,.402)
392.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
393"ORD",7,.402,0)
394INPUT TEMPLATE
395"ORD",18,19)
39619;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
397"ORD",18,19,0)
398OPTION
399"QUES","XPF1",0)
400Y
401"QUES","XPF1","??")
402^D REP^XPDH
403"QUES","XPF1","A")
404Shall I write over your |FLAG| File
405"QUES","XPF1","B")
406YES
407"QUES","XPF1","M")
408D XPF1^XPDIQ
409"QUES","XPF2",0)
410Y
411"QUES","XPF2","??")
412^D DTA^XPDH
413"QUES","XPF2","A")
414Want my data |FLAG| yours
415"QUES","XPF2","B")
416YES
417"QUES","XPF2","M")
418D XPF2^XPDIQ
419"QUES","XPI1",0)
420YO
421"QUES","XPI1","??")
422^D INHIBIT^XPDH
423"QUES","XPI1","A")
424Want KIDS to INHIBIT LOGONs during the install
425"QUES","XPI1","B")
426NO
427"QUES","XPI1","M")
428D XPI1^XPDIQ
429"QUES","XPM1",0)
430PO^VA(200,:EM
431"QUES","XPM1","??")
432^D MG^XPDH
433"QUES","XPM1","A")
434Enter the Coordinator for Mail Group '|FLAG|'
435"QUES","XPM1","B")
436
437"QUES","XPM1","M")
438D XPM1^XPDIQ
439"QUES","XPO1",0)
440Y
441"QUES","XPO1","??")
442^D MENU^XPDH
443"QUES","XPO1","A")
444Want KIDS to Rebuild Menu Trees Upon Completion of Install
445"QUES","XPO1","B")
446NO
447"QUES","XPO1","M")
448D XPO1^XPDIQ
449"QUES","XPZ1",0)
450Y
451"QUES","XPZ1","??")
452^D OPT^XPDH
453"QUES","XPZ1","A")
454Want to DISABLE Scheduled Options, Menu Options, and Protocols
455"QUES","XPZ1","B")
456NO
457"QUES","XPZ1","M")
458D XPZ1^XPDIQ
459"QUES","XPZ2",0)
460Y
461"QUES","XPZ2","??")
462^D RTN^XPDH
463"QUES","XPZ2","A")
464Want to MOVE routines to other CPUs
465"QUES","XPZ2","B")
466NO
467"QUES","XPZ2","M")
468D XPZ2^XPDIQ
469"RTN")
4709
471"RTN","DG10")
4720^2^B27855507
473"RTN","DG10",1,0)
474DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 11/5/12 12:58pm
475"RTN","DG10",2,0)
476 ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 18
477"RTN","DG10",3,0)
478 ; Modified from FOIA VISTA,
479"RTN","DG10",4,0)
480 ; Copyright (C) 2007 WorldVistA
481"RTN","DG10",5,0)
482 ;
483"RTN","DG10",6,0)
484 ; This program is free software; you can redistribute it and/or modify
485"RTN","DG10",7,0)
486 ; it under the terms of the GNU General Public License as published by
487"RTN","DG10",8,0)
488 ; the Free Software Foundation; either version 2 of the License, or
489"RTN","DG10",9,0)
490 ; (at your option) any later version.
491"RTN","DG10",10,0)
492 ;
493"RTN","DG10",11,0)
494 ; This program is distributed in the hope that it will be useful,
495"RTN","DG10",12,0)
496 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
497"RTN","DG10",13,0)
498 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
499"RTN","DG10",14,0)
500 ; GNU General Public License for more details.
501"RTN","DG10",15,0)
502 ;
503"RTN","DG10",16,0)
504 ; You should have received a copy of the GNU General Public License
505"RTN","DG10",17,0)
506 ; along with this program; if not, write to the Free Software
507"RTN","DG10",18,0)
508 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
509"RTN","DG10",19,0)
510START ;
511"RTN","DG10",20,0)
512 D LO^DGUTL
513"RTN","DG10",21,0)
514 I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1
515"RTN","DG10",22,0)
516 .; D EN^DGRPD,REG^IVMCQ($G(DFN))
517"RTN","DG10",23,0)
518 . D EN^DGRPD
519"RTN","DG10",24,0)
520 . Q:$G(DGRPOUT)
521"RTN","DG10",25,0)
522 . ;
523"RTN","DG10",26,0)
524 . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
525"RTN","DG10",27,0)
526 . ;
527"RTN","DG10",28,0)
528 . ; HEC query call only wanted/needed for VA agency code
529"RTN","DG10",29,0)
530 . ;
531"RTN","DG10",30,0)
532 . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
533"RTN","DG10",31,0)
534 . ;
535"RTN","DG10",32,0)
536 . ; ** end of VOE change 1 **
537"RTN","DG10",33,0)
538 . ;
539"RTN","DG10",34,0)
540 . D HINQ
541"RTN","DG10",35,0)
542 ;
543"RTN","DG10",36,0)
544A W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
545"RTN","DG10",37,0)
546 ;
547"RTN","DG10",38,0)
548 D REGMU^VWUTIL ; Changes for Meaningful Use
549"RTN","DG10",39,0)
550 ;
551"RTN","DG10",40,0)
552 N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
553"RTN","DG10",41,0)
554 ;
555"RTN","DG10",42,0)
556 ;MPI QUERY
557"RTN","DG10",43,0)
558 ;check to see if CIRN PD/MPI is installed
559"RTN","DG10",44,0)
560 N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
561"RTN","DG10",45,0)
562 K MPIFRTN
563"RTN","DG10",46,0)
564 ;
565"RTN","DG10",47,0)
566 ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
567"RTN","DG10",48,0)
568 ;
569"RTN","DG10",49,0)
570 ; MPI query call only wanted/needed for VA agency code
571"RTN","DG10",50,0)
572 ;
573"RTN","DG10",51,0)
574 I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
575"RTN","DG10",52,0)
576 ;
577"RTN","DG10",53,0)
578 ; ** end of VOE change 2 **
579"RTN","DG10",54,0)
580 ;
581"RTN","DG10",55,0)
582 K MPIFRTN
583"RTN","DG10",56,0)
584 ;
585"RTN","DG10",57,0)
586 I +$G(DGNEW) D
587"RTN","DG10",58,0)
588 . ; query CMOR for Patient Record Flag Assignments if NEW patient and
589"RTN","DG10",59,0)
590 . ; display results
591"RTN","DG10",60,0)
592 . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
593"RTN","DG10",61,0)
594 ;
595"RTN","DG10",62,0)
596SKIP ;
597"RTN","DG10",63,0)
598 S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
599"RTN","DG10",64,0)
600 ;
601"RTN","DG10",65,0)
602 ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
603"RTN","DG10",66,0)
604 ;
605"RTN","DG10",67,0)
606 ; these query calls only wanted/needed for VA agency code
607"RTN","DG10",68,0)
608 ;
609"RTN","DG10",69,0)
610 I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
611"RTN","DG10",70,0)
612 G A1
613"RTN","DG10",71,0)
614 ;
615"RTN","DG10",72,0)
616 ; ** end of VOE change 3 **
617"RTN","DG10",73,0)
618 ;
619"RTN","DG10",74,0)
620 ;
621"RTN","DG10",75,0)
622HINQ ;
623"RTN","DG10",76,0)
624 S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
625"RTN","DG10",77,0)
626 .N DGROUT
627"RTN","DG10",78,0)
628 .S DGROUT=X
629"RTN","DG10",79,0)
630 .I $G(DFN) D
631"RTN","DG10",80,0)
632 ..N X,Y,DGRP
633"RTN","DG10",81,0)
634 ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
635"RTN","DG10",82,0)
636 ..W !," Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
637"RTN","DG10",83,0)
638 ..W ?40," Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
639"RTN","DG10",84,0)
640 .D @("EN^"_DGROUT) K Y Q ;from dgdem0
641"RTN","DG10",85,0)
642 Q
643"RTN","DG10",86,0)
644 ;
645"RTN","DG10",87,0)
646 ; SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management
647"RTN","DG10",88,0)
648 ; to bypass the embossing routines when calling load/edit from IEMM
649"RTN","DG10",89,0)
650 ;
651"RTN","DG10",90,0)
652A1 D G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
653"RTN","DG10",91,0)
654 .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
655"RTN","DG10",92,0)
656 .S %=1 D YN^DICN
657"RTN","DG10",93,0)
658 .I +$G(DGNEW) Q
659"RTN","DG10",94,0)
660 .I $$ADD^DGADDUTL($G(DFN)) ;
661"RTN","DG10",95,0)
662 ;
663"RTN","DG10",96,0)
664H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
665"RTN","DG10",97,0)
666 G A1
667"RTN","DG10",98,0)
668 ;
669"RTN","DG10",99,0)
670CK S DGEDCN=1 D ^DGRPC,MT(DFN),CP
671"RTN","DG10",100,0)
672 G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
673"RTN","DG10",101,0)
674 I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
675"RTN","DG10",102,0)
676 ;G:Y ^DGRP9
677"RTN","DG10",103,0)
678 ;
679"RTN","DG10",104,0)
680EMBOS ;W ! D EMBOS^DGQEMA G A
681"RTN","DG10",105,0)
682 G A
683"RTN","DG10",106,0)
684 ;
685"RTN","DG10",107,0)
686 ;
687"RTN","DG10",108,0)
688Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
689"RTN","DG10",109,0)
690 ;
691"RTN","DG10",110,0)
692MT(DFN) ; Check if user requires a means test. Ask user if they want to proceedif
693"RTN","DG10",111,0)
694 ; one is required
695"RTN","DG10",112,0)
696 I '$D(SDIEMM) DO
697"RTN","DG10",113,0)
698 .N DGREQF,DIV
699"RTN","DG10",114,0)
700 .D EN^DGMTR
701"RTN","DG10",115,0)
702 .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
703"RTN","DG10",116,0)
704 .Q
705"RTN","DG10",117,0)
706 I $D(SDIEMM) DO
707"RTN","DG10",118,0)
708 .N DGMTI
709"RTN","DG10",119,0)
710 .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
711"RTN","DG10",120,0)
712 .I $P(DGMTI,U,4)="R" D I 1
713"RTN","DG10",121,0)
714 ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
715"RTN","DG10",122,0)
716 ..I '$$OKTOCONT(DGMTDT) Q
717"RTN","DG10",123,0)
718 ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
719"RTN","DG10",124,0)
720 .E D WARNING
721"RTN","DG10",125,0)
722 .Q
723"RTN","DG10",126,0)
724 Q
725"RTN","DG10",127,0)
726 ;
727"RTN","DG10",128,0)
728WARNING ;
729"RTN","DG10",129,0)
730 ;prints a warning to the screen about means test
731"RTN","DG10",130,0)
732 ;
733"RTN","DG10",131,0)
734 W !!,"A means test for this encounter date was not found and may be required!"
735"RTN","DG10",132,0)
736 W !,"Further investigation will be needed."
737"RTN","DG10",133,0)
738 W !
739"RTN","DG10",134,0)
740 D PAUSE
741"RTN","DG10",135,0)
742 Q
743"RTN","DG10",136,0)
744 ;
745"RTN","DG10",137,0)
746PAUSE ;
747"RTN","DG10",138,0)
748 N DIR
749"RTN","DG10",139,0)
750 S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
751"RTN","DG10",140,0)
752 Q
753"RTN","DG10",141,0)
754 ;
755"RTN","DG10",142,0)
756OKTOCONT(Y) ;
757"RTN","DG10",143,0)
758 ;
759"RTN","DG10",144,0)
760 N DIR
761"RTN","DG10",145,0)
762 W !!,"Patient Requires a means Test"
763"RTN","DG10",146,0)
764 X ^DD("DD")
765"RTN","DG10",147,0)
766 W !,"Primary Means Test Required from '",Y,"'",!
767"RTN","DG10",148,0)
768 ;
769"RTN","DG10",149,0)
770 I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO G OKQ
771"RTN","DG10",150,0)
772 .W !,$C(7),"You do not have the appropriate IEMM Security Key. Contact your supervisor.",!
773"RTN","DG10",151,0)
774 .D PAUSE
775"RTN","DG10",152,0)
776 .S Y=0
777"RTN","DG10",153,0)
778 ;
779"RTN","DG10",154,0)
780 S DIR("A")="Do you wish to proceed with the means test at this time"
781"RTN","DG10",155,0)
782 S DIR("B")="YES"
783"RTN","DG10",156,0)
784 S DIR(0)="Y"
785"RTN","DG10",157,0)
786 D ^DIR
787"RTN","DG10",158,0)
788OKQ Q $S(Y=1:1,1:0)
789"RTN","DG10",159,0)
790 ;
791"RTN","DG10",160,0)
792CP ;If not (autoexempt or MTested) & no CP test this year then
793"RTN","DG10",161,0)
794 ;prompt for add/edit cp test
795"RTN","DG10",162,0)
796 N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
797"RTN","DG10",163,0)
798 G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
799"RTN","DG10",164,0)
800 S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
801"RTN","DG10",165,0)
802 D EN^DGMTCOR
803"RTN","DG10",166,0)
804 I +$G(DGNOCOPF) S DGMTCOR=0
805"RTN","DG10",167,0)
806 I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
807"RTN","DG10",168,0)
808 K DGNOCOPF
809"RTN","DG10",169,0)
810QTCP Q
811"RTN","DGDEATH")
8120^6^B43242813
813"RTN","DGDEATH",1,0)
814DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 11/7/12 11:49am
815"RTN","DGDEATH",2,0)
816 ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725,772,VW1**;Aug 13, 1993;Build 18
817"RTN","DGDEATH",3,0)
818 ;
819"RTN","DGDEATH",4,0)
820 ; Change History
821"RTN","DGDEATH",5,0)
822 ; VW1 3121105: GET+7: added preliminary cause of death field to input template.
823"RTN","DGDEATH",6,0)
824 ;
825"RTN","DGDEATH",7,0)
826GET N DGMTI,DATA
827"RTN","DGDEATH",8,0)
828 S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y
829"RTN","DGDEATH",9,0)
830 S DGDOLD=$G(^DPT(DFN,.35))
831"RTN","DGDEATH",10,0)
832 I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house. Discharge him with a discharge type of DEATH." G GET
833"RTN","DGDEATH",11,0)
834 I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS
835"RTN","DGDEATH",12,0)
836 D NOW^%DTC S DGNOW=%
837"RTN","DGDEATH",13,0)
838 S ^TMP("DEATH",$J)=1
839"RTN","DGDEATH",14,0)
840 ; BEGIN WV CHANGE VEN/SMH: Add preliminary cause of death
841"RTN","DGDEATH",15,0)
842 ; K A W ! S DIE=DIC,DR=".351" D ^DIE ; before
843"RTN","DGDEATH",16,0)
844 K A W ! S DIE=DIC,DR=".351;S:(X=""""!(X=""@"")) Y=""@999"";250043.1;@999" D ^DIE ; after
845"RTN","DGDEATH",17,0)
846 ; END WV CHANGE VEN/SMH
847"RTN","DGDEATH",18,0)
848 I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET
849"RTN","DGDEATH",19,0)
850 S DGDNEW=^DPT(DFN,.35)
851"RTN","DGDEATH",20,0)
852 I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
853"RTN","DGDEATH",21,0)
854 I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
855"RTN","DGDEATH",22,0)
856SN I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE I $P($G(^DPT(DFN,.35)),"^",3)']"" D SNDISP G SN
857"RTN","DGDEATH",23,0)
858 I DGDOLD'=DGDNEW D DISCHRGE
859"RTN","DGDEATH",24,0)
860 I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
861"RTN","DGDEATH",25,0)
862 K ^TMP("DEATH",$J) G GET
863"RTN","DGDEATH",26,0)
864 ;
865"RTN","DGDEATH",27,0)
866DIS W !,"Patient has a discharge type of Death",!,"Edit the discharge",!
867"RTN","DGDEATH",28,0)
868Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q
869"RTN","DGDEATH",29,0)
870XFR ; called from set x-ref of field .351 of file 2
871"RTN","DGDEATH",30,0)
872 N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1
873"RTN","DGDEATH",31,0)
874 Q:'$D(DFN)
875"RTN","DGDEATH",32,0)
876 K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0
877"RTN","DGDEATH",33,0)
878 D DEMOG
879"RTN","DGDEATH",34,0)
880 S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT
881"RTN","DGDEATH",35,0)
882 S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN")
883"RTN","DGDEATH",36,0)
884 S DGDONOT=0 D APTT3
885"RTN","DGDEATH",37,0)
886 D LINE("")
887"RTN","DGDEATH",38,0)
888 D LINE(" Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:" (While an inpatient)"))
889"RTN","DGDEATH",39,0)
890 D LINE("")
891"RTN","DGDEATH",40,0)
892 I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0)
893"RTN","DGDEATH",41,0)
894 S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:""))
895"RTN","DGDEATH",42,0)
896 D LINE($S($D(DGDTHEN):"",DG1:" Admission Date/Time: "_Y_$S((DGDDT-ADM)<1:" (Within 24 hours of hospitalization)",1:""),1:""))
897"RTN","DGDEATH",43,0)
898 D LINE("")
899"RTN","DGDEATH",44,0)
900 S DGX=$P($G(^DGPM(+$G(DGA1),0)),"^",6),DGX=$P($G(^DIC(42,+DGX,0)),U,1)
901"RTN","DGDEATH",45,0)
902 D LINE($S($D(DGDTHEN):"",('DG1):"",$D(DGA1):" Admitted To: "_$S(DGX]"":DGX,1:"UNKNOWN"),1:"")) K DGX
903"RTN","DGDEATH",46,0)
904 D LINE("")
905"RTN","DGDEATH",47,0)
906 I DG1&'$D(DGDTHEN) D
907"RTN","DGDEATH",48,0)
908 . D LINE($S($D(DGXFR0):" Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:""))
909"RTN","DGDEATH",49,0)
910 . D LINE("")
911"RTN","DGDEATH",50,0)
912F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI=""
913"RTN","DGDEATH",51,0)
914 S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT,DGARRAY(3)="I;R"
915"RTN","DGDEATH",52,0)
916 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
917"RTN","DGDEATH",53,0)
918 ;
919"RTN","DGDEATH",54,0)
920 I SDCNT>0 F S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']"" D Q:DGFAPTI
921"RTN","DGDEATH",55,0)
922 .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1
923"RTN","DGDEATH",56,0)
924 S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!")
925"RTN","DGDEATH",57,0)
926 I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):" ["_$P(^(0),"^",1)_"]",1:""))
927"RTN","DGDEATH",58,0)
928 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
929"RTN","DGDEATH",59,0)
930 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
931"RTN","DGDEATH",60,0)
932Q1 S DGB=1 D ^DGBUL S X=DGDEATH
933"RTN","DGDEATH",61,0)
934 K DGDEATH,DGSCHAD,DGI,Y,DGDDT,^TMP($J,"SDAMA301") D KILL^DGPATV K ADM,DG1,DGA1,DGCT,DGT,DGXX,DGY,Z Q
935"RTN","DGDEATH",62,0)
936SA F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI I $D(^DGS(41.1,DGI,0)),($P(^(0),"^",13)']""),($P(^(0),"^",17)']"") S $P(^(0),"^",13)=DGDEATH,$P(^(0),"^",14)=+DUZ,$P(^(0),"^",15)=1,$P(^(0),"^",16)=2,DGSCHAD=1
937"RTN","DGDEATH",63,0)
938 Q
939"RTN","DGDEATH",64,0)
940 ;
941"RTN","DGDEATH",65,0)
942DEL ; delete death bulletin
943"RTN","DGDEATH",66,0)
944 N DGPCMM,DELBY,DELTM,DTHINFO
945"RTN","DGDEATH",67,0)
946 S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q ; no patient node
947"RTN","DGDEATH",68,0)
948 I +$G(^DPT(DFN,.35)) Q ; not deletion
949"RTN","DGDEATH",69,0)
950 S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0
951"RTN","DGDEATH",70,0)
952 D ^DGPATV
953"RTN","DGDEATH",71,0)
954 D LINE("The date of death for the following patient has been deleted.")
955"RTN","DGDEATH",72,0)
956 D LINE("")
957"RTN","DGDEATH",73,0)
958 D DEMOG
959"RTN","DGDEATH",74,0)
960 D LINE("")
961"RTN","DGDEATH",75,0)
962 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
963"RTN","DGDEATH",76,0)
964 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
965"RTN","DGDEATH",77,0)
966 S DGB=1 D ^DGBUL S X=DGDEATH
967"RTN","DGDEATH",78,0)
968 K DGCT,DGDEATH D KILL^DGPATV
969"RTN","DGDEATH",79,0)
970 Q
971"RTN","DGDEATH",80,0)
972 ;
973"RTN","DGDEATH",81,0)
974DEMOG ; list main demographics
975"RTN","DGDEATH",82,0)
976 D LINE(" NAME: "_DGNAME)
977"RTN","DGDEATH",83,0)
978 D LINE(" SSN: "_$P(SSN,"^",2))
979"RTN","DGDEATH",84,0)
980 D LINE(" DOB: "_$P(DOB,"^",2))
981"RTN","DGDEATH",85,0)
982 I DGVETS D
983"RTN","DGDEATH",86,0)
984 . N DGX
985"RTN","DGDEATH",87,0)
986 . S DGX=$G(^DPT(DFN,.31))
987"RTN","DGDEATH",88,0)
988 . S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGX,U,4)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
989"RTN","DGDEATH",89,0)
990 . D LINE(" CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED"))
991"RTN","DGDEATH",90,0)
992 . D LINE(" CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED"))
993"RTN","DGDEATH",91,0)
994 D LINE(" COORDINATING MASTER OF RECORD: "_DGCMOR)
995"RTN","DGDEATH",92,0)
996 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO")
997"RTN","DGDEATH",93,0)
998 S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E"))
999"RTN","DGDEATH",94,0)
1000 S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN")
1001"RTN","DGDEATH",95,0)
1002 S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E"))
1003"RTN","DGDEATH",96,0)
1004 S DELTM=$G(DTHINFO(2,DFN_",",.354,"E"))
1005"RTN","DGDEATH",97,0)
1006 S DELBY=$G(DTHINFO(2,DFN_",",.355,"E"))
1007"RTN","DGDEATH",98,0)
1008 D LINE("")
1009"RTN","DGDEATH",99,0)
1010 D LINE(" LAST EDITED BY: "_DELBY)
1011"RTN","DGDEATH",100,0)
1012 D LINE(" DATE/TIME LAST MODIFIED: "_DELTM)
1013"RTN","DGDEATH",101,0)
1014 D LINE(" SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE))
1015"RTN","DGDEATH",102,0)
1016 ;K DEATHVAL,SOURCE,DELTM,DELBY
1017"RTN","DGDEATH",103,0)
1018 Q
1019"RTN","DGDEATH",104,0)
1020 ;
1021"RTN","DGDEATH",105,0)
1022LINE(X) ; add line contained in X to array
1023"RTN","DGDEATH",106,0)
1024 S DGCT=DGCT+1
1025"RTN","DGDEATH",107,0)
1026 S DGTEXT(DGCT,0)=X
1027"RTN","DGDEATH",108,0)
1028 Q
1029"RTN","DGDEATH",109,0)
1030DSBULL ;
1031"RTN","DGDEATH",110,0)
1032 ;
1033"RTN","DGDEATH",111,0)
1034 I $G(IVMDODUP)=1 Q
1035"RTN","DGDEATH",112,0)
1036 S DFN=DA
1037"RTN","DGDEATH",113,0)
1038 I $D(DGPMDA) D Q
1039"RTN","DGDEATH",114,0)
1040 .S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18)
1041"RTN","DGDEATH",115,0)
1042 .I $G(^DG(405.2,DISTYPE,0))["DEATH" D
1043"RTN","DGDEATH",116,0)
1044 ..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR")
1045"RTN","DGDEATH",117,0)
1046 ..D DISCHRGE,XFR
1047"RTN","DGDEATH",118,0)
1048 I $D(^TMP("DEATH",$J)) Q
1049"RTN","DGDEATH",119,0)
1050 D DISCHRGE,XFR
1051"RTN","DGDEATH",120,0)
1052 Q
1053"RTN","DGDEATH",121,0)
1054DKBULL ;
1055"RTN","DGDEATH",122,0)
1056 S DFN=DA
1057"RTN","DGDEATH",123,0)
1058 S FDA(2,DFN_",",.353)="@"
1059"RTN","DGDEATH",124,0)
1060 I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ
1061"RTN","DGDEATH",125,0)
1062 D FILE^DIE(,"FDA",)
1063"RTN","DGDEATH",126,0)
1064 D DEL
1065"RTN","DGDEATH",127,0)
1066 Q
1067"RTN","DGDEATH",128,0)
1068DISCHRGE ;
1069"RTN","DGDEATH",129,0)
1070 ; If the patient is being discharged, determine values needed for
1071"RTN","DGDEATH",130,0)
1072 ; Source of Notification and Date/Time last entered.
1073"RTN","DGDEATH",131,0)
1074 ;
1075"RTN","DGDEATH",132,0)
1076 I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H)
1077"RTN","DGDEATH",133,0)
1078 I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW
1079"RTN","DGDEATH",134,0)
1080 S FDA(2,DFN_",",.355)=DUZ
1081"RTN","DGDEATH",135,0)
1082 D FILE^DIE(,"FDA",)
1083"RTN","DGDEATH",136,0)
1084 Q
1085"RTN","DGDEATH",137,0)
1086APTT3 ;Check to exclude "While an Inpatient" from DOD Bulletin
1087"RTN","DGDEATH",138,0)
1088 ; Input: DFN Output: DGDONOT
1089"RTN","DGDEATH",139,0)
1090 N DATE,XIEN,TYPE,XDOD,YES
1091"RTN","DGDEATH",140,0)
1092 S DGDONOT=0
1093"RTN","DGDEATH",141,0)
1094 S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q
1095"RTN","DGDEATH",142,0)
1096 S XDOD=$P(XDOD,".",1),YES=0,TYPE=""
1097"RTN","DGDEATH",143,0)
1098 I '$D(^DGPM("APTT3",DFN)) Q
1099"RTN","DGDEATH",144,0)
1100 S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q
1101"RTN","DGDEATH",145,0)
1102 I $P(DATE,".",1)=XDOD S YES=1
1103"RTN","DGDEATH",146,0)
1104 I ($P(DATE,".",1)-1)=XDOD S YES=1
1105"RTN","DGDEATH",147,0)
1106 S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q
1107"RTN","DGDEATH",148,0)
1108 S TYPE=$P($G(^DGPM(XIEN,0)),"^",4)
1109"RTN","DGDEATH",149,0)
1110 I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
1111"RTN","DGDEATH",150,0)
1112 Q
1113"RTN","DGDEATH",151,0)
1114SNDISP ; Source of Notification display choices
1115"RTN","DGDEATH",152,0)
1116 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DGLIST,DGLNAME,I,X,Y
1117"RTN","DGDEATH",153,0)
1118 S DGLIST=$P($G(^DD(2,.353,0)),"^",3)
1119"RTN","DGDEATH",154,0)
1120 S Y=6
1121"RTN","DGDEATH",155,0)
1122 S DIR("?",1)=" "
1123"RTN","DGDEATH",156,0)
1124 S DIR("?",2)=" This is a required response. Please select from the following:"
1125"RTN","DGDEATH",157,0)
1126 S DIR("?",3)=" Entering '^' will take you back to the Source of Notification prompt"
1127"RTN","DGDEATH",158,0)
1128 S DIR("?",4)=" "
1129"RTN","DGDEATH",159,0)
1130 S DIR("?",5)=" "
1131"RTN","DGDEATH",160,0)
1132 F X=1:1 S DGLNAME=$P(DGLIST,";",X) Q:DGLNAME']"" S DIR("?",Y)=" "_$P(DGLNAME,":",1)_" "_$P(DGLNAME,":",2) S Y=Y+1
1133"RTN","DGDEATH",161,0)
1134 S DIR("?",Y)=" "
1135"RTN","DGDEATH",162,0)
1136 F I=1:1 Q:'$D(DIR("?",I)) W !,DIR("?",I)
1137"RTN","DGDEATH",163,0)
1138 Q
1139"RTN","DGPMV")
11400^7^B19120801
1141"RTN","DGPMV",1,0)
1142DGPMV ;ALB/MRL/MIR - PATIENT MOVEMENT DRIVER; 10 MAR 89 ; 11/5/12 1:00pm
1143"RTN","DGPMV",2,0)
1144 ;;5.3;Registration;**60,200,268,VW1**;Aug 13, 1993;Build 18
1145"RTN","DGPMV",3,0)
1146 ;
1147"RTN","DGPMV",4,0)
1148 ;OPTION VALUE OF DGPMT
1149"RTN","DGPMV",5,0)
1150 ;------ --------------
1151"RTN","DGPMV",6,0)
1152 ;admit 1
1153"RTN","DGPMV",7,0)
1154 ;transfer 2
1155"RTN","DGPMV",8,0)
1156 ;discharge 3
1157"RTN","DGPMV",9,0)
1158 ;check-in 4
1159"RTN","DGPMV",10,0)
1160 ;check-out 5
1161"RTN","DGPMV",11,0)
1162 ;t.s. transfer 6
1163"RTN","DGPMV",12,0)
1164 ;
1165"RTN","DGPMV",13,0)
1166 ; Change History:
1167"RTN","DGPMV",14,0)
1168 ; 3121105: *VW1* Added meaningful use questions in reg+1
1169"RTN","DGPMV",15,0)
1170PAT K ORACTION,ORMENU
1171"RTN","DGPMV",16,0)
1172 D LO^DGUTL I '$D(IOF) S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
1173"RTN","DGPMV",17,0)
1174PAT1 W ! I DGPMT=5 S DGPMN=0 D SPCLU^DGPMV0 G OREN:'DGER,Q
1175"RTN","DGPMV",18,0)
1176 S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")=$S('$D(DGPMPC):$P("Admit^Transfer^Discharge^Check-in^Check-out^Specialty Change for","^",DGPMT),1:"Provider Change for")_" PATIENT: "
1177"RTN","DGPMV",19,0)
1178 S:DGPMT=1 DIC(0)=DIC(0)_"L",DLAYGO=2 S:"^1^4^"'[("^"_DGPMT_"^") DIC("S")="I $D(^DGPM($S(DGPMT'=5:""APTT1"",1:""APTT4""),+Y))" D ^DIC K DIC,DLAYGO G Q:Y'>0 S DFN=+Y,DGPMN=$P(Y,"^",3)
1179"RTN","DGPMV",20,0)
1180OREN S DGUSEOR=$$USINGOR()
1181"RTN","DGPMV",21,0)
1182 I DGUSEOR Q:'$D(ORVP) S DFN=+ORVP,DGPMN="",Y(0)=$G(^DPT(DFN,0))
1183"RTN","DGPMV",22,0)
1184 I $$LODGER(DFN)&(DGPMT=1) D Q
1185"RTN","DGPMV",23,0)
1186 .W !,*7,"Patient is a lodger...you can not add an admission!"
1187"RTN","DGPMV",24,0)
1188 .W !," Press RETURN to continue"
1189"RTN","DGPMV",25,0)
1190 .R XTEMP:30
1191"RTN","DGPMV",26,0)
1192 .D DISPOQ K DGPMDER
1193"RTN","DGPMV",27,0)
1194MOVE ;
1195"RTN","DGPMV",28,0)
1196 S XQORQUIT=1,DGPME=0 D UC
1197"RTN","DGPMV",29,0)
1198 G CHK:"^1^4^"[("^"_DGPMT_"^") I '$D(^DGPM("APTT"_$S(DGPMT'=5:1,1:4),DFN)) W !!,"'",$P(Y(0),"^",1),"' HAS NEVER BEEN ",$S(DGPMT'=5:"ADMITTED",1:"CHECK-IN")," TO THE DHCP ADMISSIONS MODULE" G PAT1:'DGUSEOR,Q
1199"RTN","DGPMV",30,0)
1200CHK D:DGPMN REG I 'DGPME,$D(^DPT(DFN,.35)),+^(.35) S Y=+^(.35) D DIED
1201"RTN","DGPMV",31,0)
1202 D NEW^DGPMVODS I $S('DGODSON:0,'$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,1:0) S DGPME=1
1203"RTN","DGPMV",32,0)
1204 D:'DGPME ^DGPMV1 G PAT1:'DGUSEOR,Q
1205"RTN","DGPMV",33,0)
1206 ;
1207"RTN","DGPMV",34,0)
1208REG ;new patient
1209"RTN","DGPMV",35,0)
1210 ; WV Change by VEN/SMH *VW1*
1211"RTN","DGPMV",36,0)
1212 D REGMU^VWUTIL ; Extra questions for Meaningful Use
1213"RTN","DGPMV",37,0)
1214 ; End WV Change *VW1*
1215"RTN","DGPMV",38,0)
1216 D NEW^DGRP
1217"RTN","DGPMV",39,0)
1218 W !!,"NEW PATIENT! WANT TO LOAD 10-10 DATA NOW" S %=1 D YN^DICN I %=1 D ENED^DGRP S:'$D(^DPT(DFN,0)) DGPME=1 Q
1219"RTN","DGPMV",40,0)
1220 Q:%>0 I % S DGPME=1 Q
1221"RTN","DGPMV",41,0)
1222 W !?4,"Answer YES if you want to load 10/10 data at this time otherwise answer NO.",*7 G REG
1223"RTN","DGPMV",42,0)
1224 ;
1225"RTN","DGPMV",43,0)
1226DIED X ^DD("DD") W !!,"PATIENT EXPIRED '",Y,"'...WANT TO CONTINUE" S %=2 D YN^DICN Q:%=1 I % S DGPME=1 Q
1227"RTN","DGPMV",44,0)
1228 W !?4,*7,"Answer YES if you want to continue this process even though the patient",!?4,"has expired otherwise answer NO!" G DIED
1229"RTN","DGPMV",45,0)
1230 ;
1231"RTN","DGPMV",46,0)
1232Q K %,DFN,DGER,DGPM5X,DGODS,DGODSON,DGPMUC,DGPME,DGPMN,DGPMT,DGPMPC,DIC,X,Y,^UTILITY("VAIP",$J) D KVAR^VADPT
1233"RTN","DGPMV",47,0)
1234 I '$G(DGUSEOR) K XQORQUIT
1235"RTN","DGPMV",48,0)
1236 K DGUSEOR
1237"RTN","DGPMV",49,0)
1238 Q
1239"RTN","DGPMV",50,0)
1240 ;
1241"RTN","DGPMV",51,0)
1242UC ; -- set type of mvt literal
1243"RTN","DGPMV",52,0)
1244 S DGPMUC=$P("ADMISSION^TRANSFER^DISCHARGE^LODGER CHECK-IN^CHECK-OUT LODGER^SPECIALTY TRANSFER^ROOM-BED CHANGE","^",DGPMT)
1245"RTN","DGPMV",53,0)
1246 I DGPMT=6,$D(DGPMPC) S DGPMUC="PROVIDER CHANGE"
1247"RTN","DGPMV",54,0)
1248 Q
1249"RTN","DGPMV",55,0)
1250 ;
1251"RTN","DGPMV",56,0)
1252CA ; -- bypass interactive process and allows editing of past admission
1253"RTN","DGPMV",57,0)
1254 ; mvts
1255"RTN","DGPMV",58,0)
1256 ;
1257"RTN","DGPMV",59,0)
1258 ; input: DFN
1259"RTN","DGPMV",60,0)
1260 ; DGPMT - mvt transaction type
1261"RTN","DGPMV",61,0)
1262 ; DGPMCA - coresp. adm
1263"RTN","DGPMV",62,0)
1264 ;
1265"RTN","DGPMV",63,0)
1266 ; output: Y - the mvt entry added/edited
1267"RTN","DGPMV",64,0)
1268 ;
1269"RTN","DGPMV",65,0)
1270 D UC
1271"RTN","DGPMV",66,0)
1272 K VAIP S VAIP("E")=DGPMCA N DGPMCA D INP^DGPMV10
1273"RTN","DGPMV",67,0)
1274 S DGPMBYP="" D C^DGPMV1
1275"RTN","DGPMV",68,0)
1276 S Y=DGPMBYP K DGPMUC,DGPMBYP
1277"RTN","DGPMV",69,0)
1278 Q
1279"RTN","DGPMV",70,0)
1280DISPO ;called from admission disposition types
1281"RTN","DGPMV",71,0)
1282 ;input DGPMSVC=SVC OF WARD REQUIRED (FROM DISPOSITION TYPE FILE)
1283"RTN","DGPMV",72,0)
1284 ; DFN=patient file IFN (this variable is NOT killed on exit)
1285"RTN","DGPMV",73,0)
1286 ;output DGPMDER=disposition error?? - FOR FUTURE USE
1287"RTN","DGPMV",74,0)
1288 ;
1289"RTN","DGPMV",75,0)
1290 S DGPMT=1,(DGPML,DGPMMD)="" K DGPMDER,VAIP S VAIP("D")="L" D UC^DGPMV,INP^DGPMV10,NOW^%DTC
1291"RTN","DGPMV",76,0)
1292 I DGPMVI(1)&('DGPMDCD!(DGPMDCD>%)) W !,"Patient is already an inpatient...editing the admission is not allowed." D DISPOQ K DGPMDER Q
1293"RTN","DGPMV",77,0)
1294 I $$LODGER(DFN) W !,*7,"Patient is a lodger...you can not add an admission!" D DISPOQ K DGPMDER Q
1295"RTN","DGPMV",78,0)
1296 ;next line should be involked in future release to error if wrong service
1297"RTN","DGPMV",79,0)
1298 ;I DGPMVI(1)&('DGPMDCD!(DGPMDCD>%)) S DGPMDER=$S(DGPMSVC="H"&("^NH^D^"'[("^"_DGPMSV_"^")):0,DGPMSVC=DGPMSV:0,1:1) W:DGPMDER=1 "Current inpatient, but not to proper service" Q
1299"RTN","DGPMV",80,0)
1300 D NEW^DGPMVODS I $S('DGODSON:0,'$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,1:0) S DGPME=1
1301"RTN","DGPMV",81,0)
1302 S DEF="NOW",DGPM1X=0 D SEL^DGPMV2 I '$D(DGPMDER) S DGPMDER=1
1303"RTN","DGPMV",82,0)
1304DISPOQ D Q^DGPMV1 K DGODS,DGODSON,DGPMT,DGPMSV,DGPMSVC,DGPMUC,DGPMN,^UTILITY("VAIP",$J) Q
1305"RTN","DGPMV",83,0)
1306 ;
1307"RTN","DGPMV",84,0)
1308USINGOR() ; return a 1 if OE/RR option is being used or 0 otherwise
1309"RTN","DGPMV",85,0)
1310 N RETURN,X
1311"RTN","DGPMV",86,0)
1312 S RETURN=0,X=+$$VERSION^XPDUTL("OR")
1313"RTN","DGPMV",87,0)
1314 I X<3,$D(ORACTION) S RETURN=1
1315"RTN","DGPMV",88,0)
1316 I X'<3,$D(ORMENU) S RETURN=1
1317"RTN","DGPMV",89,0)
1318 Q RETURN
1319"RTN","DGPMV",90,0)
1320LODGER(DFN) ; Determine lodger status
1321"RTN","DGPMV",91,0)
1322 ; Input: DFN=patient IEN
1323"RTN","DGPMV",92,0)
1324 ; Output: '1' if currently a lodger, '0' otherwise
1325"RTN","DGPMV",93,0)
1326 N DGPMDCD,DGPMVI,I,X
1327"RTN","DGPMV",94,0)
1328 D LODGER^DGPMV10
1329"RTN","DGPMV",95,0)
1330 Q DGPMVI(2)=4
1331"RTN","DGREG")
13320^1^B78971450
1333"RTN","DGREG",1,0)
1334DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ; 11/5/12 1:00pm
1335"RTN","DGREG",2,0)
1336 ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 18
1337"RTN","DGREG",3,0)
1338 ; Modified from FOIA VISTA,
1339"RTN","DGREG",4,0)
1340 ; Copyright (C) 2007 WorldVistA
1341"RTN","DGREG",5,0)
1342 ;
1343"RTN","DGREG",6,0)
1344 ; This program is free software; you can redistribute it and/or modify
1345"RTN","DGREG",7,0)
1346 ; it under the terms of the GNU General Public License as published by
1347"RTN","DGREG",8,0)
1348 ; the Free Software Foundation; either version 2 of the License, or
1349"RTN","DGREG",9,0)
1350 ; (at your option) any later version.
1351"RTN","DGREG",10,0)
1352 ;
1353"RTN","DGREG",11,0)
1354START ;
1355"RTN","DGREG",12,0)
1356EN D LO^DGUTL S DGCLPR=""
1357"RTN","DGREG",13,0)
1358 N DGDIV
1359"RTN","DGREG",14,0)
1360 S DGDIV=$$PRIM^VASITE
1361"RTN","DGREG",15,0)
1362 S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1)
1363"RTN","DGREG",16,0)
1364 I $P(^DG(43,1,0),U,39) S %ZIS="NQ",%ZIS("A")="Select 1010 printer: " D ^%ZIS Q:POP S (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION,DGASKDEV="" I $E(IOST,1,2)'["P-" W !,$C(7),"Not a printer" G DGREG
1365"RTN","DGREG",17,0)
1366 K %ZIS("B")
1367"RTN","DGREG",18,0)
1368 I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y
1369"RTN","DGREG",19,0)
1370A D ENDREG($G(DFN))
1371"RTN","DGREG",20,0)
1372 ;
1373"RTN","DGREG",21,0)
1374 ; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
1375"RTN","DGREG",22,0)
1376 ;
1377"RTN","DGREG",23,0)
1378 ; if not VA agency code, add DIC("DR") to default some identifiers and
1379"RTN","DGREG",24,0)
1380 ; skip others also, improve readability
1381"RTN","DGREG",25,0)
1382 ;
1383"RTN","DGREG",26,0)
1384 ; before change:
1385"RTN","DGREG",27,0)
1386 ; W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
1387"RTN","DGREG",28,0)
1388 ;
1389"RTN","DGREG",29,0)
1390 ; after change:
1391"RTN","DGREG",30,0)
1392 W !!
1393"RTN","DGREG",31,0)
1394 N Y,DGREGY S DGREGY=1 D I DGREGY<0 G Q1
1395"RTN","DGREG",32,0)
1396 . N DIC S DIC=2 ; Patient file
1397"RTN","DGREG",33,0)
1398 . S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index
1399"RTN","DGREG",34,0)
1400 . N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo
1401"RTN","DGREG",35,0)
1402 . I $G(DUZ("AG"))'="V" D ;adjust identifiers asked for VOE
1403"RTN","DGREG",36,0)
1404 . . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09"
1405"RTN","DGREG",37,0)
1406 . ;
1407"RTN","DGREG",38,0)
1408 . D ^DIC ; Select Patient
1409"RTN","DGREG",39,0)
1410 . ;
1411"RTN","DGREG",40,0)
1412 . I Y<0 S DGREGY=-1 Q
1413"RTN","DGREG",41,0)
1414 . K DIC("DR")
1415"RTN","DGREG",42,0)
1416 . S (DFN,DA)=+Y
1417"RTN","DGREG",43,0)
1418 . S DGNEW=$P(Y,"^",3) ; new patient?
1419"RTN","DGREG",44,0)
1420 . N Y D PAUSE^DG10 ; prompt user before continuing
1421"RTN","DGREG",45,0)
1422 . D BEGINREG(DFN) ; lock patient record
1423"RTN","DGREG",46,0)
1424 ;
1425"RTN","DGREG",47,0)
1426 ; ** end of VOE change 1 **
1427"RTN","DGREG",48,0)
1428 ;
1429"RTN","DGREG",49,0)
1430 ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
1431"RTN","DGREG",50,0)
1432 S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1)
1433"RTN","DGREG",51,0)
1434 I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A
1435"RTN","DGREG",52,0)
1436 ;
1437"RTN","DGREG",53,0)
1438 D CIRN
1439"RTN","DGREG",54,0)
1440 ;
1441"RTN","DGREG",55,0)
1442 ; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
1443"RTN","DGREG",56,0)
1444 ;
1445"RTN","DGREG",57,0)
1446 I $G(DGNEW) D NEW^DGRP ; execute new patient DR string
1447"RTN","DGREG",58,0)
1448 ;
1449"RTN","DGREG",59,0)
1450 ; send CMOR query and display results only if VA agency code
1451"RTN","DGREG",60,0)
1452 ;
1453"RTN","DGREG",61,0)
1454 ; before change:
1455"RTN","DGREG",62,0)
1456 ; I +$G(DGNEW) D
1457"RTN","DGREG",63,0)
1458 ;
1459"RTN","DGREG",64,0)
1460 ; after change:
1461"RTN","DGREG",65,0)
1462 I $G(DGNEW),$G(DUZ("AG"))="V" D
1463"RTN","DGREG",66,0)
1464 . ;
1465"RTN","DGREG",67,0)
1466 . ; end of change
1467"RTN","DGREG",68,0)
1468 . ;
1469"RTN","DGREG",69,0)
1470 . ; query CMOR for Patient Record Flag Assignments if NEW patient and
1471"RTN","DGREG",70,0)
1472 . ; display results.
1473"RTN","DGREG",71,0)
1474 . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
1475"RTN","DGREG",72,0)
1476 ;
1477"RTN","DGREG",73,0)
1478 ; before change:
1479"RTN","DGREG",74,0)
1480 ; D ROMQRY
1481"RTN","DGREG",75,0)
1482 ;
1483"RTN","DGREG",76,0)
1484 ; after change:
1485"RTN","DGREG",77,0)
1486 I $G(DUZ("AG"))="V" D ROMQRY
1487"RTN","DGREG",78,0)
1488 ;
1489"RTN","DGREG",79,0)
1490 ; ** end of VOE change 2 **
1491"RTN","DGREG",80,0)
1492 ;
1493"RTN","DGREG",81,0)
1494 D REGMU^VWUTIL ; Changes for Meaningful Use
1495"RTN","DGREG",82,0)
1496 ;
1497"RTN","DGREG",83,0)
1498 S (DGFC,CURR)=0
1499"RTN","DGREG",84,0)
1500 D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
1501"RTN","DGREG",85,0)
1502 S %ZIS="N",IOP="HOME" D ^%ZIS S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) D ENDREG($G(DFN)) D HL7A08^VAFCDD01 K DFN,DGRPOUT G A
1503"RTN","DGREG",86,0)
1504 D HINQ^DG10
1505"RTN","DGREG",87,0)
1506 I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3
1507"RTN","DGREG",88,0)
1508 ;
1509"RTN","DGREG",89,0)
1510 ; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
1511"RTN","DGREG",90,0)
1512 ;
1513"RTN","DGREG",91,0)
1514 ; send financial query only for VA agency code
1515"RTN","DGREG",92,0)
1516 ;
1517"RTN","DGREG",93,0)
1518 ; before change:
1519"RTN","DGREG",94,0)
1520 ; D REG^IVMCQ($G(DFN)) ; send financial query
1521"RTN","DGREG",95,0)
1522 ;
1523"RTN","DGREG",96,0)
1524 ; after change:
1525"RTN","DGREG",97,0)
1526 I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query
1527"RTN","DGREG",98,0)
1528 ;
1529"RTN","DGREG",99,0)
1530 ; ** end of VOE change 3 **
1531"RTN","DGREG",100,0)
1532 ;
1533"RTN","DGREG",101,0)
1534 G A1
1535"RTN","DGREG",102,0)
1536 ;
1537"RTN","DGREG",103,0)
1538RT I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3
1539"RTN","DGREG",104,0)
1540 Q
1541"RTN","DGREG",105,0)
1542 ;
1543"RTN","DGREG",106,0)
1544A1 W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G Q:'$D(DA)
1545"RTN","DGREG",107,0)
1546 .I +$G(DGNEW) Q
1547"RTN","DGREG",108,0)
1548 .I $$ADD^DGADDUTL($G(DFN)) ;
1549"RTN","DGREG",109,0)
1550 G CH
1551"RTN","DGREG",110,0)
1552PR W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1
1553"RTN","DGREG",111,0)
1554 I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR
1555"RTN","DGREG",112,0)
1556 S CURR=% G SEEN
1557"RTN","DGREG",113,0)
1558 ;
1559"RTN","DGREG",114,0)
1560CK S DGEDCN=1 D ^DGRPC
1561"RTN","DGREG",115,0)
1562CH S X=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0),X1=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0) I 'X,'X1 G CH1
1563"RTN","DGREG",116,0)
1564CH1 S DA=DFN G PR:'$D(^DPT("ADA",1,DA)) W !!,"There is still an open disposition--register aborted.",$C(7),$C(7) G Q
1565"RTN","DGREG",117,0)
1566SEEN W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN
1567"RTN","DGREG",118,0)
1568ABIL D ^DGREGG
1569"RTN","DGREG",119,0)
1570ENR ; next line appears to be dead code. left commented just to test. mli 4/28/94
1571"RTN","DGREG",120,0)
1572 ;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I I $P(^(I,0),"^",3)'?7N Q D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1)
1573"RTN","DGREG",121,0)
1574REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// "
1575"RTN","DGREG",122,0)
1576 W !,%DT("A") R ANS:DTIME S:'$T ANS="^" S:ANS="" ANS="N" S X=ANS G Q:ANS="^" S DA(1)=DFN D CHK^DIE(2.101,.01,"E",X,.RESULT) G REG:RESULT="^"!('$D(RESULT)),PR3:'(RESULT#1) S Y=RESULT
1577"RTN","DGREG",123,0)
1578 I (RESULT'="^") W " ("_RESULT(0)_")"
1579"RTN","DGREG",124,0)
1580 S DINUM=9999999-RESULT
1581"RTN","DGREG",125,0)
1582 S (DFN1,Y1)=DINUM,APD=Y I $D(^DPT(DFN,"DIS",Y1)) W !!,"You must enter a date that does not exist.",$C(7),$C(7) G REG
1583"RTN","DGREG",126,0)
1584 G:$D(^DPT("ADA",1,DA)) CH1 L @(DIE_DINUM_")"):2 G:'$T MSG S:'($D(^DPT(DA(1),"DIS",0))#2) ^(0)="^2.101D^^" S DIC(0)="L",X=+Y D ^DIC
1585"RTN","DGREG",127,0)
1586 ;
1587"RTN","DGREG",128,0)
1588 ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
1589"RTN","DGREG",129,0)
1590 S VAFCDDT=X
1591"RTN","DGREG",130,0)
1592 ;
1593"RTN","DGREG",131,0)
1594 S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
1595"RTN","DGREG",132,0)
1596 ;
1597"RTN","DGREG",133,0)
1598 ; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
1599"RTN","DGREG",134,0)
1600 ;
1601"RTN","DGREG",135,0)
1602 ; for VOE or IHS agency codes, add the following:
1603"RTN","DGREG",136,0)
1604 ; force TYPE OF CARE with ALL OTHER
1605"RTN","DGREG",137,0)
1606 ;
1607"RTN","DGREG",138,0)
1608 I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D
1609"RTN","DGREG",139,0)
1610 . S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1///5;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
1611"RTN","DGREG",140,0)
1612 ;
1613"RTN","DGREG",141,0)
1614 ; ** end of VOE change 4 **
1615"RTN","DGREG",142,0)
1616 ;
1617"RTN","DGREG",143,0)
1618 D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK
1619"RTN","DGREG",144,0)
1620 I $D(DTOUT) D G Q
1621"RTN","DGREG",145,0)
1622 .K DTOUT
1623"RTN","DGREG",146,0)
1624 .N DA,DIK
1625"RTN","DGREG",147,0)
1626 .S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS"","
1627"RTN","DGREG",148,0)
1628 .D ^DIK
1629"RTN","DGREG",149,0)
1630 .W !!?5,"User Time-out. Required registration data could be missing."
1631"RTN","DGREG",150,0)
1632 .W !,?5,"This registration has been deleted."
1633"RTN","DGREG",151,0)
1634 ; check whether facility applying to (division) is inactive
1635"RTN","DGREG",152,0)
1636 I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT
1637"RTN","DGREG",153,0)
1638ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution"
1639"RTN","DGREG",154,0)
1640 W !?5,"file record or the Institution file record is inactive."
1641"RTN","DGREG",155,0)
1642 W !?5,"Please choose another division."
1643"RTN","DGREG",156,0)
1644 S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE
1645"RTN","DGREG",157,0)
1646 I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV
1647"RTN","DGREG",158,0)
1648CONT ; continue
1649"RTN","DGREG",159,0)
1650 S DGXXXD=1 D EL^DGREGE I $P(^DPT(DFN,"DIS",DFN1,0),"^",3)=4 S DA=DFN,DIE="^DPT(",DR=".368;.369" D ^DIE S DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DA=DFN1
1651"RTN","DGREG",160,0)
1652 S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^")
1653"RTN","DGREG",161,0)
1654 I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE
1655"RTN","DGREG",162,0)
1656 G ^DGREG0
1657"RTN","DGREG",163,0)
1658PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG
1659"RTN","DGREG",164,0)
1660PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG
1661"RTN","DGREG",165,0)
1662H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1
1663"RTN","DGREG",166,0)
1664Q K DG,DQ G Q1^DGREG0
1665"RTN","DGREG",167,0)
1666Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q
1667"RTN","DGREG",168,0)
1668EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q
1669"RTN","DGREG",169,0)
1670 S DR=DR_"HUMANITARIAN EMERGENCY" Q
1671"RTN","DGREG",170,0)
1672FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1
1673"RTN","DGREG",171,0)
1674 ;
1675"RTN","DGREG",172,0)
1676WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2
1677"RTN","DGREG",173,0)
1678 I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2
1679"RTN","DGREG",174,0)
1680 Q
1681"RTN","DGREG",175,0)
1682MSG W !,"Another user is editing, try later ..." G Q
1683"RTN","DGREG",176,0)
1684 ;
1685"RTN","DGREG",177,0)
1686BEGINREG(DFN) ;
1687"RTN","DGREG",178,0)
1688 ;Description: This is called at the beginning of the registration process.
1689"RTN","DGREG",179,0)
1690 ;Concurrent processes can check the lock to determine if the patient is
1691"RTN","DGREG",180,0)
1692 ;currently being registered.
1693"RTN","DGREG",181,0)
1694 ;
1695"RTN","DGREG",182,0)
1696 Q:'$G(DFN) 0
1697"RTN","DGREG",183,0)
1698 I $$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
1699"RTN","DGREG",184,0)
1700 L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
1701"RTN","DGREG",185,0)
1702 I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record
1703"RTN","DGREG",186,0)
1704 Q
1705"RTN","DGREG",187,0)
1706 ;
1707"RTN","DGREG",188,0)
1708ENDREG(DFN) ;
1709"RTN","DGREG",189,0)
1710 ;Description: releases the lock obtained by calling BEGINREG.
1711"RTN","DGREG",190,0)
1712 ;
1713"RTN","DGREG",191,0)
1714 Q:'$G(DFN)
1715"RTN","DGREG",192,0)
1716 L -^TMP(DFN,"REGISTRATION IN PROGRESS")
1717"RTN","DGREG",193,0)
1718 D UNLOCK^DGENPTA1(DFN)
1719"RTN","DGREG",194,0)
1720 Q
1721"RTN","DGREG",195,0)
1722 ;
1723"RTN","DGREG",196,0)
1724IFREG(DFN) ;
1725"RTN","DGREG",197,0)
1726 ;Description: tests whether the lock set by BEGINREG is set
1727"RTN","DGREG",198,0)
1728 ;
1729"RTN","DGREG",199,0)
1730 ;Input: DFN
1731"RTN","DGREG",200,0)
1732 ;Output:
1733"RTN","DGREG",201,0)
1734 ; Function Value = 1 if lock is set, 0 otherwise
1735"RTN","DGREG",202,0)
1736 ;
1737"RTN","DGREG",203,0)
1738 N RETURN
1739"RTN","DGREG",204,0)
1740 Q:'$G(DFN) 0
1741"RTN","DGREG",205,0)
1742 L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
1743"RTN","DGREG",206,0)
1744 S RETURN='$T
1745"RTN","DGREG",207,0)
1746 L -^TMP(DFN,"REGISTRATION IN PROGRESS")
1747"RTN","DGREG",208,0)
1748 Q RETURN
1749"RTN","DGREG",209,0)
1750 Q
1751"RTN","DGREG",210,0)
1752CIRN ;MPI QUERY
1753"RTN","DGREG",211,0)
1754 ;check to see if CIRN PD/MPI is installed
1755"RTN","DGREG",212,0)
1756 N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T
1757"RTN","DGREG",213,0)
1758 K MPIFRTN
1759"RTN","DGREG",214,0)
1760 D MPIQ^MPIFAPI(DFN)
1761"RTN","DGREG",215,0)
1762 K MPIFRTN
1763"RTN","DGREG",216,0)
1764 Q
1765"RTN","DGREG",217,0)
1766ROMQRY ;
1767"RTN","DGREG",218,0)
1768 I +$G(DGNEW) D
1769"RTN","DGREG",219,0)
1770 . ; query LST for Patient Demographic Information if NEW patient and
1771"RTN","DGREG",220,0)
1772 . ; file into patient's record.
1773"RTN","DGREG",221,0)
1774 . N A
1775"RTN","DGREG",222,0)
1776 . I $$ROMQRY^DGROAPI(DFN) D
1777"RTN","DGREG",223,0)
1778 . . ;display busy message to interactive users
1779"RTN","DGREG",224,0)
1780 . .S DGMSG(1)="Data retrieval from LST site has been completed successfully"
1781"RTN","DGREG",225,0)
1782 . .S DGMSG(2)="Thank you for your patience."
1783"RTN","DGREG",226,0)
1784 . .D EN^DDIOL(.DGMSG) R A:5
1785"RTN","DGREG",227,0)
1786 . E D
1787"RTN","DGREG",228,0)
1788 . . ;display busy message to interactive users
1789"RTN","DGREG",229,0)
1790 . .S DGMSG(1)="Data retrieval from LST site has not been successful."
1791"RTN","DGREG",230,0)
1792 . .S DGMSG(2)="Please continue the Registration Process."
1793"RTN","DGREG",231,0)
1794 . .D EN^DDIOL(.DGMSG) R A:5
1795"RTN","DGREG",232,0)
1796 . ;
1797"RTN","DGREG",233,0)
1798 Q
1799"RTN","DGRP2")
18000^8^B19865142
1801"RTN","DGRP2",1,0)
1802DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ; 11/7/12 12:41pm
1803"RTN","DGRP2",2,0)
1804 ;;5.3;Registration;**415,545,638,677,760,634,VW1**;Aug 13, 1993;Build 18
1805"RTN","DGRP2",3,0)
1806 ; Modified from FOIA VISTA,
1807"RTN","DGRP2",4,0)
1808 ; Copyright (C) 2007 WorldVistA
1809"RTN","DGRP2",5,0)
1810 ;
1811"RTN","DGRP2",6,0)
1812 ; This program is free software; you can redistribute it and/or modify
1813"RTN","DGRP2",7,0)
1814 ; it under the terms of the GNU General Public License as published by
1815"RTN","DGRP2",8,0)
1816 ; the Free Software Foundation; either version 2 of the License, or
1817"RTN","DGRP2",9,0)
1818 ; (at your option) any later version.
1819"RTN","DGRP2",10,0)
1820 ;
1821"RTN","DGRP2",11,0)
1822 ; This program is distributed in the hope that it will be useful,
1823"RTN","DGRP2",12,0)
1824 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
1825"RTN","DGRP2",13,0)
1826 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1827"RTN","DGRP2",14,0)
1828 ; GNU General Public License for more details.
1829"RTN","DGRP2",15,0)
1830 ;
1831"RTN","DGRP2",16,0)
1832 ; You should have received a copy of the GNU General Public License
1833"RTN","DGRP2",17,0)
1834 ; along with this program; if not, write to the Free Software
1835"RTN","DGRP2",18,0)
1836 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
1837"RTN","DGRP2",19,0)
1838 S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
1839"RTN","DGRP2",20,0)
1840 S DGRPX=DGRP(0)
1841"RTN","DGRP2",21,0)
1842 S (Z,DGRPW)=1 D WW^DGRPV W " Marital: " S Z=$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),Z1=30 D WW1^DGRPV
1843"RTN","DGRP2",22,0)
1844 ;S (Z,DGRPW)=1 D WW^DGRPV W " Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV
1845"RTN","DGRP2",23,0)
1846 S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
1847"RTN","DGRP2",24,0)
1848 W ?41,"POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29)
1849"RTN","DGRP2",25,0)
1850 ;S DGRPX=DGRP(0)
1851"RTN","DGRP2",26,0)
1852 W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU)
1853"RTN","DGRP2",27,0)
1854 S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QP"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
1855"RTN","DGRP2",28,0)
1856 W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
1857"RTN","DGRP2",29,0)
1858 W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
1859"RTN","DGRP2",30,0)
1860 W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X
1861"RTN","DGRP2",31,0)
1862 E F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
1863"RTN","DGRP2",32,0)
1864 ;
1865"RTN","DGRP2",33,0)
1866 ; ** start of VOE change: DAOU,VA/CJS,WV/TOAD 1/5/2006 ** ;p634
1867"RTN","DGRP2",34,0)
1868 ;
1869"RTN","DGRP2",35,0)
1870 ; New VOE Patient fields
1871"RTN","DGRP2",36,0)
1872 ;
1873"RTN","DGRP2",37,0)
1874 ; insert 7 lines:
1875"RTN","DGRP2",38,0)
1876 ;
1877"RTN","DGRP2",39,0)
1878 I $G(DUZ("AG"))="E" D
1879"RTN","DGRP2",40,0)
1880 . W !?4,"Veteran: ",$$GET1^DIQ(2,DFN,19902)
1881"RTN","DGRP2",41,0)
1882 . W !,"Interpreter Language: "
1883"RTN","DGRP2",42,0)
1884 . N IL S IL=""
1885"RTN","DGRP2",43,0)
1886 . N I F I=1:1 S IL=$O(^DPT(DFN,19901,"B",IL)) Q:IL="" D
1887"RTN","DGRP2",44,0)
1888 . . I I'=1 W ","
1889"RTN","DGRP2",45,0)
1890 . . W $$GET1^DIQ(.85,IL,.01) ; modified by VEN/SMH 3121107 *VW1
1891"RTN","DGRP2",46,0)
1892 ;
1893"RTN","DGRP2",47,0)
1894 ; next three groups of lines have been conditionalized to only display
1895"RTN","DGRP2",48,0)
1896 ; for VA agency code; also, refactored for clarity
1897"RTN","DGRP2",49,0)
1898 ;
1899"RTN","DGRP2",50,0)
1900 I $G(DUZ("AG"))="V" D
1901"RTN","DGRP2",51,0)
1902 . W ! S Z=2 D WW^DGRPV
1903"RTN","DGRP2",52,0)
1904 . W " Previous Care Date Location of Previous Care"
1905"RTN","DGRP2",53,0)
1906 . W !?4,"------------------ -------------------------"
1907"RTN","DGRP2",54,0)
1908 . S DGRPX=DGRP(1010.15)
1909"RTN","DGRP2",55,0)
1910 . ;
1911"RTN","DGRP2",56,0)
1912 . I $P(DGRPX,"^",5)'="Y" D
1913"RTN","DGRP2",57,0)
1914 . . S X="NONE INDICATED"
1915"RTN","DGRP2",58,0)
1916 . . W !?4,X,?28,X
1917"RTN","DGRP2",59,0)
1918 . ;
1919"RTN","DGRP2",60,0)
1920 . E F I=1:1:4 D
1921"RTN","DGRP2",61,0)
1922 . . S I1=$P(DGRPX,"^",I)
1923"RTN","DGRP2",62,0)
1924 . . X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
1925"RTN","DGRP2",63,0)
1926 . . I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
1927"RTN","DGRP2",64,0)
1928 ;
1929"RTN","DGRP2",65,0)
1930 ; ** end of VOE change **; p634
1931"RTN","DGRP2",66,0)
1932 ;
1933"RTN","DGRP2",67,0)
1934 W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
1935"RTN","DGRP2",68,0)
1936 .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q
1937"RTN","DGRP2",69,0)
1938 .N NODE,NUM,ETHNIC
1939"RTN","DGRP2",70,0)
1940 .S I=0
1941"RTN","DGRP2",71,0)
1942 .F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I D
1943"RTN","DGRP2",72,0)
1944 ..S NODE=$G(^DPT(DFN,.06,I,0))
1945"RTN","DGRP2",73,0)
1946 ..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1)
1947"RTN","DGRP2",74,0)
1948 ..S ETHNIC=$S(X="":"?????",1:X)
1949"RTN","DGRP2",75,0)
1950 ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
1951"RTN","DGRP2",76,0)
1952 ..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")"
1953"RTN","DGRP2",77,0)
1954 ..I NUM S ETHNIC=", "_ETHNIC
1955"RTN","DGRP2",78,0)
1956 ..I ($X+$L(ETHNIC))>IOM D W !?15
1957"RTN","DGRP2",79,0)
1958 ...F S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM W X S ETHNIC=$P(ETHNIC," ",2,999)
1959"RTN","DGRP2",80,0)
1960 ..W ETHNIC
1961"RTN","DGRP2",81,0)
1962 W !?9,"Race: " D
1963"RTN","DGRP2",82,0)
1964 .I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q
1965"RTN","DGRP2",83,0)
1966 .N NODE,NUM,RACE
1967"RTN","DGRP2",84,0)
1968 .S I=0
1969"RTN","DGRP2",85,0)
1970 .F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I D
1971"RTN","DGRP2",86,0)
1972 ..S NODE=$G(^DPT(DFN,.02,I,0))
1973"RTN","DGRP2",87,0)
1974 ..S X=$P($G(^DIC(10,+NODE,0)),"^",1)
1975"RTN","DGRP2",88,0)
1976 ..S RACE=$S(X="":"?????",1:X)
1977"RTN","DGRP2",89,0)
1978 ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
1979"RTN","DGRP2",90,0)
1980 ..S RACE=RACE_" ("_$S(X="":"?",1:X)_")"
1981"RTN","DGRP2",91,0)
1982 ..I NUM S RACE=", "_RACE
1983"RTN","DGRP2",92,0)
1984 ..I ($X+$L(RACE))>IOM D W !?15
1985"RTN","DGRP2",93,0)
1986 ...F S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM W X S RACE=$P(RACE," ",2,999)
1987"RTN","DGRP2",94,0)
1988 ..W RACE
1989"RTN","DGRP2",95,0)
1990 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
1991"RTN","DGRP2",96,0)
1992 W !!
1993"RTN","DGRP2",97,0)
1994 W "<4> Date of Death Information"
1995"RTN","DGRP2",98,0)
1996 W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
1997"RTN","DGRP2",99,0)
1998 W ?41,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
1999"RTN","DGRP2",100,0)
2000 W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
2001"RTN","DGRP2",101,0)
2002 W ?41,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
2003"RTN","DGRP2",102,0)
2004 K PDTHINFO
2005"RTN","DGRP2",103,0)
2006 ;
2007"RTN","DGRP2",104,0)
2008 ;Emergency Response Indicator
2009"RTN","DGRP2",105,0)
2010 N DGEMRES S DGEMRES=$P($G(^DPT(DFN,.18)),"^")
2011"RTN","DGRP2",106,0)
2012 S Z=5 D WW^DGRPV W " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
2013"RTN","DGRP2",107,0)
2014 G ^DGRPP
2015"RTN","DGRPD")
20160^5^B87299590
2017"RTN","DGRPD",1,0)
2018DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC/BAJ-PATIENT INQUIRY (NEW) ; 11/5/12 1:01pm
2019"RTN","DGRPD",2,0)
2020 ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,688,634,VW1**;Aug 13, 1993;Build 18;WorldVistA 30-June-08
2021"RTN","DGRPD",3,0)
2022 ;
2023"RTN","DGRPD",4,0)
2024 ;Modified from FOIA VISTA,
2025"RTN","DGRPD",5,0)
2026 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
2027"RTN","DGRPD",6,0)
2028 ;General Public License See attached copy of the License.
2029"RTN","DGRPD",7,0)
2030 ;
2031"RTN","DGRPD",8,0)
2032 ;This program is free software; you can redistribute it and/or modify
2033"RTN","DGRPD",9,0)
2034 ;it under the terms of the GNU General Public License as published by
2035"RTN","DGRPD",10,0)
2036 ;the Free Software Foundation; either version 2 of the License, or
2037"RTN","DGRPD",11,0)
2038 ;(at your option) any later version.
2039"RTN","DGRPD",12,0)
2040 ;
2041"RTN","DGRPD",13,0)
2042 ;This program is distributed in the hope that it will be useful,
2043"RTN","DGRPD",14,0)
2044 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
2045"RTN","DGRPD",15,0)
2046 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2047"RTN","DGRPD",16,0)
2048 ;GNU General Public License for more details.
2049"RTN","DGRPD",17,0)
2050 ;
2051"RTN","DGRPD",18,0)
2052 ;You should have received a copy of the GNU General Public License along
2053"RTN","DGRPD",19,0)
2054 ;with this program; if not, write to the Free Software Foundation, Inc.,
2055"RTN","DGRPD",20,0)
2056 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
2057"RTN","DGRPD",21,0)
2058 ;
2059"RTN","DGRPD",22,0)
2060 ; *286* Newing variables X,Y in OKLINE subroutine
2061"RTN","DGRPD",23,0)
2062 ; *358* If a patient is on a domiciliary ward, don't display MEANS
2063"RTN","DGRPD",24,0)
2064 ; TEST required/Medication Copayment Exemption messages
2065"RTN","DGRPD",25,0)
2066 ; *436* If an inpatient is not on a domiciliary ward, don't display
2067"RTN","DGRPD",26,0)
2068 ; Medication Copayment Exemption message
2069"RTN","DGRPD",27,0)
2070 ; *545* Add death information near the remarks field
2071"RTN","DGRPD",28,0)
2072 ; *677* Added Emergency Response
2073"RTN","DGRPD",29,0)
2074 ; *688* Modified to display Country and Foreign Address
2075"RTN","DGRPD",30,0)
2076 ; *634* WV - Print the HRN in the CMOR line.
2077"RTN","DGRPD",31,0)
2078 ; *VW1* VEN/SMH - Add display of Preliminary cause of death
2079"RTN","DGRPD",32,0)
2080SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
2081"RTN","DGRPD",33,0)
2082EN ;call to display patient inquiry - input DFN
2083"RTN","DGRPD",34,0)
2084 ;MPI/PD CHANGE
2085"RTN","DGRPD",35,0)
2086 S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
2087"RTN","DGRPD",36,0)
2088 S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
2089"RTN","DGRPD",37,0)
2090 I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")
2091"RTN","DGRPD",38,0)
2092 ;END MPI/PD CHANGE
2093"RTN","DGRPD",39,0)
2094 K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1 F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
2095"RTN","DGRPD",40,0)
2096 S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
2097"RTN","DGRPD",41,0)
2098 W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
2099"RTN","DGRPD",42,0)
2100 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?9 W:'(I#2) ?48 W DGA(I)
2101"RTN","DGRPD",43,0)
2102 S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)
2103"RTN","DGRPD",44,0)
2104 N DGCNTRY,DGFORGN S DGCNTRY=$P(DGRP(.11),"^",10),DGFORGN=$$FORIEN^DGADDUTL(DGCNTRY) I 'DGFORGN W !?2,"County: ",DGCC
2105"RTN","DGRPD",45,0)
2106 S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
2107"RTN","DGRPD",46,0)
2108 N DGSKIP S DGSKIP=$S(DGFORGN:"!,?42,""From/To: """,1:"?42,""From/To: """) ;WorldVistA Change ;04/03/2010
2109"RTN","DGRPD",47,0)
2110 W @DGSKIP,X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPADW
2111"RTN","DGRPD",48,0)
2112 W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
2113"RTN","DGRPD",49,0)
2114 W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
2115"RTN","DGRPD",50,0)
2116 W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
2117"RTN","DGRPD",51,0)
2118 W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))
2119"RTN","DGRPD",52,0)
2120 D CA
2121"RTN","DGRPD",53,0)
2122 N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
2123"RTN","DGRPD",54,0)
2124 W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
2125"RTN","DGRPD",55,0)
2126 I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
2127"RTN","DGRPD",56,0)
2128 I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED")
2129"RTN","DGRPD",57,0)
2130 I 'DGABBRV W ! D
2131"RTN","DGRPD",58,0)
2132 .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
2133"RTN","DGRPD",59,0)
2134 .K ^UTILITY($J,"W")
2135"RTN","DGRPD",60,0)
2136 .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D
2137"RTN","DGRPD",61,0)
2138 ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
2139"RTN","DGRPD",62,0)
2140 ..Q:$$INACTIVE^DGUTL4(VAL,1)
2141"RTN","DGRPD",63,0)
2142 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
2143"RTN","DGRPD",64,0)
2144 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
2145"RTN","DGRPD",65,0)
2146 .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
2147"RTN","DGRPD",66,0)
2148 .K ^UTILITY($J,"W")
2149"RTN","DGRPD",67,0)
2150 .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D
2151"RTN","DGRPD",68,0)
2152 ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
2153"RTN","DGRPD",69,0)
2154 ..Q:$$INACTIVE^DGUTL4(VAL,2)
2155"RTN","DGRPD",70,0)
2156 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
2157"RTN","DGRPD",71,0)
2158 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
2159"RTN","DGRPD",72,0)
2160 .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
2161"RTN","DGRPD",73,0)
2162 .K ^UTILITY($J,"W")
2163"RTN","DGRPD",74,0)
2164 .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
2165"RTN","DGRPD",75,0)
2166 .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
2167"RTN","DGRPD",76,0)
2168 I '$$OKLINE^DGRPD1(16) G Q
2169"RTN","DGRPD",77,0)
2170 ;display cv status #4156
2171"RTN","DGRPD",78,0)
2172 ;Begin WorldVistA Change ;DG*5.3*634
2173"RTN","DGRPD",79,0)
2174 I DUZ("AG")="V" D
2175"RTN","DGRPD",80,0)
2176 . N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
2177"RTN","DGRPD",81,0)
2178 . W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
2179"RTN","DGRPD",82,0)
2180 ;End WorldVistA Change
2181"RTN","DGRPD",83,0)
2182 ;display primary eligibility
2183"RTN","DGRPD",84,0)
2184 S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
2185"RTN","DGRPD",85,0)
2186 W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
2187"RTN","DGRPD",86,0)
2188 I '$$OKLINE^DGRPD1(16) G Q
2189"RTN","DGRPD",87,0)
2190 ;employability status
2191"RTN","DGRPD",88,0)
2192 W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
2193"RTN","DGRPD",89,0)
2194 ;display the catastrophic disability review date if there is one
2195"RTN","DGRPD",90,0)
2196 D CATDIS^DGRPD1
2197"RTN","DGRPD",91,0)
2198 I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D
2199"RTN","DGRPD",92,0)
2200 . N DGPDT,DGPTM
2201"RTN","DGRPD",93,0)
2202 . W !,$$REPEAT^XLFSTR("-",78)
2203"RTN","DGRPD",94,0)
2204 . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
2205"RTN","DGRPD",95,0)
2206 . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
2207"RTN","DGRPD",96,0)
2208 . S DGPTM=$$PCTEAM^DGSDUTL(DFN)
2209"RTN","DGRPD",97,0)
2210 . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
2211"RTN","DGRPD",98,0)
2212 . W !,$$REPEAT^XLFSTR("-",78)
2213"RTN","DGRPD",99,0)
2214 ; Check if patient is an inpatient and on a DOM ward
2215"RTN","DGRPD",100,0)
2216 ; If inpatient is on a DOM ward, don't display MT or CP messages
2217"RTN","DGRPD",101,0)
2218 ; If inpatient is NOT on a DOM ward, don't display CP message
2219"RTN","DGRPD",102,0)
2220 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
2221"RTN","DGRPD",103,0)
2222 G Q:'$$OKLINE^DGRPD1(14)
2223"RTN","DGRPD",104,0)
2224 D DOM^DGMTR
2225"RTN","DGRPD",105,0)
2226 I '$G(DGDOM) D
2227"RTN","DGRPD",106,0)
2228 .D DIS^DGMTU(DFN)
2229"RTN","DGRPD",107,0)
2230 .D IN5^VADPT
2231"RTN","DGRPD",108,0)
2232 .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
2233"RTN","DGRPD",109,0)
2234 ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
2235"RTN","DGRPD",110,0)
2236 D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518)
2237"RTN","DGRPD",111,0)
2238 S VAIP("L")=""
2239"RTN","DGRPD",112,0)
2240 I $$OKLINE^DGRPD1(14) D INP
2241"RTN","DGRPD",113,0)
2242 I '$G(DGRPOUT),($$OKLINE^DGRPD1(17)) D SA
2243"RTN","DGRPD",114,0)
2244 ;MPI/PD CHANGE
2245"RTN","DGRPD",115,0)
2246Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
2247"RTN","DGRPD",116,0)
2248CA ;Confidential Address
2249"RTN","DGRPD",117,0)
2250 W !!?1,"Confidential Address: ",?44,"Confidential Address Categories:"
2251"RTN","DGRPD",118,0)
2252 N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR
2253"RTN","DGRPD",119,0)
2254 S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
2255"RTN","DGRPD",120,0)
2256 I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D Q
2257"RTN","DGRPD",121,0)
2258 .W !?9,"NO CONFIDENTIAL ADDRESS"
2259"RTN","DGRPD",122,0)
2260 .W !?1,"From/To: NOT APPLICABLE"
2261"RTN","DGRPD",123,0)
2262 S DGAD=.141,(DGA1,DGA2)=1
2263"RTN","DGRPD",124,0)
2264 D AL^DGRPU(30)
2265"RTN","DGRPD",125,0)
2266 D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")
2267"RTN","DGRPD",126,0)
2268 ;Format Confidential Address categories
2269"RTN","DGRPD",127,0)
2270 N DGIEN,DGCAST
2271"RTN","DGRPD",128,0)
2272 S DGIEN=0
2273"RTN","DGRPD",129,0)
2274 S DGA2=2
2275"RTN","DGRPD",130,0)
2276 F S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGIEN D
2277"RTN","DGRPD",131,0)
2278 .S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")
2279"RTN","DGRPD",132,0)
2280 .S DGCAST=DGARRAY(2.141,DGIEN,1,"E")
2281"RTN","DGRPD",133,0)
2282 .S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"
2283"RTN","DGRPD",134,0)
2284 .S DGA2=DGA2+2
2285"RTN","DGRPD",135,0)
2286 S I=0 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>43) !?9 W:'(I#2) ?44 W DGA(I)
2287"RTN","DGRPD",136,0)
2288 W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")
2289"RTN","DGRPD",137,0)
2290 Q
2291"RTN","DGRPD",138,0)
2292INP S VAIP("D")="L" D INP^DGPMV10
2293"RTN","DGRPD",139,0)
2294 S DGPMT=0
2295"RTN","DGRPD",140,0)
2296 D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
2297"RTN","DGRPD",141,0)
2298SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT)
2299"RTN","DGRPD",142,0)
2300 Q
2301"RTN","DGRPD",143,0)
2302SAA ;Scheduled Admit Data
2303"RTN","DGRPD",144,0)
2304 W !!?14,"Scheduled Admit"
2305"RTN","DGRPD",145,0)
2306 W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
2307"RTN","DGRPD",146,0)
2308 W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
2309"RTN","DGRPD",147,0)
2310 W " on "_$$FMTE^XLFDT(L,"5DZ")
2311"RTN","DGRPD",148,0)
2312 Q ;SAA
2313"RTN","DGRPD",149,0)
2314 ;
2315"RTN","DGRPD",150,0)
2316CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
2317"RTN","DGRPD",151,0)
2318 ;
2319"RTN","DGRPD",152,0)
2320FA G:'$$OKLINE^DGRPD1(20) RMK
2321"RTN","DGRPD",153,0)
2322 ;
2323"RTN","DGRPD",154,0)
2324 N DGARRAY,SDCNT
2325"RTN","DGRPD",155,0)
2326 S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
2327"RTN","DGRPD",156,0)
2328 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
2329"RTN","DGRPD",157,0)
2330 ;if there is lower subscripts hanging from the 101 node,
2331"RTN","DGRPD",158,0)
2332 ;then it is a valid appointment, otherwise it is
2333"RTN","DGRPD",159,0)
2334 ;an error eg 01/20/2005
2335"RTN","DGRPD",160,0)
2336 I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
2337"RTN","DGRPD",161,0)
2338 I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
2339"RTN","DGRPD",162,0)
2340 ;
2341"RTN","DGRPD",163,0)
2342 W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
2343"RTN","DGRPD",164,0)
2344 F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5
2345"RTN","DGRPD",165,0)
2346 .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
2347"RTN","DGRPD",166,0)
2348 .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
2349"RTN","DGRPD",167,0)
2350 ..D COV
2351"RTN","DGRPD",168,0)
2352 ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
2353"RTN","DGRPD",169,0)
2354 ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
2355"RTN","DGRPD",170,0)
2356 ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
2357"RTN","DGRPD",171,0)
2358 ..Q
2359"RTN","DGRPD",172,0)
2360 I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
2361"RTN","DGRPD",173,0)
2362RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)
2363"RTN","DGRPD",174,0)
2364 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
2365"RTN","DGRPD",175,0)
2366 ;Begin WorldVistA change ;11-4-2012 SMH; *VW1*
2367"RTN","DGRPD",176,0)
2368 N VWOK,VWDEATH ; Results of GETS1, Preliminary cause of death
2369"RTN","DGRPD",177,0)
2370 S VWOK=$$GET1^DIQ(2,DFN_",",250043.1,"","VWDEATH")
2371"RTN","DGRPD",178,0)
2372 ;End WorldVistA change
2373"RTN","DGRPD",179,0)
2374 W !!
2375"RTN","DGRPD",180,0)
2376 W "Date of Death Information"
2377"RTN","DGRPD",181,0)
2378 W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
2379"RTN","DGRPD",182,0)
2380 W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
2381"RTN","DGRPD",183,0)
2382 W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
2383"RTN","DGRPD",184,0)
2384 W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
2385"RTN","DGRPD",185,0)
2386 ;Begin WorldVistA Change ;11-4-2012 SMH; *VW1*
2387"RTN","DGRPD",186,0)
2388 W ?5,"Preliminary Cause of Death: ",!
2389"RTN","DGRPD",187,0)
2390 I $O(VWDEATH(0)) D ; if we have data in the WP field
2391"RTN","DGRPD",188,0)
2392 . N X,DIWL,DIWR,DIWF ; stuff value, LM, RM, Format control
2393"RTN","DGRPD",189,0)
2394 . S DIWL=1,DIWR=$G(IOM,80) ; LM=1 ; RM=IOM or 80
2395"RTN","DGRPD",190,0)
2396 . S DIWF="I7" ; Print text at the 7th column
2397"RTN","DGRPD",191,0)
2398 . K ^UTILITY($J,"W") ; Kill scratch global for this
2399"RTN","DGRPD",192,0)
2400 . N I S I=0 F S I=$O(VWDEATH(I)) Q:'I S X=VWDEATH(I) D ^DIWP
2401"RTN","DGRPD",193,0)
2402 . D ^DIWW
2403"RTN","DGRPD",194,0)
2404 . K ^UTILITY($J,"W") ; Kill scratch global again
2405"RTN","DGRPD",195,0)
2406 ;End WorldVistA Change
2407"RTN","DGRPD",196,0)
2408 I $$OKLINE^DGRPD1(14) D EC^DGRPD1
2409"RTN","DGRPD",197,0)
2410 K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
2411"RTN","DGRPD",198,0)
2412 Q
2413"RTN","DGRPD",199,0)
2414COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
2415"RTN","DGRPD",200,0)
2416 S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
2417"RTN","DGRPD",201,0)
2418 Q
2419"RTN","DGRPD",202,0)
2420 ;
2421"RTN","DGRPD",203,0)
2422OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
2423"RTN","DGRPD",204,0)
2424 Q
2425"RTN","DGRPD",205,0)
2426 ;Begin WorldVista Change ;DG*5.3*634
2427"RTN","DGRPD",206,0)
2428HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
2429"RTN","DGRPD",207,0)
2430 ;MPI/PD CHANGE
2431"RTN","DGRPD",208,0)
2432 W @IOF,!,$P(VADM(1),"^",1),?32,$P(VADM(2),"^",2),?50,$$HRNV(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
2433"RTN","DGRPD",209,0)
2434 ;END MPI/PD CHANGE
2435"RTN","DGRPD",210,0)
2436HRNV(DFN) ;
2437"RTN","DGRPD",211,0)
2438 N IRET
2439"RTN","DGRPD",212,0)
2440 S IRET=$$HRN^DGLBPID(DFN)
2441"RTN","DGRPD",213,0)
2442 I IRET="#" Q ""
2443"RTN","DGRPD",214,0)
2444 S IRET="HRN "_IRET
2445"RTN","DGRPD",215,0)
2446 Q IRET
2447"RTN","DGRPD",216,0)
2448 ;End WorldVistA Change
2449"RTN","ORCXPND1")
24500^4^B74010927
2451"RTN","ORCXPND1",1,0)
2452ORCXPND1 ; SLC/MKB - Expanded Display cont ;6:25 PM 20 Jun 2011 ; 11/5/12 1:02pm
2453"RTN","ORCXPND1",2,0)
2454 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 18
2455"RTN","ORCXPND1",3,0)
2456 ;
2457"RTN","ORCXPND1",4,0)
2458 ; External References
2459"RTN","ORCXPND1",5,0)
2460 ; DBIA 2387 ^LAB(60
2461"RTN","ORCXPND1",6,0)
2462 ; DBIA 3420 ^DPT( file #2
2463"RTN","ORCXPND1",7,0)
2464 ; DBIA 10035 ^DPT( file #2
2465"RTN","ORCXPND1",8,0)
2466 ; DBIA 10037 EN^DGRPD
2467"RTN","ORCXPND1",9,0)
2468 ; DBIA 700 DIS^DGRPDB
2469"RTN","ORCXPND1",10,0)
2470 ; DBIA 2926 RT^GMRCGUIA
2471"RTN","ORCXPND1",11,0)
2472 ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR"
2473"RTN","ORCXPND1",12,0)
2474 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR"
2475"RTN","ORCXPND1",13,0)
2476 ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC"
2477"RTN","ORCXPND1",14,0)
2478 ; DBIA 2952 EN^LR7OSMZ0
2479"RTN","ORCXPND1",15,0)
2480 ; DBIA 2400 OEL^PSOORRL ^TMP("PS"
2481"RTN","ORCXPND1",16,0)
2482 ; DBIA 2877 EN3^RAO7PC3
2483"RTN","ORCXPND1",17,0)
2484 ; DBIA 2877 EN30^RAO7PC3
2485"RTN","ORCXPND1",18,0)
2486 ; DBIA 1252 $$OUTPTPR^SDUTL3
2487"RTN","ORCXPND1",19,0)
2488 ; DBIA 1252 $$OUTPTTM^SDUTL3
2489"RTN","ORCXPND1",20,0)
2490 ; DBIA 2832 RPC^TIUSRV
2491"RTN","ORCXPND1",21,0)
2492 ; DBIA 10061 DEM^VADPT
2493"RTN","ORCXPND1",22,0)
2494 ; DBIA 10061 KVAR^VADPT
2495"RTN","ORCXPND1",23,0)
2496 ; DBIA 10061 OAD^VADPT
2497"RTN","ORCXPND1",24,0)
2498 ; DBIA 10103 $$FMTE^XLFDT
2499"RTN","ORCXPND1",25,0)
2500 ; DBIA 4408 DISP^DGIBDSP
2501"RTN","ORCXPND1",26,0)
2502 ;
2503"RTN","ORCXPND1",27,0)
2504COVER ; -- Cover Sheet
2505"RTN","ORCXPND1",28,0)
2506 N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
2507"RTN","ORCXPND1",29,0)
2508 D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU"
2509"RTN","ORCXPND1",30,0)
2510 Q
2511"RTN","ORCXPND1",31,0)
2512NOTES ; -- Progress Notes
2513"RTN","ORCXPND1",32,0)
2514 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
2515"RTN","ORCXPND1",33,0)
2516 D RPC^TIUSRV(.ORY,ID)
2517"RTN","ORCXPND1",34,0)
2518 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
2519"RTN","ORCXPND1",35,0)
2520 K @ORY
2521"RTN","ORCXPND1",36,0)
2522 Q
2523"RTN","ORCXPND1",37,0)
2524PROBLEMS ; -- Problem List
2525"RTN","ORCXPND1",38,0)
2526 D PL^ORCXPND4
2527"RTN","ORCXPND1",39,0)
2528 Q
2529"RTN","ORCXPND1",40,0)
2530MEDS ; -- Pharmacy
2531"RTN","ORCXPND1",41,0)
2532 ;N NODE,ORIFN
2533"RTN","ORCXPND1",42,0)
2534 K ^TMP("PS",$J)
2535"RTN","ORCXPND1",43,0)
2536 D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11)
2537"RTN","ORCXPND1",44,0)
2538 S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400
2539"RTN","ORCXPND1",45,0)
2540 ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2")
2541"RTN","ORCXPND1",46,0)
2542 K ^TMP("PS",$J)
2543"RTN","ORCXPND1",47,0)
2544 Q
2545"RTN","ORCXPND1",48,0)
2546LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #]
2547"RTN","ORCXPND1",49,0)
2548 N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT
2549"RTN","ORCXPND1",50,0)
2550 K ^TMP("LRRR",$J) ;DBIA 2503
2551"RTN","ORCXPND1",51,0)
2552 I (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N) D AP^ORCXPND3 Q ;ID=Accession #-Date/time specimen taken
2553"RTN","ORCXPND1",52,0)
2554 S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab#
2555"RTN","ORCXPND1",53,0)
2556 I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
2557"RTN","ORCXPND1",54,0)
2558 I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4))
2559"RTN","ORCXPND1",55,0)
2560 K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80)
2561"RTN","ORCXPND1",56,0)
2562 S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X)
2563"RTN","ORCXPND1",57,0)
2564 D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
2565"RTN","ORCXPND1",58,0)
2566 M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS=""
2567"RTN","ORCXPND1",59,0)
2568 F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D
2569"RTN","ORCXPND1",60,0)
2570 . I SS="BB" D
2571"RTN","ORCXPND1",61,0)
2572 .. I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface
2573"RTN","ORCXPND1",62,0)
2574 ... K ^TMP("ORLRC",$J)
2575"RTN","ORCXPND1",63,0)
2576 ... D EN^ORWLR1(DFN)
2577"RTN","ORCXPND1",64,0)
2578 ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
2579"RTN","ORCXPND1",65,0)
2580 ... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
2581"RTN","ORCXPND1",66,0)
2582 ... K ^TMP("ORLRC",$J)
2583"RTN","ORCXPND1",67,0)
2584 .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951
2585"RTN","ORCXPND1",68,0)
2586 ... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
2587"RTN","ORCXPND1",69,0)
2588 ... K ^TMP("LRC",$J)
2589"RTN","ORCXPND1",70,0)
2590 . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q
2591"RTN","ORCXPND1",71,0)
2592 .. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
2593"RTN","ORCXPND1",72,0)
2594 .. K ^TMP("LRC",$J)
2595"RTN","ORCXPND1",73,0)
2596 . I SS="CH" D Q
2597"RTN","ORCXPND1",74,0)
2598 .. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D
2599"RTN","ORCXPND1",75,0)
2600 ... I TCNT=1 D
2601"RTN","ORCXPND1",76,0)
2602 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1)
2603"RTN","ORCXPND1",77,0)
2604 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
2605"RTN","ORCXPND1",78,0)
2606 ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D
2607"RTN","ORCXPND1",79,0)
2608 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15))
2609"RTN","ORCXPND1",80,0)
2610 .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
2611"RTN","ORCXPND1",81,0)
2612 .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
2613"RTN","ORCXPND1",82,0)
2614 ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D
2615"RTN","ORCXPND1",83,0)
2616 .... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT)
2617"RTN","ORCXPND1",84,0)
2618 K ^TMP("LRRR",$J)
2619"RTN","ORCXPND1",85,0)
2620 Q
2621"RTN","ORCXPND1",86,0)
2622 ;
2623"RTN","ORCXPND1",87,0)
2624DELAY ; -- Delayed Orders
2625"RTN","ORCXPND1",88,0)
2626NEW ; -- New Orders
2627"RTN","ORCXPND1",89,0)
2628ORDERS ; -- Orders
2629"RTN","ORCXPND1",90,0)
2630 I '$G(ORESULTS) D ORDERS^ORCXPND2 Q
2631"RTN","ORCXPND1",91,0)
2632 ; -- Results Display (Add more packages as available)
2633"RTN","ORCXPND1",92,0)
2634 N PKG,TAB,ORIFN
2635"RTN","ORCXPND1",93,0)
2636 S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG)
2637"RTN","ORCXPND1",94,0)
2638 S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
2639"RTN","ORCXPND1",95,0)
2640 I '$L(TAB)!(ID'>0) D Q ; no display available
2641"RTN","ORCXPND1",96,0)
2642 . N ORY,I D TEXT^ORQ12(.ORY,+ID,80)
2643"RTN","ORCXPND1",97,0)
2644 . S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I))
2645"RTN","ORCXPND1",98,0)
2646 . D BLANK^ORCXPND
2647"RTN","ORCXPND1",99,0)
2648 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report."
2649"RTN","ORCXPND1",100,0)
2650 I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB
2651"RTN","ORCXPND1",101,0)
2652 I '$O(^OR(100,+ID,2,0)) D @TAB
2653"RTN","ORCXPND1",102,0)
2654 Q
2655"RTN","ORCXPND1",103,0)
2656REPORTS ; -- Patient Profiles
2657"RTN","ORCXPND1",104,0)
2658 D EN^ORCXPNDR ; Reports
2659"RTN","ORCXPND1",105,0)
2660 Q
2661"RTN","ORCXPND1",106,0)
2662CONSULTS ; -- Consults
2663"RTN","ORCXPND1",107,0)
2664 N I,X,SUB,ORTX ;,VALMAR
2665"RTN","ORCXPND1",108,0)
2666 I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
2667"RTN","ORCXPND1",109,0)
2668 E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order#
2669"RTN","ORCXPND1",110,0)
2670 D ITEM^ORCXPND(X),BLANK^ORCXPND
2671"RTN","ORCXPND1",111,0)
2672 I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
2673"RTN","ORCXPND1",112,0)
2674 I '$G(ORESULTS) D ;DT action
2675"RTN","ORCXPND1",113,0)
2676 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID
2677"RTN","ORCXPND1",114,0)
2678 . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925
2679"RTN","ORCXPND1",115,0)
2680 I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT"
2681"RTN","ORCXPND1",116,0)
2682 S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925
2683"RTN","ORCXPND1",117,0)
2684 K ^TMP("GMRCR",$J)
2685"RTN","ORCXPND1",118,0)
2686 Q
2687"RTN","ORCXPND1",119,0)
2688XRAYS ; -- Radiology
2689"RTN","ORCXPND1",120,0)
2690 I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID)
2691"RTN","ORCXPND1",121,0)
2692 I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID)
2693"RTN","ORCXPND1",122,0)
2694 N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET"))
2695"RTN","ORCXPND1",123,0)
2696 S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D
2697"RTN","ORCXPND1",124,0)
2698 . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q
2699"RTN","ORCXPND1",125,0)
2700 . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND
2701"RTN","ORCXPND1",126,0)
2702 I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report
2703"RTN","ORCXPND1",127,0)
2704 K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W")
2705"RTN","ORCXPND1",128,0)
2706 S VALM("RM")=81
2707"RTN","ORCXPND1",129,0)
2708 Q
2709"RTN","ORCXPND1",130,0)
2710 ;
2711"RTN","ORCXPND1",131,0)
2712XRPT ; -- Body of Report for CASE, PROC
2713"RTN","ORCXPND1",132,0)
2714 N ORD,X,I
2715"RTN","ORCXPND1",133,0)
2716 S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD
2717"RTN","ORCXPND1",134,0)
2718 S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1
2719"RTN","ORCXPND1",135,0)
2720 Q
2721"RTN","ORCXPND1",136,0)
2722 ;
2723"RTN","ORCXPND1",137,0)
2724SUMMRIES ; -- Discharge Summaries
2725"RTN","ORCXPND1",138,0)
2726 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
2727"RTN","ORCXPND1",139,0)
2728 D RPC^TIUSRV(.ORY,ID)
2729"RTN","ORCXPND1",140,0)
2730 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
2731"RTN","ORCXPND1",141,0)
2732 K @ORY
2733"RTN","ORCXPND1",142,0)
2734 Q
2735"RTN","ORCXPND1",143,0)
2736PTINQ ; Print Patient Inquiry in List Manager
2737"RTN","ORCXPND1",144,0)
2738 N DFN,ORI,X
2739"RTN","ORCXPND1",145,0)
2740 S DFN=+ORVP
2741"RTN","ORCXPND1",146,0)
2742 D DGINQ(DFN)
2743"RTN","ORCXPND1",147,0)
2744 S ORI=4,LCNT=0
2745"RTN","ORCXPND1",148,0)
2746 F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D
2747"RTN","ORCXPND1",149,0)
2748 . S LCNT=LCNT+1
2749"RTN","ORCXPND1",150,0)
2750 . S ^TMP("ORXPND",$J,LCNT,0)=X
2751"RTN","ORCXPND1",151,0)
2752 K ^TMP("ORDATA",$J,1)
2753"RTN","ORCXPND1",152,0)
2754 Q
2755"RTN","ORCXPND1",153,0)
2756 ;
2757"RTN","ORCXPND1",154,0)
2758DGINQ(DFN) ; Patient Inquiry
2759"RTN","ORCXPND1",155,0)
2760 D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
2761"RTN","ORCXPND1",156,0)
2762 Q
2763"RTN","ORCXPND1",157,0)
2764DGINQB(DFN) ; Build Patient Inquiry
2765"RTN","ORCXPND1",158,0)
2766 N CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA
2767"RTN","ORCXPND1",159,0)
2768 S ORVP=DFN_";DPT(",XQORNOD=1
2769"RTN","ORCXPND1",160,0)
2770 D EN^DGRPD ; MAS Patient Inquiry
2771"RTN","ORCXPND1",161,0)
2772 ;
2773"RTN","ORCXPND1",162,0)
2774 S ORDOC=$$OUTPTPR^SDUTL3(DFN)
2775"RTN","ORCXPND1",163,0)
2776 S ORTEAM=$$OUTPTTM^SDUTL3(DFN)
2777"RTN","ORCXPND1",164,0)
2778 I ORDOC!ORTEAM D
2779"RTN","ORCXPND1",165,0)
2780 . W !!,"Primary Care Information:"
2781"RTN","ORCXPND1",166,0)
2782 . I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2)
2783"RTN","ORCXPND1",167,0)
2784 . I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2)
2785"RTN","ORCXPND1",168,0)
2786 W !!,"Health Insurance Information:"
2787"RTN","ORCXPND1",169,0)
2788 D DISP^DGIBDSP ;DBIA #4408
2789"RTN","ORCXPND1",170,0)
2790 W !!,"Service Connection/Rated Disabilities:"
2791"RTN","ORCXPND1",171,0)
2792 D DIS^DGRPDB
2793"RTN","ORCXPND1",172,0)
2794 F CONTACT="N","S" D
2795"RTN","ORCXPND1",173,0)
2796 .S VAOA("A")=$S(CONTACT="N":"",1:3)
2797"RTN","ORCXPND1",174,0)
2798 .D OAD^VADPT ; Get NOK Information
2799"RTN","ORCXPND1",175,0)
2800 .I VAOA(9)]"" D
2801"RTN","ORCXPND1",176,0)
2802 .. W !!,$S(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:")
2803"RTN","ORCXPND1",177,0)
2804 .. W !,"Name: ",VAOA(9) ; NOK Name
2805"RTN","ORCXPND1",178,0)
2806 .. I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship
2807"RTN","ORCXPND1",179,0)
2808 .. I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1
2809"RTN","ORCXPND1",180,0)
2810 .. I VAOA(2)]"" W !?7,VAOA(2) ; Line 2
2811"RTN","ORCXPND1",181,0)
2812 .. I VAOA(3)]"" W !?7,VAOA(3) ; Line 3
2813"RTN","ORCXPND1",182,0)
2814 .. I VAOA(4)]"" D
2815"RTN","ORCXPND1",183,0)
2816 .. . W !?7,VAOA(4) ; City
2817"RTN","ORCXPND1",184,0)
2818 .. . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State
2819"RTN","ORCXPND1",185,0)
2820 .. . W " ",$P(VAOA(11),"^",2) ; Zip+4
2821"RTN","ORCXPND1",186,0)
2822 .. I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone
2823"RTN","ORCXPND1",187,0)
2824 .. I CONTACT="N",$P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11)
2825"RTN","ORCXPND1",188,0)
2826 .. I CONTACT="S",$P($G(^DPT(DFN,.211)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.211),U,11)
2827"RTN","ORCXPND1",189,0)
2828 D ;Meaningful Use change
2829"RTN","ORCXPND1",190,0)
2830 . W !?7,"Language Preference: ",$$GET1^DIQ(2,DFN_",",256000)
2831"RTN","ORCXPND1",191,0)
2832 . I $D(DIERR) D CLEAN^DILF
2833"RTN","ORCXPND1",192,0)
2834 . Q
2835"RTN","ORCXPND1",193,0)
2836 D KVAR^VADPT
2837"RTN","ORCXPND1",194,0)
2838 Q
2839"RTN","ORCXPND1",195,0)
2840TRIM(X) ; Trim Spaces
2841"RTN","ORCXPND1",196,0)
2842 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
2843"RTN","ORCXPND1",197,0)
2844 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
2845"RTN","ORCXPND1",198,0)
2846 Q X
2847"RTN","ORCXPND1",199,0)
2848S(X,Y,Z) ; Pad Over
2849"RTN","ORCXPND1",200,0)
2850 ; X=Column #
2851"RTN","ORCXPND1",201,0)
2852 ; Y=Current Length
2853"RTN","ORCXPND1",202,0)
2854 ; Z=Text
2855"RTN","ORCXPND1",203,0)
2856 ; SP=Text Sent
2857"RTN","ORCXPND1",204,0)
2858 ; CCNT=Line Position After Input Text
2859"RTN","ORCXPND1",205,0)
2860 I '$D(Z) Q ""
2861"RTN","ORCXPND1",206,0)
2862 N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z
2863"RTN","ORCXPND1",207,0)
2864 S CCNT=$$INC(CCNT,SP)
2865"RTN","ORCXPND1",208,0)
2866 Q SP
2867"RTN","ORCXPND1",209,0)
2868INC(X,Y) ; Character Position Count
2869"RTN","ORCXPND1",210,0)
2870 ; X=Current Count
2871"RTN","ORCXPND1",211,0)
2872 ; Y=Text
2873"RTN","ORCXPND1",212,0)
2874 N INC S INC=X+$L(Y)
2875"RTN","ORCXPND1",213,0)
2876 Q INC
2877"RTN","VWREGPI")
28780^^B187053
2879"RTN","VWREGPI",1,0)
2880VWREGPI ; VEN/SMH - VW MU REG 2.0 Post-install ; 11/5/12 12:51pm
2881"RTN","VWREGPI",2,0)
2882 ;;2.0;VW MU REG;;Nov 05, 2012;Build 18
2883"RTN","VWREGPI",3,0)
2884 ; Enter VW Local Registration Template into Site Parameters
2885"RTN","VWREGPI",4,0)
2886 ; PEPs: POST
2887"RTN","VWREGPI",5,0)
2888 ;
2889"RTN","VWREGPI",6,0)
2890POST ; Post install hook
2891"RTN","VWREGPI",7,0)
2892 N DIE,DA,DR
2893"RTN","VWREGPI",8,0)
2894 S DIE="^DG(43,",DA=1,DR="70///VW LOCAL REGISTRATION TEMPLATE"
2895"RTN","VWREGPI",9,0)
2896 D ^DIE
2897"RTN","VWREGPI",10,0)
2898 QUIT
2899"RTN","VWUTIL")
29000^3^B42164756
2901"RTN","VWUTIL",1,0)
2902VWUTIL ;WVEHR/Maury Pepper/Skip Ormsby- World VistA Utilities;11:37 AM 13 Apr 2011;;;; 11/5/12 1:21pm
2903"RTN","VWUTIL",2,0)
2904 ;;1.0;WORLD VISTA;250001,250002;;Build 18
2905"RTN","VWUTIL",3,0)
2906 ;
2907"RTN","VWUTIL",4,0)
2908 ;Modified from FOIA VISTA,
2909"RTN","VWUTIL",5,0)
2910 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
2911"RTN","VWUTIL",6,0)
2912 ;General Public License See attached copy of the License.
2913"RTN","VWUTIL",7,0)
2914 ;
2915"RTN","VWUTIL",8,0)
2916 ;This program is free software; you can redistribute it and/or modify
2917"RTN","VWUTIL",9,0)
2918 ;it under the terms of the GNU General Public License as published by
2919"RTN","VWUTIL",10,0)
2920 ;the Free Software Foundation; either version 2 of the License, or
2921"RTN","VWUTIL",11,0)
2922 ;(at your option) any later version.
2923"RTN","VWUTIL",12,0)
2924 ;
2925"RTN","VWUTIL",13,0)
2926 ;This program is distributed in the hope that it will be useful,
2927"RTN","VWUTIL",14,0)
2928 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
2929"RTN","VWUTIL",15,0)
2930 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2931"RTN","VWUTIL",16,0)
2932 ;GNU General Public License for more details.
2933"RTN","VWUTIL",17,0)
2934 ;
2935"RTN","VWUTIL",18,0)
2936 ;You should have received a copy of the GNU General Public License along
2937"RTN","VWUTIL",19,0)
2938 ;with this program; if not, write to the Free Software Foundation, Inc.,
2939"RTN","VWUTIL",20,0)
2940 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
2941"RTN","VWUTIL",21,0)
2942 ;
2943"RTN","VWUTIL",22,0)
2944 Q
2945"RTN","VWUTIL",23,0)
2946 ;*WVEHR - 250001*
2947"RTN","VWUTIL",24,0)
2948Q(V,D) ; Function to return $QUERY for variable V and direction D.
2949"RTN","VWUTIL",25,0)
2950 ; Replacement for Reverse $Q Function
2951"RTN","VWUTIL",26,0)
2952 ; 1/8/08 MLP
2953"RTN","VWUTIL",27,0)
2954 ;This function can be called for $Query -- either forward or reverse.
2955"RTN","VWUTIL",28,0)
2956 ;In place of $Q(V,D), use $$Q^ZDQ($NA(V),D)
2957"RTN","VWUTIL",29,0)
2958 ;Note: the 2nd argument is optional.
2959"RTN","VWUTIL",30,0)
2960 ;
2961"RTN","VWUTIL",31,0)
2962 S D=+$G(D,1)
2963"RTN","VWUTIL",32,0)
2964 Q:D=1 $Q(@V) ;Forward $Q
2965"RTN","VWUTIL",33,0)
2966 IF D'=-1 Q ;Will cause error due to no argument.
2967"RTN","VWUTIL",34,0)
2968 N S
2969"RTN","VWUTIL",35,0)
2970TOP IF $QL(V)=0 Q "" ;done if unsubscripted
2971"RTN","VWUTIL",36,0)
2972BKU S S=$O(@V,-1) ;backup to previous node on current level
2973"RTN","VWUTIL",37,0)
2974 S V=$NA(@V,$QL(V)-1) ;remove last subscript
2975"RTN","VWUTIL",38,0)
2976 IF S="" G DAT ;go chk for data if backed up all the way
2977"RTN","VWUTIL",39,0)
2978 S V=$NA(@V@(S)) ;add the subscript found when backing up.
2979"RTN","VWUTIL",40,0)
2980 IF $D(@V)>9 S V=$NA(@V@("")) G BKU ;if downpointer, descend and repeat
2981"RTN","VWUTIL",41,0)
2982DAT IF $D(@V)#2=1 Q V ;if a data node, return with current name
2983"RTN","VWUTIL",42,0)
2984 G TOP
2985"RTN","VWUTIL",43,0)
2986 ;
2987"RTN","VWUTIL",44,0)
2988 ;*WVEHR 250002*
2989"RTN","VWUTIL",45,0)
2990DD2 ;Weston/SO Make certain Required Fields in Patient File NOT required
2991"RTN","VWUTIL",46,0)
2992 ;06/30/2008
2993"RTN","VWUTIL",47,0)
2994 ;Fields:
2995"RTN","VWUTIL",48,0)
2996 ;SOCIAL SECURITY NUMBER(#.09)
2997"RTN","VWUTIL",49,0)
2998 ;SERVICE CONNECTED?(#.301)
2999"RTN","VWUTIL",50,0)
3000 ;TYPE(#391)
3001"RTN","VWUTIL",51,0)
3002 ;VETERAN (Y/N)?(#1901)
3003"RTN","VWUTIL",52,0)
3004 ;
3005"RTN","VWUTIL",53,0)
3006 D DT^DICRW ;Make sure FM variables are set up
3007"RTN","VWUTIL",54,0)
3008 F I="SOCIAL SECURITY NUMBER","SERVICE CONNECTED?","TYPE","VETERAN (Y/N)?" D
3009"RTN","VWUTIL",55,0)
3010 .N FIELD S FIELD=+$O(^DD(2,"B",I,0)) Q:'FIELD ;Get field number
3011"RTN","VWUTIL",56,0)
3012 .N X S X=$P(^DD(2,FIELD,0),U,2) ;Get field properties
3013"RTN","VWUTIL",57,0)
3014 .S X=$TR(X,"R","") ;Remove the 'R'equired flag
3015"RTN","VWUTIL",58,0)
3016 .S $P(^DD(2,FIELD,0),U,2)=X ;Re-Set field properties
3017"RTN","VWUTIL",59,0)
3018 .K ^DD(2,"RQ",FIELD) ;Kill off the ReQuired Xref
3019"RTN","VWUTIL",60,0)
3020 .S ^DD(2,FIELD,"DT")=DT ;Set the date Last Edited
3021"RTN","VWUTIL",61,0)
3022 .;
3023"RTN","VWUTIL",62,0)
3024 .;Re-Compile any Input Templates
3025"RTN","VWUTIL",63,0)
3026 .D
3027"RTN","VWUTIL",64,0)
3028 ..N IEN S IEN=0
3029"RTN","VWUTIL",65,0)
3030 ..F S IEN=$O(^DIE("AF",2,FIELD,IEN)) Q:'IEN D
3031"RTN","VWUTIL",66,0)
3032 ...N X,Y,DMAX
3033"RTN","VWUTIL",67,0)
3034 ...I '$D(^DIE(IEN,"ROU")) Q ;Not compiled
3035"RTN","VWUTIL",68,0)
3036 ...S X=^DIE(IEN,"ROU")
3037"RTN","VWUTIL",69,0)
3038 ...I X="" Q ;No routine specified
3039"RTN","VWUTIL",70,0)
3040 ...S X=$P(X,U,2),Y=IEN,DMAX=$$ROUSIZE^DILF
3041"RTN","VWUTIL",71,0)
3042 ...D EN^DIEZ
3043"RTN","VWUTIL",72,0)
3044 ...Q
3045"RTN","VWUTIL",73,0)
3046 ..Q
3047"RTN","VWUTIL",74,0)
3048 .;
3049"RTN","VWUTIL",75,0)
3050 .;Re-Compile any Print Templates
3051"RTN","VWUTIL",76,0)
3052 .D
3053"RTN","VWUTIL",77,0)
3054 ..N IEN S IEN=0
3055"RTN","VWUTIL",78,0)
3056 ..F S IEN=$O(^DIPT("AF",2,FIELD,IEN)) Q:'IEN D
3057"RTN","VWUTIL",79,0)
3058 ...N X,Y,DMAX
3059"RTN","VWUTIL",80,0)
3060 ...I '$D(^DIPT(IEN,"ROU")) Q ;Not compiled
3061"RTN","VWUTIL",81,0)
3062 ...S X=^DIPT(IEN,"ROU")
3063"RTN","VWUTIL",82,0)
3064 ...I X="" Q ;No routine specified
3065"RTN","VWUTIL",83,0)
3066 ...S X=$P(X,U,2),Y=IEN,DMAX=$$ROUSIZE^DILF
3067"RTN","VWUTIL",84,0)
3068 ...D EN^DIPZ
3069"RTN","VWUTIL",85,0)
3070 ..Q
3071"RTN","VWUTIL",86,0)
3072 .Q
3073"RTN","VWUTIL",87,0)
3074 Q
3075"RTN","VWUTIL",88,0)
3076 ;
3077"RTN","VWUTIL",89,0)
3078PMI ;Remove PMI values from file #50.68
3079"RTN","VWUTIL",90,0)
3080 N %I
3081"RTN","VWUTIL",91,0)
3082 S %I=0 F S %I=$O(^PSNDF(50.68,%I)) Q:%I'>0 S $P(^PSNDF(50.68,%I,1),"^",5,7)="^^"
3083"RTN","VWUTIL",92,0)
3084 Q
3085"RTN","VWUTIL",93,0)
3086 ;
3087"RTN","VWUTIL",94,0)
3088POSTM ;Multi-build clean up
3089"RTN","VWUTIL",95,0)
3090 D DD2
3091"RTN","VWUTIL",96,0)
3092 D PMI
3093"RTN","VWUTIL",97,0)
3094 Q
3095"RTN","VWUTIL",98,0)
3096AMA1 ;Display the AMA Copyright for 1 second
3097"RTN","VWUTIL",99,0)
3098 N VW S VW=0,VW=+$O(^ICPT(VW))
3099"RTN","VWUTIL",100,0)
3100 I 'VW Q ;No CPT Codes
3101"RTN","VWUTIL",101,0)
3102 N X W !,"CPT copyright AMA ",$E($$FMTE^XLFDT($$FMADD^XLFDT(DT,-365),7),1,4)," American Medical Association. All rights reserved."
3103"RTN","VWUTIL",102,0)
3104 R X#1:1
3105"RTN","VWUTIL",103,0)
3106 Q
3107"RTN","VWUTIL",104,0)
3108AMA10 ;Display the AMA Copyright for 10 seconds
3109"RTN","VWUTIL",105,0)
3110 N VW S VW=0,VW=+$O(^ICPT(VW))
3111"RTN","VWUTIL",106,0)
3112 I 'VW Q ;No CPT Codes
3113"RTN","VWUTIL",107,0)
3114 N X W !,"CPT copyright AMA ",$E($$FMTE^XLFDT($$FMADD^XLFDT(DT,-365),7),1,4)," American Medical Association. All rights reserved."
3115"RTN","VWUTIL",108,0)
3116 W !," Press any key to continue."
3117"RTN","VWUTIL",109,0)
3118 R X#1:10
3119"RTN","VWUTIL",110,0)
3120 Q
3121"RTN","VWUTIL",111,0)
3122 ;
3123"RTN","VWUTIL",112,0)
3124DGRP1 ;Called from VW^DGRP1
3125"RTN","VWUTIL",113,0)
3126 N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
3127"RTN","VWUTIL",114,0)
3128 N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
3129"RTN","VWUTIL",115,0)
3130 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
3131"RTN","VWUTIL",116,0)
3132 ; loads Family (Last) Name (1), Given (First) Name (2),
3133"RTN","VWUTIL",117,0)
3134 ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
3135"RTN","VWUTIL",118,0)
3136 ; field groups 1 & 2 part 3: load aliases
3137"RTN","VWUTIL",119,0)
3138 N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
3139"RTN","VWUTIL",120,0)
3140 N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
3141"RTN","VWUTIL",121,0)
3142 ; and array of aliases found
3143"RTN","VWUTIL",122,0)
3144 S DGALIAS=0 F D Q:'DGALIAS
3145"RTN","VWUTIL",123,0)
3146 . ;
3147"RTN","VWUTIL",124,0)
3148 . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
3149"RTN","VWUTIL",125,0)
3150 . Q:'DGALIAS ; out of alias subrecords
3151"RTN","VWUTIL",126,0)
3152 . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
3153"RTN","VWUTIL",127,0)
3154 . Q:'$L(DGNODE) ; bad node
3155"RTN","VWUTIL",128,0)
3156 . ;
3157"RTN","VWUTIL",129,0)
3158 . S DGCOUNT=DGCOUNT+1 ; another valid alias
3159"RTN","VWUTIL",130,0)
3160 . I DGCOUNT=6 S DGALIAS=0 Q ; can't show > 5, need to know if 6 or >
3161"RTN","VWUTIL",131,0)
3162 . ;
3163"RTN","VWUTIL",132,0)
3164 . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
3165"RTN","VWUTIL",133,0)
3166 . ;
3167"RTN","VWUTIL",134,0)
3168 . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
3169"RTN","VWUTIL",135,0)
3170 . I $L(DGSSN) D
3171"RTN","VWUTIL",136,0)
3172 . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
3173"RTN","VWUTIL",137,0)
3174 . . ; incl leading space to separate from alias name
3175"RTN","VWUTIL",138,0)
3176 . . ; incl 10 chars to allow for P of pseudo-SSNs
3177"RTN","VWUTIL",139,0)
3178 . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
3179"RTN","VWUTIL",140,0)
3180 . ;
3181"RTN","VWUTIL",141,0)
3182 . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
3183"RTN","VWUTIL",142,0)
3184 ;
3185"RTN","VWUTIL",143,0)
3186 I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
3187"RTN","VWUTIL",144,0)
3188 I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
3189"RTN","VWUTIL",145,0)
3190 K DGCOUNT
3191"RTN","VWUTIL",146,0)
3192 ;
3193"RTN","VWUTIL",147,0)
3194 ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
3195"RTN","VWUTIL",148,0)
3196 W !?5,"Family: "
3197"RTN","VWUTIL",149,0)
3198 W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
3199"RTN","VWUTIL",150,0)
3200 ;
3201"RTN","VWUTIL",151,0)
3202 I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
3203"RTN","VWUTIL",152,0)
3204 . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
3205"RTN","VWUTIL",153,0)
3206 . ; current Facility from the Health Record No. multiple field
3207"RTN","VWUTIL",154,0)
3208 . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
3209"RTN","VWUTIL",155,0)
3210 . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
3211"RTN","VWUTIL",156,0)
3212 . W ?42," HRN: ",DGHRN
3213"RTN","VWUTIL",157,0)
3214 ;
3215"RTN","VWUTIL",158,0)
3216 D
3217"RTN","VWUTIL",159,0)
3218 . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
3219"RTN","VWUTIL",160,0)
3220 . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
3221"RTN","VWUTIL",161,0)
3222 ;
3223"RTN","VWUTIL",162,0)
3224 ; field groups 1 & 2 part 5: show remaining name components and aliases
3225"RTN","VWUTIL",163,0)
3226 N DGCOUNT F DGCOUNT=2:1:6 D
3227"RTN","VWUTIL",164,0)
3228 . W !?5,$P(DGLABEL,U,DGCOUNT),": "
3229"RTN","VWUTIL",165,0)
3230 . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
3231"RTN","VWUTIL",166,0)
3232 . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
3233"RTN","VWUTIL",167,0)
3234 . I DGCOUNT=2 D ; header for aliases
3235"RTN","VWUTIL",168,0)
3236 . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
3237"RTN","VWUTIL",169,0)
3238 . . W " Alias: "
3239"RTN","VWUTIL",170,0)
3240 . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
3241"RTN","VWUTIL",171,0)
3242 . Q
3243"RTN","VWUTIL",172,0)
3244 Q
3245"RTN","VWUTIL",173,0)
3246 ;
3247"RTN","VWUTIL",174,0)
3248REGMU ; Changes to Patient Registration for MU
3249"RTN","VWUTIL",175,0)
3250 N X S X=+$O(^DIE("B","VW LOCAL REGISTRATION TEMPLATE",0)) Q:'X
3251"RTN","VWUTIL",176,0)
3252 N DA,DIE,DR,DIC,DIQ
3253"RTN","VWUTIL",177,0)
3254 S DA=DFN,DIE="^DPT(",DR="[VW LOCAL REGISTRATION TEMPLATE]"
3255"RTN","VWUTIL",178,0)
3256 D ^DIE
3257"RTN","VWUTIL",179,0)
3258 Q
3259"UP",2,2.0256001,-1)
32602^256001
3261"UP",2,2.0256001,0)
32622.0256001
3263"UP",2,2.250043,-1)
32642^250043
3265"UP",2,2.250043,0)
32662.250043
3267"UP",200,200.0256001,-1)
3268200^256001
3269"UP",200,200.0256001,0)
3270200.0256001
3271"VER")
32728.0^22.0
3273"^DD",2,2,.351,0)
3274DATE OF DEATH^DXa^^.35;1^S %DT="EPT" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X>DGTIME X K DGTIME,DGDATE I $D(X),X<$P(^DPT(DA,0),"^",3) K X
3275"^DD",2,2,.351,1,0)
3276^.1
3277"^DD",2,2,.351,1,1,0)
3278^^TRIGGER^2^.091
3279"^DD",2,2,.351,1,1,1)
3280K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,1.1) X ^DD(2,.351,1,1,1.4)
3281"^DD",2,2,.351,1,1,1,9.2)
3282S X=DIU_"[PATIENT DIED ON ",Y(1)=X S X=DIV,Y(2)=X S X=4,Y(3)=X S X=5,X=$E(Y(2),Y(3),X) S Y=X,X=Y(1),X=X_Y_"/",Y(4)=X S X=DIV,Y(5)=X S X=6,Y(6)=X S X=7
3283"^DD",2,2,.351,1,1,1.1)
3284S X=DIV X ^DD(2,.351,1,1,49.2) S X=$E(Y(5),Y(6),X) S Y=X,X=Y(4),X=X_Y_"/",Y(7)=X S X=DIV,Y(8)=X S X=2,Y(9)=X S X=3,X=$E(Y(8),Y(9),X) S Y=X,X=Y(7),X=X_Y_"]"
3285"^DD",2,2,.351,1,1,1.4)
3286S DIH=$S($D(^DPT(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
3287"^DD",2,2,.351,1,1,2)
3288K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,2.1) X ^DD(2,.351,1,1,2.4)
3289"^DD",2,2,.351,1,1,2.1)
3290S X=DIV X ^DD(2,.351,1,1,59.2) S Y(8)=X S X=2,X=$P(Y(7),Y(8),X) S Y=X,X=Y(3),X=X_Y
3291"^DD",2,2,.351,1,1,2.4)
3292S DIH=$S($D(^DPT(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,10)=DIV,DIH=2,DIG=.091 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
3293"^DD",2,2,.351,1,1,49.2)
3294S X=DIU_"[PATIENT DIED ON ",Y(1)=X S X=DIV,Y(2)=X S X=4,Y(3)=X S X=5,X=$E(Y(2),Y(3),X) S Y=X,X=Y(1),X=X_Y_"/",Y(4)=X S X=DIV,Y(5)=X S X=6,Y(6)=X S X=7
3295"^DD",2,2,.351,1,1,59.2)
3296S X=DIU,Y(1)=X S X="[PATIENT DIED",Y(2)=X S X=1,X=$P(Y(1),Y(2),X),Y(3)=X,Y(4)=X S X=DIU,Y(5)=X S X="PATIENT DIED",Y(6)=X S X=2,X=$P(Y(5),Y(6),X),Y(7)=X S X="]"
3297"^DD",2,2,.351,1,1,"%D",0)
3298^^3^3^2930723^^
3299"^DD",2,2,.351,1,1,"%D",1,0)
3300This appends into the REMARKS field a notation regarding the DATE OF
3301"^DD",2,2,.351,1,1,"%D",2,0)
3302DEATH. If DATE OF DEATH is deleted, the notation will be stripped out
3303"^DD",2,2,.351,1,1,"%D",3,0)
3304of the REMARKS field.
3305"^DD",2,2,.351,1,1,"CREATE VALUE")
3306REMARKS_"[PATIENT DIED ON "_$E(DATE OF DEATH,4,5)_"/"_$E(DATE OF DEATH,6,7)_"/"_$E(DATE OF DEATH,2,3)_"]"
3307"^DD",2,2,.351,1,1,"DELETE VALUE")
3308$P(REMARKS,"[PATIENT DIED",1)_$P($P(REMARKS,"PATIENT DIED",2),"]",2)
3309"^DD",2,2,.351,1,1,"DT")
33102930601
3311"^DD",2,2,.351,1,1,"FIELD")
3312REMARKS
3313"^DD",2,2,.351,1,2,0)
3314^^TRIGGER^2^.352
3315"^DD",2,2,.351,1,2,1)
3316K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.35)):^(.35),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(2,.351,1,2,1.1) X ^DD(2,.351,1,2,1.4)
3317"^DD",2,2,.351,1,2,1.1)
3318S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"")
3319"^DD",2,2,.351,1,2,1.4)
3320S DIH=$S($D(^DPT(DIV(0),.35)):^(.35),1:""),DIV=X S %=$P(DIH,U,3,999),DIU=$P(DIH,U,2),^(.35)=$P(DIH,U,1,1)_U_DIV_$S(%]"":U_%,1:""),DIH=2,DIG=.352 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
3321"^DD",2,2,.351,1,2,2)
3322Q
3323"^DD",2,2,.351,1,2,"CREATE VALUE")
3324S X=$S(($D(DUZ)#2):DUZ,1:"")
3325"^DD",2,2,.351,1,2,"DELETE VALUE")
3326NO EFFECT
3327"^DD",2,2,.351,1,2,"FIELD")
3328DEATH ENTERED BY
3329"^DD",2,2,.351,1,3,0)
33302^ADGDBUL^MUMPS
3331"^DD",2,2,.351,1,3,1)
3332D DSBULL^DGDEATH
3333"^DD",2,2,.351,1,3,2)
3334D DKBULL^DGDEATH
3335"^DD",2,2,.351,1,3,"DT")
33363031008
3337"^DD",2,2,.351,1,4,0)
33382^AEXP1
3339"^DD",2,2,.351,1,4,1)
3340S ^DPT("AEXP1",$E(X,1,30),DA)=""
3341"^DD",2,2,.351,1,4,2)
3342K ^DPT("AEXP1",$E(X,1,30),DA)
3343"^DD",2,2,.351,1,5,0)
33442^AOERR^MUMPS
3345"^DD",2,2,.351,1,5,1)
3346D DEATH^DGOERNOT
3347"^DD",2,2,.351,1,5,2)
3348Q
3349"^DD",2,2,.351,1,5,"%D",0)
3350^^3^3^2910716^^^^
3351"^DD",2,2,.351,1,5,"%D",1,0)
3352 This cross-reference is used in conjunction with ORDER ENTRY/RESULTS
3353"^DD",2,2,.351,1,5,"%D",2,0)
3354REPORTING v2.09 or higher to send MAS OE/RR NOTIFICATIONS of
3355"^DD",2,2,.351,1,5,"%D",3,0)
3356DEATH to users who are on an OE/RR LIST for a patient.
3357"^DD",2,2,.351,1,5,"DT")
33582910715
3359"^DD",2,2,.351,1,6,0)
33602^APSJD^MUMPS
3361"^DD",2,2,.351,1,6,1)
3362S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I D END^PSJADT
3363"^DD",2,2,.351,1,6,2)
3364Q
3365"^DD",2,2,.351,1,6,3)
3366Cancels Inpatient Medication orders.
3367"^DD",2,2,.351,1,6,"%D",0)
3368^^3^3^2930608^^^
3369"^DD",2,2,.351,1,6,"%D",1,0)
3370This is used by the Inpatient Medications package to cancel a patient's
3371"^DD",2,2,.351,1,6,"%D",2,0)
3372IV and Unit Dose orders whenever a date of death is entered for the
3373"^DD",2,2,.351,1,6,"%D",3,0)
3374patient.
3375"^DD",2,2,.351,1,6,"DT")
33762930608
3377"^DD",2,2,.351,1,7,0)
33782^ARCDTH^MUMPS
3379"^DD",2,2,.351,1,7,1)
3380S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D SET^RCAMDTH
3381"^DD",2,2,.351,1,7,2)
3382S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D ERR^RCAMDTH
3383"^DD",2,2,.351,1,7,3)
3384ACCOUNTS RECEIVABLE DEATH NOTIFICATION
3385"^DD",2,2,.351,1,7,"%D",0)
3386^^3^3^2930722^^^^
3387"^DD",2,2,.351,1,7,"%D",1,0)
3388This cross-reference is used to notify the Accounts Receivable package (v4 or
3389"^DD",2,2,.351,1,7,"%D",2,0)
3390higher) of a patient's death so that the patient's account may be reviewed for
3391"^DD",2,2,.351,1,7,"%D",3,0)
3392appropriate action.
3393"^DD",2,2,.351,1,7,"DT")
33942930609
3395"^DD",2,2,.351,1,8,0)
33962^ADEP^MUMPS
3397"^DD",2,2,.351,1,8,1)
3398D SET^DGDEPINA
3399"^DD",2,2,.351,1,8,2)
3400D KILL^DGDEPINA
3401"^DD",2,2,.351,1,8,"%D",0)
3402^^1^1^2941114^
3403"^DD",2,2,.351,1,8,"%D",1,0)
3404This is used to updated the effective dates in file 408.12.
3405"^DD",2,2,.351,1,8,"DT")
34062941114
3407"^DD",2,2,.351,1,9,0)
34082^AENR351^MUMPS
3409"^DD",2,2,.351,1,9,1)
3410D AUTOUPD^DGENA2(DA)
3411"^DD",2,2,.351,1,9,2)
3412D AUTOUPD^DGENA2(DA)
3413"^DD",2,2,.351,1,9,3)
3414DO NOT DELETE
3415"^DD",2,2,.351,1,9,"%D",0)
3416^^1^1^2970630^^^^
3417"^DD",2,2,.351,1,9,"%D",1,0)
3418Used to update the patient's enrollment.
3419"^DD",2,2,.351,1,9,"DT")
34202970630
3421"^DD",2,2,.351,1,10,0)
34222^DG714^MUMPS
3423"^DD",2,2,.351,1,10,1)
3424D START^DGMTDELS(DA)
3425"^DD",2,2,.351,1,10,2)
3426Q
3427"^DD",2,2,.351,1,10,3)
3428Deletes last REQUIRED means test
3429"^DD",2,2,.351,1,10,"DT")
34303060814
3431"^DD",2,2,.351,1,52,0)
34322^APSOD^MUMPS
3433"^DD",2,2,.351,1,52,1)
3434I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA)
3435"^DD",2,2,.351,1,52,2)
3436I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA)
3437"^DD",2,2,.351,1,52,3)
3438Discontinues Outpatient Medications.
3439"^DD",2,2,.351,1,52,"%D",0)
3440^^3^3^2961122^^^^
3441"^DD",2,2,.351,1,52,"%D",1,0)
3442This xref is used to discontinue all active outpatient medications whenever
3443"^DD",2,2,.351,1,52,"%D",2,0)
3444a date of death is entered for the patient. This xref is used with v7 of
3445"^DD",2,2,.351,1,52,"%D",3,0)
3446Outpatient Pharmacy (DBIA #1624).
3447"^DD",2,2,.351,1,52,"%D",4,0)
3448Kill logic updated with DG*5.3*455. Mail message sent to pharmacy when date
3449"^DD",2,2,.351,1,52,"%D",5,0)
3450of death is deleted to holders of PSORPH key.
3451"^DD",2,2,.351,1,52,"DT")
34523020926
3453"^DD",2,2,.351,1,250,0)
34542^AVWDOD^MUMPS
3455"^DD",2,2,.351,1,250,1)
3456Q
3457"^DD",2,2,.351,1,250,2)
3458D WP^DIE(2,DA_",",250043.1,"","@")
3459"^DD",2,2,.351,1,250,3)
3460Deletes Preliminary Cause of Death
3461"^DD",2,2,.351,1,250,"%D",0)
3462^^1^1^3121107^
3463"^DD",2,2,.351,1,250,"%D",1,0)
3464Deletes preliminary cause of death if the date of death is deleted.
3465"^DD",2,2,.351,1,250,"DT")
34663121107
3467"^DD",2,2,.351,1,301,0)
34682^IVM351^MUMPS
3469"^DD",2,2,.351,1,301,1)
3470S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
3471"^DD",2,2,.351,1,301,2)
3472S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
3473"^DD",2,2,.351,1,301,"%D",0)
3474^^5^5^2930605^
3475"^DD",2,2,.351,1,301,"%D",1,0)
3476This cross-reference will check the IVM PATIENT file to see if a change
3477"^DD",2,2,.351,1,301,"%D",2,0)
3478to this field will require transmission to the IVM Center. If it does,
3479"^DD",2,2,.351,1,301,"%D",3,0)
3480the IVM PATIENT file entry's TRANSMISSION STATUS will be set to 0 and
3481"^DD",2,2,.351,1,301,"%D",4,0)
3482the nightly background job will transmit the updated information.
3483"^DD",2,2,.351,1,301,"DT")
34842930605
3485"^DD",2,2,.351,1,991,0)
34862^AVAFC351^MUMPS
3487"^DD",2,2,.351,1,991,1)
3488I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA)
3489"^DD",2,2,.351,1,991,2)
3490I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA)
3491"^DD",2,2,.351,1,991,"%D",0)
3492^^15^15^2990204^^
3493"^DD",2,2,.351,1,991,"%D",1,0)
3494This cross reference is used to remember that changes were made to the
3495"^DD",2,2,.351,1,991,"%D",2,0)
3496PATIENT file (#2) outside of the Registration process. Execution of this
3497"^DD",2,2,.351,1,991,"%D",3,0)
3498cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71)
3499"^DD",2,2,.351,1,991,"%D",4,0)
3500and mark it as requiring transmission of an HL7 ADT-A08 message.
3501"^DD",2,2,.351,1,991,"%D",5,0)
3502
3503"^DD",2,2,.351,1,991,"%D",6,0)
3504The local variable VAFCFLG will be set to 1 if the cross reference is
3505"^DD",2,2,.351,1,991,"%D",7,0)
3506not executed because the change is being made from within the Registration
3507"^DD",2,2,.351,1,991,"%D",8,0)
3508process.
3509"^DD",2,2,.351,1,991,"%D",9,0)
3510
3511"^DD",2,2,.351,1,991,"%D",10,0)
3512Execution of this cross reference can be prevented by setting the local
3513"^DD",2,2,.351,1,991,"%D",11,0)
3514variable VAFCA08 equal to 1.
3515"^DD",2,2,.351,1,991,"%D",12,0)
3516
3517"^DD",2,2,.351,1,991,"%D",13,0)
3518The local variable VAFCF is used to identify the field edited.
3519"^DD",2,2,.351,1,991,"%D",14,0)
3520This data is stored in the FIELD(S) EDITED (#2.1) field in the
3521"^DD",2,2,.351,1,991,"%D",15,0)
3522ADT/HL7 PIVOT file (#391.71).
3523"^DD",2,2,.351,1,991,"DT")
35242990204
3525"^DD",2,2,.351,1,992,0)
35262^ADGRU351^MUMPS
3527"^DD",2,2,.351,1,992,1)
3528D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
3529"^DD",2,2,.351,1,992,2)
3530D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
3531"^DD",2,2,.351,1,992,"%D",0)
3532^^9^9^2990920^
3533"^DD",2,2,.351,1,992,"%D",1,0)
3534This cross reference is used to remember that changes were made to a
3535"^DD",2,2,.351,1,992,"%D",2,0)
3536monitored data field in the PATIENT File (#2) required for a vendor
3537"^DD",2,2,.351,1,992,"%D",3,0)
3538RAI/MDS COTS system. Execution of this cross reference will create
3539"^DD",2,2,.351,1,992,"%D",4,0)
3540an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring
3541"^DD",2,2,.351,1,992,"%D",5,0)
3542transmission of an HL7 demographic A08 update message to the COTS
3543"^DD",2,2,.351,1,992,"%D",6,0)
3544interface.
3545"^DD",2,2,.351,1,992,"%D",7,0)
3546
3547"^DD",2,2,.351,1,992,"%D",8,0)
3548The local variable DGRUGA08 will be set to 1 if the cross reference is
3549"^DD",2,2,.351,1,992,"%D",9,0)
3550not to be executed as part of a re-indexing.
3551"^DD",2,2,.351,1,992,"DT")
35522990920
3553"^DD",2,2,.351,3)
3554Enter the date this patient died. Date must not be before date of birth.
3555"^DD",2,2,.351,5,1,0)
3556405^.01^3
3557"^DD",2,2,.351,5,2,0)
3558405^.18^2
3559"^DD",2,2,.351,21,0)
3560^^1^1^2861022^
3561"^DD",2,2,.351,21,1,0)
3562Enter the date of this patient's expiration.
3563"^DD",2,2,.351,"AUDIT")
3564y
3565"^DD",2,2,.351,"DT")
35663121107
3567"^DD",2,2,250043.1,0)
3568PRELIMINARY CAUSE OF DEATH^2.250043^^250043;0
3569"^DD",2,2,256000,0)
3570LANGUAGE PREFERENCE^P.85'^DI(.85,^256000;1^Q
3571"^DD",2,2,256000,21,0)
3572^^1^1^3110524^
3573"^DD",2,2,256000,21,1,0)
3574This field is to define the language preference of the patient.
3575"^DD",2,2,256000,"DT")
35763121105
3577"^DD",2,2,256001,0)
3578LANGUAGE SKILLS^2.0256001P^^256001;0
3579"^DD",2,2,256001,21,0)
3580^^3^3^3110524^
3581"^DD",2,2,256001,21,1,0)
3582The languages listed here are associated with a series of qualifiers for
3583"^DD",2,2,256001,21,2,0)
3584UNDERSTANDING, SPEAKING, READING, and/or WRITTEN skill levels of each langua
3585"^DD",2,2,256001,21,3,0)
3586language specified for this patient.
3587"^DD",2,2.0256001,0)
3588LANGUAGE SKILLS SUB-FIELD^^4^5
3589"^DD",2,2.0256001,0,"DT")
35903121105
3591"^DD",2,2.0256001,0,"IX","B",2.0256001,.01)
3592
3593"^DD",2,2.0256001,0,"NM","LANGUAGE SKILLS")
3594
3595"^DD",2,2.0256001,0,"UP")
35962
3597"^DD",2,2.0256001,.01,0)
3598LANGUAGE SKILLS^MP.85'^DI(.85,^0;1^Q
3599"^DD",2,2.0256001,.01,1,0)
3600^.1
3601"^DD",2,2.0256001,.01,1,1,0)
36022.0256001^B
3603"^DD",2,2.0256001,.01,1,1,1)
3604S ^DPT(DA(1),256001,"B",$E(X,1,30),DA)=""
3605"^DD",2,2.0256001,.01,1,1,2)
3606K ^DPT(DA(1),256001,"B",$E(X,1,30),DA)
3607"^DD",2,2.0256001,.01,21,0)
3608^^3^3^3110524^
3609"^DD",2,2.0256001,.01,21,1,0)
3610This multiple is to help catalog the language skills of the patient.
3611"^DD",2,2.0256001,.01,21,2,0)
3612It may be the case that a patient may be called upon to communicate
3613"^DD",2,2.0256001,.01,21,3,0)
3614with other patients that the staff is unable to communicate with otherwise.
3615"^DD",2,2.0256001,.01,"DT")
36163121105
3617"^DD",2,2.0256001,1,0)
3618UNDERSTANDING SKILL LEVEL^S^P:poor to none;I:intermediate;N:native skills;M:mastery of the Language;^0;2^Q
3619"^DD",2,2.0256001,1,"DT")
36203110524
3621"^DD",2,2.0256001,2,0)
3622SPEAKING SKILL LEVEL^S^P:poor to none;I:intermediate;N:native skills;M:mastery of the Language;^0;3^Q
3623"^DD",2,2.0256001,2,3)
3624
3625"^DD",2,2.0256001,2,"DT")
36263110524
3627"^DD",2,2.0256001,3,0)
3628READING SKILL LEVEL^S^P:poor to none;I:intermediate;N:native skills;M:mastery of the Language;^0;4^Q
3629"^DD",2,2.0256001,3,3)
3630
3631"^DD",2,2.0256001,3,"DT")
36323110524
3633"^DD",2,2.0256001,4,0)
3634WRITTEN SKILL LEVEL^S^P:poor to none;I:intermediate;N:native skills;M:mastery of the Language;^0;5^Q
3635"^DD",2,2.0256001,4,3)
3636
3637"^DD",2,2.0256001,4,"DT")
36383110524
3639"^DD",2,2.250043,0)
3640PRELIMINARY CAUSE OF DEATH SUB-FIELD^^.01^1
3641"^DD",2,2.250043,0,"DT")
36423110617
3643"^DD",2,2.250043,0,"NM","PRELIMINARY CAUSE OF DEATH")
3644
3645"^DD",2,2.250043,0,"UP")
36462
3647"^DD",2,2.250043,.01,0)
3648PRELIMINARY CAUSE OF DEATH^Wx^^0;1^Q
3649"^DD",2,2.250043,.01,"DT")
36503110617
3651"^DD",200,200,256000,0)
3652PREFERRED LANGUAGE^P.85'^DI(.85,^256000;1^Q
3653"^DD",200,200,256000,21,0)
3654^.001^5^5^3110524^^
3655"^DD",200,200,256000,21,1,0)
3656This is a means of providing an alternative to the system default language.
3657"^DD",200,200,256000,21,2,0)
3658If it is not defined, the value used will be the system default (found on
3659"^DD",200,200,256000,21,3,0)
3660the KERNEL SYSTEM PARAMETER File). This field, when expressed for this user
3661"^DD",200,200,256000,21,4,0)
3662user will default to the KERNEL SYSTEM PARAMETER value, if it is missing or
3663"^DD",200,200,256000,21,5,0)
3664NULL.
3665"^DD",200,200,256000,"DT")
36663110524
3667"^DD",200,200,256001,0)
3668LANGUAGE SKILLS^200.0256001P^^256001;0
3669"^DD",200,200,256001,21,0)
3670^^2^2^3110524^
3671"^DD",200,200,256001,21,1,0)
3672This is the pointer to the LANGUAGE File for the list of languages
3673"^DD",200,200,256001,21,2,0)
3674a person may be able to understand, read, speak, and/or write.
3675"^DD",200,200,256001,23,0)
3676^^1^1^3110524^
3677"^DD",200,200,256001,23,1,0)
3678This field will be followed by 4 separate fields of sets of codes.
3679"^DD",200,200.0256001,0)
3680LANGUAGE SKILLS SUB-FIELD^^4^5
3681"^DD",200,200.0256001,0,"DT")
36823110524
3683"^DD",200,200.0256001,0,"IX","B",200.0256001,.01)
3684
3685"^DD",200,200.0256001,0,"NM","LANGUAGE SKILLS")
3686
3687"^DD",200,200.0256001,0,"UP")
3688200
3689"^DD",200,200.0256001,.01,0)
3690LANGUAGE SKILLS^MP.85'^DI(.85,^0;1^Q
3691"^DD",200,200.0256001,.01,1,0)
3692^.1
3693"^DD",200,200.0256001,.01,1,1,0)
3694200.0256001^B
3695"^DD",200,200.0256001,.01,1,1,1)
3696S ^VA(200,DA(1),256001,"B",$E(X,1,30),DA)=""
3697"^DD",200,200.0256001,.01,1,1,2)
3698K ^VA(200,DA(1),256001,"B",$E(X,1,30),DA)
3699"^DD",200,200.0256001,.01,21,0)
3700^^4^4^3110524^
3701"^DD",200,200.0256001,.01,21,1,0)
3702This is the location where the linguistic skills of the staff can be
3703"^DD",200,200.0256001,.01,21,2,0)
3704stored for comparision. The strength of the language skills of the
3705"^DD",200,200.0256001,.01,21,3,0)
3706individual are split up into understanding, speak, and/or written
3707"^DD",200,200.0256001,.01,21,4,0)
3708proficiencies for a variety of languages.
3709"^DD",200,200.0256001,.01,"DT")
37103110524
3711"^DD",200,200.0256001,1,0)
3712UNDERSTAND^S^P:poor to none;I:intermediate;N:native;M:mastery of the language;^0;2^Q
3713"^DD",200,200.0256001,1,"DT")
37143110524
3715"^DD",200,200.0256001,2,0)
3716SPEAKING SKILL LEVEL^S^P:poor to none;I:intermediate;N:native;M:mastery of the language;^0;3^Q
3717"^DD",200,200.0256001,2,3)
3718
3719"^DD",200,200.0256001,2,"DT")
37203110524
3721"^DD",200,200.0256001,3,0)
3722READING SKILL LEVEL^S^P:poor to none;I:intermediate;N:native;M:mastery of the language;^0;4^Q
3723"^DD",200,200.0256001,3,3)
3724
3725"^DD",200,200.0256001,3,"DT")
37263110524
3727"^DD",200,200.0256001,4,0)
3728WRITTEN SKILL LEVEL^S^P:poor to none;I:intermediate;N:native;M:mastery of the language;^0;5^Q
3729"^DD",200,200.0256001,4,3)
3730
3731"^DD",200,200.0256001,4,"DT")
37323110524
3733**END**
3734**END**
Note: See TracBrowser for help on using the repository browser.