XTERSUM3 ;ISF/RWF - Transport and save Error summaries ;03/10/11
;;8.0;KERNEL;**431**;Jul 10, 1995;Build 35
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
SEND ;Send summary to consolidation site.
N XMZ,XMY,XMTEXT,XTI,XT1,XT2,XT3,XTFG,FDA,XTNOW
Q:'$P(^XTV(8989.3,1,"ZTER"),U,2) ;Check if we should send
S XT1=0,XTNOW=$$NOW^XLFDT
L +^%ZTER(3.077,0):15 E Q ;Quit if don't get lock
F S XT1=$O(^%ZTER(3.077,XT1)) Q:'XT1 D
. S XT2=$G(^(XT1,0)) I $P(XT2,"^",1)="" D REMOVE(XT1) Q
. I $P(XT2,U,7)<$P(XT2,U,3) D SND1(XT1) ;Send if UPLOAD < MOST RECENT
L -^%ZTER(3.077,0)
Q
;
SND1(XT1) ;Send one entry
N XTX,IEN K ^TMP($J),FDA
D ADD("$DATA"),ADD("~~ERROR TRAP SUMMARY^3.077"),ADD("$FILE:3.077")
S IEN=XT1_","
D GETS^DIQ(3.077,IEN,".01;1;2;3;6;20;7","IN","XTX") ;Fields to get
S XTI=0
F S XTI=$O(XTX(3.077,IEN,XTI)) Q:'XTI D ADD("~"_XTI_":"_XTX(3.077,IEN,XTI,"I"))
S XT2=0
F S XT2=$O(^%ZTER(3.077,XT1,1,XT2)) Q:'XT2 D
. I $P(^%ZTER(3.077,XT1,1,XT2,0),U,5) Q
. K XTX S IEN=XT2_","_XT1_","
. D GETS^DIQ(3.07701,IEN,".01;1;2;3;13;6","IN","XTX")
. S FDA(3.07701,IEN,19)=1 ;Mark as sent.
. S XTI=0 D ADD("$SUB:3.07701")
. F S XTI=$O(XTX(3.07701,IEN,XTI)) Q:'XTI D ADD("~"_XTI_":"_XTX(3.07701,IEN,XTI,"I"))
. D ADD("$END")
. Q
D ADD("$SAVE")
S FDA(3.077,XT1_",",8)=XTNOW D FILE^DIE("K","FDA") ;Mark as sent.
Q:'$O(^TMP($J,0))
N XMDUZ,XMSUB,XMTEXT,XMY,XMSTRIP,XMMG,XMZ
S XMTEXT="^TMP($J,",XMSUB="ERROR SUMMARY - "_XTNOW
S XMY("G.XTER SUMMARY LOAD")=""
D ^XMD
Q
;
ADD(TXT) ;
S C=$G(^TMP($J)),C=C+1,^TMP($J)=C,^TMP($J,C,0)=TXT
Q
;
;This is the server code.
LOAD ;Load Summary
N XT1,XT2,XT3,FDA,XTF,XTE,XI1,XI2,XTS,XTER,DONE
S XMER=0,XT1=0,DONE=0,XI1=1,XI2=1,XTS=0
X XMREC I XMRG'="$DATA" D FORWARD(XMZ) Q ;Not correct start.
X XMREC I $E(XMRG,1,4)'="~~ER" D FORWARD(XMZ) Q
F X XMREC Q:XMER D Q:DONE ;XMRG has line from msg
. I $E(XMRG,1,5)="$FILE" S XTF=+$P(XMRG,":",2),XTS=0 Q
. I $E(XMRG,1,4)="$SUB" S XTF=+$P(XMRG,":",2),XTS=1,XI2=XI2+1 Q
. I $E(XMRG,1)="~",$L($P(XMRG,":",2)) S FDA(XTF,$$IEN(XI1,XI2,XTS),+$P(XMRG,"~",2))=$P(XMRG,":",2,99) Q
. I $E(XMRG,1,5)="$SAVE" S DONE=1 Q
. I $E(XMRG,1,4)="$END" S XTS=0 Q
. Q
S XT1=$G(FDA(3.077,$$IEN(1,,0),.01)),XT2=0 S:$L(XT1) XT2=$O(^%ZTER(3.077,"B",XT1,0)) ;See if error allready record.
I XT2 K FDA(3.077,$$IEN(1,,0),1) ;Remove First seen so don't over write
I $D(FDA)>2 D UPDATE^DIE("","FDA","XTE","XTER") I $D(XTER) D FORWARD(XMZ)
Q
;
IEN(V1,V2,V3) ;Build an ien
Q $S('V3:"?+"_V1_",",1:"?+"_V2_",?+"_V1_",")
;
FORWARD(XMZ) ;Forward to group to look at error
N XMY,XMDUZ
S XMY("G.XTER SUMMARY ERROR")=""
D ENT1^XMD
Q
;
REMOVE(XTA) ;Remove a dangling count record
N XTB
K ^%ZTER(3.077,XTA)
S XTB=""
F S XTB=$O(^%ZTER(3.077,"B",XTB)) Q:XTB="" I $D(^%ZTER(3.077,"B",XTB,XTA)) K ^%ZTER(3.077,"B",XTB)
Q
;
TESTL ;
N XMCNT,XMER,XMREC,XMRG
R !,"Msg#: ",XMZ:DTIME Q:'XMZ
S XMCNT=.9,XMER=0
S XMREC="S XMCNT=$O(^XMB(3.9,XMZ,2,XMCNT)) S:'XMCNT XMER=1 Q:XMER S XMRG=^(XMCNT,0)"
D LOAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTERSUM3 3113 printed Dec 13, 2024@02:40:51 Page 2
XTERSUM3 ;ISF/RWF - Transport and save Error summaries ;03/10/11
+1 ;;8.0;KERNEL;**431**;Jul 10, 1995;Build 35
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
SEND ;Send summary to consolidation site.
+1 NEW XMZ,XMY,XMTEXT,XTI,XT1,XT2,XT3,XTFG,FDA,XTNOW
+2 ;Check if we should send
if '$PIECE(^XTV(8989.3,1,"ZTER"),U,2)
QUIT
+3 SET XT1=0
SET XTNOW=$$NOW^XLFDT
+4 ;Quit if don't get lock
LOCK +^%ZTER(3.077,0):15
IF '$TEST
QUIT
+5 FOR
SET XT1=$ORDER(^%ZTER(3.077,XT1))
if 'XT1
QUIT
Begin DoDot:1
+6 SET XT2=$GET(^(XT1,0))
IF $PIECE(XT2,"^",1)=""
DO REMOVE(XT1)
QUIT
+7 ;Send if UPLOAD < MOST RECENT
IF $PIECE(XT2,U,7)<$PIECE(XT2,U,3)
DO SND1(XT1)
End DoDot:1
+8 LOCK -^%ZTER(3.077,0)
+9 QUIT
+10 ;
SND1(XT1) ;Send one entry
+1 NEW XTX,IEN
KILL ^TMP($JOB),FDA
+2 DO ADD("$DATA")
DO ADD("~~ERROR TRAP SUMMARY^3.077")
DO ADD("$FILE:3.077")
+3 SET IEN=XT1_","
+4 ;Fields to get
DO GETS^DIQ(3.077,IEN,".01;1;2;3;6;20;7","IN","XTX")
+5 SET XTI=0
+6 FOR
SET XTI=$ORDER(XTX(3.077,IEN,XTI))
if 'XTI
QUIT
DO ADD("~"_XTI_":"_XTX(3.077,IEN,XTI,"I"))
+7 SET XT2=0
+8 FOR
SET XT2=$ORDER(^%ZTER(3.077,XT1,1,XT2))
if 'XT2
QUIT
Begin DoDot:1
+9 IF $PIECE(^%ZTER(3.077,XT1,1,XT2,0),U,5)
QUIT
+10 KILL XTX
SET IEN=XT2_","_XT1_","
+11 DO GETS^DIQ(3.07701,IEN,".01;1;2;3;13;6","IN","XTX")
+12 ;Mark as sent.
SET FDA(3.07701,IEN,19)=1
+13 SET XTI=0
DO ADD("$SUB:3.07701")
+14 FOR
SET XTI=$ORDER(XTX(3.07701,IEN,XTI))
if 'XTI
QUIT
DO ADD("~"_XTI_":"_XTX(3.07701,IEN,XTI,"I"))
+15 DO ADD("$END")
+16 QUIT
End DoDot:1
+17 DO ADD("$SAVE")
+18 ;Mark as sent.
SET FDA(3.077,XT1_",",8)=XTNOW
DO FILE^DIE("K","FDA")
+19 if '$ORDER(^TMP($JOB,0))
QUIT
+20 NEW XMDUZ,XMSUB,XMTEXT,XMY,XMSTRIP,XMMG,XMZ
+21 SET XMTEXT="^TMP($J,"
SET XMSUB="ERROR SUMMARY - "_XTNOW
+22 SET XMY("G.XTER SUMMARY LOAD")=""
+23 DO ^XMD
+24 QUIT
+25 ;
ADD(TXT) ;
+1 SET C=$GET(^TMP($JOB))
SET C=C+1
SET ^TMP($JOB)=C
SET ^TMP($JOB,C,0)=TXT
+2 QUIT
+3 ;
+4 ;This is the server code.
LOAD ;Load Summary
+1 NEW XT1,XT2,XT3,FDA,XTF,XTE,XI1,XI2,XTS,XTER,DONE
+2 SET XMER=0
SET XT1=0
SET DONE=0
SET XI1=1
SET XI2=1
SET XTS=0
+3 ;Not correct start.
XECUTE XMREC
IF XMRG'="$DATA"
DO FORWARD(XMZ)
QUIT
+4 XECUTE XMREC
IF $EXTRACT(XMRG,1,4)'="~~ER"
DO FORWARD(XMZ)
QUIT
+5 ;XMRG has line from msg
FOR
XECUTE XMREC
if XMER
QUIT
Begin DoDot:1
+6 IF $EXTRACT(XMRG,1,5)="$FILE"
SET XTF=+$PIECE(XMRG,":",2)
SET XTS=0
QUIT
+7 IF $EXTRACT(XMRG,1,4)="$SUB"
SET XTF=+$PIECE(XMRG,":",2)
SET XTS=1
SET XI2=XI2+1
QUIT
+8 IF $EXTRACT(XMRG,1)="~"
IF $LENGTH($PIECE(XMRG,":",2))
SET FDA(XTF,$$IEN(XI1,XI2,XTS),+$PIECE(XMRG,"~",2))=$PIECE(XMRG,":",2,99)
QUIT
+9 IF $EXTRACT(XMRG,1,5)="$SAVE"
SET DONE=1
QUIT
+10 IF $EXTRACT(XMRG,1,4)="$END"
SET XTS=0
QUIT
+11 QUIT
End DoDot:1
if DONE
QUIT
+12 ;See if error allready record.
SET XT1=$GET(FDA(3.077,$$IEN(1,,0),.01))
SET XT2=0
if $LENGTH(XT1)
SET XT2=$ORDER(^%ZTER(3.077,"B",XT1,0))
+13 ;Remove First seen so don't over write
IF XT2
KILL FDA(3.077,$$IEN(1,,0),1)
+14 IF $DATA(FDA)>2
DO UPDATE^DIE("","FDA","XTE","XTER")
IF $DATA(XTER)
DO FORWARD(XMZ)
+15 QUIT
+16 ;
IEN(V1,V2,V3) ;Build an ien
+1 QUIT $SELECT('V3:"?+"_V1_",",1:"?+"_V2_",?+"_V1_",")
+2 ;
FORWARD(XMZ) ;Forward to group to look at error
+1 NEW XMY,XMDUZ
+2 SET XMY("G.XTER SUMMARY ERROR")=""
+3 DO ENT1^XMD
+4 QUIT
+5 ;
REMOVE(XTA) ;Remove a dangling count record
+1 NEW XTB
+2 KILL ^%ZTER(3.077,XTA)
+3 SET XTB=""
+4 FOR
SET XTB=$ORDER(^%ZTER(3.077,"B",XTB))
if XTB=""
QUIT
IF $DATA(^%ZTER(3.077,"B",XTB,XTA))
KILL ^%ZTER(3.077,"B",XTB)
+5 QUIT
+6 ;
TESTL ;
+1 NEW XMCNT,XMER,XMREC,XMRG
+2 READ !,"Msg#: ",XMZ:DTIME
if 'XMZ
QUIT
+3 SET XMCNT=.9
SET XMER=0
+4 SET XMREC="S XMCNT=$O(^XMB(3.9,XMZ,2,XMCNT)) S:'XMCNT XMER=1 Q:XMER S XMRG=^(XMCNT,0)"
+5 DO LOAD
+6 QUIT
