DVBCBULL ;ALB/GTS - 557/THM-SEND CANCELLATION BULLETIN ; 6/25/91 11:01 AM
;;2.7;AMIE;**42,184,189,193**;Apr 10, 1995;Build 84
;
N MSG1,MERR1,CNT1,MSG2,MERR2,CNT2,RIEN
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
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 >=========================="
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)
K ^TMP("DVBC","CMNT",$J) S $P(DOTS,".",45)="." W !!,"A bulletin will now be sent to the 2507 Cancellation mail group.",!
;
;Build Claim Type Info
S RIEN=DA
K ^TMP($J,"DVBCBULL","CT")
N MSG1,MERR1,CTR1
S (MSG1,MERR1)="",CTR1=1
D GETS^DIQ(396.3,RIEN_",","9.1*","E","MSG1","MERR1")
I $G(MERR1)'="" S ^TMP($J,"DVBCBULL","CT",CTR1)="ERROR GETTING CLAIM TYPE CODES"
S J=""
F S J=$O(MSG1(396.32,J)) Q:J="" D
. S CTR1=CTR1+1
. S ^TMP($J,"DVBCBULL","CT",CTR1)=$G(MSG1(396.32,J,.01,"E"))
;
;Build Special Considerations Info
K ^TMP($J,"DVBCBULL","SC")
N MSG2,MERR2,CTR2
S (MSG2,MERR2)="",CTR2=1
D GETS^DIQ(396.3,RIEN,"50*","IE","MSG2","MERR2")
I $G(MERR2)'="" S ^TMP($J,"DVBCBULL","SC",CTR2)="ERROR GETTING SPECIAL CONSIDERATION CODES"
S J=""
F S J=$O(MSG2(396.31,J)) Q:J="" D
. S CTR2=CTR2+1
. S ^TMP($J,"DVBCBULL","SC",CTR2)=$G(MSG2(396.31,J,.01,"E"))
;
GO S L=1,^TMP("DVBC","BULL",$J,L,0)="The following veteran had one or more 2507 exams cancelled:",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" DFN: `"_DFN_$E(" ",1,20-$L(DFN))_"SITE: "_DVBCSITE,L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" REQUEST DATE: "_DVBCRDAT,L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" Claim Type:",L=L+1
F S J=$O(^TMP($J,"DVBCBULL","CT",J)) Q:J="" D
. S ^TMP("DVBC","BULL",$J,L,0)=" "_^TMP($J,"DVBCBULL","CT",J),L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" Special Consideration(s):",L=L+1
S J=""
F S J=$O(^TMP($J,"DVBCBULL","SC",J)) Q:J="" D
. S ^TMP("DVBC","BULL",$J,L,0)=" "_^TMP($J,"DVBCBULL","SC",J),L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)="Exams cancelled Reason",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S EXAM="",RSTAT=$P(^DVB(396.3,REQDA,0),U,18)
;AJF;Request Status conversion
S RSTAT=$$RSTAT^DVBCUTL8(RSTAT)
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
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1,COMP=1,CMPC=0
;
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)="** NOTE: To view the patient using the DFN, paste the DFN number into the **",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)="** CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to **",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)="** include the ' (backward-apostrophe) character. **",L=L+1
S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1
;
K ^TMP("DVBC","CMNT",$J)
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
S ^TMP("DVBC","BULL",$J,L,0)="** This is an auto-generated email. Do not respond to this email address. **",L=L+1
G SEND
S ECNT=0
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
;CMPC=completed exam COMP=open exam
;both are toggled, depending on exam status. Both must be 1 to put release banner on message
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
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
I COMP=1&(CMPC=1),RSTAT'["X" S ^TMP("DVBC","BULL",$J,L,0)=" ",L=L+1 ;spacer
;
SEND ;remote sites get bulletins only on total cancellations
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
F JI=0:0 S JI=$O(^XMB(3.8,MG,1,"B",JI)) Q:JI="" S XMY(JI)=""
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)
S:REQSTR="" REQSTR=.5 S XMY(REQSTR)="",XMY(DUZ)="",XMSUB="Cancellation of 2507 Exams",XMTEXT="^TMP(""DVBC"",""BULL"",$J,",XMDUZ=DUZ
I '$D(^VA(200,DUZ,.15)) S XMY(XMDUZ)="" G XMD
I $D(^VA(200,DUZ,.15))&($P(^VA(200,DUZ,.15),"^",1)="") S XMY(XMDUZ)="" G XMD
I $D(^VA(200,DUZ,.15)) S XMY($P(^VA(200,DUZ,.15),"^",1))=""
XMD D ^XMD
K ^TMP("DVBC","BULL",$J),XMDUZ,DOTS,COMP,CMPC,XEXAM,REASON,L,JI,JY,XMY,XMSUB,XMTEXT,XMDUZ,ECNT
K ^TMP($J,"DVBCBULL","CT"),^TMP($J,"DVBCBULL","SC")
Q
;
EXAMS S REASON=$S($D(^DVB(396.5,+REAS,0)):$P(^(0),U,1),1:"Undetermined")
S XEXAM=$E(EXAM,1,25),^TMP("DVBC","BULL",$J,L,0)=" "_XEXAM_" "_$E(DOTS,1,35-$L(XEXAM))_" "_REASON S L=L+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCBULL 5354 printed Sep 02, 2024@18:29:04 Page 2
DVBCBULL ;ALB/GTS - 557/THM-SEND CANCELLATION BULLETIN ; 6/25/91 11:01 AM
+1 ;;2.7;AMIE;**42,184,189,193**;Apr 10, 1995;Build 84
+2 ;
+3 NEW MSG1,MERR1,CNT1,MSG2,MERR2,CNT2,RIEN
+4 KILL ^TMP("DVBC","BULL",$JOB),^TMP("DVBC","CMNT",$JOB)
SET DIC="^TMP(""DVBC"",""CMNT"",$J,99,"
SET DWPK=1
WRITE @IOF,!!,"Cancellation comments:",!!
DO EN^DIWE
+5 KILL DWPK
IF $ORDER(^TMP("DVBC","CMNT",$JOB,99,0))]""
SET ^TMP("DVBC","BULL",$JOB,98,0)=" "
SET ^TMP("DVBC","BULL",$JOB,97,0)="==========================< Additional comments >=========================="
+6 FOR I=0:0
SET I=$ORDER(^TMP("DVBC","CMNT",$JOB,99,I))
if I=""
QUIT
SET ^TMP("DVBC","BULL",$JOB,(I+99),0)=^TMP("DVBC","CMNT",$JOB,99,I,0)
+7 KILL ^TMP("DVBC","CMNT",$JOB)
SET $PIECE(DOTS,".",45)="."
WRITE !!,"A bulletin will now be sent to the 2507 Cancellation mail group.",!
+8 ;
+9 ;Build Claim Type Info
+10 SET RIEN=DA
+11 KILL ^TMP($JOB,"DVBCBULL","CT")
+12 NEW MSG1,MERR1,CTR1
+13 SET (MSG1,MERR1)=""
SET CTR1=1
+14 DO GETS^DIQ(396.3,RIEN_",","9.1*","E","MSG1","MERR1")
+15 IF $GET(MERR1)'=""
SET ^TMP($JOB,"DVBCBULL","CT",CTR1)="ERROR GETTING CLAIM TYPE CODES"
+16 SET J=""
+17 FOR
SET J=$ORDER(MSG1(396.32,J))
if J=""
QUIT
Begin DoDot:1
+18 SET CTR1=CTR1+1
+19 SET ^TMP($JOB,"DVBCBULL","CT",CTR1)=$GET(MSG1(396.32,J,.01,"E"))
End DoDot:1
+20 ;
+21 ;Build Special Considerations Info
+22 KILL ^TMP($JOB,"DVBCBULL","SC")
+23 NEW MSG2,MERR2,CTR2
+24 SET (MSG2,MERR2)=""
SET CTR2=1
+25 DO GETS^DIQ(396.3,RIEN,"50*","IE","MSG2","MERR2")
+26 IF $GET(MERR2)'=""
SET ^TMP($JOB,"DVBCBULL","SC",CTR2)="ERROR GETTING SPECIAL CONSIDERATION CODES"
+27 SET J=""
+28 FOR
SET J=$ORDER(MSG2(396.31,J))
if J=""
QUIT
Begin DoDot:1
+29 SET CTR2=CTR2+1
+30 SET ^TMP($JOB,"DVBCBULL","SC",CTR2)=$GET(MSG2(396.31,J,.01,"E"))
End DoDot:1
+31 ;
GO SET L=1
SET ^TMP("DVBC","BULL",$JOB,L,0)="The following veteran had one or more 2507 exams cancelled:"
SET L=L+1
+1 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+2 SET ^TMP("DVBC","BULL",$JOB,L,0)=" DFN: `"_DFN_$EXTRACT(" ",1,20-$LENGTH(DFN))_"SITE: "_DVBCSITE
SET L=L+1
+3 SET ^TMP("DVBC","BULL",$JOB,L,0)=" REQUEST DATE: "_DVBCRDAT
SET L=L+1
+4 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+5 SET ^TMP("DVBC","BULL",$JOB,L,0)=" Claim Type:"
SET L=L+1
+6 FOR
SET J=$ORDER(^TMP($JOB,"DVBCBULL","CT",J))
if J=""
QUIT
Begin DoDot:1
+7 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "_^TMP($JOB,"DVBCBULL","CT",J)
SET L=L+1
End DoDot:1
+8 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+9 SET ^TMP("DVBC","BULL",$JOB,L,0)=" Special Consideration(s):"
SET L=L+1
+10 SET J=""
+11 FOR
SET J=$ORDER(^TMP($JOB,"DVBCBULL","SC",J))
if J=""
QUIT
Begin DoDot:1
+12 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "_^TMP($JOB,"DVBCBULL","SC",J)
SET L=L+1
End DoDot:1
+13 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+14 SET ^TMP("DVBC","BULL",$JOB,L,0)="Exams cancelled Reason"
SET L=L+1
+15 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+16 SET EXAM=""
SET RSTAT=$PIECE(^DVB(396.3,REQDA,0),U,18)
+17 ;AJF;Request Status conversion
+18 SET RSTAT=$$RSTAT^DVBCUTL8(RSTAT)
+19 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 REAS=+$PIECE(CANC(EXAM),U,2)
DO EXAMS
+20 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
SET COMP=1
SET CMPC=0
+21 ;
+22 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+23 SET ^TMP("DVBC","BULL",$JOB,L,0)="** NOTE: To view the patient using the DFN, paste the DFN number into the **"
SET L=L+1
+24 SET ^TMP("DVBC","BULL",$JOB,L,0)="** CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to **"
SET L=L+1
+25 SET ^TMP("DVBC","BULL",$JOB,L,0)="** include the ' (backward-apostrophe) character. **"
SET L=L+1
+26 SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+27 ;
+28 KILL ^TMP("DVBC","CMNT",$JOB)
+29 IF RSTAT["X"
SET ^TMP("DVBC","BULL",$JOB,L,0)=" *** All exams on this request are now CANCELLED. ***"
SET L=L+1
SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+30 SET ^TMP("DVBC","BULL",$JOB,L,0)="** This is an auto-generated email. Do not respond to this email address. **"
SET L=L+1
+31 GOTO SEND
+32 SET ECNT=0
+33 FOR JZ=0:0
SET JZ=$ORDER(^DVB(396.4,"C",REQDA,JZ))
if JZ=""
QUIT
SET STAT=$PIECE(^DVB(396.4,JZ,0),U,4)
if STAT="C"
SET CMPC=1
IF STAT'="C"&(STAT'["X")
SET COMP=0
SET ECNT=ECNT+1
+34 ;CMPC=completed exam COMP=open exam
+35 ;both are toggled, depending on exam status. Both must be 1 to put release banner on message
+36 IF RSTAT'["X"
IF COMP=0
SET ^TMP("DVBC","BULL",$JOB,L,0)=" *** There "_$SELECT(ECNT=1:"is",1:"are")_" still "_ECNT_" exam"_$SELECT(ECNT=1:"",1:"s")_" open on this request. ***"
SET L=L+1
SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
GOTO SEND
+37 IF COMP=1&(CMPC=1)
IF RSTAT'["X"
SET ^TMP("DVBC","BULL",$JOB,L,0)=" *** This request is now COMPLETE and should be released by MAS ***"
SET L=L+1
+38 ;spacer
IF COMP=1&(CMPC=1)
IF RSTAT'["X"
SET ^TMP("DVBC","BULL",$JOB,L,0)=" "
SET L=L+1
+39 ;
SEND ;remote sites get bulletins only on total cancellations
+1 SET DIC="^XMB(3.8,"
SET DIC(0)="QM"
SET X="DVBA C 2507 CANCELLATION"
DO ^DIC
SET MG=+Y
IF +Y<0
WRITE !!,*7,"2507 mail group NOT found! Bulletin not sent.",!!
HANG 3
QUIT
+2 FOR JI=0:0
SET JI=$ORDER(^XMB(3.8,MG,1,"B",JI))
if JI=""
QUIT
SET XMY(JI)=""
+3 FOR JI=0:0
SET JI=$ORDER(XMY(JI))
if JI=""!(+JI=0)
QUIT
IF '$DATA(^VA(200,JI,2,+REQRO))&'$DATA(^VA(200,JI,2,+REQRO))&('$DATA(^XUSEC("DVBA C SUPERVISOR",JI)))
KILL XMY(JI)
+4 if REQSTR=""
SET REQSTR=.5
SET XMY(REQSTR)=""
SET XMY(DUZ)=""
SET XMSUB="Cancellation of 2507 Exams"
SET XMTEXT="^TMP(""DVBC"",""BULL"",$J,"
SET XMDUZ=DUZ
+5 IF '$DATA(^VA(200,DUZ,.15))
SET XMY(XMDUZ)=""
GOTO XMD
+6 IF $DATA(^VA(200,DUZ,.15))&($PIECE(^VA(200,DUZ,.15),"^",1)="")
SET XMY(XMDUZ)=""
GOTO XMD
+7 IF $DATA(^VA(200,DUZ,.15))
SET XMY($PIECE(^VA(200,DUZ,.15),"^",1))=""
XMD DO ^XMD
+1 KILL ^TMP("DVBC","BULL",$JOB),XMDUZ,DOTS,COMP,CMPC,XEXAM,REASON,L,JI,JY,XMY,XMSUB,XMTEXT,XMDUZ,ECNT
+2 KILL ^TMP($JOB,"DVBCBULL","CT"),^TMP($JOB,"DVBCBULL","SC")
+3 QUIT
+4 ;
EXAMS SET REASON=$SELECT($DATA(^DVB(396.5,+REAS,0)):$PIECE(^(0),U,1),1:"Undetermined")
+1 SET XEXAM=$EXTRACT(EXAM,1,25)
SET ^TMP("DVBC","BULL",$JOB,L,0)=" "_XEXAM_" "_$EXTRACT(DOTS,1,35-$LENGTH(XEXAM))_" "_REASON
SET L=L+1
+2 QUIT
