DVBAB97 ;ALB/SPH - CAPRI CONVERSION OF DVBCENQ2 FOR SUPPORT ;09/11/00
;;2.7;AMIE;**35**;Apr 10, 1995
;
S ZMSG(DVBABCNT)=" >>> Future C&P Appointments <<<",DVBABCNT=DVBABCNT+1
S ZMSG(DVBABCNT)="",DVBABCNT=DVBABCNT+1
;
FA S CT=0 W ! I $O(^DPT(DFN,"S",DT-.1))="" S ZMSG(DVBABCNT)="No future C & P appointments found.",DVBABCNT=DVBABCNT+1 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
;S ZMSG(DVBABCNT)="No future C&P appointments found.",DVBABCNT=DVBABCNT+1 G EXIT
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
S ZMSG(DVBABCNT)=$$FMTE^XLFDT(FA,"5DZ")_" "_$J(+$E(FA_"00",9,10)_":"_$E(FA_"0000",11,12),6)_" "_$E($P($S($D(^SC(C,0)):^(0),1:""),"^"),1,21)_" ",DVBABCNT=DVBABCNT+1 D CAL S PRT=1
Q
;
EXIT S ZMSG(DVBABCNT)="",DVBABCNT=DVBABCNT+1
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[HDVBAB97 1922 printed Dec 13, 2024@01:40:45 Page 2
DVBAB97 ;ALB/SPH - CAPRI CONVERSION OF DVBCENQ2 FOR SUPPORT ;09/11/00
+1 ;;2.7;AMIE;**35**;Apr 10, 1995
+2 ;
+3 SET ZMSG(DVBABCNT)=" >>> Future C&P Appointments <<<"
SET DVBABCNT=DVBABCNT+1
+4 SET ZMSG(DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+5 ;
FA SET CT=0
WRITE !
IF $ORDER(^DPT(DFN,"S",DT-.1))=""
SET ZMSG(DVBABCNT)="No future C & P appointments found."
SET DVBABCNT=DVBABCNT+1
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 ;S ZMSG(DVBABCNT)="No future C&P appointments found.",DVBABCNT=DVBABCNT+1 G EXIT
+3 GOTO EXIT
+4 ;
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 SET ZMSG(DVBABCNT)=$$FMTE^XLFDT(FA,"5DZ")_" "_$JUSTIFY(+$EXTRACT(FA_"00",9,10)_":"_$EXTRACT(FA_"0000",11,12),6)_" "_$EXTRACT($PIECE($SELECT($DATA(^SC(C,0)):^(0),1:""),"^"),1,21)_" "
SET DVBABCNT=DVBABCNT+1
DO CAL
SET PRT=1
+2 QUIT
+3 ;
EXIT SET ZMSG(DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+1 KILL YY,CT,FA,L,C,DVBCX,DATE,DVBCLNE
WRITE !!!
QUIT
+2 ;
CONT ;I IOST?1"C-".E W !!,"Press [RETURN] to continue " R ANS:DTIME
+1 QUIT
+2 ;
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 "-"
+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
