90 lines
4.2 KiB
Mathematica
90 lines
4.2 KiB
Mathematica
PRCHQ7 ;(WASH IRMFO)/LKG/DL-RFQ SERVER UNPACKING VENDOR TEXT MSG ;2/6/98 0930
|
|
;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
IN ;
|
|
K ^TMP("DIERR",$J),^TMP($J,"PRCERR")
|
|
S PRCI=0 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=1 G ERR
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
|
|
I $P(PRCX,U)'="ISM"!($P(PRCX,U,4)'="TXT") S PRCERR=2 G ERR
|
|
S PRCRFQ=$P($P(PRCX,U,7)," ")
|
|
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=3 G ERR
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="CT" S PRCERR=3 G ERR
|
|
K PRC S X=$O(^PRC(444,"B",PRCRFQ,"")) I X'?1.N S PRCERR=4 G ERR
|
|
S PRC("D0")=X L +^PRC(444,PRC("D0")):7200 E S PRCERR=5 G ERR
|
|
S PRCC=$P($G(^PRC(444,PRC("D0"),1)),U,5)+1,$P(^(1),U,5)=PRCC
|
|
K DD,DO,DA,DIC S DA(1)=PRC("D0"),DIC="^PRC(444,DA(1),7,",DIC(0)="L"
|
|
S DIC("P")=$P(^DD(444,21,0),U,2),X=PRCC,DINUM=PRCC,DLAYGO=444.021
|
|
D FILE^DICN K DIC,DINUM,DLAYGO I +Y<1 S PRCERR=6 G ERR
|
|
S PRC("D1")=+Y L -^PRC(444,PRC("D0"))
|
|
L +^PRC(444,PRC("D0"),7,PRC("D1")):7200 E S PRCERR=5 G ERR
|
|
K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_",",PRCAR(444.021,PRCIENS,1)="I"
|
|
S X=$$JD2FMD^PRCHQ7($P(PRCX,U,4))_$S($P(PRCX,U,5)]"":".",1:"")_$P(PRCX,U,5)
|
|
I $P(X,".")'?7N!($P(X,".",2)'?.6N) S PRCERR=10 G ERR
|
|
S PRCAR(444.021,PRCIENS,5)=X
|
|
S PRCAR(444.021,PRCIENS,15)=PRCDA D FILE^DIE("","PRCAR") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
|
|
S PRCY=$P(PRCX,U,2) S:PRCY]"" PRCAR(444.021,PRCIENS,4)=PRCY
|
|
S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.021,PRCIENS,9)=PRCY
|
|
S PRCAR(444.021,PRCIENS,6)="NOW"
|
|
S PRCY=$P(PRCX,U,6) S:PRCY]"" PRCAR(444.021,PRCIENS,7)=PRCY
|
|
S PRCY=$P(PRCX,U,7) S:PRCY]"" PRCAR(444.021,PRCIENS,8)=PRCY
|
|
D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
|
|
S PRCTL=+$P(PRCX,U,8)
|
|
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=7 G ERR
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="VE" S PRCERR=8 G ERR
|
|
S PRCY=$P(PRCX,U,2),PRCVEN=PRCY S:PRCY]"" PRCAR(444.021,PRCIENS,2)=PRCY
|
|
S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.021,PRCIENS,2.5)=PRCY
|
|
D FILE^DIE("E","PRCAR") K PRCAR,PRCIENS D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
|
|
S PRCC=0
|
|
F S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI=""!$D(PRCERR) D
|
|
. Q:'$D(^PRCF(423.6,PRCDA,1,PRCI,0)) Q:^(0)="$"!(^(0)="~") I $P(^(0),U)'="TX" S PRCERR=9 Q
|
|
. S PRCC=PRCC+1
|
|
. S ^PRC(444,PRC("D0"),7,PRC("D1"),2,PRCC,0)=$P(^PRCF(423.6,PRCDA,1,PRCI,0),U,3)
|
|
I $D(PRCERR) G ERR
|
|
D NOW^%DTC S ^PRC(444,PRC("D0"),7,PRC("D1"),2,0)="^^"_PRCC_"^"_PRCC_"^"_X_"^^^^"
|
|
I PRCC'=PRCTL S PRCERR=9 G ERR
|
|
I $D(^TMP($J,"PRCERR")) S PRCERR=11 G ERR
|
|
K XMB,XMY S XMB="PRCHQ 864 NORMAL",XMB(1)=$G(PRCRFQ),XMB(2)=$G(PRCVEN),XMB(3)=$G(PRC("D1"))
|
|
S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
|
|
S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
|
|
EX I $D(PRC("D0")) D
|
|
. I '$D(PRC("D1")) L -^PRC(444,PRC("D0")) Q
|
|
. L -^PRC(444,PRC("D0"),7,PRC("D1"))
|
|
K DA,PRC,PRCAR,PRCC,PRCDA,PRCI,PRCIENS,PRCRFQ,PRCTL,PRCVEN,PRCX,PRCY,X,Y
|
|
K ^TMP("DIERR",$J),^TMP($J,"PRCERR")
|
|
S:$D(ZTQUEUED) ZTREQ="@"
|
|
Q
|
|
JD2FMD(PRCJD) ;Converts from Julian Date to FileMan Date
|
|
N PRCYR,X,Y,I S Y=""
|
|
I PRCJD?7N D
|
|
. S Y="31^28^31^30^31^30^31^31^30^31^30^31",PRCYR=$E(PRCJD,1,4)
|
|
. S $P(Y,"^",2)=$S(PRCYR#400=0:29,(PRCYR#4=0&(PRCYR#100'=0)):29,1:28)
|
|
. S X=+$E(PRCJD,5,7)
|
|
. F I=1:1:13 Q:X'>$P(Y,"^",I)!(I=13) S X=X-$P(Y,"^",I)
|
|
. S Y=$S(I=13:"",1:PRCYR-1700_$E(100+I,2,3)_$E(100+X,2,3))
|
|
Q Y
|
|
ERR ;Error processing
|
|
K XMB,XMZ
|
|
S XMB="PRCHQ 864 ERROR",XMB(1)=$G(PRCRFQ),XMB(2)=$P($T(ERMSG+PRCERR),";;",2)
|
|
S XMB(3)=$G(PRCVEN) F PRCY=4:1:13 S XMB(PRCY)=""
|
|
I $D(^TMP($J,"PRCERR")) D
|
|
. S PRCX=0,PRCY=3
|
|
. F S PRCX=$O(^TMP($J,"PRCERR",PRCX)) Q:PRCX'?1.N!(PRCY>12) D
|
|
. . S:$D(^TMP($J,"PRCERR",PRCX)) PRCY=PRCY+1,XMB(PRCY)=^(PRCX)
|
|
I $D(PRC("D0")) S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
|
|
S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
|
|
K PRCERR
|
|
G EX
|
|
ERMSG ;List of Error Messages
|
|
;;No segments to file
|
|
;;First segment has format error or is wrong type
|
|
;;Second segment not the 'CT' type
|
|
;;RFQ entry not found
|
|
;;Unable to add new message entry
|
|
;;No segments after 'CT' segment
|
|
;;3rd segment not 'VE' type
|
|
;;Next segment not 'TX' type
|
|
;;Count of 'TX' segments differs from value on 'CT' segment
|
|
;;Effective Date/Time converted to invalid value
|
|
;;Value(s) failed input transform
|