Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCUTL8

DVBCUTL8.m

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