PRCOSRV3 ;WISC/DJM-Server interface to IFCAP from FMS ;12/9/96 11:12 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
PERROR ; Process Errors
N X,XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ
S PRCEND=""
S XMRG=PRCOXMRG
I $D(PRCMG),PRCMG]"" D
. S:PRCMG'["G." PRCMG="G."_PRCMG
. S X=PRCMG
. S XMDUZ="IFCAP FMS MESSAGE SERVER"
. D WHO^XMA21
. ;
. ; If the mail group found in file 423.5 for this transaction
. ; failed the lookup send the bulletin to G.FMS. If G.FMS
. ; also failed its lookup then send the bulletin to POSTMASTER.
. ;
. I Y=-1 D
. . S PRCXM(2)=$P($T(ERROR+1),";;",2)
. . S PRETRY=""
. . I PRCMG="G.FMS" S XMY(.5)="" Q
. . S X="G.FMS"
. . S XMDUZ="IFCAP FMS MESSAGE SERVER"
. . D WHO^XMA21
. . I Y=-1 S XMY(.5)=""
. . Q
. Q
;
; If there is no mail group defined when this ERROR routine is called
; send the bulletin to G.FMS. If G.FMS failed the lookup then send
; the bulletin to POSTMASTER.
;
I $G(PRCMG)="" D
. S PRCXM(2)=$P($T(ERROR+2),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,5)_"."
. S X="G.FMS"
. S XMDUZ="IFCAP FMS MESSAGE SERVER"
. D WHO^XMA21
. I Y=-1 S XMY(.5)=""
. Q
;
D EMFORM
S XMDUN="IFCAP SERVER ERROR"
S XMSUB="IFCAP message router error"
S XMTEXT="PRCXM("
D ^XMD
K PRCXM
Q
;
ERROR ;
;;Mailgroup designated in file 423.5 could not list its members.
;;There is no mail group listed for transaction
;
EMFORM ; FIRST DISPLAY INFORMATION ABOUT THE INCOMMING MAIL MESSAGE
;
N I,J
F I=1:1 S J=$O(PRCXM(I)) Q:J=""
S I=I+1
S PRCXM(I)=" "
S I=I+1
S PRCXM(I)=" Sent to Server: "_PRCOSOP
S I=I+1
S PRCXM(I)=" "
S I=I+1
S PRCXM(I)=" MailMan Message #: "_PRCOMSG
S I=I+1
S PRCXM(I)=" "
S I=I+1
S PRCXM(I)=" Sent From: "_PRCOSND
S I=I+1
S PRCXM(I)=" "
S I=I+1
S PRCXM(I)=" Message Subject: "_PRCOSUB
S I=I+1
S PRCXM(I)=" "
S I=I+1
S PRCXM(I)=" What this server thinks is the CONTROL segment of the transaction:"
S I=I+1
S PRCXM(I)=" "_XMRG
;
; HERE IS THE DATA FROM THE CONTROL SEGMENT SAVED IN FILE 423.6
;
I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) D
. N THDR,TDATE,Y
. S THDR=^PRCF(423.6,PRCDA,1,10000,0)
. S Y=$P(THDR,U,10)
. S Y=($E(Y,1,4)-1700)_$E(Y,5,8)
. D DD^%DT
. S TDATE=Y
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" This is the CONTROL segment from the saved transaction in file 423.6:"
. S I=I+1
. S PRCXM(I)=" "_THDR
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" System ID: "_$P(THDR,U,2)
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" Recieving Station #: "_$P(THDR,U,4)_" "_"Transaction Code : "_$P(THDR,U,5)
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S 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)
. S I=I+1
. I $L($P(THDR,U,9))>0 D
. . S PRCXM(I)=" "
. . S I=I+1
. . S PRCXM(I)=" Sales or Order #: "_$P(THDR,U,9)
. . S I=I+1
. . Q
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" Interface Version #: "_$P(THDR,U,14)_" Message File (423.6) #: "_PRCDA
Q
;
TFILER ;Transaction Filer
N OK,REM,REM1,YY
I PRCDA=0 D
. F L +^PRCF(423.6,0):1 Q:$T
. S YY=$O(^PRCF(423.6,"B",PRCKEY,0))
. I YY>0 S PRCDA=YY L -^PRCF(423.6,0) Q
. S CNT=$P($G(^PRCF(423.6,0)),U,3)
. F S CNT=CNT+1 Q:$G(^PRCF(423.6,CNT,0))=""
. S $P(^PRCF(423.6,0),U,3)=CNT
. S PRCDA=CNT
. S $P(^PRCF(423.6,0),U,4)=$P(^PRCF(423.6,0),U,4)+1
. F L +^PRCF(423.6,PRCDA):1 Q:$T
. S ^PRCF(423.6,PRCDA,0)=PRCKEY
. S ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
. S $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)
F L +^PRCF(423.6,PRCDA):1 Q:$T
N II,EOM,LEN,OCNT,SCNT
S (OCNT,SCNT)=10000*(+$P(XMRG,U,12))
I +$P(XMRG,U,12)=1 D
. S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
. S SCNT=SCNT+1
S (OK,REM,REM1,S1)=""
F D Q:XMER'=0 I S1>0 Q
. I REM["}" S S1=2 Q
. 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 D
. . S REM1=$E(XMRG,241-$L(REM),$L(XMRG))
. . S XMRG=REM_$E(XMRG,1,240-$L(REM))
. . Q
. S EOM=$F(XMRG,"}")
. I EOM>2 S XMRG=$E(XMRG,1,EOM-1),S1=2,REM1=""
. I EOM=2 S S1=2 Q
. S LEN=$F(XMRG,"~")
. I LEN>1,LEN<241 D Q
. . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,LEN-1)
. . S SCNT=SCNT+1
. . S REM=$E(XMRG,LEN,$L(XMRG))
. . Q
. I $L(XMRG)>0,$L(XMRG)<241 D Q
. . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
. . S SCNT=SCNT+1
. . S REM=""
. . Q
. I $E(XMRG,1,240)["^" F II=240:-1:1 I $E(XMRG,II)="^" D Q
. . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
. . S SCNT=SCNT+1
. . S REM=$E(XMRG,II+1,$L(XMRG))
. . S OK=1
. . Q
. Q:OK=1
. F II=240:-1:1 I $E(XMRG,II)=" " D Q
. . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
. . S REM=$E(XMRG,II+1,$L(XMRG))
. . Q
. Q
S $P(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
S $P(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$P(^PRCF(423.6,PRCDA,1,0),U,4)
L -^PRCF(423.6,PRCDA)
Q
;
KILL(PRCDA) ;ENTER HERE TO REMOVE THE 423.6 RECORD THAT YOU HAVE FINISHED WITH.
N DA,DIK
S DA=PRCDA
S DIK="^PRCF(423.6,"
D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSRV3 5339 printed Nov 22, 2024@17:22:14 Page 2
PRCOSRV3 ;WISC/DJM-Server interface to IFCAP from FMS ;12/9/96 11:12 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
PERROR ; Process Errors
+1 NEW X,XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ
+2 SET PRCEND=""
+3 SET XMRG=PRCOXMRG
+4 IF $DATA(PRCMG)
IF PRCMG]""
Begin DoDot:1
+5 if PRCMG'["G."
SET PRCMG="G."_PRCMG
+6 SET X=PRCMG
+7 SET XMDUZ="IFCAP FMS MESSAGE SERVER"
+8 DO WHO^XMA21
+9 ;
+10 ; If the mail group found in file 423.5 for this transaction
+11 ; failed the lookup send the bulletin to G.FMS. If G.FMS
+12 ; also failed its lookup then send the bulletin to POSTMASTER.
+13 ;
+14 IF Y=-1
Begin DoDot:2
+15 SET PRCXM(2)=$PIECE($TEXT(ERROR+1),";;",2)
+16 SET PRETRY=""
+17 IF PRCMG="G.FMS"
SET XMY(.5)=""
QUIT
+18 SET X="G.FMS"
+19 SET XMDUZ="IFCAP FMS MESSAGE SERVER"
+20 DO WHO^XMA21
+21 IF Y=-1
SET XMY(.5)=""
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 ;
+25 ; If there is no mail group defined when this ERROR routine is called
+26 ; send the bulletin to G.FMS. If G.FMS failed the lookup then send
+27 ; the bulletin to POSTMASTER.
+28 ;
+29 IF $GET(PRCMG)=""
Begin DoDot:1
+30 SET PRCXM(2)=$PIECE($TEXT(ERROR+2),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,5)_"."
+31 SET X="G.FMS"
+32 SET XMDUZ="IFCAP FMS MESSAGE SERVER"
+33 DO WHO^XMA21
+34 IF Y=-1
SET XMY(.5)=""
+35 QUIT
End DoDot:1
+36 ;
+37 DO EMFORM
+38 SET XMDUN="IFCAP SERVER ERROR"
+39 SET XMSUB="IFCAP message router error"
+40 SET XMTEXT="PRCXM("
+41 DO ^XMD
+42 KILL PRCXM
+43 QUIT
+44 ;
ERROR ;
+1 ;;Mailgroup designated in file 423.5 could not list its members.
+2 ;;There is no mail group listed for transaction
+3 ;
EMFORM ; FIRST DISPLAY INFORMATION ABOUT THE INCOMMING MAIL MESSAGE
+1 ;
+2 NEW I,J
+3 FOR I=1:1
SET J=$ORDER(PRCXM(I))
if J=""
QUIT
+4 SET I=I+1
+5 SET PRCXM(I)=" "
+6 SET I=I+1
+7 SET PRCXM(I)=" Sent to Server: "_PRCOSOP
+8 SET I=I+1
+9 SET PRCXM(I)=" "
+10 SET I=I+1
+11 SET PRCXM(I)=" MailMan Message #: "_PRCOMSG
+12 SET I=I+1
+13 SET PRCXM(I)=" "
+14 SET I=I+1
+15 SET PRCXM(I)=" Sent From: "_PRCOSND
+16 SET I=I+1
+17 SET PRCXM(I)=" "
+18 SET I=I+1
+19 SET PRCXM(I)=" Message Subject: "_PRCOSUB
+20 SET I=I+1
+21 SET PRCXM(I)=" "
+22 SET I=I+1
+23 SET PRCXM(I)=" What this server thinks is the CONTROL segment of the transaction:"
+24 SET I=I+1
+25 SET PRCXM(I)=" "_XMRG
+26 ;
+27 ; HERE IS THE DATA FROM THE CONTROL SEGMENT SAVED IN FILE 423.6
+28 ;
+29 IF $DATA(PRCDA)
IF $DATA(^PRCF(423.6,PRCDA,1,10000,0))
Begin DoDot:1
+30 NEW THDR,TDATE,Y
+31 SET THDR=^PRCF(423.6,PRCDA,1,10000,0)
+32 SET Y=$PIECE(THDR,U,10)
+33 SET Y=($EXTRACT(Y,1,4)-1700)_$EXTRACT(Y,5,8)
+34 DO DD^%DT
+35 SET TDATE=Y
+36 SET I=I+1
+37 SET PRCXM(I)=" "
+38 SET I=I+1
+39 SET PRCXM(I)=" This is the CONTROL segment from the saved transaction in file 423.6:"
+40 SET I=I+1
+41 SET PRCXM(I)=" "_THDR
+42 SET I=I+1
+43 SET PRCXM(I)=" "
+44 SET I=I+1
+45 SET PRCXM(I)=" System ID: "_$PIECE(THDR,U,2)
+46 SET I=I+1
+47 SET PRCXM(I)=" "
+48 SET I=I+1
+49 SET PRCXM(I)=" Recieving Station #: "_$PIECE(THDR,U,4)_" "_"Transaction Code : "_$PIECE(THDR,U,5)
+50 SET I=I+1
+51 SET PRCXM(I)=" "
+52 SET I=I+1
+53 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)
+54 SET I=I+1
+55 IF $LENGTH($PIECE(THDR,U,9))>0
Begin DoDot:2
+56 SET PRCXM(I)=" "
+57 SET I=I+1
+58 SET PRCXM(I)=" Sales or Order #: "_$PIECE(THDR,U,9)
+59 SET I=I+1
+60 QUIT
End DoDot:2
+61 SET PRCXM(I)=" "
+62 SET I=I+1
+63 SET PRCXM(I)=" Interface Version #: "_$PIECE(THDR,U,14)_" Message File (423.6) #: "_PRCDA
End DoDot:1
+64 QUIT
+65 ;
TFILER ;Transaction Filer
+1 NEW OK,REM,REM1,YY
+2 IF PRCDA=0
Begin DoDot:1
+3 FOR
LOCK +^PRCF(423.6,0):1
if $TEST
QUIT
+4 SET YY=$ORDER(^PRCF(423.6,"B",PRCKEY,0))
+5 IF YY>0
SET PRCDA=YY
LOCK -^PRCF(423.6,0)
QUIT
+6 SET CNT=$PIECE($GET(^PRCF(423.6,0)),U,3)
+7 FOR
SET CNT=CNT+1
if $GET(^PRCF(423.6,CNT,0))=""
QUIT
+8 SET $PIECE(^PRCF(423.6,0),U,3)=CNT
+9 SET PRCDA=CNT
+10 SET $PIECE(^PRCF(423.6,0),U,4)=$PIECE(^PRCF(423.6,0),U,4)+1
+11 FOR
LOCK +^PRCF(423.6,PRCDA):1
if $TEST
QUIT
+12 SET ^PRCF(423.6,PRCDA,0)=PRCKEY
+13 SET ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
+14 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,2)=$PIECE(^DD(423.6,1,0),U,2)
+15 KILL CNT
+16 LOCK -^PRCF(423.6,0)
+17 LOCK -^PRCF(423.6,PRCDA)
End DoDot:1
+18 FOR
LOCK +^PRCF(423.6,PRCDA):1
if $TEST
QUIT
+19 NEW II,EOM,LEN,OCNT,SCNT
+20 SET (OCNT,SCNT)=10000*(+$PIECE(XMRG,U,12))
+21 IF +$PIECE(XMRG,U,12)=1
Begin DoDot:1
+22 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
+23 SET SCNT=SCNT+1
End DoDot:1
+24 SET (OK,REM,REM1,S1)=""
+25 FOR
Begin DoDot:1
+26 IF REM["}"
SET S1=2
QUIT
+27 if XMRG["{"
SET S1=1
SET XMRG=""
+28 if S1=""
XECUTE XMREC
+29 if XMER<0
QUIT
+30 if $LENGTH(REM)+$LENGTH(REM1)<241
SET REM=REM_REM1
SET REM1=""
+31 if $LENGTH(REM)+$LENGTH(XMRG)<241
SET XMRG=REM_XMRG
SET REM=""
+32 IF $LENGTH(REM)+$LENGTH(XMRG)>240
Begin DoDot:2
+33 SET REM1=$EXTRACT(XMRG,241-$LENGTH(REM),$LENGTH(XMRG))
+34 SET XMRG=REM_$EXTRACT(XMRG,1,240-$LENGTH(REM))
+35 QUIT
End DoDot:2
+36 SET EOM=$FIND(XMRG,"}")
+37 IF EOM>2
SET XMRG=$EXTRACT(XMRG,1,EOM-1)
SET S1=2
SET REM1=""
+38 IF EOM=2
SET S1=2
QUIT
+39 SET LEN=$FIND(XMRG,"~")
+40 IF LEN>1
IF LEN<241
Begin DoDot:2
+41 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,LEN-1)
+42 SET SCNT=SCNT+1
+43 SET REM=$EXTRACT(XMRG,LEN,$LENGTH(XMRG))
+44 QUIT
End DoDot:2
QUIT
+45 IF $LENGTH(XMRG)>0
IF $LENGTH(XMRG)<241
Begin DoDot:2
+46 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
+47 SET SCNT=SCNT+1
+48 SET REM=""
+49 QUIT
End DoDot:2
QUIT
+50 IF $EXTRACT(XMRG,1,240)["^"
FOR II=240:-1:1
IF $EXTRACT(XMRG,II)="^"
Begin DoDot:2
+51 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
+52 SET SCNT=SCNT+1
+53 SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
+54 SET OK=1
+55 QUIT
End DoDot:2
QUIT
+56 if OK=1
QUIT
+57 FOR II=240:-1:1
IF $EXTRACT(XMRG,II)=" "
Begin DoDot:2
+58 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
+59 SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
+60 QUIT
End DoDot:2
QUIT
+61 QUIT
End DoDot:1
if XMER'=0
QUIT
IF S1>0
QUIT
+62 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
+63 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$PIECE(^PRCF(423.6,PRCDA,1,0),U,4)
+64 LOCK -^PRCF(423.6,PRCDA)
+65 QUIT
+66 ;
KILL(PRCDA) ;ENTER HERE TO REMOVE THE 423.6 RECORD THAT YOU HAVE FINISHED WITH.
+1 NEW DA,DIK
+2 SET DA=PRCDA
+3 SET DIK="^PRCF(423.6,"
+4 DO ^DIK
+5 QUIT
