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

BLRUTIL5.m

Go to the documentation of this file. 
  1. BLRUTIL5 ;IHS/ITSC/TPF - MISC IHS LAB UTILITIES (Cont) ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
  1.  ;
  1.  ; Following subroutines pulled from BLRUTIL routine because BLRUTIL was becoming too large.
  1.  ;
  1.  ; Original code follows:
  1.  ;
  1.  ;THE FOLLOWING IS A FIX FOR PATCH 10 THAT LEFT PARENTS
  1.  ;WITH 'STATUS FLAG' NOT SET PROPERLY
  1. PAT10FIX(BORDDATE,EORDDATE) ; EP
  1.  ;^BLRTXLOG("AOT",3010227.085637,1,9999044,6150)=""
  1.  N BLR
  1.  S BLR="^BLRPAR"
  1.  I $$KILLOK^ZIBGCHAR($P(BLR,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(BLR,U,2)))_"    "_BLR
  1.  K @BLR
  1.  S U="^"
  1.  S ORDDATE=BORDDATE-1
  1.  F  S ORDDATE=$O(^BLRTXLOG("AOT",ORDDATE)) Q:ORDDATE=""!(ORDDATE>EORDDATE)  D
  1.  .S PANEL=""
  1.  .F  S PANEL=$O(^BLRTXLOG("AOT",ORDDATE,PANEL)) Q:PANEL=""  D
  1.  ..S TESTPTR=""
  1.  ..F  S TESTPTR=$O(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR)) Q:TESTPTR=""  D
  1.  ...S SEQNUM=""
  1.  ...F  S SEQNUM=$O(^BLRTXLOG("AOT",ORDDATE,PANEL,TESTPTR,SEQNUM)) Q:SEQNUM=""  D
  1.  ....;
  1.  ....S LOGREC0=$G(^BLRTXLOG(SEQNUM,0))
  1.  ....S LOGREC1=$G(^BLRTXLOG(SEQNUM,1))
  1.  ....S NOPARENT=$P(LOGREC1,U)
  1.  ....W !,LOGREC1
  1.  ....I 'NOPARENT W !,"PARENT: ",SEQNUM S ^BLRPAR(SEQNUM)="" Q
  1.  ....W !,"CHILD: ",SEQNUM
  1.  ....S STATUS=$P(LOGREC0,U,2)
  1.  ....S CPTCODE=$P(LOGREC1,U,11)
  1.  ....S ^BLRPAR(NOPARENT,SEQNUM)=""
  1.  ....;
  1.  Q
  1.  ;
  1.  ;FIND BAD CH or mi ZERO NODES
  1. FIXCH S U="^",COUNT=0
  1.  S LRDFN=0,TARDATE=6959869.8   ;1/29 AT 12:00
  1.  F  S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN  D
  1.  .S LRIDT=0
  1.  .F  S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:(LRIDT="")  D
  1.  ..;W !,9999999-LRIDT
  1.  ..;NOTE: NOTE P^7 should be p10 when doing ch 
  1.  ..Q:($P(^LR(LRDFN,"CH",LRIDT,0),U,5)'=""&($P(^LR(LRDFN,"CH",LRIDT,0),U,10)'=""))
  1.  ..S COUNT=COUNT+1
  1.  ..;W !,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$G(^LR(LRDFN,"CH",LRIDT,0))
  1.  ..S LRNODE="^LR("_LRDFN_",""CH"","_LRIDT_",0)"
  1.  ..S LRUID=$G(^LR(LRDFN,"CH",LRIDT,"ORU"))
  1.  ..I 'LRUID W !,"MISSING ""ORU"" NODE IN FILE 63"_"^LR("_LRDFN_",""CH"","_LRIDT_",0)" Q
  1.  ..S LRPROV=$P(^LR(LRDFN,"CH",LRIDT,0),U,10)  ;FOR CH SUBSCRIPT ONLY
  1.  ..S LRSPEC=$P(^LR(LRDFN,"CH",LRIDT,0),U,5)
  1.  ..;
  1.  ..S FLAG=0
  1.  ..D GETMISS(LRUID,.FLAG)  ;GO TO LRO(68 AND FIND MISSING DATA
  1.  ..I FLAG W !,"PROBLEM WITH UID ",LRUID," ""C"" X-REF IN LRO(68" Q
  1.  ..W !!,"^LR("_LRDFN_",""CH"","_LRIDT_",0)="_$G(^LR(LRDFN,"CH",LRIDT,0))
  1.  ..W !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
  1.  ..W !,"FILE 63 PROV ENTRY IS: ",LRPROV,"  SHOULD BE: ",GPROV
  1.  ..W !,"FILE 63 SPEC ENTRY IS: ",LRSPEC,"  SHOULD BE: ",GSPEC
  1.  ..W !,"FIX MADE TO LR NODE: ",LRNODE
  1.  ..;UNCOMMENT FOLLOWING LINES TO DO FIX
  1.  ..;I LRPROV="" S $P(@LRNODE,U,10)=GPROV  ;FOR CH
  1.  ..;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
  1.  Q
  1.  ;
  1. GETMISS(UID,FLAG) ; EP
  1.  S ACCAREA=$O(^LRO(68,"C",UID,"")) I ACCAREA="" S FLAG=1 Q
  1.  S ACCDAT=$O(^LRO(68,"C",UID,ACCAREA,"")) I ACCAREA="" S FLAG=1 Q
  1.  S ACCNUM=$O(^LRO(68,"C",UID,ACCAREA,ACCDAT,"")) I ACCAREA="" S FLAG=1 Q
  1.  ;
  1.  S GPROV=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,0)),U,8)  ;GOOD PROV ENTRY
  1.  S GSPEC=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,5,1,0)),U)  ;GOOD SPEC ENTRY
  1.  S ACCESSN=$P($G(^LRO(68,ACCAREA,1,ACCDAT,1,ACCNUM,.2)),U)    ;ACCESSION
  1.  S NODE="LRO(68,"_ACCAREA_",1,"_ACCDAT_",1,"_ACCNUM_",0)"      ;ACCESSION NODE
  1.  Q
  1.  ;
  1. FIXMI ; EP
  1.  S U="^",COUNT=0
  1.  S LRDFN=0,TARDATE=6959869.8   ;1/29 AT 12:00
  1.  S TARDATE=0
  1.  F  S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN  D
  1.  .S LRIDT=0
  1.  .F  S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:(LRIDT="")  D
  1.  ..;W !,9999999-LRIDT    
  1.  ..;Q:($P(^LR(LRDFN,"MI",LRIDT,0),U,5)'=""&($P(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")&
  1.  ..Q:$P(^LR(LRDFN,"MI",LRIDT,0),U,11)'=0&($P(^LR(LRDFN,"MI",LRIDT,0),U,7)'="")
  1.  ..S COUNT=COUNT+1
  1.  ..;W !,"^LR("_LRDFN_",""MI"","_LRIDT_",0)="_$G(^LR(LRDFN,"MI",LRIDT,0))
  1.  ..S LRNODE="^LR("_LRDFN_",""MI"","_LRIDT_",0)"
  1.  ..S LRPROV=$P(^LR(LRDFN,"MI",LRIDT,0),U,7)  ;FOR MI SUBSCRIPT ONLY
  1.  ..S LRSPEC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
  1.  ..S LRCOL=$P(^LR(LRDFN,"MI",LRIDT,0),U,11)
  1.  ..;
  1.  ..S ACCESSN=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
  1.  ..S ACCNUM=$P(ACCESSN," ",3)
  1.  ..S ACCYR=$P(ACCESSN," ",2)
  1.  ..S ACCDT="3"_ACCYR_"0000"
  1.  ..S ACCAREA=5
  1.  ..;
  1.  ..W !!,LRNODE_"="_@LRNODE
  1.  ..S NODE="^LRO(68,"_ACCAREA_",1,"_ACCDT_",1,"_ACCNUM_",0)"
  1.  ..;W !,"MATCHES TO: ",NODE_"="_@NODE
  1.  ..;
  1.  ..W !,"FOUND ACCESSION: ",ACCESSN," AT ",NODE
  1.  ..S GPROV=$P(@NODE,U,8)
  1.  ..S GSPEC=$P($G(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0)),U)
  1.  ..W !,"FILE 63 PROV ENTRY IS: ",LRPROV,"  SHOULD BE: ",GPROV
  1.  ..W !,"FILE 63 SPEC ENTRY IS: ",LRSPEC,"  SHOULD BE: ",GSPEC
  1.  ..W !,"FIX MADE TO LR NODE: ",LRNODE
  1.  ..W !,"TESTS FOUND:"
  1.  ..D GETTESTS
  1.  ..;B "S+"
  1.  ..I CNT=1 D
  1.  ...S $P(@LRNODE,U,11)=GCOLSAMP
  1.  ...S $P(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,5,1,0),U,2)=GCOLSAMP
  1.  ..;I LRPROV="" S $P(@LRNODE,U,7)=GPROV   ;FOR MI
  1.  ..;I LRSPEC="" S $P(@LRNODE,U,5)=GSPEC
  1.  Q
  1.  ;
  1. GETTESTS ; EP
  1.  S LRTST=0
  1.  F  S LRTST=$O(^LRO(68,ACCAREA,1,ACCDT,1,ACCNUM,4,LRTST)) Q:'LRTST  D
  1.  .S TSTNAME=$P($G(^LAB(60,LRTST,0)),U)
  1.  .W !?5,LRTST_":"_$P($G(^LAB(60,LRTST,0)),U)
  1.  .W !,"COLLECTION SAMPLES FOUND FOR TEST ",LRTST
  1.  .D COLSAMP
  1.  .W !,"COLLECTION SAMPLES FOUND ",CNT
  1.  Q
  1.  ;
  1. COLSAMP ;^LAB(60,1,3,1,0)=3^SUPERBILL^LAVENDER^
  1.  S GCOLSAMP=0
  1.  S COLSAMP=0
  1.  F CNT=0:1 S COLSAMP=$O(^LAB(60,LRTST,3,COLSAMP)) Q:'COLSAMP  D
  1.  .S COLIEN=$P($G(^LAB(60,LRTST,3,COLSAMP,0)),U)
  1.  .W !?5,"COLLECTION SAMPLE: ",COLIEN,":",$P($G(^LAB(62,COLIEN,0)),U)
  1.  I CNT=1 S GCOLSAMP=$P($G(^LAB(60,LRTST,3,1,0)),U)
  1.  W CNT
  1.  Q
  1.  ;
  1.  ; =========================================================================================
  1.  ; Following code moved here from BLRUTIL3
  1.  ; =========================================================================================
  1.  ;
  1. INSTLRPT ; EP -- Report of ^BLRINSTL global
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D INSTLRPI
  1.  ;
  1.  F  S CP=$O(^BLRINSTL("LAB PATCH",CP),-1)  Q:CP<1!(QFLG="Q")  D
  1.  . F  S CNT=$O(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))  Q:CNT<1!(QFLG="Q")  D
  1.  .. D INSTLRPL
  1.  Q
  1.  ;
  1. INSTLRPI ; EP -- Initialize variables
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  ;
  1.  S HEADER(1)="IHS LAB Patches Report"
  1.  ;
  1.  S FRSTPTCH=$O(^BLRINSTL("LAB PATCH",0))
  1.  S FIRST=$O(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))
  1.  S FIRSTDT=$P($G(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")
  1.  ;
  1.  S LASTPTCH=$O(^BLRINSTL("LAB PATCH","A"),-1)
  1.  S LAST=$O(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)
  1.  S LASTDT=$P($G(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")
  1.  ;
  1.  S HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),5)="Patch"
  1.  S $E(HEADER(4),15)="Who"
  1.  S $E(HEADER(4),45)="When"
  1.  ;
  1.  S MAXLINES=20,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
  1.  S CNT=0
  1.  S CP="A"
  1.  Q
  1.  ;
  1. INSTLRPL ; EP -- Line of Data
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"
  1.  ;
  1.  W ?4,CP
  1.  W ?14,$G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
  1.  W ?44,$TR($P($G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")
  1.  W !
  1.  S LINES=LINES+1
  1.  Q
  1.  ;
  1. ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.
  1.  NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB
  1.  NEW REVSTS
  1.  ;
  1.  ; If E-SIG not turned on, Quit
  1.  I '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$G(DUZ(2))) Q
  1.  ;
  1.  S DOCIEN=$O(^VA(200,"B",LRDOC,""))      ; LRDOC = Ordering Provider
  1.  ;
  1.  ; If no IEN, Quit. Usually happens when LRDOC="Unknown"
  1.  Q:$G(DOCIEN)=""
  1.  ;
  1.  I '($D(^BLRALAB(9009027.1,DOCIEN,0))#2) W ?56,"NOT E-SIG PARTICIPATING"  Q
  1.  I $P(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A" W ?53,"INACTIVE E-SIG PARTICIPANT"  Q
  1.  ;
  1.  ;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.
  1.  S:$G(LRSS)="" LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1.  ;
  1.  S ESIGDSTR=$G(^LR(LRDFN,LRSS,LRIDT,9009027))           ; E-SIG string Data
  1.  ;
  1.  Q:$P(ESIGDSTR,U,2)=""                                  ; NO Signing Physician
  1.  Q:$P(^BLRALAB(9009027.1,$P(ESIGDSTR,U,2),0),U,7)'="A"  ; NOT Active
  1.  ;
  1.  ; REVIEW status Data Values
  1.  S REVIEWDV=$$UP^XLFSTR($P($G(^DD(63.04,.9009025,0)),U,3))
  1.  S REVSTS=$P($P(REVIEWDV,$P(ESIGDSTR,U)_":",2),";")
  1.  ;
  1.  ; Make sure E-SIG STATUS is flush right
  1.  S TAB=IOM-(16+$L(REVSTS))
  1.  W ?TAB,"E-SIG STATUS: ",REVSTS
  1.  ;
  1.  Q:'$P(ESIGDSTR,U,5)                                    ; NO Signed Date
  1.  ;
  1.  Q:REVSTS["NOT REV"                                     ; NOT Reviewed
  1.  ;
  1.  W !?5,"SIGNING PHYSICIAN: "
  1.  W $P($G(^VA(200,$P(ESIGDSTR,U,2),0)),U)
  1.  W !?5,"DATE/TIME RESULT SIGNED: "
  1.  W $TR($$FMTE^XLFDT($P(ESIGDSTR,U,5),"2MZ"),"@"," ")
  1.  ;
  1.  Q
  1.  ;
  1. NOCOLLDT ; EP - "Quick & Dirty" Routine to determine if Accession file has no DRAW DATE but an Accession Number
  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.  K ^TMP("BLRUTIL4",$J,"NOCOLLDT")
  1.  ;
  1.  W !!,?4,"Compilation Begins"
  1.  S LRAA=.9999999,(BADCNT,CNT)=0
  1.  F  S LRAA=$O(^LRO(68,LRAA))  Q:LRAA<1  D
  1.  . S LRAD=0
  1.  . F  S LRAD=$O(^LRO(68,LRAA,1,LRAD))  Q:LRAD<1  D
  1.  .. S LRAN=0
  1.  .. F  S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN))  Q:LRAN<1  D
  1.  ... Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1        ; No Zero Node Data, skip
  1.  ... ;
  1.  ... S UID=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  ... Q:UID<1                                       ; No UID, skip
  1.  ... ;
  1.  ... S CNT=CNT+1
  1.  ... W:(CNT#100)=0 "."  W:$X>74 !,?4
  1.  ... ;
  1.  ... Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))          ; Draw Date Exists
  1.  ... ;
  1.  ... W:($L(UID)+$X)>74 !,?3
  1.  ... W " >",UID,"< "
  1.  ... W:$X>74 !,?4
  1.  ... S ^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN)=UID
  1.  ... S BADCNT=BADCNT+1
  1.  ;
  1.  S WOTCOL=$X
  1.  W:WOTCOL<(IOM-17) "Compilation Ends"
  1.  W:WOTCOL>(IOM-18) !,?4,"Compilation Ends"
  1.  ;
  1.  W !!,?4,"Number of Accessions Analyzed = ",CNT,!
  1.  W:BADCNT<1 !,?9,"All Accessions have Draw Dates",!
  1.  W:BADCNT !,?9,"# of Accessions with No Draw Date = ",BADCNT,!
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D:BADCNT NOCOLRPT
  1.  ;
  1.  K ^TMP("BLRUTIL4",$J,"NOCOLLDT")
  1.  Q
  1.  ;
  1. NOCOLRPT ; EP - Report on ^TMP("BLRUTIL4",$J,"NOCOLLDT"
  1.  S HEADER(1)="Accessions With No Draw Date"
  1.  S HEADER(2)=" "
  1.  S HEADER(3)="LRAA"
  1.  S $E(HEADER(3),6)="LRAD"
  1.  S $E(HEADER(3),15)="LRAN"
  1.  S $E(HEADER(3),25)="UID"
  1.  S $E(HEADER(3),40)="ARRIVAL TIME"
  1.  S $E(HEADER(3),55)="LRDFN"
  1.  S $E(HEADER(3),65)="INVERSE DATE"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S LRAA=0
  1.  F  S LRAA=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA))  Q:LRAA<1  D
  1.  . S LRAD=0
  1.  . F  S LRAD=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD))  Q:LRAD<1  D
  1.  .. S LRAN=0
  1.  .. F  S LRAN=$O(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN))  Q:LRAN<1  D
  1.  ... S UID=+$G(^TMP("BLRUTIL4",$J,"NOCOLLDT",LRAA,LRAD,LRAN))
  1.  ... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),STR3=$G(^(3))
  1.  ... S LABARRT=$P(STR3,"^",3)
  1.  ... S LRIDT=$P(STR3,"^",5)
  1.  ... ;
  1.  ... W LRAA
  1.  ... W ?5,LRAD
  1.  ... W ?14,LRAN
  1.  ... W ?24,UID
  1.  ... W ?39,LABARRT
  1.  ... W ?54,LRDFN
  1.  ... W ?64,LRIDT
  1.  ... W !
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q