RGJCSUB ;SF/JC-MPI/PD SUBSCRIPTION GENERATOR ;04/30/97
;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,19,27**;30 Apr 99
EQ(RGEV,RGSTUB,RGERR,RGEP) ;Entry point for Event Queue Processor
S FLL=$P(RGSTUB,U),TLL=$P(RGSTUB,U,2),ICN=$P(RGSTUB,U,3)
S PN=$P(RGSTUB,U,4),TP=$P(RGSTUB,U,5),AD=$P(RGSTUB,U,6)
S TD=$P(RGSTUB,U,7)
I FLL=""!(TLL="")!(ICN="")!(PN="")!(TP="") S RGERR="REQUIRED PARAMETERS MISSING IN STUB"
I AD="" S AD=$$NOW^XLFDT,AD=$$DTFH^RGHLUT(AD,1) ;activation date
D BM(FLL,TLL,ICN,PN,TP,AD,TD)
Q
BM(FLL,TLL,ICN,PN,TP,AD,TD) ;Build Subscription Request Message
;FLL-'FROM' LOGICAL LINK NAME
;TLL-'TO' LOGICAL LINK NAME
;ICN-PATIENT ID
;PN-PATIENT NAME
;TP-SUBSCRIPTION TYPE
;AD-ACTIVATION DATE HL7 FORMAT
;TD-TERMINATION DATE HL7 FORMAT-OPTIONAL
N RGCMOR,RGDFN,RGSSN
Q:'+ICN
S RGDFN=$$GETDFN^MPIF001(+ICN) Q:+RGDFN<1
S RGSSN=$P(^DPT(RGDFN,0),U,9)
;Get institution number of CMOR
S RGCMOR=$$GETVCCI^MPIF001(RGDFN)
N RGCS,RGRC,RGEC,RGSS,HL
D INIT^HLFNC2("RG PT SUBSCRIPTION REQUEST",.HL) Q:+$G(HL)
S HLL("LINKS",1)="RG PT SUBSCRIPTION RECEIVER^"_TLL
S RGCS=$E(HL("ECH"),1) ;Component
S RGRC=$E(HL("ECH"),2) ;Repitition
S RGEC=$E(HL("ECH"),3) ;Escape
S RGSS=$E(HL("ECH"),4) ;Sub-component separator
MFI ;MFI-master file identifier segment
N X,HLA S X=""
S $P(X,HL("FS"))="MFI"
S $P(X,HL("FS"),2)="774"_RGCS_"SUBSCRIPTION REGISTRY"_RGCS_"L"
S $P(X,HL("FS"),4)="UPD"
S $P(X,HL("FS"),7)="NE"
S HLA("HLS",1)=X
MFE ;MFE-master file entry segment
S X=""
S $P(X,HL("FS"))="MFE"
S $P(X,HL("FS"),2)="MUP",$P(X,HL("FS"),4)=AD
S $P(X,HL("FS"),5)=+ICN_RGSS_RGSSN_RGSS_2_RGCS_PN_RGCS_"L"
S HLA("HLS",2)=X
DATA ;Record level data in 'ZSD' SEGMENT
S HLA("HLS",3)="ZSD"_HL("FS")_FLL_HL("FS")_TP_HL("FS")_AD_HL("FS")_$G(TD)_HL("FS")_HL("FS")_RGCMOR
SEND ;SEND TO HL7 PACKAGE
N HLRST
D GENERATE^HLMA("RG PT SUBSCRIPTION REQUEST","LM",1,.HLRST,"",.HL)
Q
ROUTE ;routing logic-parse A04 and put new message on event queue
;to primary facility
;If triggered by an A04
;I $G(HL("ETN"))'="A04" Q
;WITH NEW MESSAGING SUBSCRIPTIONS ARE NO LONGER USED
Q
K RGLL D R1
K RGVCCI,RGVCCIN,RGVCCIS
Q
R1 ;A04
N RGI,RGFS,RGLOC,RGLOCIEN,RGLOCNM,RGLOCSN,RGPN,RGSN,RGS,RGSCN,RGTP,RGTO
S RGS="",RGFS=HL("FS")
F RGI=1:1 X HLNEXT Q:HLQUIT'>0 Q:$P(HLNODE,HL("FS"))="PID"
Q:HLQUIT'>0
S RGICN=+$P(HLNODE,HL("FS"),3)
Q:'RGICN
S RGDFN=+$$GETDFN^MPIF001(RGICN)
Q:RGDFN'>0
S RGVCCI=$$GETVCCI^MPIF001(RGDFN)
Q:RGVCCI<1
;fix TS need IEN for compare not sta. num.
S RGVCCI=$$LKUP^XUAF4(RGVCCI)
I RGVCCI="" D START^RGHLLOG(HLMTIEN),EXC^RGHLLOG(229,"MSG#"_$G(HLMID)_" Unable to send Subscription. Duplicate station number of "_$$GETVCCI^MPIF001(RGDFN)_" in Institution file.",RGDFN) D STOP^RGHLLOG() Q
S RGPN=$P(^DPT(RGDFN,0),U) Q:RGPN=""
S RGTP=1 ;clinical update
S RGAD=$$NOW^XLFDT,RGAD=$$DTFH^RGHLUT(RGAD,1) ;activation date
;Local Station information
S RGLOC=$$SITE^VASITE(),RGLOCIEN=$P(RGLOC,U,1),RGLOCNM=$P(RGLOC,U,2),RGLOCSN=$P(RGLOC,U,3)
I RGVCCI=RGLOCIEN D ;current site is owner site, update existing subscribers
.S RGSCN=$$GETSCN^RGJCREC(RGDFN) ;get SCN
.D LINK^HLUTIL3(RGLOCIEN,.RGFROM) ;get local link definition
.S RGLL=$O(RGFROM(0)) Q:RGLL="" S RGLL=RGFROM(RGLL)
.D REC1^RGJCREC
I RGVCCI'=RGLOCIEN D ;current site is not owner, update only owner
.D LINK^HLUTIL3(RGLOCIEN,.RGFROM) ;Local Link
.S RGFROM=$O(RGFROM(0)) Q:RGFROM="" S RGFROM=RGFROM(RGFROM) ;sending facility
.I $E(RGFROM,1,2)'="VA" D START^RGHLLOG(HLMTIEN),EXC^RGHLLOG(224,"MSG#"_$G(HLMID)_" Unable to send Subscription from "_RGFROM_". This is not a MPI/PD Site.",RGDFN) D STOP^RGHLLOG() Q
.D LINK^HLUTIL3(RGVCCI,.RGTO) ;get VCCI Link
.S RGTO=$O(RGTO(0)) Q:RGTO=""
.S RGTO=RGTO(RGTO) ;receiving facility
.I $E(RGTO,1,2)'="VA" D START^RGHLLOG(HLMTIEN),EXC^RGHLLOG(224,"MSG#"_$G(HLMID)_" Unable to send Subscription to "_RGTO_". This is not a MPI/PD Site.",RGDFN) D STOP^RGHLLOG() Q
.Q:RGTO=RGFROM
.S RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD
.D EN^RGEQ("SCN_REQ",RGSTUB)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGJCSUB 4088 printed Sep 02, 2024@18:27:25 Page 2
RGJCSUB ;SF/JC-MPI/PD SUBSCRIPTION GENERATOR ;04/30/97
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,19,27**;30 Apr 99
EQ(RGEV,RGSTUB,RGERR,RGEP) ;Entry point for Event Queue Processor
+1 SET FLL=$PIECE(RGSTUB,U)
SET TLL=$PIECE(RGSTUB,U,2)
SET ICN=$PIECE(RGSTUB,U,3)
+2 SET PN=$PIECE(RGSTUB,U,4)
SET TP=$PIECE(RGSTUB,U,5)
SET AD=$PIECE(RGSTUB,U,6)
+3 SET TD=$PIECE(RGSTUB,U,7)
+4 IF FLL=""!(TLL="")!(ICN="")!(PN="")!(TP="")
SET RGERR="REQUIRED PARAMETERS MISSING IN STUB"
+5 ;activation date
IF AD=""
SET AD=$$NOW^XLFDT
SET AD=$$DTFH^RGHLUT(AD,1)
+6 DO BM(FLL,TLL,ICN,PN,TP,AD,TD)
+7 QUIT
BM(FLL,TLL,ICN,PN,TP,AD,TD) ;Build Subscription Request Message
+1 ;FLL-'FROM' LOGICAL LINK NAME
+2 ;TLL-'TO' LOGICAL LINK NAME
+3 ;ICN-PATIENT ID
+4 ;PN-PATIENT NAME
+5 ;TP-SUBSCRIPTION TYPE
+6 ;AD-ACTIVATION DATE HL7 FORMAT
+7 ;TD-TERMINATION DATE HL7 FORMAT-OPTIONAL
+8 NEW RGCMOR,RGDFN,RGSSN
+9 if '+ICN
QUIT
+10 SET RGDFN=$$GETDFN^MPIF001(+ICN)
if +RGDFN<1
QUIT
+11 SET RGSSN=$PIECE(^DPT(RGDFN,0),U,9)
+12 ;Get institution number of CMOR
+13 SET RGCMOR=$$GETVCCI^MPIF001(RGDFN)
+14 NEW RGCS,RGRC,RGEC,RGSS,HL
+15 DO INIT^HLFNC2("RG PT SUBSCRIPTION REQUEST",.HL)
if +$GET(HL)
QUIT
+16 SET HLL("LINKS",1)="RG PT SUBSCRIPTION RECEIVER^"_TLL
+17 ;Component
SET RGCS=$EXTRACT(HL("ECH"),1)
+18 ;Repitition
SET RGRC=$EXTRACT(HL("ECH"),2)
+19 ;Escape
SET RGEC=$EXTRACT(HL("ECH"),3)
+20 ;Sub-component separator
SET RGSS=$EXTRACT(HL("ECH"),4)
MFI ;MFI-master file identifier segment
+1 NEW X,HLA
SET X=""
+2 SET $PIECE(X,HL("FS"))="MFI"
+3 SET $PIECE(X,HL("FS"),2)="774"_RGCS_"SUBSCRIPTION REGISTRY"_RGCS_"L"
+4 SET $PIECE(X,HL("FS"),4)="UPD"
+5 SET $PIECE(X,HL("FS"),7)="NE"
+6 SET HLA("HLS",1)=X
MFE ;MFE-master file entry segment
+1 SET X=""
+2 SET $PIECE(X,HL("FS"))="MFE"
+3 SET $PIECE(X,HL("FS"),2)="MUP"
SET $PIECE(X,HL("FS"),4)=AD
+4 SET $PIECE(X,HL("FS"),5)=+ICN_RGSS_RGSSN_RGSS_2_RGCS_PN_RGCS_"L"
+5 SET HLA("HLS",2)=X
DATA ;Record level data in 'ZSD' SEGMENT
+1 SET HLA("HLS",3)="ZSD"_HL("FS")_FLL_HL("FS")_TP_HL("FS")_AD_HL("FS")_$GET(TD)_HL("FS")_HL("FS")_RGCMOR
SEND ;SEND TO HL7 PACKAGE
+1 NEW HLRST
+2 DO GENERATE^HLMA("RG PT SUBSCRIPTION REQUEST","LM",1,.HLRST,"",.HL)
+3 QUIT
ROUTE ;routing logic-parse A04 and put new message on event queue
+1 ;to primary facility
+2 ;If triggered by an A04
+3 ;I $G(HL("ETN"))'="A04" Q
+4 ;WITH NEW MESSAGING SUBSCRIPTIONS ARE NO LONGER USED
+5 QUIT
+6 KILL RGLL
DO R1
+7 KILL RGVCCI,RGVCCIN,RGVCCIS
+8 QUIT
R1 ;A04
+1 NEW RGI,RGFS,RGLOC,RGLOCIEN,RGLOCNM,RGLOCSN,RGPN,RGSN,RGS,RGSCN,RGTP,RGTO
+2 SET RGS=""
SET RGFS=HL("FS")
+3 FOR RGI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
if $PIECE(HLNODE,HL("FS"))="PID"
QUIT
+4 if HLQUIT'>0
QUIT
+5 SET RGICN=+$PIECE(HLNODE,HL("FS"),3)
+6 if 'RGICN
QUIT
+7 SET RGDFN=+$$GETDFN^MPIF001(RGICN)
+8 if RGDFN'>0
QUIT
+9 SET RGVCCI=$$GETVCCI^MPIF001(RGDFN)
+10 if RGVCCI<1
QUIT
+11 ;fix TS need IEN for compare not sta. num.
+12 SET RGVCCI=$$LKUP^XUAF4(RGVCCI)
+13 IF RGVCCI=""
DO START^RGHLLOG(HLMTIEN)
DO EXC^RGHLLOG(229,"MSG#"_$GET(HLMID)_" Unable to send Subscription. Duplicate station number of "_$$GETVCCI^MPIF001(RGDFN)_" in Institution file.",RGDFN)
DO STOP^RGHLLOG()
QUIT
+14 SET RGPN=$PIECE(^DPT(RGDFN,0),U)
if RGPN=""
QUIT
+15 ;clinical update
SET RGTP=1
+16 ;activation date
SET RGAD=$$NOW^XLFDT
SET RGAD=$$DTFH^RGHLUT(RGAD,1)
+17 ;Local Station information
+18 SET RGLOC=$$SITE^VASITE()
SET RGLOCIEN=$PIECE(RGLOC,U,1)
SET RGLOCNM=$PIECE(RGLOC,U,2)
SET RGLOCSN=$PIECE(RGLOC,U,3)
+19 ;current site is owner site, update existing subscribers
IF RGVCCI=RGLOCIEN
Begin DoDot:1
+20 ;get SCN
SET RGSCN=$$GETSCN^RGJCREC(RGDFN)
+21 ;get local link definition
DO LINK^HLUTIL3(RGLOCIEN,.RGFROM)
+22 SET RGLL=$ORDER(RGFROM(0))
if RGLL=""
QUIT
SET RGLL=RGFROM(RGLL)
+23 DO REC1^RGJCREC
End DoDot:1
+24 ;current site is not owner, update only owner
IF RGVCCI'=RGLOCIEN
Begin DoDot:1
+25 ;Local Link
DO LINK^HLUTIL3(RGLOCIEN,.RGFROM)
+26 ;sending facility
SET RGFROM=$ORDER(RGFROM(0))
if RGFROM=""
QUIT
SET RGFROM=RGFROM(RGFROM)
+27 IF $EXTRACT(RGFROM,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN)
DO EXC^RGHLLOG(224,"MSG#"_$GET(HLMID)_" Unable to send Subscription from "_RGFROM_". This is not a MPI/PD Site.",RGDFN)
DO STOP^RGHLLOG()
QUIT
+28 ;get VCCI Link
DO LINK^HLUTIL3(RGVCCI,.RGTO)
+29 SET RGTO=$ORDER(RGTO(0))
if RGTO=""
QUIT
+30 ;receiving facility
SET RGTO=RGTO(RGTO)
+31 IF $EXTRACT(RGTO,1,2)'="VA"
DO START^RGHLLOG(HLMTIEN)
DO EXC^RGHLLOG(224,"MSG#"_$GET(HLMID)_" Unable to send Subscription to "_RGTO_". This is not a MPI/PD Site.",RGDFN)
DO STOP^RGHLLOG()
QUIT
+32 if RGTO=RGFROM
QUIT
+33 SET RGSTUB=RGFROM_U_RGTO_U_RGICN_U_RGPN_U_RGTP_U_RGAD
+34 DO EN^RGEQ("SCN_REQ",RGSTUB)
End DoDot:1
