source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBARQP.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 6.1 KB
Line 
1DVBARQP ;ALB/JLU-7131 request processing routine ;1/28/93
2 ;;2.7;AMIE;**32**;Apr 10, 1995
3BEG ;
4 D INITIAL
5 D INITRPT^DVBAUTL3
6 F DO I DVBANY>0!($D(DTOUT)) Q
7 .S DVBAOUT=0
8 .F DO I $D(DTOUT)!($D(DUOUT))!(DVBAOUT) Q
9 ..D DRAW
10 ..D READ I $D(DTOUT)!($D(DUOUT))!(DVBAOUT) Q
11 ..D ADJ
12 ..Q
13 .D FILE
14 .Q
15 D EXIT
16 Q
17 ;
18EXIT K A,ADMNUM,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBAHD22,DVBALN,DVBAOLD,DVBAOUT,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO,DVBANY
19 Q
20 ;
21INITIAL ;This subroutine will initialize most of the variable needed for this
22 ;option.
23 S $P(DVBALN,"-",80)=""
24 S DVBATITL="7131 Report Requesting"
25 S X="NOW",%DT="ST"
26 D ^%DT
27 X ^DD("DD")
28 S DVBATDT=Y
29 I $D(ADMNUM) D ADM
30 I DVBDOC="L" D ACT
31 D SSNOUT^DVBCUTIL
32 S SSN=DVBCSSNO
33 S DVBANY=0
34 Q
35 ;
36ADM ;sets up admission date variable and discharge variable if applicable
37 S Y=DVBREQDT
38 D DD^%DT
39 S DVBAHD21="Admission Date: "_Y
40 I '$D(^DGPM(+ADMNUM,0)) K Y Q
41 I $P(^DGPM(+ADMNUM,0),U,17)]"" DO
42 .S Y=$P(^(0),U,17) ;naked from line before
43 .S Y=$P(^DGPM(+Y,0),U,1)
44 .D DD^%DT
45 .S DVBADSCH=Y
46 .S DVBAHD22="Discharge Date: "_Y
47 .Q
48 K Y
49 Q
50 ;
51ACT ;sets up activity date variable
52 S Y=DVBREQDT
53 D DD^%DT
54 S DVBAHD21="Activity Date: "_Y
55 K Y
56 Q
57 ;
58DRAW ;This subroutine will draw the screen
59 I IOST?1"C-".E W @IOF
60 W "Information Request Form"
61 W ?35,HNAME
62 W ?59,DVBATDT
63 W !,DVBALN
64 W !,"Patient: "
65 W PNAM
66 W ?54,"SSN: "
67 W SSN
68 W !,"Claim #: ",CNUM,!
69 W DVBAHD21
70 W:$D(DVBAHD22) ?40,DVBAHD22
71 W !!,?9,"Report",?37,"Selected",?60,"Status"
72 W !,DVBALN
73 F DVBAX=0:0 S DVBAX=$O(DVBARPT(DVBAX)) Q:'DVBAX D DRAW1
74 W !,DVBALN
75 Q
76 ;
77DRAW1 ;rights the reports to the screen
78 W !,DVBAX
79 W ?3,$P(DVBARPT(DVBAX),U,1)
80 W ?40,$S($P(DVBARPT(DVBAX),U,2)["Y":"YES",1:"NO")
81 W ?60,$S($P(DVBARPT(DVBAX),U,3)="C":"Completed",$P(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")
82 Q
83 ;
84READ ;reads the user answer
85 S DIR(0)="LAO^1:10^K:X[""."" X"
86 S DIR("A")="Select Report: "
87 S DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8). This will"
88 S DIR("?",2)="initially mark the report as 'YES'. If the number is selected again then it"
89 S DIR("?")="will be changed to 'NO' or vice versa"
90 D ^DIR
91 I $D(DUOUT)!($D(DTOUT)) Q
92 I 'Y S DVBAOUT=1
93 Q
94 ;
95ADJ ;This subroutine adjusts the local array
96 K DVBAER
97 N X,A,FLOP
98 F X=1:1:10 S A=$P(Y,",",X) Q:'A D DISC
99 Q
100 ;
101DISC ;checks for bad answers
102 I $D(ADMNUM),$D(DVBADSCH),A=1 DO:'$D(DVBAER) S DVBAER=1 Q
103 .W *7,!,"Vet already discharged - you cannot request Notice of Discharge."
104 .W !,?30,"<Return> to continue."
105 .R Z:DTIME
106 .Q
107 I DVBDOC="L",(A=1!(A=2)!(A=3)!(A=9)) DO:'$D(DVBAER) S DVBAER=1 Q
108 .W *7,!,"Cannot select 'Notice of Discharge', 'Hospital Summary', 'Certificate (21-day)', or 'Admission Report' for an activity date."
109 . W !,?30,"<Return> to continue."
110 .R Z:DTIME
111 .Q
112 ;
113 ;If Notice of Discharge selected, check patient's Claim Folder Location.
114 I A=1 S FLOP=0 D Q:FLOP
115 . N CK S CK=$$CKCFLOC()
116 . I CK=1 S FLOP=1 W *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"Notice of Discharge would not be returned.",!,?30,"<Return> to continue." R Z:DTIME
117 . I CK=2 S FLOP=1 D
118 .. W *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"Notice of Discharge would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue." R Z:DTIME
119 ;
120 ;If 21 Day Certificate selected, check patient's Claim Folder Location.
121 I A=3 S FLOP=0 D Q:FLOP
122 . N CK S CK=$$CKCFLOC()
123 . I CK=1 S FLOP=1 W *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"21 Day Certificate would not be returned.",!,?30,"<Return> to continue." R Z:DTIME
124 . I CK=2 S FLOP=1 D
125 .. W *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"21 Day Certificate would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue." R Z:DTIME
126 D CHNG
127 Q
128 ;
129CKCFLOC() ;Check if Claim Folder Location or its Station Number is null.
130 ;If Claim Folder Location and Station Number are not null, CK=0.
131 ;If Claim Folder Location is null, CK=1.
132 ;If Station Number is null, CK=2.
133 N CK,ZDFN,ZCFLOC
134 S CK=0
135 S ZDFN=$P($G(DFN),U) I $G(ZDFN)="" S CK=3 Q CK
136 S ZCFLOC=$P($G(^DPT(ZDFN,.31)),U,4)
137 I $G(ZCFLOC)="" S CK=1
138 I $G(ZCFLOC)'="" S:$P($G(^DIC(4,ZCFLOC,99)),U)="" CK=2
139 Q CK
140 ;
141CHNG ;updates the local array
142 Q:$P(DVBARPT(A),U,3)["C"
143 S DVBAOLD=$P(DVBARPT(A),U,2)
144 S DVBAOLD=$S(DVBAOLD["Y":"NO",1:"YES")
145 S $P(DVBARPT(A),U,2)=DVBAOLD
146 S $P(DVBARPT(A),U,3)=$S(DVBAOLD["Y":"P",1:"")
147 Q
148 ;
149FILE ;this subroutine sets the data into the file and asks the last three
150 ;questions
151 I $D(DTOUT) S DVBANY=1 D DEL^DVBAUTL3(DVBAENTR):'$D(DVBAEDT) Q
152 I $D(DUOUT) DO Q
153 .I '$D(DVBAEDT) S DVBANY=1 D DEL^DVBAUTL3(DVBAENTR) Q
154 .S DVBANY=$$ANYSEL(DVBAENTR)
155 .I DVBANY'>0 D ERR
156 .Q
157 D LAST
158 I $D(Y) I '$D(DVBAEDT) DO Q
159 .D DEL^DVBAUTL3(DVBAENTR)
160 .S DVBANY=1
161 .Q
162 S DVBANY=$$ANYSEL(DVBAENTR)
163 I 'DVBANY D ERR Q
164 D STM^DVBCUTL4
165 D FILE^DVBAUTL3
166 S XRTN=$T(+0)
167 D SPM^DVBCUTL4
168 ;;;D TEST:'$D(DVBAEDT)
169 Q
170 ;
171ERR ;this subroutine will print out an error message when no reports are
172 ;selected on the 7131.
173 S VAR(1,0)="1,0,0,2,0^You have not selected any reports for this 7131 request"
174 S VAR(2,0)="0,0,0,1:2,0^or have selected number 4 but not entered any remarks."
175 D WR^DVBAUTL4("VAR")
176 K VAR
177 D CONTMES^DVBCUTL4
178 Q
179 ;
180ANYSEL(B) ;
181 ;This subroutine checks to see if any reports were selected on the 7131
182 ;request.
183 ;B is the internal entry number in file 396
184 N X,CNT
185 S CNT=0
186 F X=0:0 S X=$O(DVBARPT(X)) Q:'X!(CNT) DO ;checking each report
187 . I $P(DVBARPT(X),U,2)="YES" S CNT=1
188 .Q
189 I $P(^DVB(396,B,0),U,25)]"" S CNT=1 ;checking opt date range
190 I $P(DVBARPT(4),U,2)="YES",'$O(^DVB(396,B,5,0)) S CNT=0 ;if no remarks set to zero
191 Q CNT
192 ;
193LAST ;this subroutine will ask the last three questions
194 S DIE="^DVB(396,",DA=DVBAENTR
195 S DR="18;S X=X;19///^S X=$S($P(^DVB(396,DA,0),U,25)']"""":""@"",$P(^(0),U,26)=""C"":""C"",1:""P"");29Routing Location;.5;23///"_DT_";24///"_DT_";27///"_LOC_";28///"_OPER
196 D ^DIE
197 Q
198 ;
199TEST ;tests to see if the user wants this 7131
200 D DRAW
201 W !,*7,"Do you want to file this request"
202 S %=1 D YN^DICN
203 I %=2 D DEL^DVBAUTL3(DVBAENTR)
204 Q
Note: See TracBrowser for help on using the repository browser.