HLUTIL4 ;OIFO-O/RJH-Don't Purge & Reprocessing for HLLP & MAILMAN ;09/02/2008 16:54
;;1.6;HEALTH LEVEL SEVEN;**142**;Oct 13, 1995;Build 17
;Per VHA Directive 2004-038, this routine should not be modified.
; Don't purge and reprocessing functions for HLLP and MailMan
; messages only
Q
;
NOPURG() ; for HLLP and MailMan messages only
; set the DON'T PURGE field to 1 in order to prevent the message
; from purging.
; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
; HLMTIEN- parent message IEN of file #772
; HLMTIENS- child message IEN of file #772
; return value : 1 for successfully set the field
; -1 for failure
;
N FLAG
S FLAG=$$SETPFLAG(1)
Q FLAG
;
PURG() ; for HLLP and MailMan messages only
; clear the DON'T PURGE field to allow the message to be purged.
; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
; HLMTIEN- parent message IEN of file #772
; HLMTIENS- child message IEN of file #772
; return value : 0 for successfully clear the field
; -1 for failure
;
N FLAG
S FLAG=$$SETPFLAG(0)
Q FLAG
;
SETPFLAG(STATUS) ; for HLLP and MailMan messages only
; to set or to clear the DONT PURGE field
; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
; HLMTIEN- parent message IEN of file #772
; HLMTIENS- child message IEN of file #772
; input: 1 to set the DONT PURGE field
; 0 to clear the DONT PURGE field.
; return value: 1 means successfully set the DONT PURGE field
; 0 means successfully clear the DONT PURGE field
; -1 means fail to set or to clear the field
;
N FLAG
S FLAG=""
I (STATUS'=1),(STATUS'=0) Q -1
I '$G(HLMTIEN),'$G(HLMTIENS) Q -1
;
; both HLMTIEN and HLMTIENS are defined
I $G(HLMTIEN),$G(HLMTIENS) D
. I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
. I '$D(^HL(772,HLMTIENS)) S FLAG=-1 Q
. I (HLMTIEN'=$P(^HL(772,HLMTIENS,0),"^",8)) S FLAG=-1 Q
. L +^HL(772,HLMTIEN):300
. E S FLAG=-1 Q
. L +^HL(772,HLMTIENS):300
. E L -^HL(772,HLMTIEN) S FLAG=-1 Q
. D SETVALUE
. L -^HL(772,HLMTIENS)
. L -^HL(772,HLMTIEN)
. S FLAG=STATUS
I (FLAG=-1)!(FLAG=STATUS) Q FLAG
;
; only HLMTIEN(parent message IEN) is defined
I $G(HLMTIEN) D
. I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
. I (HLMTIEN'=$P(^HL(772,HLMTIEN,0),"^",8)) S FLAG=-1 Q
. L +^HL(772,HLMTIEN):300
. E S FLAG=-1 Q
. D SETVALUE
. L -^HL(772,HLMTIEN)
. S FLAG=STATUS
I (FLAG=-1)!(FLAG=STATUS) Q FLAG
;
; only HLMTIENS(child message IEN) is defined
I $G(HLMTIENS) D
. I '$D(^HL(772,HLMTIENS)) S FLAG=-1 Q
. S HLMTIEN=$P(^HL(772,HLMTIENS,0),"^",8)
. I 'HLMTIEN S FLAG=-1 Q
. I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
. I (HLMTIEN'=$P(^HL(772,HLMTIEN,0),"^",8)) S FLAG=-1 Q
. L +^HL(772,HLMTIEN):300
. E S FLAG=-1 Q
. L +^HL(772,HLMTIENS):300
. E L -^HL(772,HLMTIEN) S FLAG=-1 Q
. D SETVALUE
. L -^HL(772,HLMTIENS)
. L -^HL(772,HLMTIEN)
. S FLAG=STATUS
Q FLAG
;
SETVALUE ; set or clear the DONT PURGE field
S ^HL(772,HLMTIEN,2)=STATUS
I $G(HLMTIENS) S ^HL(772,HLMTIENS,2)=STATUS
Q
;
PROC(IEN,RTN) ; reprocessing HLLP or MailMan message
; IEN- either the parent message IEN or the child message IEN
; of file #772
; RTN- the routine, to be Xecuted for processing the message
;
; return value:
; "0^reprocessing is successful" for success.
; "-1^<error text>" for failure.
;
N HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT
N HL,HDR,HLMSA,X,X1
N HLI,HLTMP,MSAFLAG
;
Q:'$G(IEN) "-1^not a valid IEN"
I $G(RTN)']"" Q "-1^reprocessing routine is misssing"
;
S HLTMP=$G(^HL(772,IEN,0))
I HLTMP']"" Q "-1^not a valid entry"
I $P(HLTMP,"^",4)'="I" Q "-1^not an incoming message"
;
; get parent message ien
S HLMTIEN=$P(HLTMP,"^",8)
;
; if IEN is child, define HLMTIENS as child IEN
I HLMTIEN,(HLMTIEN'=IEN) S HLMTIENS=IEN
;
; if IEN is parent, find child ien, HLMTIENS
I '$G(HLMTIENS) D
. S HLMTIEN=IEN
. S HLMTIENS=+$O(^HL(772,"AI",IEN,IEN))
;
S HLMSA=""
S MSAFLAG=0
S X=0
F HLI=1:1:6 S X=$O(^HL(772,HLMTIEN,"IN",X)) Q:(X'>0)!(MSAFLAG) D
. S X1=$G(^HL(772,HLMTIEN,"IN",X,0))
. Q:"FHS,BHS,MSH,MSA"'[$E(X1,1,3)
. ; If header segment, define HDR for header
. I '$D(HDR),"FHS,BHS,MSH"[$E(X1,1,3) D Q
.. S HDR=X1
. ; variable HLMSA is used to save the MSA segment data of MSH msg,
. ; HLMSA is not for saving the MSA segment data of BHS msg
. ; the MSA segment data of BHS msg will be set in CHK^HLTPCK1
. I $E(X1,1,3)="MSA",$G(HLMSA)="",$E($G(HDR),1,3)="MSH" D
.. S HLMSA=X1
.. S MSAFLAG=1
;
Q:'$D(HDR) "-1^missing message header segment"
;
;Validate message header
D CHK^HLTPCK1(HDR,.HL,$S(HLMSA]"":$P(HLMSA,$E(HDR,4),2,4),1:""))
;
I $G(HL)]"" Q "-1^"_HL
;
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
;
I RTN["D " X RTN
I RTN'["D " D
. I RTN["^" X "D "_RTN
. I RTN'["^" X "D ^"_RTN
;
S HLRESLT=0
S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0))
;
; update the status of child message
I $G(HLMTIENS) D
. D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S($D(HLERR):HLERR,HLRESLT:$P(HLRESLT,"^",2),1:""),,1)
;
; update the status of parent message
D STATUS^HLTF0(HLMTIEN,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,"^",2),1:""),,1)
;
Q "0^reprocessing is successful"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUTIL4 5422 printed Sep 23, 2025@19:36:37 Page 2
HLUTIL4 ;OIFO-O/RJH-Don't Purge & Reprocessing for HLLP & MAILMAN ;09/02/2008 16:54
+1 ;;1.6;HEALTH LEVEL SEVEN;**142**;Oct 13, 1995;Build 17
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Don't purge and reprocessing functions for HLLP and MailMan
+4 ; messages only
+5 QUIT
+6 ;
NOPURG() ; for HLLP and MailMan messages only
+1 ; set the DON'T PURGE field to 1 in order to prevent the message
+2 ; from purging.
+3 ; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
+4 ; HLMTIEN- parent message IEN of file #772
+5 ; HLMTIENS- child message IEN of file #772
+6 ; return value : 1 for successfully set the field
+7 ; -1 for failure
+8 ;
+9 NEW FLAG
+10 SET FLAG=$$SETPFLAG(1)
+11 QUIT FLAG
+12 ;
PURG() ; for HLLP and MailMan messages only
+1 ; clear the DON'T PURGE field to allow the message to be purged.
+2 ; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
+3 ; HLMTIEN- parent message IEN of file #772
+4 ; HLMTIENS- child message IEN of file #772
+5 ; return value : 0 for successfully clear the field
+6 ; -1 for failure
+7 ;
+8 NEW FLAG
+9 SET FLAG=$$SETPFLAG(0)
+10 QUIT FLAG
+11 ;
SETPFLAG(STATUS) ; for HLLP and MailMan messages only
+1 ; to set or to clear the DONT PURGE field
+2 ; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
+3 ; HLMTIEN- parent message IEN of file #772
+4 ; HLMTIENS- child message IEN of file #772
+5 ; input: 1 to set the DONT PURGE field
+6 ; 0 to clear the DONT PURGE field.
+7 ; return value: 1 means successfully set the DONT PURGE field
+8 ; 0 means successfully clear the DONT PURGE field
+9 ; -1 means fail to set or to clear the field
+10 ;
+11 NEW FLAG
+12 SET FLAG=""
+13 IF (STATUS'=1)
IF (STATUS'=0)
QUIT -1
+14 IF '$GET(HLMTIEN)
IF '$GET(HLMTIENS)
QUIT -1
+15 ;
+16 ; both HLMTIEN and HLMTIENS are defined
+17 IF $GET(HLMTIEN)
IF $GET(HLMTIENS)
Begin DoDot:1
+18 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+19 IF '$DATA(^HL(772,HLMTIENS))
SET FLAG=-1
QUIT
+20 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIENS,0),"^",8))
SET FLAG=-1
QUIT
+21 LOCK +^HL(772,HLMTIEN):300
+22 IF '$TEST
SET FLAG=-1
QUIT
+23 LOCK +^HL(772,HLMTIENS):300
+24 IF '$TEST
LOCK -^HL(772,HLMTIEN)
SET FLAG=-1
QUIT
+25 DO SETVALUE
+26 LOCK -^HL(772,HLMTIENS)
+27 LOCK -^HL(772,HLMTIEN)
+28 SET FLAG=STATUS
End DoDot:1
+29 IF (FLAG=-1)!(FLAG=STATUS)
QUIT FLAG
+30 ;
+31 ; only HLMTIEN(parent message IEN) is defined
+32 IF $GET(HLMTIEN)
Begin DoDot:1
+33 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+34 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIEN,0),"^",8))
SET FLAG=-1
QUIT
+35 LOCK +^HL(772,HLMTIEN):300
+36 IF '$TEST
SET FLAG=-1
QUIT
+37 DO SETVALUE
+38 LOCK -^HL(772,HLMTIEN)
+39 SET FLAG=STATUS
End DoDot:1
+40 IF (FLAG=-1)!(FLAG=STATUS)
QUIT FLAG
+41 ;
+42 ; only HLMTIENS(child message IEN) is defined
+43 IF $GET(HLMTIENS)
Begin DoDot:1
+44 IF '$DATA(^HL(772,HLMTIENS))
SET FLAG=-1
QUIT
+45 SET HLMTIEN=$PIECE(^HL(772,HLMTIENS,0),"^",8)
+46 IF 'HLMTIEN
SET FLAG=-1
QUIT
+47 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+48 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIEN,0),"^",8))
SET FLAG=-1
QUIT
+49 LOCK +^HL(772,HLMTIEN):300
+50 IF '$TEST
SET FLAG=-1
QUIT
+51 LOCK +^HL(772,HLMTIENS):300
+52 IF '$TEST
LOCK -^HL(772,HLMTIEN)
SET FLAG=-1
QUIT
+53 DO SETVALUE
+54 LOCK -^HL(772,HLMTIENS)
+55 LOCK -^HL(772,HLMTIEN)
+56 SET FLAG=STATUS
End DoDot:1
+57 QUIT FLAG
+58 ;
SETVALUE ; set or clear the DONT PURGE field
+1 SET ^HL(772,HLMTIEN,2)=STATUS
+2 IF $GET(HLMTIENS)
SET ^HL(772,HLMTIENS,2)=STATUS
+3 QUIT
+4 ;
PROC(IEN,RTN) ; reprocessing HLLP or MailMan message
+1 ; IEN- either the parent message IEN or the child message IEN
+2 ; of file #772
+3 ; RTN- the routine, to be Xecuted for processing the message
+4 ;
+5 ; return value:
+6 ; "0^reprocessing is successful" for success.
+7 ; "-1^<error text>" for failure.
+8 ;
+9 NEW HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT
+10 NEW HL,HDR,HLMSA,X,X1
+11 NEW HLI,HLTMP,MSAFLAG
+12 ;
+13 if '$GET(IEN)
QUIT "-1^not a valid IEN"
+14 IF $GET(RTN)']""
QUIT "-1^reprocessing routine is misssing"
+15 ;
+16 SET HLTMP=$GET(^HL(772,IEN,0))
+17 IF HLTMP']""
QUIT "-1^not a valid entry"
+18 IF $PIECE(HLTMP,"^",4)'="I"
QUIT "-1^not an incoming message"
+19 ;
+20 ; get parent message ien
+21 SET HLMTIEN=$PIECE(HLTMP,"^",8)
+22 ;
+23 ; if IEN is child, define HLMTIENS as child IEN
+24 IF HLMTIEN
IF (HLMTIEN'=IEN)
SET HLMTIENS=IEN
+25 ;
+26 ; if IEN is parent, find child ien, HLMTIENS
+27 IF '$GET(HLMTIENS)
Begin DoDot:1
+28 SET HLMTIEN=IEN
+29 SET HLMTIENS=+$ORDER(^HL(772,"AI",IEN,IEN))
End DoDot:1
+30 ;
+31 SET HLMSA=""
+32 SET MSAFLAG=0
+33 SET X=0
+34 FOR HLI=1:1:6
SET X=$ORDER(^HL(772,HLMTIEN,"IN",X))
if (X'>0)!(MSAFLAG)
QUIT
Begin DoDot:1
+35 SET X1=$GET(^HL(772,HLMTIEN,"IN",X,0))
+36 if "FHS,BHS,MSH,MSA"'[$EXTRACT(X1,1,3)
QUIT
+37 ; If header segment, define HDR for header
+38 IF '$DATA(HDR)
IF "FHS,BHS,MSH"[$EXTRACT(X1,1,3)
Begin DoDot:2
+39 SET HDR=X1
End DoDot:2
QUIT
+40 ; variable HLMSA is used to save the MSA segment data of MSH msg,
+41 ; HLMSA is not for saving the MSA segment data of BHS msg
+42 ; the MSA segment data of BHS msg will be set in CHK^HLTPCK1
+43 IF $EXTRACT(X1,1,3)="MSA"
IF $GET(HLMSA)=""
IF $EXTRACT($GET(HDR),1,3)="MSH"
Begin DoDot:2
+44 SET HLMSA=X1
+45 SET MSAFLAG=1
End DoDot:2
End DoDot:1
+46 ;
+47 if '$DATA(HDR)
QUIT "-1^missing message header segment"
+48 ;
+49 ;Validate message header
+50 DO CHK^HLTPCK1(HDR,.HL,$SELECT(HLMSA]"":$PIECE(HLMSA,$EXTRACT(HDR,4),2,4),1:""))
+51 ;
+52 IF $GET(HL)]""
QUIT "-1^"_HL
+53 ;
+54 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+55 ;
+56 IF RTN["D "
XECUTE RTN
+57 IF RTN'["D "
Begin DoDot:1
+58 IF RTN["^"
XECUTE "D "_RTN
+59 IF RTN'["^"
XECUTE "D ^"_RTN
End DoDot:1
+60 ;
+61 SET HLRESLT=0
+62 if ($DATA(HLERR))
SET HLRESLT="9^"_$GET(^HL(771.7,9,0))
+63 ;
+64 ; update the status of child message
+65 IF $GET(HLMTIENS)
Begin DoDot:1
+66 DO STATUS^HLTF0(HLMTIENS,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT($DATA(HLERR):HLERR,HLRESLT:$PIECE(HLRESLT,"^",2),1:""),,1)
End DoDot:1
+67 ;
+68 ; update the status of parent message
+69 DO STATUS^HLTF0(HLMTIEN,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT(HLRESLT:$PIECE(HLRESLT,"^",2),1:""),,1)
+70 ;
+71 QUIT "0^reprocessing is successful"
+72 ;
