Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCMKL2

DVBCMKL2.m

Go to the documentation of this file.
  1. DVBCMKL2 ;ALB/GTS-AMIE APPT EVENT DRIVER-LINK RTN 2 ; 10/20/94 9:00 PM
  1. ;;2.7;AMIE;**17**;Apr 10, 1995
  1. ;
  1. ;** NOTICE: This routine is part of an implementation of a Nationally
  1. ;** Controlled Procedure. Local modifications to this routine
  1. ;** are prohibited per VHA Directive 10-93-142
  1. ;
  1. ;** Version Changes
  1. ; 2.7 - New routine (Enhc 13)
  1. ;
  1. LINKAPPT ;** Link C&P appt to 2507
  1. ;** Enhanced mode On - user prompted with checks
  1. ;** Enhanced mode Off - appointment added as new link
  1. I $D(^DVB(396.95,"AR",DVBADA)),(+$$ENHNC^DVBCUTA4=1) DO
  1. .S DIR("A",1)=" "
  1. .S DIR("A",2)="This 2507 already has appointments."
  1. .S DIR("A",3)=" Enter '?' for help"
  1. .S DIR("A")="Is this appointment due to a cancellation? "
  1. .S DIR("?",1)="Enter NO if the appointment is not a reschedule of another appointment"
  1. .S DIR("?",2)=" made previously. Enter YES if the appointment is being scheduled because"
  1. .S DIR("?")=" an appointment has been or will be canceled."
  1. .S DIR(0)="YA^^"
  1. .S DIR("B")="NO"
  1. .S Y=""
  1. .F Q:(Y=1!(Y=0)!($D(DTOUT))) DO
  1. ..D ^DIR
  1. ..W:Y="^" *7," '^' NOT ALLOWED"
  1. .S DVBAYANS=+Y
  1. .K DIR,Y
  1. .I +DVBAYANS=1 DO ;**Appt link selection
  1. ..S DVBALKRC=$$SELLNK^DVBCUTL8(DVBADA)
  1. ..I +DVBALKRC'>0 DO ;**Appt not selected for reschedule
  1. ...S DIR("A",1)=" "
  1. ...S DIR("A",2)="You have not selected the linked appointment being rescheduled. You may"
  1. ...S DIR("A",3)=" need to adjust the link to the appointment with the AMIE link"
  1. ...S DIR("A",4)=" management option to ensure proper processing time calculation for this 2507."
  1. ...S DIR("A",5)=" "
  1. ...S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
  1. ..I +DVBALKRC>0 DO ;**Appt selected for reschedule
  1. ...I +$P(^DVB(396.95,DVBALKRC,0),U,4)'=1!($P(^DVB(396.95,DVBALKRC,0),U,5)'="") DO
  1. ....K DIR,X,Y
  1. ....S DIR("?",1)="Enter Yes if the veteran requested a reschedule or 'No Showed' the appointment"
  1. ....S DIR("?")="Enter No if the Clinic required a reschedule."
  1. ....S DIR("A")="Is this appointment due to a veteran requested cancellation or 'No Show'"
  1. ....S DIR(0)="Y^AO" D ^DIR I $D(DTOUT)!($D(DUOUT)) S DVBAGETO=""
  1. ....K DIR,DTOUT,DUOUT
  1. ....I '$D(DVBAGETO) S:+Y=1 DVBAVTRQ="" DO
  1. .....D UPDTLK ;**Reschedule appt
  1. ....I $D(DVBAGETO) DO ;**Time or '^' out
  1. .....K Y,DIR,DTOUT,DUOUT
  1. .....S DIR("A",1)=" "
  1. .....S DIR("A",2)="You have not indicated if the reschedule was due to action by the veteran."
  1. .....S DIR("A",3)="The new appointment will not be linked. You will need to adjust"
  1. .....S DIR("A",4)="the link for this appointment with the AMIE/C&P appointment link management"
  1. .....S DIR("A",5)="option to ensure proper processing time calculation for this 2507."
  1. .....S DIR("A",6)=" "
  1. .....S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue."
  1. .....D ^DIR K DIR,X,Y
  1. ....K DVBAGETO
  1. ...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
  1. .I +DVBAYANS'=1 DO CRTREC^DVBCMKLK ;**Create new appt tracking record
  1. ;
  1. ;**No appointments exist for 2507 or enhanced dialogue Off
  1. I '$D(^DVB(396.95,"AR",DVBADA))!(+$$ENHNC^DVBCUTA4'=1) DO CRTREC^DVBCMKLK
  1. Q
  1. ;
  1. UPDTLK ;** Update selected 396.95 link
  1. S DVBARSAP=$P(^DVB(396.95,DVBALKRC,0),U,3)
  1. K Y,DIR D RSCHAPT^DVBCMKLK(DVBALKRC,$P(SDATA,U,3))
  1. K DVBAVTRQ
  1. N DVBAAPST
  1. S DVBAAPST=$P(^DPT(DVBADFN,"S",DVBARSAP,0),U,2)
  1. I DVBAAPST="NT"!(DVBAAPST="I"!(DVBAAPST="")) DO
  1. .N DVBAAPIN S DVBAAPIN=DVBARSAP
  1. .S Y=DVBARSAP X ^DD("DD")
  1. .S DVBARSAP=Y K Y
  1. .S DIR("A",1)=" "
  1. .S DIR("A",2)="Remember to cancel the appointment for "_DVBARSAP
  1. .S DIR("A",3)=" and do NOT auto-rebook."
  1. .S DIR("A",4)=" "
  1. .S DIR("A")="Hit Return to continue"
  1. .S DIR(0)="FAO^1:1"
  1. .D:$P(SDATA,U,3)'=DVBAAPIN ^DIR
  1. .K DIR,Y,DVBARSAP
  1. Q
  1. ;
  1. LINKHLP ;** Indentifier info for selected links
  1. N DVBACLNC,DVBADTE,DVBATIME,DVBADTWK,DVBAX
  1. S DVBACLNC=$P(^DPT(DVBADFN,"S",$P(^DVB(396.95,+Y,0),U,3),0),U,1)
  1. S DVBACLNC=$P(^SC(DVBACLNC,0),U,1)
  1. S DVBADTWK=$P(^DVB(396.95,+Y,0),U,3) ;**Get current date
  1. S DVBATIME=$P(DVBADTWK,".",2)
  1. S DVBADTWK=$P(DVBADTWK,".",1)
  1. S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
  1. F DVBAX=$L(DVBATIME):1:3 S DVBATIME=DVBATIME_"0"
  1. S DVBATIME=$E(DVBATIME,1,2)_":"_$E(DVBATIME,3,4)
  1. S DVBADTE=DVBADTE_" @ "_DVBATIME
  1. W ?23,"Currently: ",DVBADTE,?59,DVBACLNC
  1. Q