HLCIRN ;SFISC/RJH-Don't Purge and Reprocessing message ;07/28/97 10:14
;;1.6;HEALTH LEVEL SEVEN;**33**;Oct 13, 1995
Q
;
DONTPURG() ; set the DONT PURGE field to 1 in order to prevent the message
; from purging.
; return value : 1 for successfully set the field
; -1 for failure
;
N FLAG
S FLAG=$$SETPURG(1)
Q FLAG
;
TOPURG() ; clear the DONT PURGE field to allow the message to be purged.
; return value : 0 for successfully clear the field
; -1 for failure
;
N FLAG
S FLAG=$$SETPURG(0)
Q FLAG
;
SETPURG(STATUS) ; 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
; HLMTIENS- child message IEN
; 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
. D SETVALUE
. 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
. D SETVALUE
. 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
. D SETVALUE
. S FLAG=STATUS
Q FLAG
;
SETVALUE ; set or clear the DONT PURGE field
L +^HL(772,HLMTIEN)
S ^HL(772,HLMTIEN,2)=STATUS
I $G(HLMTIENS) S ^HL(772,HLMTIENS,2)=STATUS
L -^HL(772,HLMTIEN)
Q
;
REPROC(IEN,RTN) ; reprocessing message
; IEN- either the parent message IEN or the child message IEN
; RTN- the routine, to be Xecuted for processing the message
; return value: 0 for success, -1 for failure
;
N HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT
N HL,HDR,FS,ECH,HLMSA,X,X1,X2
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
S HLMSA=""
I '$G(IEN) Q -1
I '$D(^HL(772,IEN)) Q -1
I $G(RTN)'["" Q -1
S HLMTIEN=$P(^HL(772,IEN,0),"^",8)
Q:'HLMTIEN -1
I HLMTIEN'=IEN S HLMTIENS=IEN
;
S X=0
F S X=$O(^HL(772,HLMTIEN,"IN",X)) Q:X'>0 D
. S X1=$G(^HL(772,HLMTIEN,"IN",X,0))
. Q:"FHS,BHS,MSH,MSA"'[$E(X1,1,3)
. ; If header segment, process it and set HDR equal to it
. I '$D(HDR),"FHS,BHS,MSH"[$E(X1,1,3) D
.. S HDR=X1
.. S (HL("FS"),FS)=$E(HDR,4)
.. S (HL("ECH"),ECH)=$P(HDR,FS,2)
.. S $P(HDR,FS,8)=""
.. I "FHS,BHS"[$E(HDR,1,3) D
... S HL("DTM")=$P(HDR,FS,7)
... S HL("MID")=$P(HDR,FS,11)
... S X2=$P(HDR,FS,9)
... S HL("PID")=$P(X2,$E(ECH),2)
... S HL("MTN")=$P($P(X2,$E(ECH),3),$E(ECH,4))
... S HL("ETN")=$P($P(X2,$E(ECH),3),$E(ECH,4),2)
... S HL("VER")=$P(X2,$E(ECH),4)
... I $P(HDR,FS,10)]"" S HLMSA="MSA"_FS_$P($P(HDR,FS,10),$E(HDR,5),1)_FS_$P(HDR,FS,12)_FS_$P($P(HDR,FS,10),$E(HDR,5),2)
.. I $E(HDR,1,3)="MSH" D
... S HL("DTM")=$P(HDR,FS,7)
... S HL("MID")=$P(HDR,FS,10)
... S HL("PID")=$P(HDR,FS,11)
... S HL("MTN")=$P($P(HDR,FS,9),$E(ECH))
... S HL("ETN")=$P($P(HDR,FS,9),$E(ECH),2)
... S HL("VER")=$P(HDR,FS,12)
... S:$P(HDR,FS,15)]"" HL("ACAT")=$P(HDR,FS,15)
... S:$P(HDR,FS,16)]"" HL("APAT")=$P(HDR,FS,16)
... S:$P(HDR,FS,17)]"" HL("CC")=$P(HDR,FS,17)
. ; If acknowledgement segment, set MSA equal to it
. I $E(X1,1,3)="MSA",$G(HLMSA)="",$E($G(HDR),1,3)="MSH" S HLMSA=X1
Q:'$D(HDR) -1
;
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 STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S($D(HLERR):HLERR,HLRESLT:$P(HLRESLT,"^",2),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:""))
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCIRN 4504 printed Dec 13, 2024@01:56:15 Page 2
HLCIRN ;SFISC/RJH-Don't Purge and Reprocessing message ;07/28/97 10:14
+1 ;;1.6;HEALTH LEVEL SEVEN;**33**;Oct 13, 1995
+2 QUIT
+3 ;
DONTPURG() ; set the DONT PURGE field to 1 in order to prevent the message
+1 ; from purging.
+2 ; return value : 1 for successfully set the field
+3 ; -1 for failure
+4 ;
+5 NEW FLAG
+6 SET FLAG=$$SETPURG(1)
+7 QUIT FLAG
+8 ;
TOPURG() ; clear the DONT PURGE field to allow the message to be purged.
+1 ; return value : 0 for successfully clear the field
+2 ; -1 for failure
+3 ;
+4 NEW FLAG
+5 SET FLAG=$$SETPURG(0)
+6 QUIT FLAG
+7 ;
SETPURG(STATUS) ; to set or to clear the DONT PURGE field
+1 ; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
+2 ; HLMTIEN- parent message IEN
+3 ; HLMTIENS- child message IEN
+4 ; input: 1 to set the DONT PURGE field
+5 ; 0 to clear the DONT PURGE field.
+6 ; return value: 1 means successfully set the DONT PURGE field
+7 ; 0 means successfully clear the DONT PURGE field
+8 ; -1 means fail to set or to clear the field
+9 ;
+10 NEW FLAG
+11 SET FLAG=""
+12 IF (STATUS'=1)&(STATUS'=0)
QUIT -1
+13 IF '$GET(HLMTIEN)
IF '$GET(HLMTIENS)
QUIT -1
+14 ;
+15 ; both HLMTIEN and HLMTIENS are defined
+16 IF $GET(HLMTIEN)
IF $GET(HLMTIENS)
Begin DoDot:1
+17 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+18 IF '$DATA(^HL(772,HLMTIENS))
SET FLAG=-1
QUIT
+19 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIENS,0),"^",8))
SET FLAG=-1
QUIT
+20 DO SETVALUE
+21 SET FLAG=STATUS
End DoDot:1
+22 IF (FLAG=-1)!(FLAG=STATUS)
QUIT FLAG
+23 ;
+24 ; only HLMTIEN(parent message IEN) is defined
+25 IF $GET(HLMTIEN)
Begin DoDot:1
+26 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+27 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIEN,0),"^",8))
SET FLAG=-1
QUIT
+28 DO SETVALUE
+29 SET FLAG=STATUS
End DoDot:1
+30 IF (FLAG=-1)!(FLAG=STATUS)
QUIT FLAG
+31 ;
+32 ; only HLMTIENS(child message IEN) is defined
+33 IF $GET(HLMTIENS)
Begin DoDot:1
+34 IF '$DATA(^HL(772,HLMTIENS))
SET FLAG=-1
QUIT
+35 SET HLMTIEN=$PIECE(^HL(772,HLMTIENS,0),"^",8)
+36 IF 'HLMTIEN
SET FLAG=-1
QUIT
+37 IF '$DATA(^HL(772,HLMTIEN))
SET FLAG=-1
QUIT
+38 IF (HLMTIEN'=$PIECE(^HL(772,HLMTIEN,0),"^",8))
SET FLAG=-1
QUIT
+39 DO SETVALUE
+40 SET FLAG=STATUS
End DoDot:1
+41 QUIT FLAG
+42 ;
SETVALUE ; set or clear the DONT PURGE field
+1 LOCK +^HL(772,HLMTIEN)
+2 SET ^HL(772,HLMTIEN,2)=STATUS
+3 IF $GET(HLMTIENS)
SET ^HL(772,HLMTIENS,2)=STATUS
+4 LOCK -^HL(772,HLMTIEN)
+5 QUIT
+6 ;
REPROC(IEN,RTN) ; reprocessing message
+1 ; IEN- either the parent message IEN or the child message IEN
+2 ; RTN- the routine, to be Xecuted for processing the message
+3 ; return value: 0 for success, -1 for failure
+4 ;
+5 NEW HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT
+6 NEW HL,HDR,FS,ECH,HLMSA,X,X1,X2
+7 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+8 SET HLMSA=""
+9 IF '$GET(IEN)
QUIT -1
+10 IF '$DATA(^HL(772,IEN))
QUIT -1
+11 IF $GET(RTN)'[""
QUIT -1
+12 SET HLMTIEN=$PIECE(^HL(772,IEN,0),"^",8)
+13 if 'HLMTIEN
QUIT -1
+14 IF HLMTIEN'=IEN
SET HLMTIENS=IEN
+15 ;
+16 SET X=0
+17 FOR
SET X=$ORDER(^HL(772,HLMTIEN,"IN",X))
if X'>0
QUIT
Begin DoDot:1
+18 SET X1=$GET(^HL(772,HLMTIEN,"IN",X,0))
+19 if "FHS,BHS,MSH,MSA"'[$EXTRACT(X1,1,3)
QUIT
+20 ; If header segment, process it and set HDR equal to it
+21 IF '$DATA(HDR)
IF "FHS,BHS,MSH"[$EXTRACT(X1,1,3)
Begin DoDot:2
+22 SET HDR=X1
+23 SET (HL("FS"),FS)=$EXTRACT(HDR,4)
+24 SET (HL("ECH"),ECH)=$PIECE(HDR,FS,2)
+25 SET $PIECE(HDR,FS,8)=""
+26 IF "FHS,BHS"[$EXTRACT(HDR,1,3)
Begin DoDot:3
+27 SET HL("DTM")=$PIECE(HDR,FS,7)
+28 SET HL("MID")=$PIECE(HDR,FS,11)
+29 SET X2=$PIECE(HDR,FS,9)
+30 SET HL("PID")=$PIECE(X2,$EXTRACT(ECH),2)
+31 SET HL("MTN")=$PIECE($PIECE(X2,$EXTRACT(ECH),3),$EXTRACT(ECH,4))
+32 SET HL("ETN")=$PIECE($PIECE(X2,$EXTRACT(ECH),3),$EXTRACT(ECH,4),2)
+33 SET HL("VER")=$PIECE(X2,$EXTRACT(ECH),4)
+34 IF $PIECE(HDR,FS,10)]""
SET HLMSA="MSA"_FS_$PIECE($PIECE(HDR,FS,10),$EXTRACT(HDR,5),1)_FS_$PIECE(HDR,FS,12)_FS_$PIECE($PIECE(HDR,FS,10),$EXTRACT(HDR,5),2)
End DoDot:3
+35 IF $EXTRACT(HDR,1,3)="MSH"
Begin DoDot:3
+36 SET HL("DTM")=$PIECE(HDR,FS,7)
+37 SET HL("MID")=$PIECE(HDR,FS,10)
+38 SET HL("PID")=$PIECE(HDR,FS,11)
+39 SET HL("MTN")=$PIECE($PIECE(HDR,FS,9),$EXTRACT(ECH))
+40 SET HL("ETN")=$PIECE($PIECE(HDR,FS,9),$EXTRACT(ECH),2)
+41 SET HL("VER")=$PIECE(HDR,FS,12)
+42 if $PIECE(HDR,FS,15)]""
SET HL("ACAT")=$PIECE(HDR,FS,15)
+43 if $PIECE(HDR,FS,16)]""
SET HL("APAT")=$PIECE(HDR,FS,16)
+44 if $PIECE(HDR,FS,17)]""
SET HL("CC")=$PIECE(HDR,FS,17)
End DoDot:3
End DoDot:2
+45 ; If acknowledgement segment, set MSA equal to it
+46 IF $EXTRACT(X1,1,3)="MSA"
IF $GET(HLMSA)=""
IF $EXTRACT($GET(HDR),1,3)="MSH"
SET HLMSA=X1
End DoDot:1
+47 if '$DATA(HDR)
QUIT -1
+48 ;
+49 IF RTN["D "
XECUTE RTN
+50 IF RTN'["D "
Begin DoDot:1
+51 IF RTN["^"
XECUTE "D "_RTN
+52 IF RTN'["^"
XECUTE "D ^"_RTN
End DoDot:1
+53 SET HLRESLT=0
if ($DATA(HLERR))
SET HLRESLT="9^"_$GET(^HL(771.7,9,0))
+54 ; update the status of child message
+55 IF $GET(HLMTIENS)
DO STATUS^HLTF0(HLMTIENS,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT($DATA(HLERR):HLERR,HLRESLT:$PIECE(HLRESLT,"^",2),1:""))
+56 ; update the status of parent message
+57 DO STATUS^HLTF0(HLMTIEN,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT(HLRESLT:$PIECE(HLRESLT,"^",2),1:""))
+58 QUIT 0
