IBCNEHLK ;DAOU/ALA - HL7 Acknowledgement Messages ;08-OCT-2002
;;2.0;INTEGRATED BILLING;**184,300,601**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
MFK ; MFN Acknowledgement
S HCT=1
; Loop through the message and find each segment for processing
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D
. D SPAR^IBCNEHLU
. S SEG=$G(IBSEG(1))
. ;
. I SEG="MSA" D
.. S ACK=$G(IBSEG(2)),MSGID=$G(IBSEG(3))
.. ;
.. I ACK="AE" S VMFN(350.9,"1,",51.22)=0
.. I ACK="AA" S VMFN(350.9,"1,",51.22)=1
;
D FILE^DIE("I","VMFN")
;
K IBSEG,SEG,HCT,ACK,EVENT,HL,IBPRTCL,IDUZ,MSGID,SEGMT,TAG,VMFN
Q
; IB*2.0*601 - Added new logic for ACK tag.
ACK ; ACK Acknowledgement
N IBCNHLP,HCT,MSA,MFI,MFA,CONTROL,HLFS
K ^TMP("HLA",$J)
S HCT=0
S HLFS="|"
;
D MSA S HCT=HCT+1,^TMP("HLA",$J,HCT)=$TR(MSA,"*","")
D MFI S HCT=HCT+1,^TMP("HLA",$J,HCT)=$TR(MFI,"*","")
D MFA S HCT=HCT+1,^TMP("HLA",$J,HCT)=$TR(MFA,"*","")
;
D GENACK^HLMA1($$FIND1^DIC(101,,,"IBCNE IIV MFN IN","B"),HLMTIENS,$$FIND1^DIC(101,,,"IBCNE IIV TABLE","B"),"GM",1,.ERROR)
K ^TMP("HLA",$J),HL,ERROR
;
Q
MSA ; MSA Segment
N DATA,CONTROL
S CONTROL=$P($G(^TMP($J,"IBCNEHLI",1,0)),"|",10) ; Table Update Message Control ID
S MSA="MSA"_HLFS_$G(IBACK)_HLFS_CONTROL
Q
;
MFI ; MFI Segment
S MFI=$G(^TMP($J,"IBCNEHLI",2,0)) ; Return this segment.
S $P(MFI,HLFS,7)="NE"
Q
MFA ; MFA Segment
N I,ECODE,DATA,IDMFA
S ECODE="",IDMFA=""
F I=1:1 Q:'$D(^TMP($J,"IBCNEHLI",I,0)) D Q:ECODE'=""
.S DATA=^TMP($J,"IBCNEHLI",I,0)
.I $P(DATA,"|")="MFE" S ECODE=$P(DATA,"|",2),IDMFA=$P(DATA,"|",5)
S MFA="MFA"_HLFS_ECODE_HLFS_HLFS_HLFS_$S(IBACK="AA":"S",1:"U")_HLFS_IDMFA_HLFS_"CE"
Q
MLMN ; MailMan Message
D TXT^IBCNEUT7("MSG")
S MGRP=$$MGRP^IBCNEUT5()
S XMSUB="IBCNE IIV MFN IN"
D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
K XMSUB,XMY,MSG,XMZ,XMDUZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHLK 1907 printed Apr 09, 2024@21:08:15 Page 2
IBCNEHLK ;DAOU/ALA - HL7 Acknowledgement Messages ;08-OCT-2002
+1 ;;2.0;INTEGRATED BILLING;**184,300,601**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
MFK ; MFN Acknowledgement
+1 SET HCT=1
+2 ; Loop through the message and find each segment for processing
+3 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+4 DO SPAR^IBCNEHLU
+5 SET SEG=$GET(IBSEG(1))
+6 ;
+7 IF SEG="MSA"
Begin DoDot:2
+8 SET ACK=$GET(IBSEG(2))
SET MSGID=$GET(IBSEG(3))
+9 ;
+10 IF ACK="AE"
SET VMFN(350.9,"1,",51.22)=0
+11 IF ACK="AA"
SET VMFN(350.9,"1,",51.22)=1
End DoDot:2
End DoDot:1
+12 ;
+13 DO FILE^DIE("I","VMFN")
+14 ;
+15 KILL IBSEG,SEG,HCT,ACK,EVENT,HL,IBPRTCL,IDUZ,MSGID,SEGMT,TAG,VMFN
+16 QUIT
+17 ; IB*2.0*601 - Added new logic for ACK tag.
ACK ; ACK Acknowledgement
+1 NEW IBCNHLP,HCT,MSA,MFI,MFA,CONTROL,HLFS
+2 KILL ^TMP("HLA",$JOB)
+3 SET HCT=0
+4 SET HLFS="|"
+5 ;
+6 DO MSA
SET HCT=HCT+1
SET ^TMP("HLA",$JOB,HCT)=$TRANSLATE(MSA,"*","")
+7 DO MFI
SET HCT=HCT+1
SET ^TMP("HLA",$JOB,HCT)=$TRANSLATE(MFI,"*","")
+8 DO MFA
SET HCT=HCT+1
SET ^TMP("HLA",$JOB,HCT)=$TRANSLATE(MFA,"*","")
+9 ;
+10 DO GENACK^HLMA1($$FIND1^DIC(101,,,"IBCNE IIV MFN IN","B"),HLMTIENS,$$FIND1^DIC(101,,,"IBCNE IIV TABLE","B"),"GM",1,.ERROR)
+11 KILL ^TMP("HLA",$JOB),HL,ERROR
+12 ;
+13 QUIT
MSA ; MSA Segment
+1 NEW DATA,CONTROL
+2 ; Table Update Message Control ID
SET CONTROL=$PIECE($GET(^TMP($JOB,"IBCNEHLI",1,0)),"|",10)
+3 SET MSA="MSA"_HLFS_$GET(IBACK)_HLFS_CONTROL
+4 QUIT
+5 ;
MFI ; MFI Segment
+1 ; Return this segment.
SET MFI=$GET(^TMP($JOB,"IBCNEHLI",2,0))
+2 SET $PIECE(MFI,HLFS,7)="NE"
+3 QUIT
MFA ; MFA Segment
+1 NEW I,ECODE,DATA,IDMFA
+2 SET ECODE=""
SET IDMFA=""
+3 FOR I=1:1
if '$DATA(^TMP($JOB,"IBCNEHLI",I,0))
QUIT
Begin DoDot:1
+4 SET DATA=^TMP($JOB,"IBCNEHLI",I,0)
+5 IF $PIECE(DATA,"|")="MFE"
SET ECODE=$PIECE(DATA,"|",2)
SET IDMFA=$PIECE(DATA,"|",5)
End DoDot:1
if ECODE'=""
QUIT
+6 SET MFA="MFA"_HLFS_ECODE_HLFS_HLFS_HLFS_$SELECT(IBACK="AA":"S",1:"U")_HLFS_IDMFA_HLFS_"CE"
+7 QUIT
MLMN ; MailMan Message
+1 DO TXT^IBCNEUT7("MSG")
+2 SET MGRP=$$MGRP^IBCNEUT5()
+3 SET XMSUB="IBCNE IIV MFN IN"
+4 DO MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
+5 KILL XMSUB,XMY,MSG,XMZ,XMDUZ
+6 QUIT
