Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGAUDIT2

DGAUDIT2.m

Go to the documentation of this file. 
DGAUDIT2 ;PER/LAB,ISL/DKA - Patient Lookup Audit Report for VAS ;May 17, 2021@12:09

 ;;5.3;Registration;**964,1097,1108**;Aug 13, 1993;Build 17

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ; Reference to FILE^DICN in ICR #10009

 ; Reference to $$GETICN^MPIF001 in ICR #2701

 ; Reference to $$STA^XUAF4 in ICR #2171

 ; Reference to $$KSP^XUPARAM in ICR #2541

 ; Reference to ^XLFJSON in ICR #6682

 ; Reference to $$GET^XPAR in ICR #2263

 ;

 Q  ; No entry from top

 ;

SELAUD(DGVFILNO,DGVDFN,REQTYP,DGOPT) ;Audit Patient records at selection

 ; VistA Security Remediation

 ; When a patient is manually selected to be viewed or edited, an

 ; audit record will be created. 

 S:'$G(DGAUDMAX) DGAUDMAX=$$GET^XPAR("ALL","DG VAS MAX QUEUE ENTRIES")

 Q:$$PENDING^DGAUDIT1'<DGAUDMAX

 Q:$G(DGVDFN)=""   ; if new patient, cannot display information

 Q:$$ANON^DGAUDIT1(DUZ)  ; anonymous/proxy user don't continue

 S DGVDFN=+DGVDFN

 Q:'$$FIND1^DIC(2,"","A","`"_DGVDFN)

 ;

 ; D CHKSIZE^DGAUDIT,SNDMSG^DGAUDIT(.DGAUDERR) 2/23 took out cannot add here as this will be checked at install and not let the full dia global be populated

 N DA,DIC,NINUM,DO,DTOUT,DUOUT,INDX,LFLAG,MENUOPT,X,DGVECNT,Y,DIY,DIX

 S MENUOPT=$S($L($P($G(DGOPT),"^")):$P($G(DGOPT),"^"),$L($P($G(DGOPT),"^",2)):$P($G(DGOPT),"^",2),$L($P($G(XQY0),"^")):$P($G(XQY0),"^"),1:"UNKNOWN/NON-STANDARD")

 ;

 D PROCJSON(REQTYP,DGVDFN,$G(DUZ),$G(MENUOPT),$G(DGVFILNO),$G(DUZ(2)))

 Q

 ;

 ;PROCJSON(DGAUDECNT) ; Create the JSON from the individual fields in the DGAUD AUDIT QUEUE record

PROCJSON(REQTYP,DGVDFN,DUZ,MENUOPT,DGVFILNO,DUZ2) ; Create the JSON from the individual fields in the DGAUD AUDIT QUEUE record

 ; ISL/DKA This copy is for playing around with using only FileMan calls to get the data

 N D,D0,DA,DI,DIC,DIE,DIERR,DO,DQ,DR,X,DGARR,DGAUDARR,DGAUDDATA,DGAUDDFN,DGAUDDT,DGAUDDUZ,DGAUDERR

 N DGAUDFILE,DGAUDFILNO,DGAUDJSON,DGAUDOFFN,DGAUDREF,DGAUDSITEN,DGAUDSTANUM,Y,DGFDA,DGMVI,DGERR

 N DGFDA,DGNOWDTM,DGAUDERR,DGAUDECNT,DGFILNAME,DGCTRL,DGSTA,JSONERR,DGAUDIEN

 N DGSTATION,DGSITENAM,DGSITEIEN,DGRESULT,TMPJSON

 ;

 S DGAUDECNT="+1"

 S DGNOWDTM=$$NOW^XLFDT

 D FILE^DID(DGVFILNO,,"NAME","DGFILNAME","DGERR")

 ;

 N I F I=0:1:31 S DGCTRL=$G(DGCTRL)_$c(I)  ; Build string of non-printable control characters

 S DGFDA(46.3,DGAUDECNT_",",.01)=DGNOWDTM

 ;

 S DGAUDDATA(46.3,DGAUDECNT_",",.02,"E")=$G(REQTYP)

 S DGAUDDATA(46.3,DGAUDECNT_",",.03,"E")=$$FMTE^XLFDT(DGNOWDTM,2)

 S DGAUDDATA(46.3,DGAUDECNT_",",.04,"E")=$$GET1^DIQ(2,+$G(DGVDFN),.01)

 S DGAUDDATA(46.3,DGAUDECNT_",",.05,"E")=$$GET1^DIQ(200,$G(DUZ),.01)

 S DGAUDDATA(46.3,DGAUDECNT_",",.06,"E")=$TR($G(MENUOPT),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.07,"E")=$TR($G(DGFILNAME("NAME"),"UNKNOWN"),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.08,"E")=$TR($$GET1^DIQ(4,+$G(DUZ2),.01),DGCTRL)

 ;

 S DGAUDDATA(46.3,DGAUDECNT_",",.02,"I")=$TR($E($G(REQTYP)),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.03,"I")=DGNOWDTM

 S DGAUDDATA(46.3,DGAUDECNT_",",.04,"I")=$TR(DGVDFN,DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.05,"I")=$TR($G(DUZ),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.06,"I")=$TR($$FIND1^DIC(19,,,$G(MENUOPT)),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.07,"I")=$TR($G(DGVFILNO),DGCTRL)

 S DGAUDDATA(46.3,DGAUDECNT_",",.08,"I")=$TR(DUZ2,DGCTRL)

 ;

 S DGFDA(46.3,DGAUDECNT_",",.02)=$E($G(REQTYP))

 S DGFDA(46.3,DGAUDECNT_",",.03)=DGNOWDTM

 S DGFDA(46.3,DGAUDECNT_",",.04)=$TR($G(DGVDFN),DGCTRL)

 S DGFDA(46.3,DGAUDECNT_",",.05)=$TR($G(DUZ),DGCTRL)

 S DGFDA(46.3,DGAUDECNT_",",.06)=$TR(DGAUDDATA(46.3,DGAUDECNT_",",.06,"I"),DGCTRL)

 S DGFDA(46.3,DGAUDECNT_",",.07)=$TR($G(DGVFILNO),DGCTRL)

 S DGFDA(46.3,DGAUDECNT_",",.08)=$TR(DUZ2,DGCTRL)

 ;

 ;

 S DGARR=$NA(DGAUDARR("data","HEADER"))

 D GETS^DIQ(46.3,DGAUDECNT,"*","IE","DGAUDDATA")

 ; Set DGAUDREF for use with indirection below to get each individual field from the returned array.

 S DGAUDREF=$NA(DGAUDDATA(46.3,DGAUDECNT_","))

 ; 

 S @DGARR@("SchemaType")="FMAUDIT"

 S @DGARR@("RequestType")=$TR(@DGAUDREF@(.02,"E"),DGCTRL)

 S @DGARR@("DateTime")=$$FMTHL7^XLFDT(@DGAUDREF@(.03,"I"))

 S DGAUDDT=$TR(@DGAUDREF@(.03,"I"),DGCTRL)

 S @DGARR@("Week")=$TR($$WEEK^DGAUDIT1(DGAUDDT),DGCTRL)

 S @DGARR@("Year")=+$$FMTE^XLFDT(DGAUDDT,7)

 ;

 S DGARR=$NA(DGAUDARR("data","HEADER","Patient"))

 S (DGAUDDFN,@DGARR@("DFN"))=$TR(@DGAUDREF@(.04,"I"),DGCTRL)

 S DGMVI=$$GETICN^MPIF001(DGAUDDFN),DGMVI=$S(DGMVI>0:DGMVI,1:"") ;$$GET1^DIQ(2,DGAUDDFN,991.1)

 S @DGARR@("MVI")=$S($L(DGMVI):DGMVI,1:"null")

 S @DGARR@("PatientName")=$TR(@DGAUDREF@(.04,"E"),DGCTRL)

 S @DGARR@("SSN")=$TR($$GET1^DIQ(2,DGAUDDFN,.09),DGCTRL)

 S @DGARR@("INITPLUS4")=$TR($$GET1^DIQ(2,DGAUDDFN,.0905),DGCTRL)

 S @DGARR@("DOB")=$$FMTHL7^XLFDT($$GET1^DIQ(2,DGAUDDFN,.03,"I"))

 ;

 S DGARR=$NA(DGAUDARR("data","HEADER","User"))

 S (DGAUDDUZ,@DGARR@("DUZ"))=$TR(@DGAUDREF@(.05,"I"),DGCTRL)

 S @DGARR@("UID")=$TR($$GET1^DIQ(200,DGAUDDUZ,205.4),DGCTRL)

 S @DGARR@("UserName")=$TR($$GET1^DIQ(200,DGAUDDUZ,.01),DGCTRL)

 S @DGARR@("Title")=$TR($$GET1^DIQ(200,DGAUDDUZ,8),DGCTRL)

 ;

 S DGARR=$NA(DGAUDARR("data","HEADER","Location"))

 S DGAUDSITEN=@DGAUDREF@(.08,"I")

 I DGAUDSITEN="",DGAUDDUZ'="" S DGAUDSITEN=$O(^VA(200,DGAUDDUZ,2,"AX1",1,"")) ; Checking to make sure that DGAUDDUZ is not null to avoid a subscript FLS

 S:DGAUDSITEN="" DGAUDSITEN=$$GET1^DIQ(8989.3,1,217,"I")

 S DGAUDOFFN=$$GET1^DIQ(4,DGAUDSITEN,100)

 S @DGARR@("Site")=$S(DGAUDOFFN'="":$TR(DGAUDOFFN,DGCTRL),1:$TR(@DGAUDREF@(.08,"E"),DGCTRL))

 S DGAUDSTANUM=$TR($$GET1^DIQ(4,DGAUDSITEN,99),DGCTRL)

 I DGAUDSTANUM="" S DGAUDSTANUM=$$GET1^DIQ(4,$$GET1^DIQ(8989.3,1,217,"I"),99)

 S @DGARR@("StationNumber")=$TR(DGAUDSTANUM,DGCTRL)

 ;

 S DGARR=$NA(DGAUDARR("data","SCHEMA"))

 S (DGAUDFILNO,@DGARR@("FILE NUMBER"))=@DGAUDREF@(.07,"I")

 S @DGARR@("FILE NAME")=$TR(@DGAUDREF@(.07,"E"),DGCTRL)

 S @DGARR@("ACCESSED")="INQUIRED TO ENTRY"

 S @DGARR@("MENU OPTION USED")=$TR(@DGAUDREF@(.06,"E"),DGCTRL)

 ;

 S DGARR=$NA(DGAUDARR("id"))

 S @DGARR=+$G(DUZ)_"."_+$G(DGVDFN)_"."_+DGNOWDTM

 ;

 S DGARR=$NA(DGAUDARR("station"))

 S DGSTATION=$$STA^XUAF4($$KSP^XUPARAM("INST"))

 S @DGARR=DGSTATION

 S DGARR=$NA(DGAUDARR("site"))

 S DGSITEIEN=$$FIND1^DIC(4,,"X",DGSTATION,"D")

 S DGSITENAM=$$GET1^DIQ(4,DGSITEIEN,.01)

 S @DGARR=DGSITENAM

 ;

 D ENCODE^XLFJSON("DGAUDARR","DGAUDJSON","JSONERR")

 I '$G(JSONERR) D DECODE^XLFJSON("DGAUDJSON","TMPJSON","JSONERR")

 S DGFDA(46.3,DGAUDECNT_",",1)=DGAUDJSON(1)

 ;

 I ($L(DGFDA(46.3,DGAUDECNT_",",1))<30)!$G(JSONERR(0)) D  Q

 . N DGERRCAP M DGERRCAP=DGFDA M DGERRCAP(46.3,DGAUDECNT_",",1)=DGAUDARR

 . I $G(JSONERR(0)) S JSONERR=0 F  S JSONERR=$O(JSONERR(JSONERR)) Q:'JSONERR  S DGERRCAP(46.3,DGAUDECNT_",",1,"JSON ERROR",.999+JSONERR)=$G(JSONERR(JSONERR))

 . D BADJSON(0,+$G(DGAUDKPX),.DGERRCAP)

 D UPDATE^DIE("S","DGFDA","DGAUDIEN","DGRESULT") S DGAUDIEN=$G(DGAUDIEN(1))

 I 'DGAUDIEN!'$L($G(^DGAUDIT(+DGAUDIEN,1))) D

 . N DGERRCAP M DGERRCAP=DGFDA M DGERRCAP(46.3,DGAUDECNT_",",1)=DGAUDARR

 . I $D(DGRESULT("DIERR",1,"TEXT")) S DGERRCAP(46.3,DGAUDECNT_",",1,"JSON ERROR",.999)="FileMan Filer Error: "_$G(DGRESULT("DIERR",1,"TEXT",1))

 . D BADJSON(+$G(DGAUDIEN),+$G(DGAUDKPX),.DGERRCAP)

 Q

 ;

BADJSON(DGAUDCNT,DGAUDKPX,DGFDA) ; Purge bad JSON, send message

 N DGERR,DGXNODE,DGNOW,DGHEADER,DGEMPTY S DGERR=1,DGNOW=$$NOW^XLFDT

 S DGERR(DGERR)=" An audit record with missing or invalid JSON data was "_$S($G(DGAUDCNT):"purged from",1:"not added to"),DGERR=DGERR+1

 S DGERR(DGERR)=" the VAS queue. See ^XTMP(""DGAUDIT_EXCEPTION;"_DGNOW_"."_DGAUDCNT_"""",DGERR=DGERR+1

 S DGERR(DGERR)=" for more information. ",DGERR=DGERR+1

 S DGERR(DGERR)=" Header information: ",DGERR=DGERR+1

 ;

 I $G(DGAUDCNT) D

 . N DGREQUEST,DGOPTION,DGDECODE,DGTMPJSON,DGJSONERR

 . S DGTMPJSON=$G(^DGAUDIT(DGAUDCNT,1)) I $L(DGTMPJSON) D DECODE^XLFJSON("DGTMPJSON","DGDECODE","DGJSONERR")

 . S DGREQUEST=$G(DGFDA(46.3,"+1,",1,"data","HEADER","RequestType")) I '$L(DGREQUEST) S DGREQUEST=$G(DGDECODE(46.3,"+1,",1,"data","HEADER","RequestType"))

 . S DGOPTION=$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","MENU OPTION USED")) I '$L(DGOPTION) S DGOPTION=$G(DGDECODE(46.3,"+1,",1,"data","SCHEMA","MENU OPTION USED"))

 . I '$L(DGREQUEST),'$L(DGOPTION) S DGEMPTY=1 Q  ; Need Request Type and Menu Option, or consider this an empty payload

 . S DGERR(DGERR)=" "_$G(^DGAUDIT(DGAUDCNT,0)),DGERR=DGERR+1

 . S DGERR(DGERR)="Request Type: "_$G(DGFDA(46.3,"+1,",1,"data","HEADER","RequestType")),DGERR=DGERR+1

 . S DGERR(DGERR)="File Name: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","FILE NAME")),DGERR=DGERR+1

 . S DGERR(DGERR)="File Number: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","FILE NUMBER")),DGERR=DGERR+1

 . S DGERR(DGERR)="Menu Option Used: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","MENU OPTION USED")),DGERR=DGERR+1

 I '$G(DGAUDCNT) D

 . ; If there is no JSON payload, don't generate error, there is not enought info to report

 . I '$L($G(DGFDA(46.3,"+1,",1,"data","HEADER","RequestType")))!'$L($G(DGFDA(46.3,"+1,",1,"data","SCHEMA","MENU OPTION USED"))) S DGEMPTY=1 Q

 . ; Pull raw data out of array

 . N DGI,DGFIELD S DGFIELD="" F DGI=1:1  S DGFIELD=$O(DGFDA(46.3,"+1,",DGFIELD)) Q:DGFIELD=""  D

 .. I DGFIELD<1 S DGHEADER=$S(DGI=1:DGFDA(46.3,"+1,",DGFIELD),1:$G(DGHEADER)_"^"_DGFDA(46.3,"+1,",DGFIELD)),DGERR(DGERR)=" "_DGHEADER

 .. I DGFIELD=1 S DGERR=DGERR+1 D

 ... S DGERR(DGERR)="Request Type: "_$G(DGFDA(46.3,"+1,",1,"data","HEADER","RequestType")),DGERR=DGERR+1

 ... S DGERR(DGERR)="File Name: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","FILE NAME")),DGERR=DGERR+1

 ... S DGERR(DGERR)="File Number: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","FILE NUMBER")),DGERR=DGERR+1

 ... S DGERR(DGERR)="Menu Option Used: "_$G(DGFDA(46.3,"+1,",1,"data","SCHEMA","MENU OPTION USED")),DGERR=DGERR+1

 ;

 I '$G(DGEMPTY) D GENERR^DGAUDIT1(.DGERR) D

 . ; DGAUDKPX = Days to keep exception JSON in ^XTMP : "DG VAS DAYS TO KEEP EXCEPTIONS" parameter

 . S DGAUDKPX=$S($G(DGAUDKPX):DGAUDKPX,1:3)

 . S DGXNODE="DGAUDIT_EXCEPTION;"_DGNOW_"."_DGAUDCNT

 . S ^XTMP(DGXNODE,0)=$$FMADD^XLFDT($$DT^XLFDT(),DGAUDKPX)_"^"_$$DT^XLFDT()_"^VAS Server Exceptions: Invalid JSON"

 . S ^XTMP(DGXNODE,0,0)=$S($G(DGAUDCNT):$G(^DGAUDIT(DGAUDCNT,0)),1:$G(DGHEADER))

 . I $G(DGAUDCNT) S ^XTMP(DGXNODE,0,1)=$G(^DGAUDIT(DGAUDCNT,1))

 . M ^XTMP(DGXNODE,"DGFDA")=DGFDA Q

 ;

 Q:'$G(DGAUDCNT)  ; Nothing to delete, caught before being placed in queue

 ;

 ; Delete Record Exceptions From ^DGAUDIT

 N DIK,DA S DIK="^DGAUDIT(",DA=DGAUDCNT D ^DIK

 Q