source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQAS.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1ACKQAS ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits ; 04/01/99
2 ;;3.0;QUASAR;**1,10,15**;Feb 11, 2000;Build 2
3 ;Call DEM^VADPT supported by DBIA #10061
4 ;
5 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
6 ;
7IVD ; INITIAL VISIT DATE ** TRIGGERED FROM PATIENT NAME ***
8 N Y,DDD,DD,DFN,D0,%DT
9 S DFN=X,X=$S('$D(^ACK(509850.2,DFN,0)):"",'$P(^(0),U,2):"",1:$P(^(0),U,2))
10 I 'X D
11 . F D Q:X=""!(X'>DT)
12 .. S Y=ACKVD D DD^%DT S %DT="AEP",%DT("A")="INITIAL VISIT DATE: "
13 .. S %DT("B")=Y D ^%DT K %DT S X=$S(Y<1:"",1:Y)
14 .. I X>DT W !,"No Future Dates Allowed",!
15 K A1
16 Q
17 ;
18VISIT ; New visit data input
19 N ACKOUT
20 I '$O(^ACK(509850.8,0)) W !,"A&SP site parameters must be established before visits can be entered.",! Q
21 ;
22 D LIST^DIC(509850.83,",1,",".01","I","*","","","","","","ACKTRGT","ACKMSG")
23 I '$P($G(ACKTRGT("DILIST",0)),U,1) W !,"No Divisions have been set up select the Site Parameters function to set up",!,"Division entries.",! Q
24 ;
25 ; Get the Division
26DIV ;
27 I $D(ACKDVN),$D(CLINVARR),$P($G(ACKDVN),U,2)=1,$G(CLINVARR)<2 G VEXIT
28 D VEXIT
29 S ACKDVN=$$DIV^ACKQUTL2(1,.ACKDIV) G:$P(ACKDVN,U,1)="0" VEXIT
30 I '$P(ACKDVN,U,2) W !!!!!,"No Active Divisions Set up on Site Parameters File" W ! H 1 G VEXIT
31 S ACKDIV=$O(ACKDIV("")),ACKDIV=$P(ACKDIV(ACKDIV),U,1) ; use division IEN of Parameter file
32 I $P(ACKDVN,U,2)>1 W " Station Number : "_$$GET1^DIQ(40.8,ACKDIV,1)
33 ;
34 ; Get clinic
35CLIN S ACKCLIN=$$CLIN^ACKQASU1(ACKDIV,"U") G:ACKCLIN=""&($P($G(ACKDVN),U,2)=1) VEXIT G:ACKCLIN="" DIV
36 I ACKCLIN=0 W !!!!!,"No Clinics set up for Division " W ! H 1 G DIV
37 S ACKCLIN=$P(ACKCLIN,U,1) ; Use clinic IEN from Clinic file
38 ; Get Clinic stop code
39 D STOP
40 ;
41 W !!!,"Clinic: ",$$GET1^DIQ(44,ACKCLIN,.01)," Stop Code: ",ACKCSC(1)
42 ;
43 ; Get visit date
44VDATE S DIR(0)="D^:DT:AEX",DIR("A")="Enter Visit Date",DIR("B")="TODAY"
45 S DIR("?")="Enter the visit date or press return for TODAY. Future dates not allowed",DIR("??")="^D HELP^%DTC"
46 D ^DIR K DIR I X?1"^"1.E W !,"Jumping not allowed." G VDATE
47 G:$D(DIRUT) DIV
48 S ACKVD=Y
49 ;
50 ;
51PATIENT S DIC="^ACK(509850.2,",DIC(0)="AEMQL",DLAYGO=509850.2
52 S DIC("W")="N ACKA,ACKB S ACKA=$$GET1^DIQ(2,Y,.03),ACKB=$$GET1^DIQ(2,Y,.09),ACKA=$E(ACKA,1,2)_""-""_$E(ACKA,4,5)_""-""_$E(ACKA,9,10) W ?36,ACKA_"" ""_ACKB"
53 S ACKLAYGO="" D ^DIC I X?1"^"1.E W !,"Jumping not allowed." G PATIENT
54 G:$D(DTOUT) DIV
55 I X="^" G DIV
56 I Y<0 W !,"This is a required response. Enter '^' to exit" G PATIENT
57 S (ACKPAT,DFN)=+Y
58 S ACKDFN=DFN
59 ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
60 S ACKOUT=0
61 D CHKDTH
62 I ACKOUT=1 S ACKOUT=0 G PATIENT
63 ;; END ACKQ*3*10
64 ; Check to see if Patient has a Primary Eligibility
65 I '$$ELIGCHK^ACKQASU W !!,"DATA ERROR : Patient has no Primary Eligibility defined on the Patient File.",!,"This requires updating before QUASAR processing can commence.",! D VEXIT G DIV
66 ;
67 ; check for duplicate visits (same date/same patient) allow user to select one
68 S ACKVSEL=$$DUPCHK^ACKQASU1(ACKPAT,ACKVD) G:ACKVSEL=-1 DIV
69 S (DA,ACKY)=ACKVSEL ; either 0 (no visit selected) or selected visit ien
70 ;
71 S (ACKFLG1,ACKFLG2)=0 I DA D I (ACKFLG1)!(ACKFLG2) D VEXIT G VISIT
72 .; Compare clinic location/stop code of selected visit with
73 .; original clinic location/stop code.
74 .S ACKESITE=$P($G(^ACK(509850.6,ACKY,0)),U,6),ACKECSC=$P($G(^ACK(509850.6,ACKY,2)),U)
75 .I ACKESITE'=ACKCLIN S ACKFLG1=1
76 .I ACKECSC'=ACKCSC S ACKFLG2=1
77 .I (ACKFLG1)!(ACKFLG2) K DA D
78 ..W !!,"The "_$S(ACKFLG1:"clinic location",1:"clinic stop code")_" for the selected appointment does not match",!,"the current "_$S(ACKFLG1:"clinic location",1:"clinic stop code")_". Transaction not allowed.",!
79 ;
80 ; Get PCE flag - 1 if division set to send to PCE else 0
81 S ACKPCE=$$PCE^ACKQUTL4(ACKDIV,ACKVD)
82 ;
83 ; Existing A&SP Patient
84 I DA D EDIT^ACKQAS5 G VISIT
85 ;
86 ; New visit
87 K DD,DO,DA,D0
88 S ACKVISIT="NEW",ACKVTME="" ; indicates this is a new visit
89 ;
90 ; If PCE interface not on skip to Call Template logic
91 I 'ACKPCE S ACKVTME="" G FILE
92 ;
93PCE ; Select a PCE visit
94 ;
95 ; Run function to check if there is a PCE visit for today
96 I '$$PCEVST1^ACKQASU1(ACKVD,ACKPAT,ACKCLIN) G APPMNT
97 ;
98 ; As PCE visits must exist on the visit date run the API that displays
99 ; them and prompts the user to either select one or add a new visit.
100 S ACKPCENO=$$VISITLST^PXAPI(ACKPAT,ACKVD,ACKVD,ACKCLIN,"APO","","A")
101 I ACKPCENO="-1" G DIV ; Go back to Division prompt if '^' entered
102 S ACKVTME=""
103 ; I ACKPCENO="A" 'ADD' selected user wishes to create new visit
104 I ACKPCENO'="A" G FILE
105 ;
106APPMNT ; Check for any appointments for the patient on this date.
107 S VASD("C",ACKCLIN)="",VASD("T")=ACKVD,VASD("F")=ACKVD
108 S VASD("W")="129"
109 K ^UTILITY("VASD",$J) D SDA^VADPT
110 I '$D(^UTILITY("VASD",$J)) G FILE ; If no appointments goto PCE check
111 ;
112 ; Displays headings and appointments
113 ;
114 D DISP^ACKQASU
115 ;
116 ; User is prompted to choose or create a new visit.
117 ;
118APPMNT1 S ACKNUM=$O(^UTILITY("VASD",$J,""),-1)
119 S DIR("A")=" Select Appointment (1-"_ACKNUM_") or (N)ew Visit "
120 S DIR("B")=1
121 S DIR("?")=" Select number on left of the list or 'N' for New Visit"
122 S DIR(0)="F^1:2^S:X=""n"" X=""N"" K:X'=""N""&((+X<1)!(+X>ACKNUM)) X"
123 D ^DIR K DIR,ACKNUM
124 I X?1"^"1.E W !,"Jumping not allowed." G APPMNT1
125 G:$D(DIRUT) DIV ; Go back to division if '^' entered.
126 ;
127 I X'="N"&(X'="n") S X=+X,ACKVTME=$P(^UTILITY("VASD",$J,X,"I"),U,1),ACKVTME=$P(ACKVTME,".",2),ACKAPMNT=1
128 K ^UTILITY("VASD",$J)
129 ;
130FILE ; Set up dummy record and run input template
131 ;
132 ; If Appointment Time is not yet known, but a PCE Visit was selected, get the time
133 I ACKVTME="",ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D
134 . S ACKVTME=$$GETPCETM^ACKQASU(ACKPCENO),ACKVTME=$P($P(ACKVTME,U,1),".",2)
135 . I 'ACKVTME S ACKVTME="" Q
136 ;
137 I ACKPCE,$G(ACKAPMNT)'=1,'$$ACKAPMNT^ACKQASU7(ACKVD,ACKVTME,ACKCLIN,ACKPAT) D VEXIT,HEADING G VISIT
138 K ACKAPMNT
139 ;
140 ; Check to see if entry is on 'APCE' cross ref. if so either return to
141 ; Division prompt or null out appointment time variable.
142 I ACKVTME'="",$D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)) D I 'ACKQCHK D UNLOCK,VEXIT,HEADING G VISIT
143 . S ACKQCHK=$$DUPEDATA^ACKQASU(ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)
144 . I 'ACKQCHK Q
145 . ; user has decided to continue, so TIME is deleted and PCE VISIT is deleted
146 . ; this ensures that the visit is treated as brand new when sent to PCE
147 . S ACKVTME="" ; time
148 . S ACKPCENO="" ; pce visit ien
149 ;
150 ; create new visit entry
151 ;
152 S DIC="^ACK(509850.6,",DIC(0)="L",DLAYGO=509850.6,ACKLAYGO=""
153 S X=ACKVD D FILE^DICN,CHKDT ; File a dummy record prior to template
154 S ACKVIEN=+$P(Y,U,1) ; Get visit IEN from Y value.
155 ;
156 K ACKARR
157 S ACKARR(509850.6,ACKVIEN_",",2.6)=ACKCLIN
158 S ACKARR(509850.6,ACKVIEN_",",60)=ACKDIV
159 I +ACKVTME S ACKARR(509850.6,ACKVIEN_",",55)="."_ACKVTME ; file time if known
160 I +$G(ACKPCENO)'=0 S ACKARR(509850.6,ACKVIEN_",",125)=ACKPCENO ; file PCE number if one selected
161 D STOP S ACKARR(509850.6,ACKVIEN_",",4)=ACKCSC ; file visit stop (required by COPYPCE)
162 D FILE^DIE("","ACKARR")
163 ;
164 ; Lock the record
165 L +^ACK(509850.6,ACKVIEN)
166 ;
167 ; Write away any derived PCE values to visit record
168 I ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D I +ACKERR D DEL,UNLOCK,VEXIT,HEADING G VISIT
169 . S ACKERR=$$COPYPCE^ACKQASU4(ACKVIEN,ACKPCENO)
170 . ; if error found, display and reset ACKERR according to whether the
171 . ; user wants to continue (SHOWPCE returns 1=exit,0=continue)
172 . I +ACKERR S ACKERR=$$SHOWPCE^ACKQASU7($NA(^TMP("ACKQASU4",$J,"COPYPCE","ERROR")))
173 ;
174 ;
175TPLATE ; Call template
176 S DIE="^ACK(509850.6,",(DA,ACKDA)=ACKVIEN,DR="[ACKQAS VISIT ENTRY]" D ^DIE
177 ;
178 K ACKREQ
179 I $G(ACKLOSS)'="",$$AUDIO^ACKQUTL4 D UTLAUD^ACKQASU2
180 S ACKQTST=$$POST^ACKQASU2(ACKVIEN) I 'ACKQTST S ACKDFN=DFN G TPLATE
181 I ACKPCE,ACKQTST=1 I '$$PCESEND^ACKQASU3(ACKVIEN) S ACKDFN=DFN G TPLATE
182 D UNLOCK,VEXIT,HEADING G VISIT
183 ;
184VEXIT ; Kill off variables at end of processing
185 ;
186 D KILL^ACKQASU
187 D KILL^%ZISS
188 Q
189 ;
190AOA ; COMPUTE AGE ON APPOINTMENT DATE
191 N DFN,VA,VADM,VAERR,X1,X2 S DFN=$P(^ACK(509850.6,D0,0),U,2),X1=$P(^(0),U) D DEM^VADPT S X2=+VADM(3),X=X1-X2\10000
192 Q
193 ;
194CHKDT ;
195 S ACKMON=$E(X,1,5) S ACKGEN=$S($D(^ACK(509850.7,ACKMON,0)):^(0),1:"")
196 Q:'$L(ACKGEN) I $P(ACKGEN,U,4) W !!,$C(7),"Capitation data for that time period has already been compiled.",!,"To insure proper credit for this visit, please make sure the capitation",!,"data is regenerated.",!
197 Q
198 ;
199SITE ;
200 S DIR(0)="P^ACK(509850.8,1,1,:AEMQ",DA(1)=1
201 S DIR("A")="Select Clinic Location"
202 S DIR("?")="Choose the clinic location that should be associated with these visits."
203 D ^DIR K DIR S:'$D(DIRUT) ACKSITE=+Y Q:$D(DIRUT)
204 ;
205STOP ;
206 S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,8,"I")
207 S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
208 S ACKCSC=""
209 I ACKCSC(1)=203 S ACKCSC="A"
210 I ACKCSC(1)=204 S ACKCSC="S"
211 I ACKCSC="" D
212 . S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,2503,"I")
213 . S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
214 . I ACKCSC(1)=203 S ACKCSC="AT"
215 . I ACKCSC(1)=204 S ACKCSC="ST"
216 ;
217 K ACKCSCP
218 Q
219 ;
220 ;
221UNLOCK ; Unlock Locked record
222 L
223 Q
224 ;
225HEADING ;
226 W @IOF
227 W !,"This option is used to enter new A&SP clinic visits. Existing clinic",!,"visits should be updated with the Edit an Existing Visit option.",!
228 Q
229 ;
230DEL W !!,$C(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
231 S DIK="^ACK(509850.6,",DA=ACKVIEN D ^DIK
232 Q
233 ;
234CHKDTH ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
235 N I,X,Y,ACKDIRUT,ACK,VA,VADM,VAERR
236 D DEM^VADPT
237 S ACK(4)=""
238 I VADM(6)'="" D
239 .S Y=$P(VADM(6),"^",2)
240 .X ^DD("DD")
241 .S ACK(4)="[PATIENT DIED ON "_$P(Y,"@")_"]"
242 I ACK(4)'="" W !!,ACK(4),! S ACKOUT=1
243 ;; END ACKQ*3*10
244 Q
Note: See TracBrowser for help on using the repository browser.