source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGJCSUB.m@ 1590

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)