RGRSDYN1 ;ALB/RJS-BUILD DYNAMIC LINK LIST FOR A TFU ;06/09/97
;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,8,23,27**;30 Apr 99
;Reference to ^DGCN(391.91 supported by IA #2911
;Reference to $$SEND2^VAFCUTL1 supported by IA #2779
EN(CLIENT,CLASS) ;
;CLIENT=HL7 CLIENT PROTOCOL AT TARGET SYSTEM
;DATA CLASS (Opt.) = Pull from Subs. Registry ONLY
;For now, anything else is both DESCRIPTIVE AND CLINICAL
S CLASS=$G(CLASS),CLIENT=$G(CLIENT)
Q:CLIENT="" ;No receiver
N PPF,DFN,HERE,RGRS,PPFIEN,ICN,MPI
PARS ;Parse local outbound message
N RGDC
D INITIZE^RGRSUTIL,EN^RGRSPAR1("RGRS")
;Get DFN
S ICN=$G(RGRS("ICN")) Q:$G(ICN)']""
S DFN=$$GETDFN^MPIF001(ICN) Q:+DFN'>0
Q:+$$SEND2^VAFCUTL1(DFN,"T") ;don't broadcast test patients
Q:$$IFLOCAL^MPIF001(DFN)
S PPF=$$GETVCCI^MPIF001(DFN)\1 Q:+PPF'>0
S PPFIEN=$$LKUP^XUAF4(PPF)
S HERE=$P($$SITE^VASITE,"^",3)\1
NOTPPF ; if not ppf send only to ppf
I PPF'=HERE D Q
. N PPFLINK,INDEX
. D LINK^HLUTIL3(PPFIEN,.PPFLINK)
. S INDEX=$O(PPFLINK(0))
. I INDEX]"" S HLL("LINKS",1)=CLIENT_"^"_PPFLINK(INDEX)
ISPPF ;
I PPF=HERE D Q
. N PARENT,INDEX,SUBCONTL,CHILDREN,INDEX1,NODE
. S NODE=$$MPINODE^MPIFAPI(DFN)
. S SUBCONTL=$P($G(NODE),"^",5)
. ;Get subscribers, return updated HLL array
. ;replaced with GET line tag: I SUBCONTL]"" D GET^HLSUB(SUBCONTL,+CLASS,CLIENT,.HLL)
. ;D GET(DFN,SUBCONTL,+CLASS,CLIENT,.HLL)
. D GETLINKS(.HLL)
. ;Get MPI link from SITE PARAMETER
. S MPI=$$MPILINK^MPIFAPI() D
. . I $P($G(MPI),U)'=-1 S HLL("LINKS",9999999999)=CLIENT_"^"_MPI
. . I $P($G(MPI),U)=-1 D
. . . N RGLOG,RGMTXT
. . . S RGMTXT=""
. . . D START^RGHLLOG(HLMTIEN,"","") D EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,DFN) D STOP^RGHLLOG(0)
;
Q
GETLINKS(HLL) ;
N RGTF,RGHL,X
S X=$$QUERYTF^VAFCTFU1($G(ICN),"RGTF")
;LOOP THOUGH TF LIST AND GET LINK FOR EACH
N LP,CNT,STN,STNIEN,RGHL S CNT=1,LP=0 K ERROR
F S LP=$O(RGTF(LP)) Q:LP="" D
.S STN=$$STA^XUAF4($G(RGTF(LP)))
.S STNIEN=$$IEN^XUAF4(STN)
.Q:$P($$SITE^VASITE(),"^",3)=STN
.K RGHL D LINK^HLUTIL3(STNIEN,.RGHL)
.I '$O(RGHL(0)) S ERROR="-1^Unknown Logical Link for Station # "_STN_" Unable to send msg for patient "_DFN
.I $D(ERROR) D EXC^RGHLLOG(224,ERROR,DFN) K ERROR Q
.S HLL("LINKS",CNT)=CLIENT_"^"_$P(RGHL($O(RGHL(0))),"^"),CNT=CNT+1
Q
GET(RGDFN,RGSCN,RGTP,RGCLP,RGLL) ;GET Subscribers
;RGDFN - Patient IEN from FILE (#2)
;RGSCN - Subcription Control Number
;RGTP - SUBSCRIBER TYPE (0,1,2)/Null=all
;RGCLP - HL7 CLIENT PROTOCOL (required)
;RGLL - HLL("LINKS",x)=CLIENT PROTOCOL^LOGICAL LINK (passed by reference)
N RG,RGI,RGLLIEN,RGLLI,RGLLS,RGLLN,RGLLZ,RGTF,RGTFF,RGTFI,RGX,HLER
S U="^"
;get subscribers
I RGSCN'="" D GET^HLSUB(RGSCN,RGTP,RGCLP,.RGLL)
;check for a treating facility that is not a subscriber
S RGI=0 F S RGI=$O(^DGCN(391.91,"B",RGDFN,RGI)) Q:'RGI I $D(^DGCN(391.91,RGI,0)) S RGTF=$G(^DGCN(391.91,RGI,0)),RGTFI=$P(RGTF,U,2) D:RGTFI'=+$$SITE^VASITE
.;checking INSTITUTION of links to the TREATING FACILITY INSTITUTION
.;RGTFF=1 - Flag for adding Treating Facility to Subcription Control
.S RGTFF=1
.S RGX=0 F S RGX=$O(RGLL("LINKS",RGX)) Q:'RGX!(RGTFF=0) D
..S RGLLIEN=$P(RGLL("LINKS",RGX),U,6)
..I $G(RGLL)="" S RGLL("ERR",RGX)="No logical link defined for "_$P(RGLL("LINKS",RGX),U)_"." Q
..S RGLLI=RGTFI,RGLLN=$P(RGLL("LINKS",RGX),U,2)
..I '$L(RGLLI),'$D(RGLL("ERR",RGX)) S RGLL("ERR",RGX)="Link "_$P(RGLL("LINKS",RGX),U,2)_" does not contain a link to the INSTUTUTION (#4) file." Q
..I $L(RGLLI) S:RGLLI'=RGTFI RGTFF=1 I RGLLI=RGTFI S RGTFF=0 Q
.;If TF not in Subscriber list, kill list, add to subscription control file then get new list
.I RGTFF=1 D LINK^HLUTIL3("`"_RGTFI,.RG,"I") S RGLLI=$O(RG(0)) D
..I +$G(RGLLI)>0 S RGLLN=$P(RG(RGLLI),U),RGLLI=RGTFI
..I +$G(RGLLI)>0 S:RGSCN="" RGSCN=$$GETSCN^RGJCREC(RGDFN) D UPD^HLSUB(RGSCN,RGLLN,RGTP,$$NOW^XLFDT,,,.HLER) K RGLL("LINKS") D GET^HLSUB(RGSCN,RGTP,RGCLP,.RGLL)
..I +$G(RGLLI)'>0 W !,"Unable to find Logical link for "_$$GET1^DIQ(4,+RGTFI_",",.01)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGRSDYN1 4079 printed Sep 23, 2025@19:18:52 Page 2
RGRSDYN1 ;ALB/RJS-BUILD DYNAMIC LINK LIST FOR A TFU ;06/09/97
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,8,23,27**;30 Apr 99
+2 ;Reference to ^DGCN(391.91 supported by IA #2911
+3 ;Reference to $$SEND2^VAFCUTL1 supported by IA #2779
EN(CLIENT,CLASS) ;
+1 ;CLIENT=HL7 CLIENT PROTOCOL AT TARGET SYSTEM
+2 ;DATA CLASS (Opt.) = Pull from Subs. Registry ONLY
+3 ;For now, anything else is both DESCRIPTIVE AND CLINICAL
+4 SET CLASS=$GET(CLASS)
SET CLIENT=$GET(CLIENT)
+5 ;No receiver
if CLIENT=""
QUIT
+6 NEW PPF,DFN,HERE,RGRS,PPFIEN,ICN,MPI
PARS ;Parse local outbound message
+1 NEW RGDC
+2 DO INITIZE^RGRSUTIL
DO EN^RGRSPAR1("RGRS")
+3 ;Get DFN
+4 SET ICN=$GET(RGRS("ICN"))
if $GET(ICN)']""
QUIT
+5 SET DFN=$$GETDFN^MPIF001(ICN)
if +DFN'>0
QUIT
+6 ;don't broadcast test patients
if +$$SEND2^VAFCUTL1(DFN,"T")
QUIT
+7 if $$IFLOCAL^MPIF001(DFN)
QUIT
+8 SET PPF=$$GETVCCI^MPIF001(DFN)\1
if +PPF'>0
QUIT
+9 SET PPFIEN=$$LKUP^XUAF4(PPF)
+10 SET HERE=$PIECE($$SITE^VASITE,"^",3)\1
NOTPPF ; if not ppf send only to ppf
+1 IF PPF'=HERE
Begin DoDot:1
+2 NEW PPFLINK,INDEX
+3 DO LINK^HLUTIL3(PPFIEN,.PPFLINK)
+4 SET INDEX=$ORDER(PPFLINK(0))
+5 IF INDEX]""
SET HLL("LINKS",1)=CLIENT_"^"_PPFLINK(INDEX)
End DoDot:1
QUIT
ISPPF ;
+1 IF PPF=HERE
Begin DoDot:1
+2 NEW PARENT,INDEX,SUBCONTL,CHILDREN,INDEX1,NODE
+3 SET NODE=$$MPINODE^MPIFAPI(DFN)
+4 SET SUBCONTL=$PIECE($GET(NODE),"^",5)
+5 ;Get subscribers, return updated HLL array
+6 ;replaced with GET line tag: I SUBCONTL]"" D GET^HLSUB(SUBCONTL,+CLASS,CLIENT,.HLL)
+7 ;D GET(DFN,SUBCONTL,+CLASS,CLIENT,.HLL)
+8 DO GETLINKS(.HLL)
+9 ;Get MPI link from SITE PARAMETER
+10 SET MPI=$$MPILINK^MPIFAPI()
Begin DoDot:2
+11 IF $PIECE($GET(MPI),U)'=-1
SET HLL("LINKS",9999999999)=CLIENT_"^"_MPI
+12 IF $PIECE($GET(MPI),U)=-1
Begin DoDot:3
+13 NEW RGLOG,RGMTXT
+14 SET RGMTXT=""
+15 DO START^RGHLLOG(HLMTIEN,"","")
DO EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,DFN)
DO STOP^RGHLLOG(0)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+16 ;
+17 QUIT
GETLINKS(HLL) ;
+1 NEW RGTF,RGHL,X
+2 SET X=$$QUERYTF^VAFCTFU1($GET(ICN),"RGTF")
+3 ;LOOP THOUGH TF LIST AND GET LINK FOR EACH
+4 NEW LP,CNT,STN,STNIEN,RGHL
SET CNT=1
SET LP=0
KILL ERROR
+5 FOR
SET LP=$ORDER(RGTF(LP))
if LP=""
QUIT
Begin DoDot:1
+6 SET STN=$$STA^XUAF4($GET(RGTF(LP)))
+7 SET STNIEN=$$IEN^XUAF4(STN)
+8 if $PIECE($$SITE^VASITE(),"^",3)=STN
QUIT
+9 KILL RGHL
DO LINK^HLUTIL3(STNIEN,.RGHL)
+10 IF '$ORDER(RGHL(0))
SET ERROR="-1^Unknown Logical Link for Station # "_STN_" Unable to send msg for patient "_DFN
+11 IF $DATA(ERROR)
DO EXC^RGHLLOG(224,ERROR,DFN)
KILL ERROR
QUIT
+12 SET HLL("LINKS",CNT)=CLIENT_"^"_$PIECE(RGHL($ORDER(RGHL(0))),"^")
SET CNT=CNT+1
End DoDot:1
+13 QUIT
GET(RGDFN,RGSCN,RGTP,RGCLP,RGLL) ;GET Subscribers
+1 ;RGDFN - Patient IEN from FILE (#2)
+2 ;RGSCN - Subcription Control Number
+3 ;RGTP - SUBSCRIBER TYPE (0,1,2)/Null=all
+4 ;RGCLP - HL7 CLIENT PROTOCOL (required)
+5 ;RGLL - HLL("LINKS",x)=CLIENT PROTOCOL^LOGICAL LINK (passed by reference)
+6 NEW RG,RGI,RGLLIEN,RGLLI,RGLLS,RGLLN,RGLLZ,RGTF,RGTFF,RGTFI,RGX,HLER
+7 SET U="^"
+8 ;get subscribers
+9 IF RGSCN'=""
DO GET^HLSUB(RGSCN,RGTP,RGCLP,.RGLL)
+10 ;check for a treating facility that is not a subscriber
+11 SET RGI=0
FOR
SET RGI=$ORDER(^DGCN(391.91,"B",RGDFN,RGI))
if 'RGI
QUIT
IF $DATA(^DGCN(391.91,RGI,0))
SET RGTF=$GET(^DGCN(391.91,RGI,0))
SET RGTFI=$PIECE(RGTF,U,2)
if RGTFI'=+$$SITE^VASITE
Begin DoDot:1
+12 ;checking INSTITUTION of links to the TREATING FACILITY INSTITUTION
+13 ;RGTFF=1 - Flag for adding Treating Facility to Subcription Control
+14 SET RGTFF=1
+15 SET RGX=0
FOR
SET RGX=$ORDER(RGLL("LINKS",RGX))
if 'RGX!(RGTFF=0)
QUIT
Begin DoDot:2
+16 SET RGLLIEN=$PIECE(RGLL("LINKS",RGX),U,6)
+17 IF $GET(RGLL)=""
SET RGLL("ERR",RGX)="No logical link defined for "_$PIECE(RGLL("LINKS",RGX),U)_"."
QUIT
+18 SET RGLLI=RGTFI
SET RGLLN=$PIECE(RGLL("LINKS",RGX),U,2)
+19 IF '$LENGTH(RGLLI)
IF '$DATA(RGLL("ERR",RGX))
SET RGLL("ERR",RGX)="Link "_$PIECE(RGLL("LINKS",RGX),U,2)_" does not contain a link to the INSTUTUTION (#4) file."
QUIT
+20 IF $LENGTH(RGLLI)
if RGLLI'=RGTFI
SET RGTFF=1
IF RGLLI=RGTFI
SET RGTFF=0
QUIT
End DoDot:2
+21 ;If TF not in Subscriber list, kill list, add to subscription control file then get new list
+22 IF RGTFF=1
DO LINK^HLUTIL3("`"_RGTFI,.RG,"I")
SET RGLLI=$ORDER(RG(0))
Begin DoDot:2
+23 IF +$GET(RGLLI)>0
SET RGLLN=$PIECE(RG(RGLLI),U)
SET RGLLI=RGTFI
+24 IF +$GET(RGLLI)>0
if RGSCN=""
SET RGSCN=$$GETSCN^RGJCREC(RGDFN)
DO UPD^HLSUB(RGSCN,RGLLN,RGTP,$$NOW^XLFDT,,,.HLER)
KILL RGLL("LINKS")
DO GET^HLSUB(RGSCN,RGTP,RGCLP,.RGLL)
+25 IF +$GET(RGLLI)'>0
WRITE !,"Unable to find Logical link for "_$$GET1^DIQ(4,+RGTFI_",",.01)
End DoDot:2
End DoDot:1
+26 QUIT
