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

BLROLOR.m

Go to the documentation of this file. 
  1. BLROLOR ; IHS/MSC/MKK - Open Lab Orders Report ; 13-Oct-2017 14:04 ; MKK
  1.  ;;5.2;LAB SERVICE;**1041**;NOV 1, 1997;Build 23
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1.  ;
  1. EP ; EP
  1. PEP ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  D ADDTMENU^BLRGMENU("REPORT^BLROLOR","Report by Order Number")
  1.  D ADDTMENU^BLRGMENU("PROVRPT^BLROLOR","Report by Ordering Provider")
  1.  ;
  1.  D MENUDRVR^BLRGMENU("RPMS Lab","Open Lab Orders Reports")
  1.  Q
  1.  ;
  1.  ;
  1. REPORT ; EP - Main Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$REPORTI("Order Number Sort")="Q"
  1.  ;
  1.  F  S ORDERN=$O(^LRO(69,"C",ORDERN))  Q:ORDERN<1!(QFLG="Q")  D
  1.  . S CNTORD=CNTORD+1
  1.  . S (ACTUSER,LRASFND,LRODT)=0
  1.  . F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1!(QFLG="Q")!(LRASFND)!(ACTUSER)  D
  1.  .. S LRSP=0
  1.  .. F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")!(LRASFND)!(ACTUSER)  D
  1.  ... S LROIEN=LRSP_","_LRODT
  1.  ... S ORDPROVI=$$GET1^DIQ(69.01,LROIEN,7,"I")
  1.  ... I ORDPROVI="" S ACTUSER=1  Q
  1.  ... ;
  1.  ... S ACTUSER=$$ACTIVE^XUSER(ORDPROVI)
  1.  ... Q:ACTUSER  ; Skip if Active User
  1.  ... ;
  1.  ... S LROT=0
  1.  ... F  S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT))  Q:LROT<1!(QFLG="Q")!(LRASFND)  S LRASFND=$$LRASFND()
  1.  . ;
  1.  . Q:ACTUSER!(LRASFND)    ; Skip if Active Provider OR Accession Number tied to Order
  1.  . ;
  1.  . S LRODT=0
  1.  . F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1!(QFLG="Q")!(ACTUSER)  D
  1.  .. S LRSP=0
  1.  .. F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")!(ACTUSER)  D REPORTL
  1.  ;
  1.  W !!,?4,CNTORD," Orders analyzed."
  1.  W !!,?9,CNT," Order",$$PLURAL(CNT)," with Non-Active Provider",$$PLURAL(CNT),"."
  1.  ;
  1.  D ^%ZISC
  1.  ;
  1.  I WOTDEV'["VT" D
  1.  . W !!,?4,CNTORD," Orders analyzed."
  1.  . W !!,?9,CNT," Orders with Non-Active Providers."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. REPORTI(HEDSUB2) ; EP - Initialization
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="Non-Accessioned Orders"
  1.  S HEADER(2)="With Non-Active Providers"
  1.  S HEADER(3)=$$CJ^XLFSTR(HEDSUB2,IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  I HEDSUB2="Order Number Sort" D ^%ZIS  D:'POP HEADERDT^BLRGMENU  I POP Q $$BADSTUFQ("%ZIS Call Issue.")
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S WOTDEV=IOST
  1.  ;
  1.  S HEADER(4)=" "
  1.  S $E(HEADER(5),20)=$TR($$CJ^XLFSTR("@Ordering@Provider@",28)," @","= ")
  1.  S $E(HEADER(5),50)=$TR($$CJ^XLFSTR("@Patient@",31)," @","= ")
  1.  S HEADER(6)="Order #"
  1.  S $E(HEADER(6),10)="Ord Dt"
  1.  S $E(HEADER(6),20)="IEN"
  1.  S $E(HEADER(6),30)="Name"
  1.  S $E(HEADER(6),50)="IEN"
  1.  S $E(HEADER(6),60)="Name"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,CNTORD,ORDERN,PG)=0,QFLG="NO"
  1.  U IO
  1.  Q "OK"
  1.  ;
  1. REPORTL ; EP - Line of Data
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  ;
  1.  D REPORTB
  1.  ;
  1.  W ORDERN
  1.  W ?9,$$FMTE^XLFDT(ORDTT,"2DZ")
  1.  W ?19,ORDPROVI
  1.  W ?29,$E(ORDPROVN,1,18)
  1.  W ?49,DFN
  1.  W ?59,$E(PATNAME,1,21)
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1. REPORTB ; EP - Break out Data
  1.  S LROIEN=LRSP_","_LRODT
  1.  S LRDFN=$$GET1^DIQ(69.01,LROIEN,.01,"I")      ; Patient's Lab Number
  1.  S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")            ; Patient's File 2 IEN
  1.  S PATNAME=$$GET1^DIQ(2,DFN,.01)               ; Patient's Name
  1.  S ORDTT=$$GET1^DIQ(69.01,LROIEN,5,"I")        ; Ordering Date/Time
  1.  S ORDPROVI=$$GET1^DIQ(69.01,LROIEN,7,"I")
  1.  S ORDPROVN=$$GET1^DIQ(69.01,LROIEN,7)         ; Ordering Provider
  1.  S ORDLOCI=$$GET1^DIQ(69.01,LROIEN,23,"I")
  1.  S ORDLOCN=$$GET1^DIQ(69.01,LROIEN,23)         ; Ordering Location
  1.  Q
  1.  ;
  1.  ;
  1. PROVRPT ; EP - Report by Ordering Provider
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$REPORTI("Ordering Provider Sort")="Q"
  1.  ;
  1.  K ^TMP("BLROLOR",$J)
  1.  ;
  1.  W ?4,"Compiling"
  1.  F  S ORDERN=$O(^LRO(69,"C",ORDERN))  Q:ORDERN<1!(QFLG="Q")  D
  1.  . S CNTORD=CNTORD+1
  1.  . I (CNTORD#100)=0 W "."  W:$X>74 !,?4
  1.  . S (ACTUSER,LRASFND,LRODT)=0
  1.  . K ORDPROV
  1.  . F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1!(QFLG="Q")!(LRASFND)!(ACTUSER)  D
  1.  .. S LRSP=0
  1.  .. F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")!(LRASFND)!(ACTUSER)  D
  1.  ... S LROIEN=LRSP_","_LRODT
  1.  ... S ORDPROVI=$$GET1^DIQ(69.01,LROIEN,7,"I")     ; Ordering Provider
  1.  ... I ORDPROVI="" S ACTUSER=1  Q
  1.  ... ;
  1.  ... S ACTUSER=$$ACTIVE^XUSER(ORDPROVI)
  1.  ... Q:ACTUSER  ; Skip if Active User
  1.  ... ;
  1.  ... S ORDPROV($$GET1^DIQ(69.01,LROIEN,7),ORDPROVI,LRODT,LRSP)=ORDERN
  1.  ... S LROT=0
  1.  ... F  S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT))  Q:LROT<1!(QFLG="Q")!(LRASFND)  S LRASFND=$$LRASFND()
  1.  . ;
  1.  . Q:ACTUSER!(LRASFND)    ; Skip if Active Provider OR Accession Number tied to Order
  1.  . ;
  1.  . M ^TMP("BLROLOR",$J,"PROV")=ORDPROV
  1.  ;
  1.  W !,?4,"Compilation Complete."
  1.  ;
  1.  I $D(^TMP("BLROLOR",$J))<1 D ^%ZISC  D BADSTUFF("No Open Lab Orders.")  Q
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D ^%ZIS
  1.  Q:POP $$BADSTUFQ("%ZIS Call Issue.")
  1.  S WOTDEV=IOST
  1.  U IO
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  ;
  1.  S ORDPROVN=""
  1.  F  S ORDPROVN=$O(^TMP("BLROLOR",$J,"PROV",ORDPROVN))  Q:ORDPROVN=""!(QFLG="Q")  D
  1.  . S ORDPROVI=0
  1.  . F  S ORDPROVI=$O(^TMP("BLROLOR",$J,"PROV",ORDPROVN,ORDPROVI))  Q:ORDPROVI<1!(QFLG="Q")  D
  1.  .. S LRODT=0
  1.  .. F  S LRODT=$O(^TMP("BLROLOR",$J,"PROV",ORDPROVN,ORDPROVI,LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  ... S LRSP=0
  1.  ... F  S LRSP=$O(^TMP("BLROLOR",$J,"PROV",ORDPROVN,ORDPROVI,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .... S ORDERN=$G(^TMP("BLROLOR",$J,"PROV",ORDPROVN,ORDPROVI,LRODT,LRSP))
  1.  .... D REPORTL
  1.  ;
  1.  W !!,?4,CNTORD," Orders analyzed."
  1.  W !!,?9,CNT," Order",$$PLURAL(CNT)," with Non-Active Provider",$$PLURAL(CNT),"."
  1.  ;
  1.  D ^%ZISC
  1.  ;
  1.  I WOTDEV'["VT" D
  1.  . W !!,?4,CNTORD," Orders analyzed."
  1.  . W !!,?9,CNT," Order",$$PLURAL(CNT)," with Non-Active Provider",$$PLURAL(CNT),"."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1.  ;
  1.  ; ***************************** Utilities *****************************
  1.  ;
  1. JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
  1.  K BLRVERN,BLRVERN2
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=$G(TWO)
  1.  Q
  1.  ;
  1. BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
  1.  S TAB=$S($L($G(TAB))<1:4,1:TAB)
  1.  W !!,?TAB,STR,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(TAB+5)
  1.  Q
  1.  ;
  1. BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message.  Ends with Q "Q"uit
  1.  D BADSTUFF(STR,$G(TAB))
  1.  Q "Q"
  1.  ;
  1. PLURAL(CNT) ; EP - If CNT'=1, return S else return ""
  1.  Q $S(CNT=1:"",1:"s")
  1.  ;
  1. PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
  1.  Q $S(CNT=1:"y",1:"ies")
  1.  ;
  1. LRASFND() ; EP - Determine if order's Test has an accession attached to it
  1.  S LROTIEN=LROT_","_LRSP_","_LRODT
  1.  S LRAD=$$GET1^DIQ(69.03,LROTIEN,2,"I")
  1.  S LRAA=$$GET1^DIQ(69.03,LROTIEN,3,"I")
  1.  S LRAN=$$GET1^DIQ(69.03,LROTIEN,4,"I")
  1.  I LRAA!(LRAD)!(LRAN) Q 1
  1.  E  Q 0