- 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 Feb 18, 2025@23:45:55 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
