DVBCXFRC ;ALB/GTS-557/THM-PROCESS TRANSFER-IN MAIL MESSAGE ; 9/23/21 12:11pm
;;2.7;AMIE;**1,6,18,65,149,193,209,229,227,250**;Apr 10, 1995;Build 19
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN1 ;N XMB,RDAT,RSTS,CM,SP,UP K OUT,CNT
;S (CNTA,OUT,RDAT)=0,SP="",CM=",",UP="^"
;X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS
;F DVBCI=0:0 X XMREC Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) D @SUB
N DVRRIEN,RDAT
N XMB K OUT,CNT S (CNTA,OUT)=0 X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS
F DVBCI=0:0 X XMREC Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) D @SUB
;check for existence of primary division
S DVBCDIV=$$PRIM^VASITE I DVBCDIV=""!(DVBCDIV=-1) D BULL8^DVBCXFRD G EXIT
;check for unique regional office station# using variable ronam
S RO=$$FIND1^DIC(4,,"X",RONAM,"D",,"DVBCERR") I RO=""!(RO=0) S OUT=1 D BULL11^DVBCXFRD G EXIT
;if primary division and regional office station# ok, then proceed
K XLN,CNTA I XMRG["$END" S OUT=0 D PATEDIT G:OUT EXIT D REQEDIT
I $D(DVBCNEW) S XMB="DVBA C NEW C&P VETERAN",XMB(1)=PNAM,XMB(2)=SSN,XMB(3)=$S($D(^VA(200,+DUZ,0)):$P(^(0),U),1:"Unknown user"),Y=DT X ^DD("DD") S XMB(4)=Y D ^XMB
;
EXIT D DELSER^DVBCUTL4 ;deletes the server message
K DGMSGF,TYPE,REASONS,DVBADMNM,EXMRS,XMORPV,DVBSBRCH,DVBDTYPE
K ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTY,CNTY,CNUM,DFN,DOB
K DVBCDIV,DVBCI,ECF,ELIGCOD,ELIGST,ELIGSDT,EXAMS,EXM,HOMPHON,I,II,LREXMDT
K OLREQDA,OREQDA,OTHDIS,OTHDIS1,OTHDIS2,PDSRV,REMK,REASONS,RIEN,RRIF,RRF,DVBNULL,DMAS
K PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV,RRT,RQDT,INUM,RRFIEN,RRFSTN,STN,CTR
K RRFD,RRIEN,RRR,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT
K SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,RRUP,SRVPCT
K SUB,TYPEPTR,USER,XMER,XMRG,XMREC,ZI,PREF,POBC,POBS,CSPT,DVP
K RDAT,DVRRIEN,RD1
G KILL^DVBCUTIL
;
DEM0 S PNAM=$E($P(XLN,U,1),1,28),DOB=$P(XLN,U,2),SEX=$P(XLN,U,3),SSN=$P(XLN,U,4)
;S SSN=$P(XLN,U,4),POBC=$P(XLN,U,5),POBS=$P(XLN,U,6),ICN=$P(XLN,U,7)
;S PREF=$P(XLN,U,8),CSPT=$P(XLN,U,9)
Q
;
USER S USER=$P(XLN,U,1),SITE=$P(XLN,U,2),SITE1=$P(XLN,U,3)
Q
;
DEM1 S ADR1=$P(XLN,U,1),ADR2=$P(XLN,U,2),ADR3=$P(XLN,U,3),CITY=$P(XLN,U,4),STATE=$P(XLN,U,5),CNTY=$P(XLN,U,6),ZIP=$P(XLN,U,7),HOMPHON=$P(XLN,U,8),BUSPHON=$P(XLN,U,9),ZIP4=$P(XLN,U,10)
I STATE?.E1A.E S STATE=$O(^DIC(5,"B",STATE,0)) DO
.I CNTY?.E1A.E S CNTY=$O(^DIC(5,+STATE,1,"B",CNTY,0)) Q
I 'STATE S STATE=""
I 'CNTY S CNTY=""
Q
;
ELIG S SRVCON=$P(XLN,U,1),SRVPCT=$P(XLN,U,2),CFLOC=$P(XLN,U,3),CNUM=$P(XLN,U,4),PDSRV=$P(XLN,U,5),SRVEDT=$P(XLN,U,6),SRVSDT=$P(XLN,U,7),ELIGCOD=$P(XLN,U,8),ELIGST=$P(XLN,U,9),ELIGSDT=$P(XLN,U,10),POWSTAT=$P(XLN,U,11),VETST=$P(XLN,U,12)
S TYPE=$P(XLN,U,13),DVBSBRCH=$P(XLN,U,14),DVBDTYPE=$P(XLN,U,15),TYPEPTR=""
S:TYPE]"" TYPEPTR=$O(^DG(391,"B",TYPE,TYPEPTR))
S ELIGCOD=$O(^DIC(8,"D",+ELIGCOD,0))
S ELIGCOD=$S(ELIGCOD="":"",$D(^DIC(8,"D",+ELIGCOD)):$O(^DIC(8,"D",+ELIGCOD,0)),1:"")
S PDSRV=$S(PDSRV="":"",$D(^DIC(21,"D",PDSRV)):$O(^DIC(21,"D",PDSRV,0)),1:"")
Q
;
; $REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS
;
REQ0 S OLREQDA=$P(XLN,U,1),RO=$P(XLN,U,2),RONAM=$P(XLN,U,8)
S PRIO=$P(XLN,U,3),CFLOC=+$P(XLN,U,4),LREXMDT=$P(XLN,U,5),CFREQ=$P(XLN,U,6)
S LREXMDT=$P(XLN,U,7),RQDT=$P(XLN,U,10),DMAS=$P(XLN,U,11)
S CFLOC=$O(^DIC(4,"D",CFLOC,""))
S:'$D(^DIC(4,+CFLOC,0)) CFLOC=""
Q
;
ODIS S OTHDIS=$P(XLN,U,1),OTHDIS1=$P(XLN,U,2),OTHDIS2=$P(XLN,U,3)
Q
;
EXAM S EXAMS=$P(XLN,"^^",1),REASONS=$P(XLN,"^^",2)
Q
;
REMK S:'$D(CNT) CNT=0 S CNT=CNT+1,REMK(CNT)=XLN
Q
;
; AJF ; 2507 Reroute fields
RDAT S OREQDA=$P(XLN,"^",1),PIEN=$P(XLN,"^",2),RRF=$P(XLN,"^",3)
S RR=$P(XLN,"^",4),RD=$P(XLN,"^",5),RRT=$P(XLN,"^",6)
S RRDT=$P(XLN,"^",7),CLTY=$P(XLN,"^",8),ECF=$P(XLN,"^",9)
S RRFD=$P(XLN,"^",10),RRFIEN=$P(XLN,"^",11),RRFSTN=$P(XLN,"^",12)
S STN=$P(XLN,"^",13),INUM=$P(XLN,"^",14),DVBINF=$P(XLN,"^",15)
S RDAT=1
Q
;
RDES ;PLE ; CAPRI 1214 2507 Reroute description / comment
S RD1=XLN
Q
;
SPEC F II=1:1 S SPEC(II)=$P(XLN,"^",II) Q:SPEC(II)=""
Q
;
REQEDIT ; ** Add entry to file #396.3 (request)
K DD,DO,DA,DR,DIC,X,Y
;I '$D(DFN) S OUT=1 D BULL1^DVBCXFRD Q
;
I '$D(DFN) S DFN=DVRRIEN
S DIC="^DVB(396.3,",DLAYGO=396.3,DIC(0)="L",X=DFN
S DIC("DR")="1///NOW;2////"_RO_";3////.5;9////"_PRIO_";30////"_OLREQDA
D FILE^DICN K DLAYGO
S (DA,REQDA)=+Y I DA<0 S OUT=1 D BULL1^DVBCXFRD Q
;Give Med Center Primary Division as routing location (DVBCDIV)
S DIE="^DVB(396.3,"
S DR="10////"_OTHDIS_";10.1////"_OTHDIS1_";10.2////"_OTHDIS2_";17///NT" D ^DIE
S DR="21////"_CFREQ_";21.1////"_ECF_";23.3////"_LREXMDT_";24////"_DVBCDIV D ^DIE
I RDAT'=1 S DR="28///"_SITE1_";33////"_DT D ^DIE
I RDAT=1 S DR="1////"_RQDT_";51////"_DVBINF_";4////"_DMAS_";17///NR" D ^DIE
K DIC,DIE,DD,DO
S CNT=0 I '$D(^DVB(396.3,REQDA,2,0)) S ^(0)="^^0^0^"_DT_"^^^^"
F ZI=0:0 S ZI=$O(REMK(ZI)) Q:ZI="" S X=REMK(ZI) S CNT=CNT+1,^DVB(396.3,REQDA,2,CNT,0)=X F Y=3,4 S $P(^DVB(396.3,REQDA,2,0),U,Y)=CNT
S X="",DVBADMNM=$P(SITE1,".",1)
;patch 227 adding reroute functionality
I RDAT=1 D
.S RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
.S DA=$P(RRIF,"^")
.S DIE="^DVB(396.3,"_REQDA_",6,",DA(1)=REQDA
.S DR="1////"_OREQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD D ^DIE
.S DR=".02////"_RRT_";8////"_RRFD_";7////"_DUZ D ^DIE
.S DR="9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN
.D ^DIE
.S RRIEN=DA,RRST="N",RRR=""
.D UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR) ; Update the status
.K DIC,DIE,DD,DO,DA
.S FDA(396.32,"+2,"_REQDA_",",.01)=CLTY
.D UPDATE^DIE("","FDA","KEYIEN","ERR")
.I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q
.;this will need changed if rerouting multiples
.S FDA(396.31,"+2,"_REQDA_",",.01)=SPEC(1)
.D UPDATE^DIE("","FDA","KEYIEN","ERR")
.I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q
;PLE ; CAPRI 1214 2507 Reroute description / comment
I $D(RD1) D
.S RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
.S DA=$P(RRIF,"^")-1
.S DIE="^DVB(396.3,"_REQDA_",6,",DA(1)=REQDA
.S DR="5////"_RD1 D ^DIE
F I=1:1 S EXM=$P(EXAMS,U,I) Q:EXM="" D SETVARS Q:OUT
;if adding exams failed, then delete request
I OUT S DA=REQDA,DIK="^DVB(396.3," D ^DIK K DA,DIK
Q
;
PATEDIT ; ** Lookup and/or Add entry to file #2 (patient)
N DVBCPT,DVBCARAY,DVBCERR,DVBCIENS,DOB2,NAME1,NAME2,BYEAR,X,Y
K DVBCNEW S DVBCPT=$$FIND1^DIC(2,,"X",SSN,"SSN",,"DVBCERR")
;if error returned, send error msg
I DVBCPT="" S OUT=1 D BULL9^DVBCXFRD Q
;if found matching ssn, make sure the name and dob also match
I +DVBCPT>0 D Q
.S DVBCIENS=DVBCPT_"," K DVBCERR
.D GETS^DIQ(2,DVBCIENS,".01;.03;.09","I","DVBCARAY","DVBCERR")
.;if fm returned an error msg and no data, send error msg
.I '$D(DVBCARAY(2,DVBCIENS)) S OUT=1 D BULL10^DVBCXFRD Q
.;make sure about that ssn
.I SSN'=DVBCARAY(2,DVBCIENS,.09,"I") S OUT=1,DVBCERR(1)="Possible 'SSN' index problem.",DVBCERR(2)=""
.;if name and/or dob don't match, send error msg
.I (PNAM'=DVBCARAY(2,DVBCIENS,.01,"I"))!(DOB'=DVBCARAY(2,DVBCIENS,.03,"I")) D Q:OUT
..S X=$P(PNAM,",",1),NAME1(1)=$P(X," ",1),X=$P(PNAM,",",2),NAME1(2)=$P(X," ",1)
..S X=$P(DVBCARAY(2,DVBCIENS,.01,"I"),",",1),NAME2(1)=$P(X," ",1),X=$P(DVBCARAY(2,DVBCIENS,.01,"I"),",",2),NAME2(2)=$P(X," ",1)
..I (NAME1(1)'=NAME2(1))!(NAME1(2)'=NAME2(2)) S OUT=1
..S BYEAR(1)=$E(DOB,1,3),BYEAR(2)=$E(DVBCARAY(2,DVBCIENS,.03,"I"),1,3)
..I BYEAR(1)'=BYEAR(2) S OUT=1
..I OUT D
...S DVBCERR(1)="Patient name and/or DOB at target site does not match transfer request."
...S DOB2=DVBCARAY(2,DVBCIENS,.03,"I") S Y=DOB2 X ^DD("DD") S DOB2=Y
...S DVBCERR(2)="Name: "_DVBCARAY(2,DVBCIENS,.01,"I")_" DOB: "_DOB2
...D BULL10^DVBCXFRD
.S (DFN,DVRRIEN)=+DVBCPT K X,Y,DIC
;if no match, then add record
I +DVBCPT=0 D Q
.K DA,DR,DIC,DO,DD,X,Y S DVBCNEW=1
.S DLAYGO=2,DIC="^DPT(",DIC(0)="L",X=PNAM,DIC("DR")=".02////"_SEX_";.03////"_DOB_";.09////"_SSN
.D FILE^DICN K DLAYGO S (DFN,DA,DVRRIEN)=+Y
.I DA<0 D BULL3^DVBCXFRD S OUT=1 Q
.S DGMSGF=1 ;why is this variable needed?
.D ADDEDIT
.S DIE="^DPT(",DA=DFN
.S DR(1,2,1)=".301////"_SRVCON_";.302////"_SRVPCT_";.314////"_CFLOC_";.313////"_CNUM_";.323////"_PDSRV_$S('+$$VFILE^DILFD(2.3216):";.326////"_SRVEDT_";.327////"_SRVSDT,1:"")_";.361////"_ELIGCOD
.S DR(1,2,2)=".3611////"_ELIGST_";.3612////"_ELIGSDT_";.525////"_POWSTAT_";1901////"_VETST
.S:TYPEPTR]"" DR(1,2,3)="391////"_TYPEPTR
.D ^DIE
.;MSE data now to be stored in .3216 subfile in the PATIENT File (2)
.;after Patch DG*5.3*797 has been installed. Editing of the fields
.;.326 and .327 above can be removed once DG*5.3*797 has been released.
.D:((+$$VFILE^DILFD(2.3216))&(SRVEDT]"")) CRTMSE
Q
;
SETVARS ; ** Add entry to file #396.4 (exam) **
I REASONS'="" DO
.S EXMRS=$P(REASONS,U,I) ;**Stuff Insufficient Reason
.S XMORPV="Transferred from "_DVBADMNM ;**Stuff Original Provider
S DIC="^DVB(396.4,"
S DIC(0)="L",DLAYGO=396.4
S DIC("DR")=".02////"_REQDA_";.03////"_EXM_";.04////O;63////"_DT
S:REASONS'="" DIC("DR")=DIC("DR")_";.11///"_EXMRS_";.12///"_XMORPV
S X=$$EXAM^DVBCUTL4 I 'X S OUT=1 D BULL2^DVBCXFRD Q
K DD,DO D FILE^DICN
I +Y=-1 S OUT=1 D BULL2^DVBCXFRD
K DLAYGO,DIC,X,Y
Q
;
ADDEDIT ; ** Add Patient address **
S DA=DFN,DIE="^DPT("
S DR=".111////"_ADR1_";.112////"_ADR2_";.113////"_ADR3_";.114////"_CITY_";.115////"_STATE
S DR=DR_$S(ZIP4]"":";.1112////"_ZIP4,1:";.116////"_ZIP)_";.117////"_CNTY_";.131////"_HOMPHON_";.132////"_BUSPHON
D ^DIE K DIE,DA
Q
;
CRTMSE ;create LAST MSE entry for patient in sub-file 2.3216
N DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO
S DIC="^DPT("_DFN_",.3216,",DA(1)=DFN
S DIC(0)="FL",DLAYGO=2
S X=SRVEDT ;.01 SERVICE ENTRY DATE
;SERVICE SEPARATION DATE ; SERVICE BRANCH ; SERVICE DISCHARGE TYPE
S DIC("DR")=".02////"_SRVSDT_";.03///"_DVBSBRCH_";.06///"_DVBDTYPE
K DO D FILE^DICN K DLAYGO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFRC 10041 printed Dec 13, 2024@01:54:29 Page 2
DVBCXFRC ;ALB/GTS-557/THM-PROCESS TRANSFER-IN MAIL MESSAGE ; 9/23/21 12:11pm
+1 ;;2.7;AMIE;**1,6,18,65,149,193,209,229,227,250**;Apr 10, 1995;Build 19
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN1 ;N XMB,RDAT,RSTS,CM,SP,UP K OUT,CNT
+1 ;S (CNTA,OUT,RDAT)=0,SP="",CM=",",UP="^"
+2 ;X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS
+3 ;F DVBCI=0:0 X XMREC Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) D @SUB
+4 NEW DVRRIEN,RDAT
+5 NEW XMB
KILL OUT,CNT
SET (CNTA,OUT)=0
XECUTE XMREC
IF XMRG["TRANSFER OUT"
GOTO EN1^DVBCXFRS
+6 FOR DVBCI=0:0
XECUTE XMREC
if XMER<0!(XMRG["$END")
QUIT
SET XLN=XMRG
SET SUB=$EXTRACT(XLN,2,5)
SET XLN=$EXTRACT(XLN,7,245)
DO @SUB
+7 ;check for existence of primary division
+8 SET DVBCDIV=$$PRIM^VASITE
IF DVBCDIV=""!(DVBCDIV=-1)
DO BULL8^DVBCXFRD
GOTO EXIT
+9 ;check for unique regional office station# using variable ronam
+10 SET RO=$$FIND1^DIC(4,,"X",RONAM,"D",,"DVBCERR")
IF RO=""!(RO=0)
SET OUT=1
DO BULL11^DVBCXFRD
GOTO EXIT
+11 ;if primary division and regional office station# ok, then proceed
+12 KILL XLN,CNTA
IF XMRG["$END"
SET OUT=0
DO PATEDIT
if OUT
GOTO EXIT
DO REQEDIT
+13 IF $DATA(DVBCNEW)
SET XMB="DVBA C NEW C&P VETERAN"
SET XMB(1)=PNAM
SET XMB(2)=SSN
SET XMB(3)=$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U),1:"Unknown user")
SET Y=DT
XECUTE ^DD("DD")
SET XMB(4)=Y
DO ^XMB
+14 ;
EXIT ;deletes the server message
DO DELSER^DVBCUTL4
+1 KILL DGMSGF,TYPE,REASONS,DVBADMNM,EXMRS,XMORPV,DVBSBRCH,DVBDTYPE
+2 KILL ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTY,CNTY,CNUM,DFN,DOB
+3 KILL DVBCDIV,DVBCI,ECF,ELIGCOD,ELIGST,ELIGSDT,EXAMS,EXM,HOMPHON,I,II,LREXMDT
+4 KILL OLREQDA,OREQDA,OTHDIS,OTHDIS1,OTHDIS2,PDSRV,REMK,REASONS,RIEN,RRIF,RRF,DVBNULL,DMAS
+5 KILL PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV,RRT,RQDT,INUM,RRFIEN,RRFSTN,STN,CTR
+6 KILL RRFD,RRIEN,RRR,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT
+7 KILL SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,RRUP,SRVPCT
+8 KILL SUB,TYPEPTR,USER,XMER,XMRG,XMREC,ZI,PREF,POBC,POBS,CSPT,DVP
+9 KILL RDAT,DVRRIEN,RD1
+10 GOTO KILL^DVBCUTIL
+11 ;
DEM0 SET PNAM=$EXTRACT($PIECE(XLN,U,1),1,28)
SET DOB=$PIECE(XLN,U,2)
SET SEX=$PIECE(XLN,U,3)
SET SSN=$PIECE(XLN,U,4)
+1 ;S SSN=$P(XLN,U,4),POBC=$P(XLN,U,5),POBS=$P(XLN,U,6),ICN=$P(XLN,U,7)
+2 ;S PREF=$P(XLN,U,8),CSPT=$P(XLN,U,9)
+3 QUIT
+4 ;
USER SET USER=$PIECE(XLN,U,1)
SET SITE=$PIECE(XLN,U,2)
SET SITE1=$PIECE(XLN,U,3)
+1 QUIT
+2 ;
DEM1 SET ADR1=$PIECE(XLN,U,1)
SET ADR2=$PIECE(XLN,U,2)
SET ADR3=$PIECE(XLN,U,3)
SET CITY=$PIECE(XLN,U,4)
SET STATE=$PIECE(XLN,U,5)
SET CNTY=$PIECE(XLN,U,6)
SET ZIP=$PIECE(XLN,U,7)
SET HOMPHON=$PIECE(XLN,U,8)
SET BUSPHON=$PIECE(XLN,U,9)
SET ZIP4=$PIECE(XLN,U,10)
+1 IF STATE?.E1A.E
SET STATE=$ORDER(^DIC(5,"B",STATE,0))
Begin DoDot:1
+2 IF CNTY?.E1A.E
SET CNTY=$ORDER(^DIC(5,+STATE,1,"B",CNTY,0))
QUIT
End DoDot:1
+3 IF 'STATE
SET STATE=""
+4 IF 'CNTY
SET CNTY=""
+5 QUIT
+6 ;
ELIG SET SRVCON=$PIECE(XLN,U,1)
SET SRVPCT=$PIECE(XLN,U,2)
SET CFLOC=$PIECE(XLN,U,3)
SET CNUM=$PIECE(XLN,U,4)
SET PDSRV=$PIECE(XLN,U,5)
SET SRVEDT=$PIECE(XLN,U,6)
SET SRVSDT=$PIECE(XLN,U,7)
SET ELIGCOD=$PIECE(XLN,U,8)
SET ELIGST=$PIECE(XLN,U,9)
SET ELIGSDT=$PIECE(XLN,U,10)
SET POWSTAT=$PIECE(XLN,U,11)
SET VETST=$PIECE(XLN,U,12)
+1 SET TYPE=$PIECE(XLN,U,13)
SET DVBSBRCH=$PIECE(XLN,U,14)
SET DVBDTYPE=$PIECE(XLN,U,15)
SET TYPEPTR=""
+2 if TYPE]""
SET TYPEPTR=$ORDER(^DG(391,"B",TYPE,TYPEPTR))
+3 SET ELIGCOD=$ORDER(^DIC(8,"D",+ELIGCOD,0))
+4 SET ELIGCOD=$SELECT(ELIGCOD="":"",$DATA(^DIC(8,"D",+ELIGCOD)):$ORDER(^DIC(8,"D",+ELIGCOD,0)),1:"")
+5 SET PDSRV=$SELECT(PDSRV="":"",$DATA(^DIC(21,"D",PDSRV)):$ORDER(^DIC(21,"D",PDSRV,0)),1:"")
+6 QUIT
+7 ;
+8 ; $REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS
+9 ;
REQ0 SET OLREQDA=$PIECE(XLN,U,1)
SET RO=$PIECE(XLN,U,2)
SET RONAM=$PIECE(XLN,U,8)
+1 SET PRIO=$PIECE(XLN,U,3)
SET CFLOC=+$PIECE(XLN,U,4)
SET LREXMDT=$PIECE(XLN,U,5)
SET CFREQ=$PIECE(XLN,U,6)
+2 SET LREXMDT=$PIECE(XLN,U,7)
SET RQDT=$PIECE(XLN,U,10)
SET DMAS=$PIECE(XLN,U,11)
+3 SET CFLOC=$ORDER(^DIC(4,"D",CFLOC,""))
+4 if '$DATA(^DIC(4,+CFLOC,0))
SET CFLOC=""
+5 QUIT
+6 ;
ODIS SET OTHDIS=$PIECE(XLN,U,1)
SET OTHDIS1=$PIECE(XLN,U,2)
SET OTHDIS2=$PIECE(XLN,U,3)
+1 QUIT
+2 ;
EXAM SET EXAMS=$PIECE(XLN,"^^",1)
SET REASONS=$PIECE(XLN,"^^",2)
+1 QUIT
+2 ;
REMK if '$DATA(CNT)
SET CNT=0
SET CNT=CNT+1
SET REMK(CNT)=XLN
+1 QUIT
+2 ;
+3 ; AJF ; 2507 Reroute fields
RDAT SET OREQDA=$PIECE(XLN,"^",1)
SET PIEN=$PIECE(XLN,"^",2)
SET RRF=$PIECE(XLN,"^",3)
+1 SET RR=$PIECE(XLN,"^",4)
SET RD=$PIECE(XLN,"^",5)
SET RRT=$PIECE(XLN,"^",6)
+2 SET RRDT=$PIECE(XLN,"^",7)
SET CLTY=$PIECE(XLN,"^",8)
SET ECF=$PIECE(XLN,"^",9)
+3 SET RRFD=$PIECE(XLN,"^",10)
SET RRFIEN=$PIECE(XLN,"^",11)
SET RRFSTN=$PIECE(XLN,"^",12)
+4 SET STN=$PIECE(XLN,"^",13)
SET INUM=$PIECE(XLN,"^",14)
SET DVBINF=$PIECE(XLN,"^",15)
+5 SET RDAT=1
+6 QUIT
+7 ;
RDES ;PLE ; CAPRI 1214 2507 Reroute description / comment
+1 SET RD1=XLN
+2 QUIT
+3 ;
SPEC FOR II=1:1
SET SPEC(II)=$PIECE(XLN,"^",II)
if SPEC(II)=""
QUIT
+1 QUIT
+2 ;
REQEDIT ; ** Add entry to file #396.3 (request)
+1 KILL DD,DO,DA,DR,DIC,X,Y
+2 ;I '$D(DFN) S OUT=1 D BULL1^DVBCXFRD Q
+3 ;
+4 IF '$DATA(DFN)
SET DFN=DVRRIEN
+5 SET DIC="^DVB(396.3,"
SET DLAYGO=396.3
SET DIC(0)="L"
SET X=DFN
+6 SET DIC("DR")="1///NOW;2////"_RO_";3////.5;9////"_PRIO_";30////"_OLREQDA
+7 DO FILE^DICN
KILL DLAYGO
+8 SET (DA,REQDA)=+Y
IF DA<0
SET OUT=1
DO BULL1^DVBCXFRD
QUIT
+9 ;Give Med Center Primary Division as routing location (DVBCDIV)
+10 SET DIE="^DVB(396.3,"
+11 SET DR="10////"_OTHDIS_";10.1////"_OTHDIS1_";10.2////"_OTHDIS2_";17///NT"
DO ^DIE
+12 SET DR="21////"_CFREQ_";21.1////"_ECF_";23.3////"_LREXMDT_";24////"_DVBCDIV
DO ^DIE
+13 IF RDAT'=1
SET DR="28///"_SITE1_";33////"_DT
DO ^DIE
+14 IF RDAT=1
SET DR="1////"_RQDT_";51////"_DVBINF_";4////"_DMAS_";17///NR"
DO ^DIE
+15 KILL DIC,DIE,DD,DO
+16 SET CNT=0
IF '$DATA(^DVB(396.3,REQDA,2,0))
SET ^(0)="^^0^0^"_DT_"^^^^"
+17 FOR ZI=0:0
SET ZI=$ORDER(REMK(ZI))
if ZI=""
QUIT
SET X=REMK(ZI)
SET CNT=CNT+1
SET ^DVB(396.3,REQDA,2,CNT,0)=X
FOR Y=3,4
SET $PIECE(^DVB(396.3,REQDA,2,0),U,Y)=CNT
+18 SET X=""
SET DVBADMNM=$PIECE(SITE1,".",1)
+19 ;patch 227 adding reroute functionality
+20 IF RDAT=1
Begin DoDot:1
+21 SET RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
+22 SET DA=$PIECE(RRIF,"^")
+23 SET DIE="^DVB(396.3,"_REQDA_",6,"
SET DA(1)=REQDA
+24 SET DR="1////"_OREQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD
DO ^DIE
+25 SET DR=".02////"_RRT_";8////"_RRFD_";7////"_DUZ
DO ^DIE
+26 SET DR="9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN
+27 DO ^DIE
+28 SET RRIEN=DA
SET RRST="N"
SET RRR=""
+29 ; Update the status
DO UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR)
+30 KILL DIC,DIE,DD,DO,DA
+31 SET FDA(396.32,"+2,"_REQDA_",",.01)=CLTY
+32 DO UPDATE^DIE("","FDA","KEYIEN","ERR")
+33 IF $DATA(ERR)>1
SET RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED"
QUIT
+34 ;this will need changed if rerouting multiples
+35 SET FDA(396.31,"+2,"_REQDA_",",.01)=SPEC(1)
+36 DO UPDATE^DIE("","FDA","KEYIEN","ERR")
+37 IF $DATA(ERR)>1
SET RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED"
QUIT
End DoDot:1
+38 ;PLE ; CAPRI 1214 2507 Reroute description / comment
+39 IF $DATA(RD1)
Begin DoDot:1
+40 SET RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT)
+41 SET DA=$PIECE(RRIF,"^")-1
+42 SET DIE="^DVB(396.3,"_REQDA_",6,"
SET DA(1)=REQDA
+43 SET DR="5////"_RD1
DO ^DIE
End DoDot:1
+44 FOR I=1:1
SET EXM=$PIECE(EXAMS,U,I)
if EXM=""
QUIT
DO SETVARS
if OUT
QUIT
+45 ;if adding exams failed, then delete request
+46 IF OUT
SET DA=REQDA
SET DIK="^DVB(396.3,"
DO ^DIK
KILL DA,DIK
+47 QUIT
+48 ;
PATEDIT ; ** Lookup and/or Add entry to file #2 (patient)
+1 NEW DVBCPT,DVBCARAY,DVBCERR,DVBCIENS,DOB2,NAME1,NAME2,BYEAR,X,Y
+2 KILL DVBCNEW
SET DVBCPT=$$FIND1^DIC(2,,"X",SSN,"SSN",,"DVBCERR")
+3 ;if error returned, send error msg
+4 IF DVBCPT=""
SET OUT=1
DO BULL9^DVBCXFRD
QUIT
+5 ;if found matching ssn, make sure the name and dob also match
+6 IF +DVBCPT>0
Begin DoDot:1
+7 SET DVBCIENS=DVBCPT_","
KILL DVBCERR
+8 DO GETS^DIQ(2,DVBCIENS,".01;.03;.09","I","DVBCARAY","DVBCERR")
+9 ;if fm returned an error msg and no data, send error msg
+10 IF '$DATA(DVBCARAY(2,DVBCIENS))
SET OUT=1
DO BULL10^DVBCXFRD
QUIT
+11 ;make sure about that ssn
+12 IF SSN'=DVBCARAY(2,DVBCIENS,.09,"I")
SET OUT=1
SET DVBCERR(1)="Possible 'SSN' index problem."
SET DVBCERR(2)=""
+13 ;if name and/or dob don't match, send error msg
+14 IF (PNAM'=DVBCARAY(2,DVBCIENS,.01,"I"))!(DOB'=DVBCARAY(2,DVBCIENS,.03,"I"))
Begin DoDot:2
+15 SET X=$PIECE(PNAM,",",1)
SET NAME1(1)=$PIECE(X," ",1)
SET X=$PIECE(PNAM,",",2)
SET NAME1(2)=$PIECE(X," ",1)
+16 SET X=$PIECE(DVBCARAY(2,DVBCIENS,.01,"I"),",",1)
SET NAME2(1)=$PIECE(X," ",1)
SET X=$PIECE(DVBCARAY(2,DVBCIENS,.01,"I"),",",2)
SET NAME2(2)=$PIECE(X," ",1)
+17 IF (NAME1(1)'=NAME2(1))!(NAME1(2)'=NAME2(2))
SET OUT=1
+18 SET BYEAR(1)=$EXTRACT(DOB,1,3)
SET BYEAR(2)=$EXTRACT(DVBCARAY(2,DVBCIENS,.03,"I"),1,3)
+19 IF BYEAR(1)'=BYEAR(2)
SET OUT=1
+20 IF OUT
Begin DoDot:3
+21 SET DVBCERR(1)="Patient name and/or DOB at target site does not match transfer request."
+22 SET DOB2=DVBCARAY(2,DVBCIENS,.03,"I")
SET Y=DOB2
XECUTE ^DD("DD")
SET DOB2=Y
+23 SET DVBCERR(2)="Name: "_DVBCARAY(2,DVBCIENS,.01,"I")_" DOB: "_DOB2
+24 DO BULL10^DVBCXFRD
End DoDot:3
End DoDot:2
if OUT
QUIT
+25 SET (DFN,DVRRIEN)=+DVBCPT
KILL X,Y,DIC
End DoDot:1
QUIT
+26 ;if no match, then add record
+27 IF +DVBCPT=0
Begin DoDot:1
+28 KILL DA,DR,DIC,DO,DD,X,Y
SET DVBCNEW=1
+29 SET DLAYGO=2
SET DIC="^DPT("
SET DIC(0)="L"
SET X=PNAM
SET DIC("DR")=".02////"_SEX_";.03////"_DOB_";.09////"_SSN
+30 DO FILE^DICN
KILL DLAYGO
SET (DFN,DA,DVRRIEN)=+Y
+31 IF DA<0
DO BULL3^DVBCXFRD
SET OUT=1
QUIT
+32 ;why is this variable needed?
SET DGMSGF=1
+33 DO ADDEDIT
+34 SET DIE="^DPT("
SET DA=DFN
+35 SET DR(1,2,1)=".301////"_SRVCON_";.302////"_SRVPCT_";.314////"_CFLOC_";.313////"_CNUM_";.323////"_PDSRV_$SELECT('+$$VFILE^DILFD(2.3216):";.326////"_SRVEDT_";.327////"_SRVSDT,1:"")_";.361////"_ELIGCOD
+36 SET DR(1,2,2)=".3611////"_ELIGST_";.3612////"_ELIGSDT_";.525////"_POWSTAT_";1901////"_VETST
+37 if TYPEPTR]""
SET DR(1,2,3)="391////"_TYPEPTR
+38 DO ^DIE
+39 ;MSE data now to be stored in .3216 subfile in the PATIENT File (2)
+40 ;after Patch DG*5.3*797 has been installed. Editing of the fields
+41 ;.326 and .327 above can be removed once DG*5.3*797 has been released.
+42 if ((+$$VFILE^DILFD(2.3216))&(SRVEDT]""))
DO CRTMSE
End DoDot:1
QUIT
+43 QUIT
+44 ;
SETVARS ; ** Add entry to file #396.4 (exam) **
+1 IF REASONS'=""
Begin DoDot:1
+2 ;**Stuff Insufficient Reason
SET EXMRS=$PIECE(REASONS,U,I)
+3 ;**Stuff Original Provider
SET XMORPV="Transferred from "_DVBADMNM
End DoDot:1
+4 SET DIC="^DVB(396.4,"
+5 SET DIC(0)="L"
SET DLAYGO=396.4
+6 SET DIC("DR")=".02////"_REQDA_";.03////"_EXM_";.04////O;63////"_DT
+7 if REASONS'=""
SET DIC("DR")=DIC("DR")_";.11///"_EXMRS_";.12///"_XMORPV
+8 SET X=$$EXAM^DVBCUTL4
IF 'X
SET OUT=1
DO BULL2^DVBCXFRD
QUIT
+9 KILL DD,DO
DO FILE^DICN
+10 IF +Y=-1
SET OUT=1
DO BULL2^DVBCXFRD
+11 KILL DLAYGO,DIC,X,Y
+12 QUIT
+13 ;
ADDEDIT ; ** Add Patient address **
+1 SET DA=DFN
SET DIE="^DPT("
+2 SET DR=".111////"_ADR1_";.112////"_ADR2_";.113////"_ADR3_";.114////"_CITY_";.115////"_STATE
+3 SET DR=DR_$SELECT(ZIP4]"":";.1112////"_ZIP4,1:";.116////"_ZIP)_";.117////"_CNTY_";.131////"_HOMPHON_";.132////"_BUSPHON
+4 DO ^DIE
KILL DIE,DA
+5 QUIT
+6 ;
CRTMSE ;create LAST MSE entry for patient in sub-file 2.3216
+1 NEW DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO
+2 SET DIC="^DPT("_DFN_",.3216,"
SET DA(1)=DFN
+3 SET DIC(0)="FL"
SET DLAYGO=2
+4 ;.01 SERVICE ENTRY DATE
SET X=SRVEDT
+5 ;SERVICE SEPARATION DATE ; SERVICE BRANCH ; SERVICE DISCHARGE TYPE
+6 SET DIC("DR")=".02////"_SRVSDT_";.03///"_DVBSBRCH_";.06///"_DVBDTYPE
+7 KILL DO
DO FILE^DICN
KILL DLAYGO
+8 QUIT
