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

LRLIST.m

Go to the documentation of this file. 
  1. LRLIST ;SLC/RWF/CJS - LAB RESULTS LIST ;2/19/91  10:39 [ 04/14/2003  9:05 AM ]
  1.  ;;5.2T9;LR;**1004,1006,1018**;Nov 17, 2004
  1.  ;;5.2;LAB SERVICE;**44,86,153**;Sep 27, 1994
  1.  W !,"Summary List (Supervisors')  >>> NOT FOR WARD USE <<<",!
  1. EN K ^TMP("LR",$J),LRAA
  1.  D DATE^LRWU G END:Y<1 S LRAD=Y,DIC="^LRO(68,",DIC(0)="AEQ",LRNL=0
  1.  S LRRDT=$$DDDATE^LRAFUNC1(Y,1)
  1.  F  D ^DIC Q:Y<1  D CHKDAT^LRLSTWRL Q:Y<1  S DIC("A")="ANOTHER ONE: ",LRNL=LRNL+1,LRAA(LRNL)=+Y,LRAA(LRNL,1)=$P(Y,U,2),LRSS(LRNL)=$P(^LRO(68,LRAA(LRNL),0),U,2)
  1.  K DIC G EN:$G(LRNL)<1
  1.  S LRDATE=-1 I $P(^LRO(68,LRAA(1),0),U,2)="MI" S %DT("A")="Report date approved to display: " D DATE^LRWU G END:$G(LREND) S LRDATE=Y
  1. C K DIRUT,DIR S DIR("A")="List By",DIR(0)="S^1:ACCESSION NUMBER;2:PATIENT"
  1.  D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
  1.  S LRX=Y
  1.  D RANGE G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) C
  1. INST K DIR S DIR(0)="PO^4:AQENM",DIR("A")="Optional -  Select Collecting Institution "
  1.  F  D ^DIR Q:Y=""!($E(Y=U))!(Y<1)  S:Y LRINST=+Y,LRINST(LRINST)="",DIR("A")="Select Another Collecting Institution "
  1.  K DIR,DIRUT G:$E(Y)=U END
  1. ALL W !!?5,"Do you wish to see all tests including Common Accessions " S %=1 D YN^DICN G:%=0 ALL G:%<1 END S:%=1 LRALL=""
  1.  S %ZIS="MQ" D ^%ZIS G END:POP
  1.  I $D(IO("Q")) S ZTRTN="DQ^LRLIST",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
  1. C2 S $P(LREQ,"=",IOM)="",S=1 K DX S DX(0)="Q"
  1.  I $E(IOST,1,2)="C-" S DX(0)="S S=$Y I S>(IOSL-8) N X,Y K DIR S DIR(0)=""E"" D ^DIR K DIR S S=$S($D(DIRUT):0,1:1) Q:$D(DIRUT)  W @IOF D HDR^LRLIST S S=$S($D(DIRUT):0,1:1)"
  1.  I IOST?1"P".E S DX(0)="S S=$Y I S>(IOSL-8) W @IOF D HDR^LRLIST S S=$Y"
  1.  U IO D HDR G L10:LRX=1,L20:LRX=2,END
  1. L10 I $D(LRALL) F LRAA=1:1:LRNL F LRL=LRFAN-1:0 S LRL=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL)) Q:(LRL>LRLAN)!(LRL<LRFAN)!(S=0)  S ^TMP("LR",$J,LRL,LRAA)=""
  1.  I '$D(LRALL) F LRAA=1:1:LRNL S LRL=LRFAN-1 F  S LRL=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL)) Q:(LRL>LRLAN)!(LRL<LRFAN)  I $O(^(LRL,4,0)) S ^TMP("LR",$J,LRL,LRAA)=""
  1.  F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,LRAN)) Q:LRAN<1!($D(DIRUT))!($D(DUOUT))!($D(DUOUT))  F LRAA=0:0 S LRAA=$O(^TMP("LR",$J,LRAN,LRAA)) Q:LRAA<1  D PR Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
  1.  W !! G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
  1.  W "END OF REPORT",! G END
  1. L20 F LRAA=1:1:LRNL D L22 Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
  1.  S LRPNM=""
  1.  ;F  S LRPNM=$O(^TMP("LR",$J,LRPNM)) Q:LRPNM=""!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))  S PNM=$P(LRPNM,U),SSN=$P(LRPNM,U,2) D L26
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  F  S LRPNM=$O(^TMP("LR",$J,LRPNM)) Q:LRPNM=""!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))  S PNM=$P(LRPNM,U),HRCN=$P(LRPNM,U,2) D L26  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1.  W !! G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
  1.  W !,"END OF REPORT",! G END
  1. L22 F LRAN=LRFAN-1:0 S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN)!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0)  D L23
  1.  Q
  1. L23 I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
  1.  I $G(LRINST),'$D(LRINST(+$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3))) Q
  1.  ;Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))  Q:'$D(^(3))  S LRDFN=+^(0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX S:$L(PNM) ^TMP("LR",$J,PNM_U_SSN,LRAA,LRAN)=DOB Q
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))  Q:'$D(^(3))  S LRDFN=+^(0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX S:$L(PNM) ^TMP("LR",$J,PNM_U_HRCN,LRAA,LRAN)=DOB Q  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1. L26 F LRAA=0:0 S LRAA=$O(^TMP("LR",$J,LRPNM,LRAA)) Q:LRAA<1!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0)  D L28
  1.  Q
  1. L28 F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,LRPNM,LRAA,LRAN)) Q:LRAN<1!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0)  D PR
  1.  Q
  1. PR ;
  1.  I '$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)) W !!?10," Accession ",LRAN," deleted ",!!,$C(7) Q
  1.  I $G(LRINST),'$D(LRINST(+$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3))) Q
  1.  Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3))
  1.  S LRIDT=9999999-^(3),LRDFN=+^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),LRINT=$P(^(0),U,5),LRODT=$P(^(0),U,4) G PR1:LRDATE<1
  1.  S LRSET=0 F I=1,5,8,11,16 I $D(^LR(LRDFN,"MI",LRIDT,I)),+^(I)=LRDATE S LRSET=1 Q
  1.  Q:'LRSET
  1. PR1 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX
  1.  ;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y K DIR S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0)  W @IOF D HDR S S=$Y
  1.  ;I IOST?1"P".E&($Y>(IOSL-6)) W @IOF D HDR ;ONLY FOR USE ON A PRINTER
  1.  X DX(0) Q:S=0
  1.  ;D DASH^LRX W !!,PNM,?40,SSN,!,LRAA(LRAA,1)," ACC:  ",$S($D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")
  1.  ;----- BEGIN IHS MODIFICATIONS
  1.  D DASH^LRX W !!,PNM,?40,HRCN,!,LRAA(LRAA,1)," ACC:  ",$S($D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1.  W ?45,$S($D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.1)):"  ORDER #: "_^(.1),1:"")
  1.  I LRINT S LRINT=$S($D(^LRO(69,LRODT,1,LRINT,0)):$P(^(0),U,2),1:"") I LRINT S LRINT=$P($G(^VA(200,LRINT,0)),U,1) W !,"Person placing order: ",LRINT
  1.  I $D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4)) D
  1.  .  S LRIN=+$O(^(4,"B",0))
  1.  .  I LRIN,$D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4,LRIN)) D
  1.  ..  S LRIN=$P($G(^(LRIN,0)),U,4)
  1.  ..  S:$G(LRIN) LRIN=$E($P(^VA(200,LRIN,0),U),1,10)
  1.  ..  W:$L(LRIN) "   Person performing test: ",LRIN
  1.  X DX(0) Q:S=0
  1.  I '$D(LRSS(+$G(LRAA))) W !," ACCESSION #: ",LRAN," HAS AN ERROR NOTIFY SYSTEM MANAGER >>> ",!! Q
  1.  IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN,"  >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
  1.  W ! S DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""",",DR="0"_$S(LRLONG:":99999999",1:""),DA=LRIDT
  1.  X DX(0) Q:S=0  D EN^LRDIQ Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
  1.  I $G(LRLONG)=2 F DR="ORU","ORUT" Q:S=0  X DX(0) Q:S=0  D EN^LRDIQ Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
  1.  Q
  1. TOF Q:S=0  X DX(0)
  1.  ;S S=$Y I $E(IOST,1,2)="P-",$Y>(IOSL-6) W @IOF D HDR S S=$Y Q
  1.  ;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0)  W @IOF D HDR S S=$Y
  1.  Q
  1. END W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
  1.  K DIC,D1,DIR,A,AGE,DFN,DOB,DR,LRAN,LRINST,S,SEX,T,ZZ,ZZY
  1.  K LRNG1,LRNG11,LRNG12,LRNG2,LRNG3,LRNG4,LRNG5
  1.  K DTOUT,DUOUT,DIRUT,LR,LRDFN,LRDPF,LRIDT,LRODT,LRPRAC,LRRB,LRTREA,LRWRD,PNM
  1.  K SSN,VA,LREQ
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  K SSN,HRCN,VA,LREQ  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1.  K ^TMP("LR",$J),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H
  1.  K C1,D0,DA,DICS,DL,DSC,DX,LRL,LAST,LRAA,LRAD,LRALL,LRDX,LREDT,LREND,LRFAN
  1.  K LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q")
  1.  ;D KVAR^VADPT Q
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT") Q  ;IHS/DIR TUC/AAB 06/19/98
  1.  ;----- END IHS MODIFICATIONS
  1. HDR I $G(LRDBUG),$S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,S=0:1,1:0) W !,"88888"
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
  1.  I '$G(LRRPG) S LRRPG=1 W:$E(IOST,1,2)="C-" @IOF
  1. HD1 W "SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
  1.  W "     >> NOT FOR WARD USE <<" W:$L(LRRDT)=4 ?40,"Report for date: ",$$FMTE^XLFDT($S(LRDATE>0:LRDATE,1:$$NOW^XLFDT),"D")
  1.  W !,"ACCESSION AREA(S) :" F ZZ=1:1:LRNL W LRAA(ZZ,1),"   "
  1.  I $O(LRINST(0)) W !,"Collecting Site(s) " S ZZ=0 F  S ZZ=$O(LRINST(ZZ)) Q:ZZ=""  W $P(^DIC(4,ZZ,0),U)," / "
  1.  W !,LREQ S S=$Y
  1.  S LRRPG=LRRPG+1
  1.  Q
  1. RANGE K DIR,DIRUT S DIR("B")="S",DIR(0)="S^L:LONG;S:SHORT;E:EXTENDED",LRLONG=0
  1.  S DIR("?")="Long listing shows verified results where short list does not."
  1.  S DIR("?",1)="Extened provides demographics results and normal ranges."
  1.  D ^DIR K DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
  1.  S LRLONG=$S(Y["L":1,Y["E":2,1:0)
  1.  D LRAN^LRWU3 Q
  1. TST S LRAA(1)=42,LRAA(1,1)="CHEMISTRY",LRNL=1,LRALL="",LRSS(1)="CH"
  1.  ;LRAD=DATE TO SCAN,LRRDT=DATE PRINT FORMAT,LRFAN=STARTING NUMBER
  1.  ;LRX=REPORT SORT,LRLAN=LAST ACCESSION #
  1. DQ U IO S:$D(ZTQUEUED) ZTREQ="@"
  1.  S:'$D(LRLONG) LRLONG=1
  1.  I '$G(LRAD) S X="T-1",%DT="X" D ^%DT S LRAD=Y
  1.  I '$L($G(LRRDT)) S LRRDT=$$DDDATE^LRAFUNC1(LRAD)
  1.  S:'$G(LRX) LRX=2 S:'$D(LRFAN) LRFAN=1
  1.  S:'$G(LRLAN) LRLAN=30
  1.  S:'$G(LRDATE) LRDATE=-1
  1.  G C2