DGAUDIT ;ISL/DKA,BAL/RLF - VAS - TAKES PAYLOAD AND SENDS TO AUDIT SOLUTION ; 03 Aug 2021 12:58 PM
;;5.3;Registration;**964,1097,1108**;Aug 13, 1993;Build 17
;;Per VA Directive 6402 this routine should not be modified.
;
; Reference to ^XMB("NETNAME" in ICR #1131
; Reference to ^VA(200 in ICR #1262
; Reference to FILE^DID in ICR #2052
; Reference to $$GET1^DIQ in ICR #2056
; Reference to EN^XPAR in ICR #2263
; Reference to $$PROD^XUPROD in ICR #4440
; Reference to ENCODE^XLFJSON in ICR #6682
; Reference to NOW^%DTC in ICR #10000
; Reference to YX^%DTC in ICR #10000
; Reference to DD^%DT in ICR #10003
; Reference to FILE^DICN in ICR #10009
; Reference to ^DIK in ICR #10013
; Reference to ^DIE in ICR #10018
; Reference to $$S^%ZTLOAD in ICR #10063
; Reference to ^XMD in ICR #10070
; Reference to ^DIC(4 in ICR #10090
; Reference to ^XMB(1 in ICR #10091
; Reference to DD^%DT in ICR #10103
;
Q ; No entry from top
;
EXPORT ; Called from TaskMan job
; Quit if this subroutine is already running
N DGLOGN,DGDEBUGON,DGAUDKPX,DGBATSIZE
S DGDEBUGON=$$GET^XPAR("ALL","DG VAS DEBUGGING FLAG")
L +^DGAUDIT2(0):2 I '$T D Q
. I DGDEBUGON D
.. S ^XTMP("DGLOCKFAIL",$H,DUZ,$J)="" ; Checks to see if taskman job is running ; FLS Added lock check to log lock attempts.
.. S ^XTMP("DGLOCKFAIL",0)=$$FMADD^XLFDT($$DT^XLFDT(),1)_"^"_$$DT^XLFDT()_"^Debug VAS Communication Errors"
N DGAUDERR,DGAUDOPCNT,DGAUDWRCNT,DGAUDEXPHT,DGAUDOPMAX,DGAUDOPFRQ,DGAUDSTOP,DGAUDSHUT,DGAUDOPTO,DGAUDWRMAX
N DGAUDMAX,DGAUDTN,DGAUDSRV,DGAUDPORT,DGAUDBEG,DGCONSERR,DGAUDFAIL
;
I '$$FIND1^DIC(18.12,,"B","DG VAS WEB SERVER")!('$$FIND1^DIC(18.02,,"B","DG VAS WEB SERVICE")) Q "0^Web services are not set up"
;
S DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I") ;JPN Adding to get the shutoff from xpar value as changed from 0-1
S DGAUDSTOP=0,DGAUDBEG=0,DGCONSERR=0,DGAUDFAIL=0
;
I 'DGAUDSTOP&DGAUDSHUT D
. S DGAUDMAX=$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")
. S:$G(DGAUDMAX)'>1 DGAUDMAX=60000
. S DGBATSIZE=$$GET^XPAR("ALL","DG VAS BATCH SIZE")
. ;
. ; Batch size can't be larger than Max number of entries in queue
. I (DGBATSIZE'>1)!(DGBATSIZE>DGAUDMAX) S DGBATSIZE=100
. ;
. S DGAUDSTOP=$$S^%ZTLOAD,DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
. S DGAUDKPX=+$$GET^XPAR("ALL","DG VAS DAYS TO KEEP EXCEPTIONS")
. Q:DGAUDSTOP!'DGAUDSHUT ;JPN added 'DGAUDSHUT for 0-1 change
. D EXPORT2
. I DGDEBUGON D ; FLS if debug flag on send email
. . D DBEMAIL^DGAUDIT1("EXPORT^DGAUDIT")
L -^DGAUDIT2(0)
I $D(ZTQUEUED) S ZTREQ="@" ; Kernel Environment variables. If queued, remove task when complete.
Q
;
EXPORT2 ; Main processing loop
N DGAUDECNT,DGAUDOPEN,DGAUDSC,DGAUDRD,DGDEBUGON,DGAUDTBR,DGABORT
N DGRESPERR
S DGDEBUGON=$$GET^XPAR("ALL","DG VAS DEBUGGING FLAG") ; Changed XPAR names from VSRA to VAS 3/17/21
;
; Send records already in queue
D EXPORT3(.DGABORT) Q:$G(DGABORT)
;
; Don't add records from ^DIA until queue is less than 50% full.
I '$$FROZEN(70) D ; Queue should be empty now - if queue remains more than 70% full, there's a problem.
. ; If queue less than 70% full, add payload entries for new FileMan patient-related AUDIT entries
. D NEWAUDEX^DGAUDIT1
;
D EXPORT3
Q
;
EXPORT3(DGABORT) ;JPN ADDED FOR BREAKING UP DIA GLOBAL
N DGPOST,DGRESP,DGOUT,DGERRARR,DGDONE,DGRESPONSE
S DGAUDSTOP=$$S^%ZTLOAD,DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
S DGAUDWRMAX=+$$GET^XPAR("ALL","DG VAS MAX WRITE ATTEMPTS")
S:'$G(DGAUDWRMAX) DGAUDWRMAX=5
S DGDONE=0
Q:DGAUDSTOP!'DGAUDSHUT!(DGAUDSHUT=2) ;JPN added 'DGAUDSHUT for 0-1 change
S DGAUDOPEN=1,DGAUDECNT=0,DGAUDTBR=10,DGAUDWRCNT=0
;
; Send records ready to send, in batches of DGBATSIZE
F BATCHID=$$NOW^XLFDT:.00000001 Q:'$$PENDING^DGAUDIT1!$G(DGDONE)!'DGAUDSHUT!(DGAUDSHUT=2)!$G(DGABORT) D
. N BATSIZE,PENDING,DGOUT,DGERRARR
. S PENDING=$$PENDING^DGAUDIT1
. S DGERRARR="",DGOUT=""
. I PENDING>DGBATSIZE S BATSIZE=DGBATSIZE
. E S BATSIZE=PENDING,DGDONE=1
. S DGRESP=$$RESTPOST(BATCHID,BATSIZE,.DGERRARR,DGAUDWRCNT,.DGOUT)
. I DGRESP K DGCONSERR S DGCONSERR=0,DGAUDFAIL=0
. ; Track consecutive failures, specific exceptions
. I 'DGRESP S DGAUDFAIL=$G(DGAUDFAIL)+1 I $P($G(DGRESP),"^",2) S DGCONSERR=+$P($G(DGRESP),"^",2)
. S DGAUDWRCNT=$S($G(DGRESP):1,1:DGAUDWRCNT+1)
. D PROCRESP(.DGRESP,BATCHID,.DGERRARR,DGAUDWRCNT,DGAUDWRMAX,.DGCONSERR,.DGOUT)
. I DGAUDFAIL>DGAUDWRMAX S DGABORT=1
. S DGAUDSTOP=$$S^%ZTLOAD,DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
Q
;
RESTPOST(BATCHID,BATSIZE,DGERRARR,DGAUDWRCNT,DGOUT) ; Build batch containing BATSIZE JSON records from ^DGAUDIT
N DGSERVICE,DGHEADER,DGAUDDATA,DGAUDMSG,DGAUDCNT,DGHTTPCHK,DGERR,DTSTAT,DGDATA,DGHTTPRSP,DGOUTJSON
N DGSERVER,DGSERVICE,DGRESTOBJ,DGERRCD,JSONCNT,DGAUDLAST
N $ETRAP,$ESTACK
K ^TMP($J,"DGAUDIT"),^TMP($J,"DGOUT") ; if exists from previous runs, posting would not execute.
;
K ^TMP($J,"DGOUT") ; if exists from previous runs, posting would not execute.
SET DGSERVER="DG VAS WEB SERVER"
SET DGSERVICE="DG VAS WEB SERVICE"
;
; get instance of client REST request object
SET DGRESTOBJ=$$GETREST^XOBWLIB(DGSERVICE,DGSERVER)
IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0 S DGOUT(0)="-1^"_^TMP($JOB,"DGOUT","EXCEPTION") K ^TMP($JOB,"DGOUT","EXCEPTION") Q DGOUT
S DGRESTOBJ.SSLCheckServerIdentity=0
;
; Insert JSON for one batch of records
S JSONCNT=0,BATSIZE=$S($G(BATSIZE):BATSIZE,1:100)
S DGAUDBEG=$S($G(DGAUDFAIL):+$O(^DGAUDIT(+$G(DGAUDBEG))),1:0)
S DGAUDLAST=$O(^DGAUDIT(999999999999),-1)
S DGAUDCNT=DGAUDBEG
F S DGAUDCNT=$O(^DGAUDIT(DGAUDCNT)) Q:'DGAUDCNT!(JSONCNT>(BATSIZE-1))!(DGAUDCNT>DGAUDLAST) D
. N DGJSON,FDA,DGDATA,DGDATA1,DGERR,DGERR1
. S DGJSON=$G(^DGAUDIT(DGAUDCNT,1))
. I $L(DGJSON)<30 D BADJSON^DGAUDIT2(DGAUDCNT,+$G(DGAUDKPX)) Q ; If there is no JSON payload, don't send
. S ^TMP($J,"DGAUDIT",BATCHID,DGAUDCNT)=DGJSON
. S DGJSON=$S('JSONCNT:"["_DGJSON,1:","_DGJSON)
. D DGRESTOBJ.EntityBody.Write(DGJSON)
. S JSONCNT=$G(JSONCNT)+1
D DGRESTOBJ.EntityBody.Write("]")
F DGHEADER="Accept","ContentType" D DGRESTOBJ.SetHeader(DGHEADER,"application/json")
;
Q:'JSONCNT 1 ; Nothing in batch, don't send, don't log error
;
; Execute HTTP Post method
; Get HTTP response
S DGRESPONSE=$$POST^XOBWLIB(DGRESTOBJ,"",.DGRESPERR,0)
I 'DGRESPONSE D Q DGOUT
. S DGOUT=DGRESPONSE
. S DGERRCD=$$ERRSPMSG^DGAUDIT1(DGRESPERR,.DGERRARR)
. S DGOUT=0_"^"_$S($L(DGERRCD)>1:DGERRCD,1:$P(DGRESP,"^",2))
;
S DGHTTPRSP=DGRESTOBJ.HttpResponse
S DGOUTJSON=DGHTTPRSP.Data.ReadLine() ; reads json string response from the data stream.
;
; Decode json string DGOUTJSON and return by reference via DGOUT and quit
D DECODE^XLFJSON("DGOUTJSON","DGOUT")
S DGOUT=1
Q DGRESPONSE
;
PROCRESP(DGRESP,BATCHID,DGERRARR,DGAUDWRCNT,DGAUDWRMAX,DGCONSERR,DGOUT) ; process response
; If the entire batch failed, leave entries in ^DGAUDIT and delete failed batch from ^TMP
N DGAUDERR,DGERRLIN,DGSRVRID,DGSSLPORT
I '$G(DGRESP) D Q
. N %,%H,X,Y
. S DGAUDERR=1
. I $G(DGCONSERR) I '$G(DGCONSERR(DGCONSERR)) D Q
.. I $$UPPER^VALM1($G(DGERRARR("text",1)))["UNABLE TO PARSE DATA" D
... N DGAUDC
... ; If JSON format error, save entire batch of JSON, but only for 12 hours
... S ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),,12)_"^"_$$DT^XLFDT()_"^VAS Server JSON Exceptions"
... S DGAUDC=0 F S DGAUDC=$O(^TMP($J,"DGAUDIT",BATCHID,DGAUDC)) Q:'DGAUDC D
.... S ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDC)=$G(^TMP($J,"DGAUDIT",BATCHID,DGAUDC)),^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDC,1)=$G(^DGAUDIT(DGAUDC,1))
.... N DIK,DA S DIK="^DGAUDIT(",DA=DGAUDC D ^DIK ; Remove problem JSON batch from queue
.. S DGCONSERR(DGCONSERR)=$G(DGCONSERR(DGCONSERR))+1
.. N DGERRTXT S DGERRTXT=$S($L($P($G(DGERRARR("text",1)),":",2)):$E($TR($P($G(DGERRARR("text",1)),":",2),""""),1,21),$L($G(DGERRARR("statusLine"))):$G(DGERRARR("statusLine")),1:$P($G(DGRESP),"^",2))
.. S DGERRTXT="<VAS ERROR>"_DGERRTXT D APPERROR^%ZTER(DGERRTXT)
.. S DGAUDERR(DGAUDERR)="Result of POST command: ",DGAUDERR=DGAUDERR+1
.. I $L($G(DGERRARR("statusLine"))) S DGAUDERR(DGAUDERR)=$G(DGERRARR("statusLine")),DGAUDERR=$G(DGAUDERR)+1
.. I $G(DGERRARR("text")) S DGERRLIN="" F S DGERRLIN=$O(DGERRARR("text",DGERRLIN)) Q:DGERRLIN="" S DGAUDERR(DGAUDERR)=DGERRARR("text",DGERRLIN),DGAUDERR=DGAUDERR+1
.. D CHKSIZE^DGAUDIT,GENERR^DGAUDIT1(.DGAUDERR) K DGAUDERR
. K ^TMP($J,"DGAUDIT",BATCHID)
;
; Process each record in batch (Exceptions and Successes) then delete batch from ^TMP
I $G(DGRESP) D
. ; If exceptions in DGRESP, parse comma delimited exceptions
. N DGEXCEPT,DGAUDCNT
. S DGEXCEPT=0 F S DGEXCEPT=$O(DGOUT("failedIds",DGEXCEPT)) Q:DGEXCEPT="" D
.. ; DGOUT("failedIds",exceptionSequence)=queueSequence.batchId
.. ; exceptionSequence = 1-n integer denoting sequence within list of failed id's returned in DGRESP
.. ; queueSequence = IEN from ^DGAUDIT export queue
.. ; batchId = batchId derived from FM date/time
.. ; Example: Response containing 2 record exceptions, IEN 10 and 50 from ^DGAUDIT queue, from batch Id 3211117.13122601
.. ; DGOUT("failedIds",1)=10.3211117.13122601
.. ; DGOUT("failedIds",2)=50.3211117.13122601
.. S DGAUDCNT=$P(DGOUT("failedIds",DGEXCEPT),".") Q:'DGAUDCNT ; Need ^DGAUDIT queue IEN to retrieve JSON
.. S DGAUDERR=1
.. ;
.. ; DGAUDKPX = Days to keep exception JSON in ^XTMP : "DG VAS DAYS TO KEEP EXCEPTIONS" parameter
.. I DGAUDKPX D
... I '$D(^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0)) S ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),DGAUDKPX)_"^"_$$DT^XLFDT()_"^VAS Server Exceptions"
... S ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDCNT)=$G(^TMP($J,"DGAUDIT",BATCHID,DGAUDCNT)),^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDCNT,1)=$G(^DGAUDIT(DGAUDCNT,1))
.. ;
.. ; Always send message when one or more id's are rejected?
.. S DGAUDERR(DGAUDERR)=" One or more records in batch "_BATCHID_" were rejected.",DGAUDERR=DGAUDERR+1
.. S DGAUDERR(DGAUDERR)=" See ^XTMP(""DGAUDIT_EXCEPTION;"_BATCHID_""" for more information.",DGAUDERR=DGAUDERR+1
.. I $G(DGERRARR("message")) S DGERRLIN="" F S DGERRLIN=$O(DGERRARR("message",DGERRLIN)) Q:DGERRLIN="" S DGAUDERR(DGAUDERR)=DGERRARR("message",DGERRLIN),DGAUDERR=DGAUDERR+1
.. D CHKSIZE^DGAUDIT,GENERR^DGAUDIT1(.DGAUDERR) S DGAUDWRCNT=0 K DGAUDERR
.. ; Delete Record Exceptions From ^DGAUDIT
.. N DIK,DA S DIK="^DGAUDIT(",DA=DGAUDCNT D ^DIK
. ;
. ; Delete Remaining Successful records from ^DGAUDIT
. S DGAUDCNT=0 F S DGAUDCNT=$O(^TMP($J,"DGAUDIT",BATCHID,DGAUDCNT)) Q:'DGAUDCNT D
.. N DIK,DA S DIK="^DGAUDIT(",DA=DGAUDCNT D ^DIK
. K ^TMP($J,"DGAUDIT",BATCHID)
Q 1
;
SNDMSG(DGAUDMSG,DGAUDGRP,DGALTSUB) ; Send mail message to mail group
;DGAUDMSG is an array of lines to be written in the mail message
;DGAUDGRP is mail group receiving error message.
;DGALTSUB is alternate message subject
N DGEND,DGINST,XMDUZ,XMSUB,XMTEXT,XMX,XMY,Y,DGEMAIL ;JPN ADDED 3/31/21 DGEMAIL
S DGINST=+$$STA^XUAF4($$KSP^XUPARAM("INST"))
S DGEND=$$FMTE^XLFDT($$NOW^XLFDT)
S DGEMAIL=$$GET^XPAR("ALL","DG VAS MONITOR GROUP") ;JPN ADDED 3/31/21
S DGEMAIL=$$GET1^DIQ(3.8,+$G(DGEMAIL),.01)
S DGEMAIL=$S($L(DGEMAIL):"G."_DGEMAIL,1:.5)
S XMY(DGEMAIL)="" ;JPN ADDED 3/31/21
S XMDUZ="noreply.domain.ext"
S XMSUB=$S($L($G(DGALTSUB)):DGALTSUB,1:"VAS AUDIT ERROR MESSAGE FROM STATION ")_DGINST
S XMSUB=XMSUB_$S($$PROD^XUPROD(1):" (Prod)",1:" (Test)")
S XMTEXT="DGAUDMSG(" N DIFROM D ^XMD
Q
;
CHKSIZE ; Check the size of the ^DGAUDIT global (based on the number of entries).
; If the number of entries is greater than the parameter value for the maximum number of entries,
; then repeatedly delete the first entry until the number of entries is back to the maximum.
N DA,DIK,DGAUDDATA,DGAUDMAX,DGAUDMSG,DGAUDNUM,DGAUDCNT
S DGAUDCNT=0,DGAUDMAX=+$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES") ; Changed XPAR names from VSRA to VAS 3/17/21
Q:DGAUDMAX<1 ; Don't do anything if the maximum number of entries has not been set
S:'$G(DGBATSIZE)>0 DGBATSIZE=DGBATSIZE
Q:DGAUDMAX'>DGBATSIZE ; Max queue size must be greater than batch size, otherwise we'd never accumulate enough records to fill a batch
S DIK="^DGAUDIT("
S DGAUDNUM=$$PENDING^DGAUDIT1
F Q:DGAUDNUM'>DGAUDMAX D
. S DA=$O(^DGAUDIT(0))
. D ^DIK
. S DGAUDCNT=DGAUDCNT+1
. S DGAUDNUM=$$PENDING^DGAUDIT1
I DGAUDCNT>0 S DGAUDERR=$G(DGAUDERR)+1,DGAUDERR(DGAUDERR)="The first "_$S(DGAUDCNT=1:"entry has",1:DGAUDCNT_" entries have")_" been removed from the ^DGAUDIT global."
Q
;
FROZEN(PCT) ; If there are there greater than PCT% records stuck in queue, send message
; Don't add any new records from ^DIA until queue is cleared out.
S:$G(PCT)'>25 PCT=50 ; Allow queue to reach 25% full before sending message
I $$PCTFULL>PCT D Q 1
. N DGAUDERR
. S DGAUDERR(1)="The VAS queue is over "_PCT_"% full after attempting to send all pending records."
. S DGAUDERR(2)="Please log a Help Desk ticket for assistance."
. D GENERR^DGAUDIT1(.DGAUDERR,"VAS QUEUE SIZE ERROR FROM STATION ")
Q 0
;
PCTFULL() ; VAS QUEUE % full
N DGAUDMAX
S DGAUDMAX=$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")
S:$G(DGAUDMAX)'>1 DGAUDMAX=60000 ; If parameter not defined, process defaults to 60000
Q (($$PENDING^DGAUDIT1/DGAUDMAX)*100)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGAUDIT 13527 printed Sep 23, 2025@20:17:21 Page 2
DGAUDIT ;ISL/DKA,BAL/RLF - VAS - TAKES PAYLOAD AND SENDS TO AUDIT SOLUTION ; 03 Aug 2021 12:58 PM
+1 ;;5.3;Registration;**964,1097,1108**;Aug 13, 1993;Build 17
+2 ;;Per VA Directive 6402 this routine should not be modified.
+3 ;
+4 ; Reference to ^XMB("NETNAME" in ICR #1131
+5 ; Reference to ^VA(200 in ICR #1262
+6 ; Reference to FILE^DID in ICR #2052
+7 ; Reference to $$GET1^DIQ in ICR #2056
+8 ; Reference to EN^XPAR in ICR #2263
+9 ; Reference to $$PROD^XUPROD in ICR #4440
+10 ; Reference to ENCODE^XLFJSON in ICR #6682
+11 ; Reference to NOW^%DTC in ICR #10000
+12 ; Reference to YX^%DTC in ICR #10000
+13 ; Reference to DD^%DT in ICR #10003
+14 ; Reference to FILE^DICN in ICR #10009
+15 ; Reference to ^DIK in ICR #10013
+16 ; Reference to ^DIE in ICR #10018
+17 ; Reference to $$S^%ZTLOAD in ICR #10063
+18 ; Reference to ^XMD in ICR #10070
+19 ; Reference to ^DIC(4 in ICR #10090
+20 ; Reference to ^XMB(1 in ICR #10091
+21 ; Reference to DD^%DT in ICR #10103
+22 ;
+23 ; No entry from top
QUIT
+24 ;
EXPORT ; Called from TaskMan job
+1 ; Quit if this subroutine is already running
+2 NEW DGLOGN,DGDEBUGON,DGAUDKPX,DGBATSIZE
+3 SET DGDEBUGON=$$GET^XPAR("ALL","DG VAS DEBUGGING FLAG")
+4 LOCK +^DGAUDIT2(0):2
IF '$TEST
Begin DoDot:1
+5 IF DGDEBUGON
Begin DoDot:2
+6 ; Checks to see if taskman job is running ; FLS Added lock check to log lock attempts.
SET ^XTMP("DGLOCKFAIL",$HOROLOG,DUZ,$JOB)=""
+7 SET ^XTMP("DGLOCKFAIL",0)=$$FMADD^XLFDT($$DT^XLFDT(),1)_"^"_$$DT^XLFDT()_"^Debug VAS Communication Errors"
End DoDot:2
End DoDot:1
QUIT
+8 NEW DGAUDERR,DGAUDOPCNT,DGAUDWRCNT,DGAUDEXPHT,DGAUDOPMAX,DGAUDOPFRQ,DGAUDSTOP,DGAUDSHUT,DGAUDOPTO,DGAUDWRMAX
+9 NEW DGAUDMAX,DGAUDTN,DGAUDSRV,DGAUDPORT,DGAUDBEG,DGCONSERR,DGAUDFAIL
+10 ;
+11 IF '$$FIND1^DIC(18.12,,"B","DG VAS WEB SERVER")!('$$FIND1^DIC(18.02,,"B","DG VAS WEB SERVICE"))
QUIT "0^Web services are not set up"
+12 ;
+13 ;JPN Adding to get the shutoff from xpar value as changed from 0-1
SET DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
+14 SET DGAUDSTOP=0
SET DGAUDBEG=0
SET DGCONSERR=0
SET DGAUDFAIL=0
+15 ;
+16 IF 'DGAUDSTOP&DGAUDSHUT
Begin DoDot:1
+17 SET DGAUDMAX=$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")
+18 if $GET(DGAUDMAX)'>1
SET DGAUDMAX=60000
+19 SET DGBATSIZE=$$GET^XPAR("ALL","DG VAS BATCH SIZE")
+20 ;
+21 ; Batch size can't be larger than Max number of entries in queue
+22 IF (DGBATSIZE'>1)!(DGBATSIZE>DGAUDMAX)
SET DGBATSIZE=100
+23 ;
+24 SET DGAUDSTOP=$$S^%ZTLOAD
SET DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
+25 SET DGAUDKPX=+$$GET^XPAR("ALL","DG VAS DAYS TO KEEP EXCEPTIONS")
+26 ;JPN added 'DGAUDSHUT for 0-1 change
if DGAUDSTOP!'DGAUDSHUT
QUIT
+27 DO EXPORT2
+28 ; FLS if debug flag on send email
IF DGDEBUGON
Begin DoDot:2
+29 DO DBEMAIL^DGAUDIT1("EXPORT^DGAUDIT")
End DoDot:2
End DoDot:1
+30 LOCK -^DGAUDIT2(0)
+31 ; Kernel Environment variables. If queued, remove task when complete.
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+32 QUIT
+33 ;
EXPORT2 ; Main processing loop
+1 NEW DGAUDECNT,DGAUDOPEN,DGAUDSC,DGAUDRD,DGDEBUGON,DGAUDTBR,DGABORT
+2 NEW DGRESPERR
+3 ; Changed XPAR names from VSRA to VAS 3/17/21
SET DGDEBUGON=$$GET^XPAR("ALL","DG VAS DEBUGGING FLAG")
+4 ;
+5 ; Send records already in queue
+6 DO EXPORT3(.DGABORT)
if $GET(DGABORT)
QUIT
+7 ;
+8 ; Don't add records from ^DIA until queue is less than 50% full.
+9 ; Queue should be empty now - if queue remains more than 70% full, there's a problem.
IF '$$FROZEN(70)
Begin DoDot:1
+10 ; If queue less than 70% full, add payload entries for new FileMan patient-related AUDIT entries
+11 DO NEWAUDEX^DGAUDIT1
End DoDot:1
+12 ;
+13 DO EXPORT3
+14 QUIT
+15 ;
EXPORT3(DGABORT) ;JPN ADDED FOR BREAKING UP DIA GLOBAL
+1 NEW DGPOST,DGRESP,DGOUT,DGERRARR,DGDONE,DGRESPONSE
+2 SET DGAUDSTOP=$$S^%ZTLOAD
SET DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
+3 SET DGAUDWRMAX=+$$GET^XPAR("ALL","DG VAS MAX WRITE ATTEMPTS")
+4 if '$GET(DGAUDWRMAX)
SET DGAUDWRMAX=5
+5 SET DGDONE=0
+6 ;JPN added 'DGAUDSHUT for 0-1 change
if DGAUDSTOP!'DGAUDSHUT!(DGAUDSHUT=2)
QUIT
+7 SET DGAUDOPEN=1
SET DGAUDECNT=0
SET DGAUDTBR=10
SET DGAUDWRCNT=0
+8 ;
+9 ; Send records ready to send, in batches of DGBATSIZE
+10 FOR BATCHID=$$NOW^XLFDT:.00000001
if '$$PENDING^DGAUDIT1!$G(DGDONE)!'DGAUDSHUT!(DGAUDSHUT=2)!$GET(DGABORT)
QUIT
Begin DoDot:1
+11 NEW BATSIZE,PENDING,DGOUT,DGERRARR
+12 SET PENDING=$$PENDING^DGAUDIT1
+13 SET DGERRARR=""
SET DGOUT=""
+14 IF PENDING>DGBATSIZE
SET BATSIZE=DGBATSIZE
+15 IF '$TEST
SET BATSIZE=PENDING
SET DGDONE=1
+16 SET DGRESP=$$RESTPOST(BATCHID,BATSIZE,.DGERRARR,DGAUDWRCNT,.DGOUT)
+17 IF DGRESP
KILL DGCONSERR
SET DGCONSERR=0
SET DGAUDFAIL=0
+18 ; Track consecutive failures, specific exceptions
+19 IF 'DGRESP
SET DGAUDFAIL=$GET(DGAUDFAIL)+1
IF $PIECE($GET(DGRESP),"^",2)
SET DGCONSERR=+$PIECE($GET(DGRESP),"^",2)
+20 SET DGAUDWRCNT=$SELECT($GET(DGRESP):1,1:DGAUDWRCNT+1)
+21 DO PROCRESP(.DGRESP,BATCHID,.DGERRARR,DGAUDWRCNT,DGAUDWRMAX,.DGCONSERR,.DGOUT)
+22 IF DGAUDFAIL>DGAUDWRMAX
SET DGABORT=1
+23 SET DGAUDSTOP=$$S^%ZTLOAD
SET DGAUDSHUT=$$GET1^DIQ(46.5,1,.02,"I")
End DoDot:1
+24 QUIT
+25 ;
RESTPOST(BATCHID,BATSIZE,DGERRARR,DGAUDWRCNT,DGOUT) ; Build batch containing BATSIZE JSON records from ^DGAUDIT
+1 NEW DGSERVICE,DGHEADER,DGAUDDATA,DGAUDMSG,DGAUDCNT,DGHTTPCHK,DGERR,DTSTAT,DGDATA,DGHTTPRSP,DGOUTJSON
+2 NEW DGSERVER,DGSERVICE,DGRESTOBJ,DGERRCD,JSONCNT,DGAUDLAST
+3 NEW $ETRAP,$ESTACK
+4 ; if exists from previous runs, posting would not execute.
KILL ^TMP($JOB,"DGAUDIT"),^TMP($JOB,"DGOUT")
+5 ;
+6 ; if exists from previous runs, posting would not execute.
KILL ^TMP($JOB,"DGOUT")
+7 SET DGSERVER="DG VAS WEB SERVER"
+8 SET DGSERVICE="DG VAS WEB SERVICE"
+9 ;
+10 ; get instance of client REST request object
+11 SET DGRESTOBJ=$$GETREST^XOBWLIB(DGSERVICE,DGSERVER)
+12 IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0
SET DGOUT(0)="-1^"_^TMP($JOB,"DGOUT","EXCEPTION")
KILL ^TMP($JOB,"DGOUT","EXCEPTION")
QUIT DGOUT
+13 SET DGRESTOBJ.SSLCheckServerIdentity=0
+14 ;
+15 ; Insert JSON for one batch of records
+16 SET JSONCNT=0
SET BATSIZE=$SELECT($GET(BATSIZE):BATSIZE,1:100)
+17 SET DGAUDBEG=$SELECT($GET(DGAUDFAIL):+$ORDER(^DGAUDIT(+$GET(DGAUDBEG))),1:0)
+18 SET DGAUDLAST=$ORDER(^DGAUDIT(999999999999),-1)
+19 SET DGAUDCNT=DGAUDBEG
+20 FOR
SET DGAUDCNT=$ORDER(^DGAUDIT(DGAUDCNT))
if 'DGAUDCNT!(JSONCNT>(BATSIZE-1))!(DGAUDCNT>DGAUDLAST)
QUIT
Begin DoDot:1
+21 NEW DGJSON,FDA,DGDATA,DGDATA1,DGERR,DGERR1
+22 SET DGJSON=$GET(^DGAUDIT(DGAUDCNT,1))
+23 ; If there is no JSON payload, don't send
IF $LENGTH(DGJSON)<30
DO BADJSON^DGAUDIT2(DGAUDCNT,+$GET(DGAUDKPX))
QUIT
+24 SET ^TMP($JOB,"DGAUDIT",BATCHID,DGAUDCNT)=DGJSON
+25 SET DGJSON=$SELECT('JSONCNT:"["_DGJSON,1:","_DGJSON)
+26 DO DGRESTOBJ.EntityBody.Write(DGJSON)
+27 SET JSONCNT=$GET(JSONCNT)+1
End DoDot:1
+28 DO DGRESTOBJ.EntityBody.Write("]")
+29 FOR DGHEADER="Accept","ContentType"
DO DGRESTOBJ.SetHeader(DGHEADER,"application/json")
+30 ;
+31 ; Nothing in batch, don't send, don't log error
if 'JSONCNT
QUIT 1
+32 ;
+33 ; Execute HTTP Post method
+34 ; Get HTTP response
+35 SET DGRESPONSE=$$POST^XOBWLIB(DGRESTOBJ,"",.DGRESPERR,0)
+36 IF 'DGRESPONSE
Begin DoDot:1
+37 SET DGOUT=DGRESPONSE
+38 SET DGERRCD=$$ERRSPMSG^DGAUDIT1(DGRESPERR,.DGERRARR)
+39 SET DGOUT=0_"^"_$SELECT($LENGTH(DGERRCD)>1:DGERRCD,1:$PIECE(DGRESP,"^",2))
End DoDot:1
QUIT DGOUT
+40 ;
+41 SET DGHTTPRSP=DGRESTOBJ.HttpResponse
+42 ; reads json string response from the data stream.
SET DGOUTJSON=DGHTTPRSP.Data.ReadLine()
+43 ;
+44 ; Decode json string DGOUTJSON and return by reference via DGOUT and quit
+45 DO DECODE^XLFJSON("DGOUTJSON","DGOUT")
+46 SET DGOUT=1
+47 QUIT DGRESPONSE
+48 ;
PROCRESP(DGRESP,BATCHID,DGERRARR,DGAUDWRCNT,DGAUDWRMAX,DGCONSERR,DGOUT) ; process response
+1 ; If the entire batch failed, leave entries in ^DGAUDIT and delete failed batch from ^TMP
+2 NEW DGAUDERR,DGERRLIN,DGSRVRID,DGSSLPORT
+3 IF '$GET(DGRESP)
Begin DoDot:1
+4 NEW %,%H,X,Y
+5 SET DGAUDERR=1
+6 IF $GET(DGCONSERR)
IF '$GET(DGCONSERR(DGCONSERR))
Begin DoDot:2
+7 IF $$UPPER^VALM1($GET(DGERRARR("text",1)))["UNABLE TO PARSE DATA"
Begin DoDot:3
+8 NEW DGAUDC
+9 ; If JSON format error, save entire batch of JSON, but only for 12 hours
+10 SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),,12)_"^"_$$DT^XLFDT()_"^VAS Server JSON Exceptions"
+11 SET DGAUDC=0
FOR
SET DGAUDC=$ORDER(^TMP($JOB,"DGAUDIT",BATCHID,DGAUDC))
if 'DGAUDC
QUIT
Begin DoDot:4
+12 SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDC)=$GET(^TMP($JOB,"DGAUDIT",BATCHID,DGAUDC))
SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDC,1)=$GET(^DGAUDIT(DGAUDC,1))
+13 ; Remove problem JSON batch from queue
NEW DIK,DA
SET DIK="^DGAUDIT("
SET DA=DGAUDC
DO ^DIK
End DoDot:4
End DoDot:3
+14 SET DGCONSERR(DGCONSERR)=$GET(DGCONSERR(DGCONSERR))+1
+15 NEW DGERRTXT
SET DGERRTXT=$SELECT($LENGTH($PIECE($GET(DGERRARR("text",1)),":",2)):$EXTRACT($TRANSLATE($PIECE($GET(DGERRARR("text",1)),":",2),""""),1,21),$LENGTH($GET(DGERRARR("statusLine"))):$GET(DGERRARR("statusLine")),1:$PIECE($GET(DGR
ESP),"^",2))
+16 SET DGERRTXT="<VAS ERROR>"_DGERRTXT
DO APPERROR^%ZTER(DGERRTXT)
+17 SET DGAUDERR(DGAUDERR)="Result of POST command: "
SET DGAUDERR=DGAUDERR+1
+18 IF $LENGTH($GET(DGERRARR("statusLine")))
SET DGAUDERR(DGAUDERR)=$GET(DGERRARR("statusLine"))
SET DGAUDERR=$GET(DGAUDERR)+1
+19 IF $GET(DGERRARR("text"))
SET DGERRLIN=""
FOR
SET DGERRLIN=$ORDER(DGERRARR("text",DGERRLIN))
if DGERRLIN=""
QUIT
SET DGAUDERR(DGAUDERR)=DGERRARR("text",DGERRLIN)
SET DGAUDERR=DGAUDERR+1
+20 DO CHKSIZE^DGAUDIT
DO GENERR^DGAUDIT1(.DGAUDERR)
KILL DGAUDERR
End DoDot:2
QUIT
+21 KILL ^TMP($JOB,"DGAUDIT",BATCHID)
End DoDot:1
QUIT
+22 ;
+23 ; Process each record in batch (Exceptions and Successes) then delete batch from ^TMP
+24 IF $GET(DGRESP)
Begin DoDot:1
+25 ; If exceptions in DGRESP, parse comma delimited exceptions
+26 NEW DGEXCEPT,DGAUDCNT
+27 SET DGEXCEPT=0
FOR
SET DGEXCEPT=$ORDER(DGOUT("failedIds",DGEXCEPT))
if DGEXCEPT=""
QUIT
Begin DoDot:2
+28 ; DGOUT("failedIds",exceptionSequence)=queueSequence.batchId
+29 ; exceptionSequence = 1-n integer denoting sequence within list of failed id's returned in DGRESP
+30 ; queueSequence = IEN from ^DGAUDIT export queue
+31 ; batchId = batchId derived from FM date/time
+32 ; Example: Response containing 2 record exceptions, IEN 10 and 50 from ^DGAUDIT queue, from batch Id 3211117.13122601
+33 ; DGOUT("failedIds",1)=10.3211117.13122601
+34 ; DGOUT("failedIds",2)=50.3211117.13122601
+35 ; Need ^DGAUDIT queue IEN to retrieve JSON
SET DGAUDCNT=$PIECE(DGOUT("failedIds",DGEXCEPT),".")
if 'DGAUDCNT
QUIT
+36 SET DGAUDERR=1
+37 ;
+38 ; DGAUDKPX = Days to keep exception JSON in ^XTMP : "DG VAS DAYS TO KEEP EXCEPTIONS" parameter
+39 IF DGAUDKPX
Begin DoDot:3
+40 IF '$DATA(^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0))
SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),DGAUDKPX)_"^"_$$DT^XLFDT()_"^VAS Server Exceptions"
+41 SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDCNT)=$GET(^TMP($JOB,"DGAUDIT",BATCHID,DGAUDCNT))
SET ^XTMP("DGAUDIT_EXCEPTION;"_BATCHID,DGAUDCNT,1)=$GET(^DGAUDIT(DGAUDCNT,1))
End DoDot:3
+42 ;
+43 ; Always send message when one or more id's are rejected?
+44 SET DGAUDERR(DGAUDERR)=" One or more records in batch "_BATCHID_" were rejected."
SET DGAUDERR=DGAUDERR+1
+45 SET DGAUDERR(DGAUDERR)=" See ^XTMP(""DGAUDIT_EXCEPTION;"_BATCHID_""" for more information."
SET DGAUDERR=DGAUDERR+1
+46 IF $GET(DGERRARR("message"))
SET DGERRLIN=""
FOR
SET DGERRLIN=$ORDER(DGERRARR("message",DGERRLIN))
if DGERRLIN=""
QUIT
SET DGAUDERR(DGAUDERR)=DGERRARR("message",DGERRLIN)
SET DGAUDERR=DGAUDERR+1
+47 DO CHKSIZE^DGAUDIT
DO GENERR^DGAUDIT1(.DGAUDERR)
SET DGAUDWRCNT=0
KILL DGAUDERR
+48 ; Delete Record Exceptions From ^DGAUDIT
+49 NEW DIK,DA
SET DIK="^DGAUDIT("
SET DA=DGAUDCNT
DO ^DIK
End DoDot:2
+50 ;
+51 ; Delete Remaining Successful records from ^DGAUDIT
+52 SET DGAUDCNT=0
FOR
SET DGAUDCNT=$ORDER(^TMP($JOB,"DGAUDIT",BATCHID,DGAUDCNT))
if 'DGAUDCNT
QUIT
Begin DoDot:2
+53 NEW DIK,DA
SET DIK="^DGAUDIT("
SET DA=DGAUDCNT
DO ^DIK
End DoDot:2
+54 KILL ^TMP($JOB,"DGAUDIT",BATCHID)
End DoDot:1
+55 QUIT 1
+56 ;
SNDMSG(DGAUDMSG,DGAUDGRP,DGALTSUB) ; Send mail message to mail group
+1 ;DGAUDMSG is an array of lines to be written in the mail message
+2 ;DGAUDGRP is mail group receiving error message.
+3 ;DGALTSUB is alternate message subject
+4 ;JPN ADDED 3/31/21 DGEMAIL
NEW DGEND,DGINST,XMDUZ,XMSUB,XMTEXT,XMX,XMY,Y,DGEMAIL
+5 SET DGINST=+$$STA^XUAF4($$KSP^XUPARAM("INST"))
+6 SET DGEND=$$FMTE^XLFDT($$NOW^XLFDT)
+7 ;JPN ADDED 3/31/21
SET DGEMAIL=$$GET^XPAR("ALL","DG VAS MONITOR GROUP")
+8 SET DGEMAIL=$$GET1^DIQ(3.8,+$GET(DGEMAIL),.01)
+9 SET DGEMAIL=$SELECT($LENGTH(DGEMAIL):"G."_DGEMAIL,1:.5)
+10 ;JPN ADDED 3/31/21
SET XMY(DGEMAIL)=""
+11 SET XMDUZ="noreply.domain.ext"
+12 SET XMSUB=$SELECT($LENGTH($GET(DGALTSUB)):DGALTSUB,1:"VAS AUDIT ERROR MESSAGE FROM STATION ")_DGINST
+13 SET XMSUB=XMSUB_$SELECT($$PROD^XUPROD(1):" (Prod)",1:" (Test)")
+14 SET XMTEXT="DGAUDMSG("
NEW DIFROM
DO ^XMD
+15 QUIT
+16 ;
CHKSIZE ; Check the size of the ^DGAUDIT global (based on the number of entries).
+1 ; If the number of entries is greater than the parameter value for the maximum number of entries,
+2 ; then repeatedly delete the first entry until the number of entries is back to the maximum.
+3 NEW DA,DIK,DGAUDDATA,DGAUDMAX,DGAUDMSG,DGAUDNUM,DGAUDCNT
+4 ; Changed XPAR names from VSRA to VAS 3/17/21
SET DGAUDCNT=0
SET DGAUDMAX=+$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")
+5 ; Don't do anything if the maximum number of entries has not been set
if DGAUDMAX<1
QUIT
+6 if '$GET(DGBATSIZE)>0
SET DGBATSIZE=DGBATSIZE
+7 ; Max queue size must be greater than batch size, otherwise we'd never accumulate enough records to fill a batch
if DGAUDMAX'>DGBATSIZE
QUIT
+8 SET DIK="^DGAUDIT("
+9 SET DGAUDNUM=$$PENDING^DGAUDIT1
+10 FOR
if DGAUDNUM'>DGAUDMAX
QUIT
Begin DoDot:1
+11 SET DA=$ORDER(^DGAUDIT(0))
+12 DO ^DIK
+13 SET DGAUDCNT=DGAUDCNT+1
+14 SET DGAUDNUM=$$PENDING^DGAUDIT1
End DoDot:1
+15 IF DGAUDCNT>0
SET DGAUDERR=$GET(DGAUDERR)+1
SET DGAUDERR(DGAUDERR)="The first "_$SELECT(DGAUDCNT=1:"entry has",1:DGAUDCNT_" entries have")_" been removed from the ^DGAUDIT global."
+16 QUIT
+17 ;
FROZEN(PCT) ; If there are there greater than PCT% records stuck in queue, send message
+1 ; Don't add any new records from ^DIA until queue is cleared out.
+2 ; Allow queue to reach 25% full before sending message
if $GET(PCT)'>25
SET PCT=50
+3 IF $$PCTFULL>PCT
Begin DoDot:1
+4 NEW DGAUDERR
+5 SET DGAUDERR(1)="The VAS queue is over "_PCT_"% full after attempting to send all pending records."
+6 SET DGAUDERR(2)="Please log a Help Desk ticket for assistance."
+7 DO GENERR^DGAUDIT1(.DGAUDERR,"VAS QUEUE SIZE ERROR FROM STATION ")
End DoDot:1
QUIT 1
+8 QUIT 0
+9 ;
PCTFULL() ; VAS QUEUE % full
+1 NEW DGAUDMAX
+2 SET DGAUDMAX=$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")
+3 ; If parameter not defined, process defaults to 60000
if $GET(DGAUDMAX)'>1
SET DGAUDMAX=60000
+4 QUIT (($$PENDING^DGAUDIT1/DGAUDMAX)*100)
