DVBCLKTL.m

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 ---DVBCLKTL   4277     printed  Mar 13, 2025@20:49:21                                                                                                                                                                                                    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