HLCSOUT ;ALB/JRP/CJM - OUTGOING FILER;2/25/97 ;03/07/2011
;;1.6;HEALTH LEVEL SEVEN;**25,30,62,153,175**;Oct 13, 1995;Build 2
;Per VHA Directive 6402, this routine should not be modified.
;Supported ICR# 10063, for $$PSET^%ZTLOAD API to make task persistent
STARTOUT ;Main entry point for outgoing background filer
;Create/find entry denoting this filer in the OUTGOING FILER TASK
; NUMBER multiple (field #30) of the HL COMMUNICATION SERVER PARAMETER
; file (#869.3)
;N TMP ; These vbls are not used!
N HLPTRFLR,HLPTRLL,HLCSLOOP,HLEXIT,HLXX,HLNODE,HLOGLINK,HLPARENT
N HLHDRBLD,HLERROR,HLHDR,HLD0,HLD1,HLST1
;
;;patch HL*1.6*175 adds the $$PSET^%ZTLOAD api to set filers to persistent
N HLPERS
I $G(ZTQUEUED) D
.S HLPERS=$$PSET^%ZTLOAD(ZTQUEUED)
;
S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"OUT")
;Check if any outgoing messages are in the pending transmission queue
;
S (HLPTRLL,HLCSLOOP,HLEXIT)=0
F S HLPTRLL=+$O(^HL(772,"A-XMIT-OUT",HLPTRLL)) D Q:HLEXIT
. D CHK4STOP^HLCSUTL2(HLPTRFLR,"OUT",.HLEXIT) Q:HLEXIT
. ;Update LAST KNOWN $H (field #.03) for filer every 200th iteration
. D:'(HLCSLOOP#200) SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT")
. ;Increment loop counter (reset to 0 when greater than 1000)
. S HLCSLOOP=HLCSLOOP+1 S:HLCSLOOP>1000 HLCSLOOP=0
. I 'HLPTRLL H 1 Q
.;
.;**P153 CJM START
.L +^HLCS(870,HLPTRLL,"OUT","OUTFILER"):1
.Q:'$T
.D
..;**P153 END CJM
..;
.. S HLXX=+$O(^HL(772,"A-XMIT-OUT",HLPTRLL,0)) ;Pending messages?
.. I 'HLXX H 1 Q ;No pending messages
.. L +^HL(772,HLXX,0):1 I ('$T) H 1 Q ;Lock main node of Message Text
.. ;Make sure status hasn't changed
.. I '$D(^HL(772,"AF",1,HLXX)) L -^HL(772,HLXX,0) Q
.. ;Get Logical Link and parent message
.. ; Set status to ERROR DURING TRANSMISSION if not present
.. S HLNODE=^HL(772,HLXX,0)
.. S HLOGLINK=$P(HLNODE,"^",11)
.. I HLOGLINK'>0 D Q
.. . D STATUS^HLTF0(HLXX,4,"","Logical Link not available")
.. . L -^HL(772,HLXX,0)
.. S HLPARENT=$P(HLNODE,"^",8)
.. I HLPARENT'>0!'$G(^HL(772,HLPARENT,0)) D Q
.. . D STATUS^HLTF0(HLXX,4,"","Parent Message not available")
.. . L -^HL(772,HLXX,0)
.. ;Build message header or batch header
.. S HLHDRBLD=$P(^HL(772,HLPARENT,0),U,14)
.. I "^B^M^F^"'[(U_HLHDRBLD_U) D Q
.. . D STATUS^HLTF0(HLXX,4,"","Message Type (field #772,14) Error")
.. . L -^HL(772,HLXX,0)
.. S HLERROR=""
.. I HLHDRBLD="M" D HEADER^HLCSHDR(HLXX,.HLERROR)
.. I HLHDRBLD'="M" D BHSHDR^HLCSHDR(HLXX) S:$E(HLHDR(1),1,2)="-1" HLERROR=$P(HLHDR(1),"^",2)
.. ;If error set status ERROR DURING TRANSMISSION
.. I $G(HLERROR)'="" D STATUS^HLTF0(HLXX,4) L -^HL(772,HLXX,0) Q
.. S HLD0=$$ENQUEUE^HLCSQUE(HLOGLINK,"OUT")
.. ;If error set status ERROR DURING TRANSMISSION
.. I +HLD0<0 D STATUS^HLTF0(HLXX,4) L -^HL(772,HLXX,0) Q
.. S HLD1=$P(HLD0,"^",2)
.. S HLD0=+HLD0
.. ;Move Message Header and Message Text to file 870
.. D MERGEOUT^HLTF2(HLPARENT,HLD0,HLD1,"HLHDR")
.. K HLHDR
.. D MONITOR^HLCSDR2("P",2,HLD0,HLD1,"OUT") ;Status in queue to "PENDING"
.. ;Determine status, default to "Awaiting Ack"
.. S HLST1=$$FNDSTAT^HLUTIL3(HLXX) S:'HLST1 HLST1=2
.. D STATUS^HLTF0(HLXX,HLST1) ;Update status
.. L -^HL(772,HLXX,0) ;Unlock main node of Message Text
.. ;Update LAST KNOWN $H (field #.03) for filer
.. D SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT")
.;P153 START CJM
.L -^HLCS(870,HLPTRLL,"OUT","OUTFILER")
.;P153 END CJM
S ZTSTOP=1 ;Asked to stop
D DELFLR^HLCSUTL1(HLPTRFLR,"OUT") ;Delete entry denoting this filer
S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSOUT 3547 printed Aug 26, 2025@22:12:39 Page 2
HLCSOUT ;ALB/JRP/CJM - OUTGOING FILER;2/25/97 ;03/07/2011
+1 ;;1.6;HEALTH LEVEL SEVEN;**25,30,62,153,175**;Oct 13, 1995;Build 2
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 ;Supported ICR# 10063, for $$PSET^%ZTLOAD API to make task persistent
STARTOUT ;Main entry point for outgoing background filer
+1 ;Create/find entry denoting this filer in the OUTGOING FILER TASK
+2 ; NUMBER multiple (field #30) of the HL COMMUNICATION SERVER PARAMETER
+3 ; file (#869.3)
+4 ;N TMP ; These vbls are not used!
+5 NEW HLPTRFLR,HLPTRLL,HLCSLOOP,HLEXIT,HLXX,HLNODE,HLOGLINK,HLPARENT
+6 NEW HLHDRBLD,HLERROR,HLHDR,HLD0,HLD1,HLST1
+7 ;
+8 ;;patch HL*1.6*175 adds the $$PSET^%ZTLOAD api to set filers to persistent
+9 NEW HLPERS
+10 IF $GET(ZTQUEUED)
Begin DoDot:1
+11 SET HLPERS=$$PSET^%ZTLOAD(ZTQUEUED)
End DoDot:1
+12 ;
+13 SET HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"OUT")
+14 ;Check if any outgoing messages are in the pending transmission queue
+15 ;
+16 SET (HLPTRLL,HLCSLOOP,HLEXIT)=0
+17 FOR
SET HLPTRLL=+$ORDER(^HL(772,"A-XMIT-OUT",HLPTRLL))
Begin DoDot:1
+18 DO CHK4STOP^HLCSUTL2(HLPTRFLR,"OUT",.HLEXIT)
if HLEXIT
QUIT
+19 ;Update LAST KNOWN $H (field #.03) for filer every 200th iteration
+20 if '(HLCSLOOP#200)
DO SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT")
+21 ;Increment loop counter (reset to 0 when greater than 1000)
+22 SET HLCSLOOP=HLCSLOOP+1
if HLCSLOOP>1000
SET HLCSLOOP=0
+23 IF 'HLPTRLL
HANG 1
QUIT
+24 ;
+25 ;**P153 CJM START
+26 LOCK +^HLCS(870,HLPTRLL,"OUT","OUTFILER"):1
+27 if '$TEST
QUIT
+28 Begin DoDot:2
+29 ;**P153 END CJM
+30 ;
+31 ;Pending messages?
SET HLXX=+$ORDER(^HL(772,"A-XMIT-OUT",HLPTRLL,0))
+32 ;No pending messages
IF 'HLXX
HANG 1
QUIT
+33 ;Lock main node of Message Text
LOCK +^HL(772,HLXX,0):1
IF ('$TEST)
HANG 1
QUIT
+34 ;Make sure status hasn't changed
+35 IF '$DATA(^HL(772,"AF",1,HLXX))
LOCK -^HL(772,HLXX,0)
QUIT
+36 ;Get Logical Link and parent message
+37 ; Set status to ERROR DURING TRANSMISSION if not present
+38 SET HLNODE=^HL(772,HLXX,0)
+39 SET HLOGLINK=$PIECE(HLNODE,"^",11)
+40 IF HLOGLINK'>0
Begin DoDot:3
+41 DO STATUS^HLTF0(HLXX,4,"","Logical Link not available")
+42 LOCK -^HL(772,HLXX,0)
End DoDot:3
QUIT
+43 SET HLPARENT=$PIECE(HLNODE,"^",8)
+44 IF HLPARENT'>0!'$GET(^HL(772,HLPARENT,0))
Begin DoDot:3
+45 DO STATUS^HLTF0(HLXX,4,"","Parent Message not available")
+46 LOCK -^HL(772,HLXX,0)
End DoDot:3
QUIT
+47 ;Build message header or batch header
+48 SET HLHDRBLD=$PIECE(^HL(772,HLPARENT,0),U,14)
+49 IF "^B^M^F^"'[(U_HLHDRBLD_U)
Begin DoDot:3
+50 DO STATUS^HLTF0(HLXX,4,"","Message Type (field #772,14) Error")
+51 LOCK -^HL(772,HLXX,0)
End DoDot:3
QUIT
+52 SET HLERROR=""
+53 IF HLHDRBLD="M"
DO HEADER^HLCSHDR(HLXX,.HLERROR)
+54 IF HLHDRBLD'="M"
DO BHSHDR^HLCSHDR(HLXX)
if $EXTRACT(HLHDR(1),1,2)="-1"
SET HLERROR=$PIECE(HLHDR(1),"^",2)
+55 ;If error set status ERROR DURING TRANSMISSION
+56 IF $GET(HLERROR)'=""
DO STATUS^HLTF0(HLXX,4)
LOCK -^HL(772,HLXX,0)
QUIT
+57 SET HLD0=$$ENQUEUE^HLCSQUE(HLOGLINK,"OUT")
+58 ;If error set status ERROR DURING TRANSMISSION
+59 IF +HLD0<0
DO STATUS^HLTF0(HLXX,4)
LOCK -^HL(772,HLXX,0)
QUIT
+60 SET HLD1=$PIECE(HLD0,"^",2)
+61 SET HLD0=+HLD0
+62 ;Move Message Header and Message Text to file 870
+63 DO MERGEOUT^HLTF2(HLPARENT,HLD0,HLD1,"HLHDR")
+64 KILL HLHDR
+65 ;Status in queue to "PENDING"
DO MONITOR^HLCSDR2("P",2,HLD0,HLD1,"OUT")
+66 ;Determine status, default to "Awaiting Ack"
+67 SET HLST1=$$FNDSTAT^HLUTIL3(HLXX)
if 'HLST1
SET HLST1=2
+68 ;Update status
DO STATUS^HLTF0(HLXX,HLST1)
+69 ;Unlock main node of Message Text
LOCK -^HL(772,HLXX,0)
+70 ;Update LAST KNOWN $H (field #.03) for filer
+71 DO SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT")
End DoDot:2
+72 ;P153 START CJM
+73 LOCK -^HLCS(870,HLPTRLL,"OUT","OUTFILER")
+74 ;P153 END CJM
End DoDot:1
if HLEXIT
QUIT
+75 ;Asked to stop
SET ZTSTOP=1
+76 ;Delete entry denoting this filer
DO DELFLR^HLCSUTL1(HLPTRFLR,"OUT")
+77 SET ZTREQ="@"
+78 QUIT
