- 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 Feb 18, 2025@23:09:15 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