PRCUDCT1 ;WISC/LEM-Index FMS Document Transaction Rejects ;5/24/94 9:05 AM
V ;;5.0;IFCAP;;4/21/95
; This is a utility routine not accessible through IFCAP menus.
Q
PERROR ; Process Errors
N XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ S PRCEND=""
;I $D(PRCMG) S:PRCMG'["G." PRCMG="G."_PRCMG S X=PRCMG,XMDUZ="IFCAP FMS MESSAGE SERVER" D WHO^XMA21 D
;.I Y=-1 S PRCXM(2)=$P($T(ERROR+1),";;",2)_" "_PRCMG,(PRETRY,XMY(.5))=""
;I '$D(PRCMG) S PRCXM(2)=$P($T(ERROR+2),";;",2),XMY(.5)=""
D EMFORM ;S XMDUN="IFCAP SERVER ERROR"
;S XMSUB="Document Confirmation Transaction"
;S XMTEXT="PRCXM("
;D ^XMD
K PRCXM Q
ERROR ;
;;Mailgroup members designated in file 423.5:
;;Transaction control segment is messed up.
EMFORM ;
I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) N I,J D
.N THDR,TDATE,Y S THDR=^PRCF(423.6,PRCDA,1,10000,0)
.S Y=$P(THDR,U,10),Y=($E(Y,1,4)-1700)_$E(Y,5,8) D DD^%DT S TDATE=Y
.F I=1:1 S J=$O(PRCXM(I)) Q:J=""
.S I=I+1,PRCXM(I)=" ",I=I+1,PRCXM(I)=" System ID: "_$P(THDR,U,2),I=I+1
.S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Receiving Station #: "_$P(THDR,U,4)_" "_"Transaction Code : "_$P(THDR,U,5),I=I+1
.S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$E($P(THDR,U,11),1,2)_":"_$E($P(THDR,U,11),3,4)_":"_$E($P(THDR,U,11),5,6),I=I+1
.I $L($P(THDR,U,9))>0 S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Sales or Order #: "_$P(THDR,U,9),I=I+1
.S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Interface Version #: "_$P(THDR,U,14)_" Message File #: "_PRCDA
.Q
A N LN S DA=0 F S DA=$O(^PRCF(423.6,DA)) Q:+DA'=DA D ST
Q
ST S LN=10001
S CTL=$G(^PRCF(423.6,DA,1,10000,0)) Q:CTL=""!($P(CTL,U,5)'="DCT")
S DOC=$P(CTL,U,6)
DO F S LN=$O(^PRCF(423.6,DA,1,LN)) Q:LN="" S LIN=$G(^(LN,0)) D
. Q:"~"[$P(LIN,U,2) S SEG=$P(LIN,U,1)
. I SEG="ER1"!(SEG="ER2") D Q
. . N E,EC,EM F E=1:1:5 S EC=$P(LIN,U,E*2) Q:"~"[EC D
. . . S EM=$P(LIN,U,E*2+1) S SUB=DOC_" "_EC,^ZLX(SUB)=EM
. . . Q
. . Q
. I SEG="DCL" D Q
. . N S,STATUS S S=$P(LIN,U,3)
. . S STATUS=$S(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
. . S PRCXM(I)=" ",PRCXM(I+1)=" Line "_$P(LIN,U,5)_" "_STATUS
. . S PRCXM(I+2)=" ",I=I+3
. . Q
. I SEG="DCD" D Q
. . N S,STATUS S S=$P(LIN,U,3)
. . S STATUS=$S(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
. . S PRCXM(I+1)=" FMS Document "_$P(LIN,U,6)_"-"_$P(LIN,U,7)_" "_STATUS
. . S PRCXM(I)=" ",PRCXM(I+2)=" ",I=I+3
. . Q
. Q
Q
TFILER ; Transaction Filer
N OK,REM,REM1
I PRCDA=0 D
.L +^PRCF(423.6,0):5 I '$T S X="FMS Transaction file unavailable - File Lock Timeout.*" D MSG^PRCFQ Q
.F CNT=1:1 Q:'$D(^PRCF(423.6,CNT,0))
.S $P(^PRCF(423.6,0),U,3)=CNT,PRCDA=CNT,$P(^(0),U,4)=$P(^(0),U,4)+1 L +^PRCF(423.6,PRCDA)
.S ^PRCF(423.6,PRCDA,0)=PRCKEY,^PRCF(423.6,"B",PRCKEY,PRCDA)="",$P(^PRCF(423.6,PRCDA,1,0),U,2)=$P(^DD(423.6,1,0),U,2) K CNT L -^PRCF(423.6,0) L -^PRCF(423.6,PRCDA)
L +^PRCF(423.6,PRCDA):5 I '$T S X="FMS Transaction record unavailable - File lock timeout.*" D MSG^PRCFQ Q
N II,LEN,OCNT,SCNT S (OCNT,SCNT)=10000*(+$P(XMRG,U,12)) I +$P(XMRG,U,12)=1 S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG,SCNT=SCNT+1
S (OK,REM,REM1,S1)="" F D Q:XMER'=0 I S1>0 Q
.S:REM["}" S1=2 Q:REM["}" S:XMRG["{" S1=1,XMRG="" X:S1="" XMREC Q:XMER<0
.S:$L(REM)+$L(REM1)<241 REM=REM_REM1,REM1="" S:$L(REM)+$L(XMRG)<241 XMRG=REM_XMRG,REM="" I $L(REM)+$L(XMRG)>240 S REM1=$E(XMRG,241-$L(REM),$L(XMRG)),XMRG=REM_$E(XMRG,1,240-$L(REM))
.S LEN=$F(XMRG,"~")
.I LEN>1,LEN<241 S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,LEN-1),SCNT=SCNT+1,REM=$E(XMRG,LEN,$L(XMRG)) Q
.I $L(XMRG)>0,$L(XMRG)<241 S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG,SCNT=SCNT+1,REM="" Q
.I $E(XMRG,1,240)["^" F II=240:-1:1 I $E(XMRG,II)="^" S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II),SCNT=SCNT+1,REM=$E(XMRG,II+1,$L(XMRG)),OK=1 Q
.Q:OK=1 F II=240:-1:1 I $E(XMRG,II)=" " S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II),REM=$E(XMRG,II+1,$L(XMRG)) Q
.Q
S $P(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1,$P(^(0),U,4)=(SCNT-OCNT)+$P(^(0),U,4) L -^PRCF(423.6,PRCDA) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUDCT1 4045 printed Apr 09, 2024@21:12:21 Page 2
PRCUDCT1 ;WISC/LEM-Index FMS Document Transaction Rejects ;5/24/94 9:05 AM
V ;;5.0;IFCAP;;4/21/95
+1 ; This is a utility routine not accessible through IFCAP menus.
+2 QUIT
PERROR ; Process Errors
+1 NEW XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ
SET PRCEND=""
+2 ;I $D(PRCMG) S:PRCMG'["G." PRCMG="G."_PRCMG S X=PRCMG,XMDUZ="IFCAP FMS MESSAGE SERVER" D WHO^XMA21 D
+3 ;.I Y=-1 S PRCXM(2)=$P($T(ERROR+1),";;",2)_" "_PRCMG,(PRETRY,XMY(.5))=""
+4 ;I '$D(PRCMG) S PRCXM(2)=$P($T(ERROR+2),";;",2),XMY(.5)=""
+5 ;S XMDUN="IFCAP SERVER ERROR"
DO EMFORM
+6 ;S XMSUB="Document Confirmation Transaction"
+7 ;S XMTEXT="PRCXM("
+8 ;D ^XMD
+9 KILL PRCXM
QUIT
ERROR ;
+1 ;;Mailgroup members designated in file 423.5:
+2 ;;Transaction control segment is messed up.
EMFORM ;
+1 IF $DATA(PRCDA)
IF $DATA(^PRCF(423.6,PRCDA,1,10000,0))
NEW I,J
Begin DoDot:1
+2 NEW THDR,TDATE,Y
SET THDR=^PRCF(423.6,PRCDA,1,10000,0)
+3 SET Y=$PIECE(THDR,U,10)
SET Y=($EXTRACT(Y,1,4)-1700)_$EXTRACT(Y,5,8)
DO DD^%DT
SET TDATE=Y
+4 FOR I=1:1
SET J=$ORDER(PRCXM(I))
if J=""
QUIT
+5 SET I=I+1
SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" System ID: "_$PIECE(THDR,U,2)
SET I=I+1
+6 SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" Receiving Station #: "_$PIECE(THDR,U,4)_" "_"Transaction Code : "_$PIECE(THDR,U,5)
SET I=I+1
+7 SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$EXTRACT($PIECE(THDR,U,11),1,2)_":"_$EXTRACT($PIECE(THDR,U,11),3,4)_":"_$EXTRACT($PIECE(THDR,U,11),5,6)
SET I=I+1
+8 IF $LENGTH($PIECE(THDR,U,9))>0
SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" Sales or Order #: "_$PIECE(THDR,U,9)
SET I=I+1
+9 SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" Interface Version #: "_$PIECE(THDR,U,14)_" Message File #: "_PRCDA
+10 QUIT
End DoDot:1
A NEW LN
SET DA=0
FOR
SET DA=$ORDER(^PRCF(423.6,DA))
if +DA'=DA
QUIT
DO ST
+1 QUIT
ST SET LN=10001
+1 SET CTL=$GET(^PRCF(423.6,DA,1,10000,0))
if CTL=""!($PIECE(CTL,U,5)'="DCT")
QUIT
+2 SET DOC=$PIECE(CTL,U,6)
DO FOR
SET LN=$ORDER(^PRCF(423.6,DA,1,LN))
if LN=""
QUIT
SET LIN=$GET(^(LN,0))
Begin DoDot:1
+1 if "~"[$PIECE(LIN,U,2)
QUIT
SET SEG=$PIECE(LIN,U,1)
+2 IF SEG="ER1"!(SEG="ER2")
Begin DoDot:2
+3 NEW E,EC,EM
FOR E=1:1:5
SET EC=$PIECE(LIN,U,E*2)
if "~"[EC
QUIT
Begin DoDot:3
+4 SET EM=$PIECE(LIN,U,E*2+1)
SET SUB=DOC_" "_EC
SET ^ZLX(SUB)=EM
+5 QUIT
End DoDot:3
+6 QUIT
End DoDot:2
QUIT
+7 IF SEG="DCL"
Begin DoDot:2
+8 NEW S,STATUS
SET S=$PIECE(LIN,U,3)
+9 SET STATUS=$SELECT(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
+10 SET PRCXM(I)=" "
SET PRCXM(I+1)=" Line "_$PIECE(LIN,U,5)_" "_STATUS
+11 SET PRCXM(I+2)=" "
SET I=I+3
+12 QUIT
End DoDot:2
QUIT
+13 IF SEG="DCD"
Begin DoDot:2
+14 NEW S,STATUS
SET S=$PIECE(LIN,U,3)
+15 SET STATUS=$SELECT(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
+16 SET PRCXM(I+1)=" FMS Document "_$PIECE(LIN,U,6)_"-"_$PIECE(LIN,U,7)_" "_STATUS
+17 SET PRCXM(I)=" "
SET PRCXM(I+2)=" "
SET I=I+3
+18 QUIT
End DoDot:2
QUIT
+19 QUIT
End DoDot:1
+20 QUIT
TFILER ; Transaction Filer
+1 NEW OK,REM,REM1
+2 IF PRCDA=0
Begin DoDot:1
+3 LOCK +^PRCF(423.6,0):5
IF '$TEST
SET X="FMS Transaction file unavailable - File Lock Timeout.*"
DO MSG^PRCFQ
QUIT
+4 FOR CNT=1:1
if '$DATA(^PRCF(423.6,CNT,0))
QUIT
+5 SET $PIECE(^PRCF(423.6,0),U,3)=CNT
SET PRCDA=CNT
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
LOCK +^PRCF(423.6,PRCDA)
+6 SET ^PRCF(423.6,PRCDA,0)=PRCKEY
SET ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,2)=$PIECE(^DD(423.6,1,0),U,2)
KILL CNT
LOCK -^PRCF(423.6,0)
LOCK -^PRCF(423.6,PRCDA)
End DoDot:1
+7 LOCK +^PRCF(423.6,PRCDA):5
IF '$TEST
SET X="FMS Transaction record unavailable - File lock timeout.*"
DO MSG^PRCFQ
QUIT
+8 NEW II,LEN,OCNT,SCNT
SET (OCNT,SCNT)=10000*(+$PIECE(XMRG,U,12))
IF +$PIECE(XMRG,U,12)=1
SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
SET SCNT=SCNT+1
+9 SET (OK,REM,REM1,S1)=""
FOR
Begin DoDot:1
+10 if REM["}"
SET S1=2
if REM["}"
QUIT
if XMRG["{"
SET S1=1
SET XMRG=""
if S1=""
XECUTE XMREC
if XMER<0
QUIT
+11 if $LENGTH(REM)+$LENGTH(REM1)<241
SET REM=REM_REM1
SET REM1=""
if $LENGTH(REM)+$LENGTH(XMRG)<241
SET XMRG=REM_XMRG
SET REM=""
IF $LENGTH(REM)+$LENGTH(XMRG)>240
SET REM1=$EXTRACT(XMRG,241-$LENGTH(REM),$LENGTH(XMRG))
SET XMRG=REM_$EXTRACT(XMRG,1,240-$LENGTH(REM))
+12 SET LEN=$FIND(XMRG,"~")
+13 IF LEN>1
IF LEN<241
SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,LEN-1)
SET SCNT=SCNT+1
SET REM=$EXTRACT(XMRG,LEN,$LENGTH(XMRG))
QUIT
+14 IF $LENGTH(XMRG)>0
IF $LENGTH(XMRG)<241
SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
SET SCNT=SCNT+1
SET REM=""
QUIT
+15 IF $EXTRACT(XMRG,1,240)["^"
FOR II=240:-1:1
IF $EXTRACT(XMRG,II)="^"
SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
SET SCNT=SCNT+1
SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
SET OK=1
QUIT
+16 if OK=1
QUIT
FOR II=240:-1:1
IF $EXTRACT(XMRG,II)=" "
SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
QUIT
+17 QUIT
End DoDot:1
if XMER'=0
QUIT
IF S1>0
QUIT
+18 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
SET $PIECE(^(0),U,4)=(SCNT-OCNT)+$PIECE(^(0),U,4)
LOCK -^PRCF(423.6,PRCDA)
QUIT
