DVBCUTL5 ;ALB/GTS-AMIE C&P APPT LINK USER SEL RTNS ; 10/20/94 1:00 PM
;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
;
;** 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)
;
REQARY ;** Create Array of 2507's for veteran
;
;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
;** The following variables must be KILLed by the calling routine:
;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
;** DVBADT,DVBAORD
;** NOTE: DVBASTAT must be defined before REQARY entry
S DVBACNT=0
;
;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
;** exam on current 2507, Set ^TMP
F S DVBADA=$O(^DVB(396.3,"B",DVBADFN,DVBADA)) Q:DVBADA="" DO
.;AJF;Request Status conversion ;
.I $$RSTAT^DVBCUTL8($P(^DVB(396.3,DVBADA,0),U,18))=DVBASTAT DO
..S DVBAOPEN=$$OPENCHK(DVBADA) I +DVBAOPEN'>0 K DVBAOPEN
..I '$D(DVBASDPR)!($D(DVBASDPR)&($D(DVBAOPEN))) DO
...K DVBAOPEN
...S DVBADT=$P(^DVB(396.3,DVBADA,0),"^",2),DVBACNT=DVBACNT+1
...S ^TMP("DVBC",$J,9999999.999999-DVBADT,DVBADT,DVBADA)=""
Q
;
REQSEL ;** Select 2507
;
;** Loop ^TMP array, display 2507's in groups of 5
;** ^TMP subscripts:
;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
;** Request date int, Request DA)
W !!,"Select a 2507 request",!
S DVBAORD=""
S DVBAPNAM=$P(^DPT(DVBADFN,0),"^",1)
F DVBALP=1:1 S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) Q:DVBAORD="" DO
.S (DVBADT,DVBADA)=""
.S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
.S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
.K Y S Y=DVBADT X ^DD("DD")
.W !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
.S DVBAMORE=$O(^TMP("DVBC",$J,DVBAORD))
.I +DVBAMORE'>0 D SELREQ ;**No more entries
.I (+DVBAMORE>0)&(DVBALP#5=0) DO ;**More entries exist, 5 displayed
..W !,"ENTER '^' TO STOP, OR"
..D SELREQ
Q
;
FINDDA ;** Loop ^TMP, get 396.3 DA
F DVBALP=1:1:DVBASEL S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) DO
.S (DVBADT,DVBADA)=""
.S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
.S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
Q
;
SELREQ ;** Select 2507 from ^TMP
K DVBAOUT
S DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
S DIR("?")="Select a 2507 request by entering it's associated number"
S DIR("A")="CHOOSE 1-"_DVBALP_": " D ^DIR
I $D(DTOUT)!($D(DUOUT)) S DVBAORD="9999999.999999",DVBAOUT=""
I '$D(DTOUT)&('$D(DUOUT)) S:+Y>0 DVBAORD="9999999.999999"
S:$D(DTOUT) DVBADTOT=""
W !
K DTOUT,DUOUT,DIR
Q
;
OPENCHK(REQDA) ;** Check for open exam on 2507
N LPDA,QVAR
S LPDA=""
F S LPDA=$O(^DVB(396.4,"C",REQDA,LPDA)) Q:'LPDA!($D(QVAR)) DO
.I $P(^DVB(396.4,LPDA,0),U,4)="O" DO
..S:'$D(QVAR) QVAR=LPDA
S:'$D(QVAR) QVAR=""
Q +QVAR
;
REQPAT() ;** Select patient who has 2507's
S DIC(0)="AEMQ",DIC("A")="Select C&P Veteran Name: ",DIC="^DPT("
S DIC("S")="I $D(^DVB(396.3,""B"",+Y))" D ^DIC K DIC
Q +Y
;
CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
;
;** ^TMP array ordered newest to oldest
;** DVBACNT to be killed by calling routine
N REQDA,REQDT,REQ
S DVBACNT=0
S REQDA=""
F S REQDA=$O(^DVB(396.3,"B",DVBADFN,REQDA)) Q:REQDA="" DO
.S REQ=$G(^DVB(396.3,REQDA,0))
.;AJF;Request Status conversion ;changed "N" to 1
.I +$P(REQ,U,2)>0,($P(REQ,U,18)'=1) DO
..I $P(REQ,U,18)'="" DO
...S REQDT=$P(REQ,"^",2),DVBACNT=DVBACNT+1
...S ^TMP("DVBC",$J,9999999.999999-REQDT,REQDT,REQDA)=""
Q
;
NO2507 ;** 2507 not selected, error
S DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
S DIR("A",2)="This is required to continue processing with the AMIE link management option."
S DIR("A",3)=" "
S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
Q
;
SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
N DVBASPCV
S DVBASPCV=""
S:($D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))) DVBASPCV=$P(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
Q DVBASPCV
;
SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
Q $D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))
;
SDORGST() ;** Return value of SD Event originating process
N DVBAVAR
S DVBAVAR=""
Q $O(^TMP("SDEVT",$J,SDHDL,DVBAVAR))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL5 4436 printed Sep 23, 2025@19:25:18 Page 2
DVBCUTL5 ;ALB/GTS-AMIE C&P APPT LINK USER SEL RTNS ; 10/20/94 1:00 PM
+1 ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
+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 ;
REQARY ;** Create Array of 2507's for veteran
+1 ;
+2 ;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
+3 ;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
+4 ;** The following variables must be KILLed by the calling routine:
+5 ;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
+6 ;** DVBADT,DVBAORD
+7 ;** NOTE: DVBASTAT must be defined before REQARY entry
+8 SET DVBACNT=0
+9 ;
+10 ;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
+11 ;** exam on current 2507, Set ^TMP
+12 FOR
SET DVBADA=$ORDER(^DVB(396.3,"B",DVBADFN,DVBADA))
if DVBADA=""
QUIT
Begin DoDot:1
+13 ;AJF;Request Status conversion ;
+14 IF $$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,DVBADA,0),U,18))=DVBASTAT
Begin DoDot:2
+15 SET DVBAOPEN=$$OPENCHK(DVBADA)
IF +DVBAOPEN'>0
KILL DVBAOPEN
+16 IF '$DATA(DVBASDPR)!($DATA(DVBASDPR)&($DATA(DVBAOPEN)))
Begin DoDot:3
+17 KILL DVBAOPEN
+18 SET DVBADT=$PIECE(^DVB(396.3,DVBADA,0),"^",2)
SET DVBACNT=DVBACNT+1
+19 SET ^TMP("DVBC",$JOB,9999999.999999-DVBADT,DVBADT,DVBADA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
REQSEL ;** Select 2507
+1 ;
+2 ;** Loop ^TMP array, display 2507's in groups of 5
+3 ;** ^TMP subscripts:
+4 ;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
+5 ;** Request date int, Request DA)
+6 WRITE !!,"Select a 2507 request",!
+7 SET DVBAORD=""
+8 SET DVBAPNAM=$PIECE(^DPT(DVBADFN,0),"^",1)
+9 FOR DVBALP=1:1
SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
if DVBAORD=""
QUIT
Begin DoDot:1
+10 SET (DVBADT,DVBADA)=""
+11 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
+12 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
+13 KILL Y
SET Y=DVBADT
XECUTE ^DD("DD")
+14 WRITE !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
+15 SET DVBAMORE=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
+16 ;**No more entries
IF +DVBAMORE'>0
DO SELREQ
+17 ;**More entries exist, 5 displayed
IF (+DVBAMORE>0)&(DVBALP#5=0)
Begin DoDot:2
+18 WRITE !,"ENTER '^' TO STOP, OR"
+19 DO SELREQ
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
FINDDA ;** Loop ^TMP, get 396.3 DA
+1 FOR DVBALP=1:1:DVBASEL
SET DVBAORD=$ORDER(^TMP("DVBC",$JOB,DVBAORD))
Begin DoDot:1
+2 SET (DVBADT,DVBADA)=""
+3 SET DVBADT=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT))
+4 SET DVBADA=$ORDER(^TMP("DVBC",$JOB,DVBAORD,DVBADT,DVBADA))
End DoDot:1
+5 QUIT
+6 ;
SELREQ ;** Select 2507 from ^TMP
+1 KILL DVBAOUT
+2 SET DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
+3 SET DIR("?")="Select a 2507 request by entering it's associated number"
+4 SET DIR("A")="CHOOSE 1-"_DVBALP_": "
DO ^DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET DVBAORD="9999999.999999"
SET DVBAOUT=""
+6 IF '$DATA(DTOUT)&('$DATA(DUOUT))
if +Y>0
SET DVBAORD="9999999.999999"
+7 if $DATA(DTOUT)
SET DVBADTOT=""
+8 WRITE !
+9 KILL DTOUT,DUOUT,DIR
+10 QUIT
+11 ;
OPENCHK(REQDA) ;** Check for open exam on 2507
+1 NEW LPDA,QVAR
+2 SET LPDA=""
+3 FOR
SET LPDA=$ORDER(^DVB(396.4,"C",REQDA,LPDA))
if 'LPDA!($DATA(QVAR))
QUIT
Begin DoDot:1
+4 IF $PIECE(^DVB(396.4,LPDA,0),U,4)="O"
Begin DoDot:2
+5 if '$DATA(QVAR)
SET QVAR=LPDA
End DoDot:2
End DoDot:1
+6 if '$DATA(QVAR)
SET QVAR=""
+7 QUIT +QVAR
+8 ;
REQPAT() ;** Select patient who has 2507's
+1 SET DIC(0)="AEMQ"
SET DIC("A")="Select C&P Veteran Name: "
SET DIC="^DPT("
+2 SET DIC("S")="I $D(^DVB(396.3,""B"",+Y))"
DO ^DIC
KILL DIC
+3 QUIT +Y
+4 ;
CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
+1 ;
+2 ;** ^TMP array ordered newest to oldest
+3 ;** DVBACNT to be killed by calling routine
+4 NEW REQDA,REQDT,REQ
+5 SET DVBACNT=0
+6 SET REQDA=""
+7 FOR
SET REQDA=$ORDER(^DVB(396.3,"B",DVBADFN,REQDA))
if REQDA=""
QUIT
Begin DoDot:1
+8 SET REQ=$GET(^DVB(396.3,REQDA,0))
+9 ;AJF;Request Status conversion ;changed "N" to 1
+10 IF +$PIECE(REQ,U,2)>0
IF ($PIECE(REQ,U,18)'=1)
Begin DoDot:2
+11 IF $PIECE(REQ,U,18)'=""
Begin DoDot:3
+12 SET REQDT=$PIECE(REQ,"^",2)
SET DVBACNT=DVBACNT+1
+13 SET ^TMP("DVBC",$JOB,9999999.999999-REQDT,REQDT,REQDA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
NO2507 ;** 2507 not selected, error
+1 SET DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
+2 SET DIR("A",2)="This is required to continue processing with the AMIE link management option."
+3 SET DIR("A",3)=" "
+4 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue."
DO ^DIR
KILL DIR,X,Y
+5 QUIT
+6 ;
SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
+1 NEW DVBASPCV
+2 SET DVBASPCV=""
+3 if ($DATA(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER")))
SET DVBASPCV=$PIECE(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
+4 QUIT DVBASPCV
+5 ;
SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
+1 QUIT $DATA(^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,"AFTER"))
+2 ;
SDORGST() ;** Return value of SD Event originating process
+1 NEW DVBAVAR
+2 SET DVBAVAR=""
+3 QUIT $ORDER(^TMP("SDEVT",$JOB,SDHDL,DVBAVAR))
+4 ;
