LRJSAU60 ;ALB/PO/DK/TMK Lab File 60 Audit Manager ;08/16/2010 15:54:29
;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
;
;Reference to direct lookup via fileman to DD global supported by ICR #4281
;Reference to direct lookup of subfile name in DD global supported by ICR #4768
;Reference to sort and print templates in file 1.1 (AUDIT) supported by ICR #4806
;
AUDSET ; -- enable audit fields for file 60
; Called from:
; LRJ SYS SET AUDITED FLAG FOR FIELDS protocol
;
N LRI,LRAFLDS,FILENUM,FIELDNUM,FIELDNAM,XINDEX,XISAUD,XAUDSET,Q
N DIR,DIC,DIK,DA,DUOUT,DTOUT,DIROUT,X,Y
D FULL^VALM1
I '$D(^TMP($J,"LRAUDREQ")) D
.F LRI=1:1 S LRALINE=$P($TEXT(AFLDS+LRI^LRJSAU),";;",2) Q:LRALINE="$$END$$" D
..I +LRALINE'=60 Q
..S LRSUBFLD=$P($P(LRALINE,"^"),";",2)
..F Q=1:1:$L($P(LRALINE,"^",2),";") D
...I 'LRSUBFLD S ^TMP($J,"LRAUDREQ","60,"_$P($P(LRALINE,"^",2),";",Q))=1 Q
...S ^TMP($J,"LRAUDREQ","60,"_LRSUBFLD_","_$P($P(LRALINE,"^",2),";",Q))=1
S FIELDNUM="",DIC="^DD(60," ;ICR 4281
S DIC(0)="AEQZ",DIC("A")="Field: "
F D ^DIC D Q:Y'=""
.I Y>0,$G(^TMP($J,"LRAUDREQ","60,"_+Y)) D
..W !,"'SF' cannot be used to turn auditing off for any required audit field."
..S Y=""
.I Y>0 S FIELDNUM=$P(Y,"^"),FIELDNAM=$P(Y,"^",2)
Q:FIELDNUM=""
;check if field is multiple
S FILENUM=+$$GFLDSB(60,FIELDNUM),FILENUM=$S(FILENUM>0:FILENUM,1:60)
I FILENUM'=60 D
. S DIC="^DD("_FILENUM_"," ; ICR 4281
. S DIC(0)="AEQMZ",DIC("A")="Sub-File "_FIELDNAM_" Field: "
. F D ^DIC D Q:Y'=""
.. I Y>0,$G(^TMP($J,"LRAUDREQ","60,"_FIELDNUM_","_+Y)) D
... W !,"'SF' cannot be used to turn auditing off for any required audit field."
... S Y=""
.S FIELDNUM=$S(Y>0:$P(Y,"^"),1:"")
Q:FIELDNUM=""
S XISAUD=$$ISAUDON(FILENUM,FIELDNUM)
W !," File "_FILENUM_" - Field "_FIELDNUM_" is "_$S(XISAUD:"already ",1:"not currently ")_"audited."
N DIR
S DIR(0)="Y"
S DIR("A")="Do you wish to turn auditing "_$S(XISAUD:"OFF ",1:"ON ")_"for this field?"
S DIR("B")="No"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
S XAUDSET=+Y
N DIR
I 'XAUDSET D Q
.W !!," NO ACTION TAKEN"
.D PAUSE^VALM1
.D REFRESH^LRJSAU
;if not audited, turn auditing on
I 'XISAUD D Q
.S XINDEX=$O(^LABAUD(64.9178,"B",60,""))
.S XSUB=$S(FILENUM=60:FIELDNUM,1:FILENUM_","_FIELDNUM)
.S DIC(0)="L",DA(1)=XINDEX,DLAYGO=64.9178
.S DIC="^LABAUD(64.9178,"_XINDEX_",1,",X=XSUB
.D FILE^DICN K DLAYGO
.D TURNON^DIAUTL(FILENUM,FIELDNUM)
.W !!," CHANGE MADE: File "_FILENUM_" - Field "_FIELDNUM_" is now audited"
.D PAUSE^VALM1
.D REFRESH^LRJSAU
;if audited, turn auditing off
I XISAUD D
.S XINDEX=$O(^LABAUD(64.9178,"B",60,""))
.S XSUB=$S(FILENUM=60:FIELDNUM,1:FILENUM_","_FIELDNUM)
.I $D(^LABAUD(64.9178,XINDEX,1,"B",XSUB)) D
.. S DA(1)=XINDEX
.. S DA=$O(^LABAUD(64.9178,XINDEX,1,"B",XSUB,""))
.. S DIK="^LABAUD(64.9178,"_XINDEX_",1,"
.. D ^DIK
.D TURNON^DIAUTL(FILENUM,FIELDNUM,"n")
.W !!," CHANGE MADE: File "_FILENUM_" - Field "_FIELDNUM_" is now NOT audited"
.D PAUSE^VALM1
.D REFRESH^LRJSAU
Q
;
AUDLIST ; -- list file 60 audited fields
; Called from:
; LRJ SYS LIST AUDITED FIELDS protocol
;
N X
D FULL^VALM1
S VALMCNT=0
D KILL^LRJSAU
D KILL^VALM10()
S X=$$AUDCHK(1)
Q
;
AUDISP ; -- Display file 60 changes
; Called from:
; LRJ SYS DISPLAY FILE 60 CHANGES protocol
;
; VALMCNT - [global/Input/Output] last entry in List Manager
; VALMAR - [global/Output] reference to List Manager buffer
; like "^TMP("LRJ SYS ORDERS MANAGER",$JOB)"
;
;TSKCALL set if called from TaskMan
N FR,TO,FLDS,DIC,IOP,LRD0,LRD00,X,LRDATA,XSUB,XENT,XSTR,XLRIEN,XLRIEN1,XD1,XSQ,XD2,XSP,XLOINC
N LRDT,LRDONE,LRFAC,LRFLDNM,LRGBL,LRIEN,LRNEW,LRARRY,LROLD,LROUT,LRSET,LRUSER,SPACE,LRDEV,XNEW,BY
I '$G(TSKCALL) N LRTODT,LRFRDT,LRTO,LRFROM D FULL^VALM1
S VALMCNT=0,XSUB=" "
D KILL^LRJSAU
I '$G(TSKCALL) D KILL^VALM10()
S SPACE=$J("",47)
S LROUT=0
; set up parameters to run the print template to a null device and store the results in LRDATA array
; in case there is no null defined, print template with IOP of ";;99999" still will store the results in LRDATA
;
;kill to variable DIA needed because otherwise carryover
;occurs if user invokes various audits in same session - [krused]
K DIA
S DIC="^DIA(60," ;ICR #4806
S BY="[LRJ SYS DISPLAY FILE 60 CHANGE]"
S FLDS="[LRJ SYS DISPLAY FILE 60 CHANGE]"
;
F LRDEV="NULL DEVICE","NULL" S IOP=$$GIOP(LRDEV) QUIT:IOP'=""
I IOP="" S IOP=";;99999" ; if no IOP then set the number of lines per page to maximum
;
I '$G(TSKCALL) D FILENUM(.LROUT) Q:LROUT
I '$G(TSKCALL) I $G(LRFRDT)=""!($G(LRTODT)="") G AUDISP
I '$G(TSKCALL) I LRFRDT<0!(LRTODT<0) G AUDISP
I $G(TSKCALL) S LRFRDT=LRFROM,LRTODT=LRTO
; wait message in case many audits to search through
I '$G(TSKCALL) D WAIT^DICD
K ^TMP("LRDATA",$J)
S FR=LRFRDT,TO=LRTODT
D EN1^DIP
;
; put the results from ^TMP("LRDATA",$J... into List Manager
S ^TMP("LRJ SYS F60 AUD MANAGER",$J,1)=LRFRDT_"^"_LRTODT
I '$G(TSKCALL) D
.S X="File 60 Audit - From "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
.D ADD^LRJSAU(.VALMCNT,X)
S LRD0=0
F S LRD0=$O(^TMP("LRDATA",$J,LRD0)) Q:'LRD0 D
.; sort by new entry added ... all changes made within 2 hours are 'NEW', not 'MODIFIED'
.K LRARRY
.S LRIEN=+$G(^TMP("LRDATA",$J,LRD0,"LRIEN"))
.S LRNEW=+$O(^TMP("LRDATA",$J,"NEW",LRIEN,0))
.I LRNEW,'$D(^TMP("LRDATA",$J,"NEW",LRIEN,LRD0)) S LRNEW=0 ; new entry changed outside 2 hr window
.I LRNEW Q:'$G(^TMP("LRDATA",$J,"NEW",LRIEN,LRD0)) ; change to new entry made inside 2 hr window
.S LRDT=$G(^TMP("LRDATA",$J,LRD0,"LRDT"))
.I LRNEW D ; flag all changed records associated with 'NEW' file 60 entry
.. N Z
.. S Z=0 F S Z=$O(^TMP("LRDATA",$J,"NEW",LRIEN,Z)) Q:'Z S LRARRY(Z)=1
. I 'LRNEW S LRARRY(LRD0)=""
. ; LRD00 = ien of the audit file
. S LRD00=0
. F S LRD00=$O(LRARRY(LRD00)) Q:'LRD00 D
.. K LRDATA,LRSET M LRDATA=^TMP("LRDATA",$J,LRD00)
.. S LRDT=LRDATA("LRDT")
.. S X=" "_$E($$FMTE^XLFDT(LRDT)_SPACE,1,25)_$E(LRDATA("LRUSER")_SPACE,1,40)_LRDATA("LRIEN")
.. S XSUB=$S(LRARRY(LRD00):"NEW",1:"OLD")
.. S ^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB,LRD00,"LRDT")=X
.. S X=$P($G(^LAB(60,+$G(LRDATA("LRIEN")),0)),"^")
.. I X="" S X="NONE (DELETED BEFORE BEING COMPLETELY DEFINED)"
.. S X=" TEST NAME: "_X
.. S LRSET("LRIEN")=X
.. S X=" FIELD NAME: "_LRDATA("LRFLDNM")
.. S LRSET("LRFLDNM")=X
.. S X=" OLD VALUE: "_LRDATA("LROLD")
.. S LRSET("LROLD")=X
.. S X=" NEW VALUE: "_LRDATA("LRNEW")
.. S LRSET("LRNEW")=X
.. M ^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB,LRD00)=LRSET
.. ;extract file if user requests
.. S XLRIEN=$P(LRDATA("LRIEN"),","),XLRIEN1=$TR($P(LRDATA("LRIEN"),",",2,999),",","~")
.. S ^TMP("LRJ SYS F60 AUD MANAGER",$J,"EXTRACT_INIT",XSUB,XLRIEN,LRDATA("LRFNUM")_";"_LRDATA("LRFLDNM")_$S(XLRIEN="":"",1:"-"_XLRIEN1),LRDATA("LRDT"),LRD00)=""
;create extract file entry
S (XSUB,XLRIEN,XD1)="",LRFAC=$$NAME^XUAF4($$KSP^XUPARAM("INST"))
F S XSUB=$O(^TMP("LRJ SYS F60 AUD MANAGER",$J,"EXTRACT_INIT",XSUB)) Q:XSUB="" D
.S LRGBL=$NA(^TMP("LRJ SYS F60 AUD MANAGER",$J,"EXTRACT",XSUB))
.S XSTR="File 60 Audit "_$S(XSUB="NEW":"New_",1:"Modified ")_" Entries - From "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
.S @LRGBL@(1)=$TR(XSTR,",","")
.S @LRGBL@(2)="Facility,Test Name,Subscript,IEN~subfile IEN,NLT Code,Place holder,Site/Specimen~LOINC,Synonym(s)"
.S @LRGBL@(2)=@LRGBL@(2)_",Fld #,Fld name,Date/Time of change,Previous value,New value"
.S XSQ=2
.F S XLRIEN=$O(^TMP("LRJ SYS F60 AUD MANAGER",$J,"EXTRACT_INIT",XSUB,XLRIEN)) Q:XLRIEN="" D
..N LRREC,Z
..K XLRAR M XLRAR=^LAB(60,XLRIEN)
..S LRREC=$NA(^TMP("LRJ SYS F60 AUD MANAGER",$J,"EXTRACT_INIT",XSUB,XLRIEN))
..F S LRREC=$Q(@LRREC) Q:$QS(LRREC,5)'=XLRIEN D
...S XSQ=XSQ+1,LRD00=$QS(LRREC,8)
...K LRDATA
...M LRDATA=^TMP("LRDATA",$J,LRD00)
...;facility name
...S XSTR=$TR(LRFAC,","," ")
...;test name
...S XLRAR(0)=$TR($G(XLRAR(0)),","," ")
...I XLRAR(0)="" S XLRAR(0)="NONE (DELETED BEFORE BEING COMPLETELY DEFINED)"
...S XSTR=XSTR_","_$P($G(XLRAR(0)),"^")
...;test subscript
...S XSTR=XSTR_","_$P($G(XLRAR(0)),"^",4)
...;IEN~subfile iens
...S Z=$P($QS(LRREC,6),"-",2)
...S XSTR=XSTR_","_XLRIEN_$S(Z="":"",1:"~"_Z)
...;NLT code
...S XD1=$P($G(XLRAR(64)),"^")
...I XD1]"" S XD1=$P($G(^LAM(XD1,0)),"^",2)_"~"
...S XSTR=XSTR_","_XD1
...;Place holder
...S XSTR=XSTR_",~"
...;site/specimen(s) which linked to LOINC codes at subscript 95.3
...S XD1=0,(XD2,XSP,XLOINC)="" F S XD1=$O(XLRAR(1,XD1)) Q:XD1="" Q:XD1'?1N.N D
....S XSP=$P($G(XLRAR(1,XD1,0)),"^"),XSP=$S(XSP]"":$P($G(^LAB(61,XSP,0)),"^"),1:"")
....S XLOINC=$G(XLRAR(1,XD1,95.3))
....I XLOINC]"" S XLOINC=$$GET1^DIQ(60.01,XD1_","_XLRIEN,95.3,,"LRMSG")
....S XD2=$S(XD2]"":XD2_";",1:"")_XSP_"~"_XLOINC
...S XSTR=XSTR_","_$TR(XD2,","," ")
...;synonym(s) -- string together
...S XD1=0,XD2="" F S XD1=$O(XLRAR(5,XD1)) Q:XD1="" Q:XD1'?1N.N S XD2=$S(XD2]"":XD2_";",1:"")_$P(XLRAR(5,XD1,0),"^")
...S XSTR=XSTR_","_$TR(XD2,","," ")
...; field number
...S:LRDATA("LRFNUM")["," LRDATA("LRFNUM")=""""_LRDATA("LRFNUM")_""""
...S XSTR=XSTR_","_LRDATA("LRFNUM")
...; field name
...S:LRDATA("LRFLDNM")["," LRDATA("LRFLDNM")=""""_LRDATA("LRFLDNM")_""""
...S XSTR=XSTR_","_LRDATA("LRFLDNM")
...; date/time changed
...S XSTR=XSTR_","_LRDATA("LRDT")
...; old value
...S:LRDATA("LROLD")["," LRDATA("LROLD")=""""_LRDATA("LROLD")_""""
...S XSTR=XSTR_","_LRDATA("LROLD")
...; new value
...S:LRDATA("LRNEW")["," LRDATA("LRNEW")=""""_LRDATA("LRNEW")_""""
...S XSTR=XSTR_","_LRDATA("LRNEW")
...S @LRGBL@(XSQ)=XSTR
.Q:$G(TSKCALL)
.S VALMHDR(1)=$J("",21)_"Laboratory Test File (#60) Changes"
.S VALMHDR(2)=$J("",9)_"Date Range: "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
.D CHGCAP^VALM("HEADER","DT RECORDED"_$J("",14)_"USER"_$J("",36)_"IEN(s) ")
I '$G(TSKCALL) F XSUB="NEW","OLD" D
.I '$D(^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB)) D Q
..D ADD^LRJSAU(.VALMCNT,"")
..S X="No "_$S(XSUB="NEW":"New",1:"Modified")_" Entries"
..D ADD^LRJSAU(.VALMCNT,X)
..D ADD^LRJSAU(.VALMCNT,"")
.D ADD^LRJSAU(.VALMCNT,"")
.S X=$S(XSUB="NEW":"New",1:"Modified")_" Entries"
.D ADD^LRJSAU(.VALMCNT,X)
.D ADD^LRJSAU(.VALMCNT,"")
.S (LRD0,XENT)=""
.F S LRD0=$O(^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB,LRD0)) Q:LRD0="" D
..F S XENT=$O(^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB,LRD0,XENT)) Q:XENT="" D
...S X=^TMP("LRJ SYS F60 AUD MANAGER",$J,XSUB,LRD0,XENT)
...D ADD^LRJSAU(.VALMCNT,X)
Q
;
AUDCHK(DISPLAY) ; -- check files/fields to see if they are audited for file 60
;
; DISPLAY - [Input/Optional]
; - if 0 or does not exist, return 1 if all fields in the list are audited, 0 otherwise
; if 1 or -1 populate the VALMCNT array too as described below.
; - if 1 populate VALMCNT for all the fields in the list and change the VALM header
; - if -1 populate VALMCNT for all the fields that their audit field is turned off, but do not change the VALM header
;
; VALMCNT - [global/Input/Output] last entry in List Manager
; VALMAR - [global/Output] reference to List Manager list of fields that their audit is on or off,
; like "^TMP("LRJ SYS ORDERS MANAGER",$JOB)"
;
; Returns 1 if all audited fields are on, otherwise 0.
;
N LRI,LRJ,LRALINE,LRAFLDS,LRSUBFLD,LRAUDIT,X,FLDAUDIT,SPACE,HDRDISP,FLDTITL,XAUD,XFILENUM,XNEW
S SPACE=$J("",47)
S DISPLAY=+$G(DISPLAY),XNEW=0
S HDRDISP=0 ; intialize as header not displayed
S LRAUDIT=1 ; assume audit is ON for all fields
F LRI=1:1 S LRALINE=$P($TEXT(AFLDS+LRI^LRJSAU),";;",2) Q:LRALINE="$$END$$" D
.I +LRALINE'=60 Q
.S LRSUBFLD=$P($P(LRALINE,"^"),";",2)
.F LRJ=1:1 S LRAFLDS=$P($P(LRALINE,"^",2),";",LRJ) Q:LRAFLDS="" D
.. D AUDCHK2(+LRALINE,LRSUBFLD,LRAFLDS)
N MONLIST S FILENUM=60 D GMONLIST(FILENUM,.MONLIST)
S XFILENUM="",XNEW=1
F S XFILENUM=$O(MONLIST(XFILENUM)) Q:XFILENUM="" D
.S LRALINE=MONLIST(XFILENUM)
.F LRJ=1:1 S LRAFLDS=$P(LRALINE,";",LRJ) Q:LRAFLDS="" D
.. I XFILENUM=FILENUM,LRJ=1 Q
.. D AUDCHK2(XFILENUM,"",LRAFLDS)
Q LRAUDIT
;
AUDCHK2(XFILENUM,XFLDSUB,LRAFLDS) ;
; XFILENUM (input) - file or subfile # if known
; XFLDSUB (input/opt) - If a subfield and subfile not in XFILENUM, this is the field # for the subfile
N X
S FLDAUDIT=1 ; assume audit is ON for ONLY this field.
I XFLDSUB D ; If present, field is within a subfile XFLDSUB of XFILENUM
.N OUT
.S OUT=+$$GFLDSB(XFILENUM,XFLDSUB)
.I OUT S XFILENUM=OUT
I '$$ISAUDON(XFILENUM,LRAFLDS) S LRAUDIT=0,FLDAUDIT=0
I (DISPLAY=1)!((DISPLAY=-1)&(FLDAUDIT=0)) D
.I 'HDRDISP D ; if the header is not already displayed, display it.
..S FLDTITL="Field"_$J("",15)_"File Name"_$J("",11)_"Field Name"_$J("",15)_"Audit"_$J("",14)
..I DISPLAY=1 D
...S VALMHDR(1)=$J("",26)_"List of Audited Fields"
...S VALMHDR(2)=" Asterisk (*) beside field name denotes required field for audit"
...D CHGCAP^VALM("HEADER",FLDTITL)
..I DISPLAY=-1 D
...D ADD^LRJSAU(.VALMCNT," "_FLDTITL)
...S X=" ",$P(X,"-",73)=""
...D ADD^LRJSAU(.VALMCNT,X)
..S HDRDISP=1 ; flag the header as displayed
..Q
.S X=" "_60_"."_$S(XFILENUM=60&($E(LRAFLDS)="."):$P(LRAFLDS,".",2),XFILENUM=60:LRAFLDS,1:XFILENUM)
.I XFILENUM'=60 S X=X_$S($E(LRAFLDS)'=".":".",1:"")_LRAFLDS
.S X=$E(X_SPACE,1,17)
.S X=X_$E($$GFILENM(XFILENUM)_SPACE,1,19)_" "
.S X=X_$E($$GFLDNM(XFILENUM,LRAFLDS)_$S('$G(XNEW):"*",1:" ")_SPACE,1,27)
.S XAUD=$$GET1^DID(XFILENUM,LRAFLDS,"","AUDIT")
.S X=X_" "_$S(XAUD]"":XAUD,1:"** NOT AUDITED **")
.D ADD^LRJSAU(.VALMCNT,X)
Q
;
ISAUDON(FILENUM,FLDNUM) ; -- is audit on for the given file/field number
Q ($$GET1^DID(FILENUM,FLDNUM,"","AUDIT")["YES, ALWAYS")
;
GFLDSB(FILENUM,FLDNUM) ;if field is multiple, return subfile #
N LRX
D FIELD^DID(FILENUM,FLDNUM,"","SPECIFIER","LRX")
Q +$G(LRX("SPECIFIER"))
;
GFILENM(FILENUM) ; -- get the file/subfile name for given file ien
N LRX,LRE
I $D(^DIC(FILENUM,0)) D ; Not a subfile
.S LRX=$$GET1^DID(FILENUM,"","","NAME","LRX","LRE")
E D ; subfile
.S LRX=$O(^DD(FILENUM,0,"NM",""))
Q $G(LRX)
;
GFLDNM(FILENUM,FLDNUM) ; -- get the field name for given file/sub-file ien and field number
N OUT
D FIELD^DID(FILENUM,FLDNUM,"","LABEL","OUT")
Q $G(OUT("LABEL"))
;
GMONLIST(FILENUM,MONLIST) ; return the list of fields to be monitored from configuration file.
N ARR,IEN,FLDNUM,FLDLIST,NODE,VAR,XFILENUM
S IEN=$O(^LABAUD(64.9178,"B",FILENUM,0))
D GETS^DIQ(64.9178,IEN_",","**","","ARR")
S VAR="ARR"
S MONLIST=""
S NODE=$NAME(@VAR@(64.9178))
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,3)'=.01 D
.S FLDNUM=$P(@NODE,"^",1)
.S XFILENUM=$S(FLDNUM'[",":60,1:$P(FLDNUM,","))
.S MONLIST(XFILENUM)=$S($D(MONLIST(XFILENUM)):MONLIST(XFILENUM)_";",1:"")_$S(FLDNUM'[",":FLDNUM,1:$P(FLDNUM,",",2))
Q
;
; if '^' out of prompts, allow exit/added parameter
FILENUM(LROUT) ;
K DIR
S LROUT=0
S FILENUM=60
D GIENLIST(FILENUM,.IENLIST)
I $D(DTOUT)!$D(DUOUT) S LROUT=1 Q
I '$D(IENLIST) W !," ALL TESTS"
;Select FROM DATE
S LRFRDT=$$DATEENT("Select Start date: ",,"-NOW")
I LRFRDT<1 S:$D(DTOUT)!$D(DUOUT) LROUT=1 Q
S LRTODT=$$DATEENT(" Select End date: ",LRFRDT,"-NOW")
I $D(DTOUT)!$D(DUOUT) S LROUT=1 Q
I +LRTODT<1 S:$D(DTOUT)!$D(DUOUT) LROUT=1 Q
D MSG2
Q
;
GIENLIST(FILENUM,IENLIST) ; get list of entries (ien) For a given file into IENLIST array.
N DIC,X,Y,U
K IENLIST
S DIC("0")="AEQM"
S DIC=FILENUM
S Y=-1
F D Q:+Y=-1
.D ^DIC
.S:+Y'=-1 IENLIST(+Y)=""
Q
;
DATEENT(LRPRMPT,LRBD,LRED) ;Prompt for extract date
;INPUT
; LRPRMPT - Prompt displayed to user
; LRBD - Begin date of range
; LRED - End date of range
;
;RETURN
; LRDT
; SUCCESS: FILEMAN INTERNALLY FORMATED DATE
; FAILURE: -1
;
N LRDT,LRGOOD,X,Y
S LRGOOD=0
S:+$G(LRED)>0 %DT(0)=LRED
S:$G(LRED)["NOW" %DT(0)=LRED
S %DT("A")=LRPRMPT
S %DT("B")="TODAY" ;Default for [Start] date entry
S %DT="AEPST"
D:LRPRMPT["Start" ^%DT ;Prompt for Start date
;
;Prompt for End date with conditions
I LRPRMPT["End" D
.F Q:LRGOOD D
..S %DT("B")="NOW" ;Change default for End Date entry
..D ^%DT
..W:((Y<LRBD)&(X'="^")&('$D(DTOUT))) " ??",!," End date must follow Begin date!",!
..S:((Y>LRBD)!(Y=LRBD)!($D(DTOUT))!(X="^")) LRGOOD=1
S LRDT=Y
K Y,%DT
Q LRDT
;
MSG2 ; -- set default message
N LREND,LRBEGIN,LRAUTMSG
S LRBEGIN=$$GET^XPAR("SYS","LRJ LSRP AUF60 LAST START DATE",1,"Q")
S LREND=$$GET^XPAR("SYS","LRJ LSRP AUF60 LAST END DATE",1,"Q")
I (LRBEGIN'="")!(LREND'="") D
.S LRAUTMSG="Last Task Rpt "_$S(LRBEGIN'="":$$FMTE^XLFDT(LRBEGIN),1:"undeed")_" - "_$S(LREND'="":$$FMTE^XLFDT(LREND),1:"undefined")
I LRBEGIN="",LREND="" D
.S LRAUTMSG="Tasked Report has not run!"
S VALMSG=LRAUTMSG
Q
;
GIOP(DEVICE) ; -- return the device if exist and it is not FORCED to queue, otherwise return ""
N POP
S IOP=DEVICE
S %ZIS="N" ; so the ^%ZIS call does not open the device.
D ^%ZIS ; return the characteristics of the device.
I POP=1 DO ; does the device exist?
.S DEVICE=""
E D
.; is the queuing forced forced for this device?
.I $P(^%ZIS(1,IOS,0),"^",12)=1 S DEVICE=""
;
D ^%ZISC ; restore the device variables
Q DEVICE
;
SETTMP(D0,LRIEN,LRDT,LRUSER,LRFLDNM,LRFNUM,LROLD,LRNEW) ;
; ^TMP("LRDATA",$J,OLD/NEW determination,test ien,data element)=data element value
I $D(IENLIST),'$D(IENLIST(+LRIEN)) Q ; test is not one of those selected
N Q
F Q="LRIEN","LRDT","LRUSER","LRFLDNM","LRFNUM","LROLD","LRNEW" S ^TMP("LRDATA",$J,D0,Q)=@Q
;determine if new test was entered
I LRFLDNM="NAME",LROLD["<no previous",LRIEN=+LRIEN S ^TMP("LRDATA",$J,"NEW",LRIEN,D0)=LRDT Q
I $D(^TMP("LRDATA",$J,"NEW",+LRIEN)) D
.;Check for within 2 hr window
.N DIFF,X1,X2
.S X1=+$O(^TMP("LRDATA",$J,"NEW",+LRIEN,0)),X1=$G(^TMP("LRDATA",$J,"NEW",+LRIEN,X1))
.S X2=LRDT
.S DIFF=$$FMDIFF^XLFDT(X2,X1,2) ; find difference in seconds (2 hrs = 7200 secs)
.I DIFF'>7200 S ^TMP("LRDATA",$J,"NEW",+LRIEN,D0)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRJSAU60 18315 printed Apr 09, 2024@21:20:33 Page 2
LRJSAU60 ;ALB/PO/DK/TMK Lab File 60 Audit Manager ;08/16/2010 15:54:29
+1 ;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
+2 ;
+3 ;Reference to direct lookup via fileman to DD global supported by ICR #4281
+4 ;Reference to direct lookup of subfile name in DD global supported by ICR #4768
+5 ;Reference to sort and print templates in file 1.1 (AUDIT) supported by ICR #4806
+6 ;
AUDSET ; -- enable audit fields for file 60
+1 ; Called from:
+2 ; LRJ SYS SET AUDITED FLAG FOR FIELDS protocol
+3 ;
+4 NEW LRI,LRAFLDS,FILENUM,FIELDNUM,FIELDNAM,XINDEX,XISAUD,XAUDSET,Q
+5 NEW DIR,DIC,DIK,DA,DUOUT,DTOUT,DIROUT,X,Y
+6 DO FULL^VALM1
+7 IF '$DATA(^TMP($JOB,"LRAUDREQ"))
Begin DoDot:1
+8 FOR LRI=1:1
SET LRALINE=$PIECE($TEXT(AFLDS+LRI^LRJSAU),";;",2)
if LRALINE="$$END$$"
QUIT
Begin DoDot:2
+9 IF +LRALINE'=60
QUIT
+10 SET LRSUBFLD=$PIECE($PIECE(LRALINE,"^"),";",2)
+11 FOR Q=1:1:$LENGTH($PIECE(LRALINE,"^",2),";")
Begin DoDot:3
+12 IF 'LRSUBFLD
SET ^TMP($JOB,"LRAUDREQ","60,"_$PIECE($PIECE(LRALINE,"^",2),";",Q))=1
QUIT
+13 SET ^TMP($JOB,"LRAUDREQ","60,"_LRSUBFLD_","_$PIECE($PIECE(LRALINE,"^",2),";",Q))=1
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;ICR 4281
SET FIELDNUM=""
SET DIC="^DD(60,"
+15 SET DIC(0)="AEQZ"
SET DIC("A")="Field: "
+16 FOR
DO ^DIC
Begin DoDot:1
+17 IF Y>0
IF $GET(^TMP($JOB,"LRAUDREQ","60,"_+Y))
Begin DoDot:2
+18 WRITE !,"'SF' cannot be used to turn auditing off for any required audit field."
+19 SET Y=""
End DoDot:2
+20 IF Y>0
SET FIELDNUM=$PIECE(Y,"^")
SET FIELDNAM=$PIECE(Y,"^",2)
End DoDot:1
if Y'=""
QUIT
+21 if FIELDNUM=""
QUIT
+22 ;check if field is multiple
+23 SET FILENUM=+$$GFLDSB(60,FIELDNUM)
SET FILENUM=$SELECT(FILENUM>0:FILENUM,1:60)
+24 IF FILENUM'=60
Begin DoDot:1
+25 ; ICR 4281
SET DIC="^DD("_FILENUM_","
+26 SET DIC(0)="AEQMZ"
SET DIC("A")="Sub-File "_FIELDNAM_" Field: "
+27 FOR
DO ^DIC
Begin DoDot:2
+28 IF Y>0
IF $GET(^TMP($JOB,"LRAUDREQ","60,"_FIELDNUM_","_+Y))
Begin DoDot:3
+29 WRITE !,"'SF' cannot be used to turn auditing off for any required audit field."
+30 SET Y=""
End DoDot:3
End DoDot:2
if Y'=""
QUIT
+31 SET FIELDNUM=$SELECT(Y>0:$PIECE(Y,"^"),1:"")
End DoDot:1
+32 if FIELDNUM=""
QUIT
+33 SET XISAUD=$$ISAUDON(FILENUM,FIELDNUM)
+34 WRITE !," File "_FILENUM_" - Field "_FIELDNUM_" is "_$SELECT(XISAUD:"already ",1:"not currently ")_"audited."
+35 NEW DIR
+36 SET DIR(0)="Y"
+37 SET DIR("A")="Do you wish to turn auditing "_$SELECT(XISAUD:"OFF ",1:"ON ")_"for this field?"
+38 SET DIR("B")="No"
+39 DO ^DIR
KILL DIR
+40 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+41 SET XAUDSET=+Y
+42 NEW DIR
+43 IF 'XAUDSET
Begin DoDot:1
+44 WRITE !!," NO ACTION TAKEN"
+45 DO PAUSE^VALM1
+46 DO REFRESH^LRJSAU
End DoDot:1
QUIT
+47 ;if not audited, turn auditing on
+48 IF 'XISAUD
Begin DoDot:1
+49 SET XINDEX=$ORDER(^LABAUD(64.9178,"B",60,""))
+50 SET XSUB=$SELECT(FILENUM=60:FIELDNUM,1:FILENUM_","_FIELDNUM)
+51 SET DIC(0)="L"
SET DA(1)=XINDEX
SET DLAYGO=64.9178
+52 SET DIC="^LABAUD(64.9178,"_XINDEX_",1,"
SET X=XSUB
+53 DO FILE^DICN
KILL DLAYGO
+54 DO TURNON^DIAUTL(FILENUM,FIELDNUM)
+55 WRITE !!," CHANGE MADE: File "_FILENUM_" - Field "_FIELDNUM_" is now audited"
+56 DO PAUSE^VALM1
+57 DO REFRESH^LRJSAU
End DoDot:1
QUIT
+58 ;if audited, turn auditing off
+59 IF XISAUD
Begin DoDot:1
+60 SET XINDEX=$ORDER(^LABAUD(64.9178,"B",60,""))
+61 SET XSUB=$SELECT(FILENUM=60:FIELDNUM,1:FILENUM_","_FIELDNUM)
+62 IF $DATA(^LABAUD(64.9178,XINDEX,1,"B",XSUB))
Begin DoDot:2
+63 SET DA(1)=XINDEX
+64 SET DA=$ORDER(^LABAUD(64.9178,XINDEX,1,"B",XSUB,""))
+65 SET DIK="^LABAUD(64.9178,"_XINDEX_",1,"
+66 DO ^DIK
End DoDot:2
+67 DO TURNON^DIAUTL(FILENUM,FIELDNUM,"n")
+68 WRITE !!," CHANGE MADE: File "_FILENUM_" - Field "_FIELDNUM_" is now NOT audited"
+69 DO PAUSE^VALM1
+70 DO REFRESH^LRJSAU
End DoDot:1
+71 QUIT
+72 ;
AUDLIST ; -- list file 60 audited fields
+1 ; Called from:
+2 ; LRJ SYS LIST AUDITED FIELDS protocol
+3 ;
+4 NEW X
+5 DO FULL^VALM1
+6 SET VALMCNT=0
+7 DO KILL^LRJSAU
+8 DO KILL^VALM10()
+9 SET X=$$AUDCHK(1)
+10 QUIT
+11 ;
AUDISP ; -- Display file 60 changes
+1 ; Called from:
+2 ; LRJ SYS DISPLAY FILE 60 CHANGES protocol
+3 ;
+4 ; VALMCNT - [global/Input/Output] last entry in List Manager
+5 ; VALMAR - [global/Output] reference to List Manager buffer
+6 ; like "^TMP("LRJ SYS ORDERS MANAGER",$JOB)"
+7 ;
+8 ;TSKCALL set if called from TaskMan
+9 NEW FR,TO,FLDS,DIC,IOP,LRD0,LRD00,X,LRDATA,XSUB,XENT,XSTR,XLRIEN,XLRIEN1,XD1,XSQ,XD2,XSP,XLOINC
+10 NEW LRDT,LRDONE,LRFAC,LRFLDNM,LRGBL,LRIEN,LRNEW,LRARRY,LROLD,LROUT,LRSET,LRUSER,SPACE,LRDEV,XNEW,BY
+11 IF '$GET(TSKCALL)
NEW LRTODT,LRFRDT,LRTO,LRFROM
DO FULL^VALM1
+12 SET VALMCNT=0
SET XSUB=" "
+13 DO KILL^LRJSAU
+14 IF '$GET(TSKCALL)
DO KILL^VALM10()
+15 SET SPACE=$JUSTIFY("",47)
+16 SET LROUT=0
+17 ; set up parameters to run the print template to a null device and store the results in LRDATA array
+18 ; in case there is no null defined, print template with IOP of ";;99999" still will store the results in LRDATA
+19 ;
+20 ;kill to variable DIA needed because otherwise carryover
+21 ;occurs if user invokes various audits in same session - [krused]
+22 KILL DIA
+23 ;ICR #4806
SET DIC="^DIA(60,"
+24 SET BY="[LRJ SYS DISPLAY FILE 60 CHANGE]"
+25 SET FLDS="[LRJ SYS DISPLAY FILE 60 CHANGE]"
+26 ;
+27 FOR LRDEV="NULL DEVICE","NULL"
SET IOP=$$GIOP(LRDEV)
if IOP'=""
QUIT
+28 ; if no IOP then set the number of lines per page to maximum
IF IOP=""
SET IOP=";;99999"
+29 ;
+30 IF '$GET(TSKCALL)
DO FILENUM(.LROUT)
if LROUT
QUIT
+31 IF '$GET(TSKCALL)
IF $GET(LRFRDT)=""!($GET(LRTODT)="")
GOTO AUDISP
+32 IF '$GET(TSKCALL)
IF LRFRDT<0!(LRTODT<0)
GOTO AUDISP
+33 IF $GET(TSKCALL)
SET LRFRDT=LRFROM
SET LRTODT=LRTO
+34 ; wait message in case many audits to search through
+35 IF '$GET(TSKCALL)
DO WAIT^DICD
+36 KILL ^TMP("LRDATA",$JOB)
+37 SET FR=LRFRDT
SET TO=LRTODT
+38 DO EN1^DIP
+39 ;
+40 ; put the results from ^TMP("LRDATA",$J... into List Manager
+41 SET ^TMP("LRJ SYS F60 AUD MANAGER",$JOB,1)=LRFRDT_"^"_LRTODT
+42 IF '$GET(TSKCALL)
Begin DoDot:1
+43 SET X="File 60 Audit - From "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
+44 DO ADD^LRJSAU(.VALMCNT,X)
End DoDot:1
+45 SET LRD0=0
+46 FOR
SET LRD0=$ORDER(^TMP("LRDATA",$JOB,LRD0))
if 'LRD0
QUIT
Begin DoDot:1
+47 ; sort by new entry added ... all changes made within 2 hours are 'NEW', not 'MODIFIED'
+48 KILL LRARRY
+49 SET LRIEN=+$GET(^TMP("LRDATA",$JOB,LRD0,"LRIEN"))
+50 SET LRNEW=+$ORDER(^TMP("LRDATA",$JOB,"NEW",LRIEN,0))
+51 ; new entry changed outside 2 hr window
IF LRNEW
IF '$DATA(^TMP("LRDATA",$JOB,"NEW",LRIEN,LRD0))
SET LRNEW=0
+52 ; change to new entry made inside 2 hr window
IF LRNEW
if '$GET(^TMP("LRDATA",$JOB,"NEW",LRIEN,LRD0))
QUIT
+53 SET LRDT=$GET(^TMP("LRDATA",$JOB,LRD0,"LRDT"))
+54 ; flag all changed records associated with 'NEW' file 60 entry
IF LRNEW
Begin DoDot:2
+55 NEW Z
+56 SET Z=0
FOR
SET Z=$ORDER(^TMP("LRDATA",$JOB,"NEW",LRIEN,Z))
if 'Z
QUIT
SET LRARRY(Z)=1
End DoDot:2
+57 IF 'LRNEW
SET LRARRY(LRD0)=""
+58 ; LRD00 = ien of the audit file
+59 SET LRD00=0
+60 FOR
SET LRD00=$ORDER(LRARRY(LRD00))
if 'LRD00
QUIT
Begin DoDot:2
+61 KILL LRDATA,LRSET
MERGE LRDATA=^TMP("LRDATA",$JOB,LRD00)
+62 SET LRDT=LRDATA("LRDT")
+63 SET X=" "_$EXTRACT($$FMTE^XLFDT(LRDT)_SPACE,1,25)_$EXTRACT(LRDATA("LRUSER")_SPACE,1,40)_LRDATA("LRIEN")
+64 SET XSUB=$SELECT(LRARRY(LRD00):"NEW",1:"OLD")
+65 SET ^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB,LRD00,"LRDT")=X
+66 SET X=$PIECE($GET(^LAB(60,+$GET(LRDATA("LRIEN")),0)),"^")
+67 IF X=""
SET X="NONE (DELETED BEFORE BEING COMPLETELY DEFINED)"
+68 SET X=" TEST NAME: "_X
+69 SET LRSET("LRIEN")=X
+70 SET X=" FIELD NAME: "_LRDATA("LRFLDNM")
+71 SET LRSET("LRFLDNM")=X
+72 SET X=" OLD VALUE: "_LRDATA("LROLD")
+73 SET LRSET("LROLD")=X
+74 SET X=" NEW VALUE: "_LRDATA("LRNEW")
+75 SET LRSET("LRNEW")=X
+76 MERGE ^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB,LRD00)=LRSET
+77 ;extract file if user requests
+78 SET XLRIEN=$PIECE(LRDATA("LRIEN"),",")
SET XLRIEN1=$TRANSLATE($PIECE(LRDATA("LRIEN"),",",2,999),",","~")
+79 SET ^TMP("LRJ SYS F60 AUD MANAGER",$JOB,"EXTRACT_INIT",XSUB,XLRIEN,LRDATA("LRFNUM")_";"_LRDATA("LRFLDNM")_$SELECT(XLRIEN="":"",1:"-"_XLRIEN1),LRDATA("LRDT"),LRD00)=""
End DoDot:2
End DoDot:1
+80 ;create extract file entry
+81 SET (XSUB,XLRIEN,XD1)=""
SET LRFAC=$$NAME^XUAF4($$KSP^XUPARAM("INST"))
+82 FOR
SET XSUB=$ORDER(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,"EXTRACT_INIT",XSUB))
if XSUB=""
QUIT
Begin DoDot:1
+83 SET LRGBL=$NAME(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,"EXTRACT",XSUB))
+84 SET XSTR="File 60 Audit "_$SELECT(XSUB="NEW":"New_",1:"Modified ")_" Entries - From "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
+85 SET @LRGBL@(1)=$TRANSLATE(XSTR,",","")
+86 SET @LRGBL@(2)="Facility,Test Name,Subscript,IEN~subfile IEN,NLT Code,Place holder,Site/Specimen~LOINC,Synonym(s)"
+87 SET @LRGBL@(2)=@LRGBL@(2)_",Fld #,Fld name,Date/Time of change,Previous value,New value"
+88 SET XSQ=2
+89 FOR
SET XLRIEN=$ORDER(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,"EXTRACT_INIT",XSUB,XLRIEN))
if XLRIEN=""
QUIT
Begin DoDot:2
+90 NEW LRREC,Z
+91 KILL XLRAR
MERGE XLRAR=^LAB(60,XLRIEN)
+92 SET LRREC=$NAME(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,"EXTRACT_INIT",XSUB,XLRIEN))
+93 FOR
SET LRREC=$QUERY(@LRREC)
if $QSUBSCRIPT(LRREC,5)'=XLRIEN
QUIT
Begin DoDot:3
+94 SET XSQ=XSQ+1
SET LRD00=$QSUBSCRIPT(LRREC,8)
+95 KILL LRDATA
+96 MERGE LRDATA=^TMP("LRDATA",$JOB,LRD00)
+97 ;facility name
+98 SET XSTR=$TRANSLATE(LRFAC,","," ")
+99 ;test name
+100 SET XLRAR(0)=$TRANSLATE($GET(XLRAR(0)),","," ")
+101 IF XLRAR(0)=""
SET XLRAR(0)="NONE (DELETED BEFORE BEING COMPLETELY DEFINED)"
+102 SET XSTR=XSTR_","_$PIECE($GET(XLRAR(0)),"^")
+103 ;test subscript
+104 SET XSTR=XSTR_","_$PIECE($GET(XLRAR(0)),"^",4)
+105 ;IEN~subfile iens
+106 SET Z=$PIECE($QSUBSCRIPT(LRREC,6),"-",2)
+107 SET XSTR=XSTR_","_XLRIEN_$SELECT(Z="":"",1:"~"_Z)
+108 ;NLT code
+109 SET XD1=$PIECE($GET(XLRAR(64)),"^")
+110 IF XD1]""
SET XD1=$PIECE($GET(^LAM(XD1,0)),"^",2)_"~"
+111 SET XSTR=XSTR_","_XD1
+112 ;Place holder
+113 SET XSTR=XSTR_",~"
+114 ;site/specimen(s) which linked to LOINC codes at subscript 95.3
+115 SET XD1=0
SET (XD2,XSP,XLOINC)=""
FOR
SET XD1=$ORDER(XLRAR(1,XD1))
if XD1=""
QUIT
if XD1'?1N.N
QUIT
Begin DoDot:4
+116 SET XSP=$PIECE($GET(XLRAR(1,XD1,0)),"^")
SET XSP=$SELECT(XSP]"":$PIECE($GET(^LAB(61,XSP,0)),"^"),1:"")
+117 SET XLOINC=$GET(XLRAR(1,XD1,95.3))
+118 IF XLOINC]""
SET XLOINC=$$GET1^DIQ(60.01,XD1_","_XLRIEN,95.3,,"LRMSG")
+119 SET XD2=$SELECT(XD2]"":XD2_";",1:"")_XSP_"~"_XLOINC
End DoDot:4
+120 SET XSTR=XSTR_","_$TRANSLATE(XD2,","," ")
+121 ;synonym(s) -- string together
+122 SET XD1=0
SET XD2=""
FOR
SET XD1=$ORDER(XLRAR(5,XD1))
if XD1=""
QUIT
if XD1'?1N.N
QUIT
SET XD2=$SELECT(XD2]"":XD2_";",1:"")_$PIECE(XLRAR(5,XD1,0),"^")
+123 SET XSTR=XSTR_","_$TRANSLATE(XD2,","," ")
+124 ; field number
+125 if LRDATA("LRFNUM")[","
SET LRDATA("LRFNUM")=""""_LRDATA("LRFNUM")_""""
+126 SET XSTR=XSTR_","_LRDATA("LRFNUM")
+127 ; field name
+128 if LRDATA("LRFLDNM")[","
SET LRDATA("LRFLDNM")=""""_LRDATA("LRFLDNM")_""""
+129 SET XSTR=XSTR_","_LRDATA("LRFLDNM")
+130 ; date/time changed
+131 SET XSTR=XSTR_","_LRDATA("LRDT")
+132 ; old value
+133 if LRDATA("LROLD")[","
SET LRDATA("LROLD")=""""_LRDATA("LROLD")_""""
+134 SET XSTR=XSTR_","_LRDATA("LROLD")
+135 ; new value
+136 if LRDATA("LRNEW")[","
SET LRDATA("LRNEW")=""""_LRDATA("LRNEW")_""""
+137 SET XSTR=XSTR_","_LRDATA("LRNEW")
+138 SET @LRGBL@(XSQ)=XSTR
End DoDot:3
End DoDot:2
+139 if $GET(TSKCALL)
QUIT
+140 SET VALMHDR(1)=$JUSTIFY("",21)_"Laboratory Test File (#60) Changes"
+141 SET VALMHDR(2)=$JUSTIFY("",9)_"Date Range: "_$$FMTE^XLFDT(LRFRDT)_" to "_$$FMTE^XLFDT(LRTODT)
+142 DO CHGCAP^VALM("HEADER","DT RECORDED"_$JUSTIFY("",14)_"USER"_$JUSTIFY("",36)_"IEN(s) ")
End DoDot:1
+143 IF '$GET(TSKCALL)
FOR XSUB="NEW","OLD"
Begin DoDot:1
+144 IF '$DATA(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB))
Begin DoDot:2
+145 DO ADD^LRJSAU(.VALMCNT,"")
+146 SET X="No "_$SELECT(XSUB="NEW":"New",1:"Modified")_" Entries"
+147 DO ADD^LRJSAU(.VALMCNT,X)
+148 DO ADD^LRJSAU(.VALMCNT,"")
End DoDot:2
QUIT
+149 DO ADD^LRJSAU(.VALMCNT,"")
+150 SET X=$SELECT(XSUB="NEW":"New",1:"Modified")_" Entries"
+151 DO ADD^LRJSAU(.VALMCNT,X)
+152 DO ADD^LRJSAU(.VALMCNT,"")
+153 SET (LRD0,XENT)=""
+154 FOR
SET LRD0=$ORDER(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB,LRD0))
if LRD0=""
QUIT
Begin DoDot:2
+155 FOR
SET XENT=$ORDER(^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB,LRD0,XENT))
if XENT=""
QUIT
Begin DoDot:3
+156 SET X=^TMP("LRJ SYS F60 AUD MANAGER",$JOB,XSUB,LRD0,XENT)
+157 DO ADD^LRJSAU(.VALMCNT,X)
End DoDot:3
End DoDot:2
End DoDot:1
+158 QUIT
+159 ;
AUDCHK(DISPLAY) ; -- check files/fields to see if they are audited for file 60
+1 ;
+2 ; DISPLAY - [Input/Optional]
+3 ; - if 0 or does not exist, return 1 if all fields in the list are audited, 0 otherwise
+4 ; if 1 or -1 populate the VALMCNT array too as described below.
+5 ; - if 1 populate VALMCNT for all the fields in the list and change the VALM header
+6 ; - if -1 populate VALMCNT for all the fields that their audit field is turned off, but do not change the VALM header
+7 ;
+8 ; VALMCNT - [global/Input/Output] last entry in List Manager
+9 ; VALMAR - [global/Output] reference to List Manager list of fields that their audit is on or off,
+10 ; like "^TMP("LRJ SYS ORDERS MANAGER",$JOB)"
+11 ;
+12 ; Returns 1 if all audited fields are on, otherwise 0.
+13 ;
+14 NEW LRI,LRJ,LRALINE,LRAFLDS,LRSUBFLD,LRAUDIT,X,FLDAUDIT,SPACE,HDRDISP,FLDTITL,XAUD,XFILENUM,XNEW
+15 SET SPACE=$JUSTIFY("",47)
+16 SET DISPLAY=+$GET(DISPLAY)
SET XNEW=0
+17 ; intialize as header not displayed
SET HDRDISP=0
+18 ; assume audit is ON for all fields
SET LRAUDIT=1
+19 FOR LRI=1:1
SET LRALINE=$PIECE($TEXT(AFLDS+LRI^LRJSAU),";;",2)
if LRALINE="$$END$$"
QUIT
Begin DoDot:1
+20 IF +LRALINE'=60
QUIT
+21 SET LRSUBFLD=$PIECE($PIECE(LRALINE,"^"),";",2)
+22 FOR LRJ=1:1
SET LRAFLDS=$PIECE($PIECE(LRALINE,"^",2),";",LRJ)
if LRAFLDS=""
QUIT
Begin DoDot:2
+23 DO AUDCHK2(+LRALINE,LRSUBFLD,LRAFLDS)
End DoDot:2
End DoDot:1
+24 NEW MONLIST
SET FILENUM=60
DO GMONLIST(FILENUM,.MONLIST)
+25 SET XFILENUM=""
SET XNEW=1
+26 FOR
SET XFILENUM=$ORDER(MONLIST(XFILENUM))
if XFILENUM=""
QUIT
Begin DoDot:1
+27 SET LRALINE=MONLIST(XFILENUM)
+28 FOR LRJ=1:1
SET LRAFLDS=$PIECE(LRALINE,";",LRJ)
if LRAFLDS=""
QUIT
Begin DoDot:2
+29 IF XFILENUM=FILENUM
IF LRJ=1
QUIT
+30 DO AUDCHK2(XFILENUM,"",LRAFLDS)
End DoDot:2
End DoDot:1
+31 QUIT LRAUDIT
+32 ;
AUDCHK2(XFILENUM,XFLDSUB,LRAFLDS) ;
+1 ; XFILENUM (input) - file or subfile # if known
+2 ; XFLDSUB (input/opt) - If a subfield and subfile not in XFILENUM, this is the field # for the subfile
+3 NEW X
+4 ; assume audit is ON for ONLY this field.
SET FLDAUDIT=1
+5 ; If present, field is within a subfile XFLDSUB of XFILENUM
IF XFLDSUB
Begin DoDot:1
+6 NEW OUT
+7 SET OUT=+$$GFLDSB(XFILENUM,XFLDSUB)
+8 IF OUT
SET XFILENUM=OUT
End DoDot:1
+9 IF '$$ISAUDON(XFILENUM,LRAFLDS)
SET LRAUDIT=0
SET FLDAUDIT=0
+10 IF (DISPLAY=1)!((DISPLAY=-1)&(FLDAUDIT=0))
Begin DoDot:1
+11 ; if the header is not already displayed, display it.
IF 'HDRDISP
Begin DoDot:2
+12 SET FLDTITL="Field"_$JUSTIFY("",15)_"File Name"_$JUSTIFY("",11)_"Field Name"_$JUSTIFY("",15)_"Audit"_$JUSTIFY("",14)
+13 IF DISPLAY=1
Begin DoDot:3
+14 SET VALMHDR(1)=$JUSTIFY("",26)_"List of Audited Fields"
+15 SET VALMHDR(2)=" Asterisk (*) beside field name denotes required field for audit"
+16 DO CHGCAP^VALM("HEADER",FLDTITL)
End DoDot:3
+17 IF DISPLAY=-1
Begin DoDot:3
+18 DO ADD^LRJSAU(.VALMCNT," "_FLDTITL)
+19 SET X=" "
SET $PIECE(X,"-",73)=""
+20 DO ADD^LRJSAU(.VALMCNT,X)
End DoDot:3
+21 ; flag the header as displayed
SET HDRDISP=1
+22 QUIT
End DoDot:2
+23 SET X=" "_60_"."_$SELECT(XFILENUM=60&($EXTRACT(LRAFLDS)="."):$PIECE(LRAFLDS,".",2),XFILENUM=60:LRAFLDS,1:XFILENUM)
+24 IF XFILENUM'=60
SET X=X_$SELECT($EXTRACT(LRAFLDS)'=".":".",1:"")_LRAFLDS
+25 SET X=$EXTRACT(X_SPACE,1,17)
+26 SET X=X_$EXTRACT($$GFILENM(XFILENUM)_SPACE,1,19)_" "
+27 SET X=X_$EXTRACT($$GFLDNM(XFILENUM,LRAFLDS)_$SELECT('$GET(XNEW):"*",1:" ")_SPACE,1,27)
+28 SET XAUD=$$GET1^DID(XFILENUM,LRAFLDS,"","AUDIT")
+29 SET X=X_" "_$SELECT(XAUD]"":XAUD,1:"** NOT AUDITED **")
+30 DO ADD^LRJSAU(.VALMCNT,X)
End DoDot:1
+31 QUIT
+32 ;
ISAUDON(FILENUM,FLDNUM) ; -- is audit on for the given file/field number
+1 QUIT ($$GET1^DID(FILENUM,FLDNUM,"","AUDIT")["YES, ALWAYS")
+2 ;
GFLDSB(FILENUM,FLDNUM) ;if field is multiple, return subfile #
+1 NEW LRX
+2 DO FIELD^DID(FILENUM,FLDNUM,"","SPECIFIER","LRX")
+3 QUIT +$GET(LRX("SPECIFIER"))
+4 ;
GFILENM(FILENUM) ; -- get the file/subfile name for given file ien
+1 NEW LRX,LRE
+2 ; Not a subfile
IF $DATA(^DIC(FILENUM,0))
Begin DoDot:1
+3 SET LRX=$$GET1^DID(FILENUM,"","","NAME","LRX","LRE")
End DoDot:1
+4 ; subfile
IF '$TEST
Begin DoDot:1
+5 SET LRX=$ORDER(^DD(FILENUM,0,"NM",""))
End DoDot:1
+6 QUIT $GET(LRX)
+7 ;
GFLDNM(FILENUM,FLDNUM) ; -- get the field name for given file/sub-file ien and field number
+1 NEW OUT
+2 DO FIELD^DID(FILENUM,FLDNUM,"","LABEL","OUT")
+3 QUIT $GET(OUT("LABEL"))
+4 ;
GMONLIST(FILENUM,MONLIST) ; return the list of fields to be monitored from configuration file.
+1 NEW ARR,IEN,FLDNUM,FLDLIST,NODE,VAR,XFILENUM
+2 SET IEN=$ORDER(^LABAUD(64.9178,"B",FILENUM,0))
+3 DO GETS^DIQ(64.9178,IEN_",","**","","ARR")
+4 SET VAR="ARR"
+5 SET MONLIST=""
+6 SET NODE=$NAME(@VAR@(64.9178))
+7 FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,3)'=.01
QUIT
Begin DoDot:1
+8 SET FLDNUM=$PIECE(@NODE,"^",1)
+9 SET XFILENUM=$SELECT(FLDNUM'[",":60,1:$PIECE(FLDNUM,","))
+10 SET MONLIST(XFILENUM)=$SELECT($DATA(MONLIST(XFILENUM)):MONLIST(XFILENUM)_";",1:"")_$SELECT(FLDNUM'[",":FLDNUM,1:$PIECE(FLDNUM,",",2))
End DoDot:1
+11 QUIT
+12 ;
+13 ; if '^' out of prompts, allow exit/added parameter
FILENUM(LROUT) ;
+1 KILL DIR
+2 SET LROUT=0
+3 SET FILENUM=60
+4 DO GIENLIST(FILENUM,.IENLIST)
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET LROUT=1
QUIT
+6 IF '$DATA(IENLIST)
WRITE !," ALL TESTS"
+7 ;Select FROM DATE
+8 SET LRFRDT=$$DATEENT("Select Start date: ",,"-NOW")
+9 IF LRFRDT<1
if $DATA(DTOUT)!$DATA(DUOUT)
SET LROUT=1
QUIT
+10 SET LRTODT=$$DATEENT(" Select End date: ",LRFRDT,"-NOW")
+11 IF $DATA(DTOUT)!$DATA(DUOUT)
SET LROUT=1
QUIT
+12 IF +LRTODT<1
if $DATA(DTOUT)!$DATA(DUOUT)
SET LROUT=1
QUIT
+13 DO MSG2
+14 QUIT
+15 ;
GIENLIST(FILENUM,IENLIST) ; get list of entries (ien) For a given file into IENLIST array.
+1 NEW DIC,X,Y,U
+2 KILL IENLIST
+3 SET DIC("0")="AEQM"
+4 SET DIC=FILENUM
+5 SET Y=-1
+6 FOR
Begin DoDot:1
+7 DO ^DIC
+8 if +Y'=-1
SET IENLIST(+Y)=""
End DoDot:1
if +Y=-1
QUIT
+9 QUIT
+10 ;
DATEENT(LRPRMPT,LRBD,LRED) ;Prompt for extract date
+1 ;INPUT
+2 ; LRPRMPT - Prompt displayed to user
+3 ; LRBD - Begin date of range
+4 ; LRED - End date of range
+5 ;
+6 ;RETURN
+7 ; LRDT
+8 ; SUCCESS: FILEMAN INTERNALLY FORMATED DATE
+9 ; FAILURE: -1
+10 ;
+11 NEW LRDT,LRGOOD,X,Y
+12 SET LRGOOD=0
+13 if +$GET(LRED)>0
SET %DT(0)=LRED
+14 if $GET(LRED)["NOW"
SET %DT(0)=LRED
+15 SET %DT("A")=LRPRMPT
+16 ;Default for [Start] date entry
SET %DT("B")="TODAY"
+17 SET %DT="AEPST"
+18 ;Prompt for Start date
if LRPRMPT["Start"
DO ^%DT
+19 ;
+20 ;Prompt for End date with conditions
+21 IF LRPRMPT["End"
Begin DoDot:1
+22 FOR
if LRGOOD
QUIT
Begin DoDot:2
+23 ;Change default for End Date entry
SET %DT("B")="NOW"
+24 DO ^%DT
+25 if ((Y<LRBD)&(X'="^")&('$DATA(DTOUT)))
WRITE " ??",!," End date must follow Begin date!",!
+26 if ((Y>LRBD)!(Y=LRBD)!($DATA(DTOUT))!(X="^"))
SET LRGOOD=1
End DoDot:2
End DoDot:1
+27 SET LRDT=Y
+28 KILL Y,%DT
+29 QUIT LRDT
+30 ;
MSG2 ; -- set default message
+1 NEW LREND,LRBEGIN,LRAUTMSG
+2 SET LRBEGIN=$$GET^XPAR("SYS","LRJ LSRP AUF60 LAST START DATE",1,"Q")
+3 SET LREND=$$GET^XPAR("SYS","LRJ LSRP AUF60 LAST END DATE",1,"Q")
+4 IF (LRBEGIN'="")!(LREND'="")
Begin DoDot:1
+5 SET LRAUTMSG="Last Task Rpt "_$SELECT(LRBEGIN'="":$$FMTE^XLFDT(LRBEGIN),1:"undeed")_" - "_$SELECT(LREND'="":$$FMTE^XLFDT(LREND),1:"undefined")
End DoDot:1
+6 IF LRBEGIN=""
IF LREND=""
Begin DoDot:1
+7 SET LRAUTMSG="Tasked Report has not run!"
End DoDot:1
+8 SET VALMSG=LRAUTMSG
+9 QUIT
+10 ;
GIOP(DEVICE) ; -- return the device if exist and it is not FORCED to queue, otherwise return ""
+1 NEW POP
+2 SET IOP=DEVICE
+3 ; so the ^%ZIS call does not open the device.
SET %ZIS="N"
+4 ; return the characteristics of the device.
DO ^%ZIS
+5 ; does the device exist?
IF POP=1
Begin DoDot:1
+6 SET DEVICE=""
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 ; is the queuing forced forced for this device?
+9 IF $PIECE(^%ZIS(1,IOS,0),"^",12)=1
SET DEVICE=""
End DoDot:1
+10 ;
+11 ; restore the device variables
DO ^%ZISC
+12 QUIT DEVICE
+13 ;
SETTMP(D0,LRIEN,LRDT,LRUSER,LRFLDNM,LRFNUM,LROLD,LRNEW) ;
+1 ; ^TMP("LRDATA",$J,OLD/NEW determination,test ien,data element)=data element value
+2 ; test is not one of those selected
IF $DATA(IENLIST)
IF '$DATA(IENLIST(+LRIEN))
QUIT
+3 NEW Q
+4 FOR Q="LRIEN","LRDT","LRUSER","LRFLDNM","LRFNUM","LROLD","LRNEW"
SET ^TMP("LRDATA",$JOB,D0,Q)=@Q
+5 ;determine if new test was entered
+6 IF LRFLDNM="NAME"
IF LROLD["<no previous"
IF LRIEN=+LRIEN
SET ^TMP("LRDATA",$JOB,"NEW",LRIEN,D0)=LRDT
QUIT
+7 IF $DATA(^TMP("LRDATA",$JOB,"NEW",+LRIEN))
Begin DoDot:1
+8 ;Check for within 2 hr window
+9 NEW DIFF,X1,X2
+10 SET X1=+$ORDER(^TMP("LRDATA",$JOB,"NEW",+LRIEN,0))
SET X1=$GET(^TMP("LRDATA",$JOB,"NEW",+LRIEN,X1))
+11 SET X2=LRDT
+12 ; find difference in seconds (2 hrs = 7200 secs)
SET DIFF=$$FMDIFF^XLFDT(X2,X1,2)
+13 IF DIFF'>7200
SET ^TMP("LRDATA",$JOB,"NEW",+LRIEN,D0)=""
End DoDot:1
+14 QUIT
+15 ;
