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

BLRRLTDU.m

Go to the documentation of this file.
  1. BLRRLTDU ; IHS/MSC/MKK - Reference Lab Test Delete Utilities ; 22-Oct-2013 09:22 ; MKK
  1. ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
  1. ;
  1. EEP ; Ersatz EP
  1. D EEP^BLRGMENU
  1. Q
  1. ;
  1. ; Parameters:
  1. ; F60IEN = Pointer to entry in file 60
  1. ; LRAS = Accession Number
  1. ; MSG = Message # in file 62.49
  1. ; TYPE = "A" - for ADDING test to an acceession
  1. ; = "N" - for marking test as NOT PERFORMED
  1. STORTXNS(F60IEN,LRAS,TYPE) ; EP - Set data when Reference Lab update successful
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60IEN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAS,TYPE,U,XPARSYS,XQXFLG)
  1. ;
  1. S STR=$G(^XTMP("BLRRLTMR",0))
  1. I $L(STR)<1 D ; Set ^XTMP Node Zero
  1. . S STR=$$HTFM^XLFDT(+$H)_"^^Reference Lab 'Not Performed' Update"
  1. S $P(STR,"^",2)=$$HTFM^XLFDT(+$H+30)
  1. S ^XTMP("BLRRLTMR",0)=STR
  1. ;
  1. ; Set the LRAA,LRAD,LRAN variables from the Accession number
  1. S X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
  1. ;
  1. S UID=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3),"<UNKNOWN>"),ORDER=$G(^(.1),"<UNKNOWN>")
  1. ;
  1. S (LRDFN,LRIDT,LRSS)="<UNKNOWN>"
  1. I +LRAA,+LRAD,+LRAN D
  1. . S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)
  1. . S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1. ;
  1. S ^XTMP("BLRRLTMR",$H,TYPE,LRAS,F60IEN)=UID_"^"_ORDER_"^"_LRDFN_"^"_LRSS_"^"_LRIDT
  1. S LREND=1
  1. ;
  1. Q
  1. ;
  1. TXNSREPT ; EP - Report on Reference Lab successful updates
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. Q:$$TXNSRPTI()="Q"
  1. ;
  1. F S THEN=$O(^XTMP("BLRRLTMR",THEN),-1) Q:THEN=""!(QFLG="Q") D
  1. . S TYPE=""
  1. . F S TYPE=$O(^XTMP("BLRRLTMR",THEN,TYPE)) Q:TYPE=""!(QFLG="Q") D
  1. .. S LRAS=""
  1. .. F S LRAS=$O(^XTMP("BLRRLTMR",THEN,TYPE,LRAS)) Q:LRAS=""!(QFLG="Q") D
  1. ... S F60IEN=0
  1. ... F S F60IEN=$O(^XTMP("BLRRLTMR",THEN,TYPE,LRAS,F60IEN)) Q:F60IEN<1!(QFLG="Q") D TXNSRPTL
  1. ;
  1. W:CNT&(QFLG'="Q") !!,?4,"Number of successful updates = ",CNT,!
  1. ;
  1. D ^%ZISC
  1. ;
  1. D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
  1. Q
  1. ;
  1. TXNSRPTI() ; EP - Initialization
  1. S BLRVERN=$TR($P($T(+1),";")," ")
  1. S BLRVERN2="TXNSREPT"
  1. ;
  1. S HEADER(1)="Reference Lab successful updates"
  1. S HEADER(2)="Set Test to 'Not Performed' (NP) OR Added Test"
  1. ;
  1. D HEADERDT^BLRGMENU
  1. D HEADONE^BLRGMENU(.HEADONE)
  1. ;
  1. S HEADER(3)=" "
  1. S $E(HEADER(4),53)=$TR($$CJ^XLFSTR("@File@60@",27)," @","= ")
  1. S HEADER(5)="Entry Date/Time"
  1. S $E(HEADER(5),25)="Type"
  1. S $E(HEADER(5),33)="Accession Number"
  1. S $E(HEADER(5),53)="IEN"
  1. S $E(HEADER(5),63)="Description"
  1. ;
  1. D ^%ZIS
  1. I POP D Q "Q"
  1. . W !!,?4,"Device Issue. POP postive. Routine Ends."
  1. . D PRESSKEY^BLRGMENU(9)
  1. ;
  1. U IO
  1. ;
  1. S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1. S (CNT,PG)=0,QFLG="NO"
  1. S THEN="A"
  1. ;
  1. Q "OK"
  1. ;
  1. TXNSRPTL ; EP - Line of Data
  1. Q:$$TXNSRPTB<1
  1. ;
  1. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HEADONE) Q:QFLG="Q"
  1. ;
  1. W EXTDATE
  1. W ?25,TYPEDESC
  1. W ?32,LRAS
  1. W ?52,F60IEN
  1. W ?62,F60DESC
  1. W !
  1. S LINES=LINES+1
  1. S CNT=CNT+1
  1. ;
  1. Q
  1. ;
  1. TXNSRPTB() ; EP - "Break out" variables for report
  1. S EXTDATE=$$HTE^XLFDT(THEN,"2MZ")
  1. S TYPEDESC=$S(TYPE="A":"ADD",TYPE="N":"NP",1:"<>")
  1. S F60DESC=$$GET1^DIQ(60,F60IEN,"NAME")
  1. S:$L(F60DESC)>18 F60DESC=$$GET1^DIQ(60,F60IEN,"PRINT NAME")
  1. Q 1
  1. ;
  1. XTMPNSET(F60IEN,MSG) ; EP - Set data in ^XTMP when "Not Performed" update successful
  1. NEW UID,STR
  1. ;
  1. S STR=$G(^XTMP("BLRRLTDS",0))
  1. I $L(STR)<1 D ; Set ^XTMP Node Zero
  1. . S STR=$$HTFM^XLFDT(+$H)_"^^Reference Lab 'Not Performed' Update"
  1. S $P(STR,"^",2)=$$HTFM^XLFDT(+$H+30)
  1. S ^XTMP("BLRRLTDS",0)=STR
  1. ;
  1. S UID=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3),"<UNKNOWN>")
  1. S ^XTMP("BLRRLTDS","UID",UID,"DUZ",DUZ,$H,F60IEN)=MSG
  1. S ^XTMP("BLRRLTDS","UID")=1+$G(^XTMP("BLRRLTDS","UID"))
  1. S LREND=1
  1. ;
  1. Q
  1. ;
  1. XTMPNRPT ; EP - Report on Successfully Updated Entries
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. Q:$$XTMPNRPI()="Q"
  1. ;
  1. F S UID=$O(^XTMP("BLRRLTDS","UID",UID)) Q:UID<1!(QFLG="Q") D
  1. . S MSGDUZ=0
  1. . F S MSGDUZ=$O(^XTMP("BLRRLTDS","UID",UID,"DUZ",MSGDUZ)) Q:MSGDUZ<1!(QFLG="Q") D
  1. .. S NAMEDUZ=$$GET1^DIQ(200,MSGDUZ,"NAME")
  1. .. S HDATE=""
  1. .. F S HDATE=$O(^XTMP("BLRRLTDS","UID",UID,"DUZ",MSGDUZ,HDATE)) Q:HDATE=""!(QFLG="Q") D
  1. ... S F60IEN=0
  1. ... F S F60IEN=$O(^XTMP("BLRRLTDS","UID",UID,"DUZ",MSGDUZ,HDATE,F60IEN)) Q:F60IEN<1!(QFLG="Q") D XTMPNRPL
  1. ;
  1. W:QFLG'="Q" !,?4,"Number of Reference Lab Tests set to 'Not Performed' = ",CNT
  1. ;
  1. D ^%ZISC
  1. ;
  1. Q:QFLG="Q"
  1. ;
  1. D PRESSKEY^BLRGMENU(9)
  1. Q
  1. ;
  1. XTMPNRPI() ; EP - Initialization
  1. S BLRVERN=$TR($P($T(+1),";")," ")
  1. ;
  1. S HEADER(1)=$$GET1^DIQ(9009029,DUZ(2),3001)_" Reference Lab: 'Not Performed' Tests"
  1. S HEADER(2)="^XTMP(""BLRRLTDS"") Report"
  1. S HEADER(3)=" "
  1. ;
  1. D HEADERDT^BLRGMENU
  1. D HEADONE^BLRGMENU(.HEADONE)
  1. ;
  1. I $D(^XTMP("BLRRLTDS","UID"))<1 D Q "Q"
  1. . W !,?4,"No entries in ^XTMP(""BLRRLTDS"",""UID""). Routine Ends."
  1. . D PRESSKEY^BLRGMENU(9)
  1. ;
  1. ;1 2 3 4 5 6 7 8
  1. ;12345678901234567890123456789012345678901234567890123456789012345678901234567890
  1. ; === File 60 ==== = 62.49 =
  1. ;UID Date/Time DUZ IEN Prnt NM Msg # Message
  1. ;--------------------------------------------------------------------------------
  1. ;6011000078 02/25/13@09:19 2011 9999622 AER+AN 123456789 *NP:Set
  1. ;
  1. S $E(HEADER(4),38)=$TR($$CJ^XLFSTR("@Lab@Test@File@(#60)@",28)," @","= ")
  1. S HEADER(5)="UID"
  1. S $E(HEADER(5),15)="Date/Time"
  1. S $E(HEADER(5),31)="DUZ"
  1. S $E(HEADER(5),38)="IEN"
  1. S $E(HEADER(5),48)="Description"
  1. S $E(HEADER(5),68)="Msg"
  1. ;
  1. D ^%ZIS
  1. ;
  1. I POP D Q "Q"
  1. . W !,?4,"Issue opening device. Routine Ends."
  1. . D PRESSKEY^BLRGMENU(9)
  1. . W 1/0
  1. ;
  1. U IO
  1. ;
  1. S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1. S (CNT,PG,UID)=0
  1. S QFLG="NO"
  1. ;
  1. Q "OK"
  1. ;
  1. XTMPNRPL ; EP - Line of Data
  1. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HEADONE) Q:QFLG="Q"
  1. ;
  1. W UID
  1. W ?14,$$HTE^XLFDT(HDATE,"2MZ")
  1. W ?30,MSGDUZ
  1. W ?37,F60IEN
  1. W ?47,$E($$GET1^DIQ(60,F60IEN,"NAME"),1,18)
  1. W ?67,$G(^XTMP("BLRRLTDS","UID",UID,"DUZ",MSGDUZ,HDATE,F60IEN))
  1. W !
  1. S LINES=LINES+1
  1. S CNT=CNT+1
  1. Q
  1. ;
  1. XTMPISET(MSG,RTN) ; EP - Set data in ^XTMP when there are issues
  1. NEW UID,STR
  1. ;
  1. S STR=$G(^XTMP("BLRRLTDI",0))
  1. I $L(STR)<1 D ; Set ^XTMP Node Zero
  1. . S STR=$$HTFM^XLFDT(+$H)_"^^Reference Lab Errors"
  1. S $P(STR,"^",2)=$$HTFM^XLFDT(+$H+30)
  1. S ^XTMP("BLRRLTDI",0)=STR
  1. ;
  1. S UID=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3),"<UNKNOWN>")
  1. S ^XTMP("BLRRLTDI","UID",UID,"DUZ",DUZ,$H)=RTN_"^"_MSG
  1. S ^XTMP("BLRRLTDI","UID")=1+$G(^XTMP("BLRRLTDI","UID"))
  1. S LREND=1
  1. ;
  1. D:+$G(^XTMP("BLRRLTDI","UID"))>99 XTMPIRPT
  1. ;
  1. Q
  1. ;
  1. XTMPIRPT ; EP - There are 100 Entries in ^XTMP Issues node - Send Report to LMI Mail Group and CLEAR ^XTMP Issues
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. ; Create Message array
  1. ;
  1. ; HEADER
  1. S MESSAGE(1)=$$CJ^XLFSTR($$GET1^DIQ(9009029,DUZ(2),3001)_" Reference Lab: Issues",60)
  1. S MESSAGE(2)=$$CJ^XLFSTR("^XTMP Report",60)
  1. S MESSAGE(3)=" "
  1. S MESSAGE(4)="UID"
  1. S $E(MESSAGE(4),13)="Date/Time"
  1. S $E(MESSAGE(4),29)="DUZ"
  1. S $E(MESSAGE(4),36)="Routine"
  1. S $E(MESSAGE(4),46)="Message"
  1. S MESSAGE(5)=$TR($J("",(IOM-1))," ","-")
  1. ;
  1. ; Create the body of the Message array
  1. S UID=0,MSGL=5
  1. F S UID=$O(^XTMP("BLRRLTDI","UID",UID)) Q:UID<1 D
  1. . S MSGDUZ=0
  1. . F S MSGDUZ=$O(^XTMP("BLRRLTDI","UID",UID,"DUZ",MSGDUZ)) Q:MSGDUZ<1 D
  1. .. S NAMEDUZ=$$GET1^DIQ(200,MSGDUZ,"NAME")
  1. .. S HDATE=""
  1. .. F S HDATE=$O(^XTMP("BLRRLTDI","UID",UID,"DUZ",MSGDUZ,HDATE)) Q:HDATE="" D
  1. ... S STR=$G(^XTMP("BLRRLTDI","UID",UID,"DUZ",MSGDUZ,HDATE))
  1. ... S MSGL=MSGL+1
  1. ... S MESSAGE(MSGL)=UID
  1. ... S $E(MESSAGE(MSGL),13)=$$HTE^XLFDT(HDATE,"2MZ")
  1. ... S $E(MESSAGE(MSGL),29)=MSGDUZ
  1. ... S $E(MESSAGE(MSGL),36)=$P(STR,"^",2)
  1. ... S $E(MESSAGE(MSGL),46)=$E($P(STR,"^"),1,34)
  1. ;
  1. D SENDMAIL^BLRUTIL3($G(MESSAGE(1)),.MESSAGE,"BLRRLTDR",1)
  1. ;
  1. K ^XTMP("BLRRLTDI") ; Clear the ^XTMP global
  1. Q
  1. ;
  1. TXNSURPT ; EP - Report on Reference Lab Unsuccessful updates
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. Q:$$TXNURPTI()="Q"
  1. ;
  1. F S UID=$O(^XTMP("BLRRLTDI","UID",UID)) Q:UID=""!(QFLG="Q") D
  1. . S DUZVAR=""
  1. . F S DUZVAR=$O(^XTMP("BLRRLTDI","UID",UID,"DUZ",DUZVAR)) Q:DUZVAR=""!(QFLG="Q") D
  1. .. S HDATE=""
  1. .. F S HDATE=$O(^XTMP("BLRRLTDI","UID",UID,"DUZ",DUZVAR,HDATE)) Q:HDATE=""!(QFLG="Q") D TXNURPTL
  1. ;
  1. W:CNT&(QFLG'="Q") !!,?4,"Number of unsuccessful updates = ",CNT,!
  1. ;
  1. D ^%ZISC
  1. ;
  1. D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
  1. Q
  1. ;
  1. TXNURPTI() ; EP - Initialization
  1. S BLRVERN=$TR($P($T(+1),";")," ")
  1. S BLRVERN2="TXNSURPT"
  1. ;
  1. S HEADER(1)="Reference Lab NON Successful Updates"
  1. S HEADER(2)=" "
  1. ;
  1. D HEADERDT^BLRGMENU
  1. D HEADONE^BLRGMENU(.HEADONE)
  1. ;
  1. S HEADER(4)="UID"
  1. S $E(HEADER(4),15)="DUZ"
  1. S $E(HEADER(4),25)="Date/Time"
  1. S $E(HEADER(4),43)="Routine"
  1. S $E(HEADER(4),53)="Message"
  1. ;
  1. D ^%ZIS
  1. I POP D Q "Q"
  1. . W !!,?4,"Device Issue. POP postive. Routine Ends."
  1. . D PRESSKEY^BLRGMENU(9)
  1. ;
  1. U IO
  1. ;
  1. S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1. S (CNT,PG,THEN,UID)=0,QFLG="NO"
  1. ;
  1. Q "OK"
  1. ;
  1. TXNURPTL ; EP - Line of Data
  1. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG) Q:QFLG="Q"
  1. ;
  1. D TXNURPTB
  1. ;
  1. W UID
  1. W ?14,DUZVAR
  1. W ?24,DATETIME
  1. W ?42,RTN
  1. I $L(MESSAGE)<29 W ?52,MESSAGE,! S LINES=LINES+1
  1. D:$L(MESSAGE)>28 LINEWRAP^BLRGMENU(52,MESSAGE,28)
  1. S CNT=CNT+1
  1. Q
  1. ;
  1. TXNURPTB ; EP - Break out data
  1. S DATETIME=$$HTE^XLFDT(HDATE,"5MZ")
  1. S STR=$G(^XTMP("BLRRLTDI","UID",UID,"DUZ",DUZVAR,HDATE))
  1. S RTN=$P(STR,"^")
  1. S MESSAGE=$P(STR,"^",2)
  1. Q
  1. ;
  1. DEBUGRPT ; EP - Debug the XTMPRPT report
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. I $NAMESPACE="LABMU" D Q
  1. . W !!,?4,"Will not K ^XTMP(""BLRRLTDI"") nor reset it because MU testing has begun on this UCI."
  1. . D PRESSKEY^BLRGMENU(9)
  1. ;
  1. K ^XTMP("BLRRLTDI")
  1. ;
  1. S ^XTMP("BLRRLTDI",0)=DT_"^"_$$HTFM^XLFDT(+$H+30)_"^Reference Lab Test Delete Errors"
  1. ;
  1. ; Set the Error Messages
  1. S ERRMAX=1,ERRMSG(ERRMAX)="Not authorized to change test status."
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="Accession has no Test."
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="Someone else is working on this accession"
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="Someone else is working on this data."
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="Can't find Lab Data for this accession"
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="There is no Order for this Accession"
  1. S ERRMAX=ERRMAX+1,ERRMSG(ERRMAX)="No Subscript for this Accession Area"
  1. ;
  1. ; Set the ^XTMP Array
  1. S CNT=0,ERR=1
  1. F Q:CNT>99 D
  1. . F S UID=$TR($J($R(10000000000),10)," ","0") Q:$D(^XTMP("BLRRLTDI","UID",UID))<1
  1. . S ^XTMP("BLRRLTDI","UID")=1+$G(^XTMP("BLRRLTDI","UID"))
  1. . ;
  1. . S FAKEDUZ=$TR($J($R(10000),5)," ","0")
  1. . S FAKERTN=$S((CNT#2):"BLRRLTDR",1:"BLRRLTAR")
  1. . S ^XTMP("BLRRLTDI","UID",UID,"DUZ",FAKEDUZ,$H)=ERRMSG(ERR)_"^"_FAKERTN,ERR=ERR+1 S:ERR>ERRMAX ERR=1
  1. . S CNT=CNT+1
  1. ;
  1. D XTMPIRPT
  1. ;
  1. Q
  1. ;
  1. DEBUG ; EP - Debug BLRRLTDR
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. K ^XTMP("BLRTRACE")
  1. D:$P($G(LRPARAM),"^",3)="" ^LRPARAM
  1. ;
  1. D ^XBFMK
  1. S DIR(0)="NO"
  1. S DIR("A")="Enter 62.49 Message Number"
  1. D ^DIR
  1. I +$G(DIRUT) D Q
  1. . W !!,?4,"No/Invalid Entry. Routine Ends."
  1. . D PRESSKEY^BLRGMENU(9)
  1. ;
  1. S LA76249=+$G(X)
  1. D PEP^BLRRLTDR
  1. Q
  1. ;
  1. REPORTS ; EP - Reports Menu
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. S BLRVERN=$TR($P($T(+1),";")," ")
  1. ;
  1. D ADDTMENU^BLRGMENU("TXNSREPT^BLRRLTDU","Successful Updates")
  1. D ADDTMENU^BLRGMENU("XTMPNRPT^BLRRLTDU","'Not Performed' Success")
  1. D ADDTMENU^BLRGMENU("TXNSURPT^BLRRLTDU","NON Successful updates")
  1. ;
  1. ; Main Menu driver
  1. D MENUDRVR^BLRGMENU("RPMS Reference Lab ","Automatic Updating Reports")
  1. Q