DVBCMKLK ;ALB/GTS-AMIE C&P APPT EVENT DRIVER-LINK RTN ; 10/20/94 4:00 PM
;;2.7;AMIE;;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)
;
EN ;** Link C&P appointment to 2507
S DVBADFN=DFN,DVBASTAT="P" ;**DVBASTAT used in REQARY^DVBCUTL5
;
;**If user entered from AMIE Scheduling, only prompted if enhanced
;** dialogue turned on and is needed
;** QUIT on next line if from DVBCSCHD
I $D(DVBASDRT) S DVBADA=REQDA D LINKAPPT^DVBCMKL2,KVARS QUIT ;*DVBCSCHD
S (DVBADA,DVBASDPR)=""
D REQARY^DVBCUTL5 ;**Set up ^TMP of AMIE 2507's
I +DVBACNT>0 DO
.I +DVBACNT=1 DO ;**Auto select 2507 if only one exists
..S (DVBADT,DVBADA,DVBAORD)=""
..S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD))
..S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
..S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
.I +DVBACNT>1 DO ;**If more than one 2507 exists, user select
..D REQSEL^DVBCUTL5 ;**Select a 2507 from ^TMP
..I (+Y'>0)!($D(DVBAOUT)) S DVBADA=""
..S:+Y>0 DVBASEL=+Y ;**Y is selected 2507 val returned from ^DIR
..D:+Y>0 FINDDA^DVBCUTL5 ;**Find selected 2507 DA (Returned in DVBADA)
.K ^TMP("DVBC",$J)
.I '$D(^DVB(396.3,+DVBADA,0)),(+$$ENHNC^DVBCUTA4=1) DO ;**Write warning
..S DIR("A",1)="You have not selected a 2507 request to link the C&P appointment to."
..S DIR("A",2)="The appointment should be linked with the AMIE/C&P Appointment Link"
..S DIR("A",3)=" Management Option to ensure proper processing time calculation for this 2507"
..S DIR("A",4)=" in the event of a veteran cancellation."
..S DIR("A",5)=" "
..S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
.I $D(^DVB(396.3,+DVBADA,0)) D LINKAPPT^DVBCMKL2 ;**If 2507, link appt
I +DVBACNT'>0,(+$$ENHNC^DVBCUTA4=1) DO ;**Write Warning
.S DIR("A",1)="You have made a C&P appointment for a patient who has no pending 2507 request!"
.S DIR("A",2)=" "
.S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
Q
;
KVARS ;** Kill variables used by scheduling protocol
K DVBAMORE,DVBALP,DVBAOUT,DVBADTOT,DVBASDPR,DVBASEL
K DVBAPNAM,DVBADA,DVBADFN,DVBASTAT,DVBADT,DVBAORD,DVBACNT
K ^TMP("DVBC",$J),Y,DVBAYANS,DVBALKRC,DVBARSAP
Q
;
CRTREC ;** Add a record to file 396.95 (Appt Tracking)
K DD,DO
S DVBAADT=$P(SDATA,U,3)
S DIC="^DVB(396.95,",X=DVBAADT,DIC(0)="LX",DLAYGO="396.95"
S DIC("DR")=".02////^S X=DVBAADT;.03////^S X=DVBAADT;"
S DIC("DR")=DIC("DR")_".04////^S X=0;.06////^S X=DVBADA;"
S DIC("DR")=DIC("DR")_".07////^S X=1"
D FILE^DICN K DIC,X,DLAYGO,DVBAADT
I +$$ENHNC^DVBCUTA4=1 DO
.N REQDT,SAVY
.S:$D(Y) SAVY=Y
.S REQDT=$$GETDTE(DVBADA) ;**Set REQDT
.S:$D(SAVY) Y=SAVY
.S DIR("A",1)=" "
.S DIR("A",2)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
.S DIR("A",3)=" "
.S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
Q
;
GETDTE(REQDA) ;** Get the request dte
N REQDT
K Y S Y=$P(^DVB(396.3,REQDA,0),U,2) X ^DD("DD")
S REQDT=Y
K Y
Q REQDT
;
RSCHAPT(LKDA,RSCHDT) ;** Update Appt record with reschedule data
S DA=+LKDA,DIE="^DVB(396.95,",DR=".03////^S X=RSCHDT;.07////1"
S:(+$P(^DVB(396.95,DA,0),U,4)=0&('$D(DVBAVTRQ))) DR=".02////^S X=RSCHDT;"_DR
S:($D(DVBAVTRQ)) DR=".04////^S X=1;.05////^S X=RSCHDT;"_DR
D ^DIE K DA,DIE,DR
I +$$ENHNC^DVBCUTA4=1 DO
.N REQDT,SAVY
.S:$D(Y) SAVY=Y
.S REQDT=$$GETDTE($P(^DVB(396.95,LKDA,0),U,6)) ;**Set REQDT
.S:$D(SAVY) Y=SAVY
.S DIR("A",1)=" "
.S DIR("A",2)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
.S DIR("A",3)=" "
.S DIR(0)="FAO^1:1",DIR("A")="Hit any key to continue." D ^DIR K DIR,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCMKLK 3854 printed Apr 09, 2024@20:56:03 Page 2
DVBCMKLK ;ALB/GTS-AMIE C&P APPT EVENT DRIVER-LINK RTN ; 10/20/94 4:00 PM
+1 ;;2.7;AMIE;;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 ;
EN ;** Link C&P appointment to 2507
+1 ;**DVBASTAT used in REQARY^DVBCUTL5
SET DVBADFN=DFN
SET DVBASTAT="P"
+2 ;
+3 ;**If user entered from AMIE Scheduling, only prompted if enhanced
+4 ;** dialogue turned on and is needed
+5 ;** QUIT on next line if from DVBCSCHD
+6 ;*DVBCSCHD
IF $DATA(DVBASDRT)
SET DVBADA=REQDA
DO LINKAPPT^DVBCMKL2
DO KVARS
QUIT
+7 SET (DVBADA,DVBASDPR)=""
+8 ;**Set up ^TMP of AMIE 2507's
DO REQARY^DVBCUTL5
+9 IF +DVBACNT>0
Begin DoDot:1
+10 ;**Auto select 2507 if only one exists
IF +DVBACNT=1
Begin DoDot:2
+11 SET (DVBADT,DVBADA,DVBAORD)=""
+12 SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
+13 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
+14 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
End DoDot:2
+15 ;**If more than one 2507 exists, user select
IF +DVBACNT>1
Begin DoDot:2
+16 ;**Select a 2507 from ^TMP
DO REQSEL^DVBCUTL5
+17 IF (+Y'>0)!($DATA(DVBAOUT))
SET DVBADA=""
+18 ;**Y is selected 2507 val returned from ^DIR
if +Y>0
SET DVBASEL=+Y
+19 ;**Find selected 2507 DA (Returned in DVBADA)
if +Y>0
DO FINDDA^DVBCUTL5
End DoDot:2
+20 KILL ^TMP("DVBC",$JOB)
+21 ;**Write warning
IF '$DATA(^DVB(396.3,+DVBADA,0))
IF (+$$ENHNC^DVBCUTA4=1)
Begin DoDot:2
+22 SET DIR("A",1)="You have not selected a 2507 request to link the C&P appointment to."
+23 SET DIR("A",2)="The appointment should be linked with the AMIE/C&P Appointment Link"
+24 SET DIR("A",3)=" Management Option to ensure proper processing time calculation for this 2507"
+25 SET DIR("A",4)=" in the event of a veteran cancellation."
+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:2
+28 ;**If 2507, link appt
IF $DATA(^DVB(396.3,+DVBADA,0))
DO LINKAPPT^DVBCMKL2
End DoDot:1
+29 ;**Write Warning
IF +DVBACNT'>0
IF (+$$ENHNC^DVBCUTA4=1)
Begin DoDot:1
+30 SET DIR("A",1)="You have made a C&P appointment for a patient who has no pending 2507 request!"
+31 SET DIR("A",2)=" "
+32 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit any key to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:1
+33 QUIT
+34 ;
KVARS ;** Kill variables used by scheduling protocol
+1 KILL DVBAMORE,DVBALP,DVBAOUT,DVBADTOT,DVBASDPR,DVBASEL
+2 KILL DVBAPNAM,DVBADA,DVBADFN,DVBASTAT,DVBADT,DVBAORD,DVBACNT
+3 KILL ^TMP("DVBC",$JOB),Y,DVBAYANS,DVBALKRC,DVBARSAP
+4 QUIT
+5 ;
CRTREC ;** Add a record to file 396.95 (Appt Tracking)
+1 KILL DD,DO
+2 SET DVBAADT=$PIECE(SDATA,U,3)
+3 SET DIC="^DVB(396.95,"
SET X=DVBAADT
SET DIC(0)="LX"
SET DLAYGO="396.95"
+4 SET DIC("DR")=".02////^S X=DVBAADT;.03////^S X=DVBAADT;"
+5 SET DIC("DR")=DIC("DR")_".04////^S X=0;.06////^S X=DVBADA;"
+6 SET DIC("DR")=DIC("DR")_".07////^S X=1"
+7 DO FILE^DICN
KILL DIC,X,DLAYGO,DVBAADT
+8 IF +$$ENHNC^DVBCUTA4=1
Begin DoDot:1
+9 NEW REQDT,SAVY
+10 if $DATA(Y)
SET SAVY=Y
+11 ;**Set REQDT
SET REQDT=$$GETDTE(DVBADA)
+12 if $DATA(SAVY)
SET Y=SAVY
+13 SET DIR("A",1)=" "
+14 SET DIR("A",2)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
+15 SET DIR("A",3)=" "
+16 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit any key to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:1
+17 QUIT
+18 ;
GETDTE(REQDA) ;** Get the request dte
+1 NEW REQDT
+2 KILL Y
SET Y=$PIECE(^DVB(396.3,REQDA,0),U,2)
XECUTE ^DD("DD")
+3 SET REQDT=Y
+4 KILL Y
+5 QUIT REQDT
+6 ;
RSCHAPT(LKDA,RSCHDT) ;** Update Appt record with reschedule data
+1 SET DA=+LKDA
SET DIE="^DVB(396.95,"
SET DR=".03////^S X=RSCHDT;.07////1"
+2 if (+$PIECE(^DVB(396.95,DA,0),U,4)=0&('$DATA(DVBAVTRQ)))
SET DR=".02////^S X=RSCHDT;"_DR
+3 if ($DATA(DVBAVTRQ))
SET DR=".04////^S X=1;.05////^S X=RSCHDT;"_DR
+4 DO ^DIE
KILL DA,DIE,DR
+5 IF +$$ENHNC^DVBCUTA4=1
Begin DoDot:1
+6 NEW REQDT,SAVY
+7 if $DATA(Y)
SET SAVY=Y
+8 ;**Set REQDT
SET REQDT=$$GETDTE($PIECE(^DVB(396.95,LKDA,0),U,6))
+9 if $DATA(SAVY)
SET Y=SAVY
+10 SET DIR("A",1)=" "
+11 SET DIR("A",2)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
+12 SET DIR("A",3)=" "
+13 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit any key to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:1
+14 QUIT
