DVBCLKTL ;ALB/GTS-AMIE C&P APPT LINK MNGT ROUTINE ; 10/20/94 10:30 PM
;;2.7;AMIE;**1**;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 ;** Main entry point
K ^TMP("DVBC",$J)
D HOME^%ZIS
K DVBASUPR
S:$D(^XUSEC("DVBA C SUPERVISOR",DUZ)) DVBASUPR=""
;** Select a C&P patient
F D HDR S DVBADFN=$$REQPAT^DVBCUTL5 D:+DVBADFN>0 MAINPROC Q:+DVBADFN'>0
K DVBASUPR,DVBADFN
Q
;
MAINPROC ;
D CPPATARY^DVBCUTL5(DVBADFN) ;**^TMP - array of 2507's for patient
I +DVBACNT=1 D AUTO2507 ;**S/W select the 2507 if only one exists
I +DVBACNT>1 D USEL2507 ;**More than 1 2507 exists, user selects
S:'$D(DVBADA) DVBADA=""
I '$D(^DVB(396.3,+DVBADA,0)) D NO2507^DVBCUTL5 ;**No 2507 sel'd, error
;
;** If 2507 selected, allow link adjustment
I $D(^DVB(396.3,+DVBADA,0)) DO ;**Output current appointments
.D EXMDISP^DVBCUTL6(DVBADA) ;**Display the exams
.S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue with appointment display."
.S DIR("A",1)=" " D ^DIR K DIR,X,Y
.F Q:($D(DVBAOUT)) DO
..D APPTSEL^DVBCUTL6($P(^DVB(396.3,DVBADA,0),U,1),1,DVBADA,$P(^DVB(396.3,DVBADA,0),U,5))
..I '$D(^TMP("DVBC",$J,2)),(DVBAAPT="") DO ;**No C&P appt's
...D:'$D(DVBAOUT) NOAPTERR^DVBCLKT2
..I '$D(DVBAAPT),($D(^TMP("DVBC",$J,2))) DO ;**No appt selected
...D:'$D(DVBAOUT) APPTERR^DVBCLKT2
..I $D(DVBAAPT),($D(^TMP("DVBC",$J,2))&(DVBAAPT="")) DO
...D:'$D(DVBAOUT) APPTERR^DVBCLKT2
..I $D(DVBAAPT),(DVBAAPT'="") DO
...K DVBADEL
...I $D(DVBASUPR),($D(^DVB(396.95,"AB",+DVBADA,$P(DVBAAPT,U,4)))) D DELCK^DVBCLKT2 DO
....I $D(DVBADEL) D DODEL^DVBCLKT2
...I '$D(DVBASUPR),($D(^DVB(396.95,"AB",+DVBADA,$P(DVBAAPT,U,4)))) DO DELERR^DVBCLKT2
...I '$D(^DVB(396.95,"AB",+DVBADA,$P(DVBAAPT,U,4))),('$D(DVBADEL)) D LINKPROC
..K DVBAMORE,DVBALP,DVBADT,DVBAORD,DVBASEL,DVBAAPT
..K APPTSTAT,APPTNODE,DVBALKDA,DVBCADLK,DVBCOLAP,DVBADEL
K ^TMP("DVBC",$J),DVBAOUT,DVBADTOT,DVBAPNAM,DVBADA
Q
;
AUTO2507 ;If only 1 2507, select it
;** DVBADA is the IEN of the selected 2507 request
N DVBADT,DVBAORD
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))
K ^TMP("DVBC",$J)
Q
;
LINKPROC ;Link appt to 2507
D LNKQS^DVBCLKT2 ;**Add link or modify existing link
K DVBCADLK S:+Y=0 DVBCADLK="" S DVBAYVAL=Y K Y
N DVBAOUT S:$D(DTOUT) DVBAOUT=""
;
;** If Appt, either add to 396.95 or modify an existing link
;** APPTNODE and APPTSTAT from 'S' node of appt selected to link
I $D(DVBCADLK),(DVBAYVAL'="^"),('$D(DVBAOUT)) DO ;**Add Link
.D STATCK^DVBCUTL7($P(DVBAAPT,U,4),DVBADFN) ;**Set APPTNODE,APPTSTAT
.S SAVESTAT=APPTSTAT
.I SAVESTAT["A" D ATRBCK^DVBCUTL7,ADDLK^DVBCUTL8 ;**Link lost: Auto-rbk
.I SAVESTAT'["A" D NOAUTO^DVBCUTL7,ADDLK^DVBCUTL8 ;**Link lost: non-auto
I '$D(DVBCADLK),(DVBAYVAL'="^"),('$D(DVBAOUT)) DO ;**Rebook Link
.S DVBAOLDA=$$SELLNK^DVBCUTL8(DVBADA)
.I +DVBAOLDA'>0,('$D(DVBANOLK)) D ERRMESS^DVBCLKT2
.I +DVBAOLDA>0 DO
..S OLDSTAT=$P(^DPT(DVBADFN,"S",$P(^DVB(396.95,DVBAOLDA,0),U,3),0),U,2)
..I OLDSTAT["P"!(OLDSTAT["N"&(OLDSTAT'="NT")) DO
...S ^TMP("DVBC",$J,"VETERAN CANCELLATION")=1
...S ^TMP("DVBC",$J,"VETERAN REQ APPT DATE")=$P(DVBAAPT,U,4)
..D STATCK^DVBCUTL7($P(DVBAAPT,U,4),DVBADFN) ;**Set APPTNODE,APPTSTAT
..S SAVESTAT=APPTSTAT ;**APPTNODE,APPTSTAT used in subroutines
..I SAVESTAT["A" D ATRBCK^DVBCUTL7,FIXLK^DVBCUTL8 ;**Link lost:Auto-rbk
..I SAVESTAT'["A" D NOAUTO^DVBCUTL7,FIXLK^DVBCUTL8 ;**Link lost:non-auto
K SAVESTAT,OLDSTAT,DVBAYVAL,DVBANOLK
Q
;
USEL2507 ;**User select 2507
D REQSEL^DVBCUTL5 ;**Select 2507 from ^TMP
I (+Y'>0)!($D(DVBAOUT)) S DVBADA=""
S:+Y>0 DVBASEL=+Y ;**Y selected 2507 value returned from ^DIR
D:+Y>0 FINDDA^DVBCUTL5 ;**Find selected 2507 DA (Return DVBADA)
K ^TMP("DVBC",$J)
Q
;
HDR ;** Veteran selection header
W @IOF,!!,?18,"AMIE/C&P Appointment Link Management",!!
I $D(DVBASUPR) W !,"As a Supervisor, you may remove 2507 appointment links",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCLKTL 4277 printed Dec 13, 2024@01:44:39 Page 2
DVBCLKTL ;ALB/GTS-AMIE C&P APPT LINK MNGT ROUTINE ; 10/20/94 10:30 PM
+1 ;;2.7;AMIE;**1**;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 ;** Main entry point
+1 KILL ^TMP("DVBC",$JOB)
+2 DO HOME^%ZIS
+3 KILL DVBASUPR
+4 if $DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))
SET DVBASUPR=""
+5 ;** Select a C&P patient
+6 FOR
DO HDR
SET DVBADFN=$$REQPAT^DVBCUTL5
if +DVBADFN>0
DO MAINPROC
if +DVBADFN'>0
QUIT
+7 KILL DVBASUPR,DVBADFN
+8 QUIT
+9 ;
MAINPROC ;
+1 ;**^TMP - array of 2507's for patient
DO CPPATARY^DVBCUTL5(DVBADFN)
+2 ;**S/W select the 2507 if only one exists
IF +DVBACNT=1
DO AUTO2507
+3 ;**More than 1 2507 exists, user selects
IF +DVBACNT>1
DO USEL2507
+4 if '$DATA(DVBADA)
SET DVBADA=""
+5 ;**No 2507 sel'd, error
IF '$DATA(^DVB(396.3,+DVBADA,0))
DO NO2507^DVBCUTL5
+6 ;
+7 ;** If 2507 selected, allow link adjustment
+8 ;**Output current appointments
IF $DATA(^DVB(396.3,+DVBADA,0))
Begin DoDot:1
+9 ;**Display the exams
DO EXMDISP^DVBCUTL6(DVBADA)
+10 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue with appointment display."
+11 SET DIR("A",1)=" "
DO ^DIR
KILL DIR,X,Y
+12 FOR
if ($DATA(DVBAOUT))
QUIT
Begin DoDot:2
+13 DO APPTSEL^DVBCUTL6($PIECE(^DVB(396.3,DVBADA,0),U,1),1,DVBADA,$PIECE(^DVB(396.3,DVBADA,0),U,5))
+14 ;**No C&P appt's
IF '$DATA(^TMP("DVBC",$JOB,2))
IF (DVBAAPT="")
Begin DoDot:3
+15 if '$DATA(DVBAOUT)
DO NOAPTERR^DVBCLKT2
End DoDot:3
+16 ;**No appt selected
IF '$DATA(DVBAAPT)
IF ($DATA(^TMP("DVBC",$JOB,2)))
Begin DoDot:3
+17 if '$DATA(DVBAOUT)
DO APPTERR^DVBCLKT2
End DoDot:3
+18 IF $DATA(DVBAAPT)
IF ($DATA(^TMP("DVBC",$JOB,2))&(DVBAAPT=""))
Begin DoDot:3
+19 if '$DATA(DVBAOUT)
DO APPTERR^DVBCLKT2
End DoDot:3
+20 IF $DATA(DVBAAPT)
IF (DVBAAPT'="")
Begin DoDot:3
+21 KILL DVBADEL
+22 IF $DATA(DVBASUPR)
IF ($DATA(^DVB(396.95,"AB",+DVBADA,$PIECE(DVBAAPT,U,4))))
DO DELCK^DVBCLKT2
Begin DoDot:4
+23 IF $DATA(DVBADEL)
DO DODEL^DVBCLKT2
End DoDot:4
+24 IF '$DATA(DVBASUPR)
IF ($DATA(^DVB(396.95,"AB",+DVBADA,$PIECE(DVBAAPT,U,4))))
DO DELERR^DVBCLKT2
+25 IF '$DATA(^DVB(396.95,"AB",+DVBADA,$PIECE(DVBAAPT,U,4)))
IF ('$DATA(DVBADEL))
DO LINKPROC
End DoDot:3
+26 KILL DVBAMORE,DVBALP,DVBADT,DVBAORD,DVBASEL,DVBAAPT
+27 KILL APPTSTAT,APPTNODE,DVBALKDA,DVBCADLK,DVBCOLAP,DVBADEL
End DoDot:2
End DoDot:1
+28 KILL ^TMP("DVBC",$JOB),DVBAOUT,DVBADTOT,DVBAPNAM,DVBADA
+29 QUIT
+30 ;
AUTO2507 ;If only 1 2507, select it
+1 ;** DVBADA is the IEN of the selected 2507 request
+2 NEW DVBADT,DVBAORD
+3 SET (DVBADT,DVBADA,DVBAORD)=""
+4 SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
+5 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
+6 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
+7 KILL ^TMP("DVBC",$JOB)
+8 QUIT
+9 ;
LINKPROC ;Link appt to 2507
+1 ;**Add link or modify existing link
DO LNKQS^DVBCLKT2
+2 KILL DVBCADLK
if +Y=0
SET DVBCADLK=""
SET DVBAYVAL=Y
KILL Y
+3 NEW DVBAOUT
if $DATA(DTOUT)
SET DVBAOUT=""
+4 ;
+5 ;** If Appt, either add to 396.95 or modify an existing link
+6 ;** APPTNODE and APPTSTAT from 'S' node of appt selected to link
+7 ;**Add Link
IF $DATA(DVBCADLK)
IF (DVBAYVAL'="^")
IF ('$DATA(DVBAOUT))
Begin DoDot:1
+8 ;**Set APPTNODE,APPTSTAT
DO STATCK^DVBCUTL7($PIECE(DVBAAPT,U,4),DVBADFN)
+9 SET SAVESTAT=APPTSTAT
+10 ;**Link lost: Auto-rbk
IF SAVESTAT["A"
DO ATRBCK^DVBCUTL7
DO ADDLK^DVBCUTL8
+11 ;**Link lost: non-auto
IF SAVESTAT'["A"
DO NOAUTO^DVBCUTL7
DO ADDLK^DVBCUTL8
End DoDot:1
+12 ;**Rebook Link
IF '$DATA(DVBCADLK)
IF (DVBAYVAL'="^")
IF ('$DATA(DVBAOUT))
Begin DoDot:1
+13 SET DVBAOLDA=$$SELLNK^DVBCUTL8(DVBADA)
+14 IF +DVBAOLDA'>0
IF ('$DATA(DVBANOLK))
DO ERRMESS^DVBCLKT2
+15 IF +DVBAOLDA>0
Begin DoDot:2
+16 SET OLDSTAT=$PIECE(^DPT(DVBADFN,"S",$PIECE(^DVB(396.95,DVBAOLDA,0),U,3),0),U,2)
+17 IF OLDSTAT["P"!(OLDSTAT["N"&(OLDSTAT'="NT"))
Begin DoDot:3
+18 SET ^TMP("DVBC",$JOB,"VETERAN CANCELLATION")=1
+19 SET ^TMP("DVBC",$JOB,"VETERAN REQ APPT DATE")=$PIECE(DVBAAPT,U,4)
End DoDot:3
+20 ;**Set APPTNODE,APPTSTAT
DO STATCK^DVBCUTL7($PIECE(DVBAAPT,U,4),DVBADFN)
+21 ;**APPTNODE,APPTSTAT used in subroutines
SET SAVESTAT=APPTSTAT
+22 ;**Link lost:Auto-rbk
IF SAVESTAT["A"
DO ATRBCK^DVBCUTL7
DO FIXLK^DVBCUTL8
+23 ;**Link lost:non-auto
IF SAVESTAT'["A"
DO NOAUTO^DVBCUTL7
DO FIXLK^DVBCUTL8
End DoDot:2
End DoDot:1
+24 KILL SAVESTAT,OLDSTAT,DVBAYVAL,DVBANOLK
+25 QUIT
+26 ;
USEL2507 ;**User select 2507
+1 ;**Select 2507 from ^TMP
DO REQSEL^DVBCUTL5
+2 IF (+Y'>0)!($DATA(DVBAOUT))
SET DVBADA=""
+3 ;**Y selected 2507 value returned from ^DIR
if +Y>0
SET DVBASEL=+Y
+4 ;**Find selected 2507 DA (Return DVBADA)
if +Y>0
DO FINDDA^DVBCUTL5
+5 KILL ^TMP("DVBC",$JOB)
+6 QUIT
+7 ;
HDR ;** Veteran selection header
+1 WRITE @IOF,!!,?18,"AMIE/C&P Appointment Link Management",!!
+2 IF $DATA(DVBASUPR)
WRITE !,"As a Supervisor, you may remove 2507 appointment links",!!
+3 QUIT
