LA7VLL ;DALOI\JMC - Setup HL7 v1.6 Logical Link for Consolidation ; 12/3/1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,55,64**;Sep 27, 1994
;
; Reference to HL LOGICAL LINK file (#870) supported by DBIA #1495, 1496, 2063
; Reference to PROTOCOL file (#101) supported by DBIA #872
; Reference to MAIL GROUP file (#3.8) supported by DBIA #2061
;
MAIL(LRI) ;
;
Q:LRI=""
;
N DA,DIC,DIE,DLAYGO,DR,FDA,LA7DIE,LA7IENS,LA7LINK,LA7VMGP,LA7VX,LA7X,LA7Y,X
;
S LA7VMGP="LA7V "_$P(LRI,"^") D MAILGRP
;
W !!,"Updating HL LOGICAL LINK file (#870)."
S LA7X="LA7V"_$P(LRI,"^"),LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
I LA7Y S LA7LINK(LA7Y)=LA7X
; Check for old spelling using 'space' in name
I LA7Y<1 D
. S LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$P(LRI,U))
. I LA7Y>0 S LA7LINK(LA7Y)=LA7X,FDA(1,870,LA7Y_",",.01)=LA7X
I LA7Y<1 D
. W !,?5,"Adding LA7V"_$P(LRI,"^")
. S X="LA7V"_$P(LRI,"^"),DIC="^HLCS(870,",DIC(0)="L",DLAYGO=870
. D ^DIC
. I Y>0 S LA7Y=+Y,LA7LINK(LA7Y)=$P(Y,U,2)
I LA7Y<1 D Q
. W !!,"Failure LA7V"_$P(LRI,"^")_" was not created in file #870."
S LA7IENS=LA7Y_","
S FDA(1,870,LA7IENS,2)="MAILMAN"
S FDA(1,870,LA7IENS,100.01)=LA7VMGP
D FILE^DIE("E","FDA(1)","LA7DIE(1)")
D CLEAN^DILF
D LL
;
Q
;
MAILGRP ; Create mail group for HL7 protocol logical link
;
N DA,DIC,DLAYGO,DOMAIN,LA738,LA7VDESC,LA7VXMY
;
W !!,"Creating mail group "_LA7VMGP_" for use by the"
W !,"HL7 v1.6 Logical Link "_LA7VMGP_"."
;
S LA7VXMY=""
S LA7VDESC(1)="This mail group is used by the HL7 Logical Link file for "
S LA7VDESC(2)="transmitting Lab data to site "_$P(LRI,"^",2)_"."
S LA738=$$MG^XMBGRP(LA7VMGP,0,DUZ,1,.LA7VXMY,.LA7VDESC,1)
I LA738<0 D Q
. W !!,"Failure: mail group ",LA7VMGP," was not created in file #3.8."
;
S DOMAIN=$$GET1^DIQ(4,+$P(LRI,"^",4)_",",60)
I $G(DOMAIN)="" D ERROR Q
;
; Add remote member to mail group
S DA(1)=LA738,DIC("P")=$P(^DD(3.8,12,0),U,2),DIC="^XMB(3.8,"_DA(1)_",6,",DIC(0)="L",DLAYGO=3.812
S X="S.HL V16 SERVER@"_DOMAIN
D ^DIC
Q
;
ERROR ; Error creating domain
;
W !!,"The INSTITUTION file (#4) entry for "_$P(LRI,"^",2)_" does not contain a domain."
W !,"Unable to create the COLLECTION system link for mail group ",$G(LA7VMGP),"."
W !,"The REMOTE MEMBER, S.HL V16 SERVER@domain name will need to be manually"
W !,"added to the mail group "_$G(LA7VMGP),"."
Q
;
;
TCP(LRI,PRIMARY) ;
;
N DIC,DA,DIE,DR,DLAYGO,FDA,LA7DIE,LA7IENS,LA7LINK,LA7P,LA7VX,LA7X,LA7Y,X
;
Q:LRI=""!PRIMARY=""
;
; Setup client logical link if one not associated with this institution
D LINK^HLUTIL3($P(LRI,"^",4),.LA7LINK,"")
I '$O(LA7LINK(0)) D
. W !!,"Updating HL LOGICAL LINK file (#870)."
. S LA7X="LA7V"_$P(LRI,U),LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
. I LA7Y>0 S LA7LINK(LA7Y)=LA7X
. ; Check for old spelling using 'space' in name
. I LA7Y<1 D
. . S LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$P(LRI,U))
. . I LA7Y>0 S LA7LINK(LA7Y)=LA7X,FDA(1,870,LA7Y_",",.01)=LA7X
. I LA7Y<1 D
. . W !,?5,"Adding "_LA7X
. . S X=LA7X,DIC="^HLCS(870,",DIC(0)="L",DLAYGO=870
. . D ^DIC
. . I Y>0 S LA7Y=+Y,LA7LINK(LA7Y)=$P(Y,U,2)
. I LA7Y<1 D Q
. . W !!,"Failure "_LA7X_" was not created in file #870."
. S LA7IENS=LA7Y_","
. S FDA(1,870,LA7IENS,2)="TCP"
. S FDA(1,870,LA7IENS,100.01)="@"
. D FILE^DIE("E","FDA(1)","LA7DIE(1)")
. D CLEAN^DILF
;
; Setup server logical link if one not associated with this institution
D LINK^HLUTIL3($P(PRIMARY,"^"),.LA7P,"")
I '$O(LA7P(0)) D
. S LA7X="LA7V"_$P(PRIMARY,U,3),LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
. ; Check for old spelling using 'space' in name
. I LA7Y<1 D
. . S LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$P(PRIMARY,U,3))
. . I LA7Y>0 S FDA(2,870,LA7Y_",",.01)=LA7X
. I LA7Y<1 D
. . W !,?5,"Adding "_LA7X
. . S X=LA7X,DIC="^HLCS(870,",DIC(0)="L",DLAYGO=870
. . D ^DIC
. . I Y>0 S LA7Y=+Y
. I LA7Y<1 D Q
. . W !!,"Failure "_LA7X_" was not created in file #870."
. K LA7IENS
. S LA7IENS=LA7Y_","
. S FDA(2,870,LA7IENS,2)="TCP"
. S FDA(2,870,LA7IENS,100.01)="@"
. D FILE^DIE("E","FDA(2)","LA7DIE(2)")
. D CLEAN^DILF
;
D LL
Q
;
;
LL ;
N DIR,DIRUT,DIROUT,DUOUT,DTOUT,LA7X,LINK,X
W !,"Updating the PROTOCOL file (#101)."
;
S X=$O(LA7LINK(0)),LINK=LA7LINK(X)
I $O(HOST(0)) D
. S LA7X="LA7V Process Results from "_$P(LRI,"^")
. D SETPRO(LA7X,"770.7///"_LINK)
. S LA7X="LA7V Send Order to "_$P(LRI,"^")
. D SETPRO(LA7X,"770.7///"_LINK)
;
I $O(REMOTE(0)) D
. S LA7X="LA7V Send Results to "_$P(LRI,"^")
. D SETPRO(LA7X,"770.7///"_LINK)
. S LA7X="LA7V Process Order from "_$P(LRI,"^")
. D SETPRO(LA7X,"770.7///"_LINK)
;
S DIR(0)="E" D ^DIR
Q
;
;
SETPRO(LA7X,LA7FLDS) ;
;
N DA,DIC,DIE,DLAYGO,DR,D0,X,Y
;
S X=$G(LA7X),DIC="^ORD(101,",DLAYGO=101,DIC(0)="LM"
D ^DIC
I +Y<1 Q
;
S DA=+Y,DR=LA7FLDS,DIE=DIC
D ^DIE
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLL 4910 printed Apr 09, 2024@20:47:32 Page 2
LA7VLL ;DALOI\JMC - Setup HL7 v1.6 Logical Link for Consolidation ; 12/3/1997
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,55,64**;Sep 27, 1994
+2 ;
+3 ; Reference to HL LOGICAL LINK file (#870) supported by DBIA #1495, 1496, 2063
+4 ; Reference to PROTOCOL file (#101) supported by DBIA #872
+5 ; Reference to MAIL GROUP file (#3.8) supported by DBIA #2061
+6 ;
MAIL(LRI) ;
+1 ;
+2 if LRI=""
QUIT
+3 ;
+4 NEW DA,DIC,DIE,DLAYGO,DR,FDA,LA7DIE,LA7IENS,LA7LINK,LA7VMGP,LA7VX,LA7X,LA7Y,X
+5 ;
+6 SET LA7VMGP="LA7V "_$PIECE(LRI,"^")
DO MAILGRP
+7 ;
+8 WRITE !!,"Updating HL LOGICAL LINK file (#870)."
+9 SET LA7X="LA7V"_$PIECE(LRI,"^")
SET LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
+10 IF LA7Y
SET LA7LINK(LA7Y)=LA7X
+11 ; Check for old spelling using 'space' in name
+12 IF LA7Y<1
Begin DoDot:1
+13 SET LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$PIECE(LRI,U))
+14 IF LA7Y>0
SET LA7LINK(LA7Y)=LA7X
SET FDA(1,870,LA7Y_",",.01)=LA7X
End DoDot:1
+15 IF LA7Y<1
Begin DoDot:1
+16 WRITE !,?5,"Adding LA7V"_$PIECE(LRI,"^")
+17 SET X="LA7V"_$PIECE(LRI,"^")
SET DIC="^HLCS(870,"
SET DIC(0)="L"
SET DLAYGO=870
+18 DO ^DIC
+19 IF Y>0
SET LA7Y=+Y
SET LA7LINK(LA7Y)=$PIECE(Y,U,2)
End DoDot:1
+20 IF LA7Y<1
Begin DoDot:1
+21 WRITE !!,"Failure LA7V"_$PIECE(LRI,"^")_" was not created in file #870."
End DoDot:1
QUIT
+22 SET LA7IENS=LA7Y_","
+23 SET FDA(1,870,LA7IENS,2)="MAILMAN"
+24 SET FDA(1,870,LA7IENS,100.01)=LA7VMGP
+25 DO FILE^DIE("E","FDA(1)","LA7DIE(1)")
+26 DO CLEAN^DILF
+27 DO LL
+28 ;
+29 QUIT
+30 ;
MAILGRP ; Create mail group for HL7 protocol logical link
+1 ;
+2 NEW DA,DIC,DLAYGO,DOMAIN,LA738,LA7VDESC,LA7VXMY
+3 ;
+4 WRITE !!,"Creating mail group "_LA7VMGP_" for use by the"
+5 WRITE !,"HL7 v1.6 Logical Link "_LA7VMGP_"."
+6 ;
+7 SET LA7VXMY=""
+8 SET LA7VDESC(1)="This mail group is used by the HL7 Logical Link file for "
+9 SET LA7VDESC(2)="transmitting Lab data to site "_$PIECE(LRI,"^",2)_"."
+10 SET LA738=$$MG^XMBGRP(LA7VMGP,0,DUZ,1,.LA7VXMY,.LA7VDESC,1)
+11 IF LA738<0
Begin DoDot:1
+12 WRITE !!,"Failure: mail group ",LA7VMGP," was not created in file #3.8."
End DoDot:1
QUIT
+13 ;
+14 SET DOMAIN=$$GET1^DIQ(4,+$PIECE(LRI,"^",4)_",",60)
+15 IF $GET(DOMAIN)=""
DO ERROR
QUIT
+16 ;
+17 ; Add remote member to mail group
+18 SET DA(1)=LA738
SET DIC("P")=$PIECE(^DD(3.8,12,0),U,2)
SET DIC="^XMB(3.8,"_DA(1)_",6,"
SET DIC(0)="L"
SET DLAYGO=3.812
+19 SET X="S.HL V16 SERVER@"_DOMAIN
+20 DO ^DIC
+21 QUIT
+22 ;
ERROR ; Error creating domain
+1 ;
+2 WRITE !!,"The INSTITUTION file (#4) entry for "_$PIECE(LRI,"^",2)_" does not contain a domain."
+3 WRITE !,"Unable to create the COLLECTION system link for mail group ",$GET(LA7VMGP),"."
+4 WRITE !,"The REMOTE MEMBER, S.HL V16 SERVER@domain name will need to be manually"
+5 WRITE !,"added to the mail group "_$GET(LA7VMGP),"."
+6 QUIT
+7 ;
+8 ;
TCP(LRI,PRIMARY) ;
+1 ;
+2 NEW DIC,DA,DIE,DR,DLAYGO,FDA,LA7DIE,LA7IENS,LA7LINK,LA7P,LA7VX,LA7X,LA7Y,X
+3 ;
+4 if LRI=""!PRIMARY=""
QUIT
+5 ;
+6 ; Setup client logical link if one not associated with this institution
+7 DO LINK^HLUTIL3($PIECE(LRI,"^",4),.LA7LINK,"")
+8 IF '$ORDER(LA7LINK(0))
Begin DoDot:1
+9 WRITE !!,"Updating HL LOGICAL LINK file (#870)."
+10 SET LA7X="LA7V"_$PIECE(LRI,U)
SET LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
+11 IF LA7Y>0
SET LA7LINK(LA7Y)=LA7X
+12 ; Check for old spelling using 'space' in name
+13 IF LA7Y<1
Begin DoDot:2
+14 SET LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$PIECE(LRI,U))
+15 IF LA7Y>0
SET LA7LINK(LA7Y)=LA7X
SET FDA(1,870,LA7Y_",",.01)=LA7X
End DoDot:2
+16 IF LA7Y<1
Begin DoDot:2
+17 WRITE !,?5,"Adding "_LA7X
+18 SET X=LA7X
SET DIC="^HLCS(870,"
SET DIC(0)="L"
SET DLAYGO=870
+19 DO ^DIC
+20 IF Y>0
SET LA7Y=+Y
SET LA7LINK(LA7Y)=$PIECE(Y,U,2)
End DoDot:2
+21 IF LA7Y<1
Begin DoDot:2
+22 WRITE !!,"Failure "_LA7X_" was not created in file #870."
End DoDot:2
QUIT
+23 SET LA7IENS=LA7Y_","
+24 SET FDA(1,870,LA7IENS,2)="TCP"
+25 SET FDA(1,870,LA7IENS,100.01)="@"
+26 DO FILE^DIE("E","FDA(1)","LA7DIE(1)")
+27 DO CLEAN^DILF
End DoDot:1
+28 ;
+29 ; Setup server logical link if one not associated with this institution
+30 DO LINK^HLUTIL3($PIECE(PRIMARY,"^"),.LA7P,"")
+31 IF '$ORDER(LA7P(0))
Begin DoDot:1
+32 SET LA7X="LA7V"_$PIECE(PRIMARY,U,3)
SET LA7Y=+$$FIND1^DIC(870,"","OX",LA7X)
+33 ; Check for old spelling using 'space' in name
+34 IF LA7Y<1
Begin DoDot:2
+35 SET LA7Y=+$$FIND1^DIC(870,"","OX","LA7V "_$PIECE(PRIMARY,U,3))
+36 IF LA7Y>0
SET FDA(2,870,LA7Y_",",.01)=LA7X
End DoDot:2
+37 IF LA7Y<1
Begin DoDot:2
+38 WRITE !,?5,"Adding "_LA7X
+39 SET X=LA7X
SET DIC="^HLCS(870,"
SET DIC(0)="L"
SET DLAYGO=870
+40 DO ^DIC
+41 IF Y>0
SET LA7Y=+Y
End DoDot:2
+42 IF LA7Y<1
Begin DoDot:2
+43 WRITE !!,"Failure "_LA7X_" was not created in file #870."
End DoDot:2
QUIT
+44 KILL LA7IENS
+45 SET LA7IENS=LA7Y_","
+46 SET FDA(2,870,LA7IENS,2)="TCP"
+47 SET FDA(2,870,LA7IENS,100.01)="@"
+48 DO FILE^DIE("E","FDA(2)","LA7DIE(2)")
+49 DO CLEAN^DILF
End DoDot:1
+50 ;
+51 DO LL
+52 QUIT
+53 ;
+54 ;
LL ;
+1 NEW DIR,DIRUT,DIROUT,DUOUT,DTOUT,LA7X,LINK,X
+2 WRITE !,"Updating the PROTOCOL file (#101)."
+3 ;
+4 SET X=$ORDER(LA7LINK(0))
SET LINK=LA7LINK(X)
+5 IF $ORDER(HOST(0))
Begin DoDot:1
+6 SET LA7X="LA7V Process Results from "_$PIECE(LRI,"^")
+7 DO SETPRO(LA7X,"770.7///"_LINK)
+8 SET LA7X="LA7V Send Order to "_$PIECE(LRI,"^")
+9 DO SETPRO(LA7X,"770.7///"_LINK)
End DoDot:1
+10 ;
+11 IF $ORDER(REMOTE(0))
Begin DoDot:1
+12 SET LA7X="LA7V Send Results to "_$PIECE(LRI,"^")
+13 DO SETPRO(LA7X,"770.7///"_LINK)
+14 SET LA7X="LA7V Process Order from "_$PIECE(LRI,"^")
+15 DO SETPRO(LA7X,"770.7///"_LINK)
End DoDot:1
+16 ;
+17 SET DIR(0)="E"
DO ^DIR
+18 QUIT
+19 ;
+20 ;
SETPRO(LA7X,LA7FLDS) ;
+1 ;
+2 NEW DA,DIC,DIE,DLAYGO,DR,D0,X,Y
+3 ;
+4 SET X=$GET(LA7X)
SET DIC="^ORD(101,"
SET DLAYGO=101
SET DIC(0)="LM"
+5 DO ^DIC
+6 IF +Y<1
QUIT
+7 ;
+8 SET DA=+Y
SET DR=LA7FLDS
SET DIE=DIC
+9 DO ^DIE
+10 ;
+11 QUIT
