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