- 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 Feb 18, 2025@23:49:15 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