source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAREG2.m@ 1384

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1DVBAREG2 ;ALB/JLU;second half of the 7131 input;3/2/99
2 ;;2.7;AMIE;**3,5,14,17,20,25**;Apr 10, 1995
3 ;
4CONT ;asks selection from list
5 S DIR(0)="NAO^1:"_X1_":0"
6 S DIR("A")="Select 1-"_X1_" or '^' to Exit or Return to continue "
7 D ^DIR
8 K DIR
9 I $D(DTOUT)!$D(DUOUT) S DVBASTOP=1 Q
10 I Y]"" S DVBANS=Y
11 E K DVBANS
12 Q
13 ;
14SINGLE ;when select single entry point
15 S XTYPE=""
16 S X1=$O(^TMP("DVBA",$J,0))
17 I X1="" S DVBASTOP=1 Q
18 S XTYPE=$O(^TMP("DVBA",$J,X1,XTYPE))
19 I XTYPE="" S DVBASTOP=1 Q
20 S DIR("A",1)=""
21 S DIR("A",2)=$P(^TMP("DVBA",$J,X1,XTYPE),U)
22 S DIR("A")="Is this the correct information? "
23 S DIR("B")="NO"
24 S DIR(0)="YA"
25 D ^DIR
26 K DIR
27 I $D(DUOUT)!($D(DTOUT)) S DVBASTOP=1 Q
28 I Y S DVBANS=X1,DVBTYPE=XTYPE,DVBDOC=$S(DVBTYPE["ADMISSION":"A",1:"L")
29 E K DVBANS
30 Q
31 ;
32DTRNG(DFN) ;gets date range from user
33 S DIR("A",1)="Display Admission or Activity information"
34 S DIR("A")="for "_$P(DFN,U,2)_" by"
35 S DIR("?")="Date Range will allow the user to select the specific dates."
36 S DIR("?",1)="All Dates will show the user all possible information."
37 S DIR(0)="SM^D:Date Range;A:All Dates"
38 D ^DIR
39 K DIR
40 I $D(DTOUT)!($D(DUOUT)) S DVBAQUIT=1 Q
41 I X="" S DVBASTOP=1 Q
42 S DVBBDT=0,DVBEDT=0
43 S VAR(1,0)="0,0,0,1,0^"
44 D WR^DVBAUTL4("VAR")
45 K VAR
46 I Y="D" DO
47 .D DATE^DVBCUTL4(.DVBBDT,.DVBEDT)
48 .S Y="D"
49 .I DVBBDT>0,'+$P(DVBBDT,".",2) S DVBBDT=DVBBDT-.0000001
50 .I DVBEDT>0,'+$P(DVBEDT,".",2) S DVBEDT=DVBEDT+.9999999
51 .I DVBBDT=0,DVBEDT=0 S DVBAQUIT=1
52 .I DVBBDT=-1,DVBEDT=-1 S DVBASTOP=1
53 .Q
54 Q
55 ;
56CLEAN ;cleans up variables
57 K DA,ADM,ADMDT,ADMNUM,DFN,DIC,A,DR,PNAM,SSN,TRN,Z,DINUM,DTAR,C,J,K,L,C,D,DIE,ONFILE,%,OLDDA,%Y,DIK,ZI,X,Y,AROWOUT,DVBAEDT,DVBAENTR,DVBASTOP,DVBREQDT,DVBANS,DVBTYPE
58 K ^TMP("DVBA",$J),^UTILITY("DIQ1",$J)
59 Q
60 ;
61PAGE ;pages/dispays end of page/screen
62 S VAR(1,0)="0,0,0,0,1^"
63 S VAR(2,0)="0,0,"_(IOM-$L(HD)\2)_":0,0,0^"_HD
64 S VAR(3,0)="0,0,"_(IOM-$L(HNAME)\2)_":0,1:2,0^"_HNAME
65 D WR^DVBAUTL4("VAR")
66 K VAR
67 Q
68 ;
69SELECT ;checks doc type, request status and calls deletion, if necessary
70 N ZI
71 K DVBAENTR
72 S DVBREQDT=9999999.9999999-DVBANS
73 I DVBTYPE["ADMISSION" DO
74 .S ADMNUM=$P(^TMP("DVBA",$J,DVBANS,DVBTYPE),U,2)
75 D COMPSEL
76 Q
77 ;
78COMPSEL ;** Compare selected 7131 to existing
79 N DVBATMPT
80 I DVBTYPE["ADMISSION" S DVBATMPT="A"
81 I DVBTYPE'["ADMISSION" S DVBATMPT="L"
82 F ZI=0:0 S ZI=$O(^DVB(396,"B",+DFN,ZI)) Q:ZI="" I $D(^DVB(396,"G",+$E(DVBREQDT,1,14),ZI))&(DVBATMPT=$P(^DVB(396,ZI,2),"^",10)) S DVBAENTR=ZI Q
83 I $D(DVBAENTR) DO
84 .D ALERT(ZI)
85 .D ASK
86 .Q:$D(DVBAQUIT)!($D(DVBASTOP))
87 .I '$$LOCK^DVBAUTL6(DVBAENTR) S DVBASTOP=1 Q
88 .S STAT=$P(^DVB(396,DVBAENTR,1),U,12)
89 .S ONFILE=0
90 .I STAT'="" D ALERT1
91 .Q:$D(DVBAQUIT)!($D(DVBASTOP))
92 .I ONFILE=1 S DVBASTOP=1 Q
93 .Q
94 I '$D(DVBAENTR) DO
95 .D DICW^DVBAUTIL
96 .D ASK1
97 .I $D(DVBASTOP)!($D(DVBAQUIT)) Q
98 .D STUFF
99 .Q
100 I '$D(DVBAENTR) S DVBASTOP=1
101 Q
102 ;
103ALERT(Y) ;displays when a potential hit in the 7131 file.
104 S VAR(1,0)="1,0,0,2,0^There is a 7131 already on file for "_$$FMTE^XLFDT(DVBREQDT,"5DZ")
105 S STAT=$P(^DVB(396,+Y,1),U,12)
106 S VAR(2,0)="0,0,0,1:1,0^Status is "_$S(STAT'="":"FINALIZED",1:"OPEN")
107 D WR^DVBAUTL4("VAR")
108 K VAR
109 Q
110ALERT1 ;
111 I STAT'="" DO
112 .S VAR(1,0)="0,0,0,1,0^"
113 .D WR^DVBAUTL4("VAR")
114 .K VAR
115 .S DIR("A")="Do you want to delete the existing 7131 for this date: "
116 .S DIR(0)="YAO"
117 .S DIR("B")="NO"
118 .S DIR("?")="Answer YES or No. You may not have two 7131s for the same admission date."
119 .D ^DIR
120 .K DIR
121 .I $D(DTOUT)!($D(DUOUT))!(Y="") S DVBAQUIT=1 Q
122 .I 'Y S DVBASTOP=1 Q
123 .I Y DO
124 ..S DA=+DVBAENTR
125 ..D REOPEN^DVBAUTL2
126 ..K DA
127 ..Q
128 .Q
129 Q
130 ;
131ASK1 ;ask user if wish to add new 7131
132 S DVBAASIH=$P(DVBREQDT,".",2) ;*ASIH admit? (P4,v2.7)
133 D:$L(DVBAASIH)>6 ASIHALRT^DVBAUTL8 ;**Warn ASIH admit
134 S VAR(1,0)="1,0,0,1,0^"
135 D WR^DVBAUTL4("VAR")
136 K VAR
137 S DIR("A",1)="Do you want to add a NEW 7131"
138 S DIR("A")="for "_$P(PNAM,",",2,99)_" "_$P(PNAM,",",1,1)_" :"
139 S DIR(0)="YAO"
140 S DIR("B")="NO"
141 S DIR("?")="'YES' to enter a new 7131. 'NO' to search for an existing one."
142 D ^DIR
143 K DIR,DVBAASIH
144 I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
145 S:Y=1 DVBREQDT=+$E(DVBREQDT,1,14)
146 I Y=0 S DVBASTOP=1 Q
147 Q
148 ;
149ASK ;ask the user if wish to edit existing 7131
150 S VAR(1,0)="1,0,0,1,0^"
151 D WR^DVBAUTL4("VAR")
152 K VAR
153 S DIR("A")="Are you sure you want to edit this 7131 request: "
154 S DIR("B")="NO"
155 S DIR("?")="'YES' to edit the 7131 request."
156 S DIR(0)="YAO"
157 D ^DIR
158 K DIR
159 I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
160 I Y=0 S DVBASTOP=1 Q
161 I Y=1 S DVBAEDT=1
162 Q
163 ;
164STUFF ;enters 7131 into 7131 form file
165 K DA,DIC("S"),DD,DO
166 S DLAYGO=396,DIC(0)="QLM",DIC="^DVB(396,",X=+DFN
167 D FILE^DICN
168 I 'Y DO S DVBASTOP=1 Q
169 .S VAR(1,0)="1,0,0,2,0^Unable to add this new record!"
170 .D WR^DVBAUTL4("VAR")
171 .K VAR
172 .Q
173 I '$$LOCK^DVBAUTL6(Y) S DVBASTOP=1 Q
174 S (DA,DVBAENTR)=+Y
175 S DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_$S($D(ADMNUM):"A",1:"L")
176 S DIE=DIC
177 D ^DIE
178 K DA,DLAYGO,DIC,DIE
179 Q
180 ;
Note: See TracBrowser for help on using the repository browser.