source: WorldVistAEHR/trunk/r/GENERIC_CODE_SHEET-GEC/GECSSTTM.m@ 1556

Last change on this file since 1556 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1GECSSTTM ;WISC/RFJ-stacker file transmission (multi docs in a msg) ;08 Dec 93
2 ;;2.0;GCS;**4,5**;MAR 14, 1995
3 Q
4 ;
5 ;
6TRANSALL ; transmit code sheets waiting for clock in stack file
7 ; check for another job transmitting stack code sheets
8 N DA,GECSFQUE
9 L +^GECS(2100.1,"ATRANSMIT"):10 I '$T Q
10 S GECSFQUE=1
11 K ^TMP($J,"GECSSTTR")
12 S DA=0 F S DA=$O(^GECS(2100.1,"AS","Q",DA)) Q:'DA D BUILD(DA)
13 D TRANSMIT^GECSSTTT
14 K ^TMP($J,"GECSSTTR")
15 L -^GECS(2100.1,"ATRANSMIT")
16 S ZTREQ="@"
17 Q
18 ;
19 ;
20BUILD(DA) ; build tmp global for stack entry da
21 ; $g(gecsfaut)=1 for immediate transmissions
22 I '$D(^GECS(2100.1,DA,0)) Q
23 L +^GECS(2100.1,DA):10 I '$T Q
24 ;
25 N %,BATCHDA,CHECKSUM,DA1,DATA,ENDOFCS,ENDOFMSG,FINDHOLD,GECSFLAG,GECSLPC,HOLDDATE,LINE,SEGMENT,SEQSIZE,SEQUENCE,STACSIZE,X,Y
26 ;
27 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
28 ;
29 S SEGMENT=$P(^GECS(2100.1,DA,0),"^",5)
30 I SEGMENT="" D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Segment not defined for entry") L -^GECS(2100.1,DA) Q
31 S (ENDOFCS,ENDOFMSG)=""
32 I $P(SEGMENT,":",2)="FMS" S ENDOFCS="{",ENDOFMSG="}"
33 ;
34 S BATCHDA=+$P($G(^GECS(2101.2,+$O(^GECS(2101.2,"B",SEGMENT,0)),0)),"^",4)
35 I 'BATCHDA D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Batch type in file 2101.2 is incorrect") L -^GECS(2100.1,DA) Q
36 ;
37 S GECSLPC=$G(^%ZOSF("LPC")) I GECSLPC="" S GECSLPC="S Y="""""
38 ; for automatically created docs, check checksum and hold date
39 I $P($G(^GECS(2100.1,DA,0)),"^",6)="A" D I $G(GECSFLAG) L -^GECS(2100.1,DA) Q
40 . ; check hold date greater than today
41 . S HOLDDATE=$P($G(^GECS(2100.1,DA,11)),"^",3)
42 . ; for immediate transmissions, queue code sheet
43 . I HOLDDATE>DT D:$G(GECSFAUT) SETSTAT^GECSSTAA(DA,"Q") S GECSFLAG=1 Q
44 . ; compute checksum and find hold date if not defined
45 . S CHECKSUM=""
46 . S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) D Q:$G(GECSFLAG)
47 . . 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
48 . . S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
49 . ; for immediate transmissions, queue code sheet
50 . I $G(GECSFLAG) D:$G(GECSFAUT) SETSTAT^GECSSTAA(DA,"Q") Q
51 . ; compare checksums
52 . S X=$P($G(^GECS(2100.1,DA,11)),"^",2) I X="" Q
53 . I X'=CHECKSUM D SETSTAT^GECSSTAA(DA,"E"),ERROR^GECSSTTR(DA,"Code sheet has been altered since creation") S GECSFLAG=1
54 ;
55 ; change transmission date on ctl segment
56 S ^GECS(2100.1,DA,10,1,0)=$$CTLDATE^GECSSTTR(^GECS(2100.1,DA,10,1,0))
57 ;
58 ; fit code sheet in a sequence number if possible
59 S STACSIZE=$P($G(^GECS(2100.1,DA,11)),"^")
60 I STACSIZE>30000 D MULTIPLE L -^GECS(2100.1,DA) Q
61 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
62 ; create a new sequence
63 I 'SEQUENCE D SEQUENCE S SEQSIZE="0^0"
64 ;
65 ; recompute checksum with new transmission date and time on ctl segment
66 S LINE=$P(SEQSIZE,"^",2),CHECKSUM=""
67 S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) I DATA'="" D
68 . S LINE=LINE+1,^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
69 . S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
70 . ; check for last code sheet in stack entry
71 . I '$O(^GECS(2100.1,DA,10,DA1)),$L($G(ENDOFCS)) D Q
72 . . I DATA'[ENDOFCS S DATA=DATA_ENDOFCS
73 . . S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
74 ;
75 ; store new checksum
76 S $P(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
77 ;
78 D ENDSEQ($P(SEQSIZE,"^")+STACSIZE,LINE)
79 L -^GECS(2100.1,DA)
80 Q
81 ;
82 ;
83MULTIPLE ; code sheet is larger than 30k, create multiple msgs
84 D SEQUENCE
85 N %,COUNT,SIZE,STRTSEQ,MAILMSGS
86 S STRTSEQ=SEQUENCE
87 S MAILMSGS=1,(LINE,SIZE)=0,CHECKSUM=""
88 S DA1=0 F S DA1=$O(^GECS(2100.1,DA,10,DA1)) Q:'DA1 S DATA=$G(^(DA1,0)) I DATA'="" D
89 . S LINE=LINE+1,^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
90 . S X=CHECKSUM_DATA X GECSLPC S CHECKSUM=Y
91 . ; check for last code sheet in stack entry
92 . I '$O(^GECS(2100.1,DA,10,DA1)),$L($G(ENDOFCS)) D Q
93 . . I DATA'[ENDOFCS S DATA=DATA_ENDOFCS
94 . . S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA
95 . S SIZE=SIZE+$L(DATA)
96 . I SIZE>30000 D
97 . . I $L($G(ENDOFMSG)),DATA'[ENDOFMSG S ^TMP($J,"GECSSTTR","CS",SEQUENCE,LINE,0)=DATA_ENDOFMSG
98 . . D ENDSEQ(SIZE,LINE),SEQUENCE S MAILMSGS=MAILMSGS+1,LINE=2,SIZE=0
99 ;
100 ; store new checksum
101 S $P(^GECS(2100.1,DA,11),"^",2)=CHECKSUM
102 ;
103 ; modify sequence count
104 S DATA=^GECS(2100.1,DA,10,1,0),$P(DATA,"^",13)=$E("000",$L(MAILMSGS)+1,3)_MAILMSGS
105 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
106 ;
107 ; send size=30001 to prevent other code sheets from being added
108 D ENDSEQ(30001,LINE)
109 Q
110 ;
111 ;
112ENDSEQ(SIZE,LINE) ; set end sequence control in tmp
113 ; size=size of code sheet; line=last line of sequence
114 N %
115 S ^TMP($J,"GECSSTTR","SIZE",SEQUENCE)=SIZE_"^"_LINE
116 S ^TMP($J,"GECSSTTR","LIST",SEQUENCE,DA)=""
117 S ^TMP($J,"GECSSTTR","BATCH",SEQUENCE)=BATCHDA
118 S %=$G(^TMP($J,"GECSSTTR","SEGS",SEQUENCE)) I %[$P(SEGMENT,":") Q
119 S ^TMP($J,"GECSSTTR","SEGS",SEQUENCE)=%_$S(%="":"",1:",")_$P(SEGMENT,":")
120 Q
121 ;
122 ;
123SEQUENCE ; return next sequence number
124 S SEQUENCE=$G(^TMP($J,"GECSSTTR","SEQ"))+1,^TMP($J,"GECSSTTR","SEQ")=SEQUENCE
125 Q
Note: See TracBrowser for help on using the repository browser.