55 lines
2.2 KiB
Mathematica
55 lines
2.2 KiB
Mathematica
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
|