- 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 Jan 18, 2025@02:50:30 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