EAS1071C ;ALB/PJH - ESR and HEC Messaging ; 11/27/07 3:02pm
;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18
;
LINK ;Link QRY Z10/Z11 protocols to shared servers
N ERROR,FILE,IEN101,LINE,LNCNT,RETURN,SIEN101,SNAM
S LNCNT=1
F S LINE=$T(PROTDAT1+LNCNT) Q:$P(LINE,";",3)="END" D Q:STOP
.S NAM=PREFHEC_$P(LINE,";",3)_" SERVER"
.S IEN101=$O(^ORD(101,"B",NAM,0))
.I +IEN101=0 D Q
..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
..S RETURN=-1_"^"_ERROR
..D ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM)
.;
.;Client Protocol
.S SNAM=@("PREF"_SYS)
.S SNAM=SNAM_$P(LINE,";",3)_" CLIENT"
.S SIEN101=$O(^ORD(101,"B",SNAM,0))
.I +SIEN101=0 D Q
..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
..S RETURN=-1_"^"_ERROR
..D ABORT2^EAS1071A(RETURN,"Subscriber:"_SNAM)
.;Skip if already present
.I $D(^ORD(101,IEN101,775,"B",SIEN101)) D Q
..D WARN^EAS1071A(NAM,SNAM)
..S LNCNT=LNCNT+1
.;Add subscriber to event driver
.S RETURN=$$SUBSCR^EAS1071A(IEN101,SIEN101)
.I +RETURN<0 D ABORT2^EAS1071A(RETURN,"driver with Subscriber:"_SNAM) Q
.S LNCNT=LNCNT+1
Q
;
UNLINK(PREF) ;Remove Z10/Z11 client subscriber protocols from shared servers
F LCT=1:1 S LINE=$T(PROTDAT1+LCT) Q:$P(LINE,";",3)="END" D Q:STOP
.S NAM=PREF_$P(LINE,";",3)_" CLIENT"
.S SIEN101=$O(^ORD(101,"B",NAM,0))
.I +SIEN101=0 D Q
..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
..S RETURN=-1_"^"_ERROR
..D ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM)
.;If this is a SUBSCRIBER remove from SERVER
.I $O(^ORD(101,"AB",SIEN101,0)) D REMOVE^EAS1071A(SIEN101,NAM)
Q
;
PROTDAT1 ;
;;QRY-Z10
;;QRY-Z11
;;END
;
SOR(PREF,PREFHEC) ;Check if SOR
N IENC,IENS,NAMC,NAMS
S NAMS=PREFHEC_"QRY-Z10 SERVER"
;get server ien
S IENS=$O(^ORD(101,"B",NAMS,0)) Q:'IENS 0
;check subscriber protocols
S IENC=+$G(^ORD(101,IENS,775,1,0)) Q:'IENC 0
;Check subscriber if is for this system
I $P($G(^ORD(101,IENC,0)),U)[PREF Q 1
;
Q 0
;
Z07(PREF,PREFHEC) ;Check if Z07 messaging is set up
N IENC,IENS,FOUND,NAMC,NAMS
S NAMC=PREF_"ORU-Z07 CLIENT",NAMS=PREFHEC_"ORU-Z07 SERVER"
;get server ien
S IENS=$O(^ORD(101,"B",NAMS,0)) Q:'IENS 0
;check subscriber protocols
S IENC=0,FOUND=0
F S IENC=$O(^ORD(101,IENS,775,"B",IENC)) Q:'IENC D Q:FOUND
.;Check subscriber if is for this system
.S:$P($G(^ORD(101,IENC,0)),U)=NAMC FOUND=1
;
Q FOUND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEAS1071C 2407 printed Apr 09, 2024@21:00:07 Page 2
EAS1071C ;ALB/PJH - ESR and HEC Messaging ; 11/27/07 3:02pm
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18
+2 ;
LINK ;Link QRY Z10/Z11 protocols to shared servers
+1 NEW ERROR,FILE,IEN101,LINE,LNCNT,RETURN,SIEN101,SNAM
+2 SET LNCNT=1
+3 FOR
SET LINE=$TEXT(PROTDAT1+LNCNT)
if $PIECE(LINE,";",3)="END"
QUIT
Begin DoDot:1
+4 SET NAM=PREFHEC_$PIECE(LINE,";",3)_" SERVER"
+5 SET IEN101=$ORDER(^ORD(101,"B",NAM,0))
+6 IF +IEN101=0
Begin DoDot:2
+7 SET ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
+8 SET RETURN=-1_"^"_ERROR
+9 DO ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM)
End DoDot:2
QUIT
+10 ;
+11 ;Client Protocol
+12 SET SNAM=@("PREF"_SYS)
+13 SET SNAM=SNAM_$PIECE(LINE,";",3)_" CLIENT"
+14 SET SIEN101=$ORDER(^ORD(101,"B",SNAM,0))
+15 IF +SIEN101=0
Begin DoDot:2
+16 SET ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
+17 SET RETURN=-1_"^"_ERROR
+18 DO ABORT2^EAS1071A(RETURN,"Subscriber:"_SNAM)
End DoDot:2
QUIT
+19 ;Skip if already present
+20 IF $DATA(^ORD(101,IEN101,775,"B",SIEN101))
Begin DoDot:2
+21 DO WARN^EAS1071A(NAM,SNAM)
+22 SET LNCNT=LNCNT+1
End DoDot:2
QUIT
+23 ;Add subscriber to event driver
+24 SET RETURN=$$SUBSCR^EAS1071A(IEN101,SIEN101)
+25 IF +RETURN<0
DO ABORT2^EAS1071A(RETURN,"driver with Subscriber:"_SNAM)
QUIT
+26 SET LNCNT=LNCNT+1
End DoDot:1
if STOP
QUIT
+27 QUIT
+28 ;
UNLINK(PREF) ;Remove Z10/Z11 client subscriber protocols from shared servers
+1 FOR LCT=1:1
SET LINE=$TEXT(PROTDAT1+LCT)
if $PIECE(LINE,";",3)="END"
QUIT
Begin DoDot:1
+2 SET NAM=PREF_$PIECE(LINE,";",3)_" CLIENT"
+3 SET SIEN101=$ORDER(^ORD(101,"B",NAM,0))
+4 IF +SIEN101=0
Begin DoDot:2
+5 SET ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND"
+6 SET RETURN=-1_"^"_ERROR
+7 DO ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM)
End DoDot:2
QUIT
+8 ;If this is a SUBSCRIBER remove from SERVER
+9 IF $ORDER(^ORD(101,"AB",SIEN101,0))
DO REMOVE^EAS1071A(SIEN101,NAM)
End DoDot:1
if STOP
QUIT
+10 QUIT
+11 ;
PROTDAT1 ;
+1 ;;QRY-Z10
+2 ;;QRY-Z11
+3 ;;END
+4 ;
SOR(PREF,PREFHEC) ;Check if SOR
+1 NEW IENC,IENS,NAMC,NAMS
+2 SET NAMS=PREFHEC_"QRY-Z10 SERVER"
+3 ;get server ien
+4 SET IENS=$ORDER(^ORD(101,"B",NAMS,0))
if 'IENS
QUIT 0
+5 ;check subscriber protocols
+6 SET IENC=+$GET(^ORD(101,IENS,775,1,0))
if 'IENC
QUIT 0
+7 ;Check subscriber if is for this system
+8 IF $PIECE($GET(^ORD(101,IENC,0)),U)[PREF
QUIT 1
+9 ;
+10 QUIT 0
+11 ;
Z07(PREF,PREFHEC) ;Check if Z07 messaging is set up
+1 NEW IENC,IENS,FOUND,NAMC,NAMS
+2 SET NAMC=PREF_"ORU-Z07 CLIENT"
SET NAMS=PREFHEC_"ORU-Z07 SERVER"
+3 ;get server ien
+4 SET IENS=$ORDER(^ORD(101,"B",NAMS,0))
if 'IENS
QUIT 0
+5 ;check subscriber protocols
+6 SET IENC=0
SET FOUND=0
+7 FOR
SET IENC=$ORDER(^ORD(101,IENS,775,"B",IENC))
if 'IENC
QUIT
Begin DoDot:1
+8 ;Check subscriber if is for this system
+9 if $PIECE($GET(^ORD(101,IENC,0)),U)=NAMC
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+10 ;
+11 QUIT FOUND
