PRCOSRV2.m

PRCOSRV2 ;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

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^PRCOSRV3:$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:"CTL"'[$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,15)'="~" S XMRG=""

 S ACTION=$S(+$P(XMRG,U,13)>1:"MANY",+$P(XMRG,U,13)=1:"ONE",1:"ERR")

 I ACTION="ERR" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q

 S PRCKEY=$P(XMRG,U,5)_U_$P(XMRG,U,10,11)_U_$P(XMRG,U,13)_U_$P(XMRG,U,4)

 S PRCKEY=$TR(PRCKEY,U,"-")

 S TOTS=+$P(XMRG,U,13)

 I $P(PRCKEY,"-")=""!($P(PRCKEY,"-",2)="")!($P(PRCKEY,"-",3)="")!($P(PRCKEY,"-",4)="")!($P(PRCKEY,"-",5)="") 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^PRCOSRV3

 I S1'=1 D  Q

 . S PRCXM(1)=$P($T(ERROR+5),";;",2)

 . D TSKKILL

 . D PERROR^PRCOSRV3

 . D TRADEL(PRCDA)

 . K PRCXM

 . S PRCEND=""

 . Q

 D TRTN:'$D(PRCXM)

 Q

 ;

MANY ; Distributed transaction process

 D TFILER^PRCOSRV3

 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,13)'="001" D

 . S $P(MSG,U,12)="001"

 . S $P(MSG,U,13)="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,4),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,5),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,5)_"." Q

 S PRCMG=$P(X1,U,2)

 I PRCMG'>0 S PRCXM(1)=$P($T(ERROR+6),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,5)_"." 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,5)_"." Q

 S PRCMG=$P(PRCMG,U)

 I PRCMG="" S PRCXM(1)=$P($T(ERROR+8),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,5)_"." 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^PRCOSRV3

 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^PRCOSRV2"

 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^PRCOSRV3

 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^PRCOSRV2"

 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

 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 ---PRCOSRV2   5617     printed  Apr 23, 2025@18:26:38                                                                                                                                                                                                    Page 2

PRCOSRV2  ;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 

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^PRCOSRV3

               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 "CTL"'[$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,15)'="~"

               SET XMRG=""

 +13       SET ACTION=$SELECT(+$PIECE(XMRG,U,13)>1:"MANY",+$PIECE(XMRG,U,13)=1:"ONE",1:"ERR")

 +14       IF ACTION="ERR"

               SET PRCXM(1)=$PIECE($TEXT(ERROR+4),";;",2)

               QUIT 

 +15       SET PRCKEY=$PIECE(XMRG,U,5)_U_$PIECE(XMRG,U,10,11)_U_$PIECE(XMRG,U,13)_U_$PIECE(XMRG,U,4)

 +16       SET PRCKEY=$TRANSLATE(PRCKEY,U,"-")

 +17       SET TOTS=+$PIECE(XMRG,U,13)

 +18       IF $PIECE(PRCKEY,"-")=""!($PIECE(PRCKEY,"-",2)="")!($PIECE(PRCKEY,"-",3)="")!($PIECE(PRCKEY,"-",4)="")!($PIECE(PRCKEY,"-",5)="")

               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^PRCOSRV3

 +3        IF S1'=1

               Begin DoDot:1

 +4                SET PRCXM(1)=$PIECE($TEXT(ERROR+5),";;",2)

 +5                DO TSKKILL

 +6                DO PERROR^PRCOSRV3

 +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^PRCOSRV3

 +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,13)'="001"

               Begin DoDot:1

 +8                SET $PIECE(MSG,U,12)="001"

 +9                SET $PIECE(MSG,U,13)="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,4),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,5),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,5)_"."

               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,5)_"."

               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,5)_"."

               QUIT 

 +12       SET PRCMG=$PIECE(PRCMG,U)

 +13       IF PRCMG=""

               SET PRCXM(1)=$PIECE($TEXT(ERROR+8),";;",2)_" "_$PIECE(XMRG,U)_"-"_$PIECE(XMRG,U,5)_"."

               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^PRCOSRV3

 +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^PRCOSRV2"

 +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^PRCOSRV3

 +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^PRCOSRV2"

 +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        SET XMSER="S."_XQSOP

 +2        SET XMZ=XQMSG

 +3        DO REMSBMSG^XMA1C

 +4        QUIT 

 +5       ;

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.