- 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 Feb 18, 2025@23:38:03 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
