DVBAB1A ;ALB/GAK - CAPRI Exam Complete Email Driver ; 03/13/2013 11:23 AM
;;2.7;AMIE;**185,187,189**;Apr 10, 1995;Build 22
;
Q
;
MSG2(ERR,DUZ,RIEN,ELIST) ;
;
;DUZ PERSON FILE DFN
;RIEN 2507 REQUEST IEN #396.3
;ELIST 2507 EXAM LIST #396.4
;
N DVBOPEN,DVBOPENS,DVBOPENC,J
N PNAM,PSSN,CNUM,ERR3,ERR2,ERR4,RTN,RTN2,XX
;N POE
N MSG1,MERR1,CTR1
N MSG2,MERR2,CTR2
N CLMTYP
N EIEN,EARY,EERR,ENAM,ESTA
N XMTEXT,L,XMSUB,XMY
N MSG,MERR
;
S ERR=""
I DUZ="" S ERR="NO DUZ PASSED" Q ERR
I RIEN="" S ERR="NO REQUEST IEN PASSED" Q ERR
I $D(ELIST)'>1 S ERR="NO EXAM LIST PASSED" Q ERR
;
K ^TMP($J,"DVBAB1A")
K ^TMP($J,"AMIE")
K ^TMP($J,"AMIE1")
;
S J=""
F S J=$O(ELIST(J)) Q:J="" D
. S ^TMP($J,"DVBAB1A","ELIST",J)=J
;
;Determine and count number of open exams on 2507 request
S DVBOPEN=""
S DVBOPENS=0,DVBOPENC=0
D FINDEXAM^DVBAB1(.DVBOPEN,RIEN)
S J="" F S J=$O(DVBOPEN(J)) Q:J="" D
. I $E(DVBOPEN(J),($L(DVBOPEN(J))-5),$L(DVBOPEN(J)))="[OPEN]" S DVBOPENS=1,DVBOPENC=DVBOPENC+1
;
;Determine patient name, SSN and C-Number
S (PNAM,PSSN,CNUM,ERR3,ERR2,RTN,RTN2,XX)=""
K RTN,ERR3
D GETS^DIQ(396.3,RIEN,".01","I","RTN","ERR3")
I $D(RTN) D
. S XX=""_".01;.09;.313"_""
. K RTN2,ERR2
. D GETS^DIQ(2,RTN(396.3,RIEN_",",.01,"I"),XX,"E","RTN2","ERR2")
. S PNAM=$G(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.01,"E"))
. S PSSN=$G(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.09,"E"))
. S CNUM=$G(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.313,"E"))
S:'$D(PNAM) PNAM=""
S:'$D(PSSN) PSSN=""
S:'$D(CNUM) CNUM=""
;
;Build Exam Array Info
K ^TMP($J,"DVBAB1A","ELIST")
S J=""
F S J=$O(ELIST(J)) Q:J="" D
. S EIEN=ELIST(J)
. K EARY,EERR
. D GETS^DIQ(396.4,EIEN,".03;.04","IE","EARY","EERR")
. Q:'$D(EARY(396.4,EIEN_",",.03,"E"))
. S ENAM=$G(EARY(396.4,EIEN_",",.03,"E"))
. S ESTA=$G(EARY(396.4,EIEN_",",.04,"E"))
. S ^TMP($J,"DVBAB1A","ELIST",J)=ENAM_$E(" ",1,35-$L(ENAM))_" "_ESTA
;
;Determine Priority of Exam
;K ERR4
;S POE=$$GET1^DIQ(396.3,RIEN_",",9,"E","","ERR4")
;I '$D(POE) S POE=""
;
;Build Claim Type Info
N MSG1,MERR1,CTR1
K ^TMP($J,"DVBAB1A","CT")
S MSG1="",MERR1="",CTR1=1
D GETS^DIQ(396.3,RIEN_",","9.1*","E","MSG1","MERR1")
I $G(MERR1)'="" S ^TMP($J,"DVBAB1A","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,"DVBAB1A","CT",CTR1)=$G(MSG1(396.32,J,.01,"E"))
;
;Build Special Considerations Info
N MSG2,MERR2,CTR2
K ^TMP($J,"DVBAB1A","SC")
S MSG2="",MERR2="",CTR2=1
D GETS^DIQ(396.3,RIEN,"50*","IE","MSG2","MERR2")
I $G(MERR2)'="" S ^TMP($J,"DVBAB1A","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,"DVBAB1A","SC",CTR2)=$G(MSG2(396.31,J,.01,"E"))
;
;
D ONEEMAIL
;
K ^TMP($J,"DVBAB1A","ELIST")
K ^TMP($J,"DVBAB1A","CT")
K ^TMP($J,"DVBAB1A","SC")
K ^TMP($J,"AMIE")
K ^TMP($J,"AMIE1")
I $D(ERR) Q ERR
;
Q
;
;
;
ONEEMAIL ;
K ERR
N DVBA0,DVBADFN,DVBASITE,DVBADT,DVBAREQ,DVBAEA
S XMDUZ=DUZ
;following call supported by IA 3858
N DUZ
;SINCE MAILMAN DOES NOT ALLOW MESSAGES TO BE SENT FROM USERS WITHOUT ACCESS CODES OR MAILBOXES
;WHICH CAPRI REMOTE USER DO NOT HAVE, WE HAVE TO NEW DUZ AND CHANGE XMDUZ TO THE NAME OF THE USER
;AS A STRING SO THE PROCESS IS STILL LINKED TO THE USER SENDING/TRIGGERING THE MESSAGE
;
S XMDUZ=$P($G(^VA(200,XMDUZ,0)),"^",1)_" CAPRI"
I $G(^DVB(396.3,RIEN,0))="" S ERR="INVALID REQUEST 396.3 TOP NODE" Q
S DVBA0=$G(^DVB(396.3,RIEN,0))
S DVBADFN=$P(DVBA0,"^",1),DVBAREQ=$P(DVBA0,"^",4),DVBADT=$$FMTE^XLFDT($P(DVBA0,"^",2))
;following call supported by IA 3858
;rra 938270 make sure email address exists prior to attempting to send notification
S DVBAEA=$P($G(^VA(200,DVBAREQ,.15)),"^",1)
I DVBAEA="" Q
S XMY(DVBAEA)=""
;
S DVBASITE=$$SITE^VASITE
I '$D(DVBASITE) S DVBASITE="^"
;
S XMSUB="CAPRI: Completion of 2507 Exams"
;
S L=0
S L=L+1
S ^TMP($J,"AMIE",L)="The following veteran had one or more 2507 exams completed.",L=L+1
I DVBOPENS=0 S ^TMP($J,"AMIE",L)="A 2507 request as described below has been completed and released to the regional office and is now available in CAPRI.",L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
S ^TMP($J,"AMIE",L)="DFN: `"_DVBADFN_" SITE: "_$P($G(DVBASITE),"^",2)_" Request Date: "_DVBADT
S L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
;
S ^TMP($J,"AMIE",L)=" Special Consideration(s):",L=L+1
S J=""
F S J=$O(^TMP($J,"DVBAB1A","SC",J)) Q:J="" D
. S ^TMP($J,"AMIE",L)=" "_^TMP($J,"DVBAB1A","SC",J),L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
;
;S ^TMP($J,"AMIE",L)=" Priority of Exam: "_POE,L=L+1
;S ^TMP($J,"AMIE",L)=" ",L=L+1
;
S ^TMP($J,"AMIE",L)=" Claim Type:",L=L+1
S J=""
F S J=$O(^TMP($J,"DVBAB1A","CT",J)) Q:J="" D
. S ^TMP($J,"AMIE",L)=" "_^TMP($J,"DVBAB1A","CT",J),L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
;
S ^TMP($J,"AMIE",L)="Exam(s)",L=L+1
S ^TMP($J,"AMIE",L)=" EXAM TYPE STATUS",L=L+1
;
S J=""
F S J=$O(^TMP($J,"DVBAB1A","ELIST",J)) Q:J="" D
. S ^TMP($J,"AMIE",L)=" "_^TMP($J,"DVBAB1A","ELIST",J),L=L+1
;
S ^TMP($J,"AMIE",L)=" ",L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
;
I DVBOPENS=1 S ^TMP($J,"AMIE",L)="*** Number of exams still open on this request: "_DVBOPENC_" ***",L=L+1
I DVBOPENS=0 S ^TMP($J,"AMIE",L)="*** This is the last exam to be completed on this 2507 request. ***",L=L+1
;
S ^TMP($J,"AMIE",L)=" ",L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
S ^TMP($J,"AMIE",L)="** NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI **",L=L+1
S ^TMP($J,"AMIE",L)="** Patient Selector 'Patient ID' field to find the patient. Be sure to include **",L=L+1
S ^TMP($J,"AMIE",L)="** the ` (backward-apostrophe) character. **",L=L+1
S ^TMP($J,"AMIE",L)=" ",L=L+1
S ^TMP($J,"AMIE",L)="*****This is an auto-generated email. Do not respond to this email address.*****",L=L+1
;
S XMTEXT="^TMP($J,""AMIE"","
;
D ^XMD
;
I $D(XMMG) S ERR=XMMG
I $D(XMZ) S ERR="MESSAGE SENT"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB1A 6239 printed Sep 23, 2025@19:16:18 Page 2
DVBAB1A ;ALB/GAK - CAPRI Exam Complete Email Driver ; 03/13/2013 11:23 AM
+1 ;;2.7;AMIE;**185,187,189**;Apr 10, 1995;Build 22
+2 ;
+3 QUIT
+4 ;
MSG2(ERR,DUZ,RIEN,ELIST) ;
+1 ;
+2 ;DUZ PERSON FILE DFN
+3 ;RIEN 2507 REQUEST IEN #396.3
+4 ;ELIST 2507 EXAM LIST #396.4
+5 ;
+6 NEW DVBOPEN,DVBOPENS,DVBOPENC,J
+7 NEW PNAM,PSSN,CNUM,ERR3,ERR2,ERR4,RTN,RTN2,XX
+8 ;N POE
+9 NEW MSG1,MERR1,CTR1
+10 NEW MSG2,MERR2,CTR2
+11 NEW CLMTYP
+12 NEW EIEN,EARY,EERR,ENAM,ESTA
+13 NEW XMTEXT,L,XMSUB,XMY
+14 NEW MSG,MERR
+15 ;
+16 SET ERR=""
+17 IF DUZ=""
SET ERR="NO DUZ PASSED"
QUIT ERR
+18 IF RIEN=""
SET ERR="NO REQUEST IEN PASSED"
QUIT ERR
+19 IF $DATA(ELIST)'>1
SET ERR="NO EXAM LIST PASSED"
QUIT ERR
+20 ;
+21 KILL ^TMP($JOB,"DVBAB1A")
+22 KILL ^TMP($JOB,"AMIE")
+23 KILL ^TMP($JOB,"AMIE1")
+24 ;
+25 SET J=""
+26 FOR
SET J=$ORDER(ELIST(J))
if J=""
QUIT
Begin DoDot:1
+27 SET ^TMP($JOB,"DVBAB1A","ELIST",J)=J
End DoDot:1
+28 ;
+29 ;Determine and count number of open exams on 2507 request
+30 SET DVBOPEN=""
+31 SET DVBOPENS=0
SET DVBOPENC=0
+32 DO FINDEXAM^DVBAB1(.DVBOPEN,RIEN)
+33 SET J=""
FOR
SET J=$ORDER(DVBOPEN(J))
if J=""
QUIT
Begin DoDot:1
+34 IF $EXTRACT(DVBOPEN(J),($LENGTH(DVBOPEN(J))-5),$LENGTH(DVBOPEN(J)))="[OPEN]"
SET DVBOPENS=1
SET DVBOPENC=DVBOPENC+1
End DoDot:1
+35 ;
+36 ;Determine patient name, SSN and C-Number
+37 SET (PNAM,PSSN,CNUM,ERR3,ERR2,RTN,RTN2,XX)=""
+38 KILL RTN,ERR3
+39 DO GETS^DIQ(396.3,RIEN,".01","I","RTN","ERR3")
+40 IF $DATA(RTN)
Begin DoDot:1
+41 SET XX=""_".01;.09;.313"_""
+42 KILL RTN2,ERR2
+43 DO GETS^DIQ(2,RTN(396.3,RIEN_",",.01,"I"),XX,"E","RTN2","ERR2")
+44 SET PNAM=$GET(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.01,"E"))
+45 SET PSSN=$GET(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.09,"E"))
+46 SET CNUM=$GET(RTN2(2,RTN(396.3,RIEN_",",.01,"I")_",",.313,"E"))
End DoDot:1
+47 if '$DATA(PNAM)
SET PNAM=""
+48 if '$DATA(PSSN)
SET PSSN=""
+49 if '$DATA(CNUM)
SET CNUM=""
+50 ;
+51 ;Build Exam Array Info
+52 KILL ^TMP($JOB,"DVBAB1A","ELIST")
+53 SET J=""
+54 FOR
SET J=$ORDER(ELIST(J))
if J=""
QUIT
Begin DoDot:1
+55 SET EIEN=ELIST(J)
+56 KILL EARY,EERR
+57 DO GETS^DIQ(396.4,EIEN,".03;.04","IE","EARY","EERR")
+58 if '$DATA(EARY(396.4,EIEN_",",.03,"E"))
QUIT
+59 SET ENAM=$GET(EARY(396.4,EIEN_",",.03,"E"))
+60 SET ESTA=$GET(EARY(396.4,EIEN_",",.04,"E"))
+61 SET ^TMP($JOB,"DVBAB1A","ELIST",J)=ENAM_$EXTRACT(" ",1,35-$LENGTH(ENAM))_" "_ESTA
End DoDot:1
+62 ;
+63 ;Determine Priority of Exam
+64 ;K ERR4
+65 ;S POE=$$GET1^DIQ(396.3,RIEN_",",9,"E","","ERR4")
+66 ;I '$D(POE) S POE=""
+67 ;
+68 ;Build Claim Type Info
+69 NEW MSG1,MERR1,CTR1
+70 KILL ^TMP($JOB,"DVBAB1A","CT")
+71 SET MSG1=""
SET MERR1=""
SET CTR1=1
+72 DO GETS^DIQ(396.3,RIEN_",","9.1*","E","MSG1","MERR1")
+73 IF $GET(MERR1)'=""
SET ^TMP($JOB,"DVBAB1A","CT",CTR1)="ERROR GETTING CLAIM TYPE CODES"
+74 SET J=""
+75 FOR
SET J=$ORDER(MSG1(396.32,J))
if J=""
QUIT
Begin DoDot:1
+76 SET CTR1=CTR1+1
+77 SET ^TMP($JOB,"DVBAB1A","CT",CTR1)=$GET(MSG1(396.32,J,.01,"E"))
End DoDot:1
+78 ;
+79 ;Build Special Considerations Info
+80 NEW MSG2,MERR2,CTR2
+81 KILL ^TMP($JOB,"DVBAB1A","SC")
+82 SET MSG2=""
SET MERR2=""
SET CTR2=1
+83 DO GETS^DIQ(396.3,RIEN,"50*","IE","MSG2","MERR2")
+84 IF $GET(MERR2)'=""
SET ^TMP($JOB,"DVBAB1A","SC",CTR2)="ERROR GETTING SPECIAL CONSIDERATION CODES"
+85 SET J=""
+86 FOR
SET J=$ORDER(MSG2(396.31,J))
if J=""
QUIT
Begin DoDot:1
+87 SET CTR2=CTR2+1
+88 SET ^TMP($JOB,"DVBAB1A","SC",CTR2)=$GET(MSG2(396.31,J,.01,"E"))
End DoDot:1
+89 ;
+90 ;
+91 DO ONEEMAIL
+92 ;
+93 KILL ^TMP($JOB,"DVBAB1A","ELIST")
+94 KILL ^TMP($JOB,"DVBAB1A","CT")
+95 KILL ^TMP($JOB,"DVBAB1A","SC")
+96 KILL ^TMP($JOB,"AMIE")
+97 KILL ^TMP($JOB,"AMIE1")
+98 IF $DATA(ERR)
QUIT ERR
+99 ;
+100 QUIT
+101 ;
+102 ;
+103 ;
ONEEMAIL ;
+1 KILL ERR
+2 NEW DVBA0,DVBADFN,DVBASITE,DVBADT,DVBAREQ,DVBAEA
+3 SET XMDUZ=DUZ
+4 ;following call supported by IA 3858
+5 NEW DUZ
+6 ;SINCE MAILMAN DOES NOT ALLOW MESSAGES TO BE SENT FROM USERS WITHOUT ACCESS CODES OR MAILBOXES
+7 ;WHICH CAPRI REMOTE USER DO NOT HAVE, WE HAVE TO NEW DUZ AND CHANGE XMDUZ TO THE NAME OF THE USER
+8 ;AS A STRING SO THE PROCESS IS STILL LINKED TO THE USER SENDING/TRIGGERING THE MESSAGE
+9 ;
+10 SET XMDUZ=$PIECE($GET(^VA(200,XMDUZ,0)),"^",1)_" CAPRI"
+11 IF $GET(^DVB(396.3,RIEN,0))=""
SET ERR="INVALID REQUEST 396.3 TOP NODE"
QUIT
+12 SET DVBA0=$GET(^DVB(396.3,RIEN,0))
+13 SET DVBADFN=$PIECE(DVBA0,"^",1)
SET DVBAREQ=$PIECE(DVBA0,"^",4)
SET DVBADT=$$FMTE^XLFDT($PIECE(DVBA0,"^",2))
+14 ;following call supported by IA 3858
+15 ;rra 938270 make sure email address exists prior to attempting to send notification
+16 SET DVBAEA=$PIECE($GET(^VA(200,DVBAREQ,.15)),"^",1)
+17 IF DVBAEA=""
QUIT
+18 SET XMY(DVBAEA)=""
+19 ;
+20 SET DVBASITE=$$SITE^VASITE
+21 IF '$DATA(DVBASITE)
SET DVBASITE="^"
+22 ;
+23 SET XMSUB="CAPRI: Completion of 2507 Exams"
+24 ;
+25 SET L=0
+26 SET L=L+1
+27 SET ^TMP($JOB,"AMIE",L)="The following veteran had one or more 2507 exams completed."
SET L=L+1
+28 IF DVBOPENS=0
SET ^TMP($JOB,"AMIE",L)="A 2507 request as described below has been completed and released to the regional office and is now available in CAPRI."
SET L=L+1
+29 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+30 SET ^TMP($JOB,"AMIE",L)="DFN: `"_DVBADFN_" SITE: "_$PIECE($GET(DVBASITE),"^",2)_" Request Date: "_DVBADT
+31 SET L=L+1
+32 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+33 ;
+34 SET ^TMP($JOB,"AMIE",L)=" Special Consideration(s):"
SET L=L+1
+35 SET J=""
+36 FOR
SET J=$ORDER(^TMP($JOB,"DVBAB1A","SC",J))
if J=""
QUIT
Begin DoDot:1
+37 SET ^TMP($JOB,"AMIE",L)=" "_^TMP($JOB,"DVBAB1A","SC",J)
SET L=L+1
End DoDot:1
+38 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+39 ;
+40 ;S ^TMP($J,"AMIE",L)=" Priority of Exam: "_POE,L=L+1
+41 ;S ^TMP($J,"AMIE",L)=" ",L=L+1
+42 ;
+43 SET ^TMP($JOB,"AMIE",L)=" Claim Type:"
SET L=L+1
+44 SET J=""
+45 FOR
SET J=$ORDER(^TMP($JOB,"DVBAB1A","CT",J))
if J=""
QUIT
Begin DoDot:1
+46 SET ^TMP($JOB,"AMIE",L)=" "_^TMP($JOB,"DVBAB1A","CT",J)
SET L=L+1
End DoDot:1
+47 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+48 ;
+49 SET ^TMP($JOB,"AMIE",L)="Exam(s)"
SET L=L+1
+50 SET ^TMP($JOB,"AMIE",L)=" EXAM TYPE STATUS"
SET L=L+1
+51 ;
+52 SET J=""
+53 FOR
SET J=$ORDER(^TMP($JOB,"DVBAB1A","ELIST",J))
if J=""
QUIT
Begin DoDot:1
+54 SET ^TMP($JOB,"AMIE",L)=" "_^TMP($JOB,"DVBAB1A","ELIST",J)
SET L=L+1
End DoDot:1
+55 ;
+56 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+57 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+58 ;
+59 IF DVBOPENS=1
SET ^TMP($JOB,"AMIE",L)="*** Number of exams still open on this request: "_DVBOPENC_" ***"
SET L=L+1
+60 IF DVBOPENS=0
SET ^TMP($JOB,"AMIE",L)="*** This is the last exam to be completed on this 2507 request. ***"
SET L=L+1
+61 ;
+62 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+63 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+64 SET ^TMP($JOB,"AMIE",L)="** NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI **"
SET L=L+1
+65 SET ^TMP($JOB,"AMIE",L)="** Patient Selector 'Patient ID' field to find the patient. Be sure to include **"
SET L=L+1
+66 SET ^TMP($JOB,"AMIE",L)="** the ` (backward-apostrophe) character. **"
SET L=L+1
+67 SET ^TMP($JOB,"AMIE",L)=" "
SET L=L+1
+68 SET ^TMP($JOB,"AMIE",L)="*****This is an auto-generated email. Do not respond to this email address.*****"
SET L=L+1
+69 ;
+70 SET XMTEXT="^TMP($J,""AMIE"","
+71 ;
+72 DO ^XMD
+73 ;
+74 IF $DATA(XMMG)
SET ERR=XMMG
+75 IF $DATA(XMZ)
SET ERR="MESSAGE SENT"
+76 ;
+77 QUIT
