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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ7 4389 printed Jun 11, 2024@21:55:53 Page 2
PRCHQ7 ;(WASH IRMFO)/LKG/DL-RFQ SERVER UNPACKING VENDOR TEXT MSG ;2/6/98 0930
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
IN ;
+1 KILL ^TMP("DIERR",$JOB),^TMP($JOB,"PRCERR")
+2 SET PRCI=0
SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=1
GOTO ERR
+3 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
+4 IF $PIECE(PRCX,U)'="ISM"!($PIECE(PRCX,U,4)'="TXT")
SET PRCERR=2
GOTO ERR
+5 SET PRCRFQ=$PIECE($PIECE(PRCX,U,7)," ")
+6 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=3
GOTO ERR
+7 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="CT"
SET PRCERR=3
GOTO ERR
+8 KILL PRC
SET X=$ORDER(^PRC(444,"B",PRCRFQ,""))
IF X'?1.N
SET PRCERR=4
GOTO ERR
+9 SET PRC("D0")=X
LOCK +^PRC(444,PRC("D0")):7200
IF '$TEST
SET PRCERR=5
GOTO ERR
+10 SET PRCC=$PIECE($GET(^PRC(444,PRC("D0"),1)),U,5)+1
SET $PIECE(^(1),U,5)=PRCC
+11 KILL DD,DO,DA,DIC
SET DA(1)=PRC("D0")
SET DIC="^PRC(444,DA(1),7,"
SET DIC(0)="L"
+12 SET DIC("P")=$PIECE(^DD(444,21,0),U,2)
SET X=PRCC
SET DINUM=PRCC
SET DLAYGO=444.021
+13 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
IF +Y<1
SET PRCERR=6
GOTO ERR
+14 SET PRC("D1")=+Y
LOCK -^PRC(444,PRC("D0"))
+15 LOCK +^PRC(444,PRC("D0"),7,PRC("D1")):7200
IF '$TEST
SET PRCERR=5
GOTO ERR
+16 KILL PRCAR
SET PRCIENS=PRC("D1")_","_PRC("D0")_","
SET PRCAR(444.021,PRCIENS,1)="I"
+17 SET X=$$JD2FMD^PRCHQ7($PIECE(PRCX,U,4))_$SELECT($PIECE(PRCX,U,5)]"":".",1:"")_$PIECE(PRCX,U,5)
+18 IF $PIECE(X,".")'?7N!($PIECE(X,".",2)'?.6N)
SET PRCERR=10
GOTO ERR
+19 SET PRCAR(444.021,PRCIENS,5)=X
+20 SET PRCAR(444.021,PRCIENS,15)=PRCDA
DO FILE^DIE("","PRCAR")
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+21 SET PRCY=$PIECE(PRCX,U,2)
if PRCY]""
SET PRCAR(444.021,PRCIENS,4)=PRCY
+22 SET PRCY=$PIECE(PRCX,U,3)
if PRCY]""
SET PRCAR(444.021,PRCIENS,9)=PRCY
+23 SET PRCAR(444.021,PRCIENS,6)="NOW"
+24 SET PRCY=$PIECE(PRCX,U,6)
if PRCY]""
SET PRCAR(444.021,PRCIENS,7)=PRCY
+25 SET PRCY=$PIECE(PRCX,U,7)
if PRCY]""
SET PRCAR(444.021,PRCIENS,8)=PRCY
+26 DO FILE^DIE("E","PRCAR")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+27 SET PRCTL=+$PIECE(PRCX,U,8)
+28 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=7
GOTO ERR
+29 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="VE"
SET PRCERR=8
GOTO ERR
+30 SET PRCY=$PIECE(PRCX,U,2)
SET PRCVEN=PRCY
if PRCY]""
SET PRCAR(444.021,PRCIENS,2)=PRCY
+31 SET PRCY=$PIECE(PRCX,U,3)
if PRCY]""
SET PRCAR(444.021,PRCIENS,2.5)=PRCY
+32 DO FILE^DIE("E","PRCAR")
KILL PRCAR,PRCIENS
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+33 SET PRCC=0
+34 FOR
SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
if PRCI=""!$DATA(PRCERR)
QUIT
Begin DoDot:1
+35 if '$DATA(^PRCF(423.6,PRCDA,1,PRCI,0))
QUIT
if ^(0)="$"!(^(0)="~")
QUIT
IF $PIECE(^(0),U)'="TX"
SET PRCERR=9
QUIT
+36 SET PRCC=PRCC+1
+37 SET ^PRC(444,PRC("D0"),7,PRC("D1"),2,PRCC,0)=$PIECE(^PRCF(423.6,PRCDA,1,PRCI,0),U,3)
End DoDot:1
+38 IF $DATA(PRCERR)
GOTO ERR
+39 DO NOW^%DTC
SET ^PRC(444,PRC("D0"),7,PRC("D1"),2,0)="^^"_PRCC_"^"_PRCC_"^"_X_"^^^^"
+40 IF PRCC'=PRCTL
SET PRCERR=9
GOTO ERR
+41 IF $DATA(^TMP($JOB,"PRCERR"))
SET PRCERR=11
GOTO ERR
+42 KILL XMB,XMY
SET XMB="PRCHQ 864 NORMAL"
SET XMB(1)=$GET(PRCRFQ)
SET XMB(2)=$GET(PRCVEN)
SET XMB(3)=$GET(PRC("D1"))
+43 SET X=$PIECE($GET(^PRC(444,PRC("D0"),0)),U,4)
if X?1.N
SET XMY(X)=""
+44 SET XMDUZ="864 Text Message Filer"
DO ^XMB
KILL XMB,XMDUZ,XMZ
EX IF $DATA(PRC("D0"))
Begin DoDot:1
+1 IF '$DATA(PRC("D1"))
LOCK -^PRC(444,PRC("D0"))
QUIT
+2 LOCK -^PRC(444,PRC("D0"),7,PRC("D1"))
End DoDot:1
+3 KILL DA,PRC,PRCAR,PRCC,PRCDA,PRCI,PRCIENS,PRCRFQ,PRCTL,PRCVEN,PRCX,PRCY,X,Y
+4 KILL ^TMP("DIERR",$JOB),^TMP($JOB,"PRCERR")
+5 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
JD2FMD(PRCJD) ;Converts from Julian Date to FileMan Date
+1 NEW PRCYR,X,Y,I
SET Y=""
+2 IF PRCJD?7N
Begin DoDot:1
+3 SET Y="31^28^31^30^31^30^31^31^30^31^30^31"
SET PRCYR=$EXTRACT(PRCJD,1,4)
+4 SET $PIECE(Y,"^",2)=$SELECT(PRCYR#400=0:29,(PRCYR#4=0&(PRCYR#100'=0)):29,1:28)
+5 SET X=+$EXTRACT(PRCJD,5,7)
+6 FOR I=1:1:13
if X'>$PIECE(Y,"^",I)!(I=13)
QUIT
SET X=X-$PIECE(Y,"^",I)
+7 SET Y=$SELECT(I=13:"",1:PRCYR-1700_$EXTRACT(100+I,2,3)_$EXTRACT(100+X,2,3))
End DoDot:1
+8 QUIT Y
ERR ;Error processing
+1 KILL XMB,XMZ
+2 SET XMB="PRCHQ 864 ERROR"
SET XMB(1)=$GET(PRCRFQ)
SET XMB(2)=$PIECE($TEXT(ERMSG+PRCERR),";;",2)
+3 SET XMB(3)=$GET(PRCVEN)
FOR PRCY=4:1:13
SET XMB(PRCY)=""
+4 IF $DATA(^TMP($JOB,"PRCERR"))
Begin DoDot:1
+5 SET PRCX=0
SET PRCY=3
+6 FOR
SET PRCX=$ORDER(^TMP($JOB,"PRCERR",PRCX))
if PRCX'?1.N!(PRCY>12)
QUIT
Begin DoDot:2
+7 if $DATA(^TMP($JOB,"PRCERR",PRCX))
SET PRCY=PRCY+1
SET XMB(PRCY)=^(PRCX)
End DoDot:2
End DoDot:1
+8 IF $DATA(PRC("D0"))
SET X=$PIECE($GET(^PRC(444,PRC("D0"),0)),U,4)
if X?1.N
SET XMY(X)=""
+9 SET XMDUZ="864 Text Message Filer"
DO ^XMB
KILL XMB,XMDUZ,XMZ
+10 KILL PRCERR
+11 GOTO EX
ERMSG ;List of Error Messages
+1 ;;No segments to file
+2 ;;First segment has format error or is wrong type
+3 ;;Second segment not the 'CT' type
+4 ;;RFQ entry not found
+5 ;;Unable to add new message entry
+6 ;;No segments after 'CT' segment
+7 ;;3rd segment not 'VE' type
+8 ;;Next segment not 'TX' type
+9 ;;Count of 'TX' segments differs from value on 'CT' segment
+10 ;;Effective Date/Time converted to invalid value
+11 ;;Value(s) failed input transform
