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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---HLCSOUT   3547     printed  Mar 13, 2025@21:01:30                                                                                                                                                                                                     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