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**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, 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=""
 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