- 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 Feb 18, 2025@23:11:09 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