DVBCXFR2 ;ALB/AJF-ReRoute C&P REQUESTS ; 9/30/21 3:56pm
;;2.7;AMIE;**193,227,250**;;Build 19
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Copy of DVBCXFRB
;
EN ;file 2
N DVBSBRCH,DVBDTYPE,CSPT
K ^TMP("DVBCXFR",$J),L S X=^DVB(396.3,REQDA,0),DFN=$P(X,U,1)
S X=^DPT(DFN,0),PNAM=$P(X,U,1),DOB=$P(X,U,3),SEX=$P(X,U,2),SSN=$P(X,U,9),POBC=$P(X,U,11),POBS=$P(X,U,12)
S X=$S($D(^DPT(DFN,.11)):^(.11),1:""),ADR1=$P(X,U,1),ADR2=$P(X,U,2),ADR3=$P(X,U,3),CITY=$P(X,U,4)
S STATE=$P(X,U,5),ZIP=$P(X,U,6),CNTY=$P(X,U,7),ZIP4=$P(X,U,12)
S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:""),STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"")
S X=$S($D(^DPT(DFN,.13)):^(.13),1:"") S HOMPHON=$P(X,U,1),BUSPHON=$P(X,U,2)
S X=$S($D(^DPT(DFN,.3)):^(.3),1:""),SRVCON=$P(X,U,1),SRVPCT=$P(X,U,2)
S X=$S($D(^DPT(DFN,.31)):^(.31),1:""),CNUM=$P(X,U,3)
S CFLOC=$$STATION^DVBAUTL1(DFN)
S:CFLOC=-1 CFLOC=""
S X=$S($D(^DPT(DFN,.32)):^(.32),1:""),PDSRV=$P(X,U,3),PDSRV=$S($D(^DIC(21,+PDSRV,0)):$P(^(0),U,3),1:"")
S X=$$SVC^DVBCUTIL(DFN,"I"),SRVEDT=$P(X,U),SRVSDT=$P(X,U,2)
S X=$$SVC^DVBCUTIL(DFN,"E"),DVBSBRCH=$P(X,U,3),DVBDTYPE=$P(X,U,4)
S X=$S($D(^DPT(DFN,.36)):^(.36),1:""),ELIGCOD=$P(X,U,1),ELIGCOD=$S($D(^DIC(8,+ELIGCOD,0)):$P(^(0),U,9),1:"")
S X=$S($D(^DPT(DFN,.361)):^(.361),1:""),ELIGST=$P(X,U,1),ELIGSDT=$P(X,U,2)
S X=$S($D(^DPT(DFN,.52)):^(.52),1:""),POWSTAT=$P(X,U,5)
S X=$S($D(^DPT(DFN,"VET")):^("VET"),1:""),VETST=$P(X,U,1)
S X=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:"") S TYPE=$S(X]"":$P(^DG(391,X,0),U,1),1:"")
S ICN=$$GETICN^MPIF001(DFN),PREFAC=STN,CSPT=0
I $D(^DGSL(38.1,DFN,0)) S CSPT=$P(^DGSL(38.1,DFN,0),U,2)
;
S LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN_U_POBC_U_POBS_U_ICN_U_PREFAC_U_CSPT
S LINE(2)="$DEM1 "_ADR1_U_ADR2_U_ADR3_U_CITY_U_STATE_U_CNTY_U_ZIP_U_HOMPHON_U_BUSPHON_U_ZIP4
S LINE(3)="$ELIG "_SRVCON_U_SRVPCT_U_CFLOC_U_CNUM_U_PDSRV_U_SRVEDT_U_SRVSDT_U_ELIGCOD_U_ELIGST_U_ELIGSDT_U_POWSTAT_U_VETST_U_TYPE_U_DVBSBRCH_U_DVBDTYPE
;
;file 396.3
EN1 S X=^DVB(396.3,REQDA,0),RO=$P(X,U,3),RONAM=$P($G(^DIC(4,+RO,99)),U,1),REQDT=$P(X,U,2)
S FEXM=$P(X,U,9),PRIO=$P(X,U,10),OTHDIS=$P(X,U,11),LREXMDT=$P(X,U,20),DMAS=$P(X,U,5)
S X=$S($D(^DVB(396.3,REQDA,1)):^(1),1:""),CFREQ=$P(X,U,2),OTHDOC=$P(X,U,3),LREXMDT=$P(X,U,7),OTHDIS1=$P(X,U,9),OTHDIS2=$P(X,U,10)
S CLTYP=$G(^DVB(396.3,REQDA,9,1,0)),RRDIV=$P($G(^DVB(396.3,REQDA,1)),"^",4),(SPEC,ECF)="",II=0
I $D(^DVB(396.3,REQDA,5)) S ECF=$P(^DVB(396.3,REQDA,5),"^",3)
I $D(^DVB(396.3,REQDA,10)) S DVBINF=^DVB(396.3,REQDA,10)
I $D(^DVB(396.3,REQDA,8)) F S II=$O(^DVB(396.3,REQDA,8,II)) Q:II=""!(II="B") D
. S SPEC=SPEC_$G(^DVB(396.3,REQDA,8,II,0))_"^"
S LINE(4)="$REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS
S LINE(5)="$ODIS "_OTHDIS_U_OTHDIS1_U_OTHDIS2
S EXAMS="$EXAM "_EXAMS,LINE(6)=EXAMS
S CINFO=$$SITE^VASITE,RRDT=$$NOW^XLFDT()
S RRFIEN=$P(CINFO,"^",1),RRF=$P(CINFO,"^",2),RRFSTN=$P(CINFO,"^",3)
S RRFD=$P(^DIC(4,RRFIEN,6),U,1)
; AJF ; Reroute data for MailMan message
S RR=$$EXTERNAL^DILFD(396.55,.01,,RR)
S LINE(7)="$RDAT "_REQDA_U_PIEN_U_RRF_U_RR_U_RD_U_INAM_U_RRDT_U_CLTYP_U_ECF_U_RRFD
S LINE(7)=LINE(7)_U_RRFIEN_U_RRFSTN_U_STN_U_INUM_U_DVBINF
S LINE(8)="$SPEC "_SPEC
;PLE ; CAPRI 1214 2507 Reroute limit $RDAT to 250 char
I $L($G(LINE(7)))>250 D
.S LINE(7)="$RDAT "_REQDA_U_PIEN_U_RRF_U_RR_U_""_U_INAM_U_RRDT_U_CLTYP_U_ECF_U_RRFD
.S LINE(7)=LINE(7)_U_RRFIEN_U_RRFSTN_U_STN_U_INUM_U_DVBINF
.S LINE(8)="$SPEC "_SPEC
.S LINE(9)="$RDES "_RD
;**NOTE: RONAM is now RO NUMBER
LOAD S L=1,^TMP("DVBCXFR",$J,L,0)="$TRANSFER IN",L=L+1
F X=1:1 Q:'$D(LINE(X)) S ^TMP("DVBCXFR",$J,L,0)=LINE(X),L=L+1
F JI=0:0 S JI=$O(^DVB(396.3,REQDA,2,JI)) Q:JI="" S ^TMP("DVBCXFR",$J,L,0)="$REMK "_^DVB(396.3,REQDA,2,JI,0),L=L+1
S SITE=$P(^XMB(1,1,0),U,1),SITE1=$P(^DIC(4.2,SITE,0),U,1)
S USERNM=$P(^VA(200,DUZ,0),U,1),^TMP("DVBCXFR",$J,L,0)="$USER "_USERNM_U_SITE_U_SITE1,L=L+1
S ^TMP("DVBCXFR",$J,L,0)="$END "
N XMNODE
S XMNODE=0
F X=(L+1):1:(L+XMCNT) DO
.S XMNODE=XMNODE+1
.S ^TMP("DVBCXFR",$J,X,0)=XMVAR(XMNODE)
S ^TMP("DVBCXFR",$J,X+1,0)="$END1 "
;
SEND K XMZ
;S XMY("POSTMASTER@"_DOMNAM)=DOMNUM
N RRIF
S RRXM=0
;Check for reroute within VAMC
I RRF'=INAM D
.S XMY(DUZ)="",XMY("S.DVBA C PROCESS MAIL MESSAGE@"_DOMNAM)=DOMNUM,XMSUB="Transfer of C&P Exams",XMTEXT="^TMP(""DVBCXFR"",$J,",XMDUZ=DUZ
.D ^XMD
.I $D(XMZ) S RTN="1^Transmitted as message # "_XMZ_" from this site to "_DOMNAM
.I '$D(XMZ) S RTN="0^Message transmission error! Request WILL NOT be rerouted!",RRXM=1
;if all ok, update main, sub-file
I RRXM=1 D VKILL Q
I RRF=INAM S RTN="1^Rerouted to another division within "_RRF
F III=0:0 S III=$O(XEXAMS(III)) Q:III="" D
.S DIE="^DVB(396.4,",DA=III,DR=".04///T;62///"_DOMNAM_";60////"_DT_";61///"_USERNM
.D ^DIE
;patch 227 introducing new status
K DIE,DA,DR S DIE="^DVB(396.3,",DA=REQDA,DR="17///16"
;
; ajf - Defect #2 - 02/17/2017
S CSITE=+$$SITE^VASITE
I CSITE=RRFIEN&(CSITE=INUM) S DR=DR_";24////"_$P(^DVB(396.15,RDIV,0),"^")
D ^DIE ;set transfer items
;
S RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
S DA=$P(RRIF,"^")
S DIE="^DVB(396.3,"_REQDA_",6,",DA(1)=REQDA
S DR="1////"_REQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD
S DR=DR_";.02////"_INAM_";8////"_RRDIV_";7////"_DUZ
S DR=DR_";9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN
D ^DIE ;set Reroute fields
S RRIEN=DA,RRST="N",RRR=""
D UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR) ; Update the status
; Send Reroute message to Requestor
D SENDMSG^DVBAB1C(REQDA)
;
; REQDA = 2507 Request IEN
; INUM = Institution IEN
; PIEN = Patient IEN
; DIEN = Division IEN
; RR = Reroute Reason
; RD = Reroute Description
;
;
;
K LINE,DOMNUM,DOMNUM1,^TMP("DVBCXFR",$J),XMDUZ,III,L,JI,JY,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,DIE,DA,DR,TYPE
;
VKILL ; Kill varables from process
;
K XMERR,ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTYP,CNTY,CNUM
K CSITE,DFN,DOB,DOMNAM,ECF,ELIGCOD,ELIGSDT,ELIGST,EXAMS,FEXM
K HOMPHON,II,INUM,LREXMDT,MDIV,OTDIS,OTHDIS,OTHDIS1,OTHDIS2,OTHDOC,PDSRV
K PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV
K RRFD,RRIEN,RRR,RRF,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT,DVBINF
K SRVPCT,SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,DMAS,INAM
D KILL^DVBCUTIL,KILL^DVBCUTL2,KILL^DVBCUTL3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFR2 6436 printed Apr 09, 2024@20:57:40 Page 2
DVBCXFR2 ;ALB/AJF-ReRoute C&P REQUESTS ; 9/30/21 3:56pm
+1 ;;2.7;AMIE;**193,227,250**;;Build 19
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Copy of DVBCXFRB
+5 ;
EN ;file 2
+1 NEW DVBSBRCH,DVBDTYPE,CSPT
+2 KILL ^TMP("DVBCXFR",$JOB),L
SET X=^DVB(396.3,REQDA,0)
SET DFN=$PIECE(X,U,1)
+3 SET X=^DPT(DFN,0)
SET PNAM=$PIECE(X,U,1)
SET DOB=$PIECE(X,U,3)
SET SEX=$PIECE(X,U,2)
SET SSN=$PIECE(X,U,9)
SET POBC=$PIECE(X,U,11)
SET POBS=$PIECE(X,U,12)
+4 SET X=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
SET ADR1=$PIECE(X,U,1)
SET ADR2=$PIECE(X,U,2)
SET ADR3=$PIECE(X,U,3)
SET CITY=$PIECE(X,U,4)
+5 SET STATE=$PIECE(X,U,5)
SET ZIP=$PIECE(X,U,6)
SET CNTY=$PIECE(X,U,7)
SET ZIP4=$PIECE(X,U,12)
+6 SET CNTY=$SELECT($DATA(^DIC(5,+STATE,1,+CNTY,0)):$PIECE(^(0),U,1),1:"")
SET STATE=$SELECT($DATA(^DIC(5,+STATE,0)):$PIECE(^(0),U,1),1:"")
+7 SET X=$SELECT($DATA(^DPT(DFN,.13)):^(.13),1:"")
SET HOMPHON=$PIECE(X,U,1)
SET BUSPHON=$PIECE(X,U,2)
+8 SET X=$SELECT($DATA(^DPT(DFN,.3)):^(.3),1:"")
SET SRVCON=$PIECE(X,U,1)
SET SRVPCT=$PIECE(X,U,2)
+9 SET X=$SELECT($DATA(^DPT(DFN,.31)):^(.31),1:"")
SET CNUM=$PIECE(X,U,3)
+10 SET CFLOC=$$STATION^DVBAUTL1(DFN)
+11 if CFLOC=-1
SET CFLOC=""
+12 SET X=$SELECT($DATA(^DPT(DFN,.32)):^(.32),1:"")
SET PDSRV=$PIECE(X,U,3)
SET PDSRV=$SELECT($DATA(^DIC(21,+PDSRV,0)):$PIECE(^(0),U,3),1:"")
+13 SET X=$$SVC^DVBCUTIL(DFN,"I")
SET SRVEDT=$PIECE(X,U)
SET SRVSDT=$PIECE(X,U,2)
+14 SET X=$$SVC^DVBCUTIL(DFN,"E")
SET DVBSBRCH=$PIECE(X,U,3)
SET DVBDTYPE=$PIECE(X,U,4)
+15 SET X=$SELECT($DATA(^DPT(DFN,.36)):^(.36),1:"")
SET ELIGCOD=$PIECE(X,U,1)
SET ELIGCOD=$SELECT($DATA(^DIC(8,+ELIGCOD,0)):$PIECE(^(0),U,9),1:"")
+16 SET X=$SELECT($DATA(^DPT(DFN,.361)):^(.361),1:"")
SET ELIGST=$PIECE(X,U,1)
SET ELIGSDT=$PIECE(X,U,2)
+17 SET X=$SELECT($DATA(^DPT(DFN,.52)):^(.52),1:"")
SET POWSTAT=$PIECE(X,U,5)
+18 SET X=$SELECT($DATA(^DPT(DFN,"VET")):^("VET"),1:"")
SET VETST=$PIECE(X,U,1)
+19 SET X=$SELECT($DATA(^DPT(DFN,"TYPE")):^("TYPE"),1:"")
SET TYPE=$SELECT(X]"":$PIECE(^DG(391,X,0),U,1),1:"")
+20 SET ICN=$$GETICN^MPIF001(DFN)
SET PREFAC=STN
SET CSPT=0
+21 IF $DATA(^DGSL(38.1,DFN,0))
SET CSPT=$PIECE(^DGSL(38.1,DFN,0),U,2)
+22 ;
+23 SET LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN_U_POBC_U_POBS_U_ICN_U_PREFAC_U_CSPT
+24 SET LINE(2)="$DEM1 "_ADR1_U_ADR2_U_ADR3_U_CITY_U_STATE_U_CNTY_U_ZIP_U_HOMPHON_U_BUSPHON_U_ZIP4
+25 SET LINE(3)="$ELIG "_SRVCON_U_SRVPCT_U_CFLOC_U_CNUM_U_PDSRV_U_SRVEDT_U_SRVSDT_U_ELIGCOD_U_ELIGST_U_ELIGSDT_U_POWSTAT_U_VETST_U_TYPE_U_DVBSBRCH_U_DVBDTYPE
+26 ;
+27 ;file 396.3
EN1 SET X=^DVB(396.3,REQDA,0)
SET RO=$PIECE(X,U,3)
SET RONAM=$PIECE($GET(^DIC(4,+RO,99)),U,1)
SET REQDT=$PIECE(X,U,2)
+1 SET FEXM=$PIECE(X,U,9)
SET PRIO=$PIECE(X,U,10)
SET OTHDIS=$PIECE(X,U,11)
SET LREXMDT=$PIECE(X,U,20)
SET DMAS=$PIECE(X,U,5)
+2 SET X=$SELECT($DATA(^DVB(396.3,REQDA,1)):^(1),1:"")
SET CFREQ=$PIECE(X,U,2)
SET OTHDOC=$PIECE(X,U,3)
SET LREXMDT=$PIECE(X,U,7)
SET OTHDIS1=$PIECE(X,U,9)
SET OTHDIS2=$PIECE(X,U,10)
+3 SET CLTYP=$GET(^DVB(396.3,REQDA,9,1,0))
SET RRDIV=$PIECE($GET(^DVB(396.3,REQDA,1)),"^",4)
SET (SPEC,ECF)=""
SET II=0
+4 IF $DATA(^DVB(396.3,REQDA,5))
SET ECF=$PIECE(^DVB(396.3,REQDA,5),"^",3)
+5 IF $DATA(^DVB(396.3,REQDA,10))
SET DVBINF=^DVB(396.3,REQDA,10)
+6 IF $DATA(^DVB(396.3,REQDA,8))
FOR
SET II=$ORDER(^DVB(396.3,REQDA,8,II))
if II=""!(II="B")
QUIT
Begin DoDot:1
+7 SET SPEC=SPEC_$GET(^DVB(396.3,REQDA,8,II,0))_"^"
End DoDot:1
+8 SET LINE(4)="$REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS
+9 SET LINE(5)="$ODIS "_OTHDIS_U_OTHDIS1_U_OTHDIS2
+10 SET EXAMS="$EXAM "_EXAMS
SET LINE(6)=EXAMS
+11 SET CINFO=$$SITE^VASITE
SET RRDT=$$NOW^XLFDT()
+12 SET RRFIEN=$PIECE(CINFO,"^",1)
SET RRF=$PIECE(CINFO,"^",2)
SET RRFSTN=$PIECE(CINFO,"^",3)
+13 SET RRFD=$PIECE(^DIC(4,RRFIEN,6),U,1)
+14 ; AJF ; Reroute data for MailMan message
+15 SET RR=$$EXTERNAL^DILFD(396.55,.01,,RR)
+16 SET LINE(7)="$RDAT "_REQDA_U_PIEN_U_RRF_U_RR_U_RD_U_INAM_U_RRDT_U_CLTYP_U_ECF_U_RRFD
+17 SET LINE(7)=LINE(7)_U_RRFIEN_U_RRFSTN_U_STN_U_INUM_U_DVBINF
+18 SET LINE(8)="$SPEC "_SPEC
+19 ;PLE ; CAPRI 1214 2507 Reroute limit $RDAT to 250 char
+20 IF $LENGTH($GET(LINE(7)))>250
Begin DoDot:1
+21 SET LINE(7)="$RDAT "_REQDA_U_PIEN_U_RRF_U_RR_U_""_U_INAM_U_RRDT_U_CLTYP_U_ECF_U_RRFD
+22 SET LINE(7)=LINE(7)_U_RRFIEN_U_RRFSTN_U_STN_U_INUM_U_DVBINF
+23 SET LINE(8)="$SPEC "_SPEC
+24 SET LINE(9)="$RDES "_RD
End DoDot:1
+25 ;**NOTE: RONAM is now RO NUMBER
LOAD SET L=1
SET ^TMP("DVBCXFR",$JOB,L,0)="$TRANSFER IN"
SET L=L+1
+1 FOR X=1:1
if '$DATA(LINE(X))
QUIT
SET ^TMP("DVBCXFR",$JOB,L,0)=LINE(X)
SET L=L+1
+2 FOR JI=0:0
SET JI=$ORDER(^DVB(396.3,REQDA,2,JI))
if JI=""
QUIT
SET ^TMP("DVBCXFR",$JOB,L,0)="$REMK "_^DVB(396.3,REQDA,2,JI,0)
SET L=L+1
+3 SET SITE=$PIECE(^XMB(1,1,0),U,1)
SET SITE1=$PIECE(^DIC(4.2,SITE,0),U,1)
+4 SET USERNM=$PIECE(^VA(200,DUZ,0),U,1)
SET ^TMP("DVBCXFR",$JOB,L,0)="$USER "_USERNM_U_SITE_U_SITE1
SET L=L+1
+5 SET ^TMP("DVBCXFR",$JOB,L,0)="$END "
+6 NEW XMNODE
+7 SET XMNODE=0
+8 FOR X=(L+1):1:(L+XMCNT)
Begin DoDot:1
+9 SET XMNODE=XMNODE+1
+10 SET ^TMP("DVBCXFR",$JOB,X,0)=XMVAR(XMNODE)
End DoDot:1
+11 SET ^TMP("DVBCXFR",$JOB,X+1,0)="$END1 "
+12 ;
SEND KILL XMZ
+1 ;S XMY("POSTMASTER@"_DOMNAM)=DOMNUM
+2 NEW RRIF
+3 SET RRXM=0
+4 ;Check for reroute within VAMC
+5 IF RRF'=INAM
Begin DoDot:1
+6 SET XMY(DUZ)=""
SET XMY("S.DVBA C PROCESS MAIL MESSAGE@"_DOMNAM)=DOMNUM
SET XMSUB="Transfer of C&P Exams"
SET XMTEXT="^TMP(""DVBCXFR"",$J,"
SET XMDUZ=DUZ
+7 DO ^XMD
+8 IF $DATA(XMZ)
SET RTN="1^Transmitted as message # "_XMZ_" from this site to "_DOMNAM
+9 IF '$DATA(XMZ)
SET RTN="0^Message transmission error! Request WILL NOT be rerouted!"
SET RRXM=1
End DoDot:1
+10 ;if all ok, update main, sub-file
+11 IF RRXM=1
DO VKILL
QUIT
+12 IF RRF=INAM
SET RTN="1^Rerouted to another division within "_RRF
+13 FOR III=0:0
SET III=$ORDER(XEXAMS(III))
if III=""
QUIT
Begin DoDot:1
+14 SET DIE="^DVB(396.4,"
SET DA=III
SET DR=".04///T;62///"_DOMNAM_";60////"_DT_";61///"_USERNM
+15 DO ^DIE
End DoDot:1
+16 ;patch 227 introducing new status
+17 KILL DIE,DA,DR
SET DIE="^DVB(396.3,"
SET DA=REQDA
SET DR="17///16"
+18 ;
+19 ; ajf - Defect #2 - 02/17/2017
+20 SET CSITE=+$$SITE^VASITE
+21 IF CSITE=RRFIEN&(CSITE=INUM)
SET DR=DR_";24////"_$PIECE(^DVB(396.15,RDIV,0),"^")
+22 ;set transfer items
DO ^DIE
+23 ;
+24 SET RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
+25 SET DA=$PIECE(RRIF,"^")
+26 SET DIE="^DVB(396.3,"_REQDA_",6,"
SET DA(1)=REQDA
+27 SET DR="1////"_REQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD
+28 SET DR=DR_";.02////"_INAM_";8////"_RRDIV_";7////"_DUZ
+29 SET DR=DR_";9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN
+30 ;set Reroute fields
DO ^DIE
+31 SET RRIEN=DA
SET RRST="N"
SET RRR=""
+32 ; Update the status
DO UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR)
+33 ; Send Reroute message to Requestor
+34 DO SENDMSG^DVBAB1C(REQDA)
+35 ;
+36 ; REQDA = 2507 Request IEN
+37 ; INUM = Institution IEN
+38 ; PIEN = Patient IEN
+39 ; DIEN = Division IEN
+40 ; RR = Reroute Reason
+41 ; RD = Reroute Description
+42 ;
+43 ;
+44 ;
+45 KILL LINE,DOMNUM,DOMNUM1,^TMP("DVBCXFR",$JOB),XMDUZ,III,L,JI,JY,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,DIE,DA,DR,TYPE
+46 ;
VKILL ; Kill varables from process
+1 ;
+2 KILL XMERR,ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTYP,CNTY,CNUM
+3 KILL CSITE,DFN,DOB,DOMNAM,ECF,ELIGCOD,ELIGSDT,ELIGST,EXAMS,FEXM
+4 KILL HOMPHON,II,INUM,LREXMDT,MDIV,OTDIS,OTHDIS,OTHDIS1,OTHDIS2,OTHDOC,PDSRV
+5 KILL PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV
+6 KILL RRFD,RRIEN,RRR,RRF,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT,DVBINF
+7 KILL SRVPCT,SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,DMAS,INAM
+8 DO KILL^DVBCUTIL
DO KILL^DVBCUTL2
DO KILL^DVBCUTL3
+9 QUIT
