DVBCUTL6 ;ALB/GTS-AMIE C&P APPT LINK DISPLAY SUBRTNS ; 10/20/94 1:45 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)
;
LKHDOUT ;** Link MGNT screen hdr
W @IOF
W "AMIE/C&P Appointment Link Management",!!,"Current appointment links"
W !,"Clinic",?32,"Date/Time",?51,"Status",!
Q
;
EXMOUT(LPDA) ;** Output exam
W !!,"Exam: ",$P(^DVB(396.6,$P(^DVB(396.4,LPDA,0),U,3),0),U,2)
W !,"Clinic",?32,"Date/Time",?49,"Status"
Q
;
EXMDISP(REQDA) ;** Output Open/Completed exams
D EXMHD
N DVBADA,DVBASTAT
S DVBADA=""
F S DVBADA=$O(^DVB(396.4,"C",REQDA,DVBADA)) Q:(DVBADA=""!($D(DTOUT)!$D(DUOUT))) DO
.I $D(^DVB(396.4,DVBADA,0)) DO
..S DVBASTAT=$P(^DVB(396.4,DVBADA,0),U,4)
..D EXAMLST^DVBCUTA4(DVBADA,DVBASTAT)
Q
;
EXMHD ;** Exam header
W @IOF
N DVBALN
S Y=$P(^DVB(396.3,REQDA,0),U,5)
X ^DD("DD")
W !!,"AMIE exams on 2507 request for: ",$P(^DPT($P(^DVB(396.3,REQDA,0),U,1),0),U,1)
W !,"2507 Request Date Reported to MAS: ",Y
S $P(DVBALN,"-",80)=""
W !,DVBALN
W !!,"Exam:",?40,"Status:"
K Y
Q
;
APPTSEL(DVBADFN,APPTTYPE,REQDA,STRTDT,ENDDT) ;Select appt
;** APPTTYPE = appt type to select
;** STRTDT,ENDDT = selected date range
;
;** APPTSEL creates ^TMP = appt's of APPTTYPE in date range
;** ^TMP=appt dte-ext ^ Clinic-ext ^ Status-ext ^ appt dte-int
W @IOF
N TMPDA
S STRTDT=STRTDT-.1,TMPDA=1
S:+STRTDT<0 STRTDT=0
S:'$D(ENDDT) ENDDT=""
S:ENDDT="" ENDDT=9999999
K STATUS,STATVAR
I $D(^DPT(DVBADFN,"S")) DO
.F S STRTDT=$O(^DPT(DVBADFN,"S",STRTDT)) Q:(STRTDT=""!(STRTDT>ENDDT)) DO
..I $P(^DPT(DVBADFN,"S",STRTDT,0),U,16)=APPTTYPE DO
...S TMPDA=TMPDA+1
...S DA=DVBADFN,DA(2.98)=STRTDT,DR="1900",DR(2.98)=".01",DIC=2
...S DIQ="DVBAARY" K ^UTILITY("DIQ",$J)
...D EN^DIQ1 K ^UTILITY("DIQ",$J)
...S Y=STRTDT X ^DD("DD")
...S STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
...S STATUS=$P(STATVAR,";",3)
...S ^TMP("DVBC",$J,TMPDA)=Y_"^"_DVBAARY(2.98,STRTDT,.01)_"^"_STATUS_"^"_STRTDT
...K DVBAARY(2.98),Y,STATUS,STATVAR
D ARYDISP
Q
;
ARYDISP ;** Display appts for selection
;** run APPTSEL before ARYDISP
;
;** DVBAAPT returned (= selected ^TMP node)
;
K DA,DR,DIC,DIQ
I '$D(DVBAMORE) N DVBAMORE
I '$D(TMPDA) N TMPDA
W !!!,"Select an appointment to link to the 2507 request",!
W !,?1,"1",?4,"Display Current C&P Appointment Links"
S ^TMP("DVBC",$J,1)=""
F TMPDA=2:1 Q:'$D(^TMP("DVBC",$J,TMPDA)) DO
.W !,?1,TMPDA,?4,$P(^TMP("DVBC",$J,TMPDA),U,1)
.W ?23,$E($P(^TMP("DVBC",$J,TMPDA),U,2),1,22)
.W:$D(^DVB(396.95,"AB",REQDA,$P(^TMP("DVBC",$J,TMPDA),U,4))) ?47,"*CL"
.W ?51,$E($P(^TMP("DVBC",$J,TMPDA),U,3),1,27)
.S DVBAMORE=$O(^TMP("DVBC",$J,TMPDA))
.I +DVBAMORE'>0 D SELAPT
.I (+DVBAMORE>0)&(TMPDA#5=0) D SELAPT
S DVBAAPT=""
I $D(Y) DO
.S DVBAAPT=^TMP("DVBC",$J,+Y)
.K ^TMP("DVBC",$J,+Y)
Q
;
SELAPT ;** Select Appt
W !
S DIR("A",1)="ENTER '^' TO STOP, OR"
S DIR("A")="CHOOSE 1-"_TMPDA_": "
S DIR(0)="NOA^1:"_TMPDA_"^I X["".""!('$D(^TMP(""DVBC"",$J,+Y))) K X"
S DIR("?",1)="Select an appointment by entering its associated number."
S DIR("?",2)=" *CL following Clinic means the appointment date is the"
S DIR("?",2)=DIR("?",2)_" Current Date for"
S DIR("?",3)=" an existing link."
S DIR("?",4)="Enter '1' to see the current links to this 2507."
S DIR("?")="Select from the numbers listed."
D ^DIR
I $D(DTOUT)!($D(DUOUT)) S TMPDA=9999,DVBAOUT=""
S:+Y>1 TMPDA=9999
W:+Y'>0 !
I +Y=1 DO
.W @IOF
.D LNKARY^DVBCUTA3(REQDA,DVBADFN)
.D LNKLIST^DVBCUTA3
.S:TMPDA'>5 TMPDA=TMPDA-1
.S:(TMPDA>5&(TMPDA#5=0)) TMPDA=TMPDA-5
.S:(TMPDA>5&(TMPDA#5'=0)) TMPDA=TMPDA-1
.D REFRSH^DVBCUTA4(TMPDA)
.K Y
I $D(Y),(+Y'>0) K Y
K DIR,DTOUT,DUOUT
Q
;
LINKINF(REQDA,CURRAPT) ;** Display Link info
N LINKNODE,LINKDA,INITDTE,ORIGDTE,VETDTE
S LINKDA=""
S LINKDA=$O(^DVB(396.95,"AB",REQDA,CURRAPT,LINKDA))
S LINKNODE=^DVB(396.95,LINKDA,0)
S INITDTE=$P(LINKNODE,U,1)
S ORIGDTE=$P(LINKNODE,U,2)
S VETDTE=$P(LINKNODE,U,5)
I INITDTE'=CURRAPT DO
.K Y
.S Y=INITDTE
.X ^DD("DD")
.W !,"Initial Appt: ",?36,Y
I ORIGDTE'=CURRAPT DO
.K Y
.S Y=ORIGDTE
.X ^DD("DD")
.W !,"Clock Stop Appt: ",?36,Y
I VETDTE'=""&(VETDTE'=CURRAPT) DO
.K Y
.S Y=VETDTE
.X ^DD("DD")
.W !,"Last Veteran requested Appointment: ",?36,Y
K Y
S Y=CURRAPT
X ^DD("DD")
W !,"Current Appt: ",?36,Y
K Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL6 4693 printed Sep 23, 2025@19:25:19 Page 2
DVBCUTL6 ;ALB/GTS-AMIE C&P APPT LINK DISPLAY SUBRTNS ; 10/20/94 1:45 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 ;
LKHDOUT ;** Link MGNT screen hdr
+1 WRITE @IOF
+2 WRITE "AMIE/C&P Appointment Link Management",!!,"Current appointment links"
+3 WRITE !,"Clinic",?32,"Date/Time",?51,"Status",!
+4 QUIT
+5 ;
EXMOUT(LPDA) ;** Output exam
+1 WRITE !!,"Exam: ",$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,LPDA,0),U,3),0),U,2)
+2 WRITE !,"Clinic",?32,"Date/Time",?49,"Status"
+3 QUIT
+4 ;
EXMDISP(REQDA) ;** Output Open/Completed exams
+1 DO EXMHD
+2 NEW DVBADA,DVBASTAT
+3 SET DVBADA=""
+4 FOR
SET DVBADA=$ORDER(^DVB(396.4,"C",REQDA,DVBADA))
if (DVBADA=""!($DATA(DTOUT)!$DATA(DUOUT)))
QUIT
Begin DoDot:1
+5 IF $DATA(^DVB(396.4,DVBADA,0))
Begin DoDot:2
+6 SET DVBASTAT=$PIECE(^DVB(396.4,DVBADA,0),U,4)
+7 DO EXAMLST^DVBCUTA4(DVBADA,DVBASTAT)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
EXMHD ;** Exam header
+1 WRITE @IOF
+2 NEW DVBALN
+3 SET Y=$PIECE(^DVB(396.3,REQDA,0),U,5)
+4 XECUTE ^DD("DD")
+5 WRITE !!,"AMIE exams on 2507 request for: ",$PIECE(^DPT($PIECE(^DVB(396.3,REQDA,0),U,1),0),U,1)
+6 WRITE !,"2507 Request Date Reported to MAS: ",Y
+7 SET $PIECE(DVBALN,"-",80)=""
+8 WRITE !,DVBALN
+9 WRITE !!,"Exam:",?40,"Status:"
+10 KILL Y
+11 QUIT
+12 ;
APPTSEL(DVBADFN,APPTTYPE,REQDA,STRTDT,ENDDT) ;Select appt
+1 ;** APPTTYPE = appt type to select
+2 ;** STRTDT,ENDDT = selected date range
+3 ;
+4 ;** APPTSEL creates ^TMP = appt's of APPTTYPE in date range
+5 ;** ^TMP=appt dte-ext ^ Clinic-ext ^ Status-ext ^ appt dte-int
+6 WRITE @IOF
+7 NEW TMPDA
+8 SET STRTDT=STRTDT-.1
SET TMPDA=1
+9 if +STRTDT<0
SET STRTDT=0
+10 if '$DATA(ENDDT)
SET ENDDT=""
+11 if ENDDT=""
SET ENDDT=9999999
+12 KILL STATUS,STATVAR
+13 IF $DATA(^DPT(DVBADFN,"S"))
Begin DoDot:1
+14 FOR
SET STRTDT=$ORDER(^DPT(DVBADFN,"S",STRTDT))
if (STRTDT=""!(STRTDT>ENDDT))
QUIT
Begin DoDot:2
+15 IF $PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,16)=APPTTYPE
Begin DoDot:3
+16 SET TMPDA=TMPDA+1
+17 SET DA=DVBADFN
SET DA(2.98)=STRTDT
SET DR="1900"
SET DR(2.98)=".01"
SET DIC=2
+18 SET DIQ="DVBAARY"
KILL ^UTILITY("DIQ",$JOB)
+19 DO EN^DIQ1
KILL ^UTILITY("DIQ",$JOB)
+20 SET Y=STRTDT
XECUTE ^DD("DD")
+21 SET STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
+22 SET STATUS=$PIECE(STATVAR,";",3)
+23 SET ^TMP("DVBC",$JOB,TMPDA)=Y_"^"_DVBAARY(2.98,STRTDT,.01)_"^"_STATUS_"^"_STRTDT
+24 KILL DVBAARY(2.98),Y,STATUS,STATVAR
End DoDot:3
End DoDot:2
End DoDot:1
+25 DO ARYDISP
+26 QUIT
+27 ;
ARYDISP ;** Display appts for selection
+1 ;** run APPTSEL before ARYDISP
+2 ;
+3 ;** DVBAAPT returned (= selected ^TMP node)
+4 ;
+5 KILL DA,DR,DIC,DIQ
+6 IF '$DATA(DVBAMORE)
NEW DVBAMORE
+7 IF '$DATA(TMPDA)
NEW TMPDA
+8 WRITE !!!,"Select an appointment to link to the 2507 request",!
+9 WRITE !,?1,"1",?4,"Display Current C&P Appointment Links"
+10 SET ^TMP("DVBC",$JOB,1)=""
+11 FOR TMPDA=2:1
if '$DATA(^TMP("DVBC",$JOB,TMPDA))
QUIT
Begin DoDot:1
+12 WRITE !,?1,TMPDA,?4,$PIECE(^TMP("DVBC",$JOB,TMPDA),U,1)
+13 WRITE ?23,$EXTRACT($PIECE(^TMP("DVBC",$JOB,TMPDA),U,2),1,22)
+14 if $DATA(^DVB(396.95,"AB",REQDA,$PIECE(^TMP("DVBC",$JOB,TMPDA),U,4)))
WRITE ?47,"*CL"
+15 WRITE ?51,$EXTRACT($PIECE(^TMP("DVBC",$JOB,TMPDA),U,3),1,27)
+16 SET DVBAMORE=$ORDER(^TMP("DVBC",$JOB,TMPDA))
+17 IF +DVBAMORE'>0
DO SELAPT
+18 IF (+DVBAMORE>0)&(TMPDA#5=0)
DO SELAPT
End DoDot:1
+19 SET DVBAAPT=""
+20 IF $DATA(Y)
Begin DoDot:1
+21 SET DVBAAPT=^TMP("DVBC",$JOB,+Y)
+22 KILL ^TMP("DVBC",$JOB,+Y)
End DoDot:1
+23 QUIT
+24 ;
SELAPT ;** Select Appt
+1 WRITE !
+2 SET DIR("A",1)="ENTER '^' TO STOP, OR"
+3 SET DIR("A")="CHOOSE 1-"_TMPDA_": "
+4 SET DIR(0)="NOA^1:"_TMPDA_"^I X["".""!('$D(^TMP(""DVBC"",$J,+Y))) K X"
+5 SET DIR("?",1)="Select an appointment by entering its associated number."
+6 SET DIR("?",2)=" *CL following Clinic means the appointment date is the"
+7 SET DIR("?",2)=DIR("?",2)_" Current Date for"
+8 SET DIR("?",3)=" an existing link."
+9 SET DIR("?",4)="Enter '1' to see the current links to this 2507."
+10 SET DIR("?")="Select from the numbers listed."
+11 DO ^DIR
+12 IF $DATA(DTOUT)!($DATA(DUOUT))
SET TMPDA=9999
SET DVBAOUT=""
+13 if +Y>1
SET TMPDA=9999
+14 if +Y'>0
WRITE !
+15 IF +Y=1
Begin DoDot:1
+16 WRITE @IOF
+17 DO LNKARY^DVBCUTA3(REQDA,DVBADFN)
+18 DO LNKLIST^DVBCUTA3
+19 if TMPDA'>5
SET TMPDA=TMPDA-1
+20 if (TMPDA>5&(TMPDA#5=0))
SET TMPDA=TMPDA-5
+21 if (TMPDA>5&(TMPDA#5'=0))
SET TMPDA=TMPDA-1
+22 DO REFRSH^DVBCUTA4(TMPDA)
+23 KILL Y
End DoDot:1
+24 IF $DATA(Y)
IF (+Y'>0)
KILL Y
+25 KILL DIR,DTOUT,DUOUT
+26 QUIT
+27 ;
LINKINF(REQDA,CURRAPT) ;** Display Link info
+1 NEW LINKNODE,LINKDA,INITDTE,ORIGDTE,VETDTE
+2 SET LINKDA=""
+3 SET LINKDA=$ORDER(^DVB(396.95,"AB",REQDA,CURRAPT,LINKDA))
+4 SET LINKNODE=^DVB(396.95,LINKDA,0)
+5 SET INITDTE=$PIECE(LINKNODE,U,1)
+6 SET ORIGDTE=$PIECE(LINKNODE,U,2)
+7 SET VETDTE=$PIECE(LINKNODE,U,5)
+8 IF INITDTE'=CURRAPT
Begin DoDot:1
+9 KILL Y
+10 SET Y=INITDTE
+11 XECUTE ^DD("DD")
+12 WRITE !,"Initial Appt: ",?36,Y
End DoDot:1
+13 IF ORIGDTE'=CURRAPT
Begin DoDot:1
+14 KILL Y
+15 SET Y=ORIGDTE
+16 XECUTE ^DD("DD")
+17 WRITE !,"Clock Stop Appt: ",?36,Y
End DoDot:1
+18 IF VETDTE'=""&(VETDTE'=CURRAPT)
Begin DoDot:1
+19 KILL Y
+20 SET Y=VETDTE
+21 XECUTE ^DD("DD")
+22 WRITE !,"Last Veteran requested Appointment: ",?36,Y
End DoDot:1
+23 KILL Y
+24 SET Y=CURRAPT
+25 XECUTE ^DD("DD")
+26 WRITE !,"Current Appt: ",?36,Y
+27 KILL Y
+28 QUIT
