source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCCNCL.m@ 677

Last change on this file since 677 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1DVBCCNCL ;ALB/GTS-557/THM-2507 CANCEL REQUESTS ,EXAMS ; 9/23/91 9:25 AM
2 ;;2.7;AMIE;**102**;Apr 10, 1995
3 ;
4 G EN
5LOOK1 S EXAM=$S($D(^DVB(396.6,$P(^DVB(396.4,JZ,0),U,3),0)):$P(^(0),U,1),1:"Unknown")
6 S STAT=$P(^DVB(396.4,JZ,0),U,4)
7 S $P(^TMP($J,EXAM),U,1)=STAT_U_JZ S:STAT="C" TCNCL=1 S:STAT="T" TCNCL=2
8 Q
9 ;
10EN ;
11 D HOME^%ZIS S FF=IOF,HD="2507 Exam Veteran Selection",HD2="2507 Test Cancellation"
12 ;
13LOOK 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
14 S DA(1)=+Y,DFN=$P(Y,U,2),STAT=$P(^DVB(396.3,DA(1),0),U,18) D STATCHK G:$D(NCN) LOOK S REQDT=$P(^DVB(396.3,DA(1),0),U,2)
15 I '$D(^DPT(DFN,0)) W *7,!!,"Zeroth node for ^DPT record missing!",!! H 3 G LOOK
16 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
17 S REQRO=$P(^DVB(396.3,DA(1),0),U,3),REQSTR=$P(^(0),U,4) ;used to screen bulletins
18 K TCNCL F JZ=0:0 S JZ=$O(^DVB(396.4,"C",DA(1),JZ)) Q:JZ="" D LOOK1
19 ;
20ASK 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.")
21 I W !!,"However, you may cancel other individual exams.",!!,"Press RETURN " R ANS:60 G:'$T!(ANS="^") EXIT G DATA
22 W !!,"Do you want to cancel the entire exam" S %=2 D YN^DICN G:$D(DTOUT)!(%<0) EXIT G:%=1 ^DVBCCNC1
23 I $D(%Y),%Y["?" W !!,"Enter Y to cancel the ENTIRE exam or N to cancel ONLY selected exams",!! G ASK
24 ;
25DATA K EXMPTR,NCN
26 D HDR^DVBCUTIL
27EXMSEL S REQDA=DA(1),Y=$$EXSRH^DVBCUTL4("Select EXAM TO CANCEL: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))") ;*Exam lookup function call
28 K DIC("S"),REQDA
29 G:$D(DTOUT) EXIT I X=""!(X=U)&($D(CANC)) D BULL^DVBCCNC1 G LOOK
30 I $D(X),X=""!(X=U)&('$D(CANC)) G LOOK
31 I Y=-1 W *7," ??" G EXMSEL ;DVBA*2.7*102
32 I ($P(^DVB(396.4,+Y,0),U,4)["X")!($P(^DVB(396.4,+Y,0),U,4)="T") W *7," ??" G EXMSEL
33 S EXMPTR=+Y,EXMNM=$P(^DVB(396.4,+Y,0),U,3)
34 S EXMNM=$S($D(^DVB(396.6,EXMNM,0)):$P(^(0),U,1),1:"Unknown exam")
35 S STAT=$P(^TMP($J,EXMNM),U,1) D STATCHK G:$D(NCN) DATA
36 D CNCLCHK G:NOFND=0 DATA G:$D(OUT) EXIT
37 ;
38 ; ** If selected an exam, enter Cancellation Reason.
39 S DVBCMSG=" for this "_EXMNM_" exam:",EXMCNC="" D CODE G:$D(OUT) EXIT
40 S DR="52R;.04////"_CCODE_";51////^S X=DUZ;50///NOW",DIE="^DVB(396.4,"
41 S DA=EXMPTR D ^DIE K DR,DIE G:($D(Y))!($D(DTOUT)) EXIT
42 S STAT=$P(^DVB(396.4,DA,0),U,4),REASON=+$P(^DVB(396.4,DA,"CAN"),U,3)
43 G:REASON=0 LOOK S $P(^TMP($J,EXMNM),U,1)=STAT
44 S ^TMP("DVBA",$J,9999999-$P(^DVB(396.4,EXMPTR,"CAN"),U,1))=CCODE
45 S CANC(EXMNM)=STAT_U_REASON D CNCLCHK I $D(OUT) G EXIT
46 K %DT G DATA
47 ;
48EXIT D KILL K CCODE,DVBCMSG,TCNCL,^TMP($J),EXMPTR,J G KILL^DVBCUTIL
49 ;
50KILL 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
51 Q
52 ;
53CNCLCHK S NOFND=0,Z=$P(^DVB(396.3,DA(1),0),U,18) Q:Z="X"!(Z="RX") 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
54 Q:NOFND=1 W *7,!!,"Since all exams have been cancelled",!,"the entire request will be CANCELLED.",!! H 3
55 S DVBCMSG=" for this request:" D CODE
56 S DR="17////"_CCODE_";19///NOW;20////^S X=DUZ"
57 S DA=DA(1),DIE="^DVB(396.3," D ^DIE S DA=DA(1) D NOTIFY^DVBCCNC1
58 Q
59 ;
60STATCHK Q:STAT="P"!(STAT="N")!(STAT="NT")!(STAT="S")!(STAT="O")
61 W !!,*7,"This exam or request has been ",$S(STAT="RX":"cancelled by the RO",STAT="X":"cancelled by MAS",STAT="T":"transcribed",STAT="R":"released",STAT="C":"completed",STAT="CT":"completed, transferred out",1:"given an incorrect status"),".",!!
62 S NCN=1 H 2 Q
63 ;NCN=no can do
64 Q
65 ;
66CODE S:'$D(DVBCMSG) DVBCMSG=":" W @IOF,!,"Please enter cancellation code"_DVBCMSG,! K OUT,%
67 S DIR("A")="CANCELLED BY"
68 S:'$D(EXMCNC) DIR(0)="SO^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
69 S:$D(EXMCNC) DIR(0)="S^X:MAS CANCELLATION;RX:REGIONAL OFFICE CANCELLATION"
70 D ^DIR S CCODE=Y
71 I CCODE=U&('$D(EXMCNC)) W !!,*7,"NO '^' ALLOWED AT THIS PROMPT" D CONTMES^DVBCUTL4 G CODE
72 I $D(DTOUT) D RQCODE^DVBCUTL2 S OUT=1 Q
73 I (X=""&('$D(EXMCNC))) W !,*7,"This is a required response." D CONTMES^DVBCUTL4 G CODE
74CNCBY W !!,*7,"CANCELLED BY ",$S(CCODE="X":"MAS",CCODE="RX":"RO",1:"???"),", OK" S %=2 D YN^DICN I %=2 G CODE
75 I %=-1&('$D(EXMCNC)&('$D(DTOUT))) W !!,*7,"NO '^' ALLOWED AT THIS PROMPT" D CONTMES^DVBCUTL4 G CNCBY
76 K EXMCNC
77 I $D(DTOUT) D BULL^DVBCCNC1 S OUT=1 Q
78 Q
Note: See TracBrowser for help on using the repository browser.