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

BLRAAORR.m

Go to the documentation of this file. 
  1. BLRAAORR ;IHS/OIT/MKK - IHS LAB ASK-AT-ORDER REPORTS ; JUL 06, 2011 3:15 PM
  1.  ;;5.2;IHS LABORATORY;**1030**;NOV 01, 1997
  1.  ;
  1.  Q
  1.  ;
  1. DATAREPT ; EP - Report on Data Global
  1.  NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRAS,LRODT,LRSP,P60,ORD,LRORDN
  1.  NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
  1.  ;
  1.  D DATARPTI
  1.  ;
  1.  F  S LRODT=$O(^BLRAAOQD(LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  . F  S LRSP=$O(^BLRAAOQD(LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .. F  S P60=$O(^BLRAAOQD(LRODT,LRSP,P60))  Q:P60<1!(QFLG="Q")  D
  1.  ... F  S ORD=$O(^BLRAAOQD(LRODT,LRSP,P60,ORD))  Q:ORD<1!(QFLG="Q")  D
  1.  .... D DATARPTL
  1.  .. W !
  1.  .. S LINES=LINES+1
  1.  ;
  1.  D:CNT<1 EMPTYDB("No Data in Lab Ask-At-Order Data file.")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. DATARPTI ; EP - Initialize variables
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S BLRVERN2="DATAREPT"
  1.  ;
  1.  S HEADER(1)="Lab Ask At Order Questions"
  1.  S HEADER(2)="Non Accessioned Responses"
  1.  S HEADER(3)=" "
  1.  ;
  1.  S HEADER(4)="Order #"
  1.  S $E(HEADER(4),10)="Test IEN"
  1.  S $E(HEADER(4),20)="Question"
  1.  S $E(HEADER(4),51)="Answer"
  1.  S $E(HEADER(4),65)="Date/Time Answrd"
  1.  ;
  1.  S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
  1.  ;
  1.  S (CNT,LRODT,LRSP,P60,ORD)=0
  1.  Q
  1.  ;
  1. DATARPTL ; EP - Write a line of data
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"
  1.  ;
  1.  D DATARPTB(29)
  1.  ;
  1.  W LRORDN            ; File 69: Order Number
  1.  W ?8,CANCEL
  1.  W ?9,P60            ; File 60: IEN
  1.  W ?19,LINEWRAP(1)   ; Question - Line 1
  1.  W ?50,ANSWER
  1.  W ?64,EHDT          ; Date/Time Question Answered
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  ;
  1.  D MULTLINE(19)
  1.  ;
  1.  Q
  1.  ;
  1. DATARPTB(MAXCOL) ; EP - Breakout Variables from global
  1.  NEW GLOSTR,STR,TSTORD
  1.  NEW LRAA,LRAD,LRAN,STR,TST,TEST
  1.  ;
  1.  K LRORDN,LINEWRAP,ANSWER,EHDT,HDT
  1.  ;
  1.  S LRAS=""
  1.  S TST=0
  1.  F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST!($L(LRAS))  D
  1.  . S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  . Q:+$G(STR)'=P60
  1.  . ;
  1.  . S LRAD=$P(STR,"^",4),LRAA=$P(STR,"^",3),LRAN=$P(STR,"^",5)
  1.  . S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ;
  1.  S LRORDN=$G(^LRO(69,LRODT,1,LRSP,.1))
  1.  ;
  1.  S GLOSTR=$G(^BLRAAOQD(LRODT,LRSP,P60,ORD))
  1.  S ANSWER=$P(GLOSTR,"^",2)
  1.  S HDT=$P(GLOSTR,"^",3)
  1.  S EHDT=$$HTE^XLFDT(HDT,"5MZ")
  1.  ;
  1.  S STR(1)=$P(GLOSTR,"^",1)
  1.  I $L($G(STR(1)))<MAXCOL S LINEWRAP(1)=STR(1)  Q
  1.  ;
  1.  ; Question too long; have to create multiple lines
  1.  D WRAP(.STR,MAXCOL,.LINEWRAP)
  1.  ;
  1.  S CANCEL=""
  1.  ; Determine if Test has been cancelled
  1.  S TSTORD=.9999999
  1.  F  S TSTORD=$O(^LRO(69,LRODT,1,LRSP,2,TSTORD))  Q:TSTORD<1  D
  1.  . Q:+$G(^LRO(69,LRODT,1,LRSP,2,TSTORD,0))'=P60
  1.  . ;
  1.  . S:+$P($G(^LRO(69,LRODT,1,LRSP,2,TSTORD,0)),"^",11)>0 CANCEL="*"
  1.  ;
  1.  Q
  1.  ;
  1. DATARPTA ; EP - Report on Data Global - Accession Number, not Test IEN
  1.  NEW ANSWER,CANCEL,CNT,EHDT,HDT,LRODT,LRAS,LRSP,P60,ORD,LRORDN
  1.  NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
  1.  ;
  1.  D DATRPTAI
  1.  ;
  1.  F  S LRODT=$O(^BLRAAOQD(LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  . F  S LRSP=$O(^BLRAAOQD(LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .. F  S P60=$O(^BLRAAOQD(LRODT,LRSP,P60))  Q:P60<1!(QFLG="Q")  D
  1.  ... F  S ORD=$O(^BLRAAOQD(LRODT,LRSP,P60,ORD))  Q:ORD<1!(QFLG="Q")  D
  1.  .... D DATRPTAL
  1.  .. W !
  1.  .. S LINES=LINES+1
  1.  ;
  1.  D:CNT<1 EMPTYDB("No Data in Lab Ask-At-Order Data file.")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. DATRPTAI ; EP - Initialize variables
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S BLRVERN2="DATAREPT"
  1.  ;
  1.  S HEADER(1)="Lab Ask At Order Questions"
  1.  S HEADER(2)="Non Accessioned Responses"
  1.  S HEADER(3)=" "
  1.  ;
  1.  S HEADER(4)="Order #"
  1.  S $E(HEADER(4),10)="Accession Number"
  1.  S $E(HEADER(4),30)="Question"
  1.  S $E(HEADER(4),51)="Answer"
  1.  S $E(HEADER(4),65)="Date/Time Answrd"
  1.  ;
  1.  S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
  1.  ;
  1.  S (CNT,LRODT,LRSP,P60,ORD)=0
  1.  Q
  1.  ;
  1. DATRPTAL ; EP - Write a line of data
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"
  1.  ;
  1.  D DATARPTB(19)
  1.  ;
  1.  W LRORDN            ; File 69: Order Number
  1.  W ?8,CANCEL
  1.  W ?9,LRAS           ; Accession Number
  1.  W ?29,LINEWRAP(1)   ; Question - Line 1
  1.  W ?50,ANSWER
  1.  W ?64,EHDT          ; Date/Time Question Answered
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  ;
  1.  D MULTLINE(29)
  1.  ;
  1.  Q
  1.  ;
  1. EMPTYDB(MSG) ; EP - Empty DB Message
  1.  K HEADER(3),HEADER(4)
  1.  D HEADERDT^BLRGMENU
  1.  W !!,?9,MSG,!
  1.  Q
  1.  ;
  1.  ; Cloned from LR7OSAP1.  Wrap Text in array ROOT to PUTIT array
  1. WRAP(ROOT,FMT,PUTIT) ; EP - Wrap text
  1.  I '$L($G(ROOT(1))) Q
  1.  N CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X
  1.  S:'$G(FMT) FMT=79
  1.  S LRINDX=0,LRI=0,GCNT=0
  1.  F  S LRI=$O(ROOT(LRI)) Q:LRI'>0  D
  1.  . S X=$S($L($G(ROOT(LRI))):ROOT(LRI),$L($G(ROOT(LRI,0))):ROOT(LRI,0),1:""),LRINDX=LRINDX+1
  1.  . S X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)
  1.  S LRI=0
  1.  F  S LRI=$O(LRTX(LRI)) Q:'LRI  D LN^LR7OSAP S PUTIT(GCNT)=$$S^LR7OS(1,CCNT,LRTX(LRI))
  1.  Q
  1.  ;
  1. MULTLINE(TAB) ; EP - Answer too long for one line; print rest of lines.
  1.  S WRAPLINE=1
  1.  F  S WRAPLINE=$O(LINEWRAP(WRAPLINE))  Q:WRAPLINE<1  D
  1.  . W ?TAB,LINEWRAP(WRAPLINE),!
  1.  . S LINES=LINES+1
  1.  ;
  1.  Q
  1.  ;
  1. ERRSREPT ; EP - Report on Errors Global
  1.  NEW ANSWER,CNT,EHDT,ERRSMSG,HDT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD,LRORDN
  1.  NEW BLRVERN,BLRVERN2,HEADER,HD1,LINES,LINEWRAP,MAXLINES,PG,QFLG,WRAPLINE
  1.  ;
  1.  D ERSSRPTI
  1.  ;
  1.  F  S LRDFN=$O(^BLRAAORE(LRDFN))  Q:LRDFN<1!(QFLG="Q")  D
  1.  . F  S LRIDT=$O(^BLRAAORE(LRDFN,LRIDT))  Q:LRIDT<1!(QFLG="Q")  D
  1.  .. F  S LRODT=$O(^BLRAAORE(LRDFN,LRIDT,LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  ... F  S LRSP=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .... F  S P60=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60))  Q:P60<1!(QFLG="Q")  D
  1.  ..... F  S ORD=$O(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD))  Q:ORD<1!(QFLG="Q")  D
  1.  ...... D ERSSRPTL
  1.  ;
  1.  D:CNT<1 EMPTYDB("No Data in Errors Database.")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. ERSSRPTI ; EP - Initialize variables
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S BLRVERN2="DATAREPT"
  1.  ;
  1.  S HEADER(1)="Lab Ask At Order Questions"
  1.  S HEADER(2)="Transactions With Errors"
  1.  S HEADER(3)=" "
  1.  ;
  1.  S HEADER(4)="LRDFN"
  1.  S $E(HEADER(4),10)="LRIDT"
  1.  S $E(HEADER(4),27)="LRODT"
  1.  S $E(HEADER(4),37)="LRSP"
  1.  S $E(HEADER(4),43)="Test IEN"
  1.  S $E(HEADER(4),53)="Ord"
  1.  S $E(HEADER(4),58)="Error Message"
  1.  ;
  1.  S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
  1.  ;
  1.  S (CNT,LRDFN,LRIDT,LRODT,LRSP,P60,ORD)=0
  1.  Q
  1.  ;
  1. ERSSRPTL ; EP - Write a line of data
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"
  1.  ;
  1.  S ERRMSG=$G(^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD,"DIERR",1))
  1.  ;
  1.  W LRDFN
  1.  W ?9,LRIDT
  1.  W ?26,LRODT
  1.  W ?36,LRSP
  1.  W ?42,P60
  1.  W ?52,ORD
  1.  W ?57,$E(ERRMSG,1,23)
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. ORDNREPT(LRORD) ; EP -- Report on Lab Data File Ask at Order questions given Lab Order Number
  1.  NEW LINE,LINEWRAP,LRAA,LRAD,LRAN,LRAS,LRIDT,LRODT,LRSP,PTR,STR,TST
  1.  NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
  1.  ;
  1.  D ORDNRPTI
  1.  ;
  1.  S LRODT=.9999999
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  . S LRSP=.9999999
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .. S TST=.999999
  1.  .. F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST<1!(QFLG="Q")  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  ... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
  1.  ... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ... Q:$L(LRAS)<1
  1.  ... ;
  1.  ... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  ... S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
  1.  ... ;
  1.  ... Q:LRDFN<1!(LRIDT<1)
  1.  ... ;
  1.  ... S LINE=0
  1.  ... F  S LINE=$O(^LR(LRDFN,"CH",LRIDT,1,LINE))  Q:LINE<1!(QFLG="Q")  D
  1.  .... S STR=$$TRIM^XLFSTR($G(^LR(LRDFN,"CH",LRIDT,1,LINE,0)),"LR"," ")
  1.  .... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"
  1.  .... I $L(STR)<60 D  Q
  1.  ..... W LRAS,?19,STR,!
  1.  ..... S LINES=LINES+1
  1.  .... W LRAS,?19,$E(STR,1,59),!
  1.  .... W ?19,$E(STR,60,$L(STR)),!
  1.  .... S LINES=LINES+2
  1.  Q
  1.  ;
  1. ORDNRPTI ; EP
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S BLRVERN2="DATAREPT"
  1.  ;
  1.  S HEADER(1)="Lab Ask At Order Questions"
  1.  S HEADER(2)="Lab Data Comments"
  1.  S HEADER(3)=" "
  1.  ;
  1.  S HEADER(4)="Accession #"
  1.  S $E(HEADER(4),20)="Comments"
  1.  ;
  1.  S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
  1.  ;
  1.  S (CNT,LRODT,LRSP,P60,ORD)=0
  1.  Q
  1.  ;
  1. SHOWACCS(LRORD) ;EP - Given an Order Number, show it's Accession Number(s)
  1.  NEW CNT,BLRVERN,BLRVERN2,LRAA,LRAD,LRAN,LRAS,LINE,LINEWRAP,LRIDT,LRODT,LRSP
  1.  NEW ORD,P60,PTR,STR,TST
  1.  NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
  1.  ;
  1.  D ORDNRPTI
  1.  ;
  1.  S CNT=0,LRODT=.9999999
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1!(QFLG="Q")  D
  1.  . S LRSP=.9999999
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1!(QFLG="Q")  D
  1.  .. S TST=.999999
  1.  .. F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST<1!(QFLG="Q")  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  ... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
  1.  ... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ... Q:$L(LRAS)<1
  1.  ... ;
  1.  ... W LRORD
  1.  ... W ?9,LRAS
  1.  ... W ?29,LRAA
  1.  ... W ?34,LRAD
  1.  ... W ?44,LRAN
  1.  ... W !
  1.  ... S CNT=CNT+1
  1.  ;
  1.  Q:CNT>0
  1.  ;
  1.  W !!,"No Accessions found for Order Number:",LRORD,!!
  1.  Q