IBCNHHLI ;ALB/ZEB - HL7 Receiver for NIF transmissions ;25-FEB-14
;;2.0;INTEGRATED BILLING;**519**;21-MAR-94;Build 56
;;Per VA Directive 6402, this routine should not be modified.
;**Program Description**
; This program will process incoming NIF response messages.
; Call at tags only
Q
RCV ; assumes the following from HL7: HLERR,HLNODE,HLQUIT,HLNEXT,HL,HLMTIENS
Q:+$P($G(^IBE(350.9,1,70)),U,1)'=1 ;abort if secret HL7 flag isn't set
N MSGID,INSIDS,INSQLS,RTY,PSTAT,RID,RDATA,TID
N IDCNT,IDTMP,ID,IDS,TYPE,PC,UPDDT
N HLFS,HLCS,HLRS,ACK,SEG
K HLERR ;make sure HL7 error flag isn't set
S HLFS=HL("FS")
S HLCS=$E(HL("ECH"),1)
S HLRS=$E(HL("ECH"),2)
N DIC,%,%H,%I D NOW^%DTC S UPDDT=%
S INSIDS="",INSQLS="",RDATA=""
S RTY="U",RID="",TID="",PSTAT="R" ;default values if we manage to not get an MSA or QAK
;process HL7 segments, build arguments to filing routines
F X HLNEXT Q:HLQUIT'>0 D
. S SEG=$S($E(HLNODE,1)=$C(10):$E(HLNODE,2,4),1:$E(HLNODE,1,3)) ;deal with messages with CRLF (why?!)
. I SEG="MSA" D I 1
. . S MSGID=$P(HLNODE,HLFS,3)
. . I MSGID]"" D
. . . S RTY="R"
. . . S RID=$O(^IBCNH(367,"B",MSGID,""))
. . . S:RID="" RID=$O(^IBCNH(367,"B",$E(MSGID,$L($P($$SITE^VASITE(),U,3))+1,$L(MSGID)),""))
. . . S TID=$S(RID="":"",1:$P($G(^IBCNH(367,RID,0)),U,2))
. . S ACK=$P(HLNODE,HLFS,2),PSTAT=$S(ACK="AE":"X",ACK="AR":"EXR",1:"R")
. I SEG="QAK" D I 1
. . I $P($P(HLNODE,HLFS,4),HLCS,1)="ZHPID02" S RTY="U",RID="",TID="" ;set this on top of set from MSA
. E I SEG="IN1" D
. . S $P(RDATA,U,4)=$P(HLNODE,HLFS,5)
. . S IDS=$P(HLNODE,HLFS,4)
. . F IDCNT=1:1 S IDTMP=$P(IDS,HLRS,IDCNT) Q:IDTMP="" D
. . . S ID=$P(IDTMP,HLCS,1)
. . . S TYPE=$P(IDTMP,HLCS,5)
. . . I TYPE="INS" S $P(RDATA,U,7)=ID,$P(INSIDS,U,10)=ID Q
. . . I TYPE="NIF" S $P(INSIDS,U,8)=ID Q
. . . I TYPE="HPIDC" S $P(RDATA,U,9)="C",$P(INSIDS,U,9)=ID Q
. . . I TYPE="HPIDS" S $P(RDATA,U,9)="S",$P(INSIDS,U,9)=ID Q
. . . I TYPE="OEID" S $P(RDATA,U,9)="@",$P(INSIDS,U,9)=ID,$P(RDATA,U,8)="@" Q
. . . I TYPE="VA" S $P(INSIDS,U,7)=ID Q
. . . I TYPE="PROF" S $P(INSIDS,U,1)=ID Q
. . . I TYPE="INST" S $P(INSIDS,U,2)=ID Q
. . . I TYPE="PARNT" S $P(RDATA,U,8)=ID Q
. . . I "^2UP^FYP^NFP^TJP^"[(U_TYPE_U) S PC=$S($P(INSIDS,U,3)]"":4,1:3),$P(INSIDS,U,PC)=ID,$P(INSQLS,U,PC)=$E(TYPE,1,2) Q
. . . I "^2UI^FYI^NFI^TJI^"[(U_TYPE_U) S PC=$S($P(INSIDS,U,5)]"":6,1:5),$P(INSIDS,U,PC)=ID,$P(INSQLS,U,PC)=$E(TYPE,1,2) Q
I (PSTAT="R")&($P(INSIDS,U,9)="") S $P(INSIDS,U,9)="@",$P(RDATA,U,8)="@",$P(RDATA,U,9)="@" ;delete existing HPID/OEID if we get an update without one
S $P(RDATA,U,1)=HLMTIENS ;don't overwrite sets from optional IN1
S $P(RDATA,U,2)=TID
S $P(RDATA,U,3)=RTY
S $P(RDATA,U,5)=PSTAT
S $P(RDATA,U,6)=UPDDT
;file the response and the data from it
;this routine will perform the check to see if we need to file this message
S %=$$FM367^IBCNHUT2(RID,RDATA,INSIDS,INSQLS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNHHLI 2955 printed Oct 16, 2024@18:16:23 Page 2
IBCNHHLI ;ALB/ZEB - HL7 Receiver for NIF transmissions ;25-FEB-14
+1 ;;2.0;INTEGRATED BILLING;**519**;21-MAR-94;Build 56
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;**Program Description**
+4 ; This program will process incoming NIF response messages.
+5 ; Call at tags only
+6 QUIT
RCV ; assumes the following from HL7: HLERR,HLNODE,HLQUIT,HLNEXT,HL,HLMTIENS
+1 ;abort if secret HL7 flag isn't set
if +$PIECE($GET(^IBE(350.9,1,70)),U,1)'=1
QUIT
+2 NEW MSGID,INSIDS,INSQLS,RTY,PSTAT,RID,RDATA,TID
+3 NEW IDCNT,IDTMP,ID,IDS,TYPE,PC,UPDDT
+4 NEW HLFS,HLCS,HLRS,ACK,SEG
+5 ;make sure HL7 error flag isn't set
KILL HLERR
+6 SET HLFS=HL("FS")
+7 SET HLCS=$EXTRACT(HL("ECH"),1)
+8 SET HLRS=$EXTRACT(HL("ECH"),2)
+9 NEW DIC,%,%H,%I
DO NOW^%DTC
SET UPDDT=%
+10 SET INSIDS=""
SET INSQLS=""
SET RDATA=""
+11 ;default values if we manage to not get an MSA or QAK
SET RTY="U"
SET RID=""
SET TID=""
SET PSTAT="R"
+12 ;process HL7 segments, build arguments to filing routines
+13 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+14 ;deal with messages with CRLF (why?!)
SET SEG=$SELECT($EXTRACT(HLNODE,1)=$CHAR(10):$EXTRACT(HLNODE,2,4),1:$EXTRACT(HLNODE,1,3))
+15 IF SEG="MSA"
Begin DoDot:2
+16 SET MSGID=$PIECE(HLNODE,HLFS,3)
+17 IF MSGID]""
Begin DoDot:3
+18 SET RTY="R"
+19 SET RID=$ORDER(^IBCNH(367,"B",MSGID,""))
+20 if RID=""
SET RID=$ORDER(^IBCNH(367,"B",$EXTRACT(MSGID,$LENGTH($PIECE($$SITE^VASITE(),U,3))+1,$LENGTH(MSGID)),""))
+21 SET TID=$SELECT(RID="":"",1:$PIECE($GET(^IBCNH(367,RID,0)),U,2))
End DoDot:3
+22 SET ACK=$PIECE(HLNODE,HLFS,2)
SET PSTAT=$SELECT(ACK="AE":"X",ACK="AR":"EXR",1:"R")
End DoDot:2
IF 1
+23 IF SEG="QAK"
Begin DoDot:2
+24 ;set this on top of set from MSA
IF $PIECE($PIECE(HLNODE,HLFS,4),HLCS,1)="ZHPID02"
SET RTY="U"
SET RID=""
SET TID=""
End DoDot:2
IF 1
+25 IF '$TEST
IF SEG="IN1"
Begin DoDot:2
+26 SET $PIECE(RDATA,U,4)=$PIECE(HLNODE,HLFS,5)
+27 SET IDS=$PIECE(HLNODE,HLFS,4)
+28 FOR IDCNT=1:1
SET IDTMP=$PIECE(IDS,HLRS,IDCNT)
if IDTMP=""
QUIT
Begin DoDot:3
+29 SET ID=$PIECE(IDTMP,HLCS,1)
+30 SET TYPE=$PIECE(IDTMP,HLCS,5)
+31 IF TYPE="INS"
SET $PIECE(RDATA,U,7)=ID
SET $PIECE(INSIDS,U,10)=ID
QUIT
+32 IF TYPE="NIF"
SET $PIECE(INSIDS,U,8)=ID
QUIT
+33 IF TYPE="HPIDC"
SET $PIECE(RDATA,U,9)="C"
SET $PIECE(INSIDS,U,9)=ID
QUIT
+34 IF TYPE="HPIDS"
SET $PIECE(RDATA,U,9)="S"
SET $PIECE(INSIDS,U,9)=ID
QUIT
+35 IF TYPE="OEID"
SET $PIECE(RDATA,U,9)="@"
SET $PIECE(INSIDS,U,9)=ID
SET $PIECE(RDATA,U,8)="@"
QUIT
+36 IF TYPE="VA"
SET $PIECE(INSIDS,U,7)=ID
QUIT
+37 IF TYPE="PROF"
SET $PIECE(INSIDS,U,1)=ID
QUIT
+38 IF TYPE="INST"
SET $PIECE(INSIDS,U,2)=ID
QUIT
+39 IF TYPE="PARNT"
SET $PIECE(RDATA,U,8)=ID
QUIT
+40 IF "^2UP^FYP^NFP^TJP^"[(U_TYPE_U)
SET PC=$SELECT($PIECE(INSIDS,U,3)]"":4,1:3)
SET $PIECE(INSIDS,U,PC)=ID
SET $PIECE(INSQLS,U,PC)=$EXTRACT(TYPE,1,2)
QUIT
+41 IF "^2UI^FYI^NFI^TJI^"[(U_TYPE_U)
SET PC=$SELECT($PIECE(INSIDS,U,5)]"":6,1:5)
SET $PIECE(INSIDS,U,PC)=ID
SET $PIECE(INSQLS,U,PC)=$EXTRACT(TYPE,1,2)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;delete existing HPID/OEID if we get an update without one
IF (PSTAT="R")&($PIECE(INSIDS,U,9)="")
SET $PIECE(INSIDS,U,9)="@"
SET $PIECE(RDATA,U,8)="@"
SET $PIECE(RDATA,U,9)="@"
+43 ;don't overwrite sets from optional IN1
SET $PIECE(RDATA,U,1)=HLMTIENS
+44 SET $PIECE(RDATA,U,2)=TID
+45 SET $PIECE(RDATA,U,3)=RTY
+46 SET $PIECE(RDATA,U,5)=PSTAT
+47 SET $PIECE(RDATA,U,6)=UPDDT
+48 ;file the response and the data from it
+49 ;this routine will perform the check to see if we need to file this message
+50 SET %=$$FM367^IBCNHUT2(RID,RDATA,INSIDS,INSQLS)
+51 QUIT
