LRWU9 ;DALOI/CKA - TOOL TO DETECT, FIX, AND REPORT BAD DATA NAMES ; 15 Apr 2019 2:27 PM
;;5.2;LAB SERVICE;**350,427,519**;Sep 27, 1994;Build 16
;
;Reference to ^PXRMINDX supported by ICR# 4290
;Reference to ^DD(63.04 supported by DBIA #7053
;
EN ; Interactive entry point.
;
D DT^DICRW
N INSTALL,LRFIX,LRNUM,LRSITE,LRSPACE,LRSUPFLG,XMDUZ,XMY
;
D INIT
S LRFIX=$$ASK(),XMY(DUZ)="",XMDUZ=DUZ,INSTALL=0
S $P(LRSPACE," ",80)=""
I 'LRFIX Q
S LRFIX=LRFIX-1
D DES^XMA21 ; call to get the email recipients list.
D PREP^XGF ; setup screen
D CHKDD
D CHK63
D SENDMM,CLEAN^XGF
K ^TMP("LR",$J)
;
Q
;-------------------------------------------------------
KIDS ; Entry point for post install run.
;
N INSTALL,LRFIX,LRNUM,LRSITE,LRSUPFLG,XMY
;
I $G(^XMB("NETNAME"))["DOMAIN.EXT",$$PROD^XUPROD() S XMY("G.LAB DEV IRMFO@DOMAIN.EXT")="",XMY("G.CSCLIN4@DOMAIN.EXT")=""
S XMY(DUZ)="",XMY("G.LMI")="",INSTALL=1
D INIT
;S LRFIX=1 ; [ccr-8167] - LRFIX is set to 0 in INIT subroutine.
D CHKDD,CHK63,SENDMM
;
K ^TMP("LR",$J)
;
Q
;-------------------------------------------------------
LRNIGHT ; Entry point for ^LRNIGHT run.
;
N INSTALL,LRFIX,LRNUM,LRSITE,LRSUPFLG,XMY
;
S INSTALL=1
D INIT,CHKDD,CHK63
S (XMY(DUZ),XMY("G.LMI"))=""
I $G(^XMB("NETNAME"))["DOMAIN.EXT",$$PROD^XUPROD() S XMY("G.LAB DEV IRMFO@DOMAIN.EXT")="",XMY("G.CSCLIN4@DOMAIN.EXT")=""
I $O(^TMP("LR",$J,"DD63.04",5))]"" D SENDMM
;
K ^TMP("LR",$J),^TMP("DD63.04B",$J)
;
Q
;-------------------------------------------------------
INIT ; Initialize variables.
;
K ^TMP("LR",$J)
D DT^DICRW
S LRSITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
S LRFIX=0
;
Q
;-------------------------------------------------------
CHKDD ; CHECK DD FOR BAD DATA NAMES.
;First check for DDs with the same subscript
N CNT,DA,DIK,LR60CNT,LR60IEN,LRLOC,LRDATA,LRD0,LRPC,LRSUB,LRX,LRDD,LRDDA,LRNOTEST,LRNOFIX,LRSUBCNT
K ^TMP("LR",$J),^TMP("LR63.04B",$J)
S LRNUM=1
;
S ^TMP("LR",$J,"DD63.04",LRNUM)=$$NAME^XUAF4($$KSP^XUPARAM("INST"))_" ("_$$KSP^XUPARAM("WHERE")_") "_$$FMTE^XLFDT(DT)
S LRNUM=LRNUM+1
S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
;
S LRD0=1,LRDD=0,LRDDA=0
F CNT=0:1 S LRD0=$O(^DD(63.04,LRD0)) Q:LRD0="" D:$D(^DD(63.04,LRD0,0))
. S LRDATA=$G(^DD(63.04,LRD0,0)) Q:LRDATA=""
. S LRSUB=$P($P(LRDATA,U,4),";")
. S LRPC=$P($P(LRDATA,U,4),";",2)
. S LR60IEN="",LR60CNT=0
. S LRX=0 F S LRX=$O(^LAB(60,"C","CH;"_LRSUB_";"_LRPC,LRX)) Q:'LRX D
. . I $P($G(^LAB(60,LRX,.2)),U,1)=LRD0 D
. . . S LR60IEN=LRX
. . . S ^TMP("LR",$J,"SORT","LD",LRD0,LR60IEN)=""
. . . S LR60CNT=LR60CNT+1
. S LRSUBCNT=$G(^TMP("LR",$J,"SORT",1,LRSUB))+1
. S ^TMP("LR",$J,"SORT",1,LRSUB)=LRSUBCNT
. S ^TMP("LR",$J,"SORT",1,LRSUB,LRD0)=$P(LRDATA,U,1)_U_$P(LRDATA,U,4)_U_LR60IEN
. I 'LR60IEN S ^TMP("LR",$J,"SORT","L",LRSUB,LRD0)=LRSUB ; L subscript used when Data name is not linked to a test
. I LRPC'=1!(LRSUB'=LRD0) S ^TMP("LR",$J,"SORT","C",LRD0)=LRSUB ; C subscript used when Data name has wrong subscript location
. I LRSUBCNT>1 S ^TMP("LR",$J,"SORT","D",LRSUB)="" ; D subscript used when more than one Data name has the same subscript
. I LR60CNT=1 K ^TMP("LR",$J,"SORT","LD",LRD0) ; LD subscript used when there are multiple tests linked to a data name
;
; Report issues with duplicate subscript locations
S LRSUB="" F S LRSUB=$O(^TMP("LR",$J,"SORT","D",LRSUB)) Q:LRSUB="" D
. S LRSUPFLG=1
. S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
. S ^TMP("LR",$J,"DD63.04",LRNUM)="*WARNING* THE FOLLOWING DATA NAMES ARE ASSIGNED THE SAME SUBSCRIPT #"_LRSUB,LRNUM=LRNUM+1
. S LRD0=0 F S LRD0=$O(^TMP("LR",$J,"SORT",1,LRSUB,LRD0)) Q:LRD0="" D
. . S LRDATA=$G(^TMP("LR",$J,"SORT",1,LRSUB,LRD0))
. . S ^TMP("LR",$J,"DD63.04",LRNUM)=" - Data Name '"_$P(LRDATA,U,1)_"' (#"_LRD0_") is assigned location: "_$P(LRDATA,U,2),LRNUM=LRNUM+1
. . I $P(LRDATA,U,3) D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)=" (This Data Name is linked to Lab test #"_$P(LRDATA,U,3)_" "_$P(^LAB(60,$P(LRDATA,U,3),0),U)_")",LRNUM=LRNUM+1
. . I '$P(LRDATA,U,3) D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)=" (This Data Name is not linked to a Lab test)",LRNUM=LRNUM+1
;
; Report issues with multiple tests with the same data name
S LRD0=0 F S LRD0=$O(^TMP("LR",$J,"SORT","LD",LRD0)) Q:'LRD0 D
. S LRSUPFLG=1
. S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
. S ^TMP("LR",$J,"DD63.04",LRNUM)="*WARNING* THE DATA NAME '"_$P(^DD(63.04,LRD0,0),U)_"' (#"_LRD0_") IS LINKED TO MORE THAN ONE LAB TEST:",LRNUM=LRNUM+1
. N LRCNT
. S LR60IEN=0 F S LR60IEN=$O(^TMP("LR",$J,"SORT","LD",LRD0,LR60IEN)) Q:'LR60IEN D
. . S LRCNT=$G(LRCNT)+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)=" "_LRCNT_". "_$P($G(^LAB(60,LR60IEN,0)),U,1)_" (#"_LR60IEN_")"
. . S LRNUM=LRNUM+1
;
;Check - SUBSCRIPT'=FIELD #
; NOT IN FIRST PIECE
; OR BOTH
;
;
I 'INSTALL D SAY^XGF(24,1,LRSPACE),SAY^XGF(24,1,"LRD0=")
S LRD0=1
F CNT=0:1 S LRD0=$O(^TMP("LR",$J,"SORT","C",LRD0)) Q:LRD0="" D
. S LRDATA=$G(^DD(63.04,LRD0,0)) Q:LRDATA=""
. S LRSUB=$P($P(LRDATA,U,4),";")
. S LRPC=$P($P(LRDATA,U,4),";",2)
. I $D(^TMP("LR",$J,"SORT","D",LRSUB)) Q
. S LR60IEN=$P($G(^TMP("LR",$J,"SORT",1,LRSUB,LRD0)),U,3)
. I 'INSTALL,'(CNT#100) D SAY^XGF(24,1,"LRD0="_LRD0)
. I LRPC'=1!(LRSUB'=LRD0) D
. . S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="Data Name Location "_$P(^DD(63.04,LRD0,0),U)_" CH;"_LRSUB_";"_LRPC_" should be CH;"_LRD0_";1"
. . I LRFIX,LR60IEN,'$D(^TMP("LR",$J,"SORT","LD",LRD0)) D FIXDD D
. . . S ^(LRNUM)=^TMP("LR",$J,"DD63.04",LRNUM)_" ***FIXED***"
. . I LRFIX,('LR60IEN!($D(^TMP("LR",$J,"SORT","LD",LRD0)))) D
. . . S ^(LRNUM)=^TMP("LR",$J,"DD63.04",LRNUM)_" ***NOT FIXED***"
. . . S LRSUPFLG=1
. . S LRNUM=LRNUM+1
. . I LR60IEN,$G(^TMP("LR",$J,"DDFIXED",LRSUB)) D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)="Lab test # "_LR60IEN_" "_$P(^LAB(60,LR60IEN,0),U)_" DATA NAME (LOCATION) SUBSCRIPT **** FIXED ****"
. . . S LRNUM=LRNUM+1
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)=" OLD SUBSCRIPT="_LRSUB_" NEW SUBSCRIPT="_LRD0
. . . S LRNUM=LRNUM+1
. . I 'LR60IEN D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)="Data Name is not linked to a File #60 Laboratory Test"
. . . I LRFIX S ^(LRNUM)=^TMP("LR",$J,"DD63.04",LRNUM)_" ***NOT FIXED***",LRSUPFLG=1
. . . S LRNUM=LRNUM+1
. . I $D(^TMP("LR",$J,"SORT","LD",LRD0)) D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)="Data Name is linked to more than one File #60 Laboratory Test"
. . . I LRFIX S ^(LRNUM)=^TMP("LR",$J,"DD63.04",LRNUM)_" ***NOT FIXED***",LRSUPFLG=1
. . . S LRNUM=LRNUM+1
;
;Check "B" cross reference - LR*5.2*519
D B6304^LRWU9A
Q
;-------------------------------------------------------
CHK63 ;CHECK FILE 63 FOR TEST DATA WITH NO DATA NAME
;
N CNT,DATANUM,LRDFN,LRIDT,LRD0,LRNUM1,LRNUM2
I 'INSTALL D SAY^XGF(24,1,LRSPACE),SAY^XGF(24,1,"LRDFN=")
S (LRDFN,LRIDT,LRD0)=0
S LRNUM1=1,LRNUM2=1
F CNT=0:1 S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN D
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:'LRIDT D
. . N LRREPAIR
. . S LRD0=1
. . F S LRD0=$O(^LR(LRDFN,"CH",LRIDT,LRD0)) Q:LRD0'>0 D
. . . I $D(LRREPAIR(LRD0)) Q ;Used to prevent issues when two Data Names use each others subscripts
. . . I 'INSTALL,'(CNT#100) D SAY^XGF(24,1,"LRDFN="_LRDFN)
. . . I '$D(^DD(63.04,LRD0,0)),'$D(^TMP("LR",$J,"SORT",1,LRD0)) D
. . . . S ^TMP("LR",$J,"SORT","W",LRD0,LRNUM2)="^LR("_LRDFN_",""CH"","_LRIDT_","_LRD0_")"
. . . . S LRNUM2=LRNUM2+1
. . . ; Check if there are results that belong to a Data Name that is not linked to a test.
. . . S DATANUM=$O(^TMP("LR",$J,"SORT","L",LRD0,0))
. . . I DATANUM,'$D(^TMP("LR",$J,"SORT","D",LRD0)) D
. . . . ;SORT BY DATA NAME
. . . . S ^TMP("LR",$J,"SORT","T",DATANUM,LRNUM1)="^LR("_LRDFN_",""CH"","_LRIDT_","_LRD0_")"
. . . . S LRNUM1=LRNUM1+1
. . . I LRFIX D FIX63
S LRNUM2=0,DATANUM=0
I $D(^TMP("LR",$J,"SORT","W")) D
. F S DATANUM=$O(^TMP("LR",$J,"SORT","W",DATANUM)) Q:DATANUM'>0 D
. . S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="Results in subscript '"_DATANUM_"' without a Data Name at: "
. . S LRNUM=LRNUM+1
. . F S LRNUM2=$O(^TMP("LR",$J,"SORT","W",DATANUM,LRNUM2)) Q:LRNUM2'>0 D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)=" "_^TMP("LR",$J,"SORT","W",DATANUM,LRNUM2)
. . . S LRNUM=LRNUM+1
. . . S LRSUPFLG=1
S LRNUM1=0,DATANUM=0
I $D(^TMP("LR",$J,"SORT","T")) D
. F S DATANUM=$O(^TMP("LR",$J,"SORT","T",DATANUM)) Q:DATANUM'>0 D
. . S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="Results in Data Name "_$P(^DD(63.04,DATANUM,0),U,1)_" without a test in file 60 at: "
. . S LRNUM=LRNUM+1
. . F S LRNUM1=$O(^TMP("LR",$J,"SORT","T",DATANUM,LRNUM1)) Q:LRNUM1'>0 D
. . . S ^TMP("LR",$J,"DD63.04",LRNUM)=" "_^TMP("LR",$J,"SORT","T",DATANUM,LRNUM1)
. . . S LRNUM=LRNUM+1
. . . S LRSUPFLG=1
;
Q
;-------------------------------------------------------
FIXDD ; FIX DD FOR BAD DATA NAMES.
;
N DDFIELD,LRNAME,LRTYPE
;
D FIELD^DID(63.04,LRD0,"","LABEL;TYPE","DDFIELD")
S LRNAME=DDFIELD("LABEL")
S LRTYPE=DDFIELD("TYPE")
S DA=LRD0
D DDFIX^LRWU6
I LR60IEN D
. I $P(^LAB(60,LR60IEN,0),U,5)'="CH;"_LRD0_";1"!($P(^LAB(60,LR60IEN,0),U,12)'="DD(63.04,"_LRD0_",")!(^LAB(60,LR60IEN,.2)'=LRD0) D
. . N LRFDA,LRDIE
. . S LRFDA(1,60,LR60IEN_",",400)=LRD0
. . S LRFDA(1,60,LR60IEN_",",5)="CH;"_LRD0_";1"
. . S LRFDA(1,60,LR60IEN_",",13)="DD(63.04,"_LRD0_","
. . D FILE^DIE("","LRFDA(1)","LRDIE(1)")
. . S ^TMP("LR",$J,"DDFIXED",LRSUB)=LRD0_U_LRPC_U_LR60IEN
UPD624 . . N LR624,LR6243
. . S LR624=0 F S LR624=$O(^LAB(62.4,LR624)) Q:'LR624 D
. . . S LR6243=0 F S LR6243=$O(^LAB(62.4,LR624,3,LR6243)) Q:'LR6243 D
. . . .I $P(^LAB(62.4,LR624,3,LR6243,0),U)=LR60IEN D
. . . . . N LRFDA,LRIENS
. . . . . S LRIENS=LR6243_","_LR624_","
. . . . . S LRFDA(62.41,LRIENS,11)="TV("_LRD0_",1)"
. . . . . D FILE^DIE("","LRFDA")
;
Q
;-------------------------------------------------------
FIX63 ;FIX DATA NODES IN FILE 63
;
Q:$D(^TMP("LR",$J,"SORT","D",LRD0))
Q:'$D(^TMP("LR",$J,"DDFIXED",LRD0))
Q:($P(^TMP("LR",$J,"DDFIXED",LRD0),U,2)'=1)
S LRLOC=$P(^TMP("LR",$J,"DDFIXED",LRD0),U)
I $D(^DD(63.04,LRD0,0))!($D(^TMP("LR",$J,"SORT",1,LRD0))) S ^TMP("LR",$J,"DD63.04",LRNUM)=" ",LRNUM=LRNUM+1
I $D(^LR(LRDFN,"CH",LRIDT,LRLOC)) D Q
. S ^TMP("LR",$J,"DD63.04",LRNUM)="*ERROR* MOVING OVER ^LR("_LRDFN_",CH,"_LRIDT_","_LRD0_") TO ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
. S LRNUM=LRNUM+1
. S ^TMP("LR",$J,"DD63.04",LRNUM)="Data already exists in ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
. S LRNUM=LRNUM+1
. S LRSUPFLG=1
D CHKILLPX(LRDFN,LRIDT,LRD0) ;Kill Clinical Reminders Index
S ^LR(LRDFN,"CH",LRIDT,LRLOC)=^LR(LRDFN,"CH",LRIDT,LRD0)
K ^LR(LRDFN,"CH",LRIDT,LRD0)
S LRREPAIR(LRLOC)=""
D CHSET^LRPX(LRDFN,LRIDT) ;Set Clinical Reminders Index
S ^TMP("LR",$J,"DD63.04",LRNUM)="DATA LOCATION FIXED IN LAB DATA FILE ^LR"
S LRNUM=LRNUM+1
S ^TMP("LR",$J,"DD63.04",LRNUM)="^LR("_LRDFN_",CH,"_LRIDT_","_LRD0_") NOW MOVED TO ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
S LRNUM=LRNUM+1
;
Q
;-------------------------------------------------------
CHKILLPX(LRDFN,LRIDT,LRD0) ;Kill Clinical Reminders Index
N LR60IEN,DFN,DATE,OK,DAS,LRDBLCHK
S LR60IEN=$P(^TMP("LR",$J,"DDFIXED",LRD0),U,3)
I 'LR60IEN D
. N DATA
. S DATA=^LR(LRDFN,"CH",LRIDT,LRD0)
. S LR60IEN=+$P($P(DATA,U,3),"!",7)
I 'LR60IEN Q
I '$L($G(^LR(+$G(LRDFN),"CH",+$G(LRIDT),0))) Q
D PATIENT^LRPX(LRDFN,.DFN,.OK) I 'OK Q
S DATE=9999999-LRIDT
S DAS=LRDFN_";CH;"_LRIDT_";"_LRD0
S LRDBLCHK=0
I '$D(^PXRMINDX(63,"PI",DFN,LR60IEN,DATE,DAS)) S LRDBLCHK=1
D KLAB^LRPX(DFN,DATE,LR60IEN,DAS)
;
I LRDBLCHK D
. N ITEM,FLAG
. S ITEM=0 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:'ITEM!($D(FLAG)) D
. . I $D(^PXRMINDX(63,"PI",DFN,ITEM,DATE,DAS)) D
. . . D KLAB^LRPX(DFN,DATE,ITEM,DAS)
. . . S FLAG=1
Q
;-------------------------------------------------------
SENDMM ;SEND MAIL MESSAGE OF ERRORS FOUND AND/OR FIXED.
;
N XMSUB,DIFROM,XMINSTR
;
S LRNUM=3
I $O(^TMP("LR",$J,"DD63.04",5)) D ;Errors were found
. ;
. I 'LRFIX!(LRFIX&($G(LRSUPFLG))) D ;not all errors were auto-repaired
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="Contact the National Service Desk to request assistance from the Clin 4",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="Product Support team in resolving the following errors identified in the",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="VistA Laboratory package:",LRNUM=LRNUM+1
. ;
. I LRFIX,'$G(LRSUPFLG) D ;all errors were auto-repaired
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="The LAB DATA file (#63) cleanup process has found and repaired the",LRNUM=LRNUM+1
. . S ^TMP("LR",$J,"DD63.04",LRNUM)="following errors:",LRNUM=LRNUM+1
;
I '$O(^TMP("LR",$J,"DD63.04",5)) D ;No errors were found
. S ^TMP("LR",$J,"DD63.04",LRNUM)=""
. S ^TMP("LR",$J,"DD63.04",(LRNUM+1))="*** NO ERRORS FOUND ***"
;
S XMSUB="DATA DICTIONARY ^DD(63.04 CHECK REPORT "
S XMSUB=XMSUB_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
S XMINSTR("ADDR FLAGS")="R"
D SENDMSG^XMXAPI(DUZ,XMSUB,"^TMP(""LR"",$J,""DD63.04"")",.XMY,.XMINSTR)
;
Q
;-------------------------------------------------------
ASK() ; Run analyze/repair query
;
N Y,DIR,DIRUT,DTOUT,DUOUT,FIX
;
S FIX=0
;
W !,"This process will check the CHEM, HEM, TOX, RIA, SER, etc."
W !,"Sub-file (#63.04) of the LAB DATA file (#63) looking for"
W !,"possible discrepancies in the Data Dictionary. Once the"
W !,"process has completed, a MailMan message will be sent to the"
W !,"user that started this process and any other user selected."
W !!
W !,"The two modes in which this process can be run are ANALYZE"
W !,"and REPAIR. If the ANALYZE option is chosen, the process will"
W !,"only look for discrepancies and report the findings via a"
W !,"MailMan message. If the ANALYZE,REPAIR option is chosen the"
W !,"process will ANALYZE and REPAIR any discrepancies found that"
W !,"can be fixed programmatically and list all those that could"
W !,"not be fixed but need attention."
W !!
;
S DIR("A")="Do you want to continue with this process",DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
I 'Y Q FIX
;
K DIR,Y
;
S DIR(0)="NAO^1:3",DIR("B")=3
S DIR("A",1)="Select the action you wish to take:"
S DIR("A",2)=""
S DIR("A",3)="1. Analyze and Report."
S DIR("A",4)="2. Analyze, Repair, and Report."
S DIR("A",5)="3. Quit - No Action."
S DIR("A",6)=""
S DIR("A")="Enter a number 1 thru 3: "
S DIR("?")="Select a number 1 thru 3 or press <Return> to exit"
;
D ^DIR
I Y=1 S FIX=1
I Y=2 S FIX=2
I Y=3!(Y=-1)!('Y) S FIX=0 Q FIX
;
K DIR,Y
S DIR("A")="Are you sure you want to proceed",DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
I 'Y S FIX=0
;
Q FIX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWU9 15164 printed Sep 23, 2025@19:59:03 Page 2
LRWU9 ;DALOI/CKA - TOOL TO DETECT, FIX, AND REPORT BAD DATA NAMES ; 15 Apr 2019 2:27 PM
+1 ;;5.2;LAB SERVICE;**350,427,519**;Sep 27, 1994;Build 16
+2 ;
+3 ;Reference to ^PXRMINDX supported by ICR# 4290
+4 ;Reference to ^DD(63.04 supported by DBIA #7053
+5 ;
EN ; Interactive entry point.
+1 ;
+2 DO DT^DICRW
+3 NEW INSTALL,LRFIX,LRNUM,LRSITE,LRSPACE,LRSUPFLG,XMDUZ,XMY
+4 ;
+5 DO INIT
+6 SET LRFIX=$$ASK()
SET XMY(DUZ)=""
SET XMDUZ=DUZ
SET INSTALL=0
+7 SET $PIECE(LRSPACE," ",80)=""
+8 IF 'LRFIX
QUIT
+9 SET LRFIX=LRFIX-1
+10 ; call to get the email recipients list.
DO DES^XMA21
+11 ; setup screen
DO PREP^XGF
+12 DO CHKDD
+13 DO CHK63
+14 DO SENDMM
DO CLEAN^XGF
+15 KILL ^TMP("LR",$JOB)
+16 ;
+17 QUIT
+18 ;-------------------------------------------------------
KIDS ; Entry point for post install run.
+1 ;
+2 NEW INSTALL,LRFIX,LRNUM,LRSITE,LRSUPFLG,XMY
+3 ;
+4 IF $GET(^XMB("NETNAME"))["DOMAIN.EXT"
IF $$PROD^XUPROD()
SET XMY("G.LAB DEV IRMFO@DOMAIN.EXT")=""
SET XMY("G.CSCLIN4@DOMAIN.EXT")=""
+5 SET XMY(DUZ)=""
SET XMY("G.LMI")=""
SET INSTALL=1
+6 DO INIT
+7 ;S LRFIX=1 ; [ccr-8167] - LRFIX is set to 0 in INIT subroutine.
+8 DO CHKDD
DO CHK63
DO SENDMM
+9 ;
+10 KILL ^TMP("LR",$JOB)
+11 ;
+12 QUIT
+13 ;-------------------------------------------------------
LRNIGHT ; Entry point for ^LRNIGHT run.
+1 ;
+2 NEW INSTALL,LRFIX,LRNUM,LRSITE,LRSUPFLG,XMY
+3 ;
+4 SET INSTALL=1
+5 DO INIT
DO CHKDD
DO CHK63
+6 SET (XMY(DUZ),XMY("G.LMI"))=""
+7 IF $GET(^XMB("NETNAME"))["DOMAIN.EXT"
IF $$PROD^XUPROD()
SET XMY("G.LAB DEV IRMFO@DOMAIN.EXT")=""
SET XMY("G.CSCLIN4@DOMAIN.EXT")=""
+8 IF $ORDER(^TMP("LR",$JOB,"DD63.04",5))]""
DO SENDMM
+9 ;
+10 KILL ^TMP("LR",$JOB),^TMP("DD63.04B",$JOB)
+11 ;
+12 QUIT
+13 ;-------------------------------------------------------
INIT ; Initialize variables.
+1 ;
+2 KILL ^TMP("LR",$JOB)
+3 DO DT^DICRW
+4 SET LRSITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+5 SET LRFIX=0
+6 ;
+7 QUIT
+8 ;-------------------------------------------------------
CHKDD ; CHECK DD FOR BAD DATA NAMES.
+1 ;First check for DDs with the same subscript
+2 NEW CNT,DA,DIK,LR60CNT,LR60IEN,LRLOC,LRDATA,LRD0,LRPC,LRSUB,LRX,LRDD,LRDDA,LRNOTEST,LRNOFIX,LRSUBCNT
+3 KILL ^TMP("LR",$JOB),^TMP("LR63.04B",$JOB)
+4 SET LRNUM=1
+5 ;
+6 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=$$NAME^XUAF4($$KSP^XUPARAM("INST"))_" ("_$$KSP^XUPARAM("WHERE")_") "_$$FMTE^XLFDT(DT)
+7 SET LRNUM=LRNUM+1
+8 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+9 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+10 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+11 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+12 ;
+13 SET LRD0=1
SET LRDD=0
SET LRDDA=0
+14 FOR CNT=0:1
SET LRD0=$ORDER(^DD(63.04,LRD0))
if LRD0=""
QUIT
if $DATA(^DD(63.04,LRD0,0))
Begin DoDot:1
+15 SET LRDATA=$GET(^DD(63.04,LRD0,0))
if LRDATA=""
QUIT
+16 SET LRSUB=$PIECE($PIECE(LRDATA,U,4),";")
+17 SET LRPC=$PIECE($PIECE(LRDATA,U,4),";",2)
+18 SET LR60IEN=""
SET LR60CNT=0
+19 SET LRX=0
FOR
SET LRX=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_LRPC,LRX))
if 'LRX
QUIT
Begin DoDot:2
+20 IF $PIECE($GET(^LAB(60,LRX,.2)),U,1)=LRD0
Begin DoDot:3
+21 SET LR60IEN=LRX
+22 SET ^TMP("LR",$JOB,"SORT","LD",LRD0,LR60IEN)=""
+23 SET LR60CNT=LR60CNT+1
End DoDot:3
End DoDot:2
+24 SET LRSUBCNT=$GET(^TMP("LR",$JOB,"SORT",1,LRSUB))+1
+25 SET ^TMP("LR",$JOB,"SORT",1,LRSUB)=LRSUBCNT
+26 SET ^TMP("LR",$JOB,"SORT",1,LRSUB,LRD0)=$PIECE(LRDATA,U,1)_U_$PIECE(LRDATA,U,4)_U_LR60IEN
+27 ; L subscript used when Data name is not linked to a test
IF 'LR60IEN
SET ^TMP("LR",$JOB,"SORT","L",LRSUB,LRD0)=LRSUB
+28 ; C subscript used when Data name has wrong subscript location
IF LRPC'=1!(LRSUB'=LRD0)
SET ^TMP("LR",$JOB,"SORT","C",LRD0)=LRSUB
+29 ; D subscript used when more than one Data name has the same subscript
IF LRSUBCNT>1
SET ^TMP("LR",$JOB,"SORT","D",LRSUB)=""
+30 ; LD subscript used when there are multiple tests linked to a data name
IF LR60CNT=1
KILL ^TMP("LR",$JOB,"SORT","LD",LRD0)
End DoDot:1
+31 ;
+32 ; Report issues with duplicate subscript locations
+33 SET LRSUB=""
FOR
SET LRSUB=$ORDER(^TMP("LR",$JOB,"SORT","D",LRSUB))
if LRSUB=""
QUIT
Begin DoDot:1
+34 SET LRSUPFLG=1
+35 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+36 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="*WARNING* THE FOLLOWING DATA NAMES ARE ASSIGNED THE SAME SUBSCRIPT #"_LRSUB
SET LRNUM=LRNUM+1
+37 SET LRD0=0
FOR
SET LRD0=$ORDER(^TMP("LR",$JOB,"SORT",1,LRSUB,LRD0))
if LRD0=""
QUIT
Begin DoDot:2
+38 SET LRDATA=$GET(^TMP("LR",$JOB,"SORT",1,LRSUB,LRD0))
+39 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" - Data Name '"_$PIECE(LRDATA,U,1)_"' (#"_LRD0_") is assigned location: "_$PIECE(LRDATA,U,2)
SET LRNUM=LRNUM+1
+40 IF $PIECE(LRDATA,U,3)
Begin DoDot:3
+41 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" (This Data Name is linked to Lab test #"_$PIECE(LRDATA,U,3)_" "_$PIECE(^LAB(60,$PIECE(LRDATA,U,3),0),U)_")"
SET LRNUM=LRNUM+1
End DoDot:3
+42 IF '$PIECE(LRDATA,U,3)
Begin DoDot:3
+43 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" (This Data Name is not linked to a Lab test)"
SET LRNUM=LRNUM+1
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;
+45 ; Report issues with multiple tests with the same data name
+46 SET LRD0=0
FOR
SET LRD0=$ORDER(^TMP("LR",$JOB,"SORT","LD",LRD0))
if 'LRD0
QUIT
Begin DoDot:1
+47 SET LRSUPFLG=1
+48 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+49 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="*WARNING* THE DATA NAME '"_$PIECE(^DD(63.04,LRD0,0),U)_"' (#"_LRD0_") IS LINKED TO MORE THAN ONE LAB TEST:"
SET LRNUM=LRNUM+1
+50 NEW LRCNT
+51 SET LR60IEN=0
FOR
SET LR60IEN=$ORDER(^TMP("LR",$JOB,"SORT","LD",LRD0,LR60IEN))
if 'LR60IEN
QUIT
Begin DoDot:2
+52 SET LRCNT=$GET(LRCNT)+1
+53 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "_LRCNT_". "_$PIECE($GET(^LAB(60,LR60IEN,0)),U,1)_" (#"_LR60IEN_")"
+54 SET LRNUM=LRNUM+1
End DoDot:2
End DoDot:1
+55 ;
+56 ;Check - SUBSCRIPT'=FIELD #
+57 ; NOT IN FIRST PIECE
+58 ; OR BOTH
+59 ;
+60 ;
+61 IF 'INSTALL
DO SAY^XGF(24,1,LRSPACE)
DO SAY^XGF(24,1,"LRD0=")
+62 SET LRD0=1
+63 FOR CNT=0:1
SET LRD0=$ORDER(^TMP("LR",$JOB,"SORT","C",LRD0))
if LRD0=""
QUIT
Begin DoDot:1
+64 SET LRDATA=$GET(^DD(63.04,LRD0,0))
if LRDATA=""
QUIT
+65 SET LRSUB=$PIECE($PIECE(LRDATA,U,4),";")
+66 SET LRPC=$PIECE($PIECE(LRDATA,U,4),";",2)
+67 IF $DATA(^TMP("LR",$JOB,"SORT","D",LRSUB))
QUIT
+68 SET LR60IEN=$PIECE($GET(^TMP("LR",$JOB,"SORT",1,LRSUB,LRD0)),U,3)
+69 IF 'INSTALL
IF '(CNT#100)
DO SAY^XGF(24,1,"LRD0="_LRD0)
+70 IF LRPC'=1!(LRSUB'=LRD0)
Begin DoDot:2
+71 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+72 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Data Name Location "_$PIECE(^DD(63.04,LRD0,0),U)_" CH;"_LRSUB_";"_LRPC_" should be CH;"_LRD0_";1"
+73 IF LRFIX
IF LR60IEN
IF '$DATA(^TMP("LR",$JOB,"SORT","LD",LRD0))
DO FIXDD
Begin DoDot:3
+74 SET ^(LRNUM)=^TMP("LR",$JOB,"DD63.04",LRNUM)_" ***FIXED***"
End DoDot:3
+75 IF LRFIX
IF ('LR60IEN!($DATA(^TMP("LR",$JOB,"SORT","LD",LRD0))))
Begin DoDot:3
+76 SET ^(LRNUM)=^TMP("LR",$JOB,"DD63.04",LRNUM)_" ***NOT FIXED***"
+77 SET LRSUPFLG=1
End DoDot:3
+78 SET LRNUM=LRNUM+1
+79 IF LR60IEN
IF $GET(^TMP("LR",$JOB,"DDFIXED",LRSUB))
Begin DoDot:3
+80 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Lab test # "_LR60IEN_" "_$PIECE(^LAB(60,LR60IEN,0),U)_" DATA NAME (LOCATION) SUBSCRIPT **** FIXED ****"
+81 SET LRNUM=LRNUM+1
+82 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" OLD SUBSCRIPT="_LRSUB_" NEW SUBSCRIPT="_LRD0
+83 SET LRNUM=LRNUM+1
End DoDot:3
+84 IF 'LR60IEN
Begin DoDot:3
+85 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Data Name is not linked to a File #60 Laboratory Test"
+86 IF LRFIX
SET ^(LRNUM)=^TMP("LR",$JOB,"DD63.04",LRNUM)_" ***NOT FIXED***"
SET LRSUPFLG=1
+87 SET LRNUM=LRNUM+1
End DoDot:3
+88 IF $DATA(^TMP("LR",$JOB,"SORT","LD",LRD0))
Begin DoDot:3
+89 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Data Name is linked to more than one File #60 Laboratory Test"
+90 IF LRFIX
SET ^(LRNUM)=^TMP("LR",$JOB,"DD63.04",LRNUM)_" ***NOT FIXED***"
SET LRSUPFLG=1
+91 SET LRNUM=LRNUM+1
End DoDot:3
End DoDot:2
End DoDot:1
+92 ;
+93 ;Check "B" cross reference - LR*5.2*519
+94 DO B6304^LRWU9A
+95 QUIT
+96 ;-------------------------------------------------------
CHK63 ;CHECK FILE 63 FOR TEST DATA WITH NO DATA NAME
+1 ;
+2 NEW CNT,DATANUM,LRDFN,LRIDT,LRD0,LRNUM1,LRNUM2
+3 IF 'INSTALL
DO SAY^XGF(24,1,LRSPACE)
DO SAY^XGF(24,1,"LRDFN=")
+4 SET (LRDFN,LRIDT,LRD0)=0
+5 SET LRNUM1=1
SET LRNUM2=1
+6 FOR CNT=0:1
SET LRDFN=$ORDER(^LR(LRDFN))
if 'LRDFN
QUIT
Begin DoDot:1
+7 SET LRIDT=0
+8 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if 'LRIDT
QUIT
Begin DoDot:2
+9 NEW LRREPAIR
+10 SET LRD0=1
+11 FOR
SET LRD0=$ORDER(^LR(LRDFN,"CH",LRIDT,LRD0))
if LRD0'>0
QUIT
Begin DoDot:3
+12 ;Used to prevent issues when two Data Names use each others subscripts
IF $DATA(LRREPAIR(LRD0))
QUIT
+13 IF 'INSTALL
IF '(CNT#100)
DO SAY^XGF(24,1,"LRDFN="_LRDFN)
+14 IF '$DATA(^DD(63.04,LRD0,0))
IF '$DATA(^TMP("LR",$JOB,"SORT",1,LRD0))
Begin DoDot:4
+15 SET ^TMP("LR",$JOB,"SORT","W",LRD0,LRNUM2)="^LR("_LRDFN_",""CH"","_LRIDT_","_LRD0_")"
+16 SET LRNUM2=LRNUM2+1
End DoDot:4
+17 ; Check if there are results that belong to a Data Name that is not linked to a test.
+18 SET DATANUM=$ORDER(^TMP("LR",$JOB,"SORT","L",LRD0,0))
+19 IF DATANUM
IF '$DATA(^TMP("LR",$JOB,"SORT","D",LRD0))
Begin DoDot:4
+20 ;SORT BY DATA NAME
+21 SET ^TMP("LR",$JOB,"SORT","T",DATANUM,LRNUM1)="^LR("_LRDFN_",""CH"","_LRIDT_","_LRD0_")"
+22 SET LRNUM1=LRNUM1+1
End DoDot:4
+23 IF LRFIX
DO FIX63
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET LRNUM2=0
SET DATANUM=0
+25 IF $DATA(^TMP("LR",$JOB,"SORT","W"))
Begin DoDot:1
+26 FOR
SET DATANUM=$ORDER(^TMP("LR",$JOB,"SORT","W",DATANUM))
if DATANUM'>0
QUIT
Begin DoDot:2
+27 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+28 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Results in subscript '"_DATANUM_"' without a Data Name at: "
+29 SET LRNUM=LRNUM+1
+30 FOR
SET LRNUM2=$ORDER(^TMP("LR",$JOB,"SORT","W",DATANUM,LRNUM2))
if LRNUM2'>0
QUIT
Begin DoDot:3
+31 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "_^TMP("LR",$JOB,"SORT","W",DATANUM,LRNUM2)
+32 SET LRNUM=LRNUM+1
+33 SET LRSUPFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+34 SET LRNUM1=0
SET DATANUM=0
+35 IF $DATA(^TMP("LR",$JOB,"SORT","T"))
Begin DoDot:1
+36 FOR
SET DATANUM=$ORDER(^TMP("LR",$JOB,"SORT","T",DATANUM))
if DATANUM'>0
QUIT
Begin DoDot:2
+37 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+38 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Results in Data Name "_$PIECE(^DD(63.04,DATANUM,0),U,1)_" without a test in file 60 at: "
+39 SET LRNUM=LRNUM+1
+40 FOR
SET LRNUM1=$ORDER(^TMP("LR",$JOB,"SORT","T",DATANUM,LRNUM1))
if LRNUM1'>0
QUIT
Begin DoDot:3
+41 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "_^TMP("LR",$JOB,"SORT","T",DATANUM,LRNUM1)
+42 SET LRNUM=LRNUM+1
+43 SET LRSUPFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;
+45 QUIT
+46 ;-------------------------------------------------------
FIXDD ; FIX DD FOR BAD DATA NAMES.
+1 ;
+2 NEW DDFIELD,LRNAME,LRTYPE
+3 ;
+4 DO FIELD^DID(63.04,LRD0,"","LABEL;TYPE","DDFIELD")
+5 SET LRNAME=DDFIELD("LABEL")
+6 SET LRTYPE=DDFIELD("TYPE")
+7 SET DA=LRD0
+8 DO DDFIX^LRWU6
+9 IF LR60IEN
Begin DoDot:1
+10 IF $PIECE(^LAB(60,LR60IEN,0),U,5)'="CH;"_LRD0_";1"!($PIECE(^LAB(60,LR60IEN,0),U,12)'="DD(63.04,"_LRD0_",")!(^LAB(60,LR60IEN,.2)'=LRD0)
Begin DoDot:2
+11 NEW LRFDA,LRDIE
+12 SET LRFDA(1,60,LR60IEN_",",400)=LRD0
+13 SET LRFDA(1,60,LR60IEN_",",5)="CH;"_LRD0_";1"
+14 SET LRFDA(1,60,LR60IEN_",",13)="DD(63.04,"_LRD0_","
+15 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
+16 SET ^TMP("LR",$JOB,"DDFIXED",LRSUB)=LRD0_U_LRPC_U_LR60IEN
UPD624 NEW LR624,LR6243
+1 SET LR624=0
FOR
SET LR624=$ORDER(^LAB(62.4,LR624))
if 'LR624
QUIT
Begin DoDot:3
+2 SET LR6243=0
FOR
SET LR6243=$ORDER(^LAB(62.4,LR624,3,LR6243))
if 'LR6243
QUIT
Begin DoDot:4
+3 IF $PIECE(^LAB(62.4,LR624,3,LR6243,0),U)=LR60IEN
Begin DoDot:5
+4 NEW LRFDA,LRIENS
+5 SET LRIENS=LR6243_","_LR624_","
+6 SET LRFDA(62.41,LRIENS,11)="TV("_LRD0_",1)"
+7 DO FILE^DIE("","LRFDA")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;
+9 QUIT
+10 ;-------------------------------------------------------
FIX63 ;FIX DATA NODES IN FILE 63
+1 ;
+2 if $DATA(^TMP("LR",$JOB,"SORT","D",LRD0))
QUIT
+3 if '$DATA(^TMP("LR",$JOB,"DDFIXED",LRD0))
QUIT
+4 if ($PIECE(^TMP("LR",$JOB,"DDFIXED",LRD0),U,2)'=1)
QUIT
+5 SET LRLOC=$PIECE(^TMP("LR",$JOB,"DDFIXED",LRD0),U)
+6 IF $DATA(^DD(63.04,LRD0,0))!($DATA(^TMP("LR",$JOB,"SORT",1,LRD0)))
SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=" "
SET LRNUM=LRNUM+1
+7 IF $DATA(^LR(LRDFN,"CH",LRIDT,LRLOC))
Begin DoDot:1
+8 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="*ERROR* MOVING OVER ^LR("_LRDFN_",CH,"_LRIDT_","_LRD0_") TO ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
+9 SET LRNUM=LRNUM+1
+10 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Data already exists in ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
+11 SET LRNUM=LRNUM+1
+12 SET LRSUPFLG=1
End DoDot:1
QUIT
+13 ;Kill Clinical Reminders Index
DO CHKILLPX(LRDFN,LRIDT,LRD0)
+14 SET ^LR(LRDFN,"CH",LRIDT,LRLOC)=^LR(LRDFN,"CH",LRIDT,LRD0)
+15 KILL ^LR(LRDFN,"CH",LRIDT,LRD0)
+16 SET LRREPAIR(LRLOC)=""
+17 ;Set Clinical Reminders Index
DO CHSET^LRPX(LRDFN,LRIDT)
+18 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="DATA LOCATION FIXED IN LAB DATA FILE ^LR"
+19 SET LRNUM=LRNUM+1
+20 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="^LR("_LRDFN_",CH,"_LRIDT_","_LRD0_") NOW MOVED TO ^LR("_LRDFN_",CH,"_LRIDT_","_LRLOC_")"
+21 SET LRNUM=LRNUM+1
+22 ;
+23 QUIT
+24 ;-------------------------------------------------------
CHKILLPX(LRDFN,LRIDT,LRD0) ;Kill Clinical Reminders Index
+1 NEW LR60IEN,DFN,DATE,OK,DAS,LRDBLCHK
+2 SET LR60IEN=$PIECE(^TMP("LR",$JOB,"DDFIXED",LRD0),U,3)
+3 IF 'LR60IEN
Begin DoDot:1
+4 NEW DATA
+5 SET DATA=^LR(LRDFN,"CH",LRIDT,LRD0)
+6 SET LR60IEN=+$PIECE($PIECE(DATA,U,3),"!",7)
End DoDot:1
+7 IF 'LR60IEN
QUIT
+8 IF '$LENGTH($GET(^LR(+$GET(LRDFN),"CH",+$GET(LRIDT),0)))
QUIT
+9 DO PATIENT^LRPX(LRDFN,.DFN,.OK)
IF 'OK
QUIT
+10 SET DATE=9999999-LRIDT
+11 SET DAS=LRDFN_";CH;"_LRIDT_";"_LRD0
+12 SET LRDBLCHK=0
+13 IF '$DATA(^PXRMINDX(63,"PI",DFN,LR60IEN,DATE,DAS))
SET LRDBLCHK=1
+14 DO KLAB^LRPX(DFN,DATE,LR60IEN,DAS)
+15 ;
+16 IF LRDBLCHK
Begin DoDot:1
+17 NEW ITEM,FLAG
+18 SET ITEM=0
FOR
SET ITEM=$ORDER(^PXRMINDX(63,"PI",DFN,ITEM))
if 'ITEM!($DATA(FLAG))
QUIT
Begin DoDot:2
+19 IF $DATA(^PXRMINDX(63,"PI",DFN,ITEM,DATE,DAS))
Begin DoDot:3
+20 DO KLAB^LRPX(DFN,DATE,ITEM,DAS)
+21 SET FLAG=1
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;-------------------------------------------------------
SENDMM ;SEND MAIL MESSAGE OF ERRORS FOUND AND/OR FIXED.
+1 ;
+2 NEW XMSUB,DIFROM,XMINSTR
+3 ;
+4 SET LRNUM=3
+5 ;Errors were found
IF $ORDER(^TMP("LR",$JOB,"DD63.04",5))
Begin DoDot:1
+6 ;
+7 ;not all errors were auto-repaired
IF 'LRFIX!(LRFIX&($GET(LRSUPFLG)))
Begin DoDot:2
+8 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Contact the National Service Desk to request assistance from the Clin 4"
SET LRNUM=LRNUM+1
+9 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="Product Support team in resolving the following errors identified in the"
SET LRNUM=LRNUM+1
+10 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="VistA Laboratory package:"
SET LRNUM=LRNUM+1
End DoDot:2
+11 ;
+12 ;all errors were auto-repaired
IF LRFIX
IF '$GET(LRSUPFLG)
Begin DoDot:2
+13 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="The LAB DATA file (#63) cleanup process has found and repaired the"
SET LRNUM=LRNUM+1
+14 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)="following errors:"
SET LRNUM=LRNUM+1
End DoDot:2
End DoDot:1
+15 ;
+16 ;No errors were found
IF '$ORDER(^TMP("LR",$JOB,"DD63.04",5))
Begin DoDot:1
+17 SET ^TMP("LR",$JOB,"DD63.04",LRNUM)=""
+18 SET ^TMP("LR",$JOB,"DD63.04",(LRNUM+1))="*** NO ERRORS FOUND ***"
End DoDot:1
+19 ;
+20 SET XMSUB="DATA DICTIONARY ^DD(63.04 CHECK REPORT "
+21 SET XMSUB=XMSUB_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
+22 SET XMINSTR("ADDR FLAGS")="R"
+23 DO SENDMSG^XMXAPI(DUZ,XMSUB,"^TMP(""LR"",$J,""DD63.04"")",.XMY,.XMINSTR)
+24 ;
+25 QUIT
+26 ;-------------------------------------------------------
ASK() ; Run analyze/repair query
+1 ;
+2 NEW Y,DIR,DIRUT,DTOUT,DUOUT,FIX
+3 ;
+4 SET FIX=0
+5 ;
+6 WRITE !,"This process will check the CHEM, HEM, TOX, RIA, SER, etc."
+7 WRITE !,"Sub-file (#63.04) of the LAB DATA file (#63) looking for"
+8 WRITE !,"possible discrepancies in the Data Dictionary. Once the"
+9 WRITE !,"process has completed, a MailMan message will be sent to the"
+10 WRITE !,"user that started this process and any other user selected."
+11 WRITE !!
+12 WRITE !,"The two modes in which this process can be run are ANALYZE"
+13 WRITE !,"and REPAIR. If the ANALYZE option is chosen, the process will"
+14 WRITE !,"only look for discrepancies and report the findings via a"
+15 WRITE !,"MailMan message. If the ANALYZE,REPAIR option is chosen the"
+16 WRITE !,"process will ANALYZE and REPAIR any discrepancies found that"
+17 WRITE !,"can be fixed programmatically and list all those that could"
+18 WRITE !,"not be fixed but need attention."
+19 WRITE !!
+20 ;
+21 SET DIR("A")="Do you want to continue with this process"
SET DIR("B")="NO"
+22 SET DIR(0)="Y"
+23 DO ^DIR
+24 IF 'Y
QUIT FIX
+25 ;
+26 KILL DIR,Y
+27 ;
+28 SET DIR(0)="NAO^1:3"
SET DIR("B")=3
+29 SET DIR("A",1)="Select the action you wish to take:"
+30 SET DIR("A",2)=""
+31 SET DIR("A",3)="1. Analyze and Report."
+32 SET DIR("A",4)="2. Analyze, Repair, and Report."
+33 SET DIR("A",5)="3. Quit - No Action."
+34 SET DIR("A",6)=""
+35 SET DIR("A")="Enter a number 1 thru 3: "
+36 SET DIR("?")="Select a number 1 thru 3 or press <Return> to exit"
+37 ;
+38 DO ^DIR
+39 IF Y=1
SET FIX=1
+40 IF Y=2
SET FIX=2
+41 IF Y=3!(Y=-1)!('Y)
SET FIX=0
QUIT FIX
+42 ;
+43 KILL DIR,Y
+44 SET DIR("A")="Are you sure you want to proceed"
SET DIR("B")="NO"
+45 SET DIR(0)="Y"
+46 DO ^DIR
+47 IF 'Y
SET FIX=0
+48 ;
+49 QUIT FIX
