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

LRDIDLE0.m

Go to the documentation of this file. 
  1. LRDIDLE0 ;VA/DALOI/JMC - Create audit trail of changed values ; 13-Oct-2017 14:04 ;  MKK
  1.  ;;5.2;LAB SERVICE;**1004,140,171,153,1018,286,1027,396,1033,1041**;NOV 01, 1997;Build 23
  1.  ;
  1.  ; Called by LRVER3
  1.  ;
  1. INIT ;
  1.  ; This code controls the automatic audit trail entries for CH subscripted
  1.  ; tests which are reported and subsequently changed. Modification of this
  1.  ; code by local stations may have Medical/Legal ramifications. Local
  1.  ; stations are STRONGLY advised to NOT make changes.
  1.  ;
  1.  N LRCHDT7,LRI,LRJ,LRNEW,LROLD,LRSQ9,LRTXT,LRUSER
  1.  ;
  1.  S LRJ=0,LROK=1,LRCHDT7=$$FMTE^XLFDT(LRNOW7,"MZ"),LRUSER=$$USERID(.DUZ)
  1.  ;
  1. EVAL ; EP
  1.  ;
  1.  ; Result changed
  1.  I $P($G(LRSA(LRSB,2)),"^") D
  1.  . S LRNEW=$P(LRSB(LRSB),"^") S:LRNEW="" LRNEW="<no value>" ; new value
  1.  . S LROLD=$P(LRSA(LRSB),"^") S:LROLD="" LROLD="<no value>" ; old value
  1.  . S LRSQ9=LROLD_" by ["_$$USERID($P(LRSA(LRSB),"^",4))_"]" ; old result
  1.  . S LRJ=LRJ+1,LRTXT(LRJ)=LRSA(LRSB,1)_" reported incorrectly as "_LRSQ9_"."
  1.  . S LRJ=LRJ+1,LRTXT(LRJ)="Changed to "_LRNEW_" on "_LRCHDT7_" by ["_LRUSER_"]."
  1.  ;
  1.  ; Normalcy flag changed
  1.  I $P($G(LRSA(LRSB,2)),"^",2) D
  1.  . S LRNEW=$P(LRSB(LRSB),"^",2) S:LRNEW="" LRNEW="normal" D  ; new value
  1.  . . I $P(LRSB(LRSB),"^")="canc"!($P(LRSB(LRSB),"^")="CANC") S LRNEW="canc"
  1.  . S LROLD=$P(LRSA(LRSB),"^",2) S:LROLD="" LROLD="normal" ; old value
  1.  . S LRSQ9=LROLD_" by ["_$$USERID($P(LRSA(LRSB),"^",4))_"]" ; old result
  1.  . S LRJ=LRJ+1,LRTXT(LRJ)=LRSA(LRSB,1)_" flagged incorrectly as "_LRSQ9_"."
  1.  . S LRJ=LRJ+1 D
  1.  . . I LRNEW="canc" S LRTXT(LRJ)="Abnormal flag removed on "_LRCHDT7_" by ["_LRUSER_"]." Q
  1.  . . S LRTXT(LRJ)="Changed to "_LRNEW_" on "_LRCHDT7_" by ["_LRUSER_"]."
  1.  ;
  1.  ; Check normal ranges
  1.  I $P($G(LRSA(LRSB,2)),"^",5) D
  1.  . N LRI,LRX,LRY,LRZ
  1.  . S LRX=$P(LRSB(LRSB),"^",5),LRY=$P(LRSA(LRSB),"^",5)
  1.  . ; Units changed
  1.  . I $P(LRX,"!",7)'=$P(LRY,"!",7) D
  1.  . . S LRNEW=$P(LRX,"!",7) S:LRNEW="" LRNEW="<no value>" ; new value
  1.  . . S LROLD=$P(LRY,"!",7) S:LROLD="" LROLD="<no value>" ; old value
  1.  . . S LRSQ9=LROLD_" by ["_$$USERID($P(LRSA(LRSB),"^",4))_"]" ; old value
  1.  . . S LRJ=LRJ+1,LRTXT(LRJ)=LRSA(LRSB,1)_" units reported incorrectly as "_LRSQ9_"."
  1.  . . S LRJ=LRJ+1,LRTXT(LRJ)="Changed to "_LRNEW_" on "_LRCHDT7_" by ["_LRUSER_"]."
  1.  . ; Reference ranges changed
  1.  . S LRZ(0)="^reference low^reference high^critical low^critical high^^^^^^therapeutic low^therapeutic high^"
  1.  . F LRI=2,3,4,5,11,12 I $P(LRX,"!",LRI)'=$P(LRY,"!",LRI) D
  1.  . . S LRNEW=$P(LRX,"!",LRI) S:LRNEW="" LRNEW="<no value>" ; new value
  1.  . . S LROLD=$P(LRY,"!",LRI) S:LROLD="" LROLD="<no value>" ; old value
  1.  . . S LRZ=$P(LRZ(0),"^",LRI)
  1.  . . S LRSQ9=LROLD_" by ["_$$USERID($P(LRSA(LRSB),"^",4))_"]" ; old value
  1.  . . S LRJ=LRJ+1,LRTXT(LRJ)=LRSA(LRSB,1)_" "_LRZ_" reported incorrectly as "_LRSQ9_"."
  1.  . . S LRJ=LRJ+1,LRTXT(LRJ)="Changed to "_LRNEW_" on "_LRCHDT7_" by ["_LRUSER_"]."
  1.  ;
  1.  I LRJ D STORE
  1.  Q
  1.  ;
  1.  ;
  1. STORE ; Store comments in file #63, field #99 COMMENTS
  1.  ;
  1.  N DIWF,DIWL,DIWR,LRI,LRJ,LRK,LRX,X
  1.  ;
  1.  ; Check comment lengths and if greater than 68 break line
  1.  S LRI=0
  1.  F  S LRI=$O(LRTXT(LRI)) Q:'LRI  D
  1.  . I $L(LRTXT(LRI))<69 Q
  1.  . S X=LRTXT(LRI),DIWL=1,DIWR=68,DIWF="",LRJ=0
  1.  . K ^UTILITY($J,"W"),LRTXT(LRI)
  1.  . D ^DIWP
  1.  . F  S LRJ=$O(^UTILITY($J,"W",DIWL,LRJ)) Q:'LRJ  D
  1.  . . S LRK=LRI+(LRJ/100),LRTXT(LRK)=^UTILITY($J,"W",DIWL,LRJ,0)
  1.  . . I $L(LRTXT(LRK))<68 Q
  1.  . . F J=69:68:$L(LRTXT(LRK)) S LRTXT(LRK+(J/10000))=$E(LRTXT(LRK),J,J+68)
  1.  . . S LRTXT(LRK)=$E(LRTXT(LRK),1,68)
  1.  . K ^UTILITY($J,"W")
  1.  ;
  1.  S LRI=0
  1.  F  S LRI=$O(LRTXT(LRI)) Q:'LRI  D
  1.  . S LRX=LRTXT(LRI)
  1.  . D FILECOM^LRVR4(LRDFN,LRIDT,LRX)
  1.  . W !,LRX
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  ; Check the parameter.  If not YES, then don't do anything.
  1.  Q:$$GET^XPAR("PKG","BLR LAB RESULTS CHANGED NOTIFY",1,"Q")'=1
  1.  ;
  1.  NEW CHNGRI,CHNGRN
  1.  S LRI=$O(LRTXT("A"),-1)
  1.  S CHNGRI=+$P($P($G(LRTXT(LRI)),"[",2),"]")
  1.  S CHNGRN=$$GET1^DIQ(200,CHNGRI,.01)
  1.  S:CHNGRN="" CHNGRN="<UNKNOWN>"
  1.  S LRI=LRI+1
  1.  S LRTXT(LRI)=" ",LRI=LRI+1
  1.  S LRTXT(LRI)="Patient:"_$G(VADM(1)),LRI=LRI+1
  1.  S LRTXT(LRI)="     Accession:"_$G(LRACC),LRI=LRI+1
  1.  S LRTXT(LRI)="           UID:"_$G(LRUID),LRI=LRI+1
  1.  S LRTXT(LRI)=" ",LRI=LRI+1
  1.  S LRTXT(LRI)="     Results Changed by:"_CHNGRN_" ["_CHNGRI_"]"
  1.  D SENDMAIL^BLRUTIL8("Accession "_LRACC_" Lab Results Changed",.LRTXT,"LRDIDLE0","NO","G.LAB RESULTS CHANGED")
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. USERID(LRDUZ) ;  Create user id for comment text
  1.  ;
  1.  ; Call with DUZ array by reference
  1.  ;
  1.  ; Returns   LRY = formatted user id (DUZ-VAxxx) where xxx = VA station #
  1.  ;
  1.  N LRY
  1.  S LRY=LRDUZ
  1.  ; If agency or facility not passed assumed agency/facility of current user
  1.  I $G(LRDUZ("AG"))="" S LRDUZ("AG")=DUZ("AG")
  1.  I '$G(LRDUZ(2)) S LRDUZ(2)=DUZ(2)
  1.  ;
  1.  I LRDUZ("AG")="V" S LRY=LRY_"-VA"_$$GET1^DIQ(4,LRDUZ(2)_",",99)
  1.  Q LRY