DVBCCNCL ;ALB/GTS,LAB - 557/THM-2507 CANCEL REQUESTS, EXAMS ;05/09/2019
;;2.7;AMIE;**102,184,193,194,214**;Apr 10, 1995;Build 1
;
G EN
LOOK1 S EXAM=$S($D(^DVB(396.6,$P(^DVB(396.4,JZ,0),U,3),0)):$P(^(0),U,1),1:"Unknown")
S STAT=$P(^DVB(396.4,JZ,0),U,4)
S $P(^TMP($J,EXAM),U,1)=STAT_U_JZ S:STAT="C" TCNCL=1 S:STAT="T" TCNCL=2
Q
;
EN ;
N DVBCARY,DVBCRDAT,DVBCSITE
D HOME^%ZIS S FF=IOF,HD="2507 Exam Veteran Selection",HD2="2507 Test Cancellation"
;
LOOK D KILL W @FF,!?(IOM-$L(HD)\2),HD,!?(IOM-$L(HD2)\2),HD2,!! S DIC("W")="D DICW^DVBCUTIL" S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("A")="Select VETERAN: " D ^DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" G LOOK
S DA(1)=+Y,DFN=$P(Y,U,2),STAT=$P(^DVB(396.3,DA(1),0),U,18)
;AJF; Request Status Conversion
S STAT=$$RSTAT^DVBCUTL8(STAT)
D STATCHK G:$D(NCN) LOOK S REQDT=$P(^DVB(396.3,DA(1),0),U,2)
D GETS^DIQ(396.3,DA(1),"1;2","E","DVBCARY")
S DVBCRDAT=DVBCARY(396.3,DA(1)_",",1,"E")
S DVBCSITE=DVBCARY(396.3,DA(1)_",",2,"E")
I '$D(^DPT(DFN,0)) W *7,!!,"Zeroth node for ^DPT record missing!",!! H 3 G LOOK
S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown") K DICW
S REQRO=$P(^DVB(396.3,DA(1),0),U,3),REQSTR=$P(^(0),U,4) ;used to screen bulletins
K TCNCL F JZ=0:0 S JZ=$O(^DVB(396.4,"C",DA(1),JZ)) Q:JZ="" D LOOK1
;
ASK I $D(TCNCL) W *7,!!,"This request cannot be cancelled entirely because",!," one or more exams have ",$S(TCNCL=2:"been transferred.",1:"been completed.")
I W !!,"However, you may cancel other individual exams.",!!,"Press RETURN " R ANS:60 G:'$T!(ANS="^") EXIT G DATA
W !!,"Do you want to cancel the entire exam" S %=2 D YN^DICN G:$D(DTOUT)!(%<0) EXIT G:%=1 ^DVBCCNC1
I $D(%Y),%Y["?" W !!,"Enter Y to cancel the ENTIRE exam or N to cancel ONLY selected exams",!! G ASK
;
DATA K EXMPTR,NCN
D HDR^DVBCUTIL
EXMSEL S REQDA=DA(1),Y=$$EXSRH^DVBCUTL4("Select EXAM TO CANCEL: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))") ;*Exam lookup function call
K DIC("S"),REQDA
N DVBACR
G:$D(DTOUT) EXIT I X=""!(X=U)&($D(CANC)) D BULL^DVBCCNC1 G LOOK
I $D(X),X=""!(X=U)&('$D(CANC)) G LOOK
I Y=-1 W *7," ??" G EXMSEL ;DVBA*2.7*102
I ($P(^DVB(396.4,+Y,0),U,4)["X")!($P(^DVB(396.4,+Y,0),U,4)="T") W *7," ??" G EXMSEL
S EXMPTR=+Y,EXMNM=$P(^DVB(396.4,+Y,0),U,3)
S EXMNM=$S($D(^DVB(396.6,EXMNM,0)):$P(^(0),U,1),1:"Unknown exam")
S STAT=$P(^TMP($J,EXMNM),U,1)
;AJF; Request Status Conversion
;S STAT=$$RSTAT^DVBCUTL8(STAT)
D STATCHK G:$D(NCN) DATA
D CNCLCHK G:NOFND=0 DATA G:$D(OUT) EXIT
;
; ** If selected an exam, enter Cancellation Reason.
S DVBCMSG=" for this "_EXMNM_" exam:",EXMCNC="" D CODE G:$D(OUT) EXIT
;RRA DVBA*2.7*194 filter out inactive cancelation reasons
S DIC="^DVB(396.5,",DIC(0)="QEAZ",DIC("S")="I $P(^(0),U,3)=1"
F D ^DIC Q:X'="" W " ??",!," Enter the response which best describes the reason for the cancellation."
I +Y<0 G EXIT
S DVBACR=+Y
;DVBA*2.7*214 VSR change four slashes to three slashes for validation
S DR="52///"_DVBACR_";.04///"_CCODE_";51////^S X=DUZ;50///NOW",DIE="^DVB(396.4,"
S DA=EXMPTR D ^DIE K DR,DIE G:($D(Y))!($D(DTOUT)) EXIT
S STAT=$P(^DVB(396.4,DA,0),U,4),REASON=+$P(^DVB(396.4,DA,"CAN"),U,3)
G:REASON=0 LOOK S $P(^TMP($J,EXMNM),U,1)=STAT
S ^TMP("DVBA",$J,9999999-$P(^DVB(396.4,EXMPTR,"CAN"),U,1))=CCODE
S CANC(EXMNM)=STAT_U_REASON D CNCLCHK I $D(OUT) G EXIT
K %DT G DATA
;
EXIT D KILL K CCODE,DVBCMSG,TCNCL,^TMP($J),EXMPTR,J,ANS,CNUM,DIR,DTOUT,FF,HD,HD2
G KILL^DVBCUTIL
;
KILL K TCNCL,DIC,DA,D0,D1,DFN,X,Y,OLDEXAM,JDR,REQDT,DR,EXMNM,NCN,STAT,%,NOFND,CANC,^TMP($J),%Y,Z,JY,JZ,DA,DIC,DIE,ALLCANC
K DVBCARY,DVBCRDAT,DVBCSITE,EXAM,I,PNAM,REASON,REQRO,REQSTR,SSN
Q
;
CNCLCHK S NOFND=0,Z=$P(^DVB(396.3,DA(1),0),U,18) Q:Z=6!(Z=7) K Z S I="" F J=0:0 S I=$O(^TMP($J,I)) Q:I="" I $P(^TMP($J,I),U,1)'="X"&($P(^(I),U,1)'="RX") S NOFND=1
Q:NOFND=1 W *7,!!,"Since all exams have been cancelled",!,"the entire request will be CANCELLED.",!! H 3
S DVBCMSG=" for this request:" D CODE
S DR="17///"_CCODE_";19///NOW;20////^S X=DUZ"
S DA=DA(1),DIE="^DVB(396.3," D ^DIE S DA=DA(1) D NOTIFY^DVBCCNC1
Q
;
STATCHK ;Check status
;AJF; Request Status Conversion
N STIEN,STNM
I +STAT S STAT=$$RSTAT^DVBCUTL8(STAT)
Q:STAT="P"!(STAT="N")!(STAT="NT")!(STAT="S")!(STAT="O")
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 cancelled.",!!
S NCN=1 H 2 Q
;NCN=no can do
Q
;
CODE S:'$D(DVBCMSG) DVBCMSG=":" W @IOF,!,"Please enter cancellation code"_DVBCMSG,! K OUT,%
S DIR("A")="CANCELLED BY"
S:'$D(EXMCNC) DIR(0)="SO^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
S:$D(EXMCNC) DIR(0)="S^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
D ^DIR S CCODE=Y
I CCODE=U&('$D(EXMCNC)) W !!,*7,"NO '^' ALLOWED AT THIS PROMPT" D CONTMES^DVBCUTL4 G CODE
I $D(DTOUT) D RQCODE^DVBCUTL2 S OUT=1 Q
I (X=""&('$D(EXMCNC))) W !,*7,"This is a required response." D CONTMES^DVBCUTL4 G CODE
CNCBY W !!,*7,"CANCELLED BY ",$S(CCODE="X":"MAS",CCODE="RX":"RO",1:"???"),", OK" S %=2 D YN^DICN I %=2 G CODE
I %=-1&('$D(EXMCNC)&('$D(DTOUT))) W !!,*7,"NO '^' ALLOWED AT THIS PROMPT" D CONTMES^DVBCUTL4 G CNCBY
K EXMCNC
I $D(DTOUT) D BULL^DVBCCNC1 S OUT=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCCNCL 5301 printed Dec 13, 2024@01:43:46 Page 2
DVBCCNCL ;ALB/GTS,LAB - 557/THM-2507 CANCEL REQUESTS, EXAMS ;05/09/2019
+1 ;;2.7;AMIE;**102,184,193,194,214**;Apr 10, 1995;Build 1
+2 ;
+3 GOTO EN
LOOK1 SET EXAM=$SELECT($DATA(^DVB(396.6,$PIECE(^DVB(396.4,JZ,0),U,3),0)):$PIECE(^(0),U,1),1:"Unknown")
+1 SET STAT=$PIECE(^DVB(396.4,JZ,0),U,4)
+2 SET $PIECE(^TMP($JOB,EXAM),U,1)=STAT_U_JZ
if STAT="C"
SET TCNCL=1
if STAT="T"
SET TCNCL=2
+3 QUIT
+4 ;
EN ;
+1 NEW DVBCARY,DVBCRDAT,DVBCSITE
+2 DO HOME^%ZIS
SET FF=IOF
SET HD="2507 Exam Veteran Selection"
SET HD2="2507 Test Cancellation"
+3 ;
LOOK DO KILL
WRITE @FF,!?(IOM-$LENGTH(HD)\2),HD,!?(IOM-$LENGTH(HD2)\2),HD2,!!
SET DIC("W")="D DICW^DVBCUTIL"
SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("A")="Select VETERAN: "
DO ^DIC
if X=""!(X=U)
GOTO EXIT
IF +Y<0
WRITE *7," ???"
GOTO LOOK
+1 SET DA(1)=+Y
SET DFN=$PIECE(Y,U,2)
SET STAT=$PIECE(^DVB(396.3,DA(1),0),U,18)
+2 ;AJF; Request Status Conversion
+3 SET STAT=$$RSTAT^DVBCUTL8(STAT)
+4 DO STATCHK
if $DATA(NCN)
GOTO LOOK
SET REQDT=$PIECE(^DVB(396.3,DA(1),0),U,2)
+5 DO GETS^DIQ(396.3,DA(1),"1;2","E","DVBCARY")
+6 SET DVBCRDAT=DVBCARY(396.3,DA(1)_",",1,"E")
+7 SET DVBCSITE=DVBCARY(396.3,DA(1)_",",2,"E")
+8 IF '$DATA(^DPT(DFN,0))
WRITE *7,!!,"Zeroth node for ^DPT record missing!",!!
HANG 3
GOTO LOOK
+9 SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")
KILL DICW
+10 ;used to screen bulletins
SET REQRO=$PIECE(^DVB(396.3,DA(1),0),U,3)
SET REQSTR=$PIECE(^(0),U,4)
+11 KILL TCNCL
FOR JZ=0:0
SET JZ=$ORDER(^DVB(396.4,"C",DA(1),JZ))
if JZ=""
QUIT
DO LOOK1
+12 ;
ASK IF $DATA(TCNCL)
WRITE *7,!!,"This request cannot be cancelled entirely because",!," one or more exams have ",$SELECT(TCNCL=2:"been transferred.",1:"been completed.")
+1 IF $TEST
WRITE !!,"However, you may cancel other individual exams.",!!,"Press RETURN "
READ ANS:60
if '$TEST!(ANS="^")
GOTO EXIT
GOTO DATA
+2 WRITE !!,"Do you want to cancel the entire exam"
SET %=2
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT
if %=1
GOTO ^DVBCCNC1
+3 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to cancel the ENTIRE exam or N to cancel ONLY selected exams",!!
GOTO ASK
+4 ;
DATA KILL EXMPTR,NCN
+1 DO HDR^DVBCUTIL
EXMSEL ;*Exam lookup function call
SET REQDA=DA(1)
SET Y=$$EXSRH^DVBCUTL4("Select EXAM TO CANCEL: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))")
+1 KILL DIC("S"),REQDA
+2 NEW DVBACR
+3 if $DATA(DTOUT)
GOTO EXIT
IF X=""!(X=U)&($DATA(CANC))
DO BULL^DVBCCNC1
GOTO LOOK
+4 IF $DATA(X)
IF X=""!(X=U)&('$DATA(CANC))
GOTO LOOK
+5 ;DVBA*2.7*102
IF Y=-1
WRITE *7," ??"
GOTO EXMSEL
+6 IF ($PIECE(^DVB(396.4,+Y,0),U,4)["X")!($PIECE(^DVB(396.4,+Y,0),U,4)="T")
WRITE *7," ??"
GOTO EXMSEL
+7 SET EXMPTR=+Y
SET EXMNM=$PIECE(^DVB(396.4,+Y,0),U,3)
+8 SET EXMNM=$SELECT($DATA(^DVB(396.6,EXMNM,0)):$PIECE(^(0),U,1),1:"Unknown exam")
+9 SET STAT=$PIECE(^TMP($JOB,EXMNM),U,1)
+10 ;AJF; Request Status Conversion
+11 ;S STAT=$$RSTAT^DVBCUTL8(STAT)
+12 DO STATCHK
if $DATA(NCN)
GOTO DATA
+13 DO CNCLCHK
if NOFND=0
GOTO DATA
if $DATA(OUT)
GOTO EXIT
+14 ;
+15 ; ** If selected an exam, enter Cancellation Reason.
+16 SET DVBCMSG=" for this "_EXMNM_" exam:"
SET EXMCNC=""
DO CODE
if $DATA(OUT)
GOTO EXIT
+17 ;RRA DVBA*2.7*194 filter out inactive cancelation reasons
+18 SET DIC="^DVB(396.5,"
SET DIC(0)="QEAZ"
SET DIC("S")="I $P(^(0),U,3)=1"
+19 FOR
DO ^DIC
if X'=""
QUIT
WRITE " ??",!," Enter the response which best describes the reason for the cancellation."
+20 IF +Y<0
GOTO EXIT
+21 SET DVBACR=+Y
+22 ;DVBA*2.7*214 VSR change four slashes to three slashes for validation
+23 SET DR="52///"_DVBACR_";.04///"_CCODE_";51////^S X=DUZ;50///NOW"
SET DIE="^DVB(396.4,"
+24 SET DA=EXMPTR
DO ^DIE
KILL DR,DIE
if ($DATA(Y))!($DATA(DTOUT))
GOTO EXIT
+25 SET STAT=$PIECE(^DVB(396.4,DA,0),U,4)
SET REASON=+$PIECE(^DVB(396.4,DA,"CAN"),U,3)
+26 if REASON=0
GOTO LOOK
SET $PIECE(^TMP($JOB,EXMNM),U,1)=STAT
+27 SET ^TMP("DVBA",$JOB,9999999-$PIECE(^DVB(396.4,EXMPTR,"CAN"),U,1))=CCODE
+28 SET CANC(EXMNM)=STAT_U_REASON
DO CNCLCHK
IF $DATA(OUT)
GOTO EXIT
+29 KILL %DT
GOTO DATA
+30 ;
EXIT DO KILL
KILL CCODE,DVBCMSG,TCNCL,^TMP($JOB),EXMPTR,J,ANS,CNUM,DIR,DTOUT,FF,HD,HD2
+1 GOTO KILL^DVBCUTIL
+2 ;
KILL KILL TCNCL,DIC,DA,D0,D1,DFN,X,Y,OLDEXAM,JDR,REQDT,DR,EXMNM,NCN,STAT,%,NOFND,CANC,^TMP($JOB),%Y,Z,JY,JZ,DA,DIC,DIE,ALLCANC
+1 KILL DVBCARY,DVBCRDAT,DVBCSITE,EXAM,I,PNAM,REASON,REQRO,REQSTR,SSN
+2 QUIT
+3 ;
CNCLCHK SET NOFND=0
SET Z=$PIECE(^DVB(396.3,DA(1),0),U,18)
if Z=6!(Z=7)
QUIT
KILL Z
SET I=""
FOR J=0:0
SET I=$ORDER(^TMP($JOB,I))
if I=""
QUIT
IF $PIECE(^TMP($JOB,I),U,1)'="X"&($PIECE(^(I),U,1)'="RX")
SET NOFND=1
+1 if NOFND=1
QUIT
WRITE *7,!!,"Since all exams have been cancelled",!,"the entire request will be CANCELLED.",!!
HANG 3
+2 SET DVBCMSG=" for this request:"
DO CODE
+3 SET DR="17///"_CCODE_";19///NOW;20////^S X=DUZ"
+4 SET DA=DA(1)
SET DIE="^DVB(396.3,"
DO ^DIE
SET DA=DA(1)
DO NOTIFY^DVBCCNC1
+5 QUIT
+6 ;
STATCHK ;Check status
+1 ;AJF; Request Status Conversion
+2 NEW STIEN,STNM
+3 IF +STAT
SET STAT=$$RSTAT^DVBCUTL8(STAT)
+4 if STAT="P"!(STAT="N")!(STAT="NT")!(STAT="S")!(STAT="O")
QUIT
+5 SET STIEN=$ORDER(^DVB(396.33,"C",STAT,""))
SET STNM=$$RTSTAT^DVBCUTL8(STIEN)
+6 WRITE !!,*7,"This request has a status of ",STNM," and can't be cancelled.",!!
+7 SET NCN=1
HANG 2
QUIT
+8 ;NCN=no can do
+9 QUIT
+10 ;
CODE if '$DATA(DVBCMSG)
SET DVBCMSG=":"
WRITE @IOF,!,"Please enter cancellation code"_DVBCMSG,!
KILL OUT,%
+1 SET DIR("A")="CANCELLED BY"
+2 if '$DATA(EXMCNC)
SET DIR(0)="SO^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
+3 if $DATA(EXMCNC)
SET DIR(0)="S^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
+4 DO ^DIR
SET CCODE=Y
+5 IF CCODE=U&('$DATA(EXMCNC))
WRITE !!,*7,"NO '^' ALLOWED AT THIS PROMPT"
DO CONTMES^DVBCUTL4
GOTO CODE
+6 IF $DATA(DTOUT)
DO RQCODE^DVBCUTL2
SET OUT=1
QUIT
+7 IF (X=""&('$DATA(EXMCNC)))
WRITE !,*7,"This is a required response."
DO CONTMES^DVBCUTL4
GOTO CODE
CNCBY WRITE !!,*7,"CANCELLED BY ",$SELECT(CCODE="X":"MAS",CCODE="RX":"RO",1:"???"),", OK"
SET %=2
DO YN^DICN
IF %=2
GOTO CODE
+1 IF %=-1&('$DATA(EXMCNC)&('$DATA(DTOUT)))
WRITE !!,*7,"NO '^' ALLOWED AT THIS PROMPT"
DO CONTMES^DVBCUTL4
GOTO CNCBY
+2 KILL EXMCNC
+3 IF $DATA(DTOUT)
DO BULL^DVBCCNC1
SET OUT=1
QUIT
+4 QUIT
