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

DVBCMKLK.m

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