DVBCUTL8 ;ALB/GTS-AMIE C&P APPT LINK FILE MNT RTNS 2 ; 9/29/21 11:46pm
;;2.7;AMIE;**193,227**;Apr 10, 1995;Build 21
;Per VHA Directive 2004-038, this routine should not be modified.
;
;** 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
;
N REQDT,SAVY
S:$D(Y) SAVY=Y
S REQDT=$$GETDTE^DVBCMKLK(DVBADA) ;**Set REQDT
S:$D(SAVY) Y=SAVY
S DIR("A",1)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
S DIR("A",2)=" "
S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
N ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE,INITAPPT
S VETDTE=""
S ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE")
S CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE")
S VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION")
S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE")
S APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS")
K DA,DIE,DR
;
;** Only one current appt date/time for vet can exist in 396.95
S DA="" S DA=DVBAOLDA
S APPTNODE=^DVB(396.95,DA,0) ;**APPTNODE 396.95 rec before mods
S DIE="^DVB(396.95,",DR=""
;
;** If 396.95 initial appt lost, set to original appt
I $P(APPTNODE,U,1)="",($P(APPTNODE,U,2)'="") S INITAPPT=$P(APPTNODE,U,2)
I $P(APPTNODE,U,1)="" S DR=".01////^S X=INITAPPT;"
I $P(APPTNODE,U,4)'=1 S DR=DR_".02////^S X=ORIGAPPT;"
S DR=DR_".03////^S X=CURRAPPT;"
I $P(APPTNODE,U,4)'=1 S DR=DR_".04////^S X=VETCANC;"
I VETCANC=1 S DR=DR_".05////^S X=VETDTE;" ;**Update last vet req date
S DR=DR_".07////^S X=APPTSTAT"
D ^DIE K 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
;
N REQDT,SAVY
S:$D(Y) SAVY=Y
S REQDT=$$GETDTE^DVBCMKLK(DVBADA) ;**Set REQDT
S:$D(SAVY) Y=SAVY
S DIR("A",1)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
S DIR("A",2)=" "
S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
N ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE
S VETDTE=""
S ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE")
S CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE")
S VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION")
S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE")
S APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS")
K DA,DIC,X,DD,DO
S X=^TMP("DVBC",$J,"INITIAL APPT DATE")
S DIC="^DVB(396.95,",DIC(0)="L",DIC("DR")=""
S DIC("DR")=DIC("DR")_".02////^S X=ORIGAPPT;.03////^S X=CURRAPPT;"
S DIC("DR")=DIC("DR")_".04////^S X=VETCANC;.05////^S X=VETDTE;"
S DIC("DR")=DIC("DR")_".06////^S X=DVBADA;.07////^S X=APPTSTAT"
D FILE^DICN
I +Y'>0 DO
.S DIR("A",1)="The C&P appointment link was not properly added. Please investigate the"
.S DIR("A",2)="appointment scheduled for "_ORIGAPPT_" for "_$P(^DPT(DVBADFN,0),U,1)
.S DIR("A",3)=" "
.S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
K DIC,DA,X,Y
Q
;
STYLE(REQDA) ;** Return indication of 2507 status matching integ report type
N STATIND,REQSTAT,STYLEIND,PARAMDA
S STATIND=0 ;**Leave set to zero if STYLEIND=4
S REQSTAT=$$RSTAT($P(^DVB(396.3,REQDA,0),U,18))
S PARAMDA=0
S PARAMDA=$O(^DVB(396.1,PARAMDA))
S STYLEIND=$P(^DVB(396.1,PARAMDA,0),U,15)
I STYLEIND="1" S:"P^S"[REQSTAT STATIND=1
I STYLEIND="2" S:"R^C"[REQSTAT STATIND=1
I STYLEIND="3" S STATIND=1
Q +STATIND
;
SELLNK(REQDA) ;** Return IEN from 396.95 for link to modify
N SELDA
D LNKARY^DVBCUTA3(REQDA,DVBADFN) ;**Set up link array
I '$D(TMP("DVBC LINK")) DO
.S SELDA=0,DVBANOLK=""
.D NOLNK^DVBCLKT2
I $D(TMP("DVBC LINK")) DO
.I '$D(DVBAAPT) DO
..S Y=$P(SDATA,U,3)
..X ^DD("DD")
..S DVBAAPT=Y
..S DVBAAPST=""
.D LINKDISP^DVBCUTA1
.I $D(DVBAAPST) K DVBAAPT,DVBAAPST
K Y
Q +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
N CSITE,RSTA,FSITE
S RTN=0
S CSITE=$P($$SITE^VASITE,"^",3)
S FSITE=$S('$D(^DVB(396.3,RSP,6,1,2)):CSITE,1:$P(^DVB(396.3,RSP,6,1,2),"^",4))
S RSTA=$P(^DVB(396.3,RSP,0),"^",18)
I CSITE=FSITE S:RSTA=1!(RSTA=2)!(RSTA=12) RTN=1
S 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
;
N CNT,DN,DVP,DV0,FNUM
S 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"
. S CNT=$G(CNT)+1,DVP=$P(^DVB(396.15,I,0),"^")
. Q:DVP=""
. S DV0=$G(^DG(40.8,DVP,0))
. S DN=$P(DV0,"^",1),FNUM=$P(DV0,"^",2)
. S 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
N I
S 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))
. S 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
N C2,C3,EN,CNT
S (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)
. S 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"
.. S EN=$P(^DVB(396.15,DIV,1,C2,3,C3,0),"^")
.. S EN=$$EXTERNAL^DILFD(396.1514,.01,,EN,)
.. S 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
;
N CT,C1,R0,R2
S CT=0
F S CT=$O(^DVB(396.55,CT)) Q:CT="B" D
. S R0=^DVB(396.55,CT,0)
. Q:$P(R0,"^",2)="I"
. S C1=$G(C1)+1
. S 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
;
N RTD,RTF,RTO,RTS,RTSD,RRD,J1,J2,J10,J20,J4
N REJR,RRW1,RRW2,RUSR,RDIV,RTDIV,RFDIV,CST,CRQ
I RIEN="" S RTN="0^Missing 2507 Request IEN" Q
I '$D(^DVB(396.3,RIEN,0)) S RTN="0^Not a valid 2507 Request IEN" Q
I '$D(^DVB(396.3,RIEN,6,0)) S RTN="0^This 2507 Request has not been Rerouted" Q
;
S J1=$O(^DVB(396.3,RIEN,6,99999),-1)
S J2=$O(^DVB(396.3,RIEN,6,J1,1,99999),-1)
I J2="" S 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)
S J4=$G(^DVB(396.3,RIEN,6,J1,2))
S REJR=$G(^DVB(396.3,RIEN,6,J1,1,J2,1))
S RTD=$$EXTERNAL^DILFD(396.34,.01,,$P(J10,"^",1))
S RTO=$$EXTERNAL^DILFD(396.34,.02,,$P(J10,"^",7))
S RTF=$$EXTERNAL^DILFD(396.34,3,,$P(J10,"^",4))
S RTSD=$$EXTERNAL^DILFD(396.341,.01,,$P(J20,"^",1))
S RTS=$$EXTERNAL^DILFD(396.341,1,,$P(J20,"^",2))
S RRR=$$EXTERNAL^DILFD(396.34,4,,$P(J10,"^",5))
S RRD=$P(J10,"^",6)
S RTDIV=$$EXTERNAL^DILFD(396.3,24,,$P(^DVB(396.3,RIEN,1),"^",4))
S RFDIV=$$EXTERNAL^DILFD(396.34,8,,$P(J10,"^",9))
;
S CSITE=+$$SITE^VASITE,CRQ=$P(^DVB(396.3,RIEN,0),"^",18),RRW1=0
I CSITE=$P(J4,"^",1)&(CSITE=$P(J4,"^",3)) S RRW1=1
S RRW2=$S(RRW1:1,CSITE=$P(J4,"^",3):0,1:1)
S CST=$S(RRW2=0:0,CRQ=14:1,CRQ=11:1,1:0)
I (RRW2=1)&(CRQ=16) S CST=0
;
S RTN(1)=RTO_"^"_RTD_"^"_RTS_"^"_RTSD_"^"_RTF_"^"_RRR_"^"_CST_"^"_RFDIV_"^"_RTDIV
S RTN(2)=RRD
S RTN(3)=REJR
;
Q
RPRO(RTN,RIEN,RRST,RRR,RMAS) ; AJF; 7/25/2016; Update Reroute Status
;RPC: DVBA CAPRI REROUTE STATUS
;Input:
; RIEN = 2507 Request IEN
; RRST = Reroute status
; RRR = Reject Reason
; RMAS=Date Reported to MAS
;Output:
; RTN = 0 for Failure
; 1 for Success
;
N OSITE,OIEN,DA,DR,DIE,REJM,NSITE,RRUP,J1,J2,DIV1,DIV2
I RIEN="" S RTN="0^Missing 2507 Request IEN" Q
I '$D(^DVB(396.3,RIEN,0)) S RTN="0^Not a valid 2507 Request IEN" Q
I '$D(^DVB(396.3,RIEN,6,0)) S RTN="0^This 2507 Request has not been rerouted" Q
;
S RRR=$G(RRR)
S RMAS=$G(RMAS)
S J1=$O(^DVB(396.3,RIEN,6,99999),-1)
S J2=$O(^DVB(396.3,RIEN,6,J1,99999),-1)
I J2="" S RTN="0^This 2507 Request has not been rerouted" Q
S RRIEN=J1,RRDT=$$NOW^XLFDT()
S RRUP=$$UPRS(RIEN,RRIEN,RRDT,RRST,RRR)
;
S R0=^DVB(396.3,RIEN,6,J1,0)
S R1=^DVB(396.3,RIEN,6,J1,2)
S CSITE=$P($$SITE^VASITE,"^",3),OSITE=$P(R1,"^",4),OIEN=$P(R0,"^",2),NSITE=$P(R1,"^",2)
S DIV1=$P(R0,"^",9),DIV2=$P($G(^DVB(396.3,RIEN,1)),"^",4)
I CSITE=OSITE,CSITE=NSITE,RRST="R" D
. S DIE="^DVB(396.3,"_RIEN_",6,",DA=J1,DA(1)=RIEN
. S DR="8////"_DIV2
. D ^DIE ;set Reroute fields
. K DIE,DA
; Check to see if this the original site
I CSITE=OSITE D
.S DIE="^DVB(396.3,",DA=RIEN
. I RRST="A" S DR="6////"_RRDT_";17////13" D ^DIE K DIE,DA Q
. I RRST="R" S DR="17////1" D ^DIE S REJM=1 D EXSET(RIEN,"O") S ^DVB(396.3,"AR",RRDT,RIEN)="" K DIE,DA
I CSITE'=OSITE D
.S DIE="^DVB(396.3,",DA=RIEN
. I RRST="A" S DR="17////2" D ^DIE K DIE,DA Q
. I RRST="R" S DR="6////"_RRDT_";17////12" D ^DIE D EXSET(RIEN,"T")
. K DIE,DA
I CSITE=OSITE,CSITE=NSITE D
.S DIE="^DVB(396.3,",DA=RIEN
. I RRST="A" S DR="17////2" D ^DIE K DIE,DA Q
. I RRST="R" S DR="17////1;24////"_DIV1,^DVB(396.3,"AR",RRDT,RIEN)=""
.D ^DIE K DIE,DA
S DIE="^DVB(396.3,",DA=RIEN
S DR="4////"_RMAS
D ^DIE K DIE,DA
;
; Send Reject Message to DVBA C 2507 Reroute Group
D:RRST="R" MSG^DVBAB1C(RIEN)
;
;Send Acceptance Message to DVBA C 2507 ReRoute Group
D:RRST="A" AMSG^DVBAB1C(RIEN)
;
I CSITE=OSITE S RTN="1^Reroute status updated" Q
;
S OIEN=$P(R0,"^",2)
S RTN="1^Reroute status updated^"_OSITE_"^"_OIEN
;
Q
;
;
UPRR(RIEN,RRDT) ;AJF ; 7/30/2016; Update Reroute information
;create Reroute entry for 2507 Request in sub-file 396.33
N DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DO
S DIC="^DVB(396.3,"_RIEN_",6,",DA(1)=RIEN
S DIC(0)="L",DLAYGO=396.3
S X=RRDT ;.01 2507 REQUEST REROUTE DATE
D FILE^DICN K DLAYGO
;
;
Q Y_"^"_RRDT
;
UPRS(RIEN,RRIEN,RRDT,RRST,RRR) ; Update the status
N DIC,X,Y,DA,DO,DTOUT,DUOUT,DLAYGO
S RRR=$G(RRR)
S DIC="^DVB(396.3,"_RIEN_",6,"_RRIEN_",1,"
S DA(1)=RIEN,DA(2)=RRIEN
S DIC(0)="FL",DLAYGO=396.3
S X=RRDT ;.01 2507 REQUEST REROUTE DATE
S DIC("DR")="1////"_RRST_";2////"_RRR
D FILE^DICN
S R2=Y
Q Y
;
EXSET(RIEN,EST) ;Set Exam status
Q:RIEN=""!(EST="")
N DA,DIE,DR,JJ
F JJ=0:0 S 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
. S DA=JJ,DIE="^DVB(396.4,",DR=".04////"_EST
. D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL8 11844 printed Oct 16, 2024@17:50:07 Page 2
DVBCUTL8 ;ALB/GTS-AMIE C&P APPT LINK FILE MNT RTNS 2 ; 9/29/21 11:46pm
+1 ;;2.7;AMIE;**193,227**;Apr 10, 1995;Build 21
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;** NOTICE: This routine is part of an implementation of a Nationally
+5 ;** Controlled Procedure. Local modifications to this routine
+6 ;** are prohibited per VHA Directive 10-93-142
+7 ;
+8 ;** Version Changes
+9 ; 2.7 - New routine (Enhc 13)
+10 QUIT
+11 ;
FIXLK ;** Re-attach unlinked appt to new appt
+1 ;
+2 ;** ^TMP("DVBC",$J,) must have nodes:
+3 ;** ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION,
+4 ;** VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked
+5 ;
+6 NEW REQDT,SAVY
+7 if $DATA(Y)
SET SAVY=Y
+8 ;**Set REQDT
SET REQDT=$$GETDTE^DVBCMKLK(DVBADA)
+9 if $DATA(SAVY)
SET Y=SAVY
+10 SET DIR("A",1)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"."
+11 SET DIR("A",2)=" "
+12 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue."
DO ^DIR
KILL DIR,X,Y
+13 NEW ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE,INITAPPT
+14 SET VETDTE=""
+15 SET ORIGAPPT=^TMP("DVBC",$JOB,"ORIGINAL APPT DATE")
+16 SET CURRAPPT=^TMP("DVBC",$JOB,"CURRENT APPT DATE")
+17 SET VETCANC=^TMP("DVBC",$JOB,"VETERAN CANCELLATION")
+18 if $DATA(^TMP("DVBC",$JOB,"VETERAN REQ APPT DATE"))
SET VETDTE=^TMP("DVBC",$JOB,"VETERAN REQ APPT DATE")
+19 SET APPTSTAT=^TMP("DVBC",$JOB,"APPOINTMENT STATUS")
+20 KILL DA,DIE,DR
+21 ;
+22 ;** Only one current appt date/time for vet can exist in 396.95
+23 SET DA=""
SET DA=DVBAOLDA
+24 ;**APPTNODE 396.95 rec before mods
SET APPTNODE=^DVB(396.95,DA,0)
+25 SET DIE="^DVB(396.95,"
SET DR=""
+26 ;
+27 ;** If 396.95 initial appt lost, set to original appt
+28 IF $PIECE(APPTNODE,U,1)=""
IF ($PIECE(APPTNODE,U,2)'="")
SET INITAPPT=$PIECE(APPTNODE,U,2)
+29 IF $PIECE(APPTNODE,U,1)=""
SET DR=".01////^S X=INITAPPT;"
+30 IF $PIECE(APPTNODE,U,4)'=1
SET DR=DR_".02////^S X=ORIGAPPT;"
+31 SET DR=DR_".03////^S X=CURRAPPT;"
+32 IF $PIECE(APPTNODE,U,4)'=1
SET DR=DR_".04////^S X=VETCANC;"
+33 ;**Update last vet req date
IF VETCANC=1
SET DR=DR_".05////^S X=VETDTE;"
+34 SET DR=DR_".07////^S X=APPTSTAT"
+35 DO ^DIE
KILL DIE,DA,DR
+36 QUIT
+37 ;
ADDLK ;** Add link from 2507 to appt
+1 ;
+2 ;** ^TMP("DVBC",$J,) nodes:
+3 ;** ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION,
+4 ;** VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked
+5 ;
+6 NEW REQDT,SAVY
+7 if $DATA(Y)
SET SAVY=Y
+8 ;**Set REQDT
SET REQDT=$$GETDTE^DVBCMKLK(DVBADA)
+9 if $DATA(SAVY)
SET Y=SAVY
+10 SET DIR("A",1)="Adding new C&P appointment link for 2507 request dated "_REQDT_"."
+11 SET DIR("A",2)=" "
+12 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue."
DO ^DIR
KILL DIR,X,Y
+13 NEW ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE
+14 SET VETDTE=""
+15 SET ORIGAPPT=^TMP("DVBC",$JOB,"ORIGINAL APPT DATE")
+16 SET CURRAPPT=^TMP("DVBC",$JOB,"CURRENT APPT DATE")
+17 SET VETCANC=^TMP("DVBC",$JOB,"VETERAN CANCELLATION")
+18 if $DATA(^TMP("DVBC",$JOB,"VETERAN REQ APPT DATE"))
SET VETDTE=^TMP("DVBC",$JOB,"VETERAN REQ APPT DATE")
+19 SET APPTSTAT=^TMP("DVBC",$JOB,"APPOINTMENT STATUS")
+20 KILL DA,DIC,X,DD,DO
+21 SET X=^TMP("DVBC",$JOB,"INITIAL APPT DATE")
+22 SET DIC="^DVB(396.95,"
SET DIC(0)="L"
SET DIC("DR")=""
+23 SET DIC("DR")=DIC("DR")_".02////^S X=ORIGAPPT;.03////^S X=CURRAPPT;"
+24 SET DIC("DR")=DIC("DR")_".04////^S X=VETCANC;.05////^S X=VETDTE;"
+25 SET DIC("DR")=DIC("DR")_".06////^S X=DVBADA;.07////^S X=APPTSTAT"
+26 DO FILE^DICN
+27 IF +Y'>0
Begin DoDot:1
+28 SET DIR("A",1)="The C&P appointment link was not properly added. Please investigate the"
+29 SET DIR("A",2)="appointment scheduled for "_ORIGAPPT_" for "_$PIECE(^DPT(DVBADFN,0),U,1)
+30 SET DIR("A",3)=" "
+31 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:1
+32 KILL DIC,DA,X,Y
+33 QUIT
+34 ;
STYLE(REQDA) ;** Return indication of 2507 status matching integ report type
+1 NEW STATIND,REQSTAT,STYLEIND,PARAMDA
+2 ;**Leave set to zero if STYLEIND=4
SET STATIND=0
+3 SET REQSTAT=$$RSTAT($PIECE(^DVB(396.3,REQDA,0),U,18))
+4 SET PARAMDA=0
+5 SET PARAMDA=$ORDER(^DVB(396.1,PARAMDA))
+6 SET STYLEIND=$PIECE(^DVB(396.1,PARAMDA,0),U,15)
+7 IF STYLEIND="1"
if "P^S"[REQSTAT
SET STATIND=1
+8 IF STYLEIND="2"
if "R^C"[REQSTAT
SET STATIND=1
+9 IF STYLEIND="3"
SET STATIND=1
+10 QUIT +STATIND
+11 ;
SELLNK(REQDA) ;** Return IEN from 396.95 for link to modify
+1 NEW SELDA
+2 ;**Set up link array
DO LNKARY^DVBCUTA3(REQDA,DVBADFN)
+3 IF '$DATA(TMP("DVBC LINK"))
Begin DoDot:1
+4 SET SELDA=0
SET DVBANOLK=""
+5 DO NOLNK^DVBCLKT2
End DoDot:1
+6 IF $DATA(TMP("DVBC LINK"))
Begin DoDot:1
+7 IF '$DATA(DVBAAPT)
Begin DoDot:2
+8 SET Y=$PIECE(SDATA,U,3)
+9 XECUTE ^DD("DD")
+10 SET DVBAAPT=Y
+11 SET DVBAAPST=""
End DoDot:2
+12 DO LINKDISP^DVBCUTA1
+13 IF $DATA(DVBAAPST)
KILL DVBAAPT,DVBAAPST
End DoDot:1
+14 KILL Y
+15 QUIT +SELDA
+16 ;
+17 ;AJF; Request Status Conversion
RSTAT(RSP) ;**Return Request Status Code from 396.33
+1 ;RSP - IEN for file 396.33
+2 if '$DATA(RSP)
QUIT ""
+3 if '+RSP
QUIT ""
+4 if '$DATA(^DVB(396.33,RSP,0))
QUIT ""
+5 QUIT $PIECE(^DVB(396.33,RSP,0),"^",2)
+6 ;
+7 ;AJF; Request Status Conversion
RTSTAT(RSP) ;**Return Status (External) from 396.33
+1 ;RSP - IEN for file 396.33
+2 if '$DATA(RSP)
QUIT ""
+3 if '+RSP
QUIT ""
+4 if '$DATA(^DVB(396.33,RSP,0))
QUIT ""
+5 QUIT $PIECE(^DVB(396.33,RSP,0),"^",1)
+6 ;
+7 ;AJF ; Reroute function
REROST(RTN,RSP) ;**Returns 1 if this Request is able to be rerouted
+1 ;RPC: DVBA CAPRI GET REROUTE
+2 ;RSP - IEN for file 396.3
+3 ;RTN - Return value 1 for yes 0 for no
+4 if '$DATA(RSP)
QUIT 0
+5 if '+RSP
QUIT 0
+6 if '$DATA(^DVB(396.3,RSP,0))
QUIT 0
+7 NEW CSITE,RSTA,FSITE
+8 SET RTN=0
+9 SET CSITE=$PIECE($$SITE^VASITE,"^",3)
+10 SET FSITE=$SELECT('$DATA(^DVB(396.3,RSP,6,1,2)):CSITE,1:$PIECE(^DVB(396.3,RSP,6,1,2),"^",4))
+11 SET RSTA=$PIECE(^DVB(396.3,RSP,0),"^",18)
+12 IF CSITE=FSITE
if RSTA=1!(RSTA=2)!(RSTA=12)
SET RTN=1
+13 SET RTN=RTN_"^"_CSITE
+14 QUIT
+15 ;
CDIV(RTN,SITE) ;AJF ; Provides list from CAPRI DIVISION EXAM (396.15
+1 ;RPC DVBA CAPRI GET DIVISION
+2 ;RTN - Return list of active divisions "^" Division IEN
+3 ;
+4 NEW CNT,DN,DVP,DV0,FNUM
+5 SET I=0
SET RTN(1)="No active CAPRI Divisions"
+6 FOR
SET I=$ORDER(^DVB(396.15,I))
if I="B"!(I="")
QUIT
Begin DoDot:1
+7 if $PIECE($GET(^DVB(396.15,I,3)),"^")="Y"
QUIT
+8 SET CNT=$GET(CNT)+1
SET DVP=$PIECE(^DVB(396.15,I,0),"^")
+9 if DVP=""
QUIT
+10 SET DV0=$GET(^DG(40.8,DVP,0))
+11 SET DN=$PIECE(DV0,"^",1)
SET FNUM=$PIECE(DV0,"^",2)
+12 SET RTN(CNT)=DN_" "_FNUM_"^"_I
End DoDot:1
+13 QUIT
+14 ;
CDIVC(RTN,DIV) ;AJF; Provides comments for GUI
+1 ; RPC: DVBA CAPRI GET DIV COMMENT
+2 ; RTN - Return comment
+3 ; DIV - Division IEN
+4 NEW I
+5 SET I=0
SET RTN(1)="No Division comment available "
+6 if '$DATA(DIV)
QUIT
+7 if '+DIV
QUIT
+8 FOR
SET I=$ORDER(^DVB(396.15,DIV,2,I))
if I=""
QUIT
Begin DoDot:1
+9 if '$DATA(^DVB(396.15,DIV,2,I,0))
QUIT
+10 SET RTN(I)=^DVB(396.15,DIV,2,I,0)
End DoDot:1
+11 QUIT
CDIVE(RTN,DIV) ;AJF ; Provides list of active exams
+1 ; RPC: DVBA CAPRI GET DIV EXAM
+2 ; RTN - Return exam
+3 ; DIV - Division IEN
+4 NEW C2,C3,EN,CNT
+5 SET (C2,CNT)=0
SET RTN(1)="No exam found"
+6 if '$DATA(DIV)
QUIT
+7 if '+DIV
QUIT
+8 FOR
SET C2=$ORDER(^DVB(396.15,DIV,1,C2))
if C2="B"!(CNT=100)
QUIT
Begin DoDot:1
+9 if "DEFAULT "'[$EXTRACT(^DVB(396.15,DIV,1,C2,0),1,7)
QUIT
+10 SET C3=0
+11 FOR
SET C3=$ORDER(^DVB(396.15,DIV,1,C2,3,C3))
if C3=""!(CNT=100)
QUIT
Begin DoDot:2
+12 if '$DATA(^DVB(396.15,DIV,1,C2,3,C3,0))
QUIT
+13 if $GET(^DVB(396.15,DIV,1,C2,3,C3,2))'="Y"
QUIT
+14 SET EN=$PIECE(^DVB(396.15,DIV,1,C2,3,C3,0),"^")
+15 SET EN=$$EXTERNAL^DILFD(396.1514,.01,,EN,)
+16 SET CNT=CNT+1
SET RTN(CNT)=EN
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
ARC(RTN) ;AJF ;7/15/2016 Returns all active Reroute Code
+1 ; RPC: DVBA CAPRI GET REROUTE CODE
+2 ; RTN - Return exam
+3 ;
+4 NEW CT,C1,R0,R2
+5 SET CT=0
+6 FOR
SET CT=$ORDER(^DVB(396.55,CT))
if CT="B"
QUIT
Begin DoDot:1
+7 SET R0=^DVB(396.55,CT,0)
+8 if $PIECE(R0,"^",2)="I"
QUIT
+9 SET C1=$GET(C1)+1
+10 SET RTN(C1)=CT_"^"_$PIECE(R0,"^")
End DoDot:1
+11 QUIT
+12 ;
RINFO(RTN,RIEN) ;AJF; Returns reroute information for a given 2507 Request
+1 ;RPC: DVBA CAPRI REROUTE INFO
+2 ;Input
+3 ; RIEN: 2507 Request IEN
+4 ;
+5 ;Output
+6 ; REROUTE TO^REROUTE DATE^REROUTE STATUS^STATUS DATE^REROUTED FROM^ REROUTE REASON ^ REJECT REASON
+7 ; ^ 0 for site A/ 1 for site B or C
+8 ;
+9 NEW RTD,RTF,RTO,RTS,RTSD,RRD,J1,J2,J10,J20,J4
+10 NEW REJR,RRW1,RRW2,RUSR,RDIV,RTDIV,RFDIV,CST,CRQ
+11 IF RIEN=""
SET RTN="0^Missing 2507 Request IEN"
QUIT
+12 IF '$DATA(^DVB(396.3,RIEN,0))
SET RTN="0^Not a valid 2507 Request IEN"
QUIT
+13 IF '$DATA(^DVB(396.3,RIEN,6,0))
SET RTN="0^This 2507 Request has not been Rerouted"
QUIT
+14 ;
+15 SET J1=$ORDER(^DVB(396.3,RIEN,6,99999),-1)
+16 SET J2=$ORDER(^DVB(396.3,RIEN,6,J1,1,99999),-1)
+17 IF J2=""
SET RTN="0^This 2507 Request has not been Rerouted"
QUIT
+18 SET J10=^DVB(396.3,RIEN,6,J1,0)
SET J20=^DVB(396.3,RIEN,6,J1,1,J2,0)
+19 SET J4=$GET(^DVB(396.3,RIEN,6,J1,2))
+20 SET REJR=$GET(^DVB(396.3,RIEN,6,J1,1,J2,1))
+21 SET RTD=$$EXTERNAL^DILFD(396.34,.01,,$PIECE(J10,"^",1))
+22 SET RTO=$$EXTERNAL^DILFD(396.34,.02,,$PIECE(J10,"^",7))
+23 SET RTF=$$EXTERNAL^DILFD(396.34,3,,$PIECE(J10,"^",4))
+24 SET RTSD=$$EXTERNAL^DILFD(396.341,.01,,$PIECE(J20,"^",1))
+25 SET RTS=$$EXTERNAL^DILFD(396.341,1,,$PIECE(J20,"^",2))
+26 SET RRR=$$EXTERNAL^DILFD(396.34,4,,$PIECE(J10,"^",5))
+27 SET RRD=$PIECE(J10,"^",6)
+28 SET RTDIV=$$EXTERNAL^DILFD(396.3,24,,$PIECE(^DVB(396.3,RIEN,1),"^",4))
+29 SET RFDIV=$$EXTERNAL^DILFD(396.34,8,,$PIECE(J10,"^",9))
+30 ;
+31 SET CSITE=+$$SITE^VASITE
SET CRQ=$PIECE(^DVB(396.3,RIEN,0),"^",18)
SET RRW1=0
+32 IF CSITE=$PIECE(J4,"^",1)&(CSITE=$PIECE(J4,"^",3))
SET RRW1=1
+33 SET RRW2=$SELECT(RRW1:1,CSITE=$PIECE(J4,"^",3):0,1:1)
+34 SET CST=$SELECT(RRW2=0:0,CRQ=14:1,CRQ=11:1,1:0)
+35 IF (RRW2=1)&(CRQ=16)
SET CST=0
+36 ;
+37 SET RTN(1)=RTO_"^"_RTD_"^"_RTS_"^"_RTSD_"^"_RTF_"^"_RRR_"^"_CST_"^"_RFDIV_"^"_RTDIV
+38 SET RTN(2)=RRD
+39 SET RTN(3)=REJR
+40 ;
+41 QUIT
RPRO(RTN,RIEN,RRST,RRR,RMAS) ; AJF; 7/25/2016; Update Reroute Status
+1 ;RPC: DVBA CAPRI REROUTE STATUS
+2 ;Input:
+3 ; RIEN = 2507 Request IEN
+4 ; RRST = Reroute status
+5 ; RRR = Reject Reason
+6 ; RMAS=Date Reported to MAS
+7 ;Output:
+8 ; RTN = 0 for Failure
+9 ; 1 for Success
+10 ;
+11 NEW OSITE,OIEN,DA,DR,DIE,REJM,NSITE,RRUP,J1,J2,DIV1,DIV2
+12 IF RIEN=""
SET RTN="0^Missing 2507 Request IEN"
QUIT
+13 IF '$DATA(^DVB(396.3,RIEN,0))
SET RTN="0^Not a valid 2507 Request IEN"
QUIT
+14 IF '$DATA(^DVB(396.3,RIEN,6,0))
SET RTN="0^This 2507 Request has not been rerouted"
QUIT
+15 ;
+16 SET RRR=$GET(RRR)
+17 SET RMAS=$GET(RMAS)
+18 SET J1=$ORDER(^DVB(396.3,RIEN,6,99999),-1)
+19 SET J2=$ORDER(^DVB(396.3,RIEN,6,J1,99999),-1)
+20 IF J2=""
SET RTN="0^This 2507 Request has not been rerouted"
QUIT
+21 SET RRIEN=J1
SET RRDT=$$NOW^XLFDT()
+22 SET RRUP=$$UPRS(RIEN,RRIEN,RRDT,RRST,RRR)
+23 ;
+24 SET R0=^DVB(396.3,RIEN,6,J1,0)
+25 SET R1=^DVB(396.3,RIEN,6,J1,2)
+26 SET CSITE=$PIECE($$SITE^VASITE,"^",3)
SET OSITE=$PIECE(R1,"^",4)
SET OIEN=$PIECE(R0,"^",2)
SET NSITE=$PIECE(R1,"^",2)
+27 SET DIV1=$PIECE(R0,"^",9)
SET DIV2=$PIECE($GET(^DVB(396.3,RIEN,1)),"^",4)
+28 IF CSITE=OSITE
IF CSITE=NSITE
IF RRST="R"
Begin DoDot:1
+29 SET DIE="^DVB(396.3,"_RIEN_",6,"
SET DA=J1
SET DA(1)=RIEN
+30 SET DR="8////"_DIV2
+31 ;set Reroute fields
DO ^DIE
+32 KILL DIE,DA
End DoDot:1
+33 ; Check to see if this the original site
+34 IF CSITE=OSITE
Begin DoDot:1
+35 SET DIE="^DVB(396.3,"
SET DA=RIEN
+36 IF RRST="A"
SET DR="6////"_RRDT_";17////13"
DO ^DIE
KILL DIE,DA
QUIT
+37 IF RRST="R"
SET DR="17////1"
DO ^DIE
SET REJM=1
DO EXSET(RIEN,"O")
SET ^DVB(396.3,"AR",RRDT,RIEN)=""
KILL DIE,DA
End DoDot:1
+38 IF CSITE'=OSITE
Begin DoDot:1
+39 SET DIE="^DVB(396.3,"
SET DA=RIEN
+40 IF RRST="A"
SET DR="17////2"
DO ^DIE
KILL DIE,DA
QUIT
+41 IF RRST="R"
SET DR="6////"_RRDT_";17////12"
DO ^DIE
DO EXSET(RIEN,"T")
+42 KILL DIE,DA
End DoDot:1
+43 IF CSITE=OSITE
IF CSITE=NSITE
Begin DoDot:1
+44 SET DIE="^DVB(396.3,"
SET DA=RIEN
+45 IF RRST="A"
SET DR="17////2"
DO ^DIE
KILL DIE,DA
QUIT
+46 IF RRST="R"
SET DR="17////1;24////"_DIV1
SET ^DVB(396.3,"AR",RRDT,RIEN)=""
+47 DO ^DIE
KILL DIE,DA
End DoDot:1
+48 SET DIE="^DVB(396.3,"
SET DA=RIEN
+49 SET DR="4////"_RMAS
+50 DO ^DIE
KILL DIE,DA
+51 ;
+52 ; Send Reject Message to DVBA C 2507 Reroute Group
+53 if RRST="R"
DO MSG^DVBAB1C(RIEN)
+54 ;
+55 ;Send Acceptance Message to DVBA C 2507 ReRoute Group
+56 if RRST="A"
DO AMSG^DVBAB1C(RIEN)
+57 ;
+58 IF CSITE=OSITE
SET RTN="1^Reroute status updated"
QUIT
+59 ;
+60 SET OIEN=$PIECE(R0,"^",2)
+61 SET RTN="1^Reroute status updated^"_OSITE_"^"_OIEN
+62 ;
+63 QUIT
+64 ;
+65 ;
UPRR(RIEN,RRDT) ;AJF ; 7/30/2016; Update Reroute information
+1 ;create Reroute entry for 2507 Request in sub-file 396.33
+2 NEW DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DO
+3 SET DIC="^DVB(396.3,"_RIEN_",6,"
SET DA(1)=RIEN
+4 SET DIC(0)="L"
SET DLAYGO=396.3
+5 ;.01 2507 REQUEST REROUTE DATE
SET X=RRDT
+6 DO FILE^DICN
KILL DLAYGO
+7 ;
+8 ;
+9 QUIT Y_"^"_RRDT
+10 ;
UPRS(RIEN,RRIEN,RRDT,RRST,RRR) ; Update the status
+1 NEW DIC,X,Y,DA,DO,DTOUT,DUOUT,DLAYGO
+2 SET RRR=$GET(RRR)
+3 SET DIC="^DVB(396.3,"_RIEN_",6,"_RRIEN_",1,"
+4 SET DA(1)=RIEN
SET DA(2)=RRIEN
+5 SET DIC(0)="FL"
SET DLAYGO=396.3
+6 ;.01 2507 REQUEST REROUTE DATE
SET X=RRDT
+7 SET DIC("DR")="1////"_RRST_";2////"_RRR
+8 DO FILE^DICN
+9 SET R2=Y
+10 QUIT Y
+11 ;
EXSET(RIEN,EST) ;Set Exam status
+1 if RIEN=""!(EST="")
QUIT
+2 NEW DA,DIE,DR,JJ
+3 FOR JJ=0:0
SET JJ=$ORDER(^DVB(396.4,"C",RIEN,JJ))
if JJ=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^DVB(396.4,JJ,0),U,4)="X"
QUIT
+5 IF $PIECE(^DVB(396.4,JJ,0),U,4)="C"
QUIT
+6 SET DA=JJ
SET DIE="^DVB(396.4,"
SET DR=".04////"_EST
+7 DO ^DIE
End DoDot:1
+8 QUIT
