source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGJCREC.m@ 1720

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RGJCREC ;SF/JC,LTL-MPI/PD SUBSCRIPTION PROCESSOR ;05/12/98
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,8,19**;30 Apr 99
3 ;
4 ;Reference to $$UPDATE^MPIFAPI supported by IA #2706
5 ;Reference to $$SEND2^VAFCUTL1 supported by IA #2779
6 ;Reference to ^DPT( supported by IA #2969
7 ;
8REC ;Receive inbound MPI/PD Subscription request
9 ;Read in message for file 774 Master File Update
10 ;
11 Q:($G(HL("MTN"))'="MFN")!($G(HL("ETN"))'="Z15") ;only process MPI/PD MFN/Z15 messages
12 K RGS,RGSEG,RGFS,RGCS,RGEC,RGSS,RGFILE,RGACT,RGCD,RGID,RGICN,RGSSN,RGPN,RGLL,RGTP,RGAD,RGTD,RGRAP,RGCMOR,RGDFN,RGPPFI,RGSCN,RGCURI,RGFROM,RGTO,RGSTUB,RGAD1,RGL,RGRC,HLER
13 N RGLOG,RGMTXT,X D START^RGHLLOG(HLMTIEN,"SCN_REQ","")
14 ;
15 S RGS="",U="^" N J
16 S RGFS=HL("FS") ;Field
17 S RGCS=$E(HL("ECH"),1) ;Component
18 S RGRC=$E(HL("ECH"),2) ;Repetition
19 S RGEC=$E(HL("ECH"),3) ;Escape
20 S RGSS=$E(HL("ECH"),4) ;Sub-component separator
21 F RGI=1:1 X HLNEXT Q:HLQUIT'>0 S (RGSEG,RGS(RGI))=HLNODE D
22 .S J=0 F S J=$O(HLNODE(J)) Q:'J S RGS(RGI,J)=HLNODE(J)
23 .D PARS
24 ;K RGLL ;TS 3-27-98
25 ;D PARS add this to hl7 processing logic above
26 I $D(RGFILE) Q:RGFILE'=774
27 ;Pt DFN
28 S RGDFN=$$GETDFN^MPIF001(+RGICN)
29 I +$$SEND2^VAFCUTL1(RGDFN,"T") D CLEAN Q ;don't process test patients
30 ;Validate DFN/ICN/SSN on receiving system
31 I RGDFN'>0 D D CLEAN Q
32 . S RGMTXT=""
33 . D EXC^RGHLLOG(210,"Msg#"_$G(HL("MID"))_" Bad DFN, "_$G(RGDFN)_", for "_$G(RGPN)_" (ICN#"_$G(RGICN)_")"_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
34 I $P(^DPT(RGDFN,0),U,9)'=RGSSN D D CLEAN Q
35 . S RGMTXT=" See the Exception Handling document on the MPI/PD web site."
36 . D EXC^RGHLLOG(213,"Msg#"_$G(HL("MID"))_" Mismatched SSN,"_$P(^DPT(RGDFN,0),U,9)_"/"_$G(RGSSN)_" for "_$G(RGPN)_" (ICN#"_$G(RGICN)_")"_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
37 ;Pt CMOR/Subscription Control Number
38 S RGPPFI=$$GETVCCI^MPIF001(RGDFN)
39 I +RGPPFI<1 D D CLEAN Q
40 . S RGMTXT=""
41 . D EXC^RGHLLOG(211,"Msg#"_$G(HL("MID"))_" Bad CMOR "_$G(RGPPFI)_" for DFN#"_$G(RGDFN)_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
42 ;Verify that sender and receiver agree on CMOR
43 I RGCMOR'=RGPPFI D D CLEAN Q
44 . S RGMTXT=""
45 . D EXC^RGHLLOG(211,"Msg#"_$G(HL("MID"))_" Mismatched CMOR, "_$G(RGCMOR)_"/"_$G(RGPPFI)_" for "_$G(RGPN)_" (ICN#"_$G(RGICN)_")"_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
46 S RGSCN=$$GETSCN(RGDFN)
47 I RGSCN="" D D CLEAN Q
48 . S RGMTXT=""
49 . D EXC^RGHLLOG(228,"Msg#"_$G(HL("MPI"))_" "_$G(RGPN)_" Does not exist in patient database. "_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
50 ;Current Site ien
51 S RGCURI=+$$SITE^VASITE()
52 ;If not CMOR, don't update anyone else
53 I $$IFVCCI^MPIF001(RGDFN)'=1 D FIL K RGLL Q ;TS 3-27-98
54 ;If filing data at owner site, que update to CLINICAL SUBSCRIBERS
55 D REC1
56 ;Add new clinical subscriber to local registry
57 D FIL
58 D REC2
59CLEAN K RGSTUB,RGLL ;TS 3-27-98
60 D STOP^RGHLLOG(0)
61 K RGS,RGSEG,RGFS,RGCS,RGEC,RGSS,RGFILE,RGACT,RGCD,RGID,RGICN,RGSSN,RGPN,RGLL,RGTP,RGAD,RGTD,RGRAP,RGCMOR,RGDFN,RGPPFI,RGSCN,RGCURI,RGFROM,RGTO,RGSTUB,RGAD1,RGL,RGRC,RGI
62 Q
63REC1 ;Update clinical subscribers with newest one
64 D GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
65 N I S I=0 F S I=$O(RGLL("LINKS",I)) Q:I<1 D
66 .S RGFROM=RGLL ;New Subscriber
67 .I $E(RGFROM,1,2)'="VA" D START^RGHLLOG(HLMTIEN,"SCN_REQ","") D EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request from "_RGFROM_". This is not a MPI/PD site.",RGDFN) D CLEAN Q
68 .S RGTO=$P(RGLL("LINKS",I),U,2) ;Destination (Clinical Subscriber)
69 .I $E(RGTO,1,2)'="VA" D START^RGHLLOG(HLMTIEN,"SCN_REQ","") D EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request to "_RGTO_". This is not a MPI/PD site.",RGDFN) D CLEAN Q
70 .S RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
71 .D:RGFROM'=RGTO EN^RGEQ("SCN_REQ",RGSTUB) ;put on Event Queue
72 Q
73REC2 ;Update newest subscriber with previous subscribers and CMOR
74 ;change 4/10/98 CMC to get links
75 K RGLL("LINKS")
76 D GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
77 S I=0 F S I=$O(RGLL("LINKS",I)) Q:I<1 D
78 .S RGTO=RGLL
79 .I $E(RGTO,1,2)'="VA" D START^RGHLLOG(HLMTIEN,"SCN_REQ","") D EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request to "_RGTO_". This is not a MPI/PD site.",RGDFN) D CLEAN Q
80 .S RGFROM=$P(RGLL("LINKS",I),U,2)
81 .I $E(RGFROM,1,2)'="VA" D START^RGHLLOG(HLMTIEN,"SCN_REQ","") D EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request from "_RGFROM_". This is not a MPI/PD site.",RGDFN) D CLEAN Q
82 .S RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
83 .I RGTO'=RGFROM D EN^RGEQ("SCN_REQ",RGSTUB)
84 ;Now send current institution (CMOR)
85 K RGL
86 D LINK^HLUTIL3(RGCURI,.RGL) S RGL=$O(RGL(0)) Q:RGL<1
87 ;changed cmc 5/9/98
88 S RGSTUB=RGL(RGL)_U_RGLL_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
89 D:RGL(RGL)'=RGLL EN^RGEQ("SCN_REQ",RGSTUB)
90 K RGSTUB
91 Q
92PARS ;Parse it
93 I $E(RGSEG,1,3)="MFI" D
94 .S RGFILE=+$P(RGSEG,RGFS,2) ;File number
95 I $E(RGSEG,1,3)="MFE" D
96 .S RGACT=$P(RGSEG,RGFS,2) ;Action
97 .S RGCD=$P(RGSEG,RGFS,4) ;creation date
98 .S RGID=$P(RGSEG,RGFS,5) D ;Primary Key
99 ..S RGICN=+RGID,RGSSN=$P(RGID,RGSS,2),RGPN=$P(RGID,RGCS,2) ;ICN,Patient Name
100 I $E(RGSEG,1,3)="ZSD" D
101 .S RGLL=$P(RGSEG,RGFS,2) ;Link
102 .S RGTP=$P(RGSEG,RGFS,3) ;Type
103 .S RGAD=$P(RGSEG,RGFS,4) ;Activation Date
104 .S RGTD=$P(RGSEG,RGFS,5) ;Termination Date
105 .S RGRAP=$P(RGSEG,RGFS,6) ;Receiving Application
106 .S RGCMOR=$P(RGSEG,RGFS,7) ;Coordinating Master of Record
107 Q
108GETSCN(RGDPT) ;Return existing SCN or Activate a new subscription for this patient
109 ;RGDPT=PATIENT DFN
110 N RGAR,RGAN
111 ;get subscription control #
112 S RGSCN=+$P($$MPINODE^MPIFAPI(RGDPT),"^",5)
113 ;if no SCN, create new and update 991.05, then return result
114 I 'RGSCN S RGSCN=$$ACT^HLSUB S RGAR(991.05)=RGSCN S RGAN=$$UPDATE^MPIFAPI(RGDPT,"RGAR") I RGAN=-1 S RGSCN=""
115 Q RGSCN
116FIL ;File message
117 ;Normalize dates
118 N RGCHK,RGTD1
119 S RGAD1=$$DTHF^RGHLUT(RGAD)
120 I $G(RGTD)]"" S RGTD1=$$DTHF^RGHLUT(RGTD)
121 ;check to see if this subscriber is yourself
122 D LINK^HLUTIL3(+$$SITE^VASITE,.RGCHK) Q:$O(RGCHK(0))="" S RGCHK=RGCHK($O(RGCHK(0)))
123 I $G(RGCHK)'=RGLL D UPD^HLSUB(RGSCN,RGLL,RGTP,RGAD1,$G(RGTD1),$G(RGRAP),.HLER)
124 Q
125GETINST(LINK) ;returns institution ien from logical link
126 N DIC,X,Y
127 I $G(LINK)="" Q 0
128 S DIC=870,DIC(0)="EMQZ",X=LINK D ^DIC
129 I Y=-1 Q Y
130 Q $P(Y(0),"^",2)
Note: See TracBrowser for help on using the repository browser.