DVBCADE2 ;ALB/GTS-557/THM-ADD C&P EXAMS TO REQUESTS, PART 2 ; 4/18/91 7:23 AM
;;2.7;AMIE;**1,12**;Apr 10, 1995
;
EXMHD W @FF,?(IOM-$L(HD2)\2),HD2,!!,"Please select the exams for ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1),!,"Use ? to see a list exams available for selection.",!!
;
EXMSEL I $D(DVBCLCKD) Q
S DIC("S")="I $P(^(0),U,5)'=""I""",DIC="^DVB(396.6,",DIC(0)="AEQM"
S DIC("A")="Select EXAM: "
K OUT D ^DIC S:$D(DTOUT) OUT=1 Q:$D(OUT)
G:X=""!(X=U) EXMDIS ;Only out of EXMSEL
I +Y<0 W " ??",*7 G EXMSEL
S EXMDA=+Y,EXMNM=$P(^DVB(396.6,+Y,0),U,1)
I $D(^TMP($J,"NEW",EXMNM)) W " Duplicate - ignored",!,*7 G EXMSEL
I $D(^DVB(396.4,"APS",DFN,EXMDA,"O")) W *7," -- already ON FILE",! G EXMSEL
I $D(^DVB(396.4,"APS",DFN,EXMDA,"X"))!($D(^DVB(396.4,"APS",DFN,EXMDA,"RX"))) W *7," -- Previously cancelled, addition allowable",!
FMT ;drop into
S EXCNT=EXCNT+1
G:EXCNT=1 FMT1 ;Only out of FMT
K OUT
S FMT="F"
;
;** FMT1 drops into from FMT or jumps into from FMT+3
FMT1 S ^TMP($J,"NEW",EXMNM)=+Y_U_$S(EXCNT=1:"F",1:FMT)_U_EXMDA K Y H 1 W @FF,!!! G EXMSEL ;1st exam is 'full'
;
EXMDIS K %,%Y,DIE,DIC G:$D(DVBCLCKD) EXMSEL
I '$D(^TMP($J,"NEW")) W !!,*7,"You have not selected any exams.",!,"Do you want to try again" S %=1 D YN^DICN K OUT S:%=2 OUT=1 Q:$D(OUT) G:%=1 EXMHD I $D(DTOUT) S OUT=1 Q
I $D(%Y) I %Y["?" W !!,"Enter Y to select more exams or N to abort adding exams to this request.",!! G EXMDIS
I $D(%),%'=1 S OUT=1 Q
W @FF,!!,"You have selected:",!! S EXMNM=""
F JY=0:1 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" W ?5,EXMNM,!
S DIR(0)="YA"
S DIR("A")=$S(JY'>1:"Is this exam",1:"Are these exams")_" correct? "
S DIR("B")="NO"
D ^DIR
K DIR
I Y K Y G EXMLOG
I $D(DIRUT) K Y,DIROUT S OUT=1 Q
EXMOD ;drop into
I Y=0 K DIC,DIR,Y S DIC(0)="AEQM",DIC("A")="Enter EXAM to delete: ",DIC="^DVB(396.6,",DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
;
EXMOD1 W @FF,!!! K OUT D ^DIC
S:$D(DTOUT) OUT=1 Q:$D(OUT)
G:X=""!(X=U) EXMASK ;Only out of EXMOD1
S EXMNM=$P(^DVB(396.6,+Y,0),U,1)
I +Y>0&($D(^TMP($J,"NEW",EXMNM))) K ^TMP($J,"NEW",EXMNM) W:$X>50!($X<10) ! W " Ok ..." S EXCNT=EXCNT-1 H 2 G EXMOD
G EXMOD1
;
EXMASK K DIC
W @FF,!!,"Want to add more exams"
S %=1 D YN^DICN G:%=1 EXMHD ;add exams
I $D(DTOUT) S OUT=1 Q
I $D(%Y),%Y["?" W !!,"Enter Y to add more exams or N to go on and log existing selections." D CONTMES^DVBCUTL4 G EXMASK
G EXMDIS
;
EXMLOG W !! S EXMNM="" K DR,OUT
N DVBCLCKD
F DVBCJ=0:0 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" S X=$$EXAM^DVBCUTL4 S:X=0 DVBCLCKD=1 Q:$D(DVBCLCKD) D EXMLOG1^DVBCUTL4 Q:$D(OUT)
I $D(DTOUT) S OUT=1 D ROLLBCK^DVBCUTL4
Q:$D(OUT)
W:$D(DVBCLCKD) !!," Another user adding exams now...try again later."
R:$D(DVBCLCKD) !," PRESS [Return] TO CONTINUE...",DVBCCONT:DTIME
I $D(DVBCLCKD) D ROLLBCK^DVBCUTL4 G EXMDIS
I $P(^DVB(396.3,REQDA,0),U,2)'[DT S DR="23.3///NOW;23.4////"_DUZ,(DIC,DIE)="^DVB(396.3,",DA=REQDA D ^DIE ;no edit if requested today
D ^DVBCBUL1 W !
I '$D(OUT) S DIR("A")="Do you want to print worksheets ",DIR("A",1)="Worksheets should be sent to a printer.",DIR(0)="Y",DIR("?",1)="Enter Y to print worksheets for items just entered or",DIR("?")="N to skip." D ^DIR Q:Y=0!(Y=U)
D ^DVBCADE1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCADE2 3273 printed Jan 18, 2025@02:44:34 Page 2
DVBCADE2 ;ALB/GTS-557/THM-ADD C&P EXAMS TO REQUESTS, PART 2 ; 4/18/91 7:23 AM
+1 ;;2.7;AMIE;**1,12**;Apr 10, 1995
+2 ;
EXMHD WRITE @FF,?(IOM-$LENGTH(HD2)\2),HD2,!!,"Please select the exams for ",$PIECE(PNAM,",",2,99)," ",$PIECE(PNAM,",",1),!,"Use ? to see a list exams available for selection.",!!
+1 ;
EXMSEL IF $DATA(DVBCLCKD)
QUIT
+1 SET DIC("S")="I $P(^(0),U,5)'=""I"""
SET DIC="^DVB(396.6,"
SET DIC(0)="AEQM"
+2 SET DIC("A")="Select EXAM: "
+3 KILL OUT
DO ^DIC
if $DATA(DTOUT)
SET OUT=1
if $DATA(OUT)
QUIT
+4 ;Only out of EXMSEL
if X=""!(X=U)
GOTO EXMDIS
+5 IF +Y<0
WRITE " ??",*7
GOTO EXMSEL
+6 SET EXMDA=+Y
SET EXMNM=$PIECE(^DVB(396.6,+Y,0),U,1)
+7 IF $DATA(^TMP($JOB,"NEW",EXMNM))
WRITE " Duplicate - ignored",!,*7
GOTO EXMSEL
+8 IF $DATA(^DVB(396.4,"APS",DFN,EXMDA,"O"))
WRITE *7," -- already ON FILE",!
GOTO EXMSEL
+9 IF $DATA(^DVB(396.4,"APS",DFN,EXMDA,"X"))!($DATA(^DVB(396.4,"APS",DFN,EXMDA,"RX")))
WRITE *7," -- Previously cancelled, addition allowable",!
FMT ;drop into
+1 SET EXCNT=EXCNT+1
+2 ;Only out of FMT
if EXCNT=1
GOTO FMT1
+3 KILL OUT
+4 SET FMT="F"
+5 ;
+6 ;** FMT1 drops into from FMT or jumps into from FMT+3
FMT1 ;1st exam is 'full'
SET ^TMP($JOB,"NEW",EXMNM)=+Y_U_$SELECT(EXCNT=1:"F",1:FMT)_U_EXMDA
KILL Y
HANG 1
WRITE @FF,!!!
GOTO EXMSEL
+1 ;
EXMDIS KILL %,%Y,DIE,DIC
if $DATA(DVBCLCKD)
GOTO EXMSEL
+1 IF '$DATA(^TMP($JOB,"NEW"))
WRITE !!,*7,"You have not selected any exams.",!,"Do you want to try again"
SET %=1
DO YN^DICN
KILL OUT
if %=2
SET OUT=1
if $DATA(OUT)
QUIT
if %=1
GOTO EXMHD
IF $DATA(DTOUT)
SET OUT=1
QUIT
+2 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to select more exams or N to abort adding exams to this request.",!!
GOTO EXMDIS
+3 IF $DATA(%)
IF %'=1
SET OUT=1
QUIT
+4 WRITE @FF,!!,"You have selected:",!!
SET EXMNM=""
+5 FOR JY=0:1
SET EXMNM=$ORDER(^TMP($JOB,"NEW",EXMNM))
if EXMNM=""
QUIT
WRITE ?5,EXMNM,!
+6 SET DIR(0)="YA"
+7 SET DIR("A")=$SELECT(JY'>1:"Is this exam",1:"Are these exams")_" correct? "
+8 SET DIR("B")="NO"
+9 DO ^DIR
+10 KILL DIR
+11 IF Y
KILL Y
GOTO EXMLOG
+12 IF $DATA(DIRUT)
KILL Y,DIROUT
SET OUT=1
QUIT
EXMOD ;drop into
+1 IF Y=0
KILL DIC,DIR,Y
SET DIC(0)="AEQM"
SET DIC("A")="Enter EXAM to delete: "
SET DIC="^DVB(396.6,"
SET DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
+2 ;
EXMOD1 WRITE @FF,!!!
KILL OUT
DO ^DIC
+1 if $DATA(DTOUT)
SET OUT=1
if $DATA(OUT)
QUIT
+2 ;Only out of EXMOD1
if X=""!(X=U)
GOTO EXMASK
+3 SET EXMNM=$PIECE(^DVB(396.6,+Y,0),U,1)
+4 IF +Y>0&($DATA(^TMP($JOB,"NEW",EXMNM)))
KILL ^TMP($JOB,"NEW",EXMNM)
if $X>50!($X<10)
WRITE !
WRITE " Ok ..."
SET EXCNT=EXCNT-1
HANG 2
GOTO EXMOD
+5 GOTO EXMOD1
+6 ;
EXMASK KILL DIC
+1 WRITE @FF,!!,"Want to add more exams"
+2 ;add exams
SET %=1
DO YN^DICN
if %=1
GOTO EXMHD
+3 IF $DATA(DTOUT)
SET OUT=1
QUIT
+4 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to add more exams or N to go on and log existing selections."
DO CONTMES^DVBCUTL4
GOTO EXMASK
+5 GOTO EXMDIS
+6 ;
EXMLOG WRITE !!
SET EXMNM=""
KILL DR,OUT
+1 NEW DVBCLCKD
+2 FOR DVBCJ=0:0
SET EXMNM=$ORDER(^TMP($JOB,"NEW",EXMNM))
if EXMNM=""
QUIT
SET X=$$EXAM^DVBCUTL4
if X=0
SET DVBCLCKD=1
if $DATA(DVBCLCKD)
QUIT
DO EXMLOG1^DVBCUTL4
if $DATA(OUT)
QUIT
+3 IF $DATA(DTOUT)
SET OUT=1
DO ROLLBCK^DVBCUTL4
+4 if $DATA(OUT)
QUIT
+5 if $DATA(DVBCLCKD)
WRITE !!," Another user adding exams now...try again later."
+6 if $DATA(DVBCLCKD)
READ !," PRESS [Return] TO CONTINUE...",DVBCCONT:DTIME
+7 IF $DATA(DVBCLCKD)
DO ROLLBCK^DVBCUTL4
GOTO EXMDIS
+8 ;no edit if requested today
IF $PIECE(^DVB(396.3,REQDA,0),U,2)'[DT
SET DR="23.3///NOW;23.4////"_DUZ
SET (DIC,DIE)="^DVB(396.3,"
SET DA=REQDA
DO ^DIE
+9 DO ^DVBCBUL1
WRITE !
+10 IF '$DATA(OUT)
SET DIR("A")="Do you want to print worksheets "
SET DIR("A",1)="Worksheets should be sent to a printer."
SET DIR(0)="Y"
SET DIR("?",1)="Enter Y to print worksheets for items just entered or"
SET DIR("?")="N to skip."
DO ^DIR
if Y=0!(Y=U)
QUIT
+11 DO ^DVBCADE1
+12 QUIT
