- DVBCENQ2 ;ALB ISC/THM-DISPLAY C&P APPOINTMENTS ; 8/13/90 7:02 AM
- ;;2.7;AMIE;**17**;Apr 10, 1995
- ;
- S DVBCLNE=" >>> Future C&P Appointments <<<" W ! D HDR
- ;
- FA S CT=0 W ! I $O(^DPT(DFN,"S",DT-.1))="" W !!?23,"No future C & P appointments found.",!! G EXIT
- K PRT F FA=DT-.1:0 S FA=$O(^DPT(DFN,"S",FA)) Q:FA="" S L=^(FA,0),C=+L S YY=$P(L,U,2) I YY'="N"&(YY'="C")&(YY'="NA")&(YY'="CA")&(YY'="PC")&(YY'="PCA") D FA1
- W:'$D(PRT) !!?23,"No future C&P appointments found.",!! G EXIT
- ;
- FA1 S DVBCX=$P(^DPT(DFN,"S",FA,0),U,16) I $D(^SD(409.1,+DVBCX,0)) Q:$P(^(0),U,1)'["COMPENSATION" ;compensation and pension exams only
- W !?0,$$FMTE^XLFDT(FA,"5DZ"),?9,$J(+$E(FA_"00",9,10)_":"_$E(FA_"0000",11,12),6),?18,$E($P($S($D(^SC(C,0)):^(0),1:""),"^"),1,21)," " D CAL S PRT=1
- Q
- ;
- EXIT K YY,CT,FA,L,C,DVBCX,DATE,DVBCLNE W !!! Q
- ;
- CONT I IOST?1"C-".E W !!,"Press [RETURN] to continue " R ANS:DTIME
- Q
- ;
- HDR W ?(80-$L(DVBCLNE)\2),DVBCLNE,!!?0,"Date",?12,"Time",?18,"Clinic",?43," Lab",?56," X-Ray",?69," EKG",!?0 F I=0:1:79 W "-"
- Q
- ;
- CAL F J=3:1:5 I $P(L,U,J)]"" S DATE(J)=$E($P(L,U,J),4,7),DATE(J)=$E(DATE(J),1,2)_"/"_$E(DATE(J),3,4)_" ",TIME(J)=$P($P(L,U,J),".",2) D CAL1
- Q
- ;
- CAL1 S:TIME(J)=1 TIME(J)=10 S TIME(J)=$S($L(TIME(J))=2:TIME(J)_"00",$L(TIME(J))=3:TIME(J)_"0",1:TIME(J)),DATE(J)=DATE(J)_TIME(J)
- I $D(DATE(3)) S DATE(3)=$E(DATE(3),1,6)_$E(DATE(3),7,8)_":"_$E(DATE(3),9,10) W:$D(DATE(3)) ?42,DATE(3)
- I $D(DATE(4)) S DATE(4)=$E(DATE(4),1,6)_$E(DATE(4),7,8)_":"_$E(DATE(4),9,10) W:$D(DATE(4)) ?55,DATE(4)
- I $D(DATE(5)) S DATE(5)=$E(DATE(5),1,6)_$E(DATE(5),7,8)_":"_$E(DATE(5),9,10) W:$D(DATE(5)) ?68,DATE(5)
- I IOST?1"C-".E,$Y>18 D CONT,HDR
- I IOST?1"P-".E,$Y>45 D HDR
- K DATE,CONT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCENQ2 1728 printed Mar 13, 2025@20:48:44 Page 2
- DVBCENQ2 ;ALB ISC/THM-DISPLAY C&P APPOINTMENTS ; 8/13/90 7:02 AM
- +1 ;;2.7;AMIE;**17**;Apr 10, 1995
- +2 ;
- +3 SET DVBCLNE=" >>> Future C&P Appointments <<<"
- WRITE !
- DO HDR
- +4 ;
- FA SET CT=0
- WRITE !
- IF $ORDER(^DPT(DFN,"S",DT-.1))=""
- WRITE !!?23,"No future C & P appointments found.",!!
- GOTO EXIT
- +1 KILL PRT
- FOR FA=DT-.1:0
- SET FA=$ORDER(^DPT(DFN,"S",FA))
- if FA=""
- QUIT
- SET L=^(FA,0)
- SET C=+L
- SET YY=$PIECE(L,U,2)
- IF YY'="N"&(YY'="C")&(YY'="NA")&(YY'="CA")&(YY'="PC")&(YY'="PCA")
- DO FA1
- +2 if '$DATA(PRT)
- WRITE !!?23,"No future C&P appointments found.",!!
- GOTO EXIT
- +3 ;
- FA1 ;compensation and pension exams only
- SET DVBCX=$PIECE(^DPT(DFN,"S",FA,0),U,16)
- IF $DATA(^SD(409.1,+DVBCX,0))
- if $PIECE(^(0),U,1)'["COMPENSATION"
- QUIT
- +1 WRITE !?0,$$FMTE^XLFDT(FA,"5DZ"),?9,$JUSTIFY(+$EXTRACT(FA_"00",9,10)_":"_$EXTRACT(FA_"0000",11,12),6),?18,$EXTRACT($PIECE($SELECT($DATA(^SC(C,0)):^(0),1:""),"^"),1,21)," "
- DO CAL
- SET PRT=1
- +2 QUIT
- +3 ;
- EXIT KILL YY,CT,FA,L,C,DVBCX,DATE,DVBCLNE
- WRITE !!!
- QUIT
- +1 ;
- CONT IF IOST?1"C-".E
- WRITE !!,"Press [RETURN] to continue "
- READ ANS:DTIME
- +1 QUIT
- +2 ;
- HDR WRITE ?(80-$LENGTH(DVBCLNE)\2),DVBCLNE,!!?0,"Date",?12,"Time",?18,"Clinic",?43," Lab",?56," X-Ray",?69," EKG",!?0
- FOR I=0:1:79
- WRITE "-"
- +1 QUIT
- +2 ;
- CAL FOR J=3:1:5
- IF $PIECE(L,U,J)]""
- SET DATE(J)=$EXTRACT($PIECE(L,U,J),4,7)
- SET DATE(J)=$EXTRACT(DATE(J),1,2)_"/"_$EXTRACT(DATE(J),3,4)_" "
- SET TIME(J)=$PIECE($PIECE(L,U,J),".",2)
- DO CAL1
- +1 QUIT
- +2 ;
- CAL1 if TIME(J)=1
- SET TIME(J)=10
- SET TIME(J)=$SELECT($LENGTH(TIME(J))=2:TIME(J)_"00",$LENGTH(TIME(J))=3:TIME(J)_"0",1:TIME(J))
- SET DATE(J)=DATE(J)_TIME(J)
- +1 IF $DATA(DATE(3))
- SET DATE(3)=$EXTRACT(DATE(3),1,6)_$EXTRACT(DATE(3),7,8)_":"_$EXTRACT(DATE(3),9,10)
- if $DATA(DATE(3))
- WRITE ?42,DATE(3)
- +2 IF $DATA(DATE(4))
- SET DATE(4)=$EXTRACT(DATE(4),1,6)_$EXTRACT(DATE(4),7,8)_":"_$EXTRACT(DATE(4),9,10)
- if $DATA(DATE(4))
- WRITE ?55,DATE(4)
- +3 IF $DATA(DATE(5))
- SET DATE(5)=$EXTRACT(DATE(5),1,6)_$EXTRACT(DATE(5),7,8)_":"_$EXTRACT(DATE(5),9,10)
- if $DATA(DATE(5))
- WRITE ?68,DATE(5)
- +4 IF IOST?1"C-".E
- IF $Y>18
- DO CONT
- DO HDR
- +5 IF IOST?1"P-".E
- IF $Y>45
- DO HDR
- +6 KILL DATE,CONT
- +7 QUIT
