DVBCUTL8 ;ALB/GTS-AMIE C&P APPT LINK FILE MNT RTNS 2 ; 10/20/94  3:30 PM
 ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
 ;
 ;** NOTICE: This routine is part of an implementation of a Nationally
 ;**         Controlled Procedure.  Local modifications to this routine
 ;**         are prohibited per VHA Directive 10-93-142
 ;
 ;** Version Changes
 ;   2.7 - New routine (Enhc 13)
 
Q
 
;
FIXLK ;** Re-attach unlinked appt to new appt
 ;
 ;** ^TMP("DVBC",$J,) must have nodes:
 ;**    ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION,
 ;**    VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked
 ;
 
REQDT,SAVY
 
S:$D(YSAVY=Y
 
REQDT=$$GETDTE^DVBCMKLK(DVBADA;**Set REQDT
 
S:$D(SAVYY=SAVY
 
DIR("A",1)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
 
DIR("A",2)=" "
 
DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." ^DIR DIR,X,Y
 
ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE,INITAPPT
 
VETDTE=""
 
ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE")
 
CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE")
 
VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION")
 
S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE")
 
APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS")
 
DA,DIE,DR
 
;
 ;** Only one current appt date/time for vet can exist in 396.95
 
DA="" DA=DVBAOLDA
 
APPTNODE=^DVB(396.95,DA,0) ;**APPTNODE 396.95 rec before mods
 
DIE="^DVB(396.95,",DR=""
 ;
 ;** If 396.95 initial appt lost, set to original appt
 
I $P(APPTNODE,U,1)="",($P(APPTNODE,U,2)'=""INITAPPT=$P(APPTNODE,U,2)
 
I $P(APPTNODE,U,1)="" DR=".01////^S X=INITAPPT;"
 
I $P(APPTNODE,U,4)'=1 DR=DR_".02////^S X=ORIGAPPT;"
 
DR=DR_".03////^S X=CURRAPPT;"
 
I $P(APPTNODE,U,4)'=1 DR=DR_".04////^S X=VETCANC;"
 
VETCANC=1 DR=DR_".05////^S X=VETDTE;" ;**Update last vet req date
 
DR=DR_".07////^S X=APPTSTAT"
 
^DIE DIE,DA,DR
 
Q
 
;
ADDLK ;** Add link from 2507 to appt
 ;
 ;** ^TMP("DVBC",$J,) nodes:
 ;**    ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION,
 ;**    VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked
 ;
 
REQDT,SAVY
 
S:$D(YSAVY=Y
 
REQDT=$$GETDTE^DVBCMKLK(DVBADA;**Set REQDT
 
S:$D(SAVYY=SAVY
 
DIR("A",1)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
 
DIR("A",2)=" "
 
DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." ^DIR DIR,X,Y
 
ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE
 
VETDTE=""
 
ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE")
 
CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE")
 
VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION")
 
S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE")
 
APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS")
 
DA,DIC,X,DD,DO
 
X=^TMP("DVBC",$J,"INITIAL APPT DATE")
 
DIC="^DVB(396.95,",DIC(0)="L",DIC("DR")=""
 
DIC("DR")=DIC("DR")_".02////^S X=ORIGAPPT;.03////^S X=CURRAPPT;"
 
DIC("DR")=DIC("DR")_".04////^S X=VETCANC;.05////^S X=VETDTE;"
 
DIC("DR")=DIC("DR")_".06////^S X=DVBADA;.07////^S X=APPTSTAT"
 
FILE^DICN
 
+Y'>0 DO
 
.DIR("A",1)="The C&P appointment link was not properly added.  Please investigate the"
 
.DIR("A",2)="appointment scheduled for "_ORIGAPPT_" for "_$P(^DPT(DVBADFN,0),U,1)
 .
DIR("A",3)=" "
 
.DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." ^DIR DIR,X,Y
 
DIC,DA,X,Y
 
Q
 
;
STYLE(REQDA) ;** Return indication of 2507 status matching integ report type
 
STATIND,REQSTAT,STYLEIND,PARAMDA
 
STATIND=0 ;**Leave set to zero if STYLEIND=4
 
REQSTAT=$$RSTAT($P(^DVB(396.3,REQDA,0),U,18))
 
PARAMDA=0
 
PARAMDA=$O(^DVB(396.1,PARAMDA))
 
STYLEIND=$P(^DVB(396.1,PARAMDA,0),U,15)
 
STYLEIND="1" S:"P^S"[REQSTAT STATIND=1
 
STYLEIND="2" S:"R^C"[REQSTAT STATIND=1
 
STYLEIND="3" STATIND=1
 
+STATIND
 
;
SELLNK(REQDA) ;** Return IEN from 396.95 for link to modify
 
SELDA
 
LNKARY^DVBCUTA3(REQDA,DVBADFN;**Set up link array
 
'$D(TMP("DVBC LINK")) DO
 
.SELDA=0,DVBANOLK=""
 
.NOLNK^DVBCLKT2
 
I $D(TMP("DVBC LINK")) DO
 
.'$D(DVBAAPTDO
 
..Y=$P(SDATA,U,3)
 ..
^DD("DD")
 ..
DVBAAPT=Y
 
..DVBAAPST=""
 
.LINKDISP^DVBCUTA1
 .
I $D(DVBAAPSTDVBAAPT,DVBAAPST
 
Y
 
+SELDA
 
;
 ;AJF; Request Status Conversion
RSTAT(RSP) ;**Return Request Status Code from 396.33
 ;RSP - IEN for file 396.33
 
Q:'$D(RSP""
 
Q:'+RSP ""
 
Q:'$D(^DVB(396.33,RSP,0)) ""
 
Q $P(^DVB(396.33,RSP,0),"^",2)
 
;
 ;AJF; Request Status Conversion
RTSTAT(RSP) ;**Return Status (External) from 396.33
 ;RSP - IEN for file 396.33
 
Q:'$D(RSP""
 
Q:'+RSP ""
 
Q:'$D(^DVB(396.33,RSP,0)) ""
 
Q $P(^DVB(396.33,RSP,0),"^",1)
 
;
 ;AJF ; Reroute function
REROST(RTN,RSP) ;**Returns 1 if this Request is able to be rerouted
 ;RPC: DVBA CAPRI GET REROUTE
 ;RSP - IEN for file 396.3
 ;RTN - Return value 1 for yes  0 for no
 
Q:'$D(RSP) 0
 
Q:'+RSP 0
 
Q:'$D(^DVB(396.3,RSP,0)) 0
 
CSITE,RSTA,FSITE
 
RTN=0
 
CSITE=$P($$SITE^VASITE,"^",3)
 
FSITE=$S('$D(^DVB(396.3,RSP,6,1,2)):CSITE,1:$P(^DVB(396.3,RSP,6,1,2),"^",4))
 
RSTA=$P(^DVB(396.3,RSP,0),"^",18)
 
CSITE=FSITE S:RSTA=1!(RSTA=2)!(RSTA=12) RTN=1
 
RTN=RTN_"^"_CSITE
 
Q
 
;
CDIV(RTN,SITE) ;AJF ; Provides list from CAPRI DIVISION EXAM (396.15
 ;RPC DVBA CAPRI GET DIVISION
 ;RTN - Return list of active divisions "^" Division IEN
 ;
 
CNT,DN,DVP,DV0,FNUM
 
I=0,RTN(1)="No active CAPRI Divisions"
 
F  S I=$O(^DVB(396.15,I)) Q:I="B"!(I="")  D
 
Q:$P($G(^DVB(396.15,I,3)),"^")="Y"
 
CNT=$G(CNT)+1,DVP=$P(^DVB(396.15,I,0),"^")
 . 
Q:DVP=""
 
DV0=$G(^DG(40.8,DVP,0))
 . 
DN=$P(DV0,"^",1),FNUM=$P(DV0,"^",2)
 . 
RTN(CNT)=DN_"  "_FNUM_"^"_I
 
Q
 
;
CDIVC(RTN,DIV) ;AJF; Provides comments for GUI
 ; RPC: DVBA CAPRI GET DIV COMMENT
 ; RTN - Return comment
 ; DIV - Division IEN
 
I
 
I=0,RTN(1)="No Division comment available "
 
Q:'$D(DIV)
 
Q:'+DIV
 
F  S I=$O(^DVB(396.15,DIV,2,I)) Q:I=""  D
 
.Q:'$D(^DVB(396.15,DIV,2,I,0))
 . 
RTN(I)=^DVB(396.15,DIV,2,I,0)
 
Q
CDIVE(RTN,DIV) ;AJF ; Provides list of active exams
 ; RPC: DVBA CAPRI GET DIV EXAM
 ; RTN - Return exam 
 ; DIV - Division IEN
 
C2,C3,EN,CNT
 
(C2,CNT)=0,RTN(1)="No exam found"
 
Q:'$D(DIV)
 
Q:'+DIV
 
F  S C2=$O(^DVB(396.15,DIV,1,C2)) Q:C2="B"!(CNT=100)  D
 
Q:"DEFAULT "'[$E(^DVB(396.15,DIV,1,C2,0),1,7)
 . 
C3=0
 . 
F  S C3=$O(^DVB(396.15,DIV,1,C2,3,C3)) Q:C3=""!(CNT=100)  D
 
.. Q:'$D(^DVB(396.15,DIV,1,C2,3,C3,0))
 .. 
Q:$G(^DVB(396.15,DIV,1,C2,3,C3,2))'="Y"
 
.. EN=$P(^DVB(396.15,DIV,1,C2,3,C3,0),"^")
 .. 
EN=$$EXTERNAL^DILFD(396.1514,.01,,EN,)
 .. 
CNT=CNT+1,RTN(CNT)=EN
 
Q
 
;
ARC(RTN) ;AJF ;7/15/2016 Returns all active Reroute Code
 ; RPC: DVBA CAPRI GET REROUTE CODE
 ; RTN - Return exam 
 ; 
 
CT,C1,R0,R2
 
CT=0
 
F  S CT=$O(^DVB(396.55,CT)) Q:CT="B"  D
 
R0=^DVB(396.55,CT,0)
 . 
Q:$P(R0,"^",2)="I"
 
C1=$G(C1)+1
 . 
RTN(C1)=CT_"^"_$P(R0,"^")
 
Q
 
;
RINFO(RTN,RIEN) ;AJF; Returns reroute information for a given 2507 Request
 ;RPC: DVBA CAPRI REROUTE INFO
 ;Input
 ; RIEN: 2507 Request IEN
 ;
 ;Output
 ;  REROUTE TO^REROUTE DATE^REROUTE STATUS^STATUS DATE^REROUTED FROM^ REROUTE REASON ^ REJECT REASON
 ;  ^ 0 for site A/ 1 for site B or C
 ;
 
RTD,RTF,RTO,RTS,RTSD,RRD,RRD,J1,J2,J10,J20,J4
 
REJR,RRW1,RRW2,RUSR,RDIV,RTDIV,RFDIV,CST,CRQ
 
RIEN="" RTN="0^Missing 2507 Request IEN" Q
 I 
'$D(^DVB(396.3,RIEN,0)) RTN="0^Not a valid 2507 Request IEN" Q
 I 
'$D(^DVB(396.3,RIEN,6,0)) RTN="0^This 2507 Request has not been Rerouted" Q
 
;
 
J1=$O(^DVB(396.3,RIEN,6,99999),-1)
 
J2=$O(^DVB(396.3,RIEN,6,J1,1,99999),-1)
 
J2="" RTN="0^This 2507 Request has not been Rerouted" Q
 S 
J10=^DVB(396.3,RIEN,6,J1,0),J20=^DVB(396.3,RIEN,6,J1,1,J2,0)
 
J4=$G(^DVB(396.3,RIEN,6,J1,2))
 
REJR=$G(^DVB(396.3,RIEN,6,J1,1,J2,1))
 
RTD=$$EXTERNAL^DILFD(396.34,.01,,$P(J10,"^",1))
 
RTO=$$EXTERNAL^DILFD(396.34,.02,,$P(J10,"^",7))
 
RTF=$$EXTERNAL^DILFD(396.34,3,,$P(J10,"^",4))
 
RTSD=$$EXTERNAL^DILFD(396.341,.01,,$P(J20,"^",1))
 
RTS=$$EXTERNAL^DILFD(396.341,1,,$P(J20,"^",2))
 
RRR=$$EXTERNAL^DILFD(396.34,4,,$P(J10,"^",5))
 
RRD=$G(^DVB(396.3,RIEN,6,J1,1))
 
RTDIV=$$EXTERNAL^DILFD(396.3,24,,$P(^DVB(396.3,RIEN,1),"^",4))
 
RFDIV=$$EXTERNAL^DILFD(396.34,8,,$P(J10,"^",9))
 
;
 
CSITE=+$$SITE^VASITE,CRQ=$P(^DVB(396.3,RIEN,0),"^",18),RRW1=0
 
CSITE=$P(J4,"^",1)&(CSITE=$P(J4,"^",3)) RRW1=1
 
RRW2=$S(RRW1:1,CSITE=$P(J4,"^",3):0,1:1)
 
CST=$S(RRW2=0:0,CRQ=14:1,CRQ=11:1,1:0)
 
;
 
RTN(1)=RTO_"^"_RTD_"^"_RTS_"^"_RTSD_"^"_RTF_"^"_RRR_"^"_CST_"^"_RFDIV_"^"_RTDIV
 
RTN(2)=RRD
 
RTN(3)=REJR
 
;
 
Q
RPRO(RTN,RIEN,RRST,RRR) ; AJF; 7/25/2016; Update Reroute Status
 ;RPC: DVBA CAPRI REROUTE STATUS
 ;Input:
 ;  RIEN = 2507 Request IEN
 ;  RRST = Reroute status
 ;  RRR = Reject Reason
 ;
 ;Output:
 ;  RTN = 0 for Failure
 ;        1 for Success
 ;
 
OSITE,OIEN,DA,DR,DIE,REJM,NSITE,RRUP,J1,J2,DIV1,DIV2
 
RIEN="" RTN="0^Missing 2507 Request IEN" Q
 I 
'$D(^DVB(396.3,RIEN,0)) RTN="0^Not a valid 2507 Request IEN" Q
 I 
'$D(^DVB(396.3,RIEN,6,0)) RTN="0^This 2507 Request has not been rerouted" Q
 
;
 
RRR=$G(RRR)
 
J1=$O(^DVB(396.3,RIEN,6,99999),-1)
 
J2=$O(^DVB(396.3,RIEN,6,J1,99999),-1)
 
J2="" RTN="0^This 2507 Request has not been rerouted" Q
 S 
RRIEN=J1,RRDT=$$NOW^XLFDT()
 
RRUP=$$UPRS(RIEN,RRIEN,RRDT,RRST,RRR)
 
;
 
R0=^DVB(396.3,RIEN,6,J1,0)
 
R1=^DVB(396.3,RIEN,6,J1,2)
 
CSITE=$P($$SITE^VASITE,"^",3),OSITE=$P(R1,"^",4),OIEN=$P(R0,"^",2),NSITE=$P(R1,"^",2)
 
DIV1=$P(R0,"^",9),DIV2=$P($G(^DVB(396.3,RIEN,1)),"^",4)
 
CSITE=OSITE,CSITE=NSITE,RRST="R" D
 
DIE="^DVB(396.3,"_RIEN_",6,",DA=J1,DA(1)=RIEN
 
DR="8////"_DIV2
 
^DIE ;set Reroute fields
 
DIE,DA
 
; Check to see if this the original site
 
CSITE=OSITE D
 
RRST="A" DR="6////"_RRDT_";17////13" Q
 
RRST="R" DR="17////1",REJM=1 EXSET(RIEN,"O"^DVB(396.3,"AR",RRDT,RIEN)=""
 
CSITE'=OSITE D
 
RRST="A" DR="17////2" Q
 
RRST="R" DR="6////"_RRDT_";17////12" EXSET(RIEN,"T")
 
CSITE=OSITE,CSITE=NSITE D
 
RRST="A" DR="17////2" Q
 
RRST="R" DR="17////1;24////"_DIV1,^DVB(396.3,"AR",RRDT,RIEN)=""
 
DA=RIEN,DIE="^DVB(396.3,"
 
^DIE
 
;
 ; Send Reject Message to DVBA C 2507 Reroute Group
 
D:RRST="R" MSG^DVBAB1C(RIEN)
 

 
CSITE=OSITE RTN="1^Reroute status updated" Q
 
;
 
OIEN=$P(R0,"^",2)
 
RTN="1^Reroute status updated^"_OSITE_"^"_OIEN
 

 

 
;
 ;
UPRR(RIEN,RRDT) ;AJF ; 7/30/2016; Update Reroute information
 ;create Reroute entry for 2507 Request in sub-file 396.33
 
DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DO
 
DIC="^DVB(396.3,"_RIEN_",6,",DA(1)=RIEN
 
DIC(0)="L",DLAYGO=396.3
 
X=RRDT  ;.01 2507 REQUEST REROUTE DATE
 
FILE^DICN DLAYGO
 
;
 ;
 
Y_"^"_RRDT
 
;
UPRS(RIEN,RRIEN,RRDT,RRST,RRR) ; Update the status
 
DIC,X,Y,DA,DO,DTOUT,DUOUT,DLAYGO
 
RRR=$G(RRR)
 
DIC="^DVB(396.3,"_RIEN_",6,"_RRIEN_",1,"
 
DA(1)=RIEN,DA(2)=RRIEN
 
DIC(0)="FL",DLAYGO=396.3
 
X=RRDT  ;.01 2507 REQUEST REROUTE DATE
 
DIC("DR")="1////"_RRST_";2////"_RRR
 
FILE^DICN
 
R2=Y
 
Y
 
;
EXSET(RIEN,EST) ;Set Exam status
 
Q:RIEN=""!(EST="")
 
DA,DIE,DR,JJ
 
JJ=0:0 JJ=$O(^DVB(396.4,"C",RIEN,JJ)) Q:JJ=""  D
 
I $P(^DVB(396.4,JJ,0),U,4)="X" Q
 
I $P(^DVB(396.4,JJ,0),U,4)="C" Q
 
DA=JJ,DIE="^DVB(396.4,",DR=".04////"_EST
 
^DIE
 
Q