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

BLRMANP3.m

Go to the documentation of this file. 
  1. BLRMANP3 ; IHS/MSC/MKK - Multiple Accession Not Performed utility, part 3 ; 22-Apr-2016 15:12 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1.  ; The following cloned from BLRRLTDU
  1. XTMPRPT ; EP - ^XTMP Issues node - Interactive Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS("XTMPRPT")
  1.  S HEADER(1)="^XTMP Global"
  1.  ;
  1.  I $D(^XTMP("BLRMANPU","UID"))<1 D  Q
  1.  . D HEADERDT^BLRGMENU
  1.  . W !,?4,"^XTMP Global has no Data for 'Multiple Accession Not Performed' Errors."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S HEADER(2)="Accession (UID)"
  1.  S HEADER(3)=$$CJ^XLFSTR("Could *NOT* Mark 'Not Performed' Report",80)
  1.  S HEADER(4)=" "
  1.  S HEADER(5)="UID"
  1.  S $E(HEADER(5),13)="Date/Time"
  1.  S $E(HEADER(5),29)="DUZ"
  1.  S $E(HEADER(5),36)="Error Message"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,PG)=0
  1.  S QFLG="NO"
  1.  ;
  1.  S UID=0,MSGL=5
  1.  F  S UID=$O(^XTMP("BLRMANPU","UID",UID))  Q:UID<1!(QFLG="Q")  D
  1.  . S MSGDUZ=0
  1.  . F  S MSGDUZ=$O(^XTMP("BLRMANPU","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("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE))  Q:HDATE=""!(QFLG="Q")  D
  1.  ... S STR=$G(^XTMP("BLRMANPU","UID",UID,"DUZ",MSGDUZ,HDATE))
  1.  ... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"
  1.  ... W UID
  1.  ... W ?12,$$HTE^XLFDT(HDATE,"2MZ")
  1.  ... W ?28,MSGDUZ
  1.  ... D LINEWRAP^BLRGMENU(35,$P(STR,"^"),45)
  1.  ... W !
  1.  ... S LINES=LINES+1
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. XTMPKILL ; EP - Purge the ^XTMP("BLRMANPU") Node
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S HEADER(1)="^XTMP Global"
  1.  S HEADER(2)="Purge"
  1.  D HEADERDT^BLRGMENU
  1.  W ?9,"This option will purge the ^XTMP(""BLRMANPU"") global.",!!
  1.  W ?9,"That global contains any error messages created during the",!!
  1.  W ?14,"Mark Multiple Accessions as Not Performed",!!
  1.  W ?9,"process."
  1.  S TAB=$J("",5)
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=TAB_"Are you Sure"
  1.  D ^DIR
  1.  Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=TAB_"Second Chance: Are you Really sure"
  1.  D ^DIR
  1.  Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="Y"
  1.  S DIR("A")=TAB_"FINAL CHANCE: Are you Absolutely sure"
  1.  D ^DIR
  1.  Q:+Y<1 $$BADSTUFN^BLRUTIL7("No/Quit/Invalid Response.")
  1.  ;
  1.  W !!,TAB_TAB_"^XTMP(""BLRMANPU"") Global Purged."
  1.  K ^XTMP("BLRMANPU")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. DETAIL68 ; EP - Accession (#68) File Data Detail
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$DETAILIN("ACDETAIL")="Q"
  1.  ;
  1.  D NODEZERO,NODE3,ACCTESTS
  1.  ;
  1.  I $O(^LRO(69,"C",ORDERNUM,0))<1  W !,?6,"**Order #:",ORDERNUM," is **NOT** in the Lab Order Entry (#69) File."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. DETAILIN(SUBRTN) ; EP - Initialize variables
  1.  NEW COL,COL2
  1.  D SETBLRVS($G(SUBRTN))
  1.  ;
  1.  S HEADER(1)="Accession Detail"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^LRWU4
  1.  ;
  1.  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1 Q $$ENDERQ("Accession does not Exist.")
  1.  ;
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  S LRASIEN=LRAN_","_LRAD_","_LRAA
  1.  S ORDERNUM=$$GET1^DIQ(68.02,LRASIEN,14)
  1.  S LRAS=$$GET1^DIQ(68.02,LRASIEN,15)
  1.  S UID=$$GET1^DIQ(68.02,LRASIEN,16)
  1.  S DIV=$$GET1^DIQ(68.02,LRASIEN,26)
  1.  ;
  1.  S HEADER(2)="Accession #:"_LRAS
  1.  S HEADER(3)=$$CENTER("LRAA:"_LRAA_"     LRAD:"_LRAD_"     LRAN:"_LRAN)
  1.  ;
  1.  D ^%ZIS
  1.  I POP Q $$ENDERQ("Invalid %ZIS call.")
  1.  ;
  1.  S MAXLINES=IOSL-4
  1.  S LINES=MAXLINES+10
  1.  S PG=0,RESULTDT="",QFLG="OK"
  1.  Q "OK"
  1.  ;
  1. NODEZERO() ; EP - Display Accession Node Zero
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  ; D LINEMSG("Accession (#68) file Data","=",5)
  1.  ;
  1.  S STR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  ;
  1.  W ?5,"Order #:",ORDERNUM
  1.  W:$O(^LRO(69,"C",ORDERNUM,0))<1 "**"
  1.  W ?23,"UID:",UID
  1.  W ?43,"Order Dt:"
  1.  S ORDERDT=$$GET1^DIQ(68.02,LRASIEN,3,"I")
  1.  W:ORDERDT $$FMTE^XLFDT(ORDERDT,"5DZ")
  1.  W !
  1.  ;
  1.  S LRDFN=$$GET1^DIQ(68.02,LRASIEN,.01,"I")
  1.  W ?7,"LRDFN:",LRDFN
  1.  W ?23,"DFN:",$$GET1^DIQ(63,LRDFN,.03,"I")
  1.  W ?44,"PT NAME:",$$GET1^DIQ(63,LRDFN,.03)
  1.  W !
  1.  ;
  1.  W ?4,"Provider:",$E($$GET1^DIQ(68.02,LRASIEN,6.5),1,36)
  1.  W ?42,"Rpt R Loc:",$$GET1^DIQ(68.02,LRASIEN,6)
  1.  W !
  1.  ;
  1.  W ?5,"Ord Loc:",$E($$GET1^DIQ(68.02,LRASIEN,94),1,27)
  1.  W ?48,"Div:",$E(DIV,1,28)
  1.  W !
  1.  W ?4,"Log-In Person:",$E($$GET1^DIQ(68.02,LRASIEN,6.7),1,19)
  1.  W ?39,"File 200 IEN:",$$GET1^DIQ(68.02,LRASIEN,6.7,"I")
  1.  W !!
  1.  Q
  1.  ;
  1. NODE3 ;  EP - Display Accession Node Three
  1.  S STR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
  1.  ;
  1.  W ?4,"Draw Time:"
  1.  S DRAWTIME=$$GET1^DIQ(68.02,LRASIEN,9,"I")
  1.  W $TR($$UP^XLFSTR($$FMTE^XLFDT(DRAWTIME,"5MPZ")),"@"," ")
  1.  W ?39,"Lab Arr Time:"
  1.  S LARRTIME=$$GET1^DIQ(68.02,LRASIEN,12,"I")
  1.  W $TR($$UP^XLFSTR($$FMTE^XLFDT(LARRTIME,"5MPZ")),"@"," ")
  1.  W !
  1.  ;
  1.  W ?14,DRAWTIME,?52,LARRTIME,!
  1.  ;
  1.  W ?4,"Result Dt:"
  1.  S RESULTDT=$$GET1^DIQ(68.02,LRASIEN,13,"I")
  1.  I RESULTDT D
  1.  . S TEMP=$$UP^XLFSTR($$FMTE^XLFDT(RESULTDT,"5MPZ"))
  1.  . W $P(TEMP," "),$$RJ^XLFSTR($P(TEMP," ",2,3),9)
  1.  W ?39,"Inverse Date:",$$GET1^DIQ(68.02,LRASIEN,13.5,"I")
  1.  W !
  1.  Q
  1.  ;
  1. ACCTESTS ; EP - Display the Tests
  1.  NEW TECH
  1.  ;
  1.  S LRAT=.9999999
  1.  F  S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))  Q:LRAT<1  D
  1.  . S LRATIEN=LRAT_","_LRASIEN
  1.  . S TESTIEN=$P(STR,U)
  1.  . W !,?4,"Test:",$$GET1^DIQ(68.04,LRATIEN,.01)
  1.  . W ?40,"File 60 IEN:",$$GET1^DIQ(68.04,LRATIEN,.01,"I")
  1.  . W !
  1.  . S TECH=+$P(STR,U,4)
  1.  . W ?4,"Tech:",$$GET1^DIQ(68.04,LRATIEN,3)
  1.  . S DATETIME=$$GET1^DIQ(68.04,LRATIEN,4,"I")
  1.  . I DATETIME D
  1.  .. W ?44,"Comp Dt:"
  1.  .. S TEMP=$$UP^XLFSTR($$FMTE^XLFDT(DATETIME,"5MPZ"))
  1.  .. W $P(TEMP," "),$$RJ^XLFSTR($P(TEMP," ",2,3),9)
  1.  . W !
  1.  . S STR=$$GET1^DIQ(68.04,LRATIEN,5)
  1.  . I $L(STR) D
  1.  .. W ?8,"Disp:",$E(STR,1,67)
  1.  .. W !
  1.  ;
  1.  W !
  1.  ;
  1.  S LRASP=0
  1.  F  S LRASP=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRASP))  Q:LRASP<1  D
  1.  . S LRASPIEN=LRASP_","_LRASIEN
  1.  . W ?5,"Specimen:",$E($$GET1^DIQ(68.05,LRASPIEN,.01),1,32)
  1.  . W ?40,"File 61 IEN:",$$GET1^DIQ(68.05,LRASPIEN,.01,"I")
  1.  . W !
  1.  . W ?4,"Coll Samp:",$E($$GET1^DIQ(68.05,LRASPIEN,1),1,32)
  1.  . W ?40,"File 62 IEN:",$$GET1^DIQ(68.05,LRASPIEN,1,"I")
  1.  . W !
  1.  Q
  1.  ;
  1.  ; ============================= UTILITIES =============================
  1.  ;
  1. VARSNEW ; EP - NEW put here to facilitate adding new routines.
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  Q
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set the BLRVERN variables
  1.  K BLRVERN,BLRVERN2
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q
  1. ENDMESG ; EP -- Display the message
  1.  W !!,?5,MESSAGE,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(10)
  1.  Q
  1.  ;
  1. ENDERQ(MESSAGE) ; EP - Function to state why routine ending.  Quits with "Q"
  1.  D ENDMESG
  1.  Q "Q"
  1.  ;
  1. CENTER(STR) ; EP - Center a string using IOM
  1.  Q $$CJ^XLFSTR(STR,$G(IOM,80))
  1.  ;
  1. LINEMSG(MSG,FILLER,TAB) ; EP - Demarcation line, Version 2
  1.  S MSG="@"_$TR(MSG," ","@")_"@"
  1.  S MSG=$TR($$CJ^XLFSTR(MSG,(IOM-$S(+$G(TAB):TAB*2,1:0)))," @",FILLER_" ")
  1.  W ?($S(+$G(TAB):TAB-1,1:0)),MSG,!
  1.  Q
  1.  ;
  1. NAMEPRT(DFN,CONVERT) ;EP; return printable name
  1.  ;CONVERT=1 means convert to mixed case letters
  1.  NEW VADM,X
  1.  D DEM^VADPT
  1.  S X=$P($P(VADM(1),",",2)," ")_" "_$P(VADM(1),",")
  1.  I $G(CONVERT) X ^DD("FUNC",14,1)
  1.  Q X