PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm
;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
;Per VHA Directive 2004-038, this routine should not be modified
;
;An exemption from the 245 character length standard for a variable
; has been requested from the SACC for reading HL7 segments into
; a single variable. The limit is request to be 1K and if longer
; than that the system will exit with an Application ACK reject.
; Submitted 4/14/05.
;
;This routine processes messages from DynaMed to IFCAP to build a RIL
;
;HL("MID") - Message Control ID
;HL7DT - Today's date in HL7 format
;PRCDT - Date value
;ORC Segment will repeat for each item
; PRCORD - Order control should be NW for new order - ORC-1
; PRCFCP - Fund control Point - ORC-3
; PRCDATE - Date and time item entered - ORC-9
; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority
; PRCCC - Cost Center - ORC-17
; PRCSITE - Site Code should be 516 - ORC-21
;RQD Segment will repeat for each item
; PRCCTR - Item counter - RQD-1
; PRCDOC - DynaMed Document number - unique per item - RQD-2
; PRCITM - Item number $p1 of RQD-3
; PRCQTY - Item quantity - RQD-5
; PRCNEED - Date Needed - RQD-10
;RQ1 Segment one segment for each RQD segment
; PRCCOST - Estimated Unit Cost - RQ1-1
; PRCBOC - BOC Number - RQ1-3
; PRCVND - Vendor number - pointer to file 440 - RQ1-4
; PRCNIF - National Item File number - RQ1-5
;PRCTYP - Repetitive Item List type - default to blank
;Message builds an ^XTMP to pass data to IFCAP RIL build routine.
; The first node is "PRCVRE*"+the Message Control ID. The next nodes
; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus
; $H. The $H is used to measure transmission timing. The 1 node holds
; header data common to all detail items being transmitted. The 2
; node holds detail information about each item ordered in a counter
; sub-node.
; Under the 1 and 2 nodes are "ERR" subnodes that hold error
; information about each item. There can be multiple errors
; associated with each item, therefore there are multiple sub-nodes
; possible under each "ERR" node.
;Counters
; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT
;ERRCOD - Error code from IFCAP
;ERRDAT - Error data from IFCAP
;ERRSTR - Error text from IFCAP
;ERRSUB - A substring of ERRSTR
;ERRS - Error substring from IFCAP
;SEVER - Error severity value - W or E
;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM
;FLDNO - Field identified in an error message
;ERRVAL - ERROR FLAG
;ERRARY - Message Error array sent to Prosthetics
;ERRLOC - Location of error sent in ACK
;PRCCS, PRCFS, PRCRS - Field delimiters
;PRCNODE - Message segment identifier
;Temporary Globals
; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok
; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok
; ^TMP("HLA",$J) - Message array sent to DynaMed
; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP
;Temporary variables
; TMP,MSGFLG,X, X1
;PRCHD - Array to hold map between HL7 and XTMP for Header info
;PRCDET - Array to hold map between HL7 and XTMP for Detail info
;PRCVERR - Array to hold error messages for MailMan
;PRCSUB - XTMP first node
;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID
;PRCVRES - Return variable from GENACK - Note:this doesn't work.
;PRCVINDX - Index number into XTMP to keep track of number of items
;
Q
;
BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE
N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC
N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF
N PRCSUB,PRCSUB2,PRCDT,PRCVINDX
N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2
N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID
N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL
; Fields used in PRCVREA are NEWed and KILLed here
N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO
N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC
N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES
D:'$D(U) DT^DICRW
S PRCDT=$$NOW^XLFDT
S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT
S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB)
D BUILD
S PRCCNT=0
S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2)
D START
D CLEANUP
Q
;
START ;This will read the incoming message from DynaMed and build ^TMP
;
SETACK ; Set up information for the ACK or NAK
;
K ^TMP("PRCVRIL",$J)
S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID")
S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID")
S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS
S ACKCNT=2
;
;If this is not the right message quit
;
I HL("MTN")'="OMN" D Q
.S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN")
.D NAKIT^PRCVREA
I HL("ETN")'="O07" D Q
.S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN")
.D NAKIT^PRCVREA
;
S ERRARY(1)="OK"
;
;Read the message and build the ^TMP global
;
K ^TMP("PRCVRE",$J)
S PRCI=""
F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D
.S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0
.F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ)
.I $E(HLNODE,1,3)="ORC" D
..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18)
..S TMP($J,PRCFCP,PRCCC)=""
;
;Validate that there is only one FCP and CC
S PRCFCP="",PRCFCP1=""
; Prevent PRCCC1 undefined PRC*5.1*119
S PRCCC1=""
F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D
.S PRCFCP1=X8
.S PRCCC=""
.F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D
..S PRCCC1=X9
I (PRCFCP1>1)!(PRCCC1>1) D Q
.S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA
;
PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP
;
S PRCI=0,PRCJ=0,LENVAL="OK"
F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D
.S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1=""
.F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))=""
..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))
..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q
..S NODE1=NODE1_NODE2
.Q:LENVAL="NOTOK"
.S PRCNODE=$E(NODE1,1,3)
.;
.; IF MSH segment ignore the record
.;
.I PRCNODE="MSH" Q
.S PRCNODE2=$E(NODE1,5,$L(NODE1))
.;
.; If ORC segment process the record
.;
.I PRCNODE="ORC" D Q
..I $D(^XTMP(PRCSUB,1))'=0 Q
..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21)
..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17)
..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE)
..S $P(^XTMP(PRCSUB,1),U,1)=0
..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE
..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP
.;
.; If RQD segment process the record
.;
.I PRCNODE="RQD" D Q
..S PRCCTR=$P(PRCNODE2,PRCFS,1)
..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3)
..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10)
..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE)
.;
.;If RQ1 segment process the record and build the XTMP global record
.;
.I PRCNODE="RQ1" D Q
..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5)
..;
..; Now build the XTMP record
..;
..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1)
..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR
..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP
..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC
..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC
;
I LENVAL="NOTOK" D Q
.S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K"
.D NAKIT^PRCVREA
.K ^XTMP(PRCSUB)
D CALLIT^PRCVREA
Q
;
BUILD ;Build the ^XTMP global zero node record.
;
S XX=$$HTFM^XLFDT($H,1)
S X1=$$FMADD^XLFDT(XX,5)
S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H
Q
;
CLEANUP ;This area will kill all temporary globals and variables
;
K ^TMP("PRCVRE",$J),TMP($J)
K ^TMP("HLA",$J)
K ^TMP("PRCVRIL",$J)
K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC
K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC
K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED
K PRCFS,PRCCS,PRCRS,PRCVINDX
K ERRARY
K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ
K ACKCNT,NODE1,NODE2,LENVAL
K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1
;Fields killed here are used in PRCVREA
K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB
K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER
K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVRE1 8803 printed Oct 16, 2024@18:21 Page 2
PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm
+1 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ;An exemption from the 245 character length standard for a variable
+5 ; has been requested from the SACC for reading HL7 segments into
+6 ; a single variable. The limit is request to be 1K and if longer
+7 ; than that the system will exit with an Application ACK reject.
+8 ; Submitted 4/14/05.
+9 ;
+10 ;This routine processes messages from DynaMed to IFCAP to build a RIL
+11 ;
+12 ;HL("MID") - Message Control ID
+13 ;HL7DT - Today's date in HL7 format
+14 ;PRCDT - Date value
+15 ;ORC Segment will repeat for each item
+16 ; PRCORD - Order control should be NW for new order - ORC-1
+17 ; PRCFCP - Fund control Point - ORC-3
+18 ; PRCDATE - Date and time item entered - ORC-9
+19 ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority
+20 ; PRCCC - Cost Center - ORC-17
+21 ; PRCSITE - Site Code should be 516 - ORC-21
+22 ;RQD Segment will repeat for each item
+23 ; PRCCTR - Item counter - RQD-1
+24 ; PRCDOC - DynaMed Document number - unique per item - RQD-2
+25 ; PRCITM - Item number $p1 of RQD-3
+26 ; PRCQTY - Item quantity - RQD-5
+27 ; PRCNEED - Date Needed - RQD-10
+28 ;RQ1 Segment one segment for each RQD segment
+29 ; PRCCOST - Estimated Unit Cost - RQ1-1
+30 ; PRCBOC - BOC Number - RQ1-3
+31 ; PRCVND - Vendor number - pointer to file 440 - RQ1-4
+32 ; PRCNIF - National Item File number - RQ1-5
+33 ;PRCTYP - Repetitive Item List type - default to blank
+34 ;Message builds an ^XTMP to pass data to IFCAP RIL build routine.
+35 ; The first node is "PRCVRE*"+the Message Control ID. The next nodes
+36 ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus
+37 ; $H. The $H is used to measure transmission timing. The 1 node holds
+38 ; header data common to all detail items being transmitted. The 2
+39 ; node holds detail information about each item ordered in a counter
+40 ; sub-node.
+41 ; Under the 1 and 2 nodes are "ERR" subnodes that hold error
+42 ; information about each item. There can be multiple errors
+43 ; associated with each item, therefore there are multiple sub-nodes
+44 ; possible under each "ERR" node.
+45 ;Counters
+46 ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT
+47 ;ERRCOD - Error code from IFCAP
+48 ;ERRDAT - Error data from IFCAP
+49 ;ERRSTR - Error text from IFCAP
+50 ;ERRSUB - A substring of ERRSTR
+51 ;ERRS - Error substring from IFCAP
+52 ;SEVER - Error severity value - W or E
+53 ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM
+54 ;FLDNO - Field identified in an error message
+55 ;ERRVAL - ERROR FLAG
+56 ;ERRARY - Message Error array sent to Prosthetics
+57 ;ERRLOC - Location of error sent in ACK
+58 ;PRCCS, PRCFS, PRCRS - Field delimiters
+59 ;PRCNODE - Message segment identifier
+60 ;Temporary Globals
+61 ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok
+62 ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok
+63 ; ^TMP("HLA",$J) - Message array sent to DynaMed
+64 ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP
+65 ;Temporary variables
+66 ; TMP,MSGFLG,X, X1
+67 ;PRCHD - Array to hold map between HL7 and XTMP for Header info
+68 ;PRCDET - Array to hold map between HL7 and XTMP for Detail info
+69 ;PRCVERR - Array to hold error messages for MailMan
+70 ;PRCSUB - XTMP first node
+71 ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID
+72 ;PRCVRES - Return variable from GENACK - Note:this doesn't work.
+73 ;PRCVINDX - Index number into XTMP to keep track of number of items
+74 ;
+75 QUIT
+76 ;
BEGIN NEW PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE
+1 NEW PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC
+2 NEW PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF
+3 NEW PRCSUB,PRCSUB2,PRCDT,PRCVINDX
+4 NEW ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2
+5 NEW ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID
+6 NEW X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL
+7 ; Fields used in PRCVREA are NEWed and KILLed here
+8 NEW MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO
+9 NEW I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC
+10 NEW PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES
+11 if '$DATA(U)
DO DT^DICRW
+12 SET PRCDT=$$NOW^XLFDT
+13 SET HL7DT=$$FMTHL7^XLFDT(PRCDT)
SET PRCDT=HL7DT
+14 SET PRCSUB="PRCVRE*"_HL("MID")
KILL ^XTMP(PRCSUB)
+15 DO BUILD
+16 SET PRCCNT=0
+17 SET PRCFS=$GET(HL("FS"))
SET PRCCS=$EXTRACT($GET(HL("ECH")))
SET PRCRS=$EXTRACT($GET(HL("ECH")),2)
+18 DO START
+19 DO CLEANUP
+20 QUIT
+21 ;
START ;This will read the incoming message from DynaMed and build ^TMP
+1 ;
SETACK ; Set up information for the ACK or NAK
+1 ;
+2 KILL ^TMP("PRCVRIL",$JOB)
+3 SET ^TMP("PRCVRIL",$JOB,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID")
+4 SET ^TMP("PRCVRIL",$JOB,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID")
+5 SET ^TMP("PRCVRIL",$JOB,"NAK",2)="ERR"_PRCFS
+6 SET ACKCNT=2
+7 ;
+8 ;If this is not the right message quit
+9 ;
+10 IF HL("MTN")'="OMN"
Begin DoDot:1
+11 SET $PIECE(^TMP("PRCVRIL",$JOB,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN")
+12 DO NAKIT^PRCVREA
End DoDot:1
QUIT
+13 IF HL("ETN")'="O07"
Begin DoDot:1
+14 SET $PIECE(^TMP("PRCVRIL",$JOB,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN")
+15 DO NAKIT^PRCVREA
End DoDot:1
QUIT
+16 ;
+17 SET ERRARY(1)="OK"
+18 ;
+19 ;Read the message and build the ^TMP global
+20 ;
+21 KILL ^TMP("PRCVRE",$JOB)
+22 SET PRCI=""
+23 FOR PRCI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+24 SET ^TMP("PRCVRE",$JOB,PRCSUB,PRCI)=HLNODE
SET PRCJ=0
+25 FOR
SET PRCJ=$ORDER(HLNODE(PRCJ))
if 'PRCJ
QUIT
SET ^TMP("PRCVRE",$JOB,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ)
+26 IF $EXTRACT(HLNODE,1,3)="ORC"
Begin DoDot:2
+27 SET PRCFCP=$PIECE(HLNODE,PRCFS,4)
SET PRCCC=$PIECE(HLNODE,PRCFS,18)
+28 SET TMP($JOB,PRCFCP,PRCCC)=""
End DoDot:2
End DoDot:1
+29 ;
+30 ;Validate that there is only one FCP and CC
+31 SET PRCFCP=""
SET PRCFCP1=""
+32 ; Prevent PRCCC1 undefined PRC*5.1*119
+33 SET PRCCC1=""
+34 FOR X8=1:1
SET PRCFCP=$ORDER(TMP($JOB,PRCFCP))
if PRCFCP=""
QUIT
Begin DoDot:1
+35 SET PRCFCP1=X8
+36 SET PRCCC=""
+37 FOR X9=1:1
SET PRCCC=$ORDER(TMP($JOB,PRCFCP,PRCCC))
if PRCCC=""
QUIT
Begin DoDot:2
+38 SET PRCCC1=X9
End DoDot:2
End DoDot:1
+39 IF (PRCFCP1>1)!(PRCCC1>1)
Begin DoDot:1
+40 SET $PIECE(^TMP("PRCVRIL",$JOB,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN")
DO NAKIT^PRCVREA
End DoDot:1
QUIT
+41 ;
PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP
+1 ;
+2 SET PRCI=0
SET PRCJ=0
SET LENVAL="OK"
+3 FOR
SET PRCI=$ORDER(^TMP("PRCVRE",$JOB,PRCSUB,PRCI))
if PRCI=""
QUIT
if LENVAL="NOTOK"
QUIT
Begin DoDot:1
+4 SET NODE1=$GET(^TMP("PRCVRE",$JOB,PRCSUB,PRCI))
if NODE1=""
QUIT
+5 FOR PRCJ=1:1
Begin DoDot:2
+6 SET NODE2=$GET(^TMP("PRCVRE",$JOB,PRCSUB,PRCI,PRCJ))
+7 IF $LENGTH(NODE1)+$LENGTH(NODE2)>1024
SET LENVAL="NOTOK"
QUIT
+8 SET NODE1=NODE1_NODE2
End DoDot:2
if $GET(^TMP("PRCVRE",$JOB,PRCSUB,PRCI,PRCJ))=""
QUIT
+9 if LENVAL="NOTOK"
QUIT
+10 SET PRCNODE=$EXTRACT(NODE1,1,3)
+11 ;
+12 ; IF MSH segment ignore the record
+13 ;
+14 IF PRCNODE="MSH"
QUIT
+15 SET PRCNODE2=$EXTRACT(NODE1,5,$LENGTH(NODE1))
+16 ;
+17 ; If ORC segment process the record
+18 ;
+19 IF PRCNODE="ORC"
Begin DoDot:2
+20 IF $DATA(^XTMP(PRCSUB,1))'=0
QUIT
+21 SET PRCORD=$PIECE(PRCNODE2,PRCFS,1)
SET DYNADATE=$PIECE(PRCNODE2,PRCFS,9)
SET PRCEMP=$PIECE($PIECE(PRCNODE2,PRCFS,10),PRCCS,1,3)
SET PRCSITE=$PIECE(PRCNODE2,PRCFS,21)
+22 SET PRCFCP=$PIECE(PRCNODE2,PRCFS,3)
SET PRCCC=$PIECE(PRCNODE2,PRCFS,17)
+23 SET PRCDATE=$$HL7TFM^XLFDT(DYNADATE)
+24 SET $PIECE(^XTMP(PRCSUB,1),U,1)=0
+25 SET $PIECE(^XTMP(PRCSUB,1),U,4)=PRCORD
SET $PIECE(^XTMP(PRCSUB,1),U,5)=PRCSITE
+26 SET $PIECE(^XTMP(PRCSUB,1),U,6)=PRCDATE
SET $PIECE(^XTMP(PRCSUB,1),U,7)=PRCEMP
End DoDot:2
QUIT
+27 ;
+28 ; If RQD segment process the record
+29 ;
+30 IF PRCNODE="RQD"
Begin DoDot:2
+31 SET PRCCTR=$PIECE(PRCNODE2,PRCFS,1)
+32 SET PRCDOC=$PIECE(PRCNODE2,PRCFS,2)
SET PRCITM=$PIECE(PRCNODE2,PRCFS,3)
+33 SET PRCQTY=$PIECE(PRCNODE2,PRCFS,5)
SET DYNADATE=$PIECE(PRCNODE2,PRCFS,10)
+34 SET PRCNEED=$$HL7TFM^XLFDT(DYNADATE)
End DoDot:2
QUIT
+35 ;
+36 ;If RQ1 segment process the record and build the XTMP global record
+37 ;
+38 IF PRCNODE="RQ1"
Begin DoDot:2
+39 SET PRCCOST=$PIECE(PRCNODE2,PRCFS,1)
SET PRCBOC=$PIECE(PRCNODE2,PRCFS,3)
SET PRCVND=$PIECE(PRCNODE2,PRCFS,4)
SET PRCNIF=$PIECE(PRCNODE2,PRCFS,5)
+40 ;
+41 ; Now build the XTMP record
+42 ;
+43 SET PRCVINDX=$PIECE($GET(^XTMP(PRCSUB,1)),U,1)
+44 IF PRCCTR>PRCVINDX
SET $PIECE(^XTMP(PRCSUB,1),U,1)=PRCCTR
+45 SET $PIECE(^XTMP(PRCSUB,1),U,2)=PRCFCP
+46 SET $PIECE(^XTMP(PRCSUB,1),U,3)=PRCCC
+47 SET ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC
End DoDot:2
QUIT
End DoDot:1
+48 ;
+49 IF LENVAL="NOTOK"
Begin DoDot:1
+50 SET $PIECE(^TMP("PRCVRIL",$JOB,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K"
+51 DO NAKIT^PRCVREA
+52 KILL ^XTMP(PRCSUB)
End DoDot:1
QUIT
+53 DO CALLIT^PRCVREA
+54 QUIT
+55 ;
BUILD ;Build the ^XTMP global zero node record.
+1 ;
+2 SET XX=$$HTFM^XLFDT($HOROLOG,1)
+3 SET X1=$$FMADD^XLFDT(XX,5)
+4 SET ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$HOROLOG
+5 QUIT
+6 ;
CLEANUP ;This area will kill all temporary globals and variables
+1 ;
+2 KILL ^TMP("PRCVRE",$JOB),TMP($JOB)
+3 KILL ^TMP("HLA",$JOB)
+4 KILL ^TMP("PRCVRIL",$JOB)
+5 KILL PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC
+6 KILL PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC
+7 KILL PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED
+8 KILL PRCFS,PRCCS,PRCRS,PRCVINDX
+9 KILL ERRARY
+10 KILL PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ
+11 KILL ACKCNT,NODE1,NODE2,LENVAL
+12 KILL X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1
+13 ;Fields killed here are used in PRCVREA
+14 KILL MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB
+15 KILL DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER
+16 KILL TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES
+17 QUIT
