Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCOSRV3

PRCOSRV3.m

Go to the documentation of this file. 
  1. PRCOSRV3 ;WISC/DJM-Server interface to IFCAP from FMS ;12/9/96  11:12 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1.  ;
  1. PERROR ; Process Errors
  1.  N X,XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ
  1.  S PRCEND=""
  1.  S XMRG=PRCOXMRG
  1.  I $D(PRCMG),PRCMG]"" D
  1.  . S:PRCMG'["G." PRCMG="G."_PRCMG
  1.  . S X=PRCMG
  1.  . S XMDUZ="IFCAP FMS MESSAGE SERVER"
  1.  . D WHO^XMA21
  1.  . ;
  1.  . ; If the mail group found in file 423.5 for this transaction
  1.  . ; failed the lookup send the bulletin to G.FMS.  If G.FMS
  1.  . ; also failed its lookup then send the bulletin to POSTMASTER.
  1.  . ;
  1.  . I Y=-1 D
  1.  . . S PRCXM(2)=$P($T(ERROR+1),";;",2)
  1.  . . S PRETRY=""
  1.  . . I PRCMG="G.FMS" S XMY(.5)="" Q
  1.  . . S X="G.FMS"
  1.  . . S XMDUZ="IFCAP FMS MESSAGE SERVER"
  1.  . . D WHO^XMA21
  1.  . . I Y=-1 S XMY(.5)=""
  1.  . . Q
  1.  . Q
  1.  ;
  1.  ; If there is no mail group defined when this ERROR routine is called
  1.  ; send the bulletin to G.FMS.  If G.FMS failed the lookup then send
  1.  ; the bulletin to POSTMASTER.
  1.  ;
  1.  I $G(PRCMG)="" D
  1.  . S PRCXM(2)=$P($T(ERROR+2),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,5)_"."
  1.  . S X="G.FMS"
  1.  . S XMDUZ="IFCAP FMS MESSAGE SERVER"
  1.  . D WHO^XMA21
  1.  . I Y=-1 S XMY(.5)=""
  1.  . Q
  1.  ;
  1.  D EMFORM
  1.  S XMDUN="IFCAP SERVER ERROR"
  1.  S XMSUB="IFCAP message router error"
  1.  S XMTEXT="PRCXM("
  1.  D ^XMD
  1.  K PRCXM
  1.  Q
  1.  ;
  1. ERROR ;
  1.  ;;Mailgroup designated in file 423.5 could not list its members.
  1.  ;;There is no mail group listed for transaction
  1.  ;
  1. EMFORM ; FIRST DISPLAY INFORMATION ABOUT THE INCOMMING MAIL MESSAGE
  1.  ;
  1.  N I,J
  1.  F I=1:1 S J=$O(PRCXM(I)) Q:J=""
  1.  S I=I+1
  1.  S PRCXM(I)=" "
  1.  S I=I+1
  1.  S PRCXM(I)="  Sent to Server: "_PRCOSOP
  1.  S I=I+1
  1.  S PRCXM(I)=" "
  1.  S I=I+1
  1.  S PRCXM(I)="  MailMan Message #: "_PRCOMSG
  1.  S I=I+1
  1.  S PRCXM(I)=" "
  1.  S I=I+1
  1.  S PRCXM(I)="  Sent From: "_PRCOSND
  1.  S I=I+1
  1.  S PRCXM(I)=" "
  1.  S I=I+1
  1.  S PRCXM(I)="  Message Subject: "_PRCOSUB
  1.  S I=I+1
  1.  S PRCXM(I)=" "
  1.  S I=I+1
  1.  S PRCXM(I)="  What this server thinks is the CONTROL segment of the transaction:"
  1.  S I=I+1
  1.  S PRCXM(I)="  "_XMRG
  1.  ;
  1.  ; HERE IS THE DATA FROM THE CONTROL SEGMENT SAVED IN FILE 423.6
  1.  ;
  1.  I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) D
  1.  . N THDR,TDATE,Y
  1.  . S THDR=^PRCF(423.6,PRCDA,1,10000,0)
  1.  . S Y=$P(THDR,U,10)
  1.  . S Y=($E(Y,1,4)-1700)_$E(Y,5,8)
  1.  . D DD^%DT
  1.  . S TDATE=Y
  1.  . S I=I+1
  1.  . S PRCXM(I)=" "
  1.  . S I=I+1
  1.  . S PRCXM(I)="  This is the CONTROL segment from the saved transaction in file 423.6:"
  1.  . S I=I+1
  1.  . S PRCXM(I)="  "_THDR
  1.  . S I=I+1
  1.  . S PRCXM(I)=" "
  1.  . S I=I+1
  1.  . S PRCXM(I)="  System ID: "_$P(THDR,U,2)
  1.  . S I=I+1
  1.  . S PRCXM(I)=" "
  1.  . S I=I+1
  1.  . S PRCXM(I)="  Recieving Station #: "_$P(THDR,U,4)_"                "_"Transaction Code : "_$P(THDR,U,5)
  1.  . S I=I+1
  1.  . S PRCXM(I)=" "
  1.  . S I=I+1
  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)
  1.  . S I=I+1
  1.  . I $L($P(THDR,U,9))>0 D
  1.  . . S PRCXM(I)=" "
  1.  . . S I=I+1
  1.  . . S PRCXM(I)="  Sales or Order #: "_$P(THDR,U,9)
  1.  . . S I=I+1
  1.  . . Q
  1.  . S PRCXM(I)=" "
  1.  . S I=I+1
  1.  . S PRCXM(I)="  Interface Version #: "_$P(THDR,U,14)_"                Message File (423.6) #: "_PRCDA
  1.  Q
  1.  ;
  1. TFILER ;Transaction Filer
  1.  N OK,REM,REM1,YY
  1.  I PRCDA=0 D
  1.  . F  L +^PRCF(423.6,0):1 Q:$T
  1.  . S YY=$O(^PRCF(423.6,"B",PRCKEY,0))
  1.  . I YY>0 S PRCDA=YY L -^PRCF(423.6,0) Q
  1.  . S CNT=$P($G(^PRCF(423.6,0)),U,3)
  1.  . F  S CNT=CNT+1 Q:$G(^PRCF(423.6,CNT,0))=""
  1.  . S $P(^PRCF(423.6,0),U,3)=CNT
  1.  . S PRCDA=CNT
  1.  . S $P(^PRCF(423.6,0),U,4)=$P(^PRCF(423.6,0),U,4)+1
  1.  . F  L +^PRCF(423.6,PRCDA):1 Q:$T
  1.  . S ^PRCF(423.6,PRCDA,0)=PRCKEY
  1.  . S ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
  1.  . S $P(^PRCF(423.6,PRCDA,1,0),U,2)=$P(^DD(423.6,1,0),U,2)
  1.  . K CNT
  1.  . L -^PRCF(423.6,0)
  1.  . L -^PRCF(423.6,PRCDA)
  1.  F  L +^PRCF(423.6,PRCDA):1 Q:$T
  1.  N II,EOM,LEN,OCNT,SCNT
  1.  S (OCNT,SCNT)=10000*(+$P(XMRG,U,12))
  1.  I +$P(XMRG,U,12)=1 D
  1.  . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
  1.  . S SCNT=SCNT+1
  1.  S (OK,REM,REM1,S1)=""
  1.  F  D  Q:XMER'=0  I S1>0 Q
  1.  . I REM["}" S S1=2 Q
  1.  . S:XMRG["{" S1=1,XMRG=""
  1.  . X:S1="" XMREC
  1.  . Q:XMER<0
  1.  . S:$L(REM)+$L(REM1)<241 REM=REM_REM1,REM1=""
  1.  . S:$L(REM)+$L(XMRG)<241 XMRG=REM_XMRG,REM=""
  1.  . I $L(REM)+$L(XMRG)>240 D
  1.  . . S REM1=$E(XMRG,241-$L(REM),$L(XMRG))
  1.  . . S XMRG=REM_$E(XMRG,1,240-$L(REM))
  1.  . . Q
  1.  . S EOM=$F(XMRG,"}")
  1.  . I EOM>2 S XMRG=$E(XMRG,1,EOM-1),S1=2,REM1=""
  1.  . I EOM=2 S S1=2 Q
  1.  . S LEN=$F(XMRG,"~")
  1.  . I LEN>1,LEN<241 D  Q
  1.  . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,LEN-1)
  1.  . . S SCNT=SCNT+1
  1.  . . S REM=$E(XMRG,LEN,$L(XMRG))
  1.  . . Q
  1.  . I $L(XMRG)>0,$L(XMRG)<241 D  Q
  1.  . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
  1.  . . S SCNT=SCNT+1
  1.  . . S REM=""
  1.  . . Q
  1.  . I $E(XMRG,1,240)["^" F II=240:-1:1 I $E(XMRG,II)="^" D  Q
  1.  . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
  1.  . . S SCNT=SCNT+1
  1.  . . S REM=$E(XMRG,II+1,$L(XMRG))
  1.  . . S OK=1
  1.  . . Q
  1.  . Q:OK=1
  1.  . F II=240:-1:1 I $E(XMRG,II)=" " D  Q
  1.  . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
  1.  . . S REM=$E(XMRG,II+1,$L(XMRG))
  1.  . . Q
  1.  . Q
  1.  S $P(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
  1.  S $P(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$P(^PRCF(423.6,PRCDA,1,0),U,4)
  1.  L -^PRCF(423.6,PRCDA)
  1.  Q
  1.  ;
  1. KILL(PRCDA) ;ENTER HERE TO REMOVE THE 423.6 RECORD THAT YOU HAVE FINISHED WITH.
  1.  N DA,DIK
  1.  S DA=PRCDA
  1.  S DIK="^PRCF(423.6,"
  1.  D ^DIK
  1.  Q