PRCOSRV ;WISC/RMP-Server interface to IFCAP from ISMS ;3/12/97 11:32
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
SERVER ;
N ACTION,MSG,PRCMG,PRCETIME,PRCRTN,CNT,TOTS,PRCKEY,PRCEND,PRCDA
N PRCAH,PRCXM,S1,PRCOXMRG,PRCOSOP,PRCOMSG,PRCOSND,PRCOSUB
F D THDR,PERROR^PRCOSRV1:$D(PRCXM),TRETRY:$D(PRETRY) Q:XMER'=0 Q:$D(PRCEND)
D DKILL
S ZTREQ="@"
Q
;
THDR ; Transaction header segment reader
X XMREC
Q:XMER'=0
Q:"IFC,ISM"'[$P(XMRG,U)
;
; SOME VARIABLES TO DISPLAY IF THERE IS AN ERROR.
S PRCOXMRG=XMRG ; THE LINE OF TEXT BEING EXAMINED.
S PRCOSOP=XQSOP ; THE SERVER OPTION NAME.
S PRCOMSG=XQMSG ; THE SERVER REQUEST MESSAGE NUMBER (MAILMAN NUMBER).
S PRCOSND=XQSND ; NETWORK ADDRESS OF THE SENDER.
S PRCOSUB=XQSUB ; SUBJECT HEADING OF THE SERVER REQUEST MESSAGE.
;
I $P(XMRG,U,11)'="|" S XMRG=""
S ACTION=$S(+$P(XMRG,U,9)>1:"MANY",+$P(XMRG,U,9)=1:"ONE",1:"ERR")
I ACTION="ERR" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q
S PRCKEY=$P(XMRG,U,4,6)_U_$P(XMRG,U,9)
S PRCKEY=$TR(PRCKEY,U,"-")
S TOTS=+$P(XMRG,U,9)
I $P(PRCKEY,"-")=""!($P(PRCKEY,"-",2)="")!($P(PRCKEY,"-",3)="")!($P(PRCKEY,"-",4)="") S PRCXM(1)=$P($T(ERROR+10),";;",2) Q
S Y=$O(^PRCF(423.6,"B",PRCKEY,0))
S PRCDA=+Y
D LTC
D @ACTION:'$D(PRCXM)
Q
;
ONE ; Single Message Transaction process
S PRCDA=0
D TFILER^PRCOSRV1
I S1'=1 D Q
. S PRCXM(1)=$P($T(ERROR+5),";;",2)
. D TSKKILL
. D PERROR^PRCOSRV1
. D TRADEL(PRCDA)
. K PRCXM
. S PRCEND=""
. Q
D TRTN:'$D(PRCXM)
Q
;
MANY ; Distributed transaction process
D TFILER^PRCOSRV1
I $P($G(^PRCF(423.6,PRCDA,0)),U,2)'>0 D TSKSET Q
I '$$SEQ(PRCDA,TOTS) Q
L +^PRCF(423.6,PRCDA):1
Q:'$T
S MSG=^PRCF(423.6,PRCDA,1,10000,0)
I $P(MSG,U,9)'="001" D
. S $P(MSG,U,8)="001"
. S $P(MSG,U,9)="001"
. S ^PRCF(423.6,PRCDA,1,10000,0)=MSG
. D TSKKILL
. D TRTN
. Q
L -^PRCF(423.6,PRCDA)
Q
;
LTC ; Look up Transaction Code
S PRCETIME=$P($G(^PRC(411,$P(XMRG,U,3),7)),U)
S PRCETIME=$S(PRCETIME]"":PRCETIME,1:86400)
N Y,X,X1
S Y=$O(^PRCF(423.5,"B",$P(XMRG,U)_"-"_$P(XMRG,U,4),0))
I +Y'>0 S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
S X1=$G(^PRCF(423.5,+Y,0))
I X1="" S PRCXM(1)=$P($T(ERROR+9),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
S PRCMG=$P(X1,U,2)
I PRCMG'>0 S PRCXM(1)=$P($T(ERROR+6),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
S PRCMG=$G(^XMB(3.8,$P(X1,U,2),0))
I PRCMG="" S PRCXM(1)=$P($T(ERROR+7),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
S PRCMG=$P(PRCMG,U)
I PRCMG="" S PRCXM(1)=$P($T(ERROR+8),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
S PRCRTN=$P(X1,U,3,4)
S X=$P(X1,U,4)
I X="" S PRCXM(1)=$P($T(ERROR+3),";;",2)_" is missing." Q
X ^%ZOSF("TEST")
S:'$T PRCXM(1)=$P($T(ERROR+3),";;",2)_" "_PRCRTN_" missing in RD."
Q
;
TRTN ; Task transaction process
N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
S (ZTSAVE("PRCDA"),ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))=""
S ZTSAVE("ZTREQ")="@"
S ZTRTN=PRCRTN
S ZTDTH=$H
S ZTIO=""
D ^%ZTLOAD
L +^PRCF(423.6,PRCDA):1
S $P(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
L -^PRCF(423.6,PRCDA)
Q
;
TRADEL(X) ; Process to delete transaction from transaction file
;N DIK,DA,Y S DIK="^PRCF(423.6,",DA=X D ^DIK
Q
;
TRAPRGE ; Purge old, incomplete, sequenced transactions
D TRADEL(PRCDA)
S PRCXM(1)=$P($T(ERROR+2),";;",2)
D PERROR^PRCOSRV1
Q
;
TSKKILL ; KILL Tasked PURGE process
N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
S ZTSK=+$P(^PRCF(423.6,PRCDA,0),U,2)
D KILL^%ZTLOAD
Q
;
TSKSET ; TASKs a PURGE transaction process
N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
;IF THERE IS ALREADY A TASK SET IN THE RECORD DON'T START ANOTHER ONE
Q:$P($G(^PRCF(423.6,PRCDA,0)),U,2)>0
S (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("XMDUZ"),ZTSAVE("XMZ"))=""
S (ZTSAVE("PRCOXMRG"),ZTSAVE("PRCOSOP"),ZTSAVE("PRCOMSG"),ZTSAVE("PRCOSND"),ZTSAVE("PRCOSUB"))=""
S ZTSAVE("ZTREQ")="@"
S ZTRTN="TRAPRGE^PRCOSRV"
S ZTDTH=$$DTC(PRCETIME)
S ZTIO=""
D ^%ZTLOAD
S $P(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
Q
;
TRETRY ; Task to reprocess transaction
K PRETRY,PRCEND
D TFILER^PRCOSRV1
N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
S (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("DUN"),ZTSAVE("XMSUB"),ZTSAVE("XMY("))=""
S ZTSAVE("ZTREQ")="@"
S ZTRTN="TRETRY1^PRCOSRV"
S ZTDTH=$$DTC(PRCETIME)
S ZTIO=""
D ^%ZTLOAD
Q
;
TRETRY1 ; Resend transaction in a new message
S XMTEXT="^PRCF(423.6,"_PRCDA_",1,"
D ^XMD
Q
;
SEQ(X,Y) ;
N CNT,Z
S CNT=0
F Z=10000:10000:Y*10000 S:$D(^PRCF(423.6,X,1,Z,0)) CNT=CNT+1
Q $S(CNT=Y:1,1:0)
;
DTC(SEC) ; Adds seconds to $H
N TIME,%H
D NOW^%DTC
S TIME=$P(%H,",")+(SEC+$P(%H,",",2)\86400)_","_(SEC+$P(%H,",",2)#86400)
Q TIME
;
DKILL ; Delete mail message from postmaster mailbox
N XMZ
S XMSER="S."_XQSOP
S XMZ=XQMSG
D REMSBMSG^XMA1C
Q
;
ERROR ;
;;Transaction code does not exist in PRC IFCAP MESSAGE ROUTER file (423.5) "B" x-ref.
;;All parts of this multipart message did not arrive.
;;Routine to process this transaction does not exist, routine
;;Can not figure out if this is a single or multipart transaction.
;;This transaction has no ending $.
;;There is no mail group pointer from file 423.5 entry
;;There is no mail group entry in file 3.8 for the pointer from file 423.5 entry
;;There is no mail group name in file 3.8 from file 423.5 entry
;;There is a "B" x-ref but no record in file 423.5 for entry
;;One or more parts of this transaction's key is missing.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSRV 5565 printed Nov 22, 2024@17:22:11 Page 2
PRCOSRV ;WISC/RMP-Server interface to IFCAP from ISMS ;3/12/97 11:32
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
SERVER ;
+1 NEW ACTION,MSG,PRCMG,PRCETIME,PRCRTN,CNT,TOTS,PRCKEY,PRCEND,PRCDA
+2 NEW PRCAH,PRCXM,S1,PRCOXMRG,PRCOSOP,PRCOMSG,PRCOSND,PRCOSUB
+3 FOR
DO THDR
if $DATA(PRCXM)
DO PERROR^PRCOSRV1
if $DATA(PRETRY)
DO TRETRY
if XMER'=0
QUIT
if $DATA(PRCEND)
QUIT
+4 DO DKILL
+5 SET ZTREQ="@"
+6 QUIT
+7 ;
THDR ; Transaction header segment reader
+1 XECUTE XMREC
+2 if XMER'=0
QUIT
+3 if "IFC,ISM"'[$PIECE(XMRG,U)
QUIT
+4 ;
+5 ; SOME VARIABLES TO DISPLAY IF THERE IS AN ERROR.
+6 ; THE LINE OF TEXT BEING EXAMINED.
SET PRCOXMRG=XMRG
+7 ; THE SERVER OPTION NAME.
SET PRCOSOP=XQSOP
+8 ; THE SERVER REQUEST MESSAGE NUMBER (MAILMAN NUMBER).
SET PRCOMSG=XQMSG
+9 ; NETWORK ADDRESS OF THE SENDER.
SET PRCOSND=XQSND
+10 ; SUBJECT HEADING OF THE SERVER REQUEST MESSAGE.
SET PRCOSUB=XQSUB
+11 ;
+12 IF $PIECE(XMRG,U,11)'="|"
SET XMRG=""
+13 SET ACTION=$SELECT(+$PIECE(XMRG,U,9)>1:"MANY",+$PIECE(XMRG,U,9)=1:"ONE",1:"ERR")
+14 IF ACTION="ERR"
SET PRCXM(1)=$PIECE($TEXT(ERROR+4),";;",2)
QUIT
+15 SET PRCKEY=$PIECE(XMRG,U,4,6)_U_$PIECE(XMRG,U,9)
+16 SET PRCKEY=$TRANSLATE(PRCKEY,U,"-")
+17 SET TOTS=+$PIECE(XMRG,U,9)
+18 IF $PIECE(PRCKEY,"-")=""!($PIECE(PRCKEY,"-",2)="")!($PIECE(PRCKEY,"-",3)="")!($PIECE(PRCKEY,"-",4)="")
SET PRCXM(1)=$PIECE($TEXT(ERROR+10),";;",2)
QUIT
+19 SET Y=$ORDER(^PRCF(423.6,"B",PRCKEY,0))
+20 SET PRCDA=+Y
+21 DO LTC
+22 if '$DATA(PRCXM)
DO @ACTION
+23 QUIT
+24 ;
ONE ; Single Message Transaction process
+1 SET PRCDA=0
+2 DO TFILER^PRCOSRV1
+3 IF S1'=1
Begin DoDot:1
+4 SET PRCXM(1)=$PIECE($TEXT(ERROR+5),";;",2)
+5 DO TSKKILL
+6 DO PERROR^PRCOSRV1
+7 DO TRADEL(PRCDA)
+8 KILL PRCXM
+9 SET PRCEND=""
+10 QUIT
End DoDot:1
QUIT
+11 if '$DATA(PRCXM)
DO TRTN
+12 QUIT
+13 ;
MANY ; Distributed transaction process
+1 DO TFILER^PRCOSRV1
+2 IF $PIECE($GET(^PRCF(423.6,PRCDA,0)),U,2)'>0
DO TSKSET
QUIT
+3 IF '$$SEQ(PRCDA,TOTS)
QUIT
+4 LOCK +^PRCF(423.6,PRCDA):1
+5 if '$TEST
QUIT
+6 SET MSG=^PRCF(423.6,PRCDA,1,10000,0)
+7 IF $PIECE(MSG,U,9)'="001"
Begin DoDot:1
+8 SET $PIECE(MSG,U,8)="001"
+9 SET $PIECE(MSG,U,9)="001"
+10 SET ^PRCF(423.6,PRCDA,1,10000,0)=MSG
+11 DO TSKKILL
+12 DO TRTN
+13 QUIT
End DoDot:1
+14 LOCK -^PRCF(423.6,PRCDA)
+15 QUIT
+16 ;
LTC ; Look up Transaction Code
+1 SET PRCETIME=$PIECE($GET(^PRC(411,$PIECE(XMRG,U,3),7)),U)
+2 SET PRCETIME=$SELECT(PRCETIME]"":PRCETIME,1:86400)
+3 NEW Y,X,X1
+4 SET Y=$ORDER(^PRCF(423.5,"B",$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4),0))
+5 IF +Y'>0
SET PRCXM(1)=$PIECE($TEXT(ERROR+1),";;",2)
QUIT
+6 SET X1=$GET(^PRCF(423.5,+Y,0))
+7 IF X1=""
SET PRCXM(1)=$PIECE($TEXT(ERROR+9),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4)_"."
QUIT
+8 SET PRCMG=$PIECE(X1,U,2)
+9 IF PRCMG'>0
SET PRCXM(1)=$PIECE($TEXT(ERROR+6),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4)_"."
QUIT
+10 SET PRCMG=$GET(^XMB(3.8,$PIECE(X1,U,2),0))
+11 IF PRCMG=""
SET PRCXM(1)=$PIECE($TEXT(ERROR+7),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4)_"."
QUIT
+12 SET PRCMG=$PIECE(PRCMG,U)
+13 IF PRCMG=""
SET PRCXM(1)=$PIECE($TEXT(ERROR+8),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,4)_"."
QUIT
+14 SET PRCRTN=$PIECE(X1,U,3,4)
+15 SET X=$PIECE(X1,U,4)
+16 IF X=""
SET PRCXM(1)=$PIECE($TEXT(ERROR+3),";;",2)_" is missing."
QUIT
+17 XECUTE ^%ZOSF("TEST")
+18 if '$TEST
SET PRCXM(1)=$PIECE($TEXT(ERROR+3),";;",2)_" "_PRCRTN_" missing in RD."
+19 QUIT
+20 ;
TRTN ; Task transaction process
+1 NEW ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
+2 SET (ZTSAVE("PRCDA"),ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))=""
+3 SET ZTSAVE("ZTREQ")="@"
+4 SET ZTRTN=PRCRTN
+5 SET ZTDTH=$HOROLOG
+6 SET ZTIO=""
+7 DO ^%ZTLOAD
+8 LOCK +^PRCF(423.6,PRCDA):1
+9 SET $PIECE(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
+10 LOCK -^PRCF(423.6,PRCDA)
+11 QUIT
+12 ;
TRADEL(X) ; Process to delete transaction from transaction file
+1 ;N DIK,DA,Y S DIK="^PRCF(423.6,",DA=X D ^DIK
+2 QUIT
+3 ;
TRAPRGE ; Purge old, incomplete, sequenced transactions
+1 DO TRADEL(PRCDA)
+2 SET PRCXM(1)=$PIECE($TEXT(ERROR+2),";;",2)
+3 DO PERROR^PRCOSRV1
+4 QUIT
+5 ;
TSKKILL ; KILL Tasked PURGE process
+1 NEW ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
+2 SET ZTSK=+$PIECE(^PRCF(423.6,PRCDA,0),U,2)
+3 DO KILL^%ZTLOAD
+4 QUIT
+5 ;
TSKSET ; TASKs a PURGE transaction process
+1 NEW ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
+2 ;IF THERE IS ALREADY A TASK SET IN THE RECORD DON'T START ANOTHER ONE
+3 if $PIECE($GET(^PRCF(423.6,PRCDA,0)),U,2)>0
QUIT
+4 SET (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("XMDUZ"),ZTSAVE("XMZ"))=""
+5 SET (ZTSAVE("PRCOXMRG"),ZTSAVE("PRCOSOP"),ZTSAVE("PRCOMSG"),ZTSAVE("PRCOSND"),ZTSAVE("PRCOSUB"))=""
+6 SET ZTSAVE("ZTREQ")="@"
+7 SET ZTRTN="TRAPRGE^PRCOSRV"
+8 SET ZTDTH=$$DTC(PRCETIME)
+9 SET ZTIO=""
+10 DO ^%ZTLOAD
+11 SET $PIECE(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
+12 QUIT
+13 ;
TRETRY ; Task to reprocess transaction
+1 KILL PRETRY,PRCEND
+2 DO TFILER^PRCOSRV1
+3 NEW ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
+4 SET (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("DUN"),ZTSAVE("XMSUB"),ZTSAVE("XMY("))=""
+5 SET ZTSAVE("ZTREQ")="@"
+6 SET ZTRTN="TRETRY1^PRCOSRV"
+7 SET ZTDTH=$$DTC(PRCETIME)
+8 SET ZTIO=""
+9 DO ^%ZTLOAD
+10 QUIT
+11 ;
TRETRY1 ; Resend transaction in a new message
+1 SET XMTEXT="^PRCF(423.6,"_PRCDA_",1,"
+2 DO ^XMD
+3 QUIT
+4 ;
SEQ(X,Y) ;
+1 NEW CNT,Z
+2 SET CNT=0
+3 FOR Z=10000:10000:Y*10000
if $DATA(^PRCF(423.6,X,1,Z,0))
SET CNT=CNT+1
+4 QUIT $SELECT(CNT=Y:1,1:0)
+5 ;
DTC(SEC) ; Adds seconds to $H
+1 NEW TIME,%H
+2 DO NOW^%DTC
+3 SET TIME=$PIECE(%H,",")+(SEC+$PIECE(%H,",",2)\86400)_","_(SEC+$PIECE(%H,",",2)#86400)
+4 QUIT TIME
+5 ;
DKILL ; Delete mail message from postmaster mailbox
+1 NEW XMZ
+2 SET XMSER="S."_XQSOP
+3 SET XMZ=XQMSG
+4 DO REMSBMSG^XMA1C
+5 QUIT
+6 ;
ERROR ;
+1 ;;Transaction code does not exist in PRC IFCAP MESSAGE ROUTER file (423.5) "B" x-ref.
+2 ;;All parts of this multipart message did not arrive.
+3 ;;Routine to process this transaction does not exist, routine
+4 ;;Can not figure out if this is a single or multipart transaction.
+5 ;;This transaction has no ending $.
+6 ;;There is no mail group pointer from file 423.5 entry
+7 ;;There is no mail group entry in file 3.8 for the pointer from file 423.5 entry
+8 ;;There is no mail group name in file 3.8 from file 423.5 entry
+9 ;;There is a "B" x-ref but no record in file 423.5 for entry
+10 ;;One or more parts of this transaction's key is missing.
