DVBAAPLK ;ALB/GTS-557/THM-FORMATTING ROUTINE FOR APPTS (DVBAREN1) ;21 JUL 89
;;2.7;AMIE;;Apr 10, 1995
S XDD=^DD("DD")
;
EN1 W @IOF,!,"Non-admitted Veteran Date Selection",!
S DISTYPE="" W !!,?5,"Select from:",!!,?10,"(A)ppointment date",!
W ?10,"(D)isposition log-in date",!
W ?10,"(S)top code",!!
W !,"Enter selection: A// " R DISTYPE:DTIME I '$T S Y=-1,AROWOUT=1,DVBAQUIT=1 Q
I DISTYPE["?" G CHECK
I DISTYPE="" S DISTYPE="A"
I DISTYPE=U S Y=-1,AROWOUT=1 Q
I DISTYPE'?1"A"&(DISTYPE'?1"D")&(DISTYPE'?1"S") W !!,*7,"Must be A, D, or S",!! H 2 G EN1
W @IOF,!,$S(DISTYPE="A":"Appointment",DISTYPE="D":"Disposition Log-in",1:"Stop code")_" Date Selection for "_PNAM,!!!
D @DISTYPE K APPT,DISTYPE,K,ANS,^TMP("DVBA",$J),ANS1,DIC,I,J,X
Q
;
A S Y=-1 I '$D(^DPT(DFN,"S")) W !!,*7,"This veteran has no appointments on file.",!! S OUT=1 H 2 Q
W !!,"Choose from these appointment dates: " W !!
S ANS="" S K=0 F I=0:0 S I=$O(^DPT(DFN,"S",I)) Q:I="" S J=$P(^(I,0),"^",1) S Y=I X XDD S K=K+1 S ^TMP("DVBA",$J,K)=I D WRITE
I ANS="" D SELECT
I ANS="" S OUT=1 Q
I ANS]"",ANS'="^" S Y=^TMP("DVBA",$J,ANS) K ^TMP("DVBA",$J)
I ANS="^"!(ANS']"") S AROWOUT=1,Y=-1 K APPT Q
S APPDT=$P(Y,".",1),Y=-1
Q
WRITE W ?5,K_". ",?10,$P(Y,"@",1),?25,$P(Y,"@",2,99),?35,$S($D(^SC(J,0)):$P(^SC(J,0),U,1),1:"Unknown clinic"),! I $Y#11=0 D SELECT W !! S:ANS]"" I=9999999.999 Q:ANS]""
Q
SELECT S ANS="" W !,"Select 1 to "_K_",",!," [RETURN] to continue to search,",!," OR ""^"" to QUIT. " R ANS:DTIME Q:ANS=U!(ANS="")!('$T)
I ANS'?1.3N!(ANS<1)!(ANS>K) W !!,*7,"Must be between 1 and "_K_" ,RETURN, or ""^""",!! H 2 G SELECT
Q
;
D I '$D(^DPT(DFN,"DIS")) W !!,*7,"This veteran has no log-ins on file.",!! H 2 S Y=-1,OUT=1 Q
S DIC="^DPT(DFN,""DIS"",",DIC(0)="AEQM",DIC("A")="Enter Disposition Log-in time: " D ^DIC I X=""!(X=U) S Y=-1,AROWOUT=1 Q
S APPDT=$E($P(Y,U,2),1,7),Y=-1
Q
;
S I '$D(^SDV("ADT",DFN)) W !!,*7,"This veteran has no stop codes on file.",!! H 2 S OUT=1,Y=-1 Q
S DIC="^SDV(",DIC(0)="EQM",X=$P(^DPT(DFN,0),U,9) D ^DIC I Y=-1 S OUT=1 Q
S APPDT=$E($P(Y,U,2),1,7),Y=-1
Q
;
CHECK ;check what choices are available
W @IOF,!!,"The following choices are available for this Veteran:",!!
I $D(^DPT(DFN,"S")) W "Appointments",!
I $D(^SDV("ADT",DFN)) W "Stop codes",!
I $D(^DPT(DFN,"DIS")) W "Disposition Log-in dates",!
W !!,"Press [RETURN] to continue or ""^"" to quit " R ANS1:DTIME S:ANS1=U AROWOUT=1 Q:ANS1=U I '$T S DVBAQUIT=1 Q
G EN1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAAPLK 2503 printed Sep 23, 2025@19:16:16 Page 2
DVBAAPLK ;ALB/GTS-557/THM-FORMATTING ROUTINE FOR APPTS (DVBAREN1) ;21 JUL 89
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 SET XDD=^DD("DD")
+3 ;
EN1 WRITE @IOF,!,"Non-admitted Veteran Date Selection",!
+1 SET DISTYPE=""
WRITE !!,?5,"Select from:",!!,?10,"(A)ppointment date",!
+2 WRITE ?10,"(D)isposition log-in date",!
+3 WRITE ?10,"(S)top code",!!
+4 WRITE !,"Enter selection: A// "
READ DISTYPE:DTIME
IF '$TEST
SET Y=-1
SET AROWOUT=1
SET DVBAQUIT=1
QUIT
+5 IF DISTYPE["?"
GOTO CHECK
+6 IF DISTYPE=""
SET DISTYPE="A"
+7 IF DISTYPE=U
SET Y=-1
SET AROWOUT=1
QUIT
+8 IF DISTYPE'?1"A"&(DISTYPE'?1"D")&(DISTYPE'?1"S")
WRITE !!,*7,"Must be A, D, or S",!!
HANG 2
GOTO EN1
+9 WRITE @IOF,!,$SELECT(DISTYPE="A":"Appointment",DISTYPE="D":"Disposition Log-in",1:"Stop code")_" Date Selection for "_PNAM,!!!
+10 DO @DISTYPE
KILL APPT,DISTYPE,K,ANS,^TMP("DVBA",$JOB),ANS1,DIC,I,J,X
+11 QUIT
+12 ;
A SET Y=-1
IF '$DATA(^DPT(DFN,"S"))
WRITE !!,*7,"This veteran has no appointments on file.",!!
SET OUT=1
HANG 2
QUIT
+1 WRITE !!,"Choose from these appointment dates: "
WRITE !!
+2 SET ANS=""
SET K=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,"S",I))
if I=""
QUIT
SET J=$PIECE(^(I,0),"^",1)
SET Y=I
XECUTE XDD
SET K=K+1
SET ^TMP("DVBA",$JOB,K)=I
DO WRITE
+3 IF ANS=""
DO SELECT
+4 IF ANS=""
SET OUT=1
QUIT
+5 IF ANS]""
IF ANS'="^"
SET Y=^TMP("DVBA",$JOB,ANS)
KILL ^TMP("DVBA",$JOB)
+6 IF ANS="^"!(ANS']"")
SET AROWOUT=1
SET Y=-1
KILL APPT
QUIT
+7 SET APPDT=$PIECE(Y,".",1)
SET Y=-1
+8 QUIT
WRITE WRITE ?5,K_". ",?10,$PIECE(Y,"@",1),?25,$PIECE(Y,"@",2,99),?35,$SELECT($DATA(^SC(J,0)):$PIECE(^SC(J,0),U,1),1:"Unknown clinic"),!
IF $Y#11=0
DO SELECT
WRITE !!
if ANS]""
SET I=9999999.999
if ANS]""
QUIT
+1 QUIT
SELECT SET ANS=""
WRITE !,"Select 1 to "_K_",",!," [RETURN] to continue to search,",!," OR ""^"" to QUIT. "
READ ANS:DTIME
if ANS=U!(ANS="")!('$TEST)
QUIT
+1 IF ANS'?1.3N!(ANS<1)!(ANS>K)
WRITE !!,*7,"Must be between 1 and "_K_" ,RETURN, or ""^""",!!
HANG 2
GOTO SELECT
+2 QUIT
+3 ;
D IF '$DATA(^DPT(DFN,"DIS"))
WRITE !!,*7,"This veteran has no log-ins on file.",!!
HANG 2
SET Y=-1
SET OUT=1
QUIT
+1 SET DIC="^DPT(DFN,""DIS"","
SET DIC(0)="AEQM"
SET DIC("A")="Enter Disposition Log-in time: "
DO ^DIC
IF X=""!(X=U)
SET Y=-1
SET AROWOUT=1
QUIT
+2 SET APPDT=$EXTRACT($PIECE(Y,U,2),1,7)
SET Y=-1
+3 QUIT
+4 ;
S IF '$DATA(^SDV("ADT",DFN))
WRITE !!,*7,"This veteran has no stop codes on file.",!!
HANG 2
SET OUT=1
SET Y=-1
QUIT
+1 SET DIC="^SDV("
SET DIC(0)="EQM"
SET X=$PIECE(^DPT(DFN,0),U,9)
DO ^DIC
IF Y=-1
SET OUT=1
QUIT
+2 SET APPDT=$EXTRACT($PIECE(Y,U,2),1,7)
SET Y=-1
+3 QUIT
+4 ;
CHECK ;check what choices are available
+1 WRITE @IOF,!!,"The following choices are available for this Veteran:",!!
+2 IF $DATA(^DPT(DFN,"S"))
WRITE "Appointments",!
+3 IF $DATA(^SDV("ADT",DFN))
WRITE "Stop codes",!
+4 IF $DATA(^DPT(DFN,"DIS"))
WRITE "Disposition Log-in dates",!
+5 WRITE !!,"Press [RETURN] to continue or ""^"" to quit "
READ ANS1:DTIME
if ANS1=U
SET AROWOUT=1
if ANS1=U
QUIT
IF '$TEST
SET DVBAQUIT=1
QUIT
+6 GOTO EN1
