PRCOSRV1 ;WISC/RMP-Server interface to IFCAP from ISMS ;12/9/96 11:11 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 ISMS 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.ISM. If G.ISM
. ; also failed its lookup then send the bulletin to POSTMASTER.
. ;
. I Y=-1 D
. . S PRCXM(2)=$P($T(ERROR+1),";;",2),PRETRY=""
. . I PRCMG="G.ISM" S XMY(.5)="" Q
. . S X="G.ISM"
. . S XMDUZ="IFCAP ISMS 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.ISM. If G.ISM 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,4)_"."
. S X="G.ISM"
. S XMDUZ="IFCAP ISMS 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,X1,X2,Y
. S THDR=^PRCF(423.6,PRCDA,1,10000,0)
. S X1=($E($P(THDR,U,5),1,4)-1700)_"0101"
. S X2=$E($P(THDR,U,5),5,7)
. D C^%DTC
. D YX^%DTC
. 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)_" "_"Sending Station #: "_$P(THDR,U,2)
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" Receiving Station #: "_$P(THDR,U,3)_" "_"Transaction Code : "_$P(THDR,U,4)
. S I=I+1
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$E($P(THDR,U,6),1,2)_":"_$E($P(THDR,U,6),3,4)_":"_$E($P(THDR,U,6),5,6)
. S I=I+1
. I $L($P(THDR,U,7))>0 D
. . S PRCXM(I)=" "
. . S I=I+1
. . S PRCXM(I)=" Sales or Order #: "_$P(THDR,U,7)
. . S I=I+1
. . Q
. S PRCXM(I)=" "
. S I=I+1
. S PRCXM(I)=" Interface Version #: "_$P(THDR,U,10)_" 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,LEN,OCNT,SCNT
S (OCNT,SCNT)=10000*(+$P(XMRG,U,8))
I +$P(XMRG,U,8)=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
. 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 D
. . S REM1=$E(XMRG,241-$L(REM),$L(XMRG))
. . S XMRG=REM_$E(XMRG,1,240-$L(REM))
. . 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSRV1 5202 printed Dec 13, 2024@02:12:07 Page 2
PRCOSRV1 ;WISC/RMP-Server interface to IFCAP from ISMS ;12/9/96 11:11 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 ISMS 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.ISM. If G.ISM
+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)
SET PRETRY=""
+16 IF PRCMG="G.ISM"
SET XMY(.5)=""
QUIT
+17 SET X="G.ISM"
+18 SET XMDUZ="IFCAP ISMS MESSAGE SERVER"
+19 DO WHO^XMA21
+20 IF Y=-1
SET XMY(.5)=""
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 ;
+24 ; If there is no mail group defined when this ERROR routine is called
+25 ; send the bulletin to G.ISM. If G.ISM failed the lookup then send
+26 ; the bulletin to POSTMASTER.
+27 ;
+28 IF $GET(PRCMG)=""
Begin DoDot:1
+29 SET PRCXM(2)=$PIECE($TEXT(ERROR+2),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4)_"."
+30 SET X="G.ISM"
+31 SET XMDUZ="IFCAP ISMS MESSAGE SERVER"
+32 DO WHO^XMA21
+33 IF Y=-1
SET XMY(.5)=""
+34 QUIT
End DoDot:1
+35 ;
+36 DO EMFORM
+37 SET XMDUN="IFCAP SERVER ERROR"
+38 SET XMSUB="IFCAP message router error"
+39 SET XMTEXT="PRCXM("
+40 DO ^XMD
+41 KILL PRCXM
+42 QUIT
+43 ;
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,X1,X2,Y
+31 SET THDR=^PRCF(423.6,PRCDA,1,10000,0)
+32 SET X1=($EXTRACT($PIECE(THDR,U,5),1,4)-1700)_"0101"
+33 SET X2=$EXTRACT($PIECE(THDR,U,5),5,7)
+34 DO C^%DTC
+35 DO YX^%DTC
+36 SET TDATE=Y
+37 SET I=I+1
+38 SET PRCXM(I)=" "
+39 SET I=I+1
+40 SET PRCXM(I)=" This is the CONTROL segment from the saved transaction in file 423.6:"
+41 SET I=I+1
+42 SET PRCXM(I)=" "_THDR
+43 SET I=I+1
+44 SET PRCXM(I)=" "
+45 SET I=I+1
+46 SET PRCXM(I)=" System ID: "_$PIECE(THDR,U)_" "_"Sending Station #: "_$PIECE(THDR,U,2)
+47 SET I=I+1
+48 SET PRCXM(I)=" "
+49 SET I=I+1
+50 SET PRCXM(I)=" Receiving Station #: "_$PIECE(THDR,U,3)_" "_"Transaction Code : "_$PIECE(THDR,U,4)
+51 SET I=I+1
+52 SET PRCXM(I)=" "
+53 SET I=I+1
+54 SET PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$EXTRACT($PIECE(THDR,U,6),1,2)_":"_$EXTRACT($PIECE(THDR,U,6),3,4)_":"_$EXTRACT($PIECE(THDR,U,6),5,6)
+55 SET I=I+1
+56 IF $LENGTH($PIECE(THDR,U,7))>0
Begin DoDot:2
+57 SET PRCXM(I)=" "
+58 SET I=I+1
+59 SET PRCXM(I)=" Sales or Order #: "_$PIECE(THDR,U,7)
+60 SET I=I+1
+61 QUIT
End DoDot:2
+62 SET PRCXM(I)=" "
+63 SET I=I+1
+64 SET PRCXM(I)=" Interface Version #: "_$PIECE(THDR,U,10)_" Message File (423.6) #: "_PRCDA
End DoDot:1
+65 QUIT
+66 ;
TFILER ;Transaction Filer
+1 ;
+2 NEW OK,REM,REM1,YY
+3 IF PRCDA=0
Begin DoDot:1
+4 FOR
LOCK +^PRCF(423.6,0):1
if $TEST
QUIT
+5 SET YY=+$ORDER(^PRCF(423.6,"B",PRCKEY,0))
+6 IF YY>0
SET PRCDA=YY
LOCK -^PRCF(423.6,0)
QUIT
+7 SET CNT=$PIECE($GET(^PRCF(423.6,0)),U,3)
+8 FOR
SET CNT=CNT+1
if $GET(^PRCF(423.6,CNT,0))=""
QUIT
+9 SET $PIECE(^PRCF(423.6,0),U,3)=CNT
+10 SET PRCDA=CNT
+11 SET $PIECE(^PRCF(423.6,0),U,4)=$PIECE(^PRCF(423.6,0),U,4)+1
+12 FOR
LOCK +^PRCF(423.6,PRCDA):1
if $TEST
QUIT
+13 SET ^PRCF(423.6,PRCDA,0)=PRCKEY
+14 SET ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
+15 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,2)=$PIECE(^DD(423.6,1,0),U,2)
+16 KILL CNT
+17 LOCK -^PRCF(423.6,0)
+18 LOCK -^PRCF(423.6,PRCDA)
End DoDot:1
+19 FOR
LOCK +^PRCF(423.6,PRCDA):1
if $TEST
QUIT
+20 NEW II,LEN,OCNT,SCNT
+21 SET (OCNT,SCNT)=10000*(+$PIECE(XMRG,U,8))
+22 IF +$PIECE(XMRG,U,8)=1
Begin DoDot:1
+23 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
+24 SET SCNT=SCNT+1
End DoDot:1
+25 SET (OK,REM,REM1,S1)=""
+26 FOR
Begin DoDot:1
+27 if REM["~"
SET S1=2
+28 if REM["~"
QUIT
+29 if XMRG["$"
SET S1=1
SET XMRG=""
+30 if S1=""
XECUTE XMREC
+31 if XMER<0
QUIT
+32 if $LENGTH(REM)+$LENGTH(REM1)<241
SET REM=REM_REM1
SET REM1=""
+33 if $LENGTH(REM)+$LENGTH(XMRG)<241
SET XMRG=REM_XMRG
SET REM=""
+34 IF $LENGTH(REM)+$LENGTH(XMRG)>240
Begin DoDot:2
+35 SET REM1=$EXTRACT(XMRG,241-$LENGTH(REM),$LENGTH(XMRG))
+36 SET XMRG=REM_$EXTRACT(XMRG,1,240-$LENGTH(REM))
+37 QUIT
End DoDot:2
+38 SET LEN=$FIND(XMRG,"|")
+39 IF LEN>1
IF LEN<241
Begin DoDot:2
+40 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,LEN-1)
+41 SET SCNT=SCNT+1
+42 SET REM=$EXTRACT(XMRG,LEN,$LENGTH(XMRG))
+43 QUIT
End DoDot:2
QUIT
+44 IF $LENGTH(XMRG)>0
IF $LENGTH(XMRG)<241
Begin DoDot:2
+45 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
+46 SET SCNT=SCNT+1
+47 SET REM=""
+48 QUIT
End DoDot:2
QUIT
+49 IF $EXTRACT(XMRG,1,240)["^"
FOR II=240:-1:1
IF $EXTRACT(XMRG,II)="^"
Begin DoDot:2
+50 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
+51 SET SCNT=SCNT+1
+52 SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
+53 SET OK=1
+54 QUIT
End DoDot:2
QUIT
+55 if OK=1
QUIT
+56 FOR II=240:-1:1
IF $EXTRACT(XMRG,II)=" "
Begin DoDot:2
+57 SET ^PRCF(423.6,PRCDA,1,SCNT,0)=$EXTRACT(XMRG,1,II)
+58 SET REM=$EXTRACT(XMRG,II+1,$LENGTH(XMRG))
+59 QUIT
End DoDot:2
QUIT
+60 QUIT
End DoDot:1
if XMER'=0
QUIT
IF S1>0
QUIT
+61 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
+62 SET $PIECE(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$PIECE(^PRCF(423.6,PRCDA,1,0),U,4)
+63 LOCK -^PRCF(423.6,PRCDA)
+64 QUIT
