- 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 Mar 13, 2025@20:44:57 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
