GECSSTTM ;WISC/RFJ-stacker file transmission (multi docs in a msg) ;08 Dec 93
;;2.0;GCS;**4,5**;MAR 14, 1995
Q
;
;
TRANSALL ; transmit code sheets waiting for clock in stack file
; check for another job transmitting stack code sheets
N DA,GECSFQUE
L +^GECS(2100.1,"ATRANSMIT"):10 I '$T Q
S GECSFQUE=1
K ^TMP($J,"GECSSTTR")
S DA=0 F S DA=$O(^GECS(2100.1,"AS","Q",DA)) Q:'DA D BUILD(DA)
D TRANSMIT^GECSSTTT
K ^TMP($J,"GECSSTTR")
L -^GECS(2100.1,"ATRANSMIT")
S ZTREQ="@"
Q
;
;
BUILD(DA) ; build tmp global for stack entry da
; $g(gecsfaut)=1 for immediate transmissions
I '$D(^GECS(2100.1,DA,0)) Q
L +^GECS(2100.1,DA):10 I '$T Q
;
N %,BATCHDA,CHECKSUM,DA1,DATA,ENDOFCS,ENDOFMSG,FINDHOLD,GECSFLAG,GECSLPC,HOLDDATE,LINE,SEGMENT,SEQSIZE,SEQUENCE,STACSIZE,X,Y
;
I $E($G(^GECS(2100.1,DA,10,1,0)),1,3)'="CTL" D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Control segment/first line of code sheet missing") L -^GECS(2100.1,DA) Q
;
S SEGMENT=$P(^GECS(2100.1,DA,0),"^",5)
I SEGMENT="" D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Segment not defined for entry") L -^GECS(2100.1,DA) Q
S (ENDOFCS,ENDOFMSG)=""
I $P(SEGMENT,":",2)="FMS" S ENDOFCS="{",ENDOFMSG="}"
;
S BATCHDA=+$P($G(^GECS(2101.2,+$O(^GECS(2101.2,"B",SEGMENT,0)),0)),"^",4)
I 'BATCHDA D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Batch type in file 2101.2 is incorrect") L -^GECS(2100.1,DA) Q
;
S GECSLPC=$G(^%ZOSF("LPC")) I GECSLPC="" S GECSLPC="S Y="""""
; for automatically created docs, check checksum and hold date
I $P($G(^GECS(2100.1,DA,0)),"^",6)="A" D I $G(GECSFLAG) L -^GECS(2100.1,DA) Q
. ; check hold date greater than today
. S HOLDDATE=$P($G(^GECS(2100.1,DA,11)),"^",3)
. ; for immediate transmissions, queue code sheet
. I HOLDDATE>DT D:$G(GECSFAUT) SETSTAT^GECSSTAA(DA,"Q") S GECSFLAG=1 Q
. ; compute checksum and find hold date if not defined
. S CHECKSUM=""
. S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) D Q:$G(GECSFLAG)
. . I 'HOLDDATE I $E($P(DATA,"^"),3)=2!($P(DATA,"^")="AT1") S FINDHOLD=$$HOLDDATE^GECSSTTR(DATA) I FINDHOLD S $P(^GECS(2100.1,DA,11),"^",3)=FINDHOLD,GECSFLAG=1 Q
. . S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
. ; for immediate transmissions, queue code sheet
. I $G(GECSFLAG) D:$G(GECSFAUT) SETSTAT^GECSSTAA(DA,"Q") Q
. ; compare checksums
. S X=$P($G(^GECS(2100.1,DA,11)),"^",2) I X="" Q
. I X'=CHECKSUM D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Code sheet has been altered since creation") S GECSFLAG=1
;
; change transmission date on ctl segment
S ^GECS(2100.1,DA,10,1,0)=$$CTLDATE^GECSSTTR(^GECS(2100.1,DA,10,1,0))
;
; fit code sheet in a sequence number if possible
S STACSIZE=$P($G(^GECS(2100.1,DA,11)),"^")
I STACSIZE>30000 D MULTIPLE L -^GECS(2100.1,DA) Q
S SEQUENCE=0 F S SEQUENCE=$O(^TMP($J,"GECSSTTR","SIZE",SEQUENCE)) Q:'SEQUENCE S SEQSIZE=^(SEQUENCE) I ($P(SEQSIZE,"^")+STACSIZE)<30000,^TMP($J,"GECSSTTR","BATCH",SEQUENCE)=BATCHDA Q
; create a new sequence
I 'SEQUENCE D SEQUENCE S SEQSIZE="0^0"
;
; recompute checksum with new transmission date and time on ctl segment
S LINE=$P(SEQSIZE,"^",2),CHECKSUM=""
S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) I DATA'="" D
. S LINE=LINE+1,^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
. S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
. ; check for last code sheet in stack entry
. I '$O(^GECS(2100.1,DA,10,DA1)),$L($G(ENDOFCS)) D Q
. . I DATA'[ENDOFCS S DATA=DATA_ENDOFCS
. . S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
;
; store new checksum
S $P(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
;
D ENDSEQ($P(SEQSIZE,"^")+STACSIZE,LINE)
L -^GECS(2100.1,DA)
Q
;
;
MULTIPLE ; code sheet is larger than 30k, create multiple msgs
D SEQUENCE
N %,COUNT,SIZE,STRTSEQ,MAILMSGS
S STRTSEQ=SEQUENCE
S MAILMSGS=1,(LINE,SIZE)=0,CHECKSUM=""
S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) I DATA'="" D
. S LINE=LINE+1,^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
. S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
. ; check for last code sheet in stack entry
. I '$O(^GECS(2100.1,DA,10,DA1)),$L($G(ENDOFCS)) D Q
. . I DATA'[ENDOFCS S DATA=DATA_ENDOFCS
. . S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
. S SIZE=SIZE+$L(DATA)
. I SIZE>30000 D
. . I $L($G(ENDOFMSG)),DATA'[ENDOFMSG S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA_ENDOFMSG
. . D ENDSEQ(SIZE,LINE),SEQUENCE S MAILMSGS=MAILMSGS+1,LINE=2,SIZE=0
;
; store new checksum
S $P(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
;
; modify sequence count
S DATA=^GECS(2100.1,DA,10,1,0),$P(DATA,"^",13)=$E("000",$L(MAILMSGS)+1,3)_MAILMSGS
S COUNT=1 F %=STRTSEQ:1 Q:'$D(^TMP($J,"GECSSTTR","CS",%)) S $P(DATA,"^",12)=$E("000",$L(COUNT)+1,3)_COUNT,^TMP($J,"GECSSTTR","CS",%,1,0)=DATA,COUNT=COUNT+1
;
; send size=30001 to prevent other code sheets from being added
D ENDSEQ(30001,LINE)
Q
;
;
ENDSEQ(SIZE,LINE) ; set end sequence control in tmp
; size=size of code sheet; line=last line of sequence
N %
S ^TMP($J,"GECSSTTR","SIZE",SEQUENCE)=SIZE_"^"_LINE
S ^TMP($J,"GECSSTTR","LIST",SEQUENCE,DA)=""
S ^TMP($J,"GECSSTTR","BATCH",SEQUENCE)=BATCHDA
S %=$G(^TMP($J,"GECSSTTR","SEGS",SEQUENCE)) I %[$P(SEGMENT,":") Q
S ^TMP($J,"GECSSTTR","SEGS",SEQUENCE)=%_$S(%="":"",1:",")_$P(SEGMENT,":")
Q
;
;
SEQUENCE ; return next sequence number
S SEQUENCE=$G(^TMP($J,"GECSSTTR","SEQ"))+1,^TMP($J,"GECSSTTR","SEQ")=SEQUENCE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGECSSTTM 5601 printed Dec 13, 2024@01:56:30 Page 2
GECSSTTM ;WISC/RFJ-stacker file transmission (multi docs in a msg) ;08 Dec 93
+1 ;;2.0;GCS;**4,5**;MAR 14, 1995
+2 QUIT
+3 ;
+4 ;
TRANSALL ; transmit code sheets waiting for clock in stack file
+1 ; check for another job transmitting stack code sheets
+2 NEW DA,GECSFQUE
+3 LOCK +^GECS(2100.1,"ATRANSMIT"):10
IF '$TEST
QUIT
+4 SET GECSFQUE=1
+5 KILL ^TMP($JOB,"GECSSTTR")
+6 SET DA=0
FOR
SET DA=$ORDER(^GECS(2100.1,"AS","Q",DA))
if 'DA
QUIT
DO BUILD(DA)
+7 DO TRANSMIT^GECSSTTT
+8 KILL ^TMP($JOB,"GECSSTTR")
+9 LOCK -^GECS(2100.1,"ATRANSMIT")
+10 SET ZTREQ="@"
+11 QUIT
+12 ;
+13 ;
BUILD(DA) ; build tmp global for stack entry da
+1 ; $g(gecsfaut)=1 for immediate transmissions
+2 IF '$DATA(^GECS(2100.1,DA,0))
QUIT
+3 LOCK +^GECS(2100.1,DA):10
IF '$TEST
QUIT
+4 ;
+5 NEW %,BATCHDA,CHECKSUM,DA1,DATA,ENDOFCS,ENDOFMSG,FINDHOLD,GECSFLAG,GECSLPC,HOLDDATE,LINE,SEGMENT,SEQSIZE,SEQUENCE,STACSIZE,X,Y
+6 ;
+7 IF $EXTRACT($GET(^GECS(2100.1,DA,10,1,0)),1,3)'="CTL"
DO SETSTAT^GECSSTAA(DA,"E")
DO ERROR^GECSSTTR(DA,"Control segment/first line of code sheet missing")
LOCK -^GECS(2100.1,DA)
QUIT
+8 ;
+9 SET SEGMENT=$PIECE(^GECS(2100.1,DA,0),"^",5)
+10 IF SEGMENT=""
DO SETSTAT^GECSSTAA(DA,"E")
DO ERROR^GECSSTTR(DA,"Segment not defined for entry")
LOCK -^GECS(2100.1,DA)
QUIT
+11 SET (ENDOFCS,ENDOFMSG)=""
+12 IF $PIECE(SEGMENT,":",2)="FMS"
SET ENDOFCS="{"
SET ENDOFMSG="}"
+13 ;
+14 SET BATCHDA=+$PIECE($GET(^GECS(2101.2,+$ORDER(^GECS(2101.2,"B",SEGMENT,0)),0)),"^",4)
+15 IF 'BATCHDA
DO SETSTAT^GECSSTAA(DA,"E")
DO ERROR^GECSSTTR(DA,"Batch type in file 2101.2 is incorrect")
LOCK -^GECS(2100.1,DA)
QUIT
+16 ;
+17 SET GECSLPC=$GET(^%ZOSF("LPC"))
IF GECSLPC=""
SET GECSLPC="S Y="""""
+18 ; for automatically created docs, check checksum and hold date
+19 IF $PIECE($GET(^GECS(2100.1,DA,0)),"^",6)="A"
Begin DoDot:1
+20 ; check hold date greater than today
+21 SET HOLDDATE=$PIECE($GET(^GECS(2100.1,DA,11)),"^",3)
+22 ; for immediate transmissions, queue code sheet
+23 IF HOLDDATE>DT
if $GET(GECSFAUT)
DO SETSTAT^GECSSTAA(DA,"Q")
SET GECSFLAG=1
QUIT
+24 ; compute checksum and find hold date if not defined
+25 SET CHECKSUM=""
+26 SET DA1=0
FOR
SET DA1=$ORDER(^GECS(2100.1,DA,10,DA1))
if 'DA1
QUIT
SET DATA=$GET(^(DA1,0))
Begin DoDot:2
+27 IF 'HOLDDATE
IF $EXTRACT($PIECE(DATA,"^"),3)=2!($PIECE(DATA,"^")="AT1")
SET FINDHOLD=$$HOLDDATE^GECSSTTR(DATA)
IF FINDHOLD
SET $PIECE(^GECS(2100.1,DA,11),"^",3)=FINDHOLD
SET GECSFLAG=1
QUIT
+28 SET X=CHECKSUM_DATA
XECUTE GECSLPC
SET CHECKSUM=Y
End DoDot:2
if $GET(GECSFLAG)
QUIT
+29 ; for immediate transmissions, queue code sheet
+30 IF $GET(GECSFLAG)
if $GET(GECSFAUT)
DO SETSTAT^GECSSTAA(DA,"Q")
QUIT
+31 ; compare checksums
+32 SET X=$PIECE($GET(^GECS(2100.1,DA,11)),"^",2)
IF X=""
QUIT
+33 IF X'=CHECKSUM
DO SETSTAT^GECSSTAA(DA,"E")
DO ERROR^GECSSTTR(DA,"Code sheet has been altered since creation")
SET GECSFLAG=1
End DoDot:1
IF $GET(GECSFLAG)
LOCK -^GECS(2100.1,DA)
QUIT
+34 ;
+35 ; change transmission date on ctl segment
+36 SET ^GECS(2100.1,DA,10,1,0)=$$CTLDATE^GECSSTTR(^GECS(2100.1,DA,10,1,0))
+37 ;
+38 ; fit code sheet in a sequence number if possible
+39 SET STACSIZE=$PIECE($GET(^GECS(2100.1,DA,11)),"^")
+40 IF STACSIZE>30000
DO MULTIPLE
LOCK -^GECS(2100.1,DA)
QUIT
+41 SET SEQUENCE=0
FOR
SET SEQUENCE=$ORDER(^TMP($JOB,"GECSSTTR","SIZE",SEQUENCE))
if 'SEQUENCE
QUIT
SET SEQSIZE=^(SEQUENCE)
IF ($PIECE(SEQSIZE,"^")+STACSIZE)<30000
IF ^TMP($JOB,"GECSSTTR","BATCH",SEQUENCE)=BATCHDA
QUIT
+42 ; create a new sequence
+43 IF 'SEQUENCE
DO SEQUENCE
SET SEQSIZE="0^0"
+44 ;
+45 ; recompute checksum with new transmission date and time on ctl segment
+46 SET LINE=$PIECE(SEQSIZE,"^",2)
SET CHECKSUM=""
+47 SET DA1=0
FOR
SET DA1=$ORDER(^GECS(2100.1,DA,10,DA1))
if 'DA1
QUIT
SET DATA=$GET(^(DA1,0))
IF DATA'=""
Begin DoDot:1
+48 SET LINE=LINE+1
SET ^TMP($JOB,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
+49 SET X=CHECKSUM_DATA
XECUTE GECSLPC
SET CHECKSUM=Y
+50 ; check for last code sheet in stack entry
+51 IF '$ORDER(^GECS(2100.1,DA,10,DA1))
IF $LENGTH($GET(ENDOFCS))
Begin DoDot:2
+52 IF DATA'[ENDOFCS
SET DATA=DATA_ENDOFCS
+53 SET ^TMP($JOB,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
End DoDot:2
QUIT
End DoDot:1
+54 ;
+55 ; store new checksum
+56 SET $PIECE(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
+57 ;
+58 DO ENDSEQ($PIECE(SEQSIZE,"^")+STACSIZE,LINE)
+59 LOCK -^GECS(2100.1,DA)
+60 QUIT
+61 ;
+62 ;
MULTIPLE ; code sheet is larger than 30k, create multiple msgs
+1 DO SEQUENCE
+2 NEW %,COUNT,SIZE,STRTSEQ,MAILMSGS
+3 SET STRTSEQ=SEQUENCE
+4 SET MAILMSGS=1
SET (LINE,SIZE)=0
SET CHECKSUM=""
+5 SET DA1=0
FOR
SET DA1=$ORDER(^GECS(2100.1,DA,10,DA1))
if 'DA1
QUIT
SET DATA=$GET(^(DA1,0))
IF DATA'=""
Begin DoDot:1
+6 SET LINE=LINE+1
SET ^TMP($JOB,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
+7 SET X=CHECKSUM_DATA
XECUTE GECSLPC
SET CHECKSUM=Y
+8 ; check for last code sheet in stack entry
+9 IF '$ORDER(^GECS(2100.1,DA,10,DA1))
IF $LENGTH($GET(ENDOFCS))
Begin DoDot:2
+10 IF DATA'[ENDOFCS
SET DATA=DATA_ENDOFCS
+11 SET ^TMP($JOB,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
End DoDot:2
QUIT
+12 SET SIZE=SIZE+$LENGTH(DATA)
+13 IF SIZE>30000
Begin DoDot:2
+14 IF $LENGTH($GET(ENDOFMSG))
IF DATA'[ENDOFMSG
SET ^TMP($JOB,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA_ENDOFMSG
+15 DO ENDSEQ(SIZE,LINE)
DO SEQUENCE
SET MAILMSGS=MAILMSGS+1
SET LINE=2
SET SIZE=0
End DoDot:2
End DoDot:1
+16 ;
+17 ; store new checksum
+18 SET $PIECE(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
+19 ;
+20 ; modify sequence count
+21 SET DATA=^GECS(2100.1,DA,10,1,0)
SET $PIECE(DATA,"^",13)=$EXTRACT("000",$LENGTH(MAILMSGS)+1,3)_MAILMSGS
+22 SET COUNT=1
FOR %=STRTSEQ:1
if '$DATA(^TMP($JOB,"GECSSTTR","CS",%))
QUIT
SET $PIECE(DATA,"^",12)=$EXTRACT("000",$LENGTH(COUNT)+1,3)_COUNT
SET ^TMP($JOB,"GECSSTTR","CS",%,1,0)=DATA
SET COUNT=COUNT+1
+23 ;
+24 ; send size=30001 to prevent other code sheets from being added
+25 DO ENDSEQ(30001,LINE)
+26 QUIT
+27 ;
+28 ;
ENDSEQ(SIZE,LINE) ; set end sequence control in tmp
+1 ; size=size of code sheet; line=last line of sequence
+2 NEW %
+3 SET ^TMP($JOB,"GECSSTTR","SIZE",SEQUENCE)=SIZE_"^"_LINE
+4 SET ^TMP($JOB,"GECSSTTR","LIST",SEQUENCE,DA)=""
+5 SET ^TMP($JOB,"GECSSTTR","BATCH",SEQUENCE)=BATCHDA
+6 SET %=$GET(^TMP($JOB,"GECSSTTR","SEGS",SEQUENCE))
IF %[$PIECE(SEGMENT,":")
QUIT
+7 SET ^TMP($JOB,"GECSSTTR","SEGS",SEQUENCE)=%_$SELECT(%="":"",1:",")_$PIECE(SEGMENT,":")
+8 QUIT
+9 ;
+10 ;
SEQUENCE ; return next sequence number
+1 SET SEQUENCE=$GET(^TMP($JOB,"GECSSTTR","SEQ"))+1
SET ^TMP($JOB,"GECSSTTR","SEQ")=SEQUENCE
+2 QUIT
