Changeset 623 for WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.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/PRCHQ4.m
r613 r623 1 PRCHQ4 2 ;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 HE 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 VELST(PRCN) 26 27 28 29 30 31 32 33 34 35 36 37 VE(PRCD,PRCC) 38 39 40 41 42 ST(PRCC) 43 44 45 46 47 48 49 50 51 52 53 54 55 56 STX 57 MI(PRCRFQ,PRCC) 58 59 60 61 62 AC(PRCC) 63 64 65 66 67 TX(PRCN,PRCC) 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 IT(PRCC) 89 90 91 92 93 94 95 96 97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,2,PRCA,5)),U,2)98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) 118 119 120 121 122 123 124 125 126 127 DE(PRCN,PRCIT,PRCC) 128 129 130 131 132 133 134 135 136 137 138 DUNERR(PRCA) 139 140 141 142 143 1 PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27 2 ;;5.1;IFCAP;**63**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 HE ;Set up Heading segment 5 N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y 6 S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1)) 7 S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^" 8 S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^" 9 S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2) 10 S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|" 11 K DA S DA=$P(PRCN0,U,4) I DA?1.N D 12 . K ^UTILITY("DIQ1",$J) 13 . S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR 14 . S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I") 15 . K ^UTILITY("DIQ1",$J) 16 S ^TMP($J,"STRING",1)=PRCA 17 I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date" 18 I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date" 19 I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date" 20 I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time" 21 I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing" 22 I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing" 23 I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ) 24 Q 25 VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup 26 N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0 27 F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D 28 . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY="" 29 . S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2) 30 . Q:";b;e;"'[(";"_$P(PRCY,U,2)_";") 31 . S PRCY=$P(PRCY,U) 32 . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2)) 33 . I X="" D DUNERR(PRCY) Q 34 . D VE(X,.PRCN) S PRCW=PRCW+1 35 I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1 36 Q PRCW 37 VE(PRCD,PRCC) ;Set up Vendor segment 38 S PRCC=PRCC+1 39 S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|" 40 S ^TMP($J,"VE",PRCD)="" 41 Q 42 ST(PRCC) ;Setting up Ship to segment 43 N PRCX,PRCY,DA,DIC,DR 44 S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10) 45 S:PRCX="" PRCX=$E($P(PRCY,U),1,3) 46 S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N 47 S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX="" 48 S PRCC=PRCC+1 49 I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX 50 S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4) 51 S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|" 52 S DA=$P(PRCX,U,6) I DA?1.N D 53 . K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1 54 . S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J) 55 S ^TMP($J,"STRING",PRCC)=PRCY 56 STX Q 57 MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment 58 N PRCY 59 S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1 60 S ^TMP($J,"STRING",PRCC)=PRCY 61 Q 62 AC(PRCC) ;Set up Accounting Information segment 63 N PRCY 64 S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1 65 S ^TMP($J,"STRING",PRCC)=PRCY 66 Q 67 TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification 68 ;;or 864 text) 69 ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2) 70 ;; Returns number of lines in reformatted Word Processing field 71 ;;ARG1: CLOSED GLOBAL ROOT 72 ;;ARG2: CURRENT MESSAGE LINE COUNT 73 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF 74 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") 75 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D 76 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP 77 ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D 78 ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP 79 ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP 80 ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP 81 ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP 82 S PRCT=$G(^UTILITY($J,"W",1))+0 83 F PRCI=1:1:PRCT D 84 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") 85 . S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|" 86 K ^UTILITY($J,"W") 87 Q PRCT 88 IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery 89 ;;Schedule and Description segments for item.) 90 N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT 91 S PRCA=0,PRCCNT=0 92 F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D 93 . S PRCL=0 94 . S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB="" 95 . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U) 96 . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1 97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2) 98 . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^" 99 . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH 100 . S PRCY=PRCY_"^^^^^^^^^^^^^" 101 . S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE 102 . S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|" 103 . S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY 104 . S PRCF=PRCC 105 . S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC) 106 . S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL) 107 . I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing" 108 . I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero" 109 . I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing" 110 . I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing" 111 . I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing" 112 . I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity" 113 S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT 114 I PRCCNT'>0 S PRCK(7)="No Items in RFQ" 115 I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK) 116 Q 117 SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item 118 N PRCW,PRCX,PRCY,PRCZ,X,Y 119 S PRCX=0,PRCW=0 120 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D 121 . S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ="" 122 . S X=$P(PRCZ,U,2) D JDN^PRCUTL 123 . S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU 124 . S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4) 125 . S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1 126 Q PRCW 127 DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments 128 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF 129 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") 130 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D 131 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP 132 S PRCT=$G(^UTILITY($J,"W",1)) 133 F PRCI=1:1:PRCT D 134 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") 135 . S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|" 136 K ^UTILITY($J,"W") 137 Q PRCT 138 DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun # 139 Q:$D(ZTQUEUED) 140 N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)" 141 S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient" 142 D EN^DDIOL(PRCB) 143 Q
Note:
See TracChangeset
for help on using the changeset viewer.
