PRCVRCG ;ISC-SF/GJW; Receive messages ; 5/24/05 10:56am
;;5.1;IFCAP;**81**;Oct. 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
SUB(PRCVACT) ;
N PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE
N PRCVMSG,PRCVMID,PRCVSEG,X,PRCVEVN,PRCVEVT,PRCVSTAT,PRCVCP
N HLQUIT,HLNODE,X1,MYERR,MYSEQ
S PRCVFS=$G(HL("FS"))
S PRCVCS=$E($G(HL("ECH")),1)
S PRCVRS=$E($G(HL("ECH")),2)
S PRCVES=$E($G(HL("ECH")),3)
S PRCVSS=$E($G(HL("ECH")),4)
S (HLQUIT,HLNODE)=0
;Note: the following variable is KILLed to avoid certain
;problems with $$REPROC^HLUTIL
K HLDONE1
S PRCVMSG=$G(HL("MTN"))
S PRCVMID=$G(HL("MID"))
I ((PRCVACT=1)&(PRCVMSG'="QSB"))!((PRCVACT=2)&(PRCVMSG'="QCN")) D Q
.;Error: wrong message type
.S MYERR("HL_CODE")="HL200"
.S MYERR("HL_TEXT")="Unsupported Message Type"
.S MYSEQ("FIELD_POS")=9 ;message type
.S MYSEQ("SEG_POS")=1
.D ACK("AR",PRCVMID,"MSH",.MYSEQ,.MYERR)
X HLNEXT I HLQUIT'>0 D Q
.;Error: MSH segment not found
.S MYERR("HL_CODE")="HL100"
.S MYERR("HL_TEXT")="Segment Sequence Error"
.S MYSEQ("SEG_POS")=1
.D ACK("AE",$G(PRCVMID),"MSH",1,.MYERR)
X HLNEXT I HLQUIT'>0 D Q
.;Error: no segments after MSH
S PRCVSEG=$$FLD^HLCSUTL(.HLNODE,1)
I ((PRCVACT=1)&(PRCVSEG'="QPD")) D Q
.;Error: QPD segment expected
.S MYERR("HL_CODE")="HL100"
.S MYERR("HL_TEXT")="Segment Sequence Error"
.S MYSEQ("SEG_POS")=2
.D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
I ((PRCVACT=2)&(PRCVSEG'="QID")) D Q
.;Error: QID segment expected
.S MYERR("HL_CODE")="HL100"
.S MYERR("HL_TEXT")="Segment Sequence Error"
.S MYSEQ("SEG_POS")=2
.D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
S X=$$FLD^HLCSUTL(.HLNODE,$S(PRCVACT=1:2,PRCVACT=2:3,1:999))
I (X="") D Q
.S MYERR("HL_CODE")="HL101"
.S MYERR("HL_TEXT")="Required field missing"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":1,PRCVSEG="QID":2,1:"")
.D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
S PRCVEVN=$P(X,PRCVCS,1)
S PRCVEVT=$P(X,PRCVCS,2)
I PRCVEVN'="Q16" D Q
.;Error: wrong event code
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=1
.S MYSEQ("FIELD_POS")=$S(PRCVACT=1:2,PRCVACT=1:2)
.S MYSEQ("CMP_POS")=1
.D ACK("AR",PRCVMID,$S(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
I PRCVEVT'="Fund_Subscription" D Q
.;Error: wrong event
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=$S(PRCVACT=1:2,PRCVACT=1:2)
.S MYSEQ("CMP_POS")=2
.D ACK("AR",PRCVMID,$S(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
I ((PRCVACT=2)&(PRCVEVT'="Fund_Subscription")) D Q
.;Error: wrong event
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=2
.S MYSEQ("CMP_POS")=2
.D ACK("AR",PRCVMID,"QID",.MYSEQ,.MYERR)
S X=$$FLD^HLCSUTL(.HLNODE,$S(PRCVACT=1:3,PRCVACT=2:2,1:999))
I (X="") D Q
.S MYERR("HL_CODE")="HL101"
.S MYERR("HL_TEXT")="Required field missing"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":3,PRCVSEG="QID":2,1:"")
.D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
S PRCVSTAT=$P(X,"-",1)
S PRCVCP=+$P(X,"-",2)
I '$D(^PRC(420,PRCVSTAT,0)) D Q
.;invalid station number
.S MYERR("HL_CODE")="HL204"
.S MYERR("HL_TEXT")="Unknown key identfier"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
.D ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
I '$D(^PRC(420,PRCVSTAT,1,PRCVCP,0)) D Q
.;invalid station/FCP pair
.S MYERR("HL_CODE")="HL204"
.S MYERR("HL_TEXT")="Unknown key identfier"
.S MYSEQ("SEG_POS")=2
.S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
.D ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
G:PRCVACT=2 DEL
S X1=$$ADDSUB^PRCVSUB(PRCVSTAT,PRCVCP,1)
I $P(X1,"^",1)["?" D Q
.;Duplicate
.;S MYERR("SEVERITY")="W"
.D ACK("AA",PRCVMID)
I $P(X1,"^",1)="E" D Q
.;Fileman generated error
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=2
.D ACK("AR",PRCVSEG,.MYSEQ,.MYERR)
G:PRCVACT=2 DONE ;end of message
X HLNEXT I HLQUIT'>0 D Q
.;Error: RCP segment expected
.S MYERR("HL_CODE")="HL100"
.S MYERR("HL_TEXT")="Segment sequence error"
.S MYSEQ("SEG_POS")=3
.D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
G DONE
DEL ;
S X1=$$DELSUB^PRCVSUB(PRCVSTAT,+PRCVCP,1)
I X1["E" D Q
.;Error during Fileman call
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=1
.S MYSEQ("FIELD_POS")=1
.D ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
I X1'["@" D Q
.;Deletion error
.S MYERR("HL_CODE")="HL207"
.S MYERR("HL_TEXT")="Application internal error"
.S MYSEQ("SEG_POS")=1
.S MYSEQ("FIELD_POS")=1
.D ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
DONE ;
;Success!
D ACK("AA",PRCVMID)
Q
;
ACK(PRCVSTAT,PRCVOMID,PRCVSID,PRCVSEQ,PRCVERR) ;
N HLA,ERR,I,SEV,PRCVEID,PRCVAPP,PRCVEIDS,PRCVRES
;Make sure the parameters are defined
S PRCVSTAT=$G(PRCVSTAT),PRCVOMID=$G(PRCVOMID),PRCVSID=$G(PRCVSID)
S HLA("HLA",1)="MSA"_PRCVFS_$G(PRCVSTAT)_PRCVFS_$G(PRCVOMID)
S SEV=$S($D(PRCVERR("SEVERITY")):$G(PRCVERR("SEVERITY")),1:"E")
;set some variables
S PRCVEID=$G(HL("EID"))
S PRCVEIDS=$G(HL("EIDS"))
;S PRCVAPP=$$FIND1^DIC(771,,"MX","PRCV_DYNAMED")
Q:(($L(PRCVEID)=0)!($L($G(HLMTIENS))=0)!($L(PRCVEIDS)=0))
S PRCVRES=""
S:PRCVSTAT="AA" HLA("HLA",1)=HLA("HLA",1)_PRCVFS_"OK"
D:$L(PRCVSID)>0
.S ERR="ERR"_PRCVFS_PRCVFS_PRCVSID_PRCVCS_$G(PRCVSEQ("SEG_POS"))
.S ERR=ERR_PRCVCS_$G(PRCVSEQ("FIELD_POS"))_PRCVFS
.;S ERR=ERR_PRCVCS_$G(PRCVSEQ("FIELD_POS"))_PRCVCS
.;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVCS_$G(PRCVSEQ("CMP_POS"))
.;S ERR=ERR_PRCVCS_$G(PRCVSEQ("SUBCMP_POS"))_PRCVFS
.;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVFS
.S ERR=ERR_$G(PRCVERR("HL_CODE"))_PRCVCS_$G(PRCVERR("HL_TEXT"))
.S ERR=ERR_PRCVCS_"0357"_PRCVFS_SEV_PRCVFS
.I $D(PRCVERR("APP",1)) D
..;application error(s)
..S ERR=ERR_$G(PRCVERR("APP",1,"CODE"))_PRCVCS_$G(PRCVERR("APP",1,"TEXT"))
..S I=1
..F S I=$O(PRCVERR("APP",I)) Q:((I="")!(I>10)) D
...S ERR=ERR_PRCVRS
...S ERR=ERR_$G(PRCVERR("APP",I,"CODE"))_PRCVCS
...S ERR=ERR_$G(PRCVERR("APP",I,"TEXT"))
.S HLA("HLA",2)=ERR
D GENACK^HLMA1(PRCVEID,$G(HLMTIENS),PRCVEIDS,"LM",1,.PRCVRES)
Q
;
PUBACK ;
N PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE,X
N ATYPE,OMID,SEQ,ERR,I,X1,ECNT,RFAC
S PRCVFS=$G(HL("FS"))
S PRCVCS=$E($G(HL("ECH")),1)
S PRCVRS=$E($G(HL("ECH")),2)
S PRCVES=$E($G(HL("ECH")),3)
S PRCVSS=$E($G(HL("ECH")),4)
S (HLQUIT,HLNODE)=0
;Note: the following variable is KILLed to avoid certain
;problems with $$REPROC^HLUTIL
K HLDONE1
S PRCVMSG=$G(HL("MTN"))
S PRCVMID=$G(HL("MID"))
Q:HL("MTN")'="MFK"
X HLNEXT ;read MSH
I HLQUIT'>0 Q
S X=$$FLD^HLCSUTL(.HLNODE,1)
Q:X'="MSH"
S RFAC=$P($$FLD^HLCSUTL(.HLNODE,6),PRCVCS,1)
X HLNEXT ;read MSA
I HLQUIT'>0 Q
S X=$$FLD^HLCSUTL(.HLNODE,1)
Q:X'="MSA"
S ATYPE=$$FLD^HLCSUTL(.HLNODE,2)
;No need to go further
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVRCG 7119 printed Apr 09, 2024@21:14:48 Page 2
PRCVRCG ;ISC-SF/GJW; Receive messages ; 5/24/05 10:56am
+1 ;;5.1;IFCAP;**81**;Oct. 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
SUB(PRCVACT) ;
+1 NEW PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE
+2 NEW PRCVMSG,PRCVMID,PRCVSEG,X,PRCVEVN,PRCVEVT,PRCVSTAT,PRCVCP
+3 NEW HLQUIT,HLNODE,X1,MYERR,MYSEQ
+4 SET PRCVFS=$GET(HL("FS"))
+5 SET PRCVCS=$EXTRACT($GET(HL("ECH")),1)
+6 SET PRCVRS=$EXTRACT($GET(HL("ECH")),2)
+7 SET PRCVES=$EXTRACT($GET(HL("ECH")),3)
+8 SET PRCVSS=$EXTRACT($GET(HL("ECH")),4)
+9 SET (HLQUIT,HLNODE)=0
+10 ;Note: the following variable is KILLed to avoid certain
+11 ;problems with $$REPROC^HLUTIL
+12 KILL HLDONE1
+13 SET PRCVMSG=$GET(HL("MTN"))
+14 SET PRCVMID=$GET(HL("MID"))
+15 IF ((PRCVACT=1)&(PRCVMSG'="QSB"))!((PRCVACT=2)&(PRCVMSG'="QCN"))
Begin DoDot:1
+16 ;Error: wrong message type
+17 SET MYERR("HL_CODE")="HL200"
+18 SET MYERR("HL_TEXT")="Unsupported Message Type"
+19 ;message type
SET MYSEQ("FIELD_POS")=9
+20 SET MYSEQ("SEG_POS")=1
+21 DO ACK("AR",PRCVMID,"MSH",.MYSEQ,.MYERR)
End DoDot:1
QUIT
+22 XECUTE HLNEXT
IF HLQUIT'>0
Begin DoDot:1
+23 ;Error: MSH segment not found
+24 SET MYERR("HL_CODE")="HL100"
+25 SET MYERR("HL_TEXT")="Segment Sequence Error"
+26 SET MYSEQ("SEG_POS")=1
+27 DO ACK("AE",$GET(PRCVMID),"MSH",1,.MYERR)
End DoDot:1
QUIT
+28 XECUTE HLNEXT
IF HLQUIT'>0
Begin DoDot:1
+29 ;Error: no segments after MSH
End DoDot:1
QUIT
+30 SET PRCVSEG=$$FLD^HLCSUTL(.HLNODE,1)
+31 IF ((PRCVACT=1)&(PRCVSEG'="QPD"))
Begin DoDot:1
+32 ;Error: QPD segment expected
+33 SET MYERR("HL_CODE")="HL100"
+34 SET MYERR("HL_TEXT")="Segment Sequence Error"
+35 SET MYSEQ("SEG_POS")=2
+36 DO ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+37 IF ((PRCVACT=2)&(PRCVSEG'="QID"))
Begin DoDot:1
+38 ;Error: QID segment expected
+39 SET MYERR("HL_CODE")="HL100"
+40 SET MYERR("HL_TEXT")="Segment Sequence Error"
+41 SET MYSEQ("SEG_POS")=2
+42 DO ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+43 SET X=$$FLD^HLCSUTL(.HLNODE,$SELECT(PRCVACT=1:2,PRCVACT=2:3,1:999))
+44 IF (X="")
Begin DoDot:1
+45 SET MYERR("HL_CODE")="HL101"
+46 SET MYERR("HL_TEXT")="Required field missing"
+47 SET MYSEQ("SEG_POS")=2
+48 SET MYSEQ("FIELD_POS")=$SELECT(PRCVSEG="QPD":1,PRCVSEG="QID":2,1:"")
+49 DO ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+50 SET PRCVEVN=$PIECE(X,PRCVCS,1)
+51 SET PRCVEVT=$PIECE(X,PRCVCS,2)
+52 IF PRCVEVN'="Q16"
Begin DoDot:1
+53 ;Error: wrong event code
+54 SET MYERR("HL_CODE")="HL207"
+55 SET MYERR("HL_TEXT")="Application internal error"
+56 SET MYSEQ("SEG_POS")=1
+57 SET MYSEQ("FIELD_POS")=$SELECT(PRCVACT=1:2,PRCVACT=1:2)
+58 SET MYSEQ("CMP_POS")=1
+59 DO ACK("AR",PRCVMID,$SELECT(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
End DoDot:1
QUIT
+60 IF PRCVEVT'="Fund_Subscription"
Begin DoDot:1
+61 ;Error: wrong event
+62 SET MYERR("HL_CODE")="HL207"
+63 SET MYERR("HL_TEXT")="Application internal error"
+64 SET MYSEQ("SEG_POS")=2
+65 SET MYSEQ("FIELD_POS")=$SELECT(PRCVACT=1:2,PRCVACT=1:2)
+66 SET MYSEQ("CMP_POS")=2
+67 DO ACK("AR",PRCVMID,$SELECT(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
End DoDot:1
QUIT
+68 IF ((PRCVACT=2)&(PRCVEVT'="Fund_Subscription"))
Begin DoDot:1
+69 ;Error: wrong event
+70 SET MYERR("HL_CODE")="HL207"
+71 SET MYERR("HL_TEXT")="Application internal error"
+72 SET MYSEQ("SEG_POS")=2
+73 SET MYSEQ("FIELD_POS")=2
+74 SET MYSEQ("CMP_POS")=2
+75 DO ACK("AR",PRCVMID,"QID",.MYSEQ,.MYERR)
End DoDot:1
QUIT
+76 SET X=$$FLD^HLCSUTL(.HLNODE,$SELECT(PRCVACT=1:3,PRCVACT=2:2,1:999))
+77 IF (X="")
Begin DoDot:1
+78 SET MYERR("HL_CODE")="HL101"
+79 SET MYERR("HL_TEXT")="Required field missing"
+80 SET MYSEQ("SEG_POS")=2
+81 SET MYSEQ("FIELD_POS")=$SELECT(PRCVSEG="QPD":3,PRCVSEG="QID":2,1:"")
+82 DO ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+83 SET PRCVSTAT=$PIECE(X,"-",1)
+84 SET PRCVCP=+$PIECE(X,"-",2)
+85 IF '$DATA(^PRC(420,PRCVSTAT,0))
Begin DoDot:1
+86 ;invalid station number
+87 SET MYERR("HL_CODE")="HL204"
+88 SET MYERR("HL_TEXT")="Unknown key identfier"
+89 SET MYSEQ("SEG_POS")=2
+90 SET MYSEQ("FIELD_POS")=$SELECT(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
+91 DO ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+92 IF '$DATA(^PRC(420,PRCVSTAT,1,PRCVCP,0))
Begin DoDot:1
+93 ;invalid station/FCP pair
+94 SET MYERR("HL_CODE")="HL204"
+95 SET MYERR("HL_TEXT")="Unknown key identfier"
+96 SET MYSEQ("SEG_POS")=2
+97 SET MYSEQ("FIELD_POS")=$SELECT(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
+98 DO ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+99 if PRCVACT=2
GOTO DEL
+100 SET X1=$$ADDSUB^PRCVSUB(PRCVSTAT,PRCVCP,1)
+101 IF $PIECE(X1,"^",1)["?"
Begin DoDot:1
+102 ;Duplicate
+103 ;S MYERR("SEVERITY")="W"
+104 DO ACK("AA",PRCVMID)
End DoDot:1
QUIT
+105 IF $PIECE(X1,"^",1)="E"
Begin DoDot:1
+106 ;Fileman generated error
+107 SET MYERR("HL_CODE")="HL207"
+108 SET MYERR("HL_TEXT")="Application internal error"
+109 SET MYSEQ("SEG_POS")=2
+110 DO ACK("AR",PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+111 ;end of message
if PRCVACT=2
GOTO DONE
+112 XECUTE HLNEXT
IF HLQUIT'>0
Begin DoDot:1
+113 ;Error: RCP segment expected
+114 SET MYERR("HL_CODE")="HL100"
+115 SET MYERR("HL_TEXT")="Segment sequence error"
+116 SET MYSEQ("SEG_POS")=3
+117 DO ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
End DoDot:1
QUIT
+118 GOTO DONE
DEL ;
+1 SET X1=$$DELSUB^PRCVSUB(PRCVSTAT,+PRCVCP,1)
+2 IF X1["E"
Begin DoDot:1
+3 ;Error during Fileman call
+4 SET MYERR("HL_CODE")="HL207"
+5 SET MYERR("HL_TEXT")="Application internal error"
+6 SET MYSEQ("SEG_POS")=1
+7 SET MYSEQ("FIELD_POS")=1
+8 DO ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
End DoDot:1
QUIT
+9 IF X1'["@"
Begin DoDot:1
+10 ;Deletion error
+11 SET MYERR("HL_CODE")="HL207"
+12 SET MYERR("HL_TEXT")="Application internal error"
+13 SET MYSEQ("SEG_POS")=1
+14 SET MYSEQ("FIELD_POS")=1
+15 DO ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
End DoDot:1
QUIT
DONE ;
+1 ;Success!
+2 DO ACK("AA",PRCVMID)
+3 QUIT
+4 ;
ACK(PRCVSTAT,PRCVOMID,PRCVSID,PRCVSEQ,PRCVERR) ;
+1 NEW HLA,ERR,I,SEV,PRCVEID,PRCVAPP,PRCVEIDS,PRCVRES
+2 ;Make sure the parameters are defined
+3 SET PRCVSTAT=$GET(PRCVSTAT)
SET PRCVOMID=$GET(PRCVOMID)
SET PRCVSID=$GET(PRCVSID)
+4 SET HLA("HLA",1)="MSA"_PRCVFS_$GET(PRCVSTAT)_PRCVFS_$GET(PRCVOMID)
+5 SET SEV=$SELECT($DATA(PRCVERR("SEVERITY")):$GET(PRCVERR("SEVERITY")),1:"E")
+6 ;set some variables
+7 SET PRCVEID=$GET(HL("EID"))
+8 SET PRCVEIDS=$GET(HL("EIDS"))
+9 ;S PRCVAPP=$$FIND1^DIC(771,,"MX","PRCV_DYNAMED")
+10 if (($LENGTH(PRCVEID)=0)!($LENGTH($GET(HLMTIENS))=0)!($LENGTH(PRCVEIDS)=0))
QUIT
+11 SET PRCVRES=""
+12 if PRCVSTAT="AA"
SET HLA("HLA",1)=HLA("HLA",1)_PRCVFS_"OK"
+13 if $LENGTH(PRCVSID)>0
Begin DoDot:1
+14 SET ERR="ERR"_PRCVFS_PRCVFS_PRCVSID_PRCVCS_$GET(PRCVSEQ("SEG_POS"))
+15 SET ERR=ERR_PRCVCS_$GET(PRCVSEQ("FIELD_POS"))_PRCVFS
+16 ;S ERR=ERR_PRCVCS_$G(PRCVSEQ("FIELD_POS"))_PRCVCS
+17 ;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVCS_$G(PRCVSEQ("CMP_POS"))
+18 ;S ERR=ERR_PRCVCS_$G(PRCVSEQ("SUBCMP_POS"))_PRCVFS
+19 ;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVFS
+20 SET ERR=ERR_$GET(PRCVERR("HL_CODE"))_PRCVCS_$GET(PRCVERR("HL_TEXT"))
+21 SET ERR=ERR_PRCVCS_"0357"_PRCVFS_SEV_PRCVFS
+22 IF $DATA(PRCVERR("APP",1))
Begin DoDot:2
+23 ;application error(s)
+24 SET ERR=ERR_$GET(PRCVERR("APP",1,"CODE"))_PRCVCS_$GET(PRCVERR("APP",1,"TEXT"))
+25 SET I=1
+26 FOR
SET I=$ORDER(PRCVERR("APP",I))
if ((I="")!(I>10))
QUIT
Begin DoDot:3
+27 SET ERR=ERR_PRCVRS
+28 SET ERR=ERR_$GET(PRCVERR("APP",I,"CODE"))_PRCVCS
+29 SET ERR=ERR_$GET(PRCVERR("APP",I,"TEXT"))
End DoDot:3
End DoDot:2
+30 SET HLA("HLA",2)=ERR
End DoDot:1
+31 DO GENACK^HLMA1(PRCVEID,$GET(HLMTIENS),PRCVEIDS,"LM",1,.PRCVRES)
+32 QUIT
+33 ;
PUBACK ;
+1 NEW PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE,X
+2 NEW ATYPE,OMID,SEQ,ERR,I,X1,ECNT,RFAC
+3 SET PRCVFS=$GET(HL("FS"))
+4 SET PRCVCS=$EXTRACT($GET(HL("ECH")),1)
+5 SET PRCVRS=$EXTRACT($GET(HL("ECH")),2)
+6 SET PRCVES=$EXTRACT($GET(HL("ECH")),3)
+7 SET PRCVSS=$EXTRACT($GET(HL("ECH")),4)
+8 SET (HLQUIT,HLNODE)=0
+9 ;Note: the following variable is KILLed to avoid certain
+10 ;problems with $$REPROC^HLUTIL
+11 KILL HLDONE1
+12 SET PRCVMSG=$GET(HL("MTN"))
+13 SET PRCVMID=$GET(HL("MID"))
+14 if HL("MTN")'="MFK"
QUIT
+15 ;read MSH
XECUTE HLNEXT
+16 IF HLQUIT'>0
QUIT
+17 SET X=$$FLD^HLCSUTL(.HLNODE,1)
+18 if X'="MSH"
QUIT
+19 SET RFAC=$PIECE($$FLD^HLCSUTL(.HLNODE,6),PRCVCS,1)
+20 ;read MSA
XECUTE HLNEXT
+21 IF HLQUIT'>0
QUIT
+22 SET X=$$FLD^HLCSUTL(.HLNODE,1)
+23 if X'="MSA"
QUIT
+24 SET ATYPE=$$FLD^HLCSUTL(.HLNODE,2)
+25 ;No need to go further
+26 QUIT
