- HLCS2 ;SF/JC - More Communication Server utilities ; 08/05/2011 11:22
- ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122,157**;Oct 13, 1995;Build 8
- ;Per VHA Directive 2004-038, this routine should not be modified.
- FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array
- ;This enhancement also supports distribution of a message to
- ;the same client over multiple logical links.
- Q:'$D(HLL("LINKS"))
- N CNT,LNK,CLIAP
- S CNT=0,ROUTINE=1 F S CNT=$O(HLL("LINKS",CNT)) Q:CNT<1 D
- . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2)
- . Q:PTR="" I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1
- . ;
- . ; patch HL*1.6*122: excluding subscribers defined in
- . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber
- . N I,EXCLUDE
- . S (EXCLUDE,I)=0
- . F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I D Q:EXCLUDE
- .. N TEMP
- .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
- .. I TEMP=PTR S EXCLUDE=1
- . Q:EXCLUDE
- . ;
- . Q:LNK="" I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1
- . Q:'$D(^HLCS(870,LNK))
- . S CLIAP=$$PTR^HLUTIL2(PTR)
- . ; patch HL*1.6*122: add the 3rd component as receiving facility
- . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
- . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3))
- Q
- ADD ;Deliver message to supplemental client list.
- ;Invoked by HLTP before and after processing normal clients
- ;Only processes remote links. Local clients must be subscribing
- ;protocols.
- Q:'$D(HLSUP("S"))
- N HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS
- S ZHLEIDS=0 F S ZHLEIDS=$O(HLSUP("S",ZHLEIDS)) Q:ZHLEIDS<1 D
- .S ZLOGLINK=0 F S ZLOGLINK=$O(HLSUP("S",ZHLEIDS,ZLOGLINK)) Q:ZLOGLINK<1 D
- ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
- ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q
- .. ; patch HL*1.6*122 start
- .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
- .. S HLOGLINK=ZLOGLINK
- .. ; 3rd component for receiving facility
- .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3)
- .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK)
- .. D STATUS^HLTF0(+ZMTIENS,1)
- .. ; patch HL*1.6*122 end
- .. ;
- K HLL("LINKS"),HLSUP
- Q
- STALL ;STOP ALL LINKS AND FILERS
- N DIR,Y
- W ! S DIR(0)="Y",DIR("A")="Okay to shut down all Links and Filers"
- D ^DIR
- I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"Shutdown Aborted!" Q
- W !,"Shutting down all Links and Filers..."
- D CLEAR
- D LLP(1)
- Q
- QUE ;Restart Filers and AUTOSTART Logical Links after system re-boot
- N DIR,Y
- I '$D(ZTQUEUED) D Q:'Y!($D(DIRUT))!($D(DUOUT))
- .W ! S DIR(0)="Y",DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay"
- .D ^DIR
- .I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"RESTART Aborted!" Q
- .W !,"Restarting all Autostart-Enabled Links and Filers..."
- D CLEAR
- D STARTF
- D LLP(0)
- D STRT
- Q
- CLEAR ;Reset state of 869.3
- S DA(1)=1,DA=0,DIK="^HLCS(869.3,1,2,"
- F S DA=$O(^HLCS(869.3,DA(1),2,DA)) Q:DA<1 D ^DIK
- S DA=0,DIK="^HLCS(869.3,1,3,"
- F S DA=$O(^HLCS(869.3,DA(1),3,DA)) Q:DA<1 D ^DIK
- Q
- STARTF ;Start filers
- ;Get Defaults
- N TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1
- S PTR=+$O(^HLCS(869.3,0)) Q:'PTR
- ;default # of incoming filers
- S HLNODE1=$G(^HLCS(869.3,PTR,1)),DEFCNT=+$P(HLNODE1,U) S:'DEFCNT DEFCNT=1
- F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("IN")
- ;default # of outgoing filers
- S DEFCNT=+$P(HLNODE1,U,2) S:'DEFCNT DEFCNT=1
- F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("OUT")
- Q
- LLP(ALL) ;Stop Logical Links
- ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped
- N HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y S HLDP=0
- F S HLDP=$O(^HLCS(870,HLDP)) Q:'HLDP S HLDP0=$G(^(HLDP,0)),X=+$P(HLDP0,U,3) D:X
- .;skip this link if not stopping all and Autostart not enabled
- . I 'ALL&('$P(HLDP0,U,6)) Q
- . S HLPARM4=$G(^HLCS(870,HLDP,400))
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
- . ; patch HL*1.6*157
- . ; I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS"
- . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX")
- . ;
- . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
- . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
- . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting"
- . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown"
- . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109
- . ; patch HL*1.6*157
- . ; I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
- . I ($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
- .. ; pass task number to stop listener
- .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12))
- ; patch HL*1.6*122 start
- ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- ; .. I POP D HOME^%ZIS Q
- ; .. D CLOSE^%ZISTCP
- ; patch HL*1.6*122 end
- Q
- STRT ;Start Links
- N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU
- S HLDP=0
- F S HLDP=$O(^HLCS(870,HLDP)) Q:HLDP<1 S HLDP0=$G(^(HLDP,0)) D
- . S HLPARM4=$G(^HLCS(870,HLDP,400))
- . ;quit if no parameters or AUTOSTART is disabled
- . Q:'$P(HLDP0,U,6)
- . ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check
- . S HLDAPP=$P(HLDP0,U),HLTYPTR=+$P(HLDP0,U,3),HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200))
- . ;quit if no LL type or no routine
- . Q:'HLTYPTR!(HLBGR="")
- . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
- . ; patch HL*1.6*157
- . ; I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS"
- . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX")
- . ;
- . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D Q
- .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
- .. ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
- .. N HLJ,X
- .. I $P(HLDP0,U,15)=0 Q
- .. L +^HLCS(870,HLDP,0):2
- .. E Q
- .. S X="HLJ(870,"""_HLDP_","")"
- .. S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
- .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6*109
- .. L -^HLCS(870,HLDP,0)
- .. Q
- . S ZTRTN=$P(HLBGR," ",2),ZTIO="",ZTDTH=$H,HLTRACE=""
- . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
- . ;get startup node
- . I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U)
- . D ^%ZTLOAD
- Q
- SITEP ;Edit Site Parameters
- S DDSFILE=869.3,DA=1,DR="[HL SITE PARAMETERS]" D ^DDS
- Q
- PARAM() ;Return HL7 site parameters
- ;HLPARAM=domain ien^domain name^production or test^institution ien^
- ;institution name^institution number^mail group ien^mail group name^
- ;purge completed messages^purge awaiting ack messages^purge all msgs^
- ;default retention
- N HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET
- S HLX=$G(^HLCS(869.3,1,0))
- S HLX4=$G(^HLCS(869.3,1,4))
- S HLX5=$G(^HLCS(869.3,1,5))
- S HLDOMP=$P(HLX,U,2) I HLDOMP S HLDOMN=$P(^DIC(4.2,HLDOMP,0),U)
- S HLPROD=$P(HLX,U,3)
- S HLINSP=$P(HLX,U,4) I HLINSP S HLINSN=$P(^DIC(4,HLINSP,0),U),HLINSNM=$P($G(^DIC(4,HLINSP,99)),U)
- S HLMAILP=$P(HLX,U,5) I HLMAILP S HLMAILN=$P(^XMB(3.8,HLMAILP,0),U)
- S HLPRGCMP=$P(HLX4,U),HLPRGAA=$P(HLX4,U,2),HLPRGALL=$P(HLX4,U,3)
- S HLDEFRET=$P(HLX5,U)
- S HLPARAM=HLDOMP_U_$G(HLDOMN)_U_$G(HLPROD)_U_HLINSP_U_$G(HLINSN)_U_$G(HLINSNM)_U_HLMAILP_U_$G(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET
- Q HLPARAM
- ;
- GETAPP(HLAPP) ;Function to Retrieve parameters pertaining to a specific sending or receiving application
- ;HLAPP=APPLICATION NAME OR IEN OF FILE 771
- ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive)
- S HLAPP=$G(HLAPP)
- I HLAPP]"",'HLAPP S HLAPP=$O(^HL(771,"B",$E(HLAPP,1,30),0))
- I 'HLAPP Q ""
- I HLAPP S HLM=$P(^HL(771,HLAPP,0),U,4)
- I HLM S HLM=$P($G(^XMB(3.8,HLM,0)),U)
- Q $G(HLM)_U_$P(^HL(771,HLAPP,0),U,2)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCS2 8119 printed Jan 18, 2025@02:57:33 Page 2
- HLCS2 ;SF/JC - More Communication Server utilities ; 08/05/2011 11:22
- +1 ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122,157**;Oct 13, 1995;Build 8
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array
- +1 ;This enhancement also supports distribution of a message to
- +2 ;the same client over multiple logical links.
- +3 if '$DATA(HLL("LINKS"))
- QUIT
- +4 NEW CNT,LNK,CLIAP
- +5 SET CNT=0
- SET ROUTINE=1
- FOR
- SET CNT=$ORDER(HLL("LINKS",CNT))
- if CNT<1
- QUIT
- Begin DoDot:1
- +6 SET PTR=$PIECE(HLL("LINKS",CNT),"^")
- SET LNK=$PIECE(HLL("LINKS",CNT),"^",2)
- +7 if PTR=""
- QUIT
- IF +PTR<1
- SET PTR=$ORDER(^ORD(101,"B",PTR,0))
- if PTR<1
- QUIT
- +8 ;
- +9 ; patch HL*1.6*122: excluding subscribers defined in
- +10 ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber
- +11 NEW I,EXCLUDE
- +12 SET (EXCLUDE,I)=0
- +13 FOR
- SET I=$ORDER(HLP("EXCLUDE SUBSCRIBER",I))
- if 'I
- QUIT
- Begin DoDot:2
- +14 NEW TEMP
- +15 SET TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- +16 IF 'TEMP
- IF TEMP]""
- SET TEMP=$ORDER(^ORD(101,"B",TEMP,0))
- +17 IF TEMP=PTR
- SET EXCLUDE=1
- End DoDot:2
- if EXCLUDE
- QUIT
- +18 if EXCLUDE
- QUIT
- +19 ;
- +20 if LNK=""
- QUIT
- IF +LNK<1
- SET LNK=$ORDER(^HLCS(870,"B",LNK,0))
- if LNK<1
- QUIT
- +21 if '$DATA(^HLCS(870,LNK))
- QUIT
- +22 SET CLIAP=$$PTR^HLUTIL2(PTR)
- +23 ; patch HL*1.6*122: add the 3rd component as receiving facility
- +24 ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
- +25 SET HLSUP("S",PTR,+LNK)=CLIAP_U_$SELECT(CLIAP<1:HLL("LINKS",CNT),1:$PIECE(HLL("LINKS",CNT),"^",3))
- End DoDot:1
- +26 QUIT
- ADD ;Deliver message to supplemental client list.
- +1 ;Invoked by HLTP before and after processing normal clients
- +2 ;Only processes remote links. Local clients must be subscribing
- +3 ;protocols.
- +4 if '$DATA(HLSUP("S"))
- QUIT
- +5 NEW HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS
- +6 SET ZHLEIDS=0
- FOR
- SET ZHLEIDS=$ORDER(HLSUP("S",ZHLEIDS))
- if ZHLEIDS<1
- QUIT
- Begin DoDot:1
- +7 SET ZLOGLINK=0
- FOR
- SET ZLOGLINK=$ORDER(HLSUP("S",ZHLEIDS,ZLOGLINK))
- if ZLOGLINK<1
- QUIT
- Begin DoDot:2
- +8 SET ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
- +9 IF ZLCLIENT<1
- if $GET(HLERROR)=""
- SET HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$PIECE(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9)
- QUIT
- +10 ; patch HL*1.6*122 start
- +11 ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
- +12 SET HLOGLINK=ZLOGLINK
- +13 ; 3rd component for receiving facility
- +14 SET ZMTIENS("REC-FACILITY")=$PIECE(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3)
- +15 DO SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK)
- +16 DO STATUS^HLTF0(+ZMTIENS,1)
- +17 ; patch HL*1.6*122 end
- +18 ;
- End DoDot:2
- End DoDot:1
- +19 KILL HLL("LINKS"),HLSUP
- +20 QUIT
- STALL ;STOP ALL LINKS AND FILERS
- +1 NEW DIR,Y
- +2 WRITE !
- SET DIR(0)="Y"
- SET DIR("A")="Okay to shut down all Links and Filers"
- +3 DO ^DIR
- +4 IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
- WRITE !!,"Shutdown Aborted!"
- QUIT
- +5 WRITE !,"Shutting down all Links and Filers..."
- +6 DO CLEAR
- +7 DO LLP(1)
- +8 QUIT
- QUE ;Restart Filers and AUTOSTART Logical Links after system re-boot
- +1 NEW DIR,Y
- +2 IF '$DATA(ZTQUEUED)
- Begin DoDot:1
- +3 WRITE !
- SET DIR(0)="Y"
- SET DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay"
- +4 DO ^DIR
- +5 IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
- WRITE !!,"RESTART Aborted!"
- QUIT
- +6 WRITE !,"Restarting all Autostart-Enabled Links and Filers..."
- End DoDot:1
- if 'Y!($DATA(DIRUT))!($DATA(DUOUT))
- QUIT
- +7 DO CLEAR
- +8 DO STARTF
- +9 DO LLP(0)
- +10 DO STRT
- +11 QUIT
- CLEAR ;Reset state of 869.3
- +1 SET DA(1)=1
- SET DA=0
- SET DIK="^HLCS(869.3,1,2,"
- +2 FOR
- SET DA=$ORDER(^HLCS(869.3,DA(1),2,DA))
- if DA<1
- QUIT
- DO ^DIK
- +3 SET DA=0
- SET DIK="^HLCS(869.3,1,3,"
- +4 FOR
- SET DA=$ORDER(^HLCS(869.3,DA(1),3,DA))
- if DA<1
- QUIT
- DO ^DIK
- +5 QUIT
- STARTF ;Start filers
- +1 ;Get Defaults
- +2 NEW TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1
- +3 SET PTR=+$ORDER(^HLCS(869.3,0))
- if 'PTR
- QUIT
- +4 ;default # of incoming filers
- +5 SET HLNODE1=$GET(^HLCS(869.3,PTR,1))
- SET DEFCNT=+$PIECE(HLNODE1,U)
- if 'DEFCNT
- SET DEFCNT=1
- +6 FOR HLCNT=1:1:DEFCNT
- SET TMP=$$TASKFLR^HLCS1("IN")
- +7 ;default # of outgoing filers
- +8 SET DEFCNT=+$PIECE(HLNODE1,U,2)
- if 'DEFCNT
- SET DEFCNT=1
- +9 FOR HLCNT=1:1:DEFCNT
- SET TMP=$$TASKFLR^HLCS1("OUT")
- +10 QUIT
- LLP(ALL) ;Stop Logical Links
- +1 ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped
- +2 NEW HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y
- SET HLDP=0
- +3 FOR
- SET HLDP=$ORDER(^HLCS(870,HLDP))
- if 'HLDP
- QUIT
- SET HLDP0=$GET(^(HLDP,0))
- SET X=+$PIECE(HLDP0,U,3)
- if X
- Begin DoDot:1
- +4 ;skip this link if not stopping all and Autostart not enabled
- +5 IF 'ALL&('$PIECE(HLDP0,U,6))
- QUIT
- +6 SET HLPARM4=$GET(^HLCS(870,HLDP,400))
- +7 ; patch HL*1.6*122
- +8 ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- +9 ; or Cache/VMS
- +10 ; patch HL*1.6*157
- +11 ; I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS"
- +12 IF $PIECE(HLPARM4,U,3)="M"
- if ^%ZOSF("OS")'["OpenM"
- QUIT
- if ($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX")
- QUIT
- +13 ;
- +14 ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
- +15 SET X="HLJ(870,"""_HLDP_","")"
- SET @X@(10)=$$NOW^XLFDT
- SET (@X@(11),@X@(9))="@"
- SET @X@(14)=1
- +16 IF "Shutdown,SHUTDOWN"'[$PIECE(HLDP0,U,5)
- SET @X@(4)="Halting"
- +17 IF $PIECE(HLPARM4,U,3)="C"&("N"[$PIECE(HLPARM4,U,4))
- IF '$PIECE(HLDP0,U,12)
- SET @X@(4)="Shutdown"
- +18 ;HL*1.6*109
- DO FILE^HLDIE("","HLJ","","LLP","HLCS2")
- +19 ; patch HL*1.6*157
- +20 ; I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
- +21 IF ($PIECE(HLPARM4,U,3)="M"!($PIECE(HLPARM4,U,3)="S"))
- Begin DoDot:2
- +22 ; pass task number to stop listener
- +23 if $PIECE(HLDP0,U,12)
- SET X=$$ASKSTOP^%ZTLOAD(+$PIECE(HLDP0,U,12))
- End DoDot:2
- End DoDot:1
- +24 ; patch HL*1.6*122 start
- +25 ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- +26 ; .. I POP D HOME^%ZIS Q
- +27 ; .. D CLOSE^%ZISTCP
- +28 ; patch HL*1.6*122 end
- +29 QUIT
- STRT ;Start Links
- +1 NEW HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU
- +2 SET HLDP=0
- +3 FOR
- SET HLDP=$ORDER(^HLCS(870,HLDP))
- if HLDP<1
- QUIT
- SET HLDP0=$GET(^(HLDP,0))
- Begin DoDot:1
- +4 SET HLPARM4=$GET(^HLCS(870,HLDP,400))
- +5 ;quit if no parameters or AUTOSTART is disabled
- +6 if '$PIECE(HLDP0,U,6)
- QUIT
- +7 ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check
- +8 SET HLDAPP=$PIECE(HLDP0,U)
- SET HLTYPTR=+$PIECE(HLDP0,U,3)
- SET HLBGR=$GET(^HLCS(869.1,HLTYPTR,100))
- SET HLENV=$GET(^(200))
- +9 ;quit if no LL type or no routine
- +10 if 'HLTYPTR!(HLBGR="")
- QUIT
- +11 IF HLENV'=""
- KILL HLQUIT
- XECUTE HLENV
- if $DATA(HLQUIT)
- QUIT
- +12 ; patch HL*1.6*122
- +13 ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- +14 ; or Cache/VMS
- +15 ; patch HL*1.6*157
- +16 ; I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS"
- +17 IF $PIECE(HLPARM4,U,3)="M"
- if ^%ZOSF("OS")'["OpenM"
- QUIT
- if ($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX")
- QUIT
- +18 ;
- +19 IF $PIECE(HLPARM4,U,3)="C"&("N"[$PIECE(HLPARM4,U,4))
- Begin DoDot:2
- +20 ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
- +21 ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
- +22 NEW HLJ,X
- +23 IF $PIECE(HLDP0,U,15)=0
- QUIT
- +24 LOCK +^HLCS(870,HLDP,0):2
- +25 IF '$TEST
- QUIT
- +26 SET X="HLJ(870,"""_HLDP_","")"
- +27 SET @X@(4)="Enabled"
- SET @X@(9)=$$NOW^XLFDT
- SET @X@(14)=0
- +28 ; HL*1.6*109
- DO FILE^HLDIE("","HLJ","","STRT","HLCS2")
- +29 LOCK -^HLCS(870,HLDP,0)
- +30 QUIT
- End DoDot:2
- QUIT
- +31 SET ZTRTN=$PIECE(HLBGR," ",2)
- SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET HLTRACE=""
- +32 SET ZTDESC=HLDAPP_" Low Level Protocol"
- SET ZTSAVE("HLDP")=""
- +33 ;get startup node
- +34 IF $PIECE(HLPARM4,U,6)
- IF $DATA(^%ZIS(14.7,+$PIECE(HLPARM4,U,6),0))
- SET ZTCPU=$PIECE(^(0),U)
- +35 DO ^%ZTLOAD
- End DoDot:1
- +36 QUIT
- SITEP ;Edit Site Parameters
- +1 SET DDSFILE=869.3
- SET DA=1
- SET DR="[HL SITE PARAMETERS]"
- DO ^DDS
- +2 QUIT
- PARAM() ;Return HL7 site parameters
- +1 ;HLPARAM=domain ien^domain name^production or test^institution ien^
- +2 ;institution name^institution number^mail group ien^mail group name^
- +3 ;purge completed messages^purge awaiting ack messages^purge all msgs^
- +4 ;default retention
- +5 NEW HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET
- +6 SET HLX=$GET(^HLCS(869.3,1,0))
- +7 SET HLX4=$GET(^HLCS(869.3,1,4))
- +8 SET HLX5=$GET(^HLCS(869.3,1,5))
- +9 SET HLDOMP=$PIECE(HLX,U,2)
- IF HLDOMP
- SET HLDOMN=$PIECE(^DIC(4.2,HLDOMP,0),U)
- +10 SET HLPROD=$PIECE(HLX,U,3)
- +11 SET HLINSP=$PIECE(HLX,U,4)
- IF HLINSP
- SET HLINSN=$PIECE(^DIC(4,HLINSP,0),U)
- SET HLINSNM=$PIECE($GET(^DIC(4,HLINSP,99)),U)
- +12 SET HLMAILP=$PIECE(HLX,U,5)
- IF HLMAILP
- SET HLMAILN=$PIECE(^XMB(3.8,HLMAILP,0),U)
- +13 SET HLPRGCMP=$PIECE(HLX4,U)
- SET HLPRGAA=$PIECE(HLX4,U,2)
- SET HLPRGALL=$PIECE(HLX4,U,3)
- +14 SET HLDEFRET=$PIECE(HLX5,U)
- +15 SET HLPARAM=HLDOMP_U_$GET(HLDOMN)_U_$GET(HLPROD)_U_HLINSP_U_$GET(HLINSN)_U_$GET(HLINSNM)_U_HLMAILP_U_$GET(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET
- +16 QUIT HLPARAM
- +17 ;
- GETAPP(HLAPP) ;Function to Retrieve parameters pertaining to a specific sending or receiving application
- +1 ;HLAPP=APPLICATION NAME OR IEN OF FILE 771
- +2 ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive)
- +3 SET HLAPP=$GET(HLAPP)
- +4 IF HLAPP]""
- IF 'HLAPP
- SET HLAPP=$ORDER(^HL(771,"B",$EXTRACT(HLAPP,1,30),0))
- +5 IF 'HLAPP
- QUIT ""
- +6 IF HLAPP
- SET HLM=$PIECE(^HL(771,HLAPP,0),U,4)
- +7 IF HLM
- SET HLM=$PIECE($GET(^XMB(3.8,HLM,0)),U)
- +8 QUIT $GET(HLM)_U_$PIECE(^HL(771,HLAPP,0),U,2)