PRCVIBH ;WOIFO/DST - Issue Book Processing, from DynaMed to IFCAP ;7/26/05 17:10
;;5.1;IFCAP;**81,86**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; IV - Internal Voucher, SV - Standard Voucher
Q
CRT ; Process Issue Book transactions sent from DynaMed to IFCAP
K HLERR
N %,PRCVDT,PRCVI,PRCVJ,PRCVK,PRCVIBF,PRCVSUB,PRCVSITE
D:'$D(U) DT^DICRW
D NOW^%DTC S PRCVDT=%
S PRCVSUB="PRCVFMS2;"_HL("MID")
K ^TMP(PRCVSUB),^TMP($J,"PRCVIB")
F PRCVI=1:1 X HLNEXT Q:HLQUIT'>0 D
. S ^TMP($J,"PRCVIB",PRCVI)=HLNODE,PRCVJ=0
. F S PRCVJ=$O(HLNODE(PRCVJ)) Q:'PRCVJ S ^TMP($J,"PRCVIB",PRCVI,PRCVJ)=HLNODE(PRCVJ)
. Q
;
MAIN ; Main routine
; Check HL7 message type and message event
; PRCVEA - Error message array
; PRCVTDT - Transaction Date
; PRCVDAC - Document Action
N PRCVFS,PRCVRS,PRCVCS,PRCVES,PRCVSS,PRCVCC,PRCVSCC
N PRCVEA,PRCVTDT,PRCVBID,PRCVLID,PRCVND,PRCVSEG,PRCVY,X,X1,X2
;
S PRCVK=0
S PRCVFS=$G(HL("FS")),PRCVCS=$E($G(HL("ECH"))),PRCVRS=$E($G(HL("ECH")),2),PRCVES=$E($G(HL("ECH")),U,3),PRCVSS=$E($G(HL("ECH")),U,4)
;
. D ADDERR("PRCV1"_U_"Wrong Message or Event Type: "_HL("MTN")_U_HL("ETN"))
. D GENACK("AR",HL("MID"),PRCVDT,.PRCVEA)
. Q
;
S X1=$P(PRCVDT,"."),X2=14 D C^%DTC
S ^TMP(PRCVSUB,$J,0)=X_U_$P(PRCVDT,".")_"^IB Sent from DynaMed to IFCAP"
;
; Check each segments - EVN,PID,FT1
; PRCVTCD - Transaction Code - "IV" or "SV"
; PRCVSTN - Station Number
;
START N PREVSEG,PRCVSTN,PRCVDAC,PRCVTDT,PRCVTCD
S PRCVSITE=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
S PREVSEG=""
S PRCVI=0
D NOW^%DTC S PRCVDT=%
F S PRCVI=$O(^TMP($J,"PRCVIB",PRCVI)) Q:'PRCVI D
. S PRCVND=$G(^TMP($J,"PRCVIB",PRCVI))
. S PRCVSEG=$P(PRCVND,PRCVFS)
. Q:PRCVSEG="MSH"!(PRCVSEG="")
. I $$CHKSEQ(PRCVSEG) K ^TMP($J,"PRCVIB") S PRCVI="" Q
. S PREVSEG=PRCVSEG
. D @PRCVSEG
. Q
I PRCVSEG'="FT1" D ADDERR("PRCV1"_U_"No Item line for this transaction.")
;
; If errored, send AE ACK, clean up and QUIT
ERR I $D(PRCVEA)!(PRCVTCD']"") D XTMP("AE"),FIN Q
OK ; Calling IFCAP and FMS routines for Issue Book and FMS update
;
I PRCVTCD="SV" D
. I '$$ENT^PRCVFMS2(PRCVSUB) D
.. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
.. D XTMP("AE")
.. Q
. Q
I PRCVTCD="IV" D
. S PRCVIBF=$$INIT^PRCVIBF(PRCVSUB)
. ; PRCVIBF - return "IEN of 410^Error Code^Error Description"
. ; If errored, move ^TMP to ^XTMP and quit
. I '+PRCVIBF D Q
.. D ADDERR("PRCV3"_U_$P(PRCVIBF,U,2)_"-"_$P(PRCVIBF,U,3))
.. D XTMP("AE")
.. Q
. I '$$ENT^PRCVFMS1(PRCVSUB,+PRCVIBF) D
.. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
.. D XTMP("AE")
.. Q
. Q
;
I '$D(PRCVEA) D GENACK("AA",HL("MID"),PRCVDT)
D FIN
Q
;
CHKSEQ(SEG) ; SEG - Segment name
N SEGERR,PREV1,PREV2,PRCVER1
S SEGERR=0
S PREV1=$P($P($T(@(SEG_1)),";;",2),U)
S PREV2=$P($P($T(@(SEG_1)),";;",2),U,2)
I PREVSEG=PREV1!(PREVSEG=PREV2) Q SEGERR
S SEGERR=1
S PRCVER1=$P($P($T(@(SEG_1)),";;",2),U,4)_SEG
D ADDERR("PRCV1"_U_PRCVER1)
Q SEGERR
;
EVN ; Process EVN segment
;
S PRCVSTN=$P(PRCVND,PRCVFS,8)
I PRCVSTN']"" D ADDERR("PRCV2"_U_"Station Number is missing.",8)
I PRCVSTN'=PRCVSITE D ADDERR("PRCV2"_U_"Invalid Station Number: "_PRCVSTN,8)
S PRCVDAC=$P(PRCVND,PRCVFS,5)
I "EMX"'[PRCVDAC!(PRCVDAC']"") D ADDERR("PRCV2"_U_"Invalid Document Action: "_PRCVDAC,5)
S PRCVTDT=$P(PRCVND,PRCVFS,3)
I PRCVTDT']"" D ADDERR("PRCV2"_U_"Transaction Date is missing.",3) Q
S PRCVTDT=$$HL7TFM^XLFDT(PRCVTDT,"L",0)
I $P(PRCVTDT,".")>PRCVDT D ADDERR("PRCV2"_U_"Invalid Transaction Date: "_PRCVTDT,3)
Q
;
PID ; Process PID segment
;
N PRCVDUZ,PRCVFCP1,PRCVFCP2,PRCVBOC,PRCVTERM
;
S PRCVBID=$P(PRCVND,PRCVFS,4)
I PRCVBID']"" D ADDERR("PRCV2"_U_"Batch ID is missing.",4)
S PRCVTCD=$P(PRCVND,PRCVFS,5)
I PRCVTCD']"" D ADDERR("PRCV2"_U_"Transaction Code is missing.",5)
I PRCVTCD'="IV",(PRCVTCD'="SV") D ADDERR("PRCV2"_U_"Invalid Transaction Code: "_PRCVTCD,5)
; Check User ID, Termination Date and is authorized FCP user
S PRCVDUZ=$P(PRCVND,PRCVFS,3)
I PRCVDUZ']"" D ADDERR("PRCV2"_U_"User ID is missing.",3)
I PRCVDUZ]"" D
. I '$$FIND1^DIC(200,"","","`"_PRCVDUZ,"","","PRCVERR") D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
. E D
.. S PRCVTERM=$$GET1^DIQ(200,PRCVDUZ_",",9.2,"I")
.. I +PRCVTERM>0,(PRCVTERM<DT) D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
.. Q
.Q
S PRCVFCP1=$P(PRCVND,PRCVFS,22)
I PRCVFCP1']"" D ADDERR("PRCV2"_U_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point is missing.",22)
I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP1)) D ADDERR("PRCV2"_U_"Invalid "_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
I $D(^PRC(420,PRCVSITE,1,+PRCVFCP1)),$P(^PRC(420,PRCVSITE,1,+PRCVFCP1,0),U,19) D ADDERR("PRCV2"_U_"Inactivated "_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
I PRCVTCD="IV" D
. S PRCVFCP2=$P(PRCVND,PRCVFS,24)
. I PRCVFCP2']"" D ADDERR("PRCV2"_U_"Buyer's Fund Control Point is missing.",24)
. E D
.. I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP2)) D ADDERR("PRCV2"_U_"Invalid Buyer's Fund Control Point.",24)
.. I $D(^PRC(420,PRCVSITE,1,+PRCVFCP2)),$P(^PRC(420,PRCVSITE,1,+PRCVFCP2,0),U,19) D ADDERR("PRCV2"_U_"Inactivated Buyer's Fund Control Point.",24)
.. Q
. S PRCVCC=$P(PRCVND,PRCVFS,19)
. I PRCVCC']"" D ADDERR("PRCV2"_U_"Buyer's Cost Center is missing.",19)
. S PRCVSCC=$P(PRCVND,PRCVFS,20)
. I PRCVSCC']"" D ADDERR("PRCV2"_U_"Buyer's Sub-cost Center is missing.",20)
. I PRCVCC,(PRCVSCC'="") D
.. I '$D(^PRCD(420.1,PRCVCC_PRCVSCC)) D ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not defined in Cost Center file 420.1",19) Q
.. I '$D(^PRC(420,PRCVSTN,1,+PRCVFCP2,2,PRCVCC_PRCVSCC)) D ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not used for this Fund Control Point.",19)
.. Q
. Q
I PRCVDUZ]"",('$D(^PRC(420,PRCVSTN,1,$S(PRCVTCD="IV":+PRCVFCP2,1:+PRCVFCP1),1,PRCVDUZ))) D ADDERR("PRCV2"_U_"Unauthorized User for this FCP.",3)
S ^TMP(PRCVSUB,$J,1)=PRCVSTN_U_PRCVBID_U_PRCVTCD_U_PRCVDAC_U_PRCVTDT_U_PRCVDUZ
S ^TMP(PRCVSUB,$J,2)=PRCVFCP1_U_$G(PRCVFCP2)_U_$G(PRCVCC)_U_$G(PRCVSCC)
Q
;
FT1 ; Process FT1 segment
N PRCVACC,PRCVBOC,PRCVINV,PRCVSAL,PRCVRCD
;
S PRCVLID=$P(PRCVND,PRCVFS,3)
I 'PRCVLID D ADDERR("PRCV2"_U_"Line ID is missing.",3)
S PRCVACC=$P(PRCVND,PRCVFS,9)
I 'PRCVACC D ADDERR("PRCV2"_U_"Account Code is missing.",9)
I PRCVACC,((PRCVACC'?1N)!("12368"'[PRCVACC)) D ADDERR("PRCV2"_U_"Invalid Account Code: "_PRCVACC,9)
I PRCVTCD="IV" D
. S PRCVBOC=$P(PRCVND,PRCVFS,10)
. I PRCVBOC=2696 D ADDERR("PRCV2"_U_"Invalid Buyer's Budget Object Code: "_PRCVBOC,10)
. I 'PRCVBOC D ADDERR("PRCV2"_U_"Budget Object Code is missing.",10)
. I '$D(^PRCD(420.1,PRCVCC_PRCVSCC,1,PRCVBOC)) D ADDERR("PRCV2"_U_"Invalid Budget Object Code for this Cost Center: "_PRCVBOC,10)
. I $P($G(^PRCD(420.2,PRCVBOC,0)),"^",2)=1 D ADDERR("PRCV2"_U_"Inactivated Budget Object Code: "_PRCVBOC,10)
. S PRCVSAL=$P(PRCVND,PRCVFS,13)
. I 'PRCVSAL D ADDERR("PRCV2"_U_"Sale Value is missing.",13)
. Q
S PRCVINV=$P(PRCVND,PRCVFS,12)
I 'PRCVINV D ADDERR("PRCV2"_U_"Inventory Value is missing.",12)
I PRCVTCD="SV" D
. S PRCVRCD=$P(PRCVND,PRCVFS,8)
. I PRCVRCD']"" D ADDERR("PRCV2"_U_"Reason Code is missing.",8)
. I PRCVRCD'?1N!(PRCVRCD<1)!(PRCVRCD>7) D ADDERR("PRCV2"_U_"Invalid Reason Code: "_PRCVRCD,8)
. Q
S ^TMP(PRCVSUB,$J,3,0)=PRCVLID
S ^TMP(PRCVSUB,$J,3,PRCVLID,0)=PRCVLID_U_PRCVACC_U_$G(PRCVBOC)_U_PRCVINV_U_$G(PRCVSAL)_U_$G(PRCVRCD)
Q
;
GENACK(PRCVAC,PRCVMCID,PRCVDT,PRCVOCCR) ;
;
;PRCVAC - Acknowledgment Code
;PRCVMCID - Message Control ID which you're acknowledging
;PRCVDT - Date/Time of Transaction
;PRCVOCCR - Error message array
;
N PRCVFS,PRCVCNT,PRCVCS,PRCVI,PRCVJ,PRCVND,PRCVRES
;
S PRCVFS=$G(HL("FS")),PRCVCS=$E($G(HL("ECH"))),PRCVRS=$E($G(HL("ECH")),2),PRCVES=$E($G(HL("ECH")),U,3),PRCVSS=$E($G(HL("ECH")),U,4)
S PRCVRES="",PRCVJ=0,PRCVI=1
;
; MSA Segment
S HLA("HLA",1)="MSA"_PRCVFS_PRCVAC_PRCVFS_PRCVMCID_PRCVFS_$G(PRCVBID)
;
; ERR Segment
I $G(PRCVOCCR)'="" D
. F S PRCVJ=$O(PRCVOCCR(PRCVJ)) Q:'PRCVJ D
.. S PRCVI=PRCVI+1
.. S HLA("HLA",PRCVI)="ERR"_PRCVFS_PRCVOCCR(PRCVJ)
.. Q
. Q
;
D GENACK^HLMA1(HL("EID"),$G(HLMTIENS),HL("EIDS"),"LM",1,PRCVRES)
I $P($G(PRCVRES),U,2) D
. K XMB,XMZ
. S XMB="PRCV HL7 ERROR"
. S XMB(1)="PRCVIB"
. S XMB(2)="Application Acknowledgement"
. S XMB(3)="PRCV_IFCAP_06_SU_IB_PROC"
. S XMB(4)=PRCVRES
. S XMDUZ="PRCV HL7 Generator"
. D ^XMB
. K XMB,XMDUZ,XMZ
. Q
;
K HLA("HLA"),^TMP("HLA",$J)
K PRCVAC,X
Q
;
ADDERR(PRCVER,PRCVFD) ;
; PRCVER - Error message
; PRCVFD - Field number, if any
;
S PRCVK=PRCVK+1
S PRCVEA=PRCVK
S:'$G(PRCVLID) PRCVLID=1
S:'$G(PRCVFD) PRCVLID="",PRCVFD=""
S PRCVEA(PRCVK)=PRCVFS_$G(PRCVSEG)_U_PRCVLID_U_PRCVFD_PRCVFS_"207^Application Internal Error^HL70357"_PRCVFS_"E"_PRCVFS_PRCVER_PRCVFS_PRCVLID
Q
;
XTMP(AC) ; Move ^TMP(PRCVSUB,$j) to ^XTMP
;
; AC - Acknowledgement
;
S ^XTMP(PRCVSUB,0)=$$FMADD^XLFDT(PRCVDT,14)_U_PRCVDT_U_"IB Data from DynaMed with error"
F PRCVI=1,2 S ^XTMP(PRCVSUB,PRCVI)=^TMP(PRCVSUB,$J,PRCVI)
I $D(^TMP(PRCVSUB,$J,3,0)) D
. S ^XTMP(PRCVSUB,3,0)=^TMP(PRCVSUB,$J,3,0)
. S PRCVI=0
. F S PRCVI=$O(^TMP(PRCVSUB,$J,3,PRCVI)) Q:'PRCVI D
.. S ^XTMP(PRCVSUB,3,PRCVI)=^TMP(PRCVSUB,$J,3,PRCVI,0)
.. Q
D GENACK(AC,HL("MID"),PRCVDT,.PRCVEA)
S ^XTMP(PRCVSUB,4,0)=PRCVEA
S PRCVI=0
F S PRCVI=$O(PRCVEA(PRCVI)) Q:'PRCVI D
. S ^XTMP(PRCVSUB,4,PRCVI)=PRCVEA(PRCVI)
. Q
Q
;
FIN ; Clean up
;
; K ^TMP($J,"PRCVIB")
; K ^TMP(PRCVSUB,$J)
K PRCVEA
Q
;
TXT ;
EVN1 ;;^EVN^^Missing segment ^100^Missing line item info.
PID1 ;;EVN^^^Missing segment ^100^Missing line item info.
FT11 ;;PID^FT1^^Missing segment ^100^Missing line item info.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVIBH 9988 printed Dec 13, 2024@02:20:02 Page 2
PRCVIBH ;WOIFO/DST - Issue Book Processing, from DynaMed to IFCAP ;7/26/05 17:10
+1 ;;5.1;IFCAP;**81,86**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; IV - Internal Voucher, SV - Standard Voucher
+5 QUIT
CRT ; Process Issue Book transactions sent from DynaMed to IFCAP
+1 KILL HLERR
+2 NEW %,PRCVDT,PRCVI,PRCVJ,PRCVK,PRCVIBF,PRCVSUB,PRCVSITE
+3 if '$DATA(U)
DO DT^DICRW
+4 DO NOW^%DTC
SET PRCVDT=%
+5 SET PRCVSUB="PRCVFMS2;"_HL("MID")
+6 KILL ^TMP(PRCVSUB),^TMP($JOB,"PRCVIB")
+7 FOR PRCVI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET ^TMP($JOB,"PRCVIB",PRCVI)=HLNODE
SET PRCVJ=0
+9 FOR
SET PRCVJ=$ORDER(HLNODE(PRCVJ))
if 'PRCVJ
QUIT
SET ^TMP($JOB,"PRCVIB",PRCVI,PRCVJ)=HLNODE(PRCVJ)
+10 QUIT
End DoDot:1
+11 ;
MAIN ; Main routine
+1 ; Check HL7 message type and message event
+2 ; PRCVEA - Error message array
+3 ; PRCVTDT - Transaction Date
+4 ; PRCVDAC - Document Action
+5 NEW PRCVFS,PRCVRS,PRCVCS,PRCVES,PRCVSS,PRCVCC,PRCVSCC
+6 NEW PRCVEA,PRCVTDT,PRCVBID,PRCVLID,PRCVND,PRCVSEG,PRCVY,X,X1,X2
+7 ;
+8 SET PRCVK=0
+9 SET PRCVFS=$GET(HL("FS"))
SET PRCVCS=$EXTRACT($GET(HL("ECH")))
SET PRCVRS=$EXTRACT($GET(HL("ECH")),2)
SET PRCVES=$EXTRACT($GET(HL("ECH")),U,3)
SET PRCVSS=$EXTRACT($GET(HL("ECH")),U,4)
+10 ;
Begin DoDot:1
+1 DO ADDERR("PRCV1"_U_"Wrong Message or Event Type: "_HL("MTN")_U_HL("ETN"))
+2 DO GENACK("AR",HL("MID"),PRCVDT,.PRCVEA)
+3 QUIT
End DoDot:1
QUIT
+4 ;
+5 SET X1=$PIECE(PRCVDT,".")
SET X2=14
DO C^%DTC
+6 SET ^TMP(PRCVSUB,$JOB,0)=X_U_$PIECE(PRCVDT,".")_"^IB Sent from DynaMed to IFCAP"
+7 ;
+8 ; Check each segments - EVN,PID,FT1
+9 ; PRCVTCD - Transaction Code - "IV" or "SV"
+10 ; PRCVSTN - Station Number
+11 ;
START NEW PREVSEG,PRCVSTN,PRCVDAC,PRCVTDT,PRCVTCD
+1 SET PRCVSITE=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+2 SET PREVSEG=""
+3 SET PRCVI=0
+4 DO NOW^%DTC
SET PRCVDT=%
+5 FOR
SET PRCVI=$ORDER(^TMP($JOB,"PRCVIB",PRCVI))
if 'PRCVI
QUIT
Begin DoDot:1
+6 SET PRCVND=$GET(^TMP($JOB,"PRCVIB",PRCVI))
+7 SET PRCVSEG=$PIECE(PRCVND,PRCVFS)
+8 if PRCVSEG="MSH"!(PRCVSEG="")
QUIT
+9 IF $$CHKSEQ(PRCVSEG)
KILL ^TMP($JOB,"PRCVIB")
SET PRCVI=""
QUIT
+10 SET PREVSEG=PRCVSEG
+11 DO @PRCVSEG
+12 QUIT
End DoDot:1
+13 IF PRCVSEG'="FT1"
DO ADDERR("PRCV1"_U_"No Item line for this transaction.")
+14 ;
+15 ; If errored, send AE ACK, clean up and QUIT
ERR IF $DATA(PRCVEA)!(PRCVTCD']"")
DO XTMP("AE")
DO FIN
QUIT
OK ; Calling IFCAP and FMS routines for Issue Book and FMS update
+1 ;
+2 IF PRCVTCD="SV"
Begin DoDot:1
+3 IF '$$ENT^PRCVFMS2(PRCVSUB)
Begin DoDot:2
+4 DO ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
+5 DO XTMP("AE")
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 IF PRCVTCD="IV"
Begin DoDot:1
+9 SET PRCVIBF=$$INIT^PRCVIBF(PRCVSUB)
+10 ; PRCVIBF - return "IEN of 410^Error Code^Error Description"
+11 ; If errored, move ^TMP to ^XTMP and quit
+12 IF '+PRCVIBF
Begin DoDot:2
+13 DO ADDERR("PRCV3"_U_$PIECE(PRCVIBF,U,2)_"-"_$PIECE(PRCVIBF,U,3))
+14 DO XTMP("AE")
+15 QUIT
End DoDot:2
QUIT
+16 IF '$$ENT^PRCVFMS1(PRCVSUB,+PRCVIBF)
Begin DoDot:2
+17 DO ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
+18 DO XTMP("AE")
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;
+22 IF '$DATA(PRCVEA)
DO GENACK("AA",HL("MID"),PRCVDT)
+23 DO FIN
+24 QUIT
+25 ;
CHKSEQ(SEG) ; SEG - Segment name
+1 NEW SEGERR,PREV1,PREV2,PRCVER1
+2 SET SEGERR=0
+3 SET PREV1=$PIECE($PIECE($TEXT(@(SEG_1)),";;",2),U)
+4 SET PREV2=$PIECE($PIECE($TEXT(@(SEG_1)),";;",2),U,2)
+5 IF PREVSEG=PREV1!(PREVSEG=PREV2)
QUIT SEGERR
+6 SET SEGERR=1
+7 SET PRCVER1=$PIECE($PIECE($TEXT(@(SEG_1)),";;",2),U,4)_SEG
+8 DO ADDERR("PRCV1"_U_PRCVER1)
+9 QUIT SEGERR
+10 ;
EVN ; Process EVN segment
+1 ;
+2 SET PRCVSTN=$PIECE(PRCVND,PRCVFS,8)
+3 IF PRCVSTN']""
DO ADDERR("PRCV2"_U_"Station Number is missing.",8)
+4 IF PRCVSTN'=PRCVSITE
DO ADDERR("PRCV2"_U_"Invalid Station Number: "_PRCVSTN,8)
+5 SET PRCVDAC=$PIECE(PRCVND,PRCVFS,5)
+6 IF "EMX"'[PRCVDAC!(PRCVDAC']"")
DO ADDERR("PRCV2"_U_"Invalid Document Action: "_PRCVDAC,5)
+7 SET PRCVTDT=$PIECE(PRCVND,PRCVFS,3)
+8 IF PRCVTDT']""
DO ADDERR("PRCV2"_U_"Transaction Date is missing.",3)
QUIT
+9 SET PRCVTDT=$$HL7TFM^XLFDT(PRCVTDT,"L",0)
+10 IF $PIECE(PRCVTDT,".")>PRCVDT
DO ADDERR("PRCV2"_U_"Invalid Transaction Date: "_PRCVTDT,3)
+11 QUIT
+12 ;
PID ; Process PID segment
+1 ;
+2 NEW PRCVDUZ,PRCVFCP1,PRCVFCP2,PRCVBOC,PRCVTERM
+3 ;
+4 SET PRCVBID=$PIECE(PRCVND,PRCVFS,4)
+5 IF PRCVBID']""
DO ADDERR("PRCV2"_U_"Batch ID is missing.",4)
+6 SET PRCVTCD=$PIECE(PRCVND,PRCVFS,5)
+7 IF PRCVTCD']""
DO ADDERR("PRCV2"_U_"Transaction Code is missing.",5)
+8 IF PRCVTCD'="IV"
IF (PRCVTCD'="SV")
DO ADDERR("PRCV2"_U_"Invalid Transaction Code: "_PRCVTCD,5)
+9 ; Check User ID, Termination Date and is authorized FCP user
+10 SET PRCVDUZ=$PIECE(PRCVND,PRCVFS,3)
+11 IF PRCVDUZ']""
DO ADDERR("PRCV2"_U_"User ID is missing.",3)
+12 IF PRCVDUZ]""
Begin DoDot:1
+13 IF '$$FIND1^DIC(200,"","","`"_PRCVDUZ,"","","PRCVERR")
DO ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
+14 IF '$TEST
Begin DoDot:2
+15 SET PRCVTERM=$$GET1^DIQ(200,PRCVDUZ_",",9.2,"I")
+16 IF +PRCVTERM>0
IF (PRCVTERM<DT)
DO ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 SET PRCVFCP1=$PIECE(PRCVND,PRCVFS,22)
+20 IF PRCVFCP1']""
DO ADDERR("PRCV2"_U_$SELECT(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point is missing.",22)
+21 IF '$DATA(^PRC(420,PRCVSITE,1,+PRCVFCP1))
DO ADDERR("PRCV2"_U_"Invalid "_$SELECT(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
+22 IF $DATA(^PRC(420,PRCVSITE,1,+PRCVFCP1))
IF $PIECE(^PRC(420,PRCVSITE,1,+PRCVFCP1,0),U,19)
DO ADDERR("PRCV2"_U_"Inactivated "_$SELECT(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
+23 IF PRCVTCD="IV"
Begin DoDot:1
+24 SET PRCVFCP2=$PIECE(PRCVND,PRCVFS,24)
+25 IF PRCVFCP2']""
DO ADDERR("PRCV2"_U_"Buyer's Fund Control Point is missing.",24)
+26 IF '$TEST
Begin DoDot:2
+27 IF '$DATA(^PRC(420,PRCVSITE,1,+PRCVFCP2))
DO ADDERR("PRCV2"_U_"Invalid Buyer's Fund Control Point.",24)
+28 IF $DATA(^PRC(420,PRCVSITE,1,+PRCVFCP2))
IF $PIECE(^PRC(420,PRCVSITE,1,+PRCVFCP2,0),U,19)
DO ADDERR("PRCV2"_U_"Inactivated Buyer's Fund Control Point.",24)
+29 QUIT
End DoDot:2
+30 SET PRCVCC=$PIECE(PRCVND,PRCVFS,19)
+31 IF PRCVCC']""
DO ADDERR("PRCV2"_U_"Buyer's Cost Center is missing.",19)
+32 SET PRCVSCC=$PIECE(PRCVND,PRCVFS,20)
+33 IF PRCVSCC']""
DO ADDERR("PRCV2"_U_"Buyer's Sub-cost Center is missing.",20)
+34 IF PRCVCC
IF (PRCVSCC'="")
Begin DoDot:2
+35 IF '$DATA(^PRCD(420.1,PRCVCC_PRCVSCC))
DO ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not defined in Cost Center file 420.1",19)
QUIT
+36 IF '$DATA(^PRC(420,PRCVSTN,1,+PRCVFCP2,2,PRCVCC_PRCVSCC))
DO ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not used for this Fund Control Point.",19)
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 IF PRCVDUZ]""
IF ('$DATA(^PRC(420,PRCVSTN,1,$SELECT(PRCVTCD="IV":+PRCVFCP2,1:+PRCVFCP1),1,PRCVDUZ)))
DO ADDERR("PRCV2"_U_"Unauthorized User for this FCP.",3)
+40 SET ^TMP(PRCVSUB,$JOB,1)=PRCVSTN_U_PRCVBID_U_PRCVTCD_U_PRCVDAC_U_PRCVTDT_U_PRCVDUZ
+41 SET ^TMP(PRCVSUB,$JOB,2)=PRCVFCP1_U_$GET(PRCVFCP2)_U_$GET(PRCVCC)_U_$GET(PRCVSCC)
+42 QUIT
+43 ;
FT1 ; Process FT1 segment
+1 NEW PRCVACC,PRCVBOC,PRCVINV,PRCVSAL,PRCVRCD
+2 ;
+3 SET PRCVLID=$PIECE(PRCVND,PRCVFS,3)
+4 IF 'PRCVLID
DO ADDERR("PRCV2"_U_"Line ID is missing.",3)
+5 SET PRCVACC=$PIECE(PRCVND,PRCVFS,9)
+6 IF 'PRCVACC
DO ADDERR("PRCV2"_U_"Account Code is missing.",9)
+7 IF PRCVACC
IF ((PRCVACC'?1N)!("12368"'[PRCVACC))
DO ADDERR("PRCV2"_U_"Invalid Account Code: "_PRCVACC,9)
+8 IF PRCVTCD="IV"
Begin DoDot:1
+9 SET PRCVBOC=$PIECE(PRCVND,PRCVFS,10)
+10 IF PRCVBOC=2696
DO ADDERR("PRCV2"_U_"Invalid Buyer's Budget Object Code: "_PRCVBOC,10)
+11 IF 'PRCVBOC
DO ADDERR("PRCV2"_U_"Budget Object Code is missing.",10)
+12 IF '$DATA(^PRCD(420.1,PRCVCC_PRCVSCC,1,PRCVBOC))
DO ADDERR("PRCV2"_U_"Invalid Budget Object Code for this Cost Center: "_PRCVBOC,10)
+13 IF $PIECE($GET(^PRCD(420.2,PRCVBOC,0)),"^",2)=1
DO ADDERR("PRCV2"_U_"Inactivated Budget Object Code: "_PRCVBOC,10)
+14 SET PRCVSAL=$PIECE(PRCVND,PRCVFS,13)
+15 IF 'PRCVSAL
DO ADDERR("PRCV2"_U_"Sale Value is missing.",13)
+16 QUIT
End DoDot:1
+17 SET PRCVINV=$PIECE(PRCVND,PRCVFS,12)
+18 IF 'PRCVINV
DO ADDERR("PRCV2"_U_"Inventory Value is missing.",12)
+19 IF PRCVTCD="SV"
Begin DoDot:1
+20 SET PRCVRCD=$PIECE(PRCVND,PRCVFS,8)
+21 IF PRCVRCD']""
DO ADDERR("PRCV2"_U_"Reason Code is missing.",8)
+22 IF PRCVRCD'?1N!(PRCVRCD<1)!(PRCVRCD>7)
DO ADDERR("PRCV2"_U_"Invalid Reason Code: "_PRCVRCD,8)
+23 QUIT
End DoDot:1
+24 SET ^TMP(PRCVSUB,$JOB,3,0)=PRCVLID
+25 SET ^TMP(PRCVSUB,$JOB,3,PRCVLID,0)=PRCVLID_U_PRCVACC_U_$GET(PRCVBOC)_U_PRCVINV_U_$GET(PRCVSAL)_U_$GET(PRCVRCD)
+26 QUIT
+27 ;
GENACK(PRCVAC,PRCVMCID,PRCVDT,PRCVOCCR) ;
+1 ;
+2 ;PRCVAC - Acknowledgment Code
+3 ;PRCVMCID - Message Control ID which you're acknowledging
+4 ;PRCVDT - Date/Time of Transaction
+5 ;PRCVOCCR - Error message array
+6 ;
+7 NEW PRCVFS,PRCVCNT,PRCVCS,PRCVI,PRCVJ,PRCVND,PRCVRES
+8 ;
+9 SET PRCVFS=$GET(HL("FS"))
SET PRCVCS=$EXTRACT($GET(HL("ECH")))
SET PRCVRS=$EXTRACT($GET(HL("ECH")),2)
SET PRCVES=$EXTRACT($GET(HL("ECH")),U,3)
SET PRCVSS=$EXTRACT($GET(HL("ECH")),U,4)
+10 SET PRCVRES=""
SET PRCVJ=0
SET PRCVI=1
+11 ;
+12 ; MSA Segment
+13 SET HLA("HLA",1)="MSA"_PRCVFS_PRCVAC_PRCVFS_PRCVMCID_PRCVFS_$GET(PRCVBID)
+14 ;
+15 ; ERR Segment
+16 IF $GET(PRCVOCCR)'=""
Begin DoDot:1
+17 FOR
SET PRCVJ=$ORDER(PRCVOCCR(PRCVJ))
if 'PRCVJ
QUIT
Begin DoDot:2
+18 SET PRCVI=PRCVI+1
+19 SET HLA("HLA",PRCVI)="ERR"_PRCVFS_PRCVOCCR(PRCVJ)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 ;
+23 DO GENACK^HLMA1(HL("EID"),$GET(HLMTIENS),HL("EIDS"),"LM",1,PRCVRES)
+24 IF $PIECE($GET(PRCVRES),U,2)
Begin DoDot:1
+25 KILL XMB,XMZ
+26 SET XMB="PRCV HL7 ERROR"
+27 SET XMB(1)="PRCVIB"
+28 SET XMB(2)="Application Acknowledgement"
+29 SET XMB(3)="PRCV_IFCAP_06_SU_IB_PROC"
+30 SET XMB(4)=PRCVRES
+31 SET XMDUZ="PRCV HL7 Generator"
+32 DO ^XMB
+33 KILL XMB,XMDUZ,XMZ
+34 QUIT
End DoDot:1
+35 ;
+36 KILL HLA("HLA"),^TMP("HLA",$JOB)
+37 KILL PRCVAC,X
+38 QUIT
+39 ;
ADDERR(PRCVER,PRCVFD) ;
+1 ; PRCVER - Error message
+2 ; PRCVFD - Field number, if any
+3 ;
+4 SET PRCVK=PRCVK+1
+5 SET PRCVEA=PRCVK
+6 if '$GET(PRCVLID)
SET PRCVLID=1
+7 if '$GET(PRCVFD)
SET PRCVLID=""
SET PRCVFD=""
+8 SET PRCVEA(PRCVK)=PRCVFS_$GET(PRCVSEG)_U_PRCVLID_U_PRCVFD_PRCVFS_"207^Application Internal Error^HL70357"_PRCVFS_"E"_PRCVFS_PRCVER_PRCVFS_PRCVLID
+9 QUIT
+10 ;
XTMP(AC) ; Move ^TMP(PRCVSUB,$j) to ^XTMP
+1 ;
+2 ; AC - Acknowledgement
+3 ;
+4 SET ^XTMP(PRCVSUB,0)=$$FMADD^XLFDT(PRCVDT,14)_U_PRCVDT_U_"IB Data from DynaMed with error"
+5 FOR PRCVI=1,2
SET ^XTMP(PRCVSUB,PRCVI)=^TMP(PRCVSUB,$JOB,PRCVI)
+6 IF $DATA(^TMP(PRCVSUB,$JOB,3,0))
Begin DoDot:1
+7 SET ^XTMP(PRCVSUB,3,0)=^TMP(PRCVSUB,$JOB,3,0)
+8 SET PRCVI=0
+9 FOR
SET PRCVI=$ORDER(^TMP(PRCVSUB,$JOB,3,PRCVI))
if 'PRCVI
QUIT
Begin DoDot:2
+10 SET ^XTMP(PRCVSUB,3,PRCVI)=^TMP(PRCVSUB,$JOB,3,PRCVI,0)
+11 QUIT
End DoDot:2
End DoDot:1
+12 DO GENACK(AC,HL("MID"),PRCVDT,.PRCVEA)
+13 SET ^XTMP(PRCVSUB,4,0)=PRCVEA
+14 SET PRCVI=0
+15 FOR
SET PRCVI=$ORDER(PRCVEA(PRCVI))
if 'PRCVI
QUIT
Begin DoDot:1
+16 SET ^XTMP(PRCVSUB,4,PRCVI)=PRCVEA(PRCVI)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
FIN ; Clean up
+1 ;
+2 ; K ^TMP($J,"PRCVIB")
+3 ; K ^TMP(PRCVSUB,$J)
+4 KILL PRCVEA
+5 QUIT
+6 ;
TXT ;
EVN1 ;;^EVN^^Missing segment ^100^Missing line item info.
PID1 ;;EVN^^^Missing segment ^100^Missing line item info.
FT11 ;;PID^FT1^^Missing segment ^100^Missing line item info.
