PRCODCT1 ;WISC/DJM-Server interface to IFCAP from FMS ;5/30/95 1:22 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
PERROR ; Process Errors
N XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ,PRCEND,E,EC,LIN,S,SEG,STOP,XMCHAN,XMDUZ
S PRCEND=""
I $D(PRCMG) S:PRCMG'["G." PRCMG="G."_PRCMG ; S X=PRCMG
S XMDUZ="IFCAP FMS MESSAGE SERVER",XMCHAN=1
;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 (DCT)"
S XMTEXT="PRCXM(",XMY(PRCMG)=""
D ^XMD
K PRCXM
Q
ERROR ;
;;No mailgroup members designated in
;;There is no mailgroup listed for CTL-DCT in file 423.5.
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
.S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Interface Version #: "_$P(THDR,U,14),I=I+1
.Q
S LN=DOCLN,STOP=0
DO F S LN=$O(^PRCF(423.6,PRCDA,1,LN)) Q:LN="" Q:LN=LINE S LIN=$G(^(LN,0)) D Q:STOP=1
. S SEG=$P(LIN,U,1)
. I LN>DOCLN,(SEG="DOC") S STOP=1 Q
. Q:"~"[$P(LIN,U,2)
. 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),PRCXM(I)=" "_EC_" "_EM,I=I+1
. . . 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 I=I+2
. . 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)=" ",PRCXM(I+1)=" FMS Document "_DOCID_" "_STATUS
. . S I=I+2
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCODCT1 2277 printed Nov 22, 2024@17:21:46 Page 2
PRCODCT1 ;WISC/DJM-Server interface to IFCAP from FMS ;5/30/95 1:22 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
PERROR ; Process Errors
+1 NEW XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ,PRCEND,E,EC,LIN,S,SEG,STOP,XMCHAN,XMDUZ
+2 SET PRCEND=""
+3 ; S X=PRCMG
IF $DATA(PRCMG)
if PRCMG'["G."
SET PRCMG="G."_PRCMG
+4 SET XMDUZ="IFCAP FMS MESSAGE SERVER"
SET XMCHAN=1
+5 ;D WHO^XMA21 D
+6 ;.I Y=-1 S PRCXM(2)=$P($T(ERROR+1),";;",2)_" "_PRCMG,(PRETRY,XMY(.5))=""
+7 IF '$DATA(PRCMG)
SET PRCXM(2)=$PIECE($TEXT(ERROR+2),";;",2)
SET XMY(.5)=""
+8 DO EMFORM
SET XMDUN="IFCAP SERVER ERROR"
+9 SET XMSUB="Document Confirmation Transaction (DCT)"
+10 SET XMTEXT="PRCXM("
SET XMY(PRCMG)=""
+11 DO ^XMD
+12 KILL PRCXM
+13 QUIT
ERROR ;
+1 ;;No mailgroup members designated in
+2 ;;There is no mailgroup listed for CTL-DCT in file 423.5.
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 SET PRCXM(I)=" "
SET I=I+1
SET PRCXM(I)=" Interface Version #: "_$PIECE(THDR,U,14)
SET I=I+1
+9 QUIT
End DoDot:1
+10 SET LN=DOCLN
SET STOP=0
DO FOR
SET LN=$ORDER(^PRCF(423.6,PRCDA,1,LN))
if LN=""
QUIT
if LN=LINE
QUIT
SET LIN=$GET(^(LN,0))
Begin DoDot:1
+1 SET SEG=$PIECE(LIN,U,1)
+2 IF LN>DOCLN
IF (SEG="DOC")
SET STOP=1
QUIT
+3 if "~"[$PIECE(LIN,U,2)
QUIT
+4 IF SEG="ER1"!(SEG="ER2")
Begin DoDot:2
+5 NEW E,EC,EM
FOR E=1:1:5
SET EC=$PIECE(LIN,U,E*2)
if "~"[EC
QUIT
Begin DoDot:3
+6 SET EM=$PIECE(LIN,U,E*2+1)
SET PRCXM(I)=" "_EC_" "_EM
SET I=I+1
+7 QUIT
End DoDot:3
+8 QUIT
End DoDot:2
QUIT
+9 IF SEG="DCL"
Begin DoDot:2
+10 NEW S,STATUS
SET S=$PIECE(LIN,U,3)
+11 SET STATUS=$SELECT(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
+12 SET PRCXM(I)=" "
SET PRCXM(I+1)=" Line "_$PIECE(LIN,U,5)_" "_STATUS
+13 SET I=I+2
+14 QUIT
End DoDot:2
QUIT
+15 IF SEG="DCD"
Begin DoDot:2
+16 NEW S,STATUS
SET S=$PIECE(LIN,U,3)
+17 SET STATUS=$SELECT(S="A":"Accepted.",S="R":"Rejected:",1:"unknown.")
+18 SET PRCXM(I)=" "
SET PRCXM(I+1)=" FMS Document "_DOCID_" "_STATUS
+19 SET I=I+2
End DoDot:2
QUIT
+20 QUIT
End DoDot:1
if STOP=1
QUIT
+21 QUIT
