RGJCREC ;SF/JC,LTL-MPI/PD SUBSCRIPTION PROCESSOR ;05/12/98
;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,8,19**;30 Apr 99
;
;Reference to $$UPDATE^MPIFAPI supported by IA #2706
;Reference to $$SEND2^VAFCUTL1 supported by IA #2779
;Reference to ^DPT( supported by IA #2969
;
REC ;Receive inbound MPI/PD Subscription request
;Read in message for file 774 Master File Update
;
Q:($G(HL("MTN"))'="MFN")!($G(HL("ETN"))'="Z15") ;only process MPI/PD MFN/Z15 messages
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
N RGLOG,RGMTXT,X D START^RGHLLOG(HLMTIEN,"SCN_REQ","")
;
S RGS="",U="^" N J
S RGFS=HL("FS") ;Field
S RGCS=$E(HL("ECH"),1) ;Component
S RGRC=$E(HL("ECH"),2) ;Repetition
S RGEC=$E(HL("ECH"),3) ;Escape
S RGSS=$E(HL("ECH"),4) ;Sub-component separator
F RGI=1:1 X HLNEXT Q:HLQUIT'>0 S (RGSEG,RGS(RGI))=HLNODE D
.S J=0 F S J=$O(HLNODE(J)) Q:'J S RGS(RGI,J)=HLNODE(J)
.D PARS
;K RGLL ;TS 3-27-98
;D PARS add this to hl7 processing logic above
I $D(RGFILE) Q:RGFILE'=774
;Pt DFN
S RGDFN=$$GETDFN^MPIF001(+RGICN)
I +$$SEND2^VAFCUTL1(RGDFN,"T") D CLEAN Q ;don't process test patients
;Validate DFN/ICN/SSN on receiving system
I RGDFN'>0 D D CLEAN Q
. S RGMTXT=""
. 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
I $P(^DPT(RGDFN,0),U,9)'=RGSSN D D CLEAN Q
. S RGMTXT=" See the Exception Handling document on the MPI/PD web site."
. 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
;Pt CMOR/Subscription Control Number
S RGPPFI=$$GETVCCI^MPIF001(RGDFN)
I +RGPPFI<1 D D CLEAN Q
. S RGMTXT=""
. D EXC^RGHLLOG(211,"Msg#"_$G(HL("MID"))_" Bad CMOR "_$G(RGPPFI)_" for DFN#"_$G(RGDFN)_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
;Verify that sender and receiver agree on CMOR
I RGCMOR'=RGPPFI D D CLEAN Q
. S RGMTXT=""
. 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
S RGSCN=$$GETSCN(RGDFN)
I RGSCN="" D D CLEAN Q
. S RGMTXT=""
. D EXC^RGHLLOG(228,"Msg#"_$G(HL("MPI"))_" "_$G(RGPN)_" Does not exist in patient database. "_RGMTXT,RGDFN) D STOP^RGHLLOG(1) Q
;Current Site ien
S RGCURI=+$$SITE^VASITE()
;If not CMOR, don't update anyone else
I $$IFVCCI^MPIF001(RGDFN)'=1 D FIL K RGLL Q ;TS 3-27-98
;If filing data at owner site, que update to CLINICAL SUBSCRIBERS
D REC1
;Add new clinical subscriber to local registry
D FIL
D REC2
CLEAN K RGSTUB,RGLL ;TS 3-27-98
D STOP^RGHLLOG(0)
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
Q
REC1 ;Update clinical subscribers with newest one
D GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
N I S I=0 F S I=$O(RGLL("LINKS",I)) Q:I<1 D
.S RGFROM=RGLL ;New Subscriber
.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
.S RGTO=$P(RGLL("LINKS",I),U,2) ;Destination (Clinical Subscriber)
.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
.S RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
.D:RGFROM'=RGTO EN^RGEQ("SCN_REQ",RGSTUB) ;put on Event Queue
Q
REC2 ;Update newest subscriber with previous subscribers and CMOR
;change 4/10/98 CMC to get links
K RGLL("LINKS")
D GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
S I=0 F S I=$O(RGLL("LINKS",I)) Q:I<1 D
.S RGTO=RGLL
.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
.S RGFROM=$P(RGLL("LINKS",I),U,2)
.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
.S RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
.I RGTO'=RGFROM D EN^RGEQ("SCN_REQ",RGSTUB)
;Now send current institution (CMOR)
K RGL
D LINK^HLUTIL3(RGCURI,.RGL) S RGL=$O(RGL(0)) Q:RGL<1
;changed cmc 5/9/98
S RGSTUB=RGL(RGL)_U_RGLL_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$G(RGTD)
D:RGL(RGL)'=RGLL EN^RGEQ("SCN_REQ",RGSTUB)
K RGSTUB
Q
PARS ;Parse it
I $E(RGSEG,1,3)="MFI" D
.S RGFILE=+$P(RGSEG,RGFS,2) ;File number
I $E(RGSEG,1,3)="MFE" D
.S RGACT=$P(RGSEG,RGFS,2) ;Action
.S RGCD=$P(RGSEG,RGFS,4) ;creation date
.S RGID=$P(RGSEG,RGFS,5) D ;Primary Key
..S RGICN=+RGID,RGSSN=$P(RGID,RGSS,2),RGPN=$P(RGID,RGCS,2) ;ICN,Patient Name
I $E(RGSEG,1,3)="ZSD" D
.S RGLL=$P(RGSEG,RGFS,2) ;Link
.S RGTP=$P(RGSEG,RGFS,3) ;Type
.S RGAD=$P(RGSEG,RGFS,4) ;Activation Date
.S RGTD=$P(RGSEG,RGFS,5) ;Termination Date
.S RGRAP=$P(RGSEG,RGFS,6) ;Receiving Application
.S RGCMOR=$P(RGSEG,RGFS,7) ;Coordinating Master of Record
Q
GETSCN(RGDPT) ;Return existing SCN or Activate a new subscription for this patient
;RGDPT=PATIENT DFN
N RGAR,RGAN
;get subscription control #
S RGSCN=+$P($$MPINODE^MPIFAPI(RGDPT),"^",5)
;if no SCN, create new and update 991.05, then return result
I 'RGSCN S RGSCN=$$ACT^HLSUB S RGAR(991.05)=RGSCN S RGAN=$$UPDATE^MPIFAPI(RGDPT,"RGAR") I RGAN=-1 S RGSCN=""
Q RGSCN
FIL ;File message
;Normalize dates
N RGCHK,RGTD1
S RGAD1=$$DTHF^RGHLUT(RGAD)
I $G(RGTD)]"" S RGTD1=$$DTHF^RGHLUT(RGTD)
;check to see if this subscriber is yourself
D LINK^HLUTIL3(+$$SITE^VASITE,.RGCHK) Q:$O(RGCHK(0))="" S RGCHK=RGCHK($O(RGCHK(0)))
I $G(RGCHK)'=RGLL D UPD^HLSUB(RGSCN,RGLL,RGTP,RGAD1,$G(RGTD1),$G(RGRAP),.HLER)
Q
GETINST(LINK) ;returns institution ien from logical link
N DIC,X,Y
I $G(LINK)="" Q 0
S DIC=870,DIC(0)="EMQZ",X=LINK D ^DIC
I Y=-1 Q Y
Q $P(Y(0),"^",2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGJCREC 6294 printed Apr 09, 2024@20:46:33 Page 2
RGJCREC ;SF/JC,LTL-MPI/PD SUBSCRIPTION PROCESSOR ;05/12/98
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,8,19**;30 Apr 99
+2 ;
+3 ;Reference to $$UPDATE^MPIFAPI supported by IA #2706
+4 ;Reference to $$SEND2^VAFCUTL1 supported by IA #2779
+5 ;Reference to ^DPT( supported by IA #2969
+6 ;
REC ;Receive inbound MPI/PD Subscription request
+1 ;Read in message for file 774 Master File Update
+2 ;
+3 ;only process MPI/PD MFN/Z15 messages
if ($GET(HL("MTN"))'="MFN")!($GET(HL("ETN"))'="Z15")
QUIT
+4 KILL 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
+5 NEW RGLOG,RGMTXT,X
DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
+6 ;
+7 SET RGS=""
SET U="^"
NEW J
+8 ;Field
SET RGFS=HL("FS")
+9 ;Component
SET RGCS=$EXTRACT(HL("ECH"),1)
+10 ;Repetition
SET RGRC=$EXTRACT(HL("ECH"),2)
+11 ;Escape
SET RGEC=$EXTRACT(HL("ECH"),3)
+12 ;Sub-component separator
SET RGSS=$EXTRACT(HL("ECH"),4)
+13 FOR RGI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET (RGSEG,RGS(RGI))=HLNODE
Begin DoDot:1
+14 SET J=0
FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET RGS(RGI,J)=HLNODE(J)
+15 DO PARS
End DoDot:1
+16 ;K RGLL ;TS 3-27-98
+17 ;D PARS add this to hl7 processing logic above
+18 IF $DATA(RGFILE)
if RGFILE'=774
QUIT
+19 ;Pt DFN
+20 SET RGDFN=$$GETDFN^MPIF001(+RGICN)
+21 ;don't process test patients
IF +$$SEND2^VAFCUTL1(RGDFN,"T")
DO CLEAN
QUIT
+22 ;Validate DFN/ICN/SSN on receiving system
+23 IF RGDFN'>0
Begin DoDot:1
+24 SET RGMTXT=""
+25 DO EXC^RGHLLOG(210,"Msg#"_$GET(HL("MID"))_" Bad DFN, "_$GET(RGDFN)_", for "_$GET(RGPN)_" (ICN#"_$GET(RGICN)_")"_RGMTXT,RGDFN)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
DO CLEAN
QUIT
+26 IF $PIECE(^DPT(RGDFN,0),U,9)'=RGSSN
Begin DoDot:1
+27 SET RGMTXT=" See the Exception Handling document on the MPI/PD web site."
+28 DO EXC^RGHLLOG(213,"Msg#"_$GET(HL("MID"))_" Mismatched SSN,"_$PIECE(^DPT(RGDFN,0),U,9)_"/"_$GET(RGSSN)_" for "_$GET(RGPN)_" (ICN#"_$GET(RGICN)_")"_RGMTXT,RGDFN)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
DO CLEAN
QUIT
+29 ;Pt CMOR/Subscription Control Number
+30 SET RGPPFI=$$GETVCCI^MPIF001(RGDFN)
+31 IF +RGPPFI<1
Begin DoDot:1
+32 SET RGMTXT=""
+33 DO EXC^RGHLLOG(211,"Msg#"_$GET(HL("MID"))_" Bad CMOR "_$GET(RGPPFI)_" for DFN#"_$GET(RGDFN)_RGMTXT,RGDFN)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
DO CLEAN
QUIT
+34 ;Verify that sender and receiver agree on CMOR
+35 IF RGCMOR'=RGPPFI
Begin DoDot:1
+36 SET RGMTXT=""
+37 DO EXC^RGHLLOG(211,"Msg#"_$GET(HL("MID"))_" Mismatched CMOR, "_$GET(RGCMOR)_"/"_$GET(RGPPFI)_" for "_$GET(RGPN)_" (ICN#"_$GET(RGICN)_")"_RGMTXT,RGDFN)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
DO CLEAN
QUIT
+38 SET RGSCN=$$GETSCN(RGDFN)
+39 IF RGSCN=""
Begin DoDot:1
+40 SET RGMTXT=""
+41 DO EXC^RGHLLOG(228,"Msg#"_$GET(HL("MPI"))_" "_$GET(RGPN)_" Does not exist in patient database. "_RGMTXT,RGDFN)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
DO CLEAN
QUIT
+42 ;Current Site ien
+43 SET RGCURI=+$$SITE^VASITE()
+44 ;If not CMOR, don't update anyone else
+45 ;TS 3-27-98
IF $$IFVCCI^MPIF001(RGDFN)'=1
DO FIL
KILL RGLL
QUIT
+46 ;If filing data at owner site, que update to CLINICAL SUBSCRIBERS
+47 DO REC1
+48 ;Add new clinical subscriber to local registry
+49 DO FIL
+50 DO REC2
CLEAN ;TS 3-27-98
KILL RGSTUB,RGLL
+1 DO STOP^RGHLLOG(0)
+2 KILL 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
+3 QUIT
REC1 ;Update clinical subscribers with newest one
+1 DO GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
+2 NEW I
SET I=0
FOR
SET I=$ORDER(RGLL("LINKS",I))
if I<1
QUIT
Begin DoDot:1
+3 ;New Subscriber
SET RGFROM=RGLL
+4 IF $EXTRACT(RGFROM,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request from "_RGFROM_". This is not a MPI/PD site.",RGDFN)
DO CLEAN
QUIT
+5 ;Destination (Clinical Subscriber)
SET RGTO=$PIECE(RGLL("LINKS",I),U,2)
+6 IF $EXTRACT(RGTO,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request to "_RGTO_". This is not a MPI/PD site.",RGDFN)
DO CLEAN
QUIT
+7 SET RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$GET(RGTD)
+8 ;put on Event Queue
if RGFROM'=RGTO
DO EN^RGEQ("SCN_REQ",RGSTUB)
End DoDot:1
+9 QUIT
REC2 ;Update newest subscriber with previous subscribers and CMOR
+1 ;change 4/10/98 CMC to get links
+2 KILL RGLL("LINKS")
+3 DO GET^RGRSDYN1(RGDFN,RGSCN,0,"",.RGLL)
+4 SET I=0
FOR
SET I=$ORDER(RGLL("LINKS",I))
if I<1
QUIT
Begin DoDot:1
+5 SET RGTO=RGLL
+6 IF $EXTRACT(RGTO,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request to "_RGTO_". This is not a MPI/PD site.",RGDFN)
DO CLEAN
QUIT
+7 SET RGFROM=$PIECE(RGLL("LINKS",I),U,2)
+8 IF $EXTRACT(RGFROM,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request from "_RGFROM_". This is not a MPI/PD site.",RGDFN)
DO CLEAN
QUIT
+9 SET RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$GET(RGTD)
+10 IF RGTO'=RGFROM
DO EN^RGEQ("SCN_REQ",RGSTUB)
End DoDot:1
+11 ;Now send current institution (CMOR)
+12 KILL RGL
+13 DO LINK^HLUTIL3(RGCURI,.RGL)
SET RGL=$ORDER(RGL(0))
if RGL<1
QUIT
+14 ;changed cmc 5/9/98
+15 SET RGSTUB=RGL(RGL)_U_RGLL_U_RGICN_U_RGPN_U_RGTP_U_RGAD_U_$GET(RGTD)
+16 if RGL(RGL)'=RGLL
DO EN^RGEQ("SCN_REQ",RGSTUB)
+17 KILL RGSTUB
+18 QUIT
PARS ;Parse it
+1 IF $EXTRACT(RGSEG,1,3)="MFI"
Begin DoDot:1
+2 ;File number
SET RGFILE=+$PIECE(RGSEG,RGFS,2)
End DoDot:1
+3 IF $EXTRACT(RGSEG,1,3)="MFE"
Begin DoDot:1
+4 ;Action
SET RGACT=$PIECE(RGSEG,RGFS,2)
+5 ;creation date
SET RGCD=$PIECE(RGSEG,RGFS,4)
+6 ;Primary Key
SET RGID=$PIECE(RGSEG,RGFS,5)
Begin DoDot:2
+7 ;ICN,Patient Name
SET RGICN=+RGID
SET RGSSN=$PIECE(RGID,RGSS,2)
SET RGPN=$PIECE(RGID,RGCS,2)
End DoDot:2
End DoDot:1
+8 IF $EXTRACT(RGSEG,1,3)="ZSD"
Begin DoDot:1
+9 ;Link
SET RGLL=$PIECE(RGSEG,RGFS,2)
+10 ;Type
SET RGTP=$PIECE(RGSEG,RGFS,3)
+11 ;Activation Date
SET RGAD=$PIECE(RGSEG,RGFS,4)
+12 ;Termination Date
SET RGTD=$PIECE(RGSEG,RGFS,5)
+13 ;Receiving Application
SET RGRAP=$PIECE(RGSEG,RGFS,6)
+14 ;Coordinating Master of Record
SET RGCMOR=$PIECE(RGSEG,RGFS,7)
End DoDot:1
+15 QUIT
GETSCN(RGDPT) ;Return existing SCN or Activate a new subscription for this patient
+1 ;RGDPT=PATIENT DFN
+2 NEW RGAR,RGAN
+3 ;get subscription control #
+4 SET RGSCN=+$PIECE($$MPINODE^MPIFAPI(RGDPT),"^",5)
+5 ;if no SCN, create new and update 991.05, then return result
+6 IF 'RGSCN
SET RGSCN=$$ACT^HLSUB
SET RGAR(991.05)=RGSCN
SET RGAN=$$UPDATE^MPIFAPI(RGDPT,"RGAR")
IF RGAN=-1
SET RGSCN=""
+7 QUIT RGSCN
FIL ;File message
+1 ;Normalize dates
+2 NEW RGCHK,RGTD1
+3 SET RGAD1=$$DTHF^RGHLUT(RGAD)
+4 IF $GET(RGTD)]""
SET RGTD1=$$DTHF^RGHLUT(RGTD)
+5 ;check to see if this subscriber is yourself
+6 DO LINK^HLUTIL3(+$$SITE^VASITE,.RGCHK)
if $ORDER(RGCHK(0))=""
QUIT
SET RGCHK=RGCHK($ORDER(RGCHK(0)))
+7 IF $GET(RGCHK)'=RGLL
DO UPD^HLSUB(RGSCN,RGLL,RGTP,RGAD1,$GET(RGTD1),$GET(RGRAP),.HLER)
+8 QUIT
GETINST(LINK) ;returns institution ien from logical link
+1 NEW DIC,X,Y
+2 IF $GET(LINK)=""
QUIT 0
+3 SET DIC=870
SET DIC(0)="EMQZ"
SET X=LINK
DO ^DIC
+4 IF Y=-1
QUIT Y
+5 QUIT $PIECE(Y(0),"^",2)
