DVBCXFR1 ;AJF/ReRoute C&P Request ; 7/18/16 2:14 PM
;;2.7;AMIE;**193**;;Build 84
;
;
Q
EN(RTN,REQDA,PIEN,SNUM,RDIV,RR,RD) ;Call from CAPRI
; RPC: DVBA CAPRI SEND REROUTE
;
;ReRoute C&P 2507 Request
; RTN = Return value
; REQDA = 2507 Request IEN
; SNUM = CAPRI Reroute IEN
; PIEN = Patient IEN
; RDIV = Division IEN
; RR = Reroute Reason
; RD = Reroute Description
;
I $G(REQDA)="" S RTN="0^Missing request number number" Q
I $G(SNUM)="" S RTN="0^Missing CAPRI Reroute Site number" Q
I $G(PIEN)="" S RTN="0^Missing Patient IEN" Q
I $G(RDIV)="" S RTN="0^Missing Routing Location" Q
I $G(RR)="" S RTN="0^Missing Reroute Reason" Q
I '$D(^DVB(396.3,REQDA,0)) S RTN="0^Not a valad request number" Q
I '$D(^DVB(396.195,SNUM)) S RTN="0^Not a valid CAPRI Reroute Site IEN" Q
;
N R0,DFN,DIEN,DOMNAM,DOMNUM,DOMNUM1,EXAMS,EXMNM,EXR,JJ,PNAM,INAM
N SSN,XMCNT,XMVAR
S R0=^DVB(396.3,REQDA,0)
K DVBAINSF
I $P(R0,U,18)>2 S RTN="0^This request does not have a NEW or PENDING status and may not be rerouted." Q
;I $P(R0,U,18)'=1,($P(R0,U,18)'=2),($P(R0,U,18)'=12) S RTN="0^This request does not have a NEW or PENDING status and may not be rerouted." Q
;I $P(R0,U,22)]"" S RTN="0^This request was transferred in and CANNOT be transferred to any other site " Q
;
S DFN=$P(R0,U,1)
I DFN'=PIEN S RTN="0^Patient IEN passed in does match 2507 Request" Q
S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9)
S:$P(R0,U,10)="E" DVBAINSF=""
S DOMNAM=$P(^DVB(396.195,SNUM,0),"^",3)
S DIEN=$O(^DIC(4.2,"B",DOMNAM,""))
I DIEN="" S RTN="0^Domain Name not found in Domain File. Please contact IRM for assistance." Q
S STN=$P(^DIC(4.2,DIEN,0),"^",13)
I STN="" S RTN="0^Station Number not found in Domain File. Please contact IRM for assistance." Q
S INUM=$O(^DIC(4,"D",STN,0))
I INUM'="" S TSITE=$P($G(^DIC(4,INUM,0)),"^",1)
S:INUM="" INUM=STN
S DOMNUM=$S($P(^DIC(4.2,DIEN,0),U,3)]"":$P(^(0),U,3),1:DIEN)
S INAM=$S($D(TSITE):TSITE,1:$P(^DIC(4.2,DIEN,0),U,1))
S DOMNUM1=DIEN
;
I $L($G(RD))>250 S RD=$E(RD,1,250)
;I $D(CORR) G DISPLAY
;
;EXAMS K XEXAMS W @FF,!,"Exam selection",!!!! S EXAMS="",XMCNT=0
;F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
;W !!,"Do you want to transfer ALL exams" S %=2 D YN^DICN G:%<0 EXIT
;I %=2 W !! G PART
;I %=0 W !!,"Enter Y if you want to transfer all exams or N if not.",!! D CONTMES^DVBCUTL4 G EXAMS
;W !!!
K XEXAMS S EXAMS="",XMCNT=0
F JJ=0:0 S JJ=$O(^DVB(396.4,"C",REQDA,JJ)) Q:JJ="" D SET
;
D INREAS^DVBCXUTL
MAILMAN D ^DVBCXFR2
;
Q
;
SET ;** EXAMS - Xfr all
S EXMNM=$P(^DVB(396.6,$P(^DVB(396.4,JJ,0),U,3),0),U,1)
I $P(^DVB(396.4,JJ,0),U,4)["X" S EXR(JJ)=EXMNM_" is CANCELED and cannot be transferred." Q
I $P(^DVB(396.4,JJ,0),U,4)="C" S EXR(JJ)=EXMNM_" is COMPLETED and cannot be transferred." Q
I $P(^DVB(396.4,JJ,0),U,4)="T" S EXR(JJ)=EXMNM_" has been TRANSFERRED and cannot be selected." Q
;W !,EXMNM," is OK to transfer.",!!
S EXAMS=EXAMS_$P(^DVB(396.4,JJ,0),U,3)_U,XEXAMS(JJ)="",XMCNT=XMCNT+1
;
;** Set XMVAR(XMCNT)=$EXAM AMIE EXAM IFN^INSUFF REASON IFN
S XMVAR(XMCNT)="$EXAM "_$P(^DVB(396.4,JJ,0),U,3)_U_$S(+$P(^DVB(396.4,JJ,0),U,11)>0:$P(^DVB(396.94,$P(^DVB(396.4,JJ,0),U,11),0),U,1),1:"")
;EXAMS for MailMan msg, XEXAMS sets exam status
;XMVAR() add one exam/line to bulletin - Future
Q
;
;
EXIT D CLRVAR^DVBCXUTL,KILLVRS^DVBCXUTL,KILL^DVBCUTIL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFR1 3434 printed Sep 23, 2025@19:30:30 Page 2
DVBCXFR1 ;AJF/ReRoute C&P Request ; 7/18/16 2:14 PM
+1 ;;2.7;AMIE;**193**;;Build 84
+2 ;
+3 ;
+4 QUIT
EN(RTN,REQDA,PIEN,SNUM,RDIV,RR,RD) ;Call from CAPRI
+1 ; RPC: DVBA CAPRI SEND REROUTE
+2 ;
+3 ;ReRoute C&P 2507 Request
+4 ; RTN = Return value
+5 ; REQDA = 2507 Request IEN
+6 ; SNUM = CAPRI Reroute IEN
+7 ; PIEN = Patient IEN
+8 ; RDIV = Division IEN
+9 ; RR = Reroute Reason
+10 ; RD = Reroute Description
+11 ;
+12 IF $GET(REQDA)=""
SET RTN="0^Missing request number number"
QUIT
+13 IF $GET(SNUM)=""
SET RTN="0^Missing CAPRI Reroute Site number"
QUIT
+14 IF $GET(PIEN)=""
SET RTN="0^Missing Patient IEN"
QUIT
+15 IF $GET(RDIV)=""
SET RTN="0^Missing Routing Location"
QUIT
+16 IF $GET(RR)=""
SET RTN="0^Missing Reroute Reason"
QUIT
+17 IF '$DATA(^DVB(396.3,REQDA,0))
SET RTN="0^Not a valad request number"
QUIT
+18 IF '$DATA(^DVB(396.195,SNUM))
SET RTN="0^Not a valid CAPRI Reroute Site IEN"
QUIT
+19 ;
+20 NEW R0,DFN,DIEN,DOMNAM,DOMNUM,DOMNUM1,EXAMS,EXMNM,EXR,JJ,PNAM,INAM
+21 NEW SSN,XMCNT,XMVAR
+22 SET R0=^DVB(396.3,REQDA,0)
+23 KILL DVBAINSF
+24 IF $PIECE(R0,U,18)>2
SET RTN="0^This request does not have a NEW or PENDING status and may not be rerouted."
QUIT
+25 ;I $P(R0,U,18)'=1,($P(R0,U,18)'=2),($P(R0,U,18)'=12) S RTN="0^This request does not have a NEW or PENDING status and may not be rerouted." Q
+26 ;I $P(R0,U,22)]"" S RTN="0^This request was transferred in and CANNOT be transferred to any other site " Q
+27 ;
+28 SET DFN=$PIECE(R0,U,1)
+29 IF DFN'=PIEN
SET RTN="0^Patient IEN passed in does match 2507 Request"
QUIT
+30 SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
+31 if $PIECE(R0,U,10)="E"
SET DVBAINSF=""
+32 SET DOMNAM=$PIECE(^DVB(396.195,SNUM,0),"^",3)
+33 SET DIEN=$ORDER(^DIC(4.2,"B",DOMNAM,""))
+34 IF DIEN=""
SET RTN="0^Domain Name not found in Domain File. Please contact IRM for assistance."
QUIT
+35 SET STN=$PIECE(^DIC(4.2,DIEN,0),"^",13)
+36 IF STN=""
SET RTN="0^Station Number not found in Domain File. Please contact IRM for assistance."
QUIT
+37 SET INUM=$ORDER(^DIC(4,"D",STN,0))
+38 IF INUM'=""
SET TSITE=$PIECE($GET(^DIC(4,INUM,0)),"^",1)
+39 if INUM=""
SET INUM=STN
+40 SET DOMNUM=$SELECT($PIECE(^DIC(4.2,DIEN,0),U,3)]"":$PIECE(^(0),U,3),1:DIEN)
+41 SET INAM=$SELECT($DATA(TSITE):TSITE,1:$PIECE(^DIC(4.2,DIEN,0),U,1))
+42 SET DOMNUM1=DIEN
+43 ;
+44 IF $LENGTH($GET(RD))>250
SET RD=$EXTRACT(RD,1,250)
+45 ;I $D(CORR) G DISPLAY
+46 ;
+47 ;EXAMS K XEXAMS W @FF,!,"Exam selection",!!!! S EXAMS="",XMCNT=0
+48 ;F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
+49 ;W !!,"Do you want to transfer ALL exams" S %=2 D YN^DICN G:%<0 EXIT
+50 ;I %=2 W !! G PART
+51 ;I %=0 W !!,"Enter Y if you want to transfer all exams or N if not.",!! D CONTMES^DVBCUTL4 G EXAMS
+52 ;W !!!
+53 KILL XEXAMS
SET EXAMS=""
SET XMCNT=0
+54 FOR JJ=0:0
SET JJ=$ORDER(^DVB(396.4,"C",REQDA,JJ))
if JJ=""
QUIT
DO SET
+55 ;
+56 DO INREAS^DVBCXUTL
MAILMAN DO ^DVBCXFR2
+1 ;
+2 QUIT
+3 ;
SET ;** EXAMS - Xfr all
+1 SET EXMNM=$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,JJ,0),U,3),0),U,1)
+2 IF $PIECE(^DVB(396.4,JJ,0),U,4)["X"
SET EXR(JJ)=EXMNM_" is CANCELED and cannot be transferred."
QUIT
+3 IF $PIECE(^DVB(396.4,JJ,0),U,4)="C"
SET EXR(JJ)=EXMNM_" is COMPLETED and cannot be transferred."
QUIT
+4 IF $PIECE(^DVB(396.4,JJ,0),U,4)="T"
SET EXR(JJ)=EXMNM_" has been TRANSFERRED and cannot be selected."
QUIT
+5 ;W !,EXMNM," is OK to transfer.",!!
+6 SET EXAMS=EXAMS_$PIECE(^DVB(396.4,JJ,0),U,3)_U
SET XEXAMS(JJ)=""
SET XMCNT=XMCNT+1
+7 ;
+8 ;** Set XMVAR(XMCNT)=$EXAM AMIE EXAM IFN^INSUFF REASON IFN
+9 SET XMVAR(XMCNT)="$EXAM "_$PIECE(^DVB(396.4,JJ,0),U,3)_U_$SELECT(+$PIECE(^DVB(396.4,JJ,0),U,11)>0:$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,JJ,0),U,11),0),U,1),1:"")
+10 ;EXAMS for MailMan msg, XEXAMS sets exam status
+11 ;XMVAR() add one exam/line to bulletin - Future
+12 QUIT
+13 ;
+14 ;
EXIT DO CLRVAR^DVBCXUTL
DO KILLVRS^DVBCXUTL
DO KILL^DVBCUTIL
