source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCMKL2.m@ 1789

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

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1DVBCMKL2 ;ALB/GTS-AMIE APPT EVENT DRIVER-LINK RTN 2 ; 10/20/94 9:00 PM
2 ;;2.7;AMIE;**17**;Apr 10, 1995
3 ;
4 ;** NOTICE: This routine is part of an implementation of a Nationally
5 ;** Controlled Procedure. Local modifications to this routine
6 ;** are prohibited per VHA Directive 10-93-142
7 ;
8 ;** Version Changes
9 ; 2.7 - New routine (Enhc 13)
10 ;
11LINKAPPT ;** Link C&P appt to 2507
12 ;** Enhanced mode On - user prompted with checks
13 ;** Enhanced mode Off - appointment added as new link
14 I $D(^DVB(396.95,"AR",DVBADA)),(+$$ENHNC^DVBCUTA4=1) DO
15 .S DIR("A",1)=" "
16 .S DIR("A",2)="This 2507 already has appointments."
17 .S DIR("A",3)=" Enter '?' for help"
18 .S DIR("A")="Is this appointment due to a cancellation? "
19 .S DIR("?",1)="Enter NO if the appointment is not a reschedule of another appointment"
20 .S DIR("?",2)=" made previously. Enter YES if the appointment is being scheduled because"
21 .S DIR("?")=" an appointment has been or will be canceled."
22 .S DIR(0)="YA^^"
23 .S DIR("B")="NO"
24 .S Y=""
25 .F Q:(Y=1!(Y=0)!($D(DTOUT))) DO
26 ..D ^DIR
27 ..W:Y="^" *7," '^' NOT ALLOWED"
28 .S DVBAYANS=+Y
29 .K DIR,Y
30 .I +DVBAYANS=1 DO ;**Appt link selection
31 ..S DVBALKRC=$$SELLNK^DVBCUTL8(DVBADA)
32 ..I +DVBALKRC'>0 DO ;**Appt not selected for reschedule
33 ...S DIR("A",1)=" "
34 ...S DIR("A",2)="You have not selected the linked appointment being rescheduled. You may"
35 ...S DIR("A",3)=" need to adjust the link to the appointment with the AMIE link"
36 ...S DIR("A",4)=" management option to ensure proper processing time calculation for this 2507."
37 ...S DIR("A",5)=" "
38 ...S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
39 ..I +DVBALKRC>0 DO ;**Appt selected for reschedule
40 ...I +$P(^DVB(396.95,DVBALKRC,0),U,4)'=1!($P(^DVB(396.95,DVBALKRC,0),U,5)'="") DO
41 ....K DIR,X,Y
42 ....S DIR("?",1)="Enter Yes if the veteran requested a reschedule or 'No Showed' the appointment"
43 ....S DIR("?")="Enter No if the Clinic required a reschedule."
44 ....S DIR("A")="Is this appointment due to a veteran requested cancellation or 'No Show'"
45 ....S DIR(0)="Y^AO" D ^DIR I $D(DTOUT)!($D(DUOUT)) S DVBAGETO=""
46 ....K DIR,DTOUT,DUOUT
47 ....I '$D(DVBAGETO) S:+Y=1 DVBAVTRQ="" DO
48 .....D UPDTLK ;**Reschedule appt
49 ....I $D(DVBAGETO) DO ;**Time or '^' out
50 .....K Y,DIR,DTOUT,DUOUT
51 .....S DIR("A",1)=" "
52 .....S DIR("A",2)="You have not indicated if the reschedule was due to action by the veteran."
53 .....S DIR("A",3)="The new appointment will not be linked. You will need to adjust"
54 .....S DIR("A",4)="the link for this appointment with the AMIE/C&P appointment link management"
55 .....S DIR("A",5)="option to ensure proper processing time calculation for this 2507."
56 .....S DIR("A",6)=" "
57 .....S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue."
58 .....D ^DIR K DIR,X,Y
59 ....K DVBAGETO
60 ...I +$P(^DVB(396.95,DVBALKRC,0),U,4)=1&($P(^DVB(396.95,DVBALKRC,0),U,5)="") S DVBAVTRQ="" D UPDTLK ;**Vet cancel and no vet req date - reschd appt
61 .I +DVBAYANS'=1 DO CRTREC^DVBCMKLK ;**Create new appt tracking record
62 ;
63 ;**No appointments exist for 2507 or enhanced dialogue Off
64 I '$D(^DVB(396.95,"AR",DVBADA))!(+$$ENHNC^DVBCUTA4'=1) DO CRTREC^DVBCMKLK
65 Q
66 ;
67UPDTLK ;** Update selected 396.95 link
68 S DVBARSAP=$P(^DVB(396.95,DVBALKRC,0),U,3)
69 K Y,DIR D RSCHAPT^DVBCMKLK(DVBALKRC,$P(SDATA,U,3))
70 K DVBAVTRQ
71 N DVBAAPST
72 S DVBAAPST=$P(^DPT(DVBADFN,"S",DVBARSAP,0),U,2)
73 I DVBAAPST="NT"!(DVBAAPST="I"!(DVBAAPST="")) DO
74 .N DVBAAPIN S DVBAAPIN=DVBARSAP
75 .S Y=DVBARSAP X ^DD("DD")
76 .S DVBARSAP=Y K Y
77 .S DIR("A",1)=" "
78 .S DIR("A",2)="Remember to cancel the appointment for "_DVBARSAP
79 .S DIR("A",3)=" and do NOT auto-rebook."
80 .S DIR("A",4)=" "
81 .S DIR("A")="Hit Return to continue"
82 .S DIR(0)="FAO^1:1"
83 .D:$P(SDATA,U,3)'=DVBAAPIN ^DIR
84 .K DIR,Y,DVBARSAP
85 Q
86 ;
87LINKHLP ;** Indentifier info for selected links
88 N DVBACLNC,DVBADTE,DVBATIME,DVBADTWK,DVBAX
89 S DVBACLNC=$P(^DPT(DVBADFN,"S",$P(^DVB(396.95,+Y,0),U,3),0),U,1)
90 S DVBACLNC=$P(^SC(DVBACLNC,0),U,1)
91 S DVBADTWK=$P(^DVB(396.95,+Y,0),U,3) ;**Get current date
92 S DVBATIME=$P(DVBADTWK,".",2)
93 S DVBADTWK=$P(DVBADTWK,".",1)
94 S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
95 F DVBAX=$L(DVBATIME):1:3 S DVBATIME=DVBATIME_"0"
96 S DVBATIME=$E(DVBATIME,1,2)_":"_$E(DVBATIME,3,4)
97 S DVBADTE=DVBADTE_" @ "_DVBATIME
98 W ?23,"Currently: ",DVBADTE,?59,DVBACLNC
99 Q
Note: See TracBrowser for help on using the repository browser.