DVBCSCHD ;ALB/GTS-557/THM-SCHEDULE C&P EXAMS ; 9/23/91 9:54 AM
;;2.7;AMIE;**17,193**;Apr 10, 1995;Build 84
;
;** Version Changes
; 2.7 - GTS/Set DVBADA,DVBASDRT SD Event driver (Enhc 13)
;
SETUP D HOME^%ZIS S HD="SCHEDULE C&P EXAMS",FF=IOF
I $D(DUZ)#2=0 W *7,!!,"You have no user number !",!! H 3 G EXIT
S SUPER=0 I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) S SUPER=1
;
EN D ZAP W @FF,?(IOM-$L(HD)\2),HD,!!!
S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("A")="Enter VETERAN NAME: ",DIC("W")="D DICW^DVBCUTIL"
D ^DIC G:X=""!(X[U)!($D(DTOUT)) EXIT
I +Y>0 S (OLDDA,REQDA)=+Y,DFN=$P(Y,U,2)
I $O(^DVB(396.4,"C",REQDA,0))="" W !!,*7,"This request has no exams on it and should",!,"be completely cancelled.",!! H 3 G EN
D GO1 I '$D(TFIND) W !!,*7,"This request has been completely transferred to another site.",!,"Scheduling will not be allowed.",!! H 3 G EN
;AJF;Conversion of Request Status field
S STAT=$P(^DVB(396.3,REQDA,0),U,18),STAT=$$RSTAT^DVBCUTL8(STAT) D STATCHK I $D(NCN) G EN
S DTSCHED=$P(^DVB(396.3,+Y,0),U,6) I DTSCHED]"" W !!,*7,"Scheduling has been completed for this request as of ",$$FMTE^XLFDT(DTSCHED,"5DZ")_".",!
I DTSCHED]"",SUPER=0 W "Only supervisors can change it.",!! H 3 G EN
;
ASK K %,%Y I DTSCHED]"",SUPER=1 W "Do you want to change" S %=2 D YN^DICN G:$D(DTOUT)!(%<0) EXIT
I $D(%Y),%Y["?" W !!,"Enter Y to be able to change the scheduling information or N to backup.",!! G ASK
I $D(%),%'=1 G EN
;
ASK1 I $D(^DVB(396.3,REQDA,4)),$P(^(4),U,1)="y" W !!,"Note: One or more exams on this request have transferred out."
W !!,"Do you want to make an appointment for a clinic" S %=1 D YN^DICN G:$D(DTOUT)!(%<0) EXIT I %=1 W @FF,"Schedule a Clinic Appointment for 2507 Exam",!!! S ORACTION=1,DVBADA=REQDA,DVBASDRT="",ORVP=DFN D OERR^SDM
I $D(%Y),%Y["?" W !!,"Enter Y to make an appointment via ADT/Scheduling or N to skip." G ASK1
;
EN1 W @FF,"Enter Scheduling Information for 2507 Exams",!!
;
ASK2 W !,"Has scheduling for all exams been completed" S %=2 D YN^DICN G:$D(DTOUT)!(%<0) EXIT
I $D(%Y),%Y["?" W !!,"Enter Y if scheduling is completed, N if not.",!! G ASK2
G:%'=1 EN
W !!,"Ok, then please complete the following:",!!
S:$P(^DVB(396.3,REQDA,0),U,6)="" DR="5///NOW",DIE="^DVB(396.3,",DA=REQDA D ^DIE:$P(^DVB(396.3,REQDA,0),U,6)="",EXAMS I '$D(Y) G EN
I $D(Y) W *7,!!,"Important scheduling information is missing!",!,"2507 file NOT updated!",!! S DR="5///@",DIE="^DVB(396.3,",DA=REQDA D ^DIE H 2 G EN ;delete date if "^"
;
ZAP K %,%Y,NCN,DFN,EXAM,JDR,JDT,DTSCHED,REQDA,RO,RONAME,STAT,TFIND,TSTDT
Q
;
EXIT K TFIND,ORACTION,ORVP,DVBAXJ,DVBASDRT G KILL^DVBCUTIL
;
STATCHK Q:STAT="P"!(STAT="N")!(STAT="NT")!(STAT="S")!(STAT="O")
;AJF; Request Status Conversion
N STIEN,STNM
S STIEN=$O(^DVB(396.33,"C",STAT,"")),STNM=$$RTSTAT^DVBCUTL8(STIEN)
W !!,*7,"This request has a status of ",STNM," and can't be scheduled.",!!
S NCN=1 H 2 Q
Q
;
EXAMS H 1 S DA(1)=REQDA
F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA=""!(+DA=0) S EXNAME=+$P(^DVB(396.4,DA,0),U,3),EXST=$P(^(0),U,4),EXNAME=$S($D(^DVB(396.6,EXNAME,0)):$P(^(0),U,1),1:"") I EXST'["X",EXST'="T" D EXAMS1 ;screen cancels, transfers
Q
;
EXAMS1 I EXNAME]"" S DIE="^DVB(396.4,",DR=".08//NO;.09//CLINIC" W @IOF,!!!,"Exam: ",EXNAME,!!! D ^DIE Q:$D(Y)
Q
;
GO1 K TFIND F DVBAXJ=0:0 S DVBAXJ=$O(^DVB(396.4,"C",REQDA,DVBAXJ)) Q:DVBAXJ="" I $P(^DVB(396.4,DVBAXJ,0),U,4)'="T" S TFIND=1
Q
;if $D(TFIND) at least one exam to be done locally
;if '$D(TFIND) all exams are transferred/don't consider
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCSCHD 3554 printed Nov 22, 2024@16:58:50 Page 2
DVBCSCHD ;ALB/GTS-557/THM-SCHEDULE C&P EXAMS ; 9/23/91 9:54 AM
+1 ;;2.7;AMIE;**17,193**;Apr 10, 1995;Build 84
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - GTS/Set DVBADA,DVBASDRT SD Event driver (Enhc 13)
+5 ;
SETUP DO HOME^%ZIS
SET HD="SCHEDULE C&P EXAMS"
SET FF=IOF
+1 IF $DATA(DUZ)#2=0
WRITE *7,!!,"You have no user number !",!!
HANG 3
GOTO EXIT
+2 SET SUPER=0
IF $DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))
SET SUPER=1
+3 ;
EN DO ZAP
WRITE @FF,?(IOM-$LENGTH(HD)\2),HD,!!!
+1 SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("A")="Enter VETERAN NAME: "
SET DIC("W")="D DICW^DVBCUTIL"
+2 DO ^DIC
if X=""!(X[U)!($DATA(DTOUT))
GOTO EXIT
+3 IF +Y>0
SET (OLDDA,REQDA)=+Y
SET DFN=$PIECE(Y,U,2)
+4 IF $ORDER(^DVB(396.4,"C",REQDA,0))=""
WRITE !!,*7,"This request has no exams on it and should",!,"be completely cancelled.",!!
HANG 3
GOTO EN
+5 DO GO1
IF '$DATA(TFIND)
WRITE !!,*7,"This request has been completely transferred to another site.",!,"Scheduling will not be allowed.",!!
HANG 3
GOTO EN
+6 ;AJF;Conversion of Request Status field
+7 SET STAT=$PIECE(^DVB(396.3,REQDA,0),U,18)
SET STAT=$$RSTAT^DVBCUTL8(STAT)
DO STATCHK
IF $DATA(NCN)
GOTO EN
+8 SET DTSCHED=$PIECE(^DVB(396.3,+Y,0),U,6)
IF DTSCHED]""
WRITE !!,*7,"Scheduling has been completed for this request as of ",$$FMTE^XLFDT(DTSCHED,"5DZ")_".",!
+9 IF DTSCHED]""
IF SUPER=0
WRITE "Only supervisors can change it.",!!
HANG 3
GOTO EN
+10 ;
ASK KILL %,%Y
IF DTSCHED]""
IF SUPER=1
WRITE "Do you want to change"
SET %=2
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to be able to change the scheduling information or N to backup.",!!
GOTO ASK
+2 IF $DATA(%)
IF %'=1
GOTO EN
+3 ;
ASK1 IF $DATA(^DVB(396.3,REQDA,4))
IF $PIECE(^(4),U,1)="y"
WRITE !!,"Note: One or more exams on this request have transferred out."
+1 WRITE !!,"Do you want to make an appointment for a clinic"
SET %=1
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT
IF %=1
WRITE @FF,"Schedule a Clinic Appointment for 2507 Exam",!!!
SET ORACTION=1
SET DVBADA=REQDA
SET DVBASDRT=""
SET ORVP=DFN
DO OERR^SDM
+2 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to make an appointment via ADT/Scheduling or N to skip."
GOTO ASK1
+3 ;
EN1 WRITE @FF,"Enter Scheduling Information for 2507 Exams",!!
+1 ;
ASK2 WRITE !,"Has scheduling for all exams been completed"
SET %=2
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y if scheduling is completed, N if not.",!!
GOTO ASK2
+2 if %'=1
GOTO EN
+3 WRITE !!,"Ok, then please complete the following:",!!
+4 if $PIECE(^DVB(396.3,REQDA,0),U,6)=""
SET DR="5///NOW"
SET DIE="^DVB(396.3,"
SET DA=REQDA
if $PIECE(^DVB(396.3,REQDA,0),U,6)=""
DO ^DIE
DO EXAMS
IF '$DATA(Y)
GOTO EN
+5 ;delete date if "^"
IF $DATA(Y)
WRITE *7,!!,"Important scheduling information is missing!",!,"2507 file NOT updated!",!!
SET DR="5///@"
SET DIE="^DVB(396.3,"
SET DA=REQDA
DO ^DIE
HANG 2
GOTO EN
+6 ;
ZAP KILL %,%Y,NCN,DFN,EXAM,JDR,JDT,DTSCHED,REQDA,RO,RONAME,STAT,TFIND,TSTDT
+1 QUIT
+2 ;
EXIT KILL TFIND,ORACTION,ORVP,DVBAXJ,DVBASDRT
GOTO KILL^DVBCUTIL
+1 ;
STATCHK if STAT="P"!(STAT="N")!(STAT="NT")!(STAT="S")!(STAT="O")
QUIT
+1 ;AJF; Request Status Conversion
+2 NEW STIEN,STNM
+3 SET STIEN=$ORDER(^DVB(396.33,"C",STAT,""))
SET STNM=$$RTSTAT^DVBCUTL8(STIEN)
+4 WRITE !!,*7,"This request has a status of ",STNM," and can't be scheduled.",!!
+5 SET NCN=1
HANG 2
QUIT
+6 QUIT
+7 ;
EXAMS HANG 1
SET DA(1)=REQDA
+1 ;screen cancels, transfers
FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if DA=""!(+DA=0)
QUIT
SET EXNAME=+$PIECE(^DVB(396.4,DA,0),U,3)
SET EXST=$PIECE(^(0),U,4)
SET EXNAME=$SELECT($DATA(^DVB(396.6,EXNAME,0)):$PIECE(^(0),U,1),1:"")
IF EXST'["X"
IF EXST'="T"
DO EXAMS1
+2 QUIT
+3 ;
EXAMS1 IF EXNAME]""
SET DIE="^DVB(396.4,"
SET DR=".08//NO;.09//CLINIC"
WRITE @IOF,!!!,"Exam: ",EXNAME,!!!
DO ^DIE
if $DATA(Y)
QUIT
+1 QUIT
+2 ;
GO1 KILL TFIND
FOR DVBAXJ=0:0
SET DVBAXJ=$ORDER(^DVB(396.4,"C",REQDA,DVBAXJ))
if DVBAXJ=""
QUIT
IF $PIECE(^DVB(396.4,DVBAXJ,0),U,4)'="T"
SET TFIND=1
+1 QUIT
+2 ;if $D(TFIND) at least one exam to be done locally
+3 ;if '$D(TFIND) all exams are transferred/don't consider
