PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 2/29/08 1:54pm
;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
;Per VHA Directive 2004-038, this routine should not be modified
;
CALLIT ;Call the IFCAP RIL build Routine
;
D EN^PRCVRC1(PRCSUB)
;
SETUP S PRCHD(1)=""
;Added 1,"T" node to stop crash
S PRCHD(1,"T")="ORDER HEADER INFO"
S PRCHD(2)="ORC"_PRCCS_PRCCS_3
S PRCHD(2,"T")="FUND CONTROL POINT"
S PRCHD(3)="ORC"_PRCCS_PRCCS_17
S PRCHD(3,"T")="COST CENTER"
S PRCHD(4)=""
S PRCHD(5)="ORC"_PRCCS_PRCCS_21
S PRCHD(5,"T")="SITE NUMBER"
S PRCHD(6)=""
S PRCHD(7)="ORC"_PRCCS_PRCCS_10
S PRCHD(7,"T")="DUZ"
S PRCHD(8)="ORC"_PRCCS_PRCCS_10
S PRCHD(8,"T")="LAST NAME"
S PRCHD(9)="ORC"_PRCCS_PRCCS_11
S PRCHD(9,"T")="FIRST NAME"
S PRCDET(1)="RQD"_PRCCS_PRCCS_3
S PRCDET(1,"T")="ITEM NUMBER"
S PRCDET(2)="RQD"_PRCCS_PRCCS_5
S PRCDET(2,"T")="QUANTITY"
S PRCDET(3)="RQ1"_PRCCS_PRCCS_4
S PRCDET(3,"T")="VENDOR ID"
S PRCDET(4)="RQ1"_PRCCS_PRCCS_1
S PRCDET(4,"T")="UNIT COST"
S PRCDET(5)="RQD"_PRCCS_PRCCS_10
S PRCDET(5,"T")="DATE NEEDED"
S PRCDET(6)="RQD"_PRCCS_PRCCS_2
S PRCDET(6,"T")="DYNAMED DOCUMENT ID"
S PRCDET(7)="RQ1"_PRCCS_PRCCS_5
S PRCDET(7,"T")="NIF NUMBER"
S PRCDET(8)="RQ1"_PRCCS_PRCCS_3
S PRCDET(8,"T")="BOC"
;Check if IFCAP has returned any errors
;
S ERRCNT=1
S PRCVERR(0)="0"
HEAD ;If there are errors in the "1" sub-segment, add all errors to all
; line items
S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2)
I $D(^XTMP(PRCSUB,1,"ERR"))>0 D
.S II=0
.F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D
..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II))
..Q:ERRDAT=""
..S MSGFLG=1
..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3)
..S SEVER=$P(ERRDAT,U,4)
..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS
..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1
..S J=0
..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D
...S ERRSUB=$P(ERRSTR,PRCFS,3)
...S $P(ERRSUB,U,2)=J
...S $P(ERRSTR,PRCFS,3)=ERRSUB
...;S $P($P(ERRSTR,PRCFS,3),U,2)=J
...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6)
...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1
DETAIL ;If there are errors in the detail lines, add them
S II=0
F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D
.S DOCID=$P(^XTMP(PRCSUB,2,II),U,6)
.S III=0
.F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D
..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III))
..Q:ERRDAT=""
..S MSGFLG=1
..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3)
..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II
..S SEVER=$P(ERRDAT,U,4)
..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID
..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1
..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID
..S ERRCNT=ERRCNT+1
;
I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q
SETNTE ; If there are errors set an NTE segment
;
S TOT=0,TOTREC=0,TOTERR=0
F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D
.S TOTREC=TOT
.I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D
..S ERRS=0
..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D
...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4)
...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99
I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC
S TOTGOOD=TOTREC-TOTERR
S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1
D NAKIT,CLEANUP^PRCVRE1 Q
;
NAKIT ;Send an acknowledgement that the message is rejected
;
I HL("APAT")'="AL" Q
S MSG=""
F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D
.S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG)
S PRCVRES=""
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES)
;I +$P(PRCVRES,U,2) D
;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS."
MAIL ;Send MailMan message with error
Q:LENVAL="NOTOK"
N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
S XMSUB="RIL build errors in HL7 message "_HL("MID")_" "
S XMDUZ="IFCAP/DynaMed Interface"
S XMTEXT="PRCVERR("
D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP)
D ^XMD
K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
Q
;
ACKIT ;Send an acknowledgement that everything went fine
;
I HL("APAT")'="AL" Q
F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I))
;
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES)
;I +P(PRCVRES,U,2) D
;.I $D(ERRCNT)=0 S ERRCNT=1
;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS."
;.D MAIL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVREA 4899 printed Sep 23, 2025@19:56:22 Page 2
PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 2/29/08 1:54pm
+1 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
CALLIT ;Call the IFCAP RIL build Routine
+1 ;
+2 DO EN^PRCVRC1(PRCSUB)
+3 ;
SETUP SET PRCHD(1)=""
+1 ;Added 1,"T" node to stop crash
+2 SET PRCHD(1,"T")="ORDER HEADER INFO"
+3 SET PRCHD(2)="ORC"_PRCCS_PRCCS_3
+4 SET PRCHD(2,"T")="FUND CONTROL POINT"
+5 SET PRCHD(3)="ORC"_PRCCS_PRCCS_17
+6 SET PRCHD(3,"T")="COST CENTER"
+7 SET PRCHD(4)=""
+8 SET PRCHD(5)="ORC"_PRCCS_PRCCS_21
+9 SET PRCHD(5,"T")="SITE NUMBER"
+10 SET PRCHD(6)=""
+11 SET PRCHD(7)="ORC"_PRCCS_PRCCS_10
+12 SET PRCHD(7,"T")="DUZ"
+13 SET PRCHD(8)="ORC"_PRCCS_PRCCS_10
+14 SET PRCHD(8,"T")="LAST NAME"
+15 SET PRCHD(9)="ORC"_PRCCS_PRCCS_11
+16 SET PRCHD(9,"T")="FIRST NAME"
+17 SET PRCDET(1)="RQD"_PRCCS_PRCCS_3
+18 SET PRCDET(1,"T")="ITEM NUMBER"
+19 SET PRCDET(2)="RQD"_PRCCS_PRCCS_5
+20 SET PRCDET(2,"T")="QUANTITY"
+21 SET PRCDET(3)="RQ1"_PRCCS_PRCCS_4
+22 SET PRCDET(3,"T")="VENDOR ID"
+23 SET PRCDET(4)="RQ1"_PRCCS_PRCCS_1
+24 SET PRCDET(4,"T")="UNIT COST"
+25 SET PRCDET(5)="RQD"_PRCCS_PRCCS_10
+26 SET PRCDET(5,"T")="DATE NEEDED"
+27 SET PRCDET(6)="RQD"_PRCCS_PRCCS_2
+28 SET PRCDET(6,"T")="DYNAMED DOCUMENT ID"
+29 SET PRCDET(7)="RQ1"_PRCCS_PRCCS_5
+30 SET PRCDET(7,"T")="NIF NUMBER"
+31 SET PRCDET(8)="RQ1"_PRCCS_PRCCS_3
+32 SET PRCDET(8,"T")="BOC"
+33 ;Check if IFCAP has returned any errors
+34 ;
+35 SET ERRCNT=1
+36 SET PRCVERR(0)="0"
HEAD ;If there are errors in the "1" sub-segment, add all errors to all
+1 ; line items
+2 SET ERRCNT=1
SET MSGFLG=0
SET PRCSUB2=$PIECE(PRCSUB,"*",2)
+3 IF $DATA(^XTMP(PRCSUB,1,"ERR"))>0
Begin DoDot:1
+4 SET II=0
+5 FOR I=1:1
SET II=$ORDER(^XTMP(PRCSUB,1,"ERR",II))
if II=""
QUIT
Begin DoDot:2
+6 SET ERRDAT=$GET(^XTMP(PRCSUB,1,"ERR",II))
+7 if ERRDAT=""
QUIT
+8 SET MSGFLG=1
+9 SET FLDNO=$PIECE(ERRDAT,U,1)
SET ERRCOD="PRCV"_$PIECE(ERRDAT,U,2)
SET ERRTXT=$PIECE(ERRDAT,U,3)
+10 SET SEVER=$PIECE(ERRDAT,U,4)
+11 SET ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS
+12 SET PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT
SET ERRCNT=ERRCNT+1
+13 SET J=0
+14 FOR IL=1:1
SET J=$ORDER(^XTMP(PRCSUB,2,J))
if J=""
QUIT
Begin DoDot:3
+15 SET ERRSUB=$PIECE(ERRSTR,PRCFS,3)
+16 SET $PIECE(ERRSUB,U,2)=J
+17 SET $PIECE(ERRSTR,PRCFS,3)=ERRSUB
+18 ;S $P($P(ERRSTR,PRCFS,3),U,2)=J
+19 SET $PIECE(ERRSTR,PRCFS,7)=$PIECE($GET(^XTMP(PRCSUB,2,J)),U,6)
+20 SET ^TMP("PRCVRIL",$JOB,"NAK",ACKCNT)=ERRSTR
SET ACKCNT=ACKCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
DETAIL ;If there are errors in the detail lines, add them
+1 SET II=0
+2 FOR I=1:1
SET II=$ORDER(^XTMP(PRCSUB,2,II))
if II=""
QUIT
Begin DoDot:1
+3 SET DOCID=$PIECE(^XTMP(PRCSUB,2,II),U,6)
+4 SET III=0
+5 FOR J=1:1
SET III=$ORDER(^XTMP(PRCSUB,2,II,"ERR",III))
if III=""
QUIT
Begin DoDot:2
+6 SET ERRDAT=$GET(^XTMP(PRCSUB,2,II,"ERR",III))
+7 if ERRDAT=""
QUIT
+8 SET MSGFLG=1
+9 SET FLDNO=$PIECE(ERRDAT,U,1)
SET ERRCOD="PRCV"_$PIECE(ERRDAT,U,2)
SET ERRTXT=$PIECE(ERRDAT,U,3)
+10 SET ERRLOC=PRCDET(FLDNO)
SET $PIECE(ERRLOC,U,2)=II
+11 SET SEVER=$PIECE(ERRDAT,U,4)
+12 SET ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID
+13 SET ^TMP("PRCVRIL",$JOB,"NAK",ACKCNT)=ERRSTR
SET ACKCNT=ACKCNT+1
+14 SET PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID
+15 SET ERRCNT=ERRCNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 IF MSGFLG=0
DO ACKIT
DO CLEANUP^PRCVRE1
QUIT
SETNTE ; If there are errors set an NTE segment
+1 ;
+2 SET TOT=0
SET TOTREC=0
SET TOTERR=0
+3 FOR I=1:1
SET TOT=$ORDER(^XTMP(PRCSUB,2,TOT))
if TOT=""
QUIT
Begin DoDot:1
+4 SET TOTREC=TOT
+5 IF $DATA(^XTMP(PRCSUB,2,TOT,"ERR"))>0
Begin DoDot:2
+6 SET ERRS=0
+7 FOR J=1:1
SET ERRS=$ORDER(^XTMP(PRCSUB,2,TOT,"ERR",ERRS))
if ERRS=""
QUIT
Begin DoDot:3
+8 SET SEVER=$PIECE($GET(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4)
+9 IF SEVER'="W"
SET TOTERR=TOTERR+1
SET ERRS=99
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $DATA(^XTMP(PRCSUB,2,"ERR",1))>1
SET TOTERR=TOTREC
+11 SET TOTGOOD=TOTREC-TOTERR
+12 SET ^TMP("PRCVRIL",$JOB,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD
SET ACKCNT=ACKCNT+1
+13 DO NAKIT
DO CLEANUP^PRCVRE1
QUIT
+14 ;
NAKIT ;Send an acknowledgement that the message is rejected
+1 ;
+2 IF HL("APAT")'="AL"
QUIT
+3 SET MSG=""
+4 FOR I=1:1
SET MSG=$ORDER(^TMP("PRCVRIL",$JOB,"NAK",MSG))
if MSG=""
QUIT
Begin DoDot:1
+5 SET ^TMP("HLA",$JOB,I)=^TMP("PRCVRIL",$JOB,"NAK",MSG)
End DoDot:1
+6 SET PRCVRES=""
+7 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES)
+8 ;I +$P(PRCVRES,U,2) D
+9 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS."
MAIL ;Send MailMan message with error
+1 if LENVAL="NOTOK"
QUIT
+2 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+3 SET XMSUB="RIL build errors in HL7 message "_HL("MID")_" "
+4 SET XMDUZ="IFCAP/DynaMed Interface"
+5 SET XMTEXT="PRCVERR("
+6 DO GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP)
+7 DO ^XMD
+8 KILL XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+9 QUIT
+10 ;
ACKIT ;Send an acknowledgement that everything went fine
+1 ;
+2 IF HL("APAT")'="AL"
QUIT
+3 FOR I=1:1:1
SET ^TMP("HLA",$JOB,I)=$GET(^TMP("PRCVRIL",$JOB,"ACK",I))
+4 ;
+5 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES)
+6 ;I +P(PRCVRES,U,2) D
+7 ;.I $D(ERRCNT)=0 S ERRCNT=1
+8 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS."
+9 ;.D MAIL
+10 QUIT
