DVBCMKL2 ;ALB/GTS-AMIE APPT EVENT DRIVER-LINK RTN 2 ; 10/20/94 9:00 PM
;;2.7;AMIE;**17**;Apr 10, 1995
;
;** NOTICE: This routine is part of an implementation of a Nationally
;** Controlled Procedure. Local modifications to this routine
;** are prohibited per VHA Directive 10-93-142
;
;** Version Changes
; 2.7 - New routine (Enhc 13)
;
LINKAPPT ;** Link C&P appt to 2507
;** Enhanced mode On - user prompted with checks
;** Enhanced mode Off - appointment added as new link
I $D(^DVB(396.95,"AR",DVBADA)),(+$$ENHNC^DVBCUTA4=1) DO
.S DIR("A",1)=" "
.S DIR("A",2)="This 2507 already has appointments."
.S DIR("A",3)=" Enter '?' for help"
.S DIR("A")="Is this appointment due to a cancellation? "
.S DIR("?",1)="Enter NO if the appointment is not a reschedule of another appointment"
.S DIR("?",2)=" made previously. Enter YES if the appointment is being scheduled because"
.S DIR("?")=" an appointment has been or will be canceled."
.S DIR(0)="YA^^"
.S DIR("B")="NO"
.S Y=""
.F Q:(Y=1!(Y=0)!($D(DTOUT))) DO
..D ^DIR
..W:Y="^" *7," '^' NOT ALLOWED"
.S DVBAYANS=+Y
.K DIR,Y
.I +DVBAYANS=1 DO ;**Appt link selection
..S DVBALKRC=$$SELLNK^DVBCUTL8(DVBADA)
..I +DVBALKRC'>0 DO ;**Appt not selected for reschedule
...S DIR("A",1)=" "
...S DIR("A",2)="You have not selected the linked appointment being rescheduled. You may"
...S DIR("A",3)=" need to adjust the link to the appointment with the AMIE link"
...S DIR("A",4)=" management option to ensure proper processing time calculation for this 2507."
...S DIR("A",5)=" "
...S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
..I +DVBALKRC>0 DO ;**Appt selected for reschedule
...I +$P(^DVB(396.95,DVBALKRC,0),U,4)'=1!($P(^DVB(396.95,DVBALKRC,0),U,5)'="") DO
....K DIR,X,Y
....S DIR("?",1)="Enter Yes if the veteran requested a reschedule or 'No Showed' the appointment"
....S DIR("?")="Enter No if the Clinic required a reschedule."
....S DIR("A")="Is this appointment due to a veteran requested cancellation or 'No Show'"
....S DIR(0)="Y^AO" D ^DIR I $D(DTOUT)!($D(DUOUT)) S DVBAGETO=""
....K DIR,DTOUT,DUOUT
....I '$D(DVBAGETO) S:+Y=1 DVBAVTRQ="" DO
.....D UPDTLK ;**Reschedule appt
....I $D(DVBAGETO) DO ;**Time or '^' out
.....K Y,DIR,DTOUT,DUOUT
.....S DIR("A",1)=" "
.....S DIR("A",2)="You have not indicated if the reschedule was due to action by the veteran."
.....S DIR("A",3)="The new appointment will not be linked. You will need to adjust"
.....S DIR("A",4)="the link for this appointment with the AMIE/C&P appointment link management"
.....S DIR("A",5)="option to ensure proper processing time calculation for this 2507."
.....S DIR("A",6)=" "
.....S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue."
.....D ^DIR K DIR,X,Y
....K DVBAGETO
...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
.I +DVBAYANS'=1 DO CRTREC^DVBCMKLK ;**Create new appt tracking record
;
;**No appointments exist for 2507 or enhanced dialogue Off
I '$D(^DVB(396.95,"AR",DVBADA))!(+$$ENHNC^DVBCUTA4'=1) DO CRTREC^DVBCMKLK
Q
;
UPDTLK ;** Update selected 396.95 link
S DVBARSAP=$P(^DVB(396.95,DVBALKRC,0),U,3)
K Y,DIR D RSCHAPT^DVBCMKLK(DVBALKRC,$P(SDATA,U,3))
K DVBAVTRQ
N DVBAAPST
S DVBAAPST=$P(^DPT(DVBADFN,"S",DVBARSAP,0),U,2)
I DVBAAPST="NT"!(DVBAAPST="I"!(DVBAAPST="")) DO
.N DVBAAPIN S DVBAAPIN=DVBARSAP
.S Y=DVBARSAP X ^DD("DD")
.S DVBARSAP=Y K Y
.S DIR("A",1)=" "
.S DIR("A",2)="Remember to cancel the appointment for "_DVBARSAP
.S DIR("A",3)=" and do NOT auto-rebook."
.S DIR("A",4)=" "
.S DIR("A")="Hit Return to continue"
.S DIR(0)="FAO^1:1"
.D:$P(SDATA,U,3)'=DVBAAPIN ^DIR
.K DIR,Y,DVBARSAP
Q
;
LINKHLP ;** Indentifier info for selected links
N DVBACLNC,DVBADTE,DVBATIME,DVBADTWK,DVBAX
S DVBACLNC=$P(^DPT(DVBADFN,"S",$P(^DVB(396.95,+Y,0),U,3),0),U,1)
S DVBACLNC=$P(^SC(DVBACLNC,0),U,1)
S DVBADTWK=$P(^DVB(396.95,+Y,0),U,3) ;**Get current date
S DVBATIME=$P(DVBADTWK,".",2)
S DVBADTWK=$P(DVBADTWK,".",1)
S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
F DVBAX=$L(DVBATIME):1:3 S DVBATIME=DVBATIME_"0"
S DVBATIME=$E(DVBATIME,1,2)_":"_$E(DVBATIME,3,4)
S DVBADTE=DVBADTE_" @ "_DVBATIME
W ?23,"Currently: ",DVBADTE,?59,DVBACLNC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCMKL2 4404 printed Dec 13, 2024@01:44:50 Page 2
DVBCMKL2 ;ALB/GTS-AMIE APPT EVENT DRIVER-LINK RTN 2 ; 10/20/94 9:00 PM
+1 ;;2.7;AMIE;**17**;Apr 10, 1995
+2 ;
+3 ;** NOTICE: This routine is part of an implementation of a Nationally
+4 ;** Controlled Procedure. Local modifications to this routine
+5 ;** are prohibited per VHA Directive 10-93-142
+6 ;
+7 ;** Version Changes
+8 ; 2.7 - New routine (Enhc 13)
+9 ;
LINKAPPT ;** Link C&P appt to 2507
+1 ;** Enhanced mode On - user prompted with checks
+2 ;** Enhanced mode Off - appointment added as new link
+3 IF $DATA(^DVB(396.95,"AR",DVBADA))
IF (+$$ENHNC^DVBCUTA4=1)
Begin DoDot:1
+4 SET DIR("A",1)=" "
+5 SET DIR("A",2)="This 2507 already has appointments."
+6 SET DIR("A",3)=" Enter '?' for help"
+7 SET DIR("A")="Is this appointment due to a cancellation? "
+8 SET DIR("?",1)="Enter NO if the appointment is not a reschedule of another appointment"
+9 SET DIR("?",2)=" made previously. Enter YES if the appointment is being scheduled because"
+10 SET DIR("?")=" an appointment has been or will be canceled."
+11 SET DIR(0)="YA^^"
+12 SET DIR("B")="NO"
+13 SET Y=""
+14 FOR
if (Y=1!(Y=0)!($DATA(DTOUT)))
QUIT
Begin DoDot:2
+15 DO ^DIR
+16 if Y="^"
WRITE *7," '^' NOT ALLOWED"
End DoDot:2
+17 SET DVBAYANS=+Y
+18 KILL DIR,Y
+19 ;**Appt link selection
IF +DVBAYANS=1
Begin DoDot:2
+20 SET DVBALKRC=$$SELLNK^DVBCUTL8(DVBADA)
+21 ;**Appt not selected for reschedule
IF +DVBALKRC'>0
Begin DoDot:3
+22 SET DIR("A",1)=" "
+23 SET DIR("A",2)="You have not selected the linked appointment being rescheduled. You may"
+24 SET DIR("A",3)=" need to adjust the link to the appointment with the AMIE link"
+25 SET DIR("A",4)=" management option to ensure proper processing time calculation for this 2507."
+26 SET DIR("A",5)=" "
+27 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit any key to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:3
+28 ;**Appt selected for reschedule
IF +DVBALKRC>0
Begin DoDot:3
+29 IF +$PIECE(^DVB(396.95,DVBALKRC,0),U,4)'=1!($PIECE(^DVB(396.95,DVBALKRC,0),U,5)'="")
Begin DoDot:4
+30 KILL DIR,X,Y
+31 SET DIR("?",1)="Enter Yes if the veteran requested a reschedule or 'No Showed' the appointment"
+32 SET DIR("?")="Enter No if the Clinic required a reschedule."
+33 SET DIR("A")="Is this appointment due to a veteran requested cancellation or 'No Show'"
+34 SET DIR(0)="Y^AO"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET DVBAGETO=""
+35 KILL DIR,DTOUT,DUOUT
+36 IF '$DATA(DVBAGETO)
if +Y=1
SET DVBAVTRQ=""
Begin DoDot:5
+37 ;**Reschedule appt
DO UPDTLK
End DoDot:5
+38 ;**Time or '^' out
IF $DATA(DVBAGETO)
Begin DoDot:5
+39 KILL Y,DIR,DTOUT,DUOUT
+40 SET DIR("A",1)=" "
+41 SET DIR("A",2)="You have not indicated if the reschedule was due to action by the veteran."
+42 SET DIR("A",3)="The new appointment will not be linked. You will need to adjust"
+43 SET DIR("A",4)="the link for this appointment with the AMIE/C&P appointment link management"
+44 SET DIR("A",5)="option to ensure proper processing time calculation for this 2507."
+45 SET DIR("A",6)=" "
+46 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit any key to continue."
+47 DO ^DIR
KILL DIR,X,Y
End DoDot:5
+48 KILL DVBAGETO
End DoDot:4
+49 ;**Vet cancel and no vet req date - reschd appt
IF +$PIECE(^DVB(396.95,DVBALKRC,0),U,4)=1&($PIECE(^DVB(396.95,DVBALKRC,0),U,5)="")
SET DVBAVTRQ=""
DO UPDTLK
End DoDot:3
End DoDot:2
+50 ;**Create new appt tracking record
IF +DVBAYANS'=1
DO CRTREC^DVBCMKLK
End DoDot:1
+51 ;
+52 ;**No appointments exist for 2507 or enhanced dialogue Off
+53 IF '$DATA(^DVB(396.95,"AR",DVBADA))!(+$$ENHNC^DVBCUTA4'=1)
DO CRTREC^DVBCMKLK
+54 QUIT
+55 ;
UPDTLK ;** Update selected 396.95 link
+1 SET DVBARSAP=$PIECE(^DVB(396.95,DVBALKRC,0),U,3)
+2 KILL Y,DIR
DO RSCHAPT^DVBCMKLK(DVBALKRC,$PIECE(SDATA,U,3))
+3 KILL DVBAVTRQ
+4 NEW DVBAAPST
+5 SET DVBAAPST=$PIECE(^DPT(DVBADFN,"S",DVBARSAP,0),U,2)
+6 IF DVBAAPST="NT"!(DVBAAPST="I"!(DVBAAPST=""))
Begin DoDot:1
+7 NEW DVBAAPIN
SET DVBAAPIN=DVBARSAP
+8 SET Y=DVBARSAP
XECUTE ^DD("DD")
+9 SET DVBARSAP=Y
KILL Y
+10 SET DIR("A",1)=" "
+11 SET DIR("A",2)="Remember to cancel the appointment for "_DVBARSAP
+12 SET DIR("A",3)=" and do NOT auto-rebook."
+13 SET DIR("A",4)=" "
+14 SET DIR("A")="Hit Return to continue"
+15 SET DIR(0)="FAO^1:1"
+16 if $PIECE(SDATA,U,3)'=DVBAAPIN
DO ^DIR
+17 KILL DIR,Y,DVBARSAP
End DoDot:1
+18 QUIT
+19 ;
LINKHLP ;** Indentifier info for selected links
+1 NEW DVBACLNC,DVBADTE,DVBATIME,DVBADTWK,DVBAX
+2 SET DVBACLNC=$PIECE(^DPT(DVBADFN,"S",$PIECE(^DVB(396.95,+Y,0),U,3),0),U,1)
+3 SET DVBACLNC=$PIECE(^SC(DVBACLNC,0),U,1)
+4 ;**Get current date
SET DVBADTWK=$PIECE(^DVB(396.95,+Y,0),U,3)
+5 SET DVBATIME=$PIECE(DVBADTWK,".",2)
+6 SET DVBADTWK=$PIECE(DVBADTWK,".",1)
+7 SET DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
+8 FOR DVBAX=$LENGTH(DVBATIME):1:3
SET DVBATIME=DVBATIME_"0"
+9 SET DVBATIME=$EXTRACT(DVBATIME,1,2)_":"_$EXTRACT(DVBATIME,3,4)
+10 SET DVBADTE=DVBADTE_" @ "_DVBATIME
+11 WRITE ?23,"Currently: ",DVBADTE,?59,DVBACLNC
+12 QUIT
