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

BLRRLMU3.m

Go to the documentation of this file. 
  1. BLRRLMU3 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 3  ; 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. PEP ; EP
  1. LAHMENU ; EP - ^LAH Global 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("LAHTESTS^BLRRLMU3","62.49 Tests Report")
  1.  D ADDTMENU^BLRGMENU("LAHSPMS^BLRRLMU3","IHSSPM Values")
  1.  D ADDTMENU^BLRGMENU("LAHLRASR^BLRRLMU3","LRAS Report")
  1.  D ADDTMENU^BLRGMENU("LAHUIDS^BLRRLMU3","UIDs Report")
  1.  D ADDTMENU^BLRGMENU("LRLLUIDS^BLRRLMU3","Load/Work List UIDs Report")
  1.  D ADDTMENU^BLRGMENU("LAHDETAC^BLRRLMU3","Accession/UID Detail Report")
  1.  D ADDTMENU^BLRGMENU("DUPCINDX^BLRRLMU3","Duplicate 'C' Index Entries")
  1.  ;
  1.  ;
  1.  ; Main Menu driver
  1.  D MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("^LAH Global Reports",IOM))
  1.  Q
  1.  ;
  1. LAHTESTS ; EP - ^LAH 62.49 Tests Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D LAHTESTI
  1.  ;
  1.  F  S LAHIEN=$O(^LAH(37,1,LAHIEN))  Q:LAHIEN<1  D
  1.  . S UID=$G(^LAH(37,1,LAHIEN,.3))
  1.  . Q:$L(UID)<1
  1.  . Q:$D(^TMP("BLRRLMUU",$J,"UID",UID))<1
  1.  . ;
  1.  . W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),!
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!
  1.  ;
  1.  W:CNT<1 ?4,"No UIDs in ^LAH match 62.49",!
  1.  W:CNT ?4,"Number of UIDs in ^LAH that Match 62.49 = ",CNT,!
  1.  ;
  1.  W !,?9,"Number of UIDs in 62.49 = ",UID6249,!
  1.  ;
  1.  D PRESSKEY^BLRGMENU
  1.  Q
  1.  ;
  1. LAHTESTI ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  S HEADER(1)="^LAH NIST Entries with 62.49 Data"
  1.  ;
  1.  S HEADER(2)=" "
  1.  S $E(HEADER(3),5)="IEN"
  1.  S $E(HEADER(3),20)="UID"
  1.  S $E(HEADER(3),35)="IHSSPM"
  1.  ;
  1.  S MAXLINES=IOSL-4
  1.  S LINES=MAXLINES+10
  1.  S (CNT,PG,UID6249)=0
  1.  S (HDRONE,QFLG)="NO"
  1.  ;
  1.  D LAHTESTU(.UID6249)
  1.  ;
  1.  S LAHIEN=.9999999
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  Q
  1.  ;
  1. LAHTESTU(UID6249) ; EP - Create UID index into 62.49
  1.  NEW IEN,INST,UID
  1.  ;
  1.  K ^TMP("BLRRLMUU",$J,"UID")
  1.  ;
  1.  S INST=""
  1.  F  S INST=$O(^LAHM(62.49,"C",INST))  Q:INST=""  D
  1.  . S UID=$P(INST,"-",3)
  1.  . Q:$L(UID)<1
  1.  . ;
  1.  . S IEN=$O(^LAHM(62.49,"C",INST,"A"),-1)
  1.  . S ^TMP("BLRRLMUU",$J,"UID",UID)=IEN
  1.  . S UID6249=UID6249+1
  1.  Q
  1.  ;
  1. LAHSPMS ; EP - ^LAH IHSSPM Values
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$LAHSPMSI()="Q"
  1.  ;
  1.  F  S IEN=$O(^LAH(LOADWORK,1,IEN),-1)  Q:IEN<1  D
  1.  . Q:$D(^LAH(LOADWORK,1,IEN,"IHSSPM"))<1
  1.  . W IEN
  1.  . W ?9,$G(^LAH(LOADWORK,1,IEN,.3))
  1.  . W ?24,$E($G(^LAH(LOADWORK,1,IEN,"IHSSPM")),1,60)
  1.  . W !
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. LAHSPMSI() ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  S HEADER(1)="^LAH IHSSPM Entries"
  1.  S HEADER(2)=" "
  1.  S HEADER(3)="IEN"
  1.  S $E(HEADER(3),10)="UID"
  1.  S $E(HEADER(3),25)="IHSSPM"
  1.  ;
  1.  S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
  1.  I $G(LA7INST)=""
  1.  Q:$G(LA7INST)="" "Q"                              ; Quit with zero if no Reference Lab
  1.  ;
  1.  S AUTOIEN=+$O(^LAB(62.4,"B",LA7INST,""))          ; Auto Instrument IEN
  1.  Q:AUTOIEN<1 "Q"                                   ; Quit with zero if No Auto Instrument
  1.  ;
  1.  S LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
  1.  ;
  1.  S MAXLINES=IOSL-4
  1.  S LINES=MAXLINES+10
  1.  S (CNT,PG)=0
  1.  S (HDRONE,QFLG)="NO"
  1.  S IEN="AA"
  1.  D HEADERDT^BLRGMENU
  1.  Q "OK"
  1.  ;
  1. LAHLRASR ; EP - LAH LRAS Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D LAHLRASI
  1.  ;
  1.  F  S LAHIEN=$O(^LAH(37,1,LAHIEN))  Q:LAHIEN<1  D
  1.  . S UID=$G(^LAH(37,1,LAHIEN,.3))
  1.  . Q:$L(UID)<1
  1.  . ;
  1.  . W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),?54,$$GETLRAS(UID),!
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!
  1.  ;
  1.  W:CNT<1 ?4,"No UIDs in ^LAH",!
  1.  W:CNT ?4,"Number of UIDs in ^LAH = ",CNT,!
  1.  ;
  1.  D PRESSKEY^BLRGMENU	
  1.  Q
  1.  ;
  1. LAHLRASI ; EP - Initialization
  1.  D LAHTESTI
  1.  K HEADER(1)
  1.  S HEADER(1)="^LAH NIST Entries"
  1.  S $E(HEADER(3),55)="LRAS"
  1.  ;
  1.  S LAHIEN=.9999999
  1.  D HEADERDT^BLRGMENU
  1.  Q
  1.  ;
  1. LAHUIDS ; EP - List the UIDs found in the ^LAH global
  1.  NEW HEADER,IEN,UID,UIDCNT,UIDPTR
  1.  ;
  1.  S HEADER(1)="^LAH Global Listing"
  1.  S HEADER(2)="Entries with UIDs ONLY"
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),5)="IEN"
  1.  S $E(HEADER(4),15)="LOAD/WORK LIST"
  1.  S $E(HEADER(4),35)="UID"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S IEN=.9999999
  1.  F  S IEN=$O(^LAH(IEN))  Q:IEN<1  D
  1.  . S LOADWORK=$$GET1^DIQ(68.2,IEN,"NAME")
  1.  . S LOADWORK=$TR(LOADWORK," ","@")
  1.  . W !,?5,$TR($$CJ^XLFSTR("@LOAD/WORK@LIST:@"_LOADWORK_"@["_IEN_"]@",66)," @","= "),!
  1.  . W ?9
  1.  . S UID="AAA",UIDCNT=0
  1.  . F  S UID=$O(^LAH(IEN,1,"U",UID),-1)  Q:UID<1!(UIDCNT>19)  D
  1.  .. S UIDPTR=+$O(^LAH(IEN,1,"U",UID,0))
  1.  .. Q:$D(^LAH(IEN,1,UIDPTR))<1
  1.  .. ;
  1.  .. W $$LJ^XLFSTR(UID,12)
  1.  .. W:$X>64 !,?9
  1.  .. S UIDCNT=UIDCNT+1
  1.  . W:UIDCNT<20 !
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. LAHDETAC ; EP -- Accession/UID Detail Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$LAHDETAI()="Q"
  1.  ;
  1.  Q
  1.  ;
  1. LAHDETAI() ; EP - Initialization
  1.  Q ""
  1.  ;
  1. LRLLUIDS ; EP - Load/Work List UIDs Report
  1.  NEW HEADER,IEN,LRIFN,LRLL,LRLLDESC,UID,UIDCNT,UIDPTR
  1.  ;
  1.  S HEADER(1)="^LAH Global Listing"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D ^XBFMK
  1.  S DIR(0)="PO^68.2:AE"
  1.  D ^DIR
  1.  I +$G(DIRUT) D  Q
  1.  . W !!,?4,"Invalid/No Entry.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S LRLL=+Y
  1.  S LRLLDESC=$P(Y,"^",2)
  1.  ;
  1.  S HEADER(2)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
  1.  S HEADER(3)=$$CJ^XLFSTR("UIDs Report",IOM)
  1.  S HEADER(4)=" "
  1.  S HEADER(5)="IEN"
  1.  S $E(HEADER(5),10)="UID"
  1.  S $E(HEADER(5),25)="Accession #"
  1.  S $E(HEADER(5),40)="^LAH(LRLL,1,LRIFN,0)"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S UID="",UIDCNT=0
  1.  F  S UID=$O(^LAH(LRLL,1,"U",UID))  Q:UID<1  D
  1.  . S LRIFN=+$O(^LAH(LRLL,1,"U",UID,0))
  1.  . Q:'$D(^LAH(LRLL,1,LRIFN,0))#2
  1.  . ;
  1.  . W LRIFN
  1.  . W ?9,UID
  1.  . W ?24,$$GETLRAS(UID)
  1.  . W ?39,$E($G(^LAH(LRLL,1,LRIFN,0)),1,40)
  1.  . W !
  1.  . S UIDCNT=UIDCNT+1
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. GETLRAS(UID) ; EP - Get the Accession # from the UID
  1.  NEW X,LRAA,LRAD,LRAN
  1.  ;
  1.  S X=$Q(^LRO(68,"C",UID,0))
  1.  S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
  1.  S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  Q LRAS
  1.  ;
  1. DUPCINDX ; EP - Duplicate 'C' Index Entries
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVR
  1.  Q:$$GETLOADW()="Q"
  1.  ;
  1.  Q:$$DUPCNDXI()="Q"
  1.  ;
  1.  F  S NUM=$O(^LAH(LRLL,1,"C",NUM))  Q:NUM=""!(QFLG="Q")  D
  1.  . S CNTNUM=CNTNUM+1
  1.  . S IEN=0
  1.  . K IENCNT
  1.  . F  S IEN=$O(^LAH(LRLL,1,"C",NUM,IEN))  Q:IEN<1!(QFLG="Q")  D
  1.  .. S IENCNT=1+$G(IENCNT)
  1.  .. S IENCNT(IENCNT)=IEN
  1.  . D:IENCNT>1 DUPCNDXL
  1.  ;
  1.  W:CNT<1 !!,?4,"Number of entries for ",$G(HEADER(1))," examined = ",CNTNUM
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. SETBLRVR(TWO) ; EP - Set the BLRVERN variable(s)
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q
  1.  ;
  1. GETLOADW() ; EP - Get the LOAD/WORK LIST
  1.  NEW HEADER
  1.  S HEADER(1)="LOAD/WORK LIST"
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="PO^68.2:AE"
  1.  D ^DIR
  1.  I +$G(DIRUT) D  Q "Q"
  1.  . W !!,?4,"Invalid/No Entry.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S LRLL=+Y
  1.  S LRLLDESC=$P(Y,"^",2)
  1.  Q "OK"
  1.  ;
  1. DUPCNDXI() ; EP - Initialization
  1.  S HEADER(1)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
  1.  S HEADER(2)="Duplicate Counts"
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),5)="NUM"
  1.  S $E(HEADER(4),20)="CNT"
  1.  S $E(HEADER(4),30)="IEN"
  1.  S $E(HEADER(4),40)="UID"
  1.  S $E(HEADER(4),55)="IHSSPM"
  1.  ;
  1.  S MAXLINES=IOSL-4
  1.  S LINES=MAXLINES+10
  1.  S (CNT,CNTNUM,NUM,PG)=0
  1.  S (HDRONE,QFLG)="NO"
  1.  Q "OK"
  1.  ;
  1. DUPCNDXL ; EP - Line of Data
  1.  S CNT2=0
  1.  F  S CNT2=$O(IENCNT(CNT2))  Q:CNT2<1!(QFLG="Q")  D
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"
  1.  . S IEN2=$G(IENCNT(CNT2))
  1.  . W ?4,NUM
  1.  . W ?19,CNT2
  1.  . W ?29,IEN2
  1.  . W ?39,$G(^LAH(LRLL,1,IEN2,.3))   ; UID
  1.  . W ?54,$E($G(^LAH(LRLL,1,IEN2,"IHSSPM")),1,25)
  1.  . W !
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  Q