Changeset 623 for WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m
r613 r623 1 PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 2/29/08 1:54pm 2 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ; 5 CALLIT ;Call the IFCAP RIL build Routine 6 ; 7 D EN^PRCVRC1(PRCSUB) 8 ; 9 SETUP S PRCHD(1)="" 10 ;Added 1,"T" node to stop crash 11 S PRCHD(1,"T")="ORDER HEADER INFO" 12 S PRCHD(2)="ORC"_PRCCS_PRCCS_3 13 S PRCHD(2,"T")="FUND CONTROL POINT" 14 S PRCHD(3)="ORC"_PRCCS_PRCCS_17 15 S PRCHD(3,"T")="COST CENTER" 16 S PRCHD(4)="" 17 S PRCHD(5)="ORC"_PRCCS_PRCCS_21 18 S PRCHD(5,"T")="SITE NUMBER" 19 S PRCHD(6)="" 20 S PRCHD(7)="ORC"_PRCCS_PRCCS_10 21 S PRCHD(7,"T")="DUZ" 22 S PRCHD(8)="ORC"_PRCCS_PRCCS_10 23 S PRCHD(8,"T")="LAST NAME" 24 S PRCHD(9)="ORC"_PRCCS_PRCCS_11 25 S PRCHD(9,"T")="FIRST NAME" 26 S PRCDET(1)="RQD"_PRCCS_PRCCS_3 27 S PRCDET(1,"T")="ITEM NUMBER" 28 S PRCDET(2)="RQD"_PRCCS_PRCCS_5 29 S PRCDET(2,"T")="QUANTITY" 30 S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 31 S PRCDET(3,"T")="VENDOR ID" 32 S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 33 S PRCDET(4,"T")="UNIT COST" 34 S PRCDET(5)="RQD"_PRCCS_PRCCS_10 35 S PRCDET(5,"T")="DATE NEEDED" 36 S PRCDET(6)="RQD"_PRCCS_PRCCS_2 37 S PRCDET(6,"T")="DYNAMED DOCUMENT ID" 38 S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 39 S PRCDET(7,"T")="NIF NUMBER" 40 S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 41 S PRCDET(8,"T")="BOC" 42 ;Check if IFCAP has returned any errors 43 ; 44 S ERRCNT=1 45 S PRCVERR(0)="0" 46 HEAD ;If there are errors in the "1" sub-segment, add all errors to all 47 ; line items 48 S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) 49 I $D(^XTMP(PRCSUB,1,"ERR"))>0 D 50 .S II=0 51 .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D 52 ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) 53 ..Q:ERRDAT="" 54 ..S MSGFLG=1 55 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 56 ..S SEVER=$P(ERRDAT,U,4) 57 ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS 58 ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 59 ..S J=0 60 ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D 61 ...S ERRSUB=$P(ERRSTR,PRCFS,3) 62 ...S $P(ERRSUB,U,2)=J 63 ...S $P(ERRSTR,PRCFS,3)=ERRSUB 64 ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J 65 ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) 66 ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 67 DETAIL ;If there are errors in the detail lines, add them 68 S II=0 69 F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D 70 .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) 71 .S III=0 72 .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D 73 ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) 74 ..Q:ERRDAT="" 75 ..S MSGFLG=1 76 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 77 ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II 78 ..S SEVER=$P(ERRDAT,U,4) 79 ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID 80 ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 81 ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID 82 ..S ERRCNT=ERRCNT+1 83 ; 84 I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q 85 SETNTE ; If there are errors set an NTE segment 86 ; 87 S TOT=0,TOTREC=0,TOTERR=0 88 F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D 89 .S TOTREC=TOT 90 .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D 91 ..S ERRS=0 92 ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D 93 ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) 94 ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 95 I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC 96 S TOTGOOD=TOTREC-TOTERR 97 S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 98 D NAKIT,CLEANUP^PRCVRE1 Q 99 ; 100 NAKIT ;Send an acknowledgement that the message is rejected 101 ; 102 I HL("APAT")'="AL" Q 103 S MSG="" 104 F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D 105 .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) 106 S PRCVRES="" 107 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 108 ;I +$P(PRCVRES,U,2) D 109 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 110 MAIL ;Send MailMan message with error 111 Q:LENVAL="NOTOK" 112 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 113 S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " 114 S XMDUZ="IFCAP/DynaMed Interface" 115 S XMTEXT="PRCVERR(" 116 D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) 117 D ^XMD 118 K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 119 Q 120 ; 121 ACKIT ;Send an acknowledgement that everything went fine 122 ; 123 I HL("APAT")'="AL" Q 124 F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) 125 ; 126 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 127 ;I +P(PRCVRES,U,2) D 128 ;.I $D(ERRCNT)=0 S ERRCNT=1 129 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 130 ;.D MAIL 131 Q 1 PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 4/26/05 2:42pm 2 ;;5.1;IFCAP;**81**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified 4 ; 5 CALLIT ;Call the IFCAP RIL build Routine 6 ; 7 D EN^PRCVRC1(PRCSUB) 8 ; 9 SETUP S PRCHD(1)="" 10 S PRCHD(2)="ORC"_PRCCS_PRCCS_3 11 S PRCHD(2,"T")="FUND CONTROL POINT" 12 S PRCHD(3)="ORC"_PRCCS_PRCCS_17 13 S PRCHD(3,"T")="COST CENTER" 14 S PRCHD(4)="" 15 S PRCHD(5)="ORC"_PRCCS_PRCCS_21 16 S PRCHD(5,"T")="SITE NUMBER" 17 S PRCHD(6)="" 18 S PRCHD(7)="ORC"_PRCCS_PRCCS_10 19 S PRCHD(7,"T")="DUZ" 20 S PRCHD(8)="ORC"_PRCCS_PRCCS_10 21 S PRCHD(8,"T")="LAST NAME" 22 S PRCHD(9)="ORC"_PRCCS_PRCCS_11 23 S PRCHD(9,"T")="FIRST NAME" 24 S PRCDET(1)="RQD"_PRCCS_PRCCS_3 25 S PRCDET(1,"T")="ITEM NUMBER" 26 S PRCDET(2)="RQD"_PRCCS_PRCCS_5 27 S PRCDET(2,"T")="QUANTITY" 28 S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 29 S PRCDET(3,"T")="VENDOR ID" 30 S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 31 S PRCDET(4,"T")="UNIT COST" 32 S PRCDET(5)="RQD"_PRCCS_PRCCS_10 33 S PRCDET(5,"T")="DATE NEEDED" 34 S PRCDET(6)="RQD"_PRCCS_PRCCS_2 35 S PRCDET(6,"T")="DYNAMED DOCUMENT ID" 36 S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 37 S PRCDET(7,"T")="NIF NUMBER" 38 S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 39 S PRCDET(8,"T")="BOC" 40 ;Check if IFCAP has returned any errors 41 ; 42 S ERRCNT=1 43 S PRCVERR(0)="0" 44 HEAD ;If there are errors in the "1" sub-segment, add all errors to all 45 ; line items 46 S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) 47 I $D(^XTMP(PRCSUB,1,"ERR"))>0 D 48 .S II=0 49 .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D 50 ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) 51 ..Q:ERRDAT="" 52 ..S MSGFLG=1 53 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 54 ..S SEVER=$P(ERRDAT,U,4) 55 ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS 56 ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 57 ..S J=0 58 ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D 59 ...S ERRSUB=$P(ERRSTR,PRCFS,3) 60 ...S $P(ERRSUB,U,2)=J 61 ...S $P(ERRSTR,PRCFS,3)=ERRSUB 62 ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J 63 ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) 64 ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 65 DETAIL ;If there are errors in the detail lines, add them 66 S II=0 67 F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D 68 .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) 69 .S III=0 70 .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D 71 ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) 72 ..Q:ERRDAT="" 73 ..S MSGFLG=1 74 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 75 ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II 76 ..S SEVER=$P(ERRDAT,U,4) 77 ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID 78 ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 79 ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID 80 ..S ERRCNT=ERRCNT+1 81 ; 82 I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q 83 SETNTE ; If there are errors set an NTE segment 84 ; 85 S TOT=0,TOTREC=0,TOTERR=0 86 F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D 87 .S TOTREC=TOT 88 .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D 89 ..S ERRS=0 90 ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D 91 ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) 92 ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 93 I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC 94 S TOTGOOD=TOTREC-TOTERR 95 S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 96 D NAKIT,CLEANUP^PRCVRE1 Q 97 ; 98 NAKIT ;Send an acknowledgement that the message is rejected 99 ; 100 I HL("APAT")'="AL" Q 101 S MSG="" 102 F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D 103 .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) 104 S PRCVRES="" 105 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 106 ;I +$P(PRCVRES,U,2) D 107 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 108 MAIL ;Send MailMan message with error 109 Q:LENVAL="NOTOK" 110 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 111 S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " 112 S XMDUZ="IFCAP/DynaMed Interface" 113 S XMTEXT="PRCVERR(" 114 D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) 115 D ^XMD 116 K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 117 Q 118 ; 119 ACKIT ;Send an acknowledgement that everything went fine 120 ; 121 I HL("APAT")'="AL" Q 122 F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) 123 ; 124 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 125 ;I +P(PRCVRES,U,2) D 126 ;.I $D(ERRCNT)=0 S ERRCNT=1 127 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 128 ;.D MAIL 129 Q
Note:
See TracChangeset
for help on using the changeset viewer.
