source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOE3.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1PRCOE3 ;WISC/DJM-IFCAP SEGMENTS HE,MI,CO ;6/18/97 16:29
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5HE(VAR1,VAR2) ;PO HEADER INFORMATION SEGMENT
6 ; uses PRCHPC variable to determine if document is a purchase card
7 ; PRCHPC should not exist & should not be used in non-Purchase Card options
8 ;
9 ; VAR1 = string of up to 4 pieces -- (last 3 pieces are optional)
10 ; ('^' piece 1) ==> ien to file 442
11 ; ('^' piece 2) ==> amendment flag (1 for PHM, 2 for PHA)
12 ; ('^' piece 3) ==> amendment number
13 ; ('^' piece 4) ==> 442 ien of amended order if PO number
14 ; was changed
15 ;
16 ; VAR2 is used to pass error conditions to the calling routine
17 ;
18 N A,A1,AFLG,ANO,B,DA,DD,NM,P,PHN,PM,PNM,PO,POD,PPM,RFQ,SC,MOP,X,Y
19 S PO=$P(VAR1,"^",1)
20 S A=$G(^PRC(442,PO,0))
21 S A1=$G(^PRC(442,PO,1))
22 I $G(^PRC(442,PO,12))="" S VAR2="NP12" Q ; exit if no info in node 12
23 ;
24 S X=$P(A1,U,15)
25 I X="" S VAR2="NPOD" Q ; exit if no PO Date
26 D JD^PRCFDLN ; puts julian date for X in Y
27 S POD=$E(X,1,3)+1700_$E(Y,1,3)
28 ;
29 S X=$P(A,U,10)
30 I X="" S VAR2="NDD" Q ; exit if no delivery date
31 D JD^PRCFDLN ; Puts julian date for X in Y
32 S DD=$E(X,1,3)+1700_$E(Y,1,3)
33 ;
34 S AFLG=$P(VAR1,"^",2) I AFLG="" S AFLG=0
35 S DA=PO
36 I AFLG=2 S DA=$P(VAR1,"^",4) ; use old PO's ien if PO number was changed
37 ;
38 I 'AFLG S P=$P(A1,U,10)
39 I AFLG D
40 . S ANO=$P(VAR1,"^",3) ; amendment number
41 . S P=$P(^PRC(442,DA,6,ANO,1),"^",1)
42 I P="" S VAR2="NPPM" Q ; exit if no PA/PPM (or Authorized buyer)
43 ;
44 S PHN=$P($G(^VA(200,P,.13)),"^",5)
45 I '$G(PRCHPC) D Q:PHN=""
46 . I PHN="" S VAR2="NPHN" Q ;exit if no commercial phone# for PA/PPM
47 . S PHN=$P(PHN,U)
48 . I PHN="" S VAR2="NPH" Q ; exit (but when would there be an '^'???)
49 ;
50 I 'AFLG S PPM=$E("ES/"_$$DECODE^PRCHES5(DA),1,30)
51 I AFLG S PPM=$E("ES/"_$$DECODE^PRCHES6(DA,ANO),1,30)
52 I PPM="ES/" S VAR2="ESBD" Q ; exit if no name found
53 ;
54 S PO=$P(VAR1,"^",1)
55 S MOP=$P(A,U,2) ; method of processing
56 S MOP=$S(MOP=1:"A",MOP=2:"B",MOP=3:"C",MOP=4:"D",MOP=7:"E",MOP=8:"F",MOP=9:"G",MOP=21:"H",MOP=22:"I",MOP=23:"J",MOP=24:"K",MOP=25:"L",MOP=26:"M",1:"")
57 S:MOP="" MOP="A"
58 ;
59 S SC=$P(A1,U,7) ; source code
60 S:SC>0 SC=$P($G(^PRCD(420.8,SC,0)),U)
61 S RFQ=$P($G(^PRC(442,PO,21)),U,8)
62 S PM=0
63 S PM=$O(^PRC(442,PO,14,PM)) ; purchase method
64 D:PM>0
65 . S PM=$P($G(^PRC(442,PO,14,PM,0)),U) Q:PM'>0
66 . S PM=$P($G(^PRC(442.4,PM,0)),U)
67 . Q
68 ;
69 S B="HE^^"_POD_"^"_SC_"^"_DD_"^^^"_PPM_"^"_PHN_"^"_PM_"^"_MOP_"^^0^^^^"_RFQ_"^1^|"
70 S ^TMP($J,"STRING",1)=B
71 Q
72 ;
73MI(VAR1,VAR2) ;MISCELLANEOUS INFORMATION SEGMENT
74 N B,F1,F2,I2,ITEM,M0,M1,M12,M23,PR
75 S M0=$G(^PRC(442,VAR1,0))
76 S M1=$G(^PRC(442,VAR1,1))
77 S M12=$G(^PRC(442,VAR1,12))
78 S M23=$G(^PRC(442,VAR1,23))
79 S B="MI^^"_$P(M12,U,7)_"^" ; FIELDS 1, 2, 3
80 I $P(M23,U,11)="P" S F1="" G MI1
81 S F1=$P(M1,U,7)
82 S:F1="" VAR2="NSC"
83 Q:F1=""
84 S F1=$S(F1=9:"B","2,3,5,8"[F1:"P",1:"D")
85MI1 S B=B_F1_"^^^" ; FIELDS 4, 5, 6
86 S PR=$P(M1,U,8)
87 I $P(M0,U,19)=2,PR="" S PR="N/A"
88 S:PR="" VAR2="NOPR"
89 Q:PR=""
90 S B=B_PR_"^^^^|" ; FIELDS 7, 8, 9, 10, 11
91 S ^TMP($J,"STRING",5)=B
92 Q
93 ;
94CO(VAR1,VAR2,TOTAL) ;COMMENT INFORMATION SEGMENT
95 N B,TOSH
96 S TOSH=$P($G(^PRC(442,VAR1,12)),U,14)
97 Q:TOSH=""
98 S TOSH=$E($P(^PRC(443.4,TOSH,0),U,3),1,59)
99 S B="CO^1^"_TOSH_"^|"
100 S ^TMP($J,"STRING",TOTAL)=B
101 S TOTAL=TOTAL+1
102 S B=^TMP($J,"STRING",1)
103 S $P(B,U,13)=$P(B,U,13)+1
104 S ^TMP($J,"STRING",1)=B
105 Q
Note: See TracBrowser for help on using the repository browser.