- 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 Mar 13, 2025@20:48:27 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
