- 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 Mar 13, 2025@21:00:56 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
