HLCSOUT.m

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