DVBCLOGE ;ALB/GTS-557/THM-SET UP C&P EXAM ; 5/10/91 8:55 AM
;;2.7;AMIE;;Apr 10, 1995
;if $D(OUT), request deleted - exams must be completed
;
EXMHD K OUT N DVBARQDT,DVBADT,DVBADA
W @FF,?(IOM-$L(HD2)\2),HD2
W !!,"Please select the exams for ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1)
W !,"Use ? to see a list of exams available for selection.",!!
I $D(^DVB(396.3,REQDA,5)),($P(^DVB(396.3,REQDA,0),"^",10)="E"&(+$P(^DVB(396.3,REQDA,5),"^",1)'>0)) DO
.S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
.S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
.S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
.D WR^DVBAUTL4("TVAR")
.K TVAR
I '$D(^DVB(396.3,REQDA,5))&($P(^DVB(396.3,REQDA,0),"^",10)="E") DO
.S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
.S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
.S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
.D WR^DVBAUTL4("TVAR")
.K TVAR
;
EXMSEL K DIC,OUT,DVBAQT I $D(DVBCLCKD) Q
S DVBARQDT=$P(^DVB(396.3,REQDA,0),U,2)
I $D(^DVB(396.3,REQDA,5)),(+$P(^DVB(396.3,REQDA,5),U,1)>0) DO
.S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1) ;**Exam Scr for Insuff 2507'S
.S DIC("S")="I $D(^DVB(396.4,""ARQ"_DVBAINDA_""",Y))"
S:'$D(DIC("S")) DIC("S")="I $P(^(0),U,5)'=""I"""
S DIC="^DVB(396.6,"
S DIC(0)="AEQM",DIC("A")="Select EXAM: " D ^DIC
S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS Q:$D(OUT)
G:X=""!(X=U) EXMDIS ;Only out of EXMSEL
I +Y>0 S EXMNM=$P(^DVB(396.6,+Y,0),U,1),EXMPTR=+Y
I +Y<0 W " ???" G EXMSEL
I $D(^TMP($J,"NEW",EXMNM)) W " Duplicate - ignored",!,*7 G EXMSEL
I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 W *7," -- already ON FILE",!
I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 S DVBAQT=1
G:$D(DVBAQT) EXMSEL
S ^TMP($J,"NEW",EXMNM)=+Y K Y G EXMSEL
;
EXMDIS W @FF,!! 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 D:%=1 KVARS G:%=1 EXMHD I $D(DTOUT) S OUT=1 D KVARS Q
I $D(%Y) I %Y["?" W !!,"Enter Y to go back and select exams or N to DELETE the entire request",!,"as well as any exams selected." D CONTMES^DVBCUTL4 G EXMDIS
I $D(%) I %'=1 S OUT=1 D KVARS Q
W !!,"You have selected these exams:",!! S EXMNM="" F JY=0:1 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" W ?5,EXMNM,!
W !,$S(JY'>1:"Is this exam",1:"Are these exams")," correct"
S %=2 D YN^DICN G:%=1 EXMLOG ;Only out of EXMDIS
I $D(DTOUT) S OUT=1 D KVARS Q
I $D(%Y),%Y["?" W !,"Enter Y to go ahead and log the selected exams or N to modify the list." D CONTMES^DVBCUTL4 G EXMDIS
;
EXMOD ;drop into - correct exams
I $D(%),%=2 W @FF,!!!
S DIC(0)="AEQM",DIC("A")="Enter EXAM to delete: "
S DIC="^DVB(396.6,",DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
;
EXMOD1 K OUT D ^DIC
S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS 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 " Ok ..." H 1 G EXMOD1
G EXMOD1
;
EXMASK W @FF,!!,"Want to add more exams"
S %=1 D YN^DICN G:%=1 EXMSEL ;select more exams
I $D(DTOUT) S OUT=1 D KVARS 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 ;display exams
;
EXMLOG W !! S EXMNM="" K DR
D STM^DVBCUTL4
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 Q:$D(OUT)
S XRTN=$T(+0)
D SPM^DVBCUTL4
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 $D(OUT) D KVARS Q
H 2 K DA S DA=REQDA
W @IOF,!,"Please enter any remarks for this request:",!!!
S DR="23",DIE="^DVB(396.3," D ^DIE H 1
K DIC,DIE,DR,EXMNM,DVBCDEL,Y,X,EXMPTR D KVARS
Q
;
EXMLOG1 ;called by EXMLOG
K OUT,DD,DO S (DIC,DIE)="^DVB(396.4,",DIC(0)=""
S DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
D FILE^DICN
I $D(Y),+Y>0 W:$X>50 ! W:$X>40&($L(EXMNM)>30) ! W EXMNM_" -added, "
I $D(Y),+Y<0 W *7,"Exam addition error ! " S OUT=1
D INSXM^DVBCUTA1
I $D(DTOUT) W *7,"Exam addition error ! " S OUT=1 D ROLLBCK^DVBCUTL4
Q
;
KVARS ;Kill this routines variables
K DVBARQDT,DVBADT,DVBADA,DVBAQT,DVBAINDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCLOGE 4510 printed Jan 18, 2025@02:45:58 Page 2
DVBCLOGE ;ALB/GTS-557/THM-SET UP C&P EXAM ; 5/10/91 8:55 AM
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;if $D(OUT), request deleted - exams must be completed
+3 ;
EXMHD KILL OUT
NEW DVBARQDT,DVBADT,DVBADA
+1 WRITE @FF,?(IOM-$LENGTH(HD2)\2),HD2
+2 WRITE !!,"Please select the exams for ",$PIECE(PNAM,",",2,99)," ",$PIECE(PNAM,",",1)
+3 WRITE !,"Use ? to see a list of exams available for selection.",!!
+4 IF $DATA(^DVB(396.3,REQDA,5))
IF ($PIECE(^DVB(396.3,REQDA,0),"^",10)="E"&(+$PIECE(^DVB(396.3,REQDA,5),"^",1)'>0))
Begin DoDot:1
+5 SET TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
+6 SET TVAR(2,0)="0,8,0,1:1,0^to a completed request."
+7 SET TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
+8 DO WR^DVBAUTL4("TVAR")
+9 KILL TVAR
End DoDot:1
+10 IF '$DATA(^DVB(396.3,REQDA,5))&($PIECE(^DVB(396.3,REQDA,0),"^",10)="E")
Begin DoDot:1
+11 SET TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
+12 SET TVAR(2,0)="0,8,0,1:1,0^to a completed request."
+13 SET TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
+14 DO WR^DVBAUTL4("TVAR")
+15 KILL TVAR
End DoDot:1
+16 ;
EXMSEL KILL DIC,OUT,DVBAQT
IF $DATA(DVBCLCKD)
QUIT
+1 SET DVBARQDT=$PIECE(^DVB(396.3,REQDA,0),U,2)
+2 IF $DATA(^DVB(396.3,REQDA,5))
IF (+$PIECE(^DVB(396.3,REQDA,5),U,1)>0)
Begin DoDot:1
+3 ;**Exam Scr for Insuff 2507'S
SET DVBAINDA=+$PIECE(^DVB(396.3,REQDA,5),U,1)
+4 SET DIC("S")="I $D(^DVB(396.4,""ARQ"_DVBAINDA_""",Y))"
End DoDot:1
+5 if '$DATA(DIC("S"))
SET DIC("S")="I $P(^(0),U,5)'=""I"""
+6 SET DIC="^DVB(396.6,"
+7 SET DIC(0)="AEQM"
SET DIC("A")="Select EXAM: "
DO ^DIC
+8 if $DATA(DTOUT)
SET OUT=1
if $DATA(OUT)
DO KVARS
if $DATA(OUT)
QUIT
+9 ;Only out of EXMSEL
if X=""!(X=U)
GOTO EXMDIS
+10 IF +Y>0
SET EXMNM=$PIECE(^DVB(396.6,+Y,0),U,1)
SET EXMPTR=+Y
+11 IF +Y<0
WRITE " ???"
GOTO EXMSEL
+12 IF $DATA(^TMP($JOB,"NEW",EXMNM))
WRITE " Duplicate - ignored",!,*7
GOTO EXMSEL
+13 IF $DATA(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0
WRITE *7," -- already ON FILE",!
+14 IF $DATA(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0
SET DVBAQT=1
+15 if $DATA(DVBAQT)
GOTO EXMSEL
+16 SET ^TMP($JOB,"NEW",EXMNM)=+Y
KILL Y
GOTO EXMSEL
+17 ;
EXMDIS WRITE @FF,!!
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
if %=1
DO KVARS
if %=1
GOTO EXMHD
IF $DATA(DTOUT)
SET OUT=1
DO KVARS
QUIT
+2 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to go back and select exams or N to DELETE the entire request",!,"as well as any exams selected."
DO CONTMES^DVBCUTL4
GOTO EXMDIS
+3 IF $DATA(%)
IF %'=1
SET OUT=1
DO KVARS
QUIT
+4 WRITE !!,"You have selected these exams:",!!
SET EXMNM=""
FOR JY=0:1
SET EXMNM=$ORDER(^TMP($JOB,"NEW",EXMNM))
if EXMNM=""
QUIT
WRITE ?5,EXMNM,!
+5 WRITE !,$SELECT(JY'>1:"Is this exam",1:"Are these exams")," correct"
+6 ;Only out of EXMDIS
SET %=2
DO YN^DICN
if %=1
GOTO EXMLOG
+7 IF $DATA(DTOUT)
SET OUT=1
DO KVARS
QUIT
+8 IF $DATA(%Y)
IF %Y["?"
WRITE !,"Enter Y to go ahead and log the selected exams or N to modify the list."
DO CONTMES^DVBCUTL4
GOTO EXMDIS
+9 ;
EXMOD ;drop into - correct exams
+1 IF $DATA(%)
IF %=2
WRITE @FF,!!!
+2 SET DIC(0)="AEQM"
SET DIC("A")="Enter EXAM to delete: "
+3 SET DIC="^DVB(396.6,"
SET DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
+4 ;
EXMOD1 KILL OUT
DO ^DIC
+1 if $DATA(DTOUT)
SET OUT=1
if $DATA(OUT)
DO KVARS
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)
WRITE " Ok ..."
HANG 1
GOTO EXMOD1
+5 GOTO EXMOD1
+6 ;
EXMASK WRITE @FF,!!,"Want to add more exams"
+1 ;select more exams
SET %=1
DO YN^DICN
if %=1
GOTO EXMSEL
+2 IF $DATA(DTOUT)
SET OUT=1
DO KVARS
QUIT
+3 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
+4 ;display exams
GOTO EXMDIS
+5 ;
EXMLOG WRITE !!
SET EXMNM=""
KILL DR
+1 DO STM^DVBCUTL4
+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
if $DATA(OUT)
QUIT
+3 SET XRTN=$TEXT(+0)
+4 DO SPM^DVBCUTL4
+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 IF $DATA(OUT)
DO KVARS
QUIT
+9 HANG 2
KILL DA
SET DA=REQDA
+10 WRITE @IOF,!,"Please enter any remarks for this request:",!!!
+11 SET DR="23"
SET DIE="^DVB(396.3,"
DO ^DIE
HANG 1
+12 KILL DIC,DIE,DR,EXMNM,DVBCDEL,Y,X,EXMPTR
DO KVARS
+13 QUIT
+14 ;
EXMLOG1 ;called by EXMLOG
+1 KILL OUT,DD,DO
SET (DIC,DIE)="^DVB(396.4,"
SET DIC(0)=""
+2 SET DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
+3 DO FILE^DICN
+4 IF $DATA(Y)
IF +Y>0
if $X>50
WRITE !
if $X>40&($LENGTH(EXMNM)>30)
WRITE !
WRITE EXMNM_" -added, "
+5 IF $DATA(Y)
IF +Y<0
WRITE *7,"Exam addition error ! "
SET OUT=1
+6 DO INSXM^DVBCUTA1
+7 IF $DATA(DTOUT)
WRITE *7,"Exam addition error ! "
SET OUT=1
DO ROLLBCK^DVBCUTL4
+8 QUIT
+9 ;
KVARS ;Kill this routines variables
+1 KILL DVBARQDT,DVBADT,DVBADA,DVBAQT,DVBAINDA
+2 QUIT
