[613] | 1 | PRCVIBH ;WOIFO/DST - Issue Book Processing, from DynaMed to IFCAP ;7/26/05 17:10
|
---|
| 2 | ;;5.1;IFCAP;**81,86**;Oct 20, 2000
|
---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | ;
|
---|
| 5 | ; IV - Internal Voucher, SV - Standard Voucher
|
---|
| 6 | Q
|
---|
| 7 | CRT ; Process Issue Book transactions sent from DynaMed to IFCAP
|
---|
| 8 | K HLERR
|
---|
| 9 | N %,PRCVDT,PRCVI,PRCVJ,PRCVK,PRCVIBF,PRCVSUB,PRCVSITE
|
---|
| 10 | D:'$D(U) DT^DICRW
|
---|
| 11 | D NOW^%DTC S PRCVDT=%
|
---|
| 12 | S PRCVSUB="PRCVFMS2;"_HL("MID")
|
---|
| 13 | K ^TMP(PRCVSUB),^TMP($J,"PRCVIB")
|
---|
| 14 | F PRCVI=1:1 X HLNEXT Q:HLQUIT'>0 D
|
---|
| 15 | . S ^TMP($J,"PRCVIB",PRCVI)=HLNODE,PRCVJ=0
|
---|
| 16 | . F S PRCVJ=$O(HLNODE(PRCVJ)) Q:'PRCVJ S ^TMP($J,"PRCVIB",PRCVI,PRCVJ)=HLNODE(PRCVJ)
|
---|
| 17 | . Q
|
---|
| 18 | ;
|
---|
| 19 | MAIN ; Main routine
|
---|
| 20 | ; Check HL7 message type and message event
|
---|
| 21 | ; PRCVEA - Error message array
|
---|
| 22 | ; PRCVTDT - Transaction Date
|
---|
| 23 | ; PRCVDAC - Document Action
|
---|
| 24 | N PRCVFS,PRCVRS,PRCVCS,PRCVES,PRCVSS,PRCVCC,PRCVSCC
|
---|
| 25 | N PRCVEA,PRCVTDT,PRCVBID,PRCVLID,PRCVND,PRCVSEG,PRCVY,X,X1,X2
|
---|
| 26 | ;
|
---|
| 27 | S PRCVK=0
|
---|
| 28 | 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)
|
---|
| 29 | ;
|
---|
| 30 | HEADER I HL("MTN")'="DFT"!(HL("ETN")'="P03") D Q
|
---|
| 31 | . D ADDERR("PRCV1"_U_"Wrong Message or Event Type: "_HL("MTN")_U_HL("ETN"))
|
---|
| 32 | . D GENACK("AR",HL("MID"),PRCVDT,.PRCVEA)
|
---|
| 33 | . Q
|
---|
| 34 | ;
|
---|
| 35 | S X1=$P(PRCVDT,"."),X2=14 D C^%DTC
|
---|
| 36 | S ^TMP(PRCVSUB,$J,0)=X_U_$P(PRCVDT,".")_"^IB Sent from DynaMed to IFCAP"
|
---|
| 37 | ;
|
---|
| 38 | ; Check each segments - EVN,PID,FT1
|
---|
| 39 | ; PRCVTCD - Transaction Code - "IV" or "SV"
|
---|
| 40 | ; PRCVSTN - Station Number
|
---|
| 41 | ;
|
---|
| 42 | START N PREVSEG,PRCVSTN,PRCVDAC,PRCVTDT,PRCVTCD
|
---|
| 43 | S PRCVSITE=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
---|
| 44 | S PREVSEG=""
|
---|
| 45 | S PRCVI=0
|
---|
| 46 | D NOW^%DTC S PRCVDT=%
|
---|
| 47 | F S PRCVI=$O(^TMP($J,"PRCVIB",PRCVI)) Q:'PRCVI D
|
---|
| 48 | . S PRCVND=$G(^TMP($J,"PRCVIB",PRCVI))
|
---|
| 49 | . S PRCVSEG=$P(PRCVND,PRCVFS)
|
---|
| 50 | . Q:PRCVSEG="MSH"!(PRCVSEG="")
|
---|
| 51 | . I $$CHKSEQ(PRCVSEG) K ^TMP($J,"PRCVIB") S PRCVI="" Q
|
---|
| 52 | . S PREVSEG=PRCVSEG
|
---|
| 53 | . D @PRCVSEG
|
---|
| 54 | . Q
|
---|
| 55 | I PRCVSEG'="FT1" D ADDERR("PRCV1"_U_"No Item line for this transaction.")
|
---|
| 56 | ;
|
---|
| 57 | ; If errored, send AE ACK, clean up and QUIT
|
---|
| 58 | ERR I $D(PRCVEA)!(PRCVTCD']"") D XTMP("AE"),FIN Q
|
---|
| 59 | OK ; Calling IFCAP and FMS routines for Issue Book and FMS update
|
---|
| 60 | ;
|
---|
| 61 | I PRCVTCD="SV" D
|
---|
| 62 | . I '$$ENT^PRCVFMS2(PRCVSUB) D
|
---|
| 63 | .. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
|
---|
| 64 | .. D XTMP("AE")
|
---|
| 65 | .. Q
|
---|
| 66 | . Q
|
---|
| 67 | I PRCVTCD="IV" D
|
---|
| 68 | . S PRCVIBF=$$INIT^PRCVIBF(PRCVSUB)
|
---|
| 69 | . ; PRCVIBF - return "IEN of 410^Error Code^Error Description"
|
---|
| 70 | . ; If errored, move ^TMP to ^XTMP and quit
|
---|
| 71 | . I '+PRCVIBF D Q
|
---|
| 72 | .. D ADDERR("PRCV3"_U_$P(PRCVIBF,U,2)_"-"_$P(PRCVIBF,U,3))
|
---|
| 73 | .. D XTMP("AE")
|
---|
| 74 | .. Q
|
---|
| 75 | . I '$$ENT^PRCVFMS1(PRCVSUB,+PRCVIBF) D
|
---|
| 76 | .. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
|
---|
| 77 | .. D XTMP("AE")
|
---|
| 78 | .. Q
|
---|
| 79 | . Q
|
---|
| 80 | ;
|
---|
| 81 | I '$D(PRCVEA) D GENACK("AA",HL("MID"),PRCVDT)
|
---|
| 82 | D FIN
|
---|
| 83 | Q
|
---|
| 84 | ;
|
---|
| 85 | CHKSEQ(SEG) ; SEG - Segment name
|
---|
| 86 | N SEGERR,PREV1,PREV2,PRCVER1
|
---|
| 87 | S SEGERR=0
|
---|
| 88 | S PREV1=$P($P($T(@(SEG_1)),";;",2),U)
|
---|
| 89 | S PREV2=$P($P($T(@(SEG_1)),";;",2),U,2)
|
---|
| 90 | I PREVSEG=PREV1!(PREVSEG=PREV2) Q SEGERR
|
---|
| 91 | S SEGERR=1
|
---|
| 92 | S PRCVER1=$P($P($T(@(SEG_1)),";;",2),U,4)_SEG
|
---|
| 93 | D ADDERR("PRCV1"_U_PRCVER1)
|
---|
| 94 | Q SEGERR
|
---|
| 95 | ;
|
---|
| 96 | EVN ; Process EVN segment
|
---|
| 97 | ;
|
---|
| 98 | S PRCVSTN=$P(PRCVND,PRCVFS,8)
|
---|
| 99 | I PRCVSTN']"" D ADDERR("PRCV2"_U_"Station Number is missing.",8)
|
---|
| 100 | I PRCVSTN'=PRCVSITE D ADDERR("PRCV2"_U_"Invalid Station Number: "_PRCVSTN,8)
|
---|
| 101 | S PRCVDAC=$P(PRCVND,PRCVFS,5)
|
---|
| 102 | I "EMX"'[PRCVDAC!(PRCVDAC']"") D ADDERR("PRCV2"_U_"Invalid Document Action: "_PRCVDAC,5)
|
---|
| 103 | S PRCVTDT=$P(PRCVND,PRCVFS,3)
|
---|
| 104 | I PRCVTDT']"" D ADDERR("PRCV2"_U_"Transaction Date is missing.",3) Q
|
---|
| 105 | S PRCVTDT=$$HL7TFM^XLFDT(PRCVTDT,"L",0)
|
---|
| 106 | I $P(PRCVTDT,".")>PRCVDT D ADDERR("PRCV2"_U_"Invalid Transaction Date: "_PRCVTDT,3)
|
---|
| 107 | Q
|
---|
| 108 | ;
|
---|
| 109 | PID ; Process PID segment
|
---|
| 110 | ;
|
---|
| 111 | N PRCVDUZ,PRCVFCP1,PRCVFCP2,PRCVBOC,PRCVTERM
|
---|
| 112 | ;
|
---|
| 113 | S PRCVBID=$P(PRCVND,PRCVFS,4)
|
---|
| 114 | I PRCVBID']"" D ADDERR("PRCV2"_U_"Batch ID is missing.",4)
|
---|
| 115 | S PRCVTCD=$P(PRCVND,PRCVFS,5)
|
---|
| 116 | I PRCVTCD']"" D ADDERR("PRCV2"_U_"Transaction Code is missing.",5)
|
---|
| 117 | I PRCVTCD'="IV",(PRCVTCD'="SV") D ADDERR("PRCV2"_U_"Invalid Transaction Code: "_PRCVTCD,5)
|
---|
| 118 | ; Check User ID, Termination Date and is authorized FCP user
|
---|
| 119 | S PRCVDUZ=$P(PRCVND,PRCVFS,3)
|
---|
| 120 | I PRCVDUZ']"" D ADDERR("PRCV2"_U_"User ID is missing.",3)
|
---|
| 121 | I PRCVDUZ]"" D
|
---|
| 122 | . I '$$FIND1^DIC(200,"","","`"_PRCVDUZ,"","","PRCVERR") D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
|
---|
| 123 | . E D
|
---|
| 124 | .. S PRCVTERM=$$GET1^DIQ(200,PRCVDUZ_",",9.2,"I")
|
---|
| 125 | .. I +PRCVTERM>0,(PRCVTERM<DT) D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
|
---|
| 126 | .. Q
|
---|
| 127 | .Q
|
---|
| 128 | S PRCVFCP1=$P(PRCVND,PRCVFS,22)
|
---|
| 129 | I PRCVFCP1']"" D ADDERR("PRCV2"_U_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point is missing.",22)
|
---|
| 130 | I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP1)) D ADDERR("PRCV2"_U_"Invalid "_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
|
---|
| 131 | 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)
|
---|
| 132 | I PRCVTCD="IV" D
|
---|
| 133 | . S PRCVFCP2=$P(PRCVND,PRCVFS,24)
|
---|
| 134 | . I PRCVFCP2']"" D ADDERR("PRCV2"_U_"Buyer's Fund Control Point is missing.",24)
|
---|
| 135 | . E D
|
---|
| 136 | .. I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP2)) D ADDERR("PRCV2"_U_"Invalid Buyer's Fund Control Point.",24)
|
---|
| 137 | .. 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)
|
---|
| 138 | .. Q
|
---|
| 139 | . S PRCVCC=$P(PRCVND,PRCVFS,19)
|
---|
| 140 | . I PRCVCC']"" D ADDERR("PRCV2"_U_"Buyer's Cost Center is missing.",19)
|
---|
| 141 | . S PRCVSCC=$P(PRCVND,PRCVFS,20)
|
---|
| 142 | . I PRCVSCC']"" D ADDERR("PRCV2"_U_"Buyer's Sub-cost Center is missing.",20)
|
---|
| 143 | . I PRCVCC,(PRCVSCC'="") D
|
---|
| 144 | .. 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
|
---|
| 145 | .. 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)
|
---|
| 146 | .. Q
|
---|
| 147 | . Q
|
---|
| 148 | 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)
|
---|
| 149 | S ^TMP(PRCVSUB,$J,1)=PRCVSTN_U_PRCVBID_U_PRCVTCD_U_PRCVDAC_U_PRCVTDT_U_PRCVDUZ
|
---|
| 150 | S ^TMP(PRCVSUB,$J,2)=PRCVFCP1_U_$G(PRCVFCP2)_U_$G(PRCVCC)_U_$G(PRCVSCC)
|
---|
| 151 | Q
|
---|
| 152 | ;
|
---|
| 153 | FT1 ; Process FT1 segment
|
---|
| 154 | N PRCVACC,PRCVBOC,PRCVINV,PRCVSAL,PRCVRCD
|
---|
| 155 | ;
|
---|
| 156 | S PRCVLID=$P(PRCVND,PRCVFS,3)
|
---|
| 157 | I 'PRCVLID D ADDERR("PRCV2"_U_"Line ID is missing.",3)
|
---|
| 158 | S PRCVACC=$P(PRCVND,PRCVFS,9)
|
---|
| 159 | I 'PRCVACC D ADDERR("PRCV2"_U_"Account Code is missing.",9)
|
---|
| 160 | I PRCVACC,((PRCVACC'?1N)!("12368"'[PRCVACC)) D ADDERR("PRCV2"_U_"Invalid Account Code: "_PRCVACC,9)
|
---|
| 161 | I PRCVTCD="IV" D
|
---|
| 162 | . S PRCVBOC=$P(PRCVND,PRCVFS,10)
|
---|
| 163 | . I PRCVBOC=2696 D ADDERR("PRCV2"_U_"Invalid Buyer's Budget Object Code: "_PRCVBOC,10)
|
---|
| 164 | . I 'PRCVBOC D ADDERR("PRCV2"_U_"Budget Object Code is missing.",10)
|
---|
| 165 | . I '$D(^PRCD(420.1,PRCVCC_PRCVSCC,1,PRCVBOC)) D ADDERR("PRCV2"_U_"Invalid Budget Object Code for this Cost Center: "_PRCVBOC,10)
|
---|
| 166 | . I $P($G(^PRCD(420.2,PRCVBOC,0)),"^",2)=1 D ADDERR("PRCV2"_U_"Inactivated Budget Object Code: "_PRCVBOC,10)
|
---|
| 167 | . S PRCVSAL=$P(PRCVND,PRCVFS,13)
|
---|
| 168 | . I 'PRCVSAL D ADDERR("PRCV2"_U_"Sale Value is missing.",13)
|
---|
| 169 | . Q
|
---|
| 170 | S PRCVINV=$P(PRCVND,PRCVFS,12)
|
---|
| 171 | I 'PRCVINV D ADDERR("PRCV2"_U_"Inventory Value is missing.",12)
|
---|
| 172 | I PRCVTCD="SV" D
|
---|
| 173 | . S PRCVRCD=$P(PRCVND,PRCVFS,8)
|
---|
| 174 | . I PRCVRCD']"" D ADDERR("PRCV2"_U_"Reason Code is missing.",8)
|
---|
| 175 | . I PRCVRCD'?1N!(PRCVRCD<1)!(PRCVRCD>7) D ADDERR("PRCV2"_U_"Invalid Reason Code: "_PRCVRCD,8)
|
---|
| 176 | . Q
|
---|
| 177 | S ^TMP(PRCVSUB,$J,3,0)=PRCVLID
|
---|
| 178 | S ^TMP(PRCVSUB,$J,3,PRCVLID,0)=PRCVLID_U_PRCVACC_U_$G(PRCVBOC)_U_PRCVINV_U_$G(PRCVSAL)_U_$G(PRCVRCD)
|
---|
| 179 | Q
|
---|
| 180 | ;
|
---|
| 181 | GENACK(PRCVAC,PRCVMCID,PRCVDT,PRCVOCCR) ;
|
---|
| 182 | ;
|
---|
| 183 | ;PRCVAC - Acknowledgment Code
|
---|
| 184 | ;PRCVMCID - Message Control ID which you're acknowledging
|
---|
| 185 | ;PRCVDT - Date/Time of Transaction
|
---|
| 186 | ;PRCVOCCR - Error message array
|
---|
| 187 | ;
|
---|
| 188 | N PRCVFS,PRCVCNT,PRCVCS,PRCVI,PRCVJ,PRCVND,PRCVRES
|
---|
| 189 | ;
|
---|
| 190 | 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)
|
---|
| 191 | S PRCVRES="",PRCVJ=0,PRCVI=1
|
---|
| 192 | ;
|
---|
| 193 | ; MSA Segment
|
---|
| 194 | S HLA("HLA",1)="MSA"_PRCVFS_PRCVAC_PRCVFS_PRCVMCID_PRCVFS_$G(PRCVBID)
|
---|
| 195 | ;
|
---|
| 196 | ; ERR Segment
|
---|
| 197 | I $G(PRCVOCCR)'="" D
|
---|
| 198 | . F S PRCVJ=$O(PRCVOCCR(PRCVJ)) Q:'PRCVJ D
|
---|
| 199 | .. S PRCVI=PRCVI+1
|
---|
| 200 | .. S HLA("HLA",PRCVI)="ERR"_PRCVFS_PRCVOCCR(PRCVJ)
|
---|
| 201 | .. Q
|
---|
| 202 | . Q
|
---|
| 203 | ;
|
---|
| 204 | D GENACK^HLMA1(HL("EID"),$G(HLMTIENS),HL("EIDS"),"LM",1,PRCVRES)
|
---|
| 205 | I $P($G(PRCVRES),U,2) D
|
---|
| 206 | . K XMB,XMZ
|
---|
| 207 | . S XMB="PRCV HL7 ERROR"
|
---|
| 208 | . S XMB(1)="PRCVIB"
|
---|
| 209 | . S XMB(2)="Application Acknowledgement"
|
---|
| 210 | . S XMB(3)="PRCV_IFCAP_06_SU_IB_PROC"
|
---|
| 211 | . S XMB(4)=PRCVRES
|
---|
| 212 | . S XMDUZ="PRCV HL7 Generator"
|
---|
| 213 | . D ^XMB
|
---|
| 214 | . K XMB,XMDUZ,XMZ
|
---|
| 215 | . Q
|
---|
| 216 | ;
|
---|
| 217 | K HLA("HLA"),^TMP("HLA",$J)
|
---|
| 218 | K PRCVAC,X
|
---|
| 219 | Q
|
---|
| 220 | ;
|
---|
| 221 | ADDERR(PRCVER,PRCVFD) ;
|
---|
| 222 | ; PRCVER - Error message
|
---|
| 223 | ; PRCVFD - Field number, if any
|
---|
| 224 | ;
|
---|
| 225 | S PRCVK=PRCVK+1
|
---|
| 226 | S PRCVEA=PRCVK
|
---|
| 227 | S:'$G(PRCVLID) PRCVLID=1
|
---|
| 228 | S:'$G(PRCVFD) PRCVLID="",PRCVFD=""
|
---|
| 229 | S PRCVEA(PRCVK)=PRCVFS_$G(PRCVSEG)_U_PRCVLID_U_PRCVFD_PRCVFS_"207^Application Internal Error^HL70357"_PRCVFS_"E"_PRCVFS_PRCVER_PRCVFS_PRCVLID
|
---|
| 230 | Q
|
---|
| 231 | ;
|
---|
| 232 | XTMP(AC) ; Move ^TMP(PRCVSUB,$j) to ^XTMP
|
---|
| 233 | ;
|
---|
| 234 | ; AC - Acknowledgement
|
---|
| 235 | ;
|
---|
| 236 | S ^XTMP(PRCVSUB,0)=$$FMADD^XLFDT(PRCVDT,14)_U_PRCVDT_U_"IB Data from DynaMed with error"
|
---|
| 237 | F PRCVI=1,2 S ^XTMP(PRCVSUB,PRCVI)=^TMP(PRCVSUB,$J,PRCVI)
|
---|
| 238 | I $D(^TMP(PRCVSUB,$J,3,0)) D
|
---|
| 239 | . S ^XTMP(PRCVSUB,3,0)=^TMP(PRCVSUB,$J,3,0)
|
---|
| 240 | . S PRCVI=0
|
---|
| 241 | . F S PRCVI=$O(^TMP(PRCVSUB,$J,3,PRCVI)) Q:'PRCVI D
|
---|
| 242 | .. S ^XTMP(PRCVSUB,3,PRCVI)=^TMP(PRCVSUB,$J,3,PRCVI,0)
|
---|
| 243 | .. Q
|
---|
| 244 | D GENACK(AC,HL("MID"),PRCVDT,.PRCVEA)
|
---|
| 245 | S ^XTMP(PRCVSUB,4,0)=PRCVEA
|
---|
| 246 | S PRCVI=0
|
---|
| 247 | F S PRCVI=$O(PRCVEA(PRCVI)) Q:'PRCVI D
|
---|
| 248 | . S ^XTMP(PRCVSUB,4,PRCVI)=PRCVEA(PRCVI)
|
---|
| 249 | . Q
|
---|
| 250 | Q
|
---|
| 251 | ;
|
---|
| 252 | FIN ; Clean up
|
---|
| 253 | ;
|
---|
| 254 | ; K ^TMP($J,"PRCVIB")
|
---|
| 255 | ; K ^TMP(PRCVSUB,$J)
|
---|
| 256 | K PRCVEA
|
---|
| 257 | Q
|
---|
| 258 | ;
|
---|
| 259 | TXT ;
|
---|
| 260 | EVN1 ;;^EVN^^Missing segment ^100^Missing line item info.
|
---|
| 261 | PID1 ;;EVN^^^Missing segment ^100^Missing line item info.
|
---|
| 262 | FT11 ;;PID^FT1^^Missing segment ^100^Missing line item info.
|
---|