source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ7.m@ 1804

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

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1PRCHQ7 ;(WASH IRMFO)/LKG/DL-RFQ SERVER UNPACKING VENDOR TEXT MSG ;2/6/98 0930
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5IN ;
6 K ^TMP("DIERR",$J),^TMP($J,"PRCERR")
7 S PRCI=0 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=1 G ERR
8 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
9 I $P(PRCX,U)'="ISM"!($P(PRCX,U,4)'="TXT") S PRCERR=2 G ERR
10 S PRCRFQ=$P($P(PRCX,U,7)," ")
11 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=3 G ERR
12 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="CT" S PRCERR=3 G ERR
13 K PRC S X=$O(^PRC(444,"B",PRCRFQ,"")) I X'?1.N S PRCERR=4 G ERR
14 S PRC("D0")=X L +^PRC(444,PRC("D0")):7200 E S PRCERR=5 G ERR
15 S PRCC=$P($G(^PRC(444,PRC("D0"),1)),U,5)+1,$P(^(1),U,5)=PRCC
16 K DD,DO,DA,DIC S DA(1)=PRC("D0"),DIC="^PRC(444,DA(1),7,",DIC(0)="L"
17 S DIC("P")=$P(^DD(444,21,0),U,2),X=PRCC,DINUM=PRCC,DLAYGO=444.021
18 D FILE^DICN K DIC,DINUM,DLAYGO I +Y<1 S PRCERR=6 G ERR
19 S PRC("D1")=+Y L -^PRC(444,PRC("D0"))
20 L +^PRC(444,PRC("D0"),7,PRC("D1")):7200 E S PRCERR=5 G ERR
21 K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_",",PRCAR(444.021,PRCIENS,1)="I"
22 S X=$$JD2FMD^PRCHQ7($P(PRCX,U,4))_$S($P(PRCX,U,5)]"":".",1:"")_$P(PRCX,U,5)
23 I $P(X,".")'?7N!($P(X,".",2)'?.6N) S PRCERR=10 G ERR
24 S PRCAR(444.021,PRCIENS,5)=X
25 S PRCAR(444.021,PRCIENS,15)=PRCDA D FILE^DIE("","PRCAR") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
26 S PRCY=$P(PRCX,U,2) S:PRCY]"" PRCAR(444.021,PRCIENS,4)=PRCY
27 S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.021,PRCIENS,9)=PRCY
28 S PRCAR(444.021,PRCIENS,6)="NOW"
29 S PRCY=$P(PRCX,U,6) S:PRCY]"" PRCAR(444.021,PRCIENS,7)=PRCY
30 S PRCY=$P(PRCX,U,7) S:PRCY]"" PRCAR(444.021,PRCIENS,8)=PRCY
31 D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
32 S PRCTL=+$P(PRCX,U,8)
33 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=7 G ERR
34 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="VE" S PRCERR=8 G ERR
35 S PRCY=$P(PRCX,U,2),PRCVEN=PRCY S:PRCY]"" PRCAR(444.021,PRCIENS,2)=PRCY
36 S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.021,PRCIENS,2.5)=PRCY
37 D FILE^DIE("E","PRCAR") K PRCAR,PRCIENS D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
38 S PRCC=0
39 F S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI=""!$D(PRCERR) D
40 . Q:'$D(^PRCF(423.6,PRCDA,1,PRCI,0)) Q:^(0)="$"!(^(0)="~") I $P(^(0),U)'="TX" S PRCERR=9 Q
41 . S PRCC=PRCC+1
42 . S ^PRC(444,PRC("D0"),7,PRC("D1"),2,PRCC,0)=$P(^PRCF(423.6,PRCDA,1,PRCI,0),U,3)
43 I $D(PRCERR) G ERR
44 D NOW^%DTC S ^PRC(444,PRC("D0"),7,PRC("D1"),2,0)="^^"_PRCC_"^"_PRCC_"^"_X_"^^^^"
45 I PRCC'=PRCTL S PRCERR=9 G ERR
46 I $D(^TMP($J,"PRCERR")) S PRCERR=11 G ERR
47 K XMB,XMY S XMB="PRCHQ 864 NORMAL",XMB(1)=$G(PRCRFQ),XMB(2)=$G(PRCVEN),XMB(3)=$G(PRC("D1"))
48 S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
49 S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
50EX I $D(PRC("D0")) D
51 . I '$D(PRC("D1")) L -^PRC(444,PRC("D0")) Q
52 . L -^PRC(444,PRC("D0"),7,PRC("D1"))
53 K DA,PRC,PRCAR,PRCC,PRCDA,PRCI,PRCIENS,PRCRFQ,PRCTL,PRCVEN,PRCX,PRCY,X,Y
54 K ^TMP("DIERR",$J),^TMP($J,"PRCERR")
55 S:$D(ZTQUEUED) ZTREQ="@"
56 Q
57JD2FMD(PRCJD) ;Converts from Julian Date to FileMan Date
58 N PRCYR,X,Y,I S Y=""
59 I PRCJD?7N D
60 . S Y="31^28^31^30^31^30^31^31^30^31^30^31",PRCYR=$E(PRCJD,1,4)
61 . S $P(Y,"^",2)=$S(PRCYR#400=0:29,(PRCYR#4=0&(PRCYR#100'=0)):29,1:28)
62 . S X=+$E(PRCJD,5,7)
63 . F I=1:1:13 Q:X'>$P(Y,"^",I)!(I=13) S X=X-$P(Y,"^",I)
64 . S Y=$S(I=13:"",1:PRCYR-1700_$E(100+I,2,3)_$E(100+X,2,3))
65 Q Y
66ERR ;Error processing
67 K XMB,XMZ
68 S XMB="PRCHQ 864 ERROR",XMB(1)=$G(PRCRFQ),XMB(2)=$P($T(ERMSG+PRCERR),";;",2)
69 S XMB(3)=$G(PRCVEN) F PRCY=4:1:13 S XMB(PRCY)=""
70 I $D(^TMP($J,"PRCERR")) D
71 . S PRCX=0,PRCY=3
72 . F S PRCX=$O(^TMP($J,"PRCERR",PRCX)) Q:PRCX'?1.N!(PRCY>12) D
73 . . S:$D(^TMP($J,"PRCERR",PRCX)) PRCY=PRCY+1,XMB(PRCY)=^(PRCX)
74 I $D(PRC("D0")) S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
75 S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
76 K PRCERR
77 G EX
78ERMSG ;List of Error Messages
79 ;;No segments to file
80 ;;First segment has format error or is wrong type
81 ;;Second segment not the 'CT' type
82 ;;RFQ entry not found
83 ;;Unable to add new message entry
84 ;;No segments after 'CT' segment
85 ;;3rd segment not 'VE' type
86 ;;Next segment not 'TX' type
87 ;;Count of 'TX' segments differs from value on 'CT' segment
88 ;;Effective Date/Time converted to invalid value
89 ;;Value(s) failed input transform
Note: See TracBrowser for help on using the repository browser.