- 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 Feb 18, 2025@23:20:55 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