source: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCXFRC.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1DVBCXFRC ;ALB/GTS-557/THM-PROCESS TRANSFER-IN MAIL MESSAGE ; 10/4/91 9:26 AM
2 ;;2.7;AMIE;**1,6,18,65**;Apr 10, 1995
3 ;
4EN1 N XMB K OUT,CNT S (CNTA,OUT)=0 X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS
5 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
6 ;check for existence of primary division
7 S DVBCDIV=$$PRIM^VASITE I DVBCDIV=""!(DVBCDIV=-1) D BULL8^DVBCXFRD G EXIT
8 ;check for unique regional office station# using variable ronam
9 S RO=$$FIND1^DIC(4,,"X",RONAM,"D",,"DVBCERR") I RO=""!(RO=0) S OUT=1 D BULL11^DVBCXFRD G EXIT
10 ;if primary division and regional office station# ok, then proceed
11 K XLN,CNTA I XMRG["$END" S OUT=0 D PATEDIT G:OUT EXIT D REQEDIT
12 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
13 ;
14EXIT D DELSER^DVBCUTL4 ;deletes the server message
15 K DGMSGF,TYPE,REASONS,DVBADMNM,EXMRS,XMORPV
16 G KILL^DVBCUTIL
17 ;
18DEM0 S PNAM=$E($P(XLN,U,1),1,28),DOB=$P(XLN,U,2),SEX=$P(XLN,U,3),SSN=$P(XLN,U,4)
19 Q
20 ;
21USER S USER=$P(XLN,U,1),SITE=$P(XLN,U,2),SITE1=$P(XLN,U,3)
22 Q
23 ;
24DEM1 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)
25 I STATE?.E1A.E S STATE=$O(^DIC(5,"B",STATE,0)) DO
26 .I CNTY?.E1A.E S CNTY=$O(^DIC(5,+STATE,1,"B",CNTY,0)) Q
27 I 'STATE S STATE=""
28 I 'CNTY S CNTY=""
29 Q
30 ;
31ELIG 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)
32 S TYPE=$P(XLN,U,13),TYPEPTR=""
33 S:TYPE]"" TYPEPTR=$O(^DG(391,"B",TYPE,TYPEPTR))
34 S ELIGCOD=$O(^DIC(8,"D",+ELIGCOD,0))
35 S ELIGCOD=$S(ELIGCOD="":"",$D(^DIC(8,"D",+ELIGCOD)):$O(^DIC(8,"D",+ELIGCOD,0)),1:"")
36 S PDSRV=$S(PDSRV="":"",$D(^DIC(21,"D",PDSRV)):$O(^DIC(21,"D",PDSRV,0)),1:"")
37 Q
38 ;
39REQ0 S OLREQDA=$P(XLN,U,1),RO=$P(XLN,U,2),RONAM=$P(XLN,U,8),PRIO=$P(XLN,U,3),CFLOC=+$P(XLN,U,4),LREXMDT=$P(XLN,U,5),CFREQ=$P(XLN,U,6),LREXMDT=$P(XLN,U,7)
40 S CFLOC=$O(^DIC(4,"D",CFLOC,""))
41 S:'$D(^DIC(4,+CFLOC,0)) CFLOC=""
42 Q
43 ;
44ODIS S OTHDIS=$P(XLN,U,1),OTHDIS1=$P(XLN,U,2),OTHDIS2=$P(XLN,U,3)
45 Q
46 ;
47EXAM S EXAMS=$P(XLN,"^^",1),REASONS=$P(XLN,"^^",2)
48 Q
49 ;
50REMK S:'$D(CNT) CNT=0 S CNT=CNT+1,REMK(CNT)=XLN
51 Q
52 ;
53REQEDIT ; ** Add entry to file #396.3 (request)
54 K DD,DO,DA,DR,DIC,X,Y S DIC="^DVB(396.3,",DLAYGO=396.3,DIC(0)="L",X=DFN
55 S DIC("DR")="1///NOW;2////"_RO_";3////.5;9////"_PRIO_";28///"_SITE1_";30////"_OLREQDA_";33////"_DT
56 D FILE^DICN K DLAYGO
57 S (DA,REQDA)=+Y I DA<0 S OUT=1 D BULL1^DVBCXFRD Q
58 ;Give Med Center Primary Division as routing location (DVBCDIV)
59 S DIE="^DVB(396.3,"
60 S DR="10////"_OTHDIS_";10.1////"_OTHDIS1_";10.2////"_OTHDIS2_";17////NT" D ^DIE
61 S DR="21////"_CFREQ_";23.3////"_LREXMDT_";24////"_DVBCDIV
62 D ^DIE K DIC,DIE,DD,DO
63 S CNT=0 I '$D(^DVB(396.3,REQDA,2,0)) S ^(0)="^^0^0^"_DT_"^^^^"
64 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
65 S X="",DVBADMNM=$P(SITE1,".",1)
66 F I=1:1 S EXM=$P(EXAMS,U,I) Q:EXM="" D SETVARS Q:OUT
67 ;if adding exams failed, then delete request
68 I OUT S DA=REQDA,DIK="^DVB(396.3," D ^DIK K DA,DIK
69 Q
70 ;
71PATEDIT ; ** Add entry and/or update file #2 (patient)
72 N DVBCPT,DVBCARAY,DVBCERR,DVBCIENS,DOB2,NAME1,NAME2,BYEAR,X,Y
73 K DVBCNEW S DVBCPT=$$FIND1^DIC(2,,"X",SSN,"SSN",,"DVBCERR")
74 ;if error returned, send error msg
75 I DVBCPT="" S OUT=1 D BULL9^DVBCXFRD Q
76 ;if found matching ssn, make sure the name and dob also match
77 I +DVBCPT>0 D Q
78 .S DVBCIENS=DVBCPT_"," K DVBCERR
79 .D GETS^DIQ(2,DVBCIENS,".01;.03;.09","I","DVBCARAY","DVBCERR")
80 .;if fm returned an error msg and no data, send error msg
81 .I '$D(DVBCARAY(2,DVBCIENS)) S OUT=1 D BULL10^DVBCXFRD Q
82 .;make sure about that ssn
83 .I SSN'=DVBCARAY(2,DVBCIENS,.09,"I") S OUT=1,DVBCERR(1)="Possible 'SSN' index problem.",DVBCERR(2)=""
84 .;if name and/or dob don't match, send error msg
85 .I (PNAM'=DVBCARAY(2,DVBCIENS,.01,"I"))!(DOB'=DVBCARAY(2,DVBCIENS,.03,"I")) D Q:OUT
86 ..S X=$P(PNAM,",",1),NAME1(1)=$P(X," ",1),X=$P(PNAM,",",2),NAME1(2)=$P(X," ",1)
87 ..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)
88 ..I (NAME1(1)'=NAME2(1))!(NAME1(2)'=NAME2(2)) S OUT=1
89 ..S BYEAR(1)=$E(DOB,1,3),BYEAR(2)=$E(DVBCARAY(2,DVBCIENS,.03,"I"),1,3)
90 ..I BYEAR(1)'=BYEAR(2) S OUT=1
91 ..I OUT D
92 ...S DVBCERR(1)="Patient name and/or DOB at target site does not match transfer request."
93 ...S DOB2=DVBCARAY(2,DVBCIENS,.03,"I") S Y=DOB2 X ^DD("DD") S DOB2=Y
94 ...S DVBCERR(2)="Name: "_DVBCARAY(2,DVBCIENS,.01,"I")_" DOB: "_DOB2
95 ...D BULL10^DVBCXFRD
96 .;otherwise, update address info
97 .S DFN=+DVBCPT K X,Y,DIC
98 .D ADDEDIT
99 ;if no match, then add record
100 I +DVBCPT=0 D Q
101 .K DA,DR,DIC,DO,DD,X,Y S DVBCNEW=1
102 .S DLAYGO=2,DIC="^DPT(",DIC(0)="L",X=PNAM,DIC("DR")=".02////"_SEX_";.03////"_DOB_";.09////"_SSN
103 .D FILE^DICN K DLAYGO S (DFN,DA)=+Y
104 .I DA<0 D BULL3^DVBCXFRD S OUT=1 Q
105 .S DGMSGF=1 ;why is this variable needed?
106 .D ADDEDIT
107 .S DIE="^DPT(",DA=DFN
108 .S DR(1,2,1)=".301////"_SRVCON_";.302////"_SRVPCT_";.314////"_CFLOC_";.313////"_CNUM_";.323////"_PDSRV_";.326////"_SRVEDT_";.327////"_SRVSDT_";.361////"_ELIGCOD
109 .S DR(1,2,2)=".3611////"_ELIGST_";.3612////"_ELIGSDT_";.525////"_POWSTAT_";1901////"_VETST
110 .S:TYPEPTR]"" DR(1,2,3)="391////"_TYPEPTR
111 .D ^DIE
112 Q
113 ;
114SETVARS ; ** Add entry to file #396.4 (exam) **
115 I REASONS'="" DO
116 .S EXMRS=$P(REASONS,U,I) ;**Stuff Insufficient Reason
117 .S XMORPV="Transferred from "_DVBADMNM ;**Stuff Original Provider
118 S DIC="^DVB(396.4,"
119 S DIC(0)="L",DLAYGO=396.4
120 S DIC("DR")=".02////"_REQDA_";.03////"_EXM_";.04////O;63////"_DT
121 S:REASONS'="" DIC("DR")=DIC("DR")_";.11///"_EXMRS_";.12///"_XMORPV
122 S X=$$EXAM^DVBCUTL4 I 'X S OUT=1 D BULL2^DVBCXFRD Q
123 K DD,DO D FILE^DICN
124 I +Y=-1 S OUT=1 D BULL2^DVBCXFRD
125 K DLAYGO,DIC,X,Y
126 Q
127 ;
128ADDEDIT ; ** Edit Patient address (Always!) **
129 S DA=DFN,DIE="^DPT("
130 S:ADR1="" ADR1="@" S:ADR2="" ADR2="@" S:ADR3="" ADR3="@"
131 S:CITY="" CITY="@" S:STATE="" STATE="@" S:ZIP="" ZIP="@"
132 S:CNTY="" CNTY="@" S:HOMPHON="" HOMPHON="@" S:BUSPHON="" BUSPHON="@"
133 S DR=".111////"_ADR1_";.112////"_ADR2_";.113////"_ADR3_";.114////"_CITY_";.115////"_STATE_$S(ZIP4]"":";.1112////"_ZIP4,1:";.116////"_ZIP)_";.117////"_CNTY_";.131////"_HOMPHON_";.132////"_BUSPHON
134 D ^DIE K DIE,DA
135 Q
Note: See TracBrowser for help on using the repository browser.