source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCBULL.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1DVBCBULL ;ALB/GTS-557/THM-SEND CANCELLATION BULLETIN ; 6/25/91 11:01 AM
2 ;;2.7;AMIE;**42**;Apr 10, 1995
3 ;
4 K ^TMP("DVBC","BULL",$J),^TMP("DVBC","CMNT",$J) S DIC="^TMP(""DVBC"",""CMNT"",$J,99,",DWPK=1 W @IOF,!!,"Cancellation comments:",!! D EN^DIWE
5 K DWPK I $O(^TMP("DVBC","CMNT",$J,99,0))]"" S ^TMP("DVBC","BULL",$J,98,0)=" ",^TMP("DVBC","BULL",$J,97,0)="==========================< Additional comments >=========================="
6 F I=0:0 S I=$O(^TMP("DVBC","CMNT",$J,99,I)) Q:I="" S ^TMP("DVBC","BULL",$J,(I+99),0)=^TMP("DVBC","CMNT",$J,99,I,0)
7 K ^TMP("DVBC","CMNT",$J) S $P(DOTS,".",45)="." W !!,"A bulletin will now be sent to the 2507 Cancellation mail group.",!
8 ;
9GO S L=1,^TMP("DVBC","BULL",$J,L,0)="The following veteran had one or more 2507 exams cancelled:",L=L+1
10 S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
11 S ^TMP("DVBC","BULL",$J,L,0)=" Name: "_PNAM_" SSN: "_"XXXXX"_$E(SSN,6,9)_" "_"C-Number: "_CNUM,L=L+1
12 S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
13 S ^TMP("DVBC","BULL",$J,L,0)="Exams cancelled Reason",L=L+1
14 S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
15 S EXAM="",RSTAT=$P(^DVB(396.3,REQDA,0),U,18)
16 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 REAS=+$P(CANC(EXAM),U,2) D EXAMS
17 S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1,COMP=1,CMPC=0
18 S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1 K ^TMP("DVBC","CMNT",$J)
19 I RSTAT["X" S ^TMP("DVBC","BULL",$J,L,0)=" *** All exams on this request are now CANCELLED. ***",L=L+1,^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1 G SEND
20 S ECNT=0
21 F JZ=0:0 S JZ=$O(^DVB(396.4,"C",REQDA,JZ)) Q:JZ="" S STAT=$P(^DVB(396.4,JZ,0),U,4) S:STAT="C" CMPC=1 I STAT'="C"&(STAT'["X") S COMP=0,ECNT=ECNT+1
22 ;CMPC=completed exam COMP=open exam
23 ;both are toggled, depending on exam status. Both must be 1 to put release banner on message
24 I RSTAT'["X",COMP=0 S ^TMP("DVBC","BULL",$J,L,0)=" *** There "_$S(ECNT=1:"is",1:"are")_" still "_ECNT_" exam"_$S(ECNT=1:"",1:"s")_" open on this request. ***",L=L+1,^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1 G SEND
25 I COMP=1&(CMPC=1),RSTAT'["X" S ^TMP("DVBC","BULL",$J,L,0)=" *** This request is now COMPLETE and should be released by MAS ***",L=L+1
26 I COMP=1&(CMPC=1),RSTAT'["X" S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1 ;spacer
27 ;
28SEND ;remote sites get bulletins only on total cancellations
29 S DIC="^XMB(3.8,",DIC(0)="QM",X="DVBA C 2507 CANCELLATION" D ^DIC S MG=+Y I +Y<0 W !!,*7,"2507 mail group NOT found! Bulletin not sent.",!! H 3 Q
30 F JI=0:0 S JI=$O(^XMB(3.8,MG,1,"B",JI)) Q:JI="" S XMY(JI)=""
31 F JI=0:0 S JI=$O(XMY(JI)) Q:JI=""!(+JI=0) I '$D(^VA(200,JI,2,+REQRO))&'$D(^VA(200,JI,2,+REQRO))&('$D(^XUSEC("DVBA C SUPERVISOR",JI))) K XMY(JI)
32 S:REQSTR="" REQSTR=.5 S XMY(REQSTR)="",XMY(DUZ)="",XMSUB="Cancellation of 2507 Exams",XMTEXT="^TMP(""DVBC"",""BULL"",$J,",XMDUZ=DUZ
33 I '$D(^VA(200,DUZ,.15)) S XMY(XMDUZ)="" G XMD
34 I $D(^VA(200,DUZ,.15))&($P(^VA(200,DUZ,.15),"^",1)="") S XMY(XMDUZ)="" G XMD
35 I $D(^VA(200,DUZ,.15)) S XMY($P(^VA(200,DUZ,.15),"^",1))=""
36XMD D ^XMD
37 K ^TMP("DVBC","BULL",$J),XMDUZ,DOTS,COMP,CMPC,XEXAM,REASON,L,JI,JY,XMY,XMSUB,XMTEXT,XMDUZ,ECNT
38 Q
39 ;
40EXAMS S REASON=$S($D(^DVB(396.5,+REAS,0)):$P(^(0),U,1),1:"Undetermined")
41 S XEXAM=$E(EXAM,1,25),^TMP("DVBC","BULL",$J,L,0)=" "_XEXAM_" "_$E(DOTS,1,35-$L(XEXAM))_" "_REASON S L=L+1
42 Q
Note: See TracBrowser for help on using the repository browser.