source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAUTL7.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1DVBAUTL7 ;ALB/GTS;UTILITY ROUTINE;12/6/94
2 ;;2.7;AMIE;**17**;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - New routine (Enhc 16)
6 ;
7SEL7131() ;** Select a 7131 request
8 K Y
9 F DO Q:$D(Y)
10 .S DIC="^DVB(396,",DIC(0)="AEMQ"
11 .S DIC("W")="D REQDT^DVBAUTL7"
12 .D ^DIC
13 .D:+Y>0 CHECK
14 K DIC,X
15 Q +Y
16 ;
17CHECK ;** Check 7131 for a pending report
18 K DVBAOPEN
19 N DVBAX
20 F DVBAX=9,11,13,15,17,19,21,23,7,28,26 DO
21 .I '$D(DVBAOPEN) DO
22 ..I DVBAX'=7 DO
23 ...S:$P(^DVB(396,+Y,0),U,DVBAX)="P" DVBAOPEN=""
24 ..I DVBAX=7 DO
25 ...S:$P(^DVB(396,+Y,1),U,DVBAX)="P" DVBAOPEN=""
26 I '$D(DVBAOPEN) K Y
27 I '$D(DVBAOPEN) DO
28 .S VAR(1,0)="1,0,0,2:2,0^You must select a 7131 with Pending reports!"
29 .D WR^DVBAUTL4("VAR")
30 .K VAR,PAR1,PAR2
31 K DVBAOPEN
32 Q
33 ;
34INITRPT(DVBAIEN) ;** Set nodes for division updates on 7131
35 ;** Variable Descriptions
36 ; DVBARPT(RPT #)=Report name^Selected - Y/N^Status - P/C^Division #
37 ; DVBA0 and DVBA6 are the 7131 rec's 0 and 6 node respectively
38 ;
39 ;** Note: DVBARPT local array returned to calling rtn
40 ;
41 N DVBA0,DVBA6,DVBAX,SUBSCPT,RPTNME,RPTSTAT,RPTSEL,SELPCE,DVBADIV,DIVNUM
42 S DVBA0=^DVB(396,DVBAIEN,0)
43 S:$D(^DVB(396,DVBAIEN,6)) DVBA6=^DVB(396,DVBAIEN,6)
44 S:'$D(^DVB(396,DVBAIEN,6)) DVBA6=""
45 S SUBSCPT=0
46 F DVBAX=9,11,13,15,17,19,21,23,7,28,26 DO ;**Subscpt's = Status Pce's
47 .S SUBSCPT=SUBSCPT+1
48 .S RPTNME=$T(@DVBAX)
49 .S RPTNME=$P(RPTNME,";;",2)
50 .I DVBAX'=7 DO ;**Set up Rpt Selection Pce #'s
51 ..I DVBAX<17 DO
52 ...S:DVBAX=9 SELPCE=5
53 ...S:DVBAX=11 SELPCE=6
54 ...S:DVBAX=13 SELPCE=7
55 ...S:DVBAX=15 SELPCE=8
56 ..S:(DVBAX>15&(DVBAX'=26)) SELPCE=DVBAX-1
57 ..S RPTSTAT=$P(^DVB(396,DVBAIEN,0),U,DVBAX)
58 .S:DVBAX=7 RPTSTAT=$P(^DVB(396,DVBAIEN,1),U,DVBAX),SELPCE=24
59 .S:DVBAX'=26 RPTSEL=$P(^DVB(396,DVBAIEN,0),U,SELPCE)
60 .I DVBAX=26 DO
61 ..S SELPCE=25
62 ..S:$P(^DVB(396,DVBAIEN,0),U,SELPCE)'="" RPTSEL="YES"
63 ..S:$P(^DVB(396,DVBAIEN,0),U,SELPCE)="" RPTSEL="NO"
64 .S DIVNUM=$P(DVBA6,U,DVBAX)
65 .S:+DIVNUM>0 DVBADIV=$P(^DG(40.8,DIVNUM,0),U,1)
66 .S:+DIVNUM'>0 DVBADIV=""
67 .S DVBARPT(SUBSCPT)=RPTNME_"^"_RPTSEL_"^"_RPTSTAT_"^"_DVBADIV_"^"_DIVNUM_"^"_DIVNUM
68 Q
69 ;
70SETDR ;** Set DR string for 7131 division/tran date field updates
71 S:$D(DR) DR=DR_";"_FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
72 S:'$D(DR) DR=FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
73 Q
74 ;
75CLEARDR ;** Set DR string to clear 7131 division/tran date fields (7131 edit)
76 S:$D(DR) DR=DR_";"_FLDDIV_"///@;"_FLDDTE_"///@"
77 S:'$D(DR) DR=FLDDIV_"///@;"_FLDDTE_"///@"
78 Q
79 ;
80REQDT ;** Output 7131 date for DIC("W")
81 N DVBADTE,DVBATIME,DVBADTWK,DVBAX
82 S DVBADTWK=$P(^DVB(396,+Y,0),U,4)
83 S DVBATIME=$P(DVBADTWK,".",2)
84 S DVBADTWK=$P(DVBADTWK,".",1)
85 S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
86 I +DVBATIME>0 DO
87 .F DVBAX=$L(DVBATIME):1:3 S DVBATIME=DVBATIME_"0"
88 .S DVBATIME=$E(DVBATIME,1,2)_":"_$E(DVBATIME,3,4)
89 .S DVBADTE=DVBADTE_" @ "_DVBATIME
90 W ?35,$S($P(^(2),U,10)="L":"Activity Date: ",$P(^(2),U,10)="A":"Admission Date: ",1:""),DVBADTE
91 Q
92 ;
93FILE ;** Update 7131 record - Called from DVBADXFR
94 N DVBAX,DVBADTWK
95 S DVBADTWK=DVBATDT
96 S DVBADTWK=$P(DVBATDT,"@",2)
97 S REQDTE=$P(DVBATDT,"@",1)_"@"_$P(DVBADTWK,":",1)_":"_$P(DVBADTWK,":",2)
98 F DVBAX=1:1:11 DO
99 .I $P(DVBARPT(DVBAX),U,5)'=$P(DVBARPT(DVBAX),U,6) DO
100 ..I DVBAX=1 DO
101 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
102 ...S FLDDIV=4.6,FLDDTE=4.7
103 ...D SETDR
104 ..I DVBAX=2 DO
105 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
106 ...S FLDDIV=5.6,FLDDTE=5.7
107 ...D SETDR
108 ..I DVBAX=3 DO
109 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
110 ...S FLDDIV=6.6,FLDDTE=6.7
111 ...D SETDR
112 ..I DVBAX=4 DO
113 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
114 ...S FLDDIV=7.6,FLDDTE=7.7
115 ...D SETDR
116 ..I DVBAX=5 DO
117 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
118 ...S FLDDIV=9.6,FLDDTE=9.7
119 ...D SETDR
120 ..I DVBAX=6 DO
121 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
122 ...S FLDDIV=11.6,FLDDTE=11.7
123 ...D SETDR
124 ..I DVBAX=7 DO
125 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
126 ...S FLDDIV=13.6,FLDDTE=13.7
127 ...D SETDR
128 ..I DVBAX=8 DO
129 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
130 ...S FLDDIV=15.6,FLDDTE=15.7
131 ...D SETDR
132 ..I DVBAX=9 DO
133 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
134 ...S FLDDIV=17.6,FLDDTE=17.7
135 ...D SETDR
136 ..I DVBAX=10 DO
137 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
138 ...S FLDDIV=20.6,FLDDTE=20.7
139 ...D SETDR
140 ..I DVBAX=11 DO
141 ...S REQDIV=$P(DVBARPT(DVBAX),U,5)
142 ...S FLDDIV=18.6,FLDDTE=18.7
143 ...D SETDR
144 I $D(DR) DO
145 .S DIE="^DVB(396,"
146 .S DA=REQDA
147 .D ^DIE
148 .K DIE,DA,DR
149 Q
150 ;
151RPTNMS ;
1529 ;;Notice of Discharge
15311 ;;Hospital Summary
15413 ;;Certificate (21-day)
15515 ;;Other/Exam (Review Remarks)
15617 ;;Special Report
15719 ;;Competency Report
15821 ;;VA Form 21-2680
15923 ;;Asset Information
1607 ;;Admission Report
16128 ;;Beginning Date Care
16226 ;;OPT Treatment Report (Date Range)
163 Q
Note: See TracBrowser for help on using the repository browser.