DVBCCNC1 ;ALB ISC/THM,LAB - CANCEL ENTIRE REQUEST ;05/10/2019
;;2.7;AMIE;**193,194,214**;Apr 10, 1995;Build 1
;
ALL K NONE W ! S ALLCANC=1,DIC="^DVB(396.5,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=1",DIC("A")="Enter REASON FOR CANCELLATION: " D ^DIC G:X=""!(X=U)!(+Y'>0) EXIT^DVBCCNCL S REAS=+Y
;
BY W !,"Cancelled by (M)AS or (R)O? M// "
R BY:DTIME
G:'$T!(BY=U) EXIT^DVBCCNCL
I BY=""!(BY="m") W:BY="" "M" S BY="M" ;echo selection
S:BY="r" BY="R"
I BY'?1"M"&(BY'?1"R") W !!,"Enter M to indicate cancellation by MAS or",!," R to indicate cancellation by the Regional Office.",!! G BY
W $S(BY="M":"AS",BY="R":"O",1:"") ;finish echo of selection
;
BY1 W *7,!!,"Cancelled by ",$S(BY="":"MAS",BY="M":"MAS",BY="R":"RO",1:"Unknown source")," Ok" S %=2 D YN^DICN G:$D(DTOUT)!(%<0) EXIT^DVBCCNCL
I $D(%Y),%Y["?" W !!,"Enter Y to verify or N to reselect",! G BY1
I $D(%),%'=1 G BY
S BY=$S(BY="R":"RX",BY="M":"X",1:"")
W !!
F JJZ=0:0 S JJZ=$O(^DVB(396.4,"C",DA(1),JJZ)) Q:JJZ="" S STAT=$P(^DVB(396.4,JJZ,0),U,4) I STAT="O" D ALL1
I '$D(CANC) S CANC("None - (Request only)")=BY_U_REAS ;used in case of request logging error (system)
H 1 S DA=DA(1),(DIC,DIE)="^DVB(396.3,",DR="17///"_BY_";19///NOW;20////^S X=DUZ" D ^DIE,NOTIFY,BULL I $D(OUT) G EXIT^DVBCCNCL
G LOOK^DVBCCNCL
;
ALL1 S EXMPTR=$P(^DVB(396.4,JJZ,0),U,3),EXMNM=$S($D(^DVB(396.6,+EXMPTR,0)):$P(^(0),U,1),1:"Unknown exam"_" ("_+EXMPTR_")") K EXMPTR ;show deleted exam
;DVBA*2.7*214 changed //// to /// to allow for validation of data
S DR=".04///"_BY_";52///"_REAS_";51////^S X=DUZ;50///NOW",DA=JJZ
S (DIC,DIE)="^DVB(396.4," D ^DIE
I '$D(Y) W:$X>50 ! W:$L(EXMNM)>25&($X>45) ! W EXMNM," cancelled, " S CANC(EXMNM)=BY_U_REAS
I $D(Y) W !!!,"Y = ",Y
I $D(Y) W *7,!,"Cancellation error on ",EXMNM," exam !" H 2
Q
;
NOTIFY S X=$P(^DVB(396.3,DA,0),U,18)
;AJF; Request Status Conversion
S X=$$RSTAT^DVBCUTL8(X)
I X="RX"!(X="X") W !!,"Entire exam is now CANCELLED.",!! H 1 Q
I X'="RX"&(X'="X") W *7,!!,"Cancellation error !",!! H 3 S OUT=1
Q
;
BULL Q:'$D(CANC) S SEND=1,EXAM="" F JI=0:0 S EXAM=$O(CANC(EXAM)) Q:EXAM="" I $P(CANC(EXAM),U,1)'="X"&($P(CANC(EXAM),U,1)'="RX") S SEND=0 Q
I SEND=0 W *7,!!,"An error has occurred during cancellation - bulletin will not be sent!",!!,*7 H 3 Q
K OWNDOM,XDOM,DOMAIN,DOMNUM
I $D(ALLCANC) S OWNDOM=$P(^DVB(396.3,DA(1),0),U,22) I OWNDOM]"" S XDOM=$S($D(^DIC(4.2,OWNDOM,0)):^(0),1:"") S DOMAIN=$P(XDOM,U,1),DOMNUM=$S(+$P(XDOM,U,3)>0:+$P(XDOM,U,3),1:OWNDOM)
I $D(ALLCANC),OWNDOM]"" I +DOMNUM>0 S XMY("G.DVBA C 2507 CANCELLATION@"_DOMAIN)=DOMNUM W !!,*7,"I am sending a copy of this cancellation to the",!,"cancellation mail group at "_DOMAIN,!,"since this was transferred in.",!! H 2
I SEND=1 S REQDA=DA(1) D ^DVBCBULL I $D(ALLCANC),OWNDOM]"",+DOMNUM>0 S REQDA=DA(1) D EN1^DVBCXFRE
K ALLCANC,CANC,SEND,OWNDOM,DOMNUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCCNC1 2882 printed Dec 13, 2024@01:43:45 Page 2
DVBCCNC1 ;ALB ISC/THM,LAB - CANCEL ENTIRE REQUEST ;05/10/2019
+1 ;;2.7;AMIE;**193,194,214**;Apr 10, 1995;Build 1
+2 ;
ALL KILL NONE
WRITE !
SET ALLCANC=1
SET DIC="^DVB(396.5,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,3)=1"
SET DIC("A")="Enter REASON FOR CANCELLATION: "
DO ^DIC
if X=""!(X=U)!(+Y'>0)
GOTO EXIT^DVBCCNCL
SET REAS=+Y
+1 ;
BY WRITE !,"Cancelled by (M)AS or (R)O? M// "
+1 READ BY:DTIME
+2 if '$TEST!(BY=U)
GOTO EXIT^DVBCCNCL
+3 ;echo selection
IF BY=""!(BY="m")
if BY=""
WRITE "M"
SET BY="M"
+4 if BY="r"
SET BY="R"
+5 IF BY'?1"M"&(BY'?1"R")
WRITE !!,"Enter M to indicate cancellation by MAS or",!," R to indicate cancellation by the Regional Office.",!!
GOTO BY
+6 ;finish echo of selection
WRITE $SELECT(BY="M":"AS",BY="R":"O",1:"")
+7 ;
BY1 WRITE *7,!!,"Cancelled by ",$SELECT(BY="":"MAS",BY="M":"MAS",BY="R":"RO",1:"Unknown source")," Ok"
SET %=2
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT^DVBCCNCL
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to verify or N to reselect",!
GOTO BY1
+2 IF $DATA(%)
IF %'=1
GOTO BY
+3 SET BY=$SELECT(BY="R":"RX",BY="M":"X",1:"")
+4 WRITE !!
+5 FOR JJZ=0:0
SET JJZ=$ORDER(^DVB(396.4,"C",DA(1),JJZ))
if JJZ=""
QUIT
SET STAT=$PIECE(^DVB(396.4,JJZ,0),U,4)
IF STAT="O"
DO ALL1
+6 ;used in case of request logging error (system)
IF '$DATA(CANC)
SET CANC("None - (Request only)")=BY_U_REAS
+7 HANG 1
SET DA=DA(1)
SET (DIC,DIE)="^DVB(396.3,"
SET DR="17///"_BY_";19///NOW;20////^S X=DUZ"
DO ^DIE
DO NOTIFY
DO BULL
IF $DATA(OUT)
GOTO EXIT^DVBCCNCL
+8 GOTO LOOK^DVBCCNCL
+9 ;
ALL1 ;show deleted exam
SET EXMPTR=$PIECE(^DVB(396.4,JJZ,0),U,3)
SET EXMNM=$SELECT($DATA(^DVB(396.6,+EXMPTR,0)):$PIECE(^(0),U,1),1:"Unknown exam"_" ("_+EXMPTR_")")
KILL EXMPTR
+1 ;DVBA*2.7*214 changed //// to /// to allow for validation of data
+2 SET DR=".04///"_BY_";52///"_REAS_";51////^S X=DUZ;50///NOW"
SET DA=JJZ
+3 SET (DIC,DIE)="^DVB(396.4,"
DO ^DIE
+4 IF '$DATA(Y)
if $X>50
WRITE !
if $LENGTH(EXMNM)>25&($X>45)
WRITE !
WRITE EXMNM," cancelled, "
SET CANC(EXMNM)=BY_U_REAS
+5 IF $DATA(Y)
WRITE !!!,"Y = ",Y
+6 IF $DATA(Y)
WRITE *7,!,"Cancellation error on ",EXMNM," exam !"
HANG 2
+7 QUIT
+8 ;
NOTIFY SET X=$PIECE(^DVB(396.3,DA,0),U,18)
+1 ;AJF; Request Status Conversion
+2 SET X=$$RSTAT^DVBCUTL8(X)
+3 IF X="RX"!(X="X")
WRITE !!,"Entire exam is now CANCELLED.",!!
HANG 1
QUIT
+4 IF X'="RX"&(X'="X")
WRITE *7,!!,"Cancellation error !",!!
HANG 3
SET OUT=1
+5 QUIT
+6 ;
BULL if '$DATA(CANC)
QUIT
SET SEND=1
SET EXAM=""
FOR JI=0:0
SET EXAM=$ORDER(CANC(EXAM))
if EXAM=""
QUIT
IF $PIECE(CANC(EXAM),U,1)'="X"&($PIECE(CANC(EXAM),U,1)'="RX")
SET SEND=0
QUIT
+1 IF SEND=0
WRITE *7,!!,"An error has occurred during cancellation - bulletin will not be sent!",!!,*7
HANG 3
QUIT
+2 KILL OWNDOM,XDOM,DOMAIN,DOMNUM
+3 IF $DATA(ALLCANC)
SET OWNDOM=$PIECE(^DVB(396.3,DA(1),0),U,22)
IF OWNDOM]""
SET XDOM=$SELECT($DATA(^DIC(4.2,OWNDOM,0)):^(0),1:"")
SET DOMAIN=$PIECE(XDOM,U,1)
SET DOMNUM=$SELECT(+$PIECE(XDOM,U,3)>0:+$PIECE(XDOM,U,3),1:OWNDOM)
+4 IF $DATA(ALLCANC)
IF OWNDOM]""
IF +DOMNUM>0
SET XMY("G.DVBA C 2507 CANCELLATION@"_DOMAIN)=DOMNUM
WRITE !!,*7,"I am sending a copy of this cancellation to the",!,"cancellation mail group at "_DOMAIN,!,"since this was transferred in.",!!
HANG 2
+5 IF SEND=1
SET REQDA=DA(1)
DO ^DVBCBULL
IF $DATA(ALLCANC)
IF OWNDOM]""
IF +DOMNUM>0
SET REQDA=DA(1)
DO EN1^DVBCXFRE
+6 KILL ALLCANC,CANC,SEND,OWNDOM,DOMNUM
+7 QUIT
