- 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 Feb 18, 2025@23:11:15 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