- 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 Feb 18, 2025@23:41:29 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 ;