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

LRWRKLST.m

Go to the documentation of this file. 
  1. LRWRKLST ;DALOI/CJS/DRH-LONG ACCESSION LIST ; 13-Oct-2017 14:04 ; MKK
  1.  ;;5.2;LAB SERVICE;**1,17,38,1004,1013,153,185,221,268,1018,362,1031,1037,1041**;NOV 1, 1997;Build 23
  1.  ;
  1.  ; NOTE: LR*5.2*1031 restores LR*5.2*1018 modifications
  1.  ;
  1.  N LRDICS
  1.  ;
  1.  ; Save and restore DIC("S") if micro long form accession option (LRMIACC1).
  1.  I $D(DIC("S")) S LRDICS=DIC("S")
  1.  D LREND
  1.  I $D(LRDICS) S DIC("S")=LRDICS
  1.  ;
  1.  S LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
  1.  ;
  1.  S LREND=0
  1.  S DIC="^LRO(68,",DIC(0)="AEMOQ"
  1.  D ^DIC S LRAA=+Y,LRNAME=$P(Y,U,2)
  1.  I LRAA<1 D LREND Q
  1.  ;
  1.  ; Ask if list by date rather than accession number
  1.  I $P(^LRO(68,LRAA,0),U,3)="Y" D STAR^LRWU3 S LRLAST=$G(LAST)
  1.  I LREND D LREND Q
  1.  ; List by acccession number
  1.  I '$D(LRSTAR) D PHD
  1.  I LREND D LREND Q
  1.  ;
  1. W ;from LRVER, LRVR
  1.  ;
  1.  N DIR,DTOUT,DIRUT,DIROUT
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,0)),'$D(LRSTAR) D LREND Q
  1.  ;
  1.  S (LRUNC,LRTSE)=0
  1.  S:'$D(LRNAME) LRNAME=$P(^LRO(68,LRAA,0),U,1)
  1.  ;
  1.  S DIR(0)="YO",DIR("A")="Do you want a specific test",DIR("B")="NO"
  1.  D ^DIR
  1.  I $D(DIRUT) D LREND Q
  1.  I Y=1 D
  1.  . N DIC,X,Y
  1.  . S DIC="^LAB(60,",DIC(0)="AEZOQ"
  1.  . D ^DIC
  1.  . I Y>0 S LRTSE=+Y
  1.  ;
  1.  K DIR
  1.  S DIR(0)="YO",DIR("A")="Do you want only incomplete entries",DIR("B")="YES"
  1.  D ^DIR
  1.  I $D(DIRUT) D LREND Q
  1.  S LRUNC=Y
  1.  ;
  1.  S %ZIS="Q" D ^%ZIS
  1.  I POP D ^%ZISC,LREND Q
  1.  ;
  1.  ; Queue report via Taskman
  1.  I $D(IO("Q")) D  Q
  1.  . N ZTDESC,ZTSK,ZTRTN,ZTIO,ZTSAVE,%T
  1.  . S ZTRTN="ENT^LRWRKLST",ZTDESC="Long form accession list",ZTSAVE("LR*")=""
  1.  . D ^%ZTLOAD,^%ZISC
  1.  . W !,"Task ",$S($G(ZTSK):ZTSK,1:"NOT")," Queued"
  1.  . D LREND K IO("Q")
  1.  ;
  1. ENT ;
  1.  ;
  1.  N LRTST
  1.  ;
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  S (LREND,LRSTOP)=0
  1.  ;
  1.  ;
  1.  U IO
  1.  D HED,URG^LRX
  1.  ;
  1.  ; Process by accession date
  1.  I '$D(LRSTAR) D
  1.  . S LRAN=LRFAN-1
  1.  . F  S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LRLAN)  D  Q:LRSTOP
  1.  . . S LREND=0 D TD
  1.  . . I LREND Q
  1.  . . D LST,TESTS
  1.  ;
  1.  ; Process by date received in lab - yearly accession area
  1.  I $D(LRSTAR) D
  1.  . F  S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL)  D AC  Q:LRSTOP
  1.  ;
  1.  D ^%ZISC,LREND
  1.  Q
  1.  ;
  1.  ;
  1. TD ; Check tests on accession to determine if meets criteria to display.
  1.  ; If incomplete only (LRUNC=1) and complete date then skip
  1.  ; If not specific test selected (LRTSE=file #60 ien) then skip
  1.  ; Otherwise set LRTST array with file #60 ien.
  1.  ;
  1.  K LRTST
  1.  ;
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 Q
  1.  S LRSN=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5),LRDAT=+$P(^(0),U,4)
  1.  S LRI=0
  1.  F  S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5  D
  1.  . I LRTSE,LRTSE'=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0) Q
  1.  . I LRUNC,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5) Q
  1.  . S LRTST(LRI)=""
  1.  ;
  1.  I '$D(LRTST) S LREND=1
  1.  Q
  1.  ;
  1.  ;
  1. TESTS ;
  1.  N S1,S2
  1.  ;
  1.  D CHKPAGE^LRWRKLS1
  1.  Q:LRSTOP!LREND
  1.  ;
  1.  Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
  1.  ;
  1.  S LRSPEC=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),LRSAMP=$S(LRSPEC:$P(^(0),U,2),1:"")
  1.  S S1=$P($G(^LAB(61,+LRSPEC,0)),U,1)
  1.  S S2=$P($G(^LAB(62,+LRSAMP,0)),U,1)
  1.  ;
  1.  W !,"  SAMPLE: ",S1_$S(S1'=S2:"  "_S2,1:"")
  1.  S LN=1+$G(LN)
  1.  ;
  1.  S LRLO69=$G(^LRO(69,LRDAT,1,LRSN,0))
  1.  I $L(LRLO69),$D(^LRO(69,LRDAT,1,LRSN,1)),$L($P(^(1),U,6)) W !,$P(^(1),U,6) S LN=LN+1
  1.  ;
  1.  K LRNAC
  1.  S LRI=0
  1.  F  S LRI=$O(LRTST(LRI)) Q:'LRI  D TS2
  1.  ;
  1.  I '$D(LRNAC),$L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,4)) D
  1.  . W !,"ALL COMPLETED",!!
  1.  . S LN=3+$G(LN)
  1.  Q
  1.  ;
  1.  ;
  1. TS2 ;
  1.  ;
  1.  D CHKPAGE^LRWRKLS1
  1.  Q:LRSTOP!LREND
  1.  ;
  1.  S LRXXX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),LRURG=+$P(LRXXX,U,2)
  1.  W !,"  TEST: ",$P($G(^LAB(60,+LRXXX,0),"deleted test"),"^")
  1.  S LN=LN+1
  1.  ;
  1.  ; W ?40,$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  W ?40," ",$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
  1.  I $L($P(LRXXX,U,4)) D
  1.  . NEW TECH,TECHLEN,TAB
  1.  . S TECH=$$GET1^DIQ(200,$P(LRXXX,U,4),.01)
  1.  . S TECHLEN=$L(TECH)
  1.  . S TAB=(IOM-TECHLEN)-8
  1.  . I TAB>$X W ?TAB,"TECH: ",TECH
  1.  . E  W !,?8,"TECH: ",TECH  S LN=LN+1
  1.  . S LN=LN+1
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  W:$L($P(LRXXX,U,3)) ?55," LIST: ",$P($G(^LRO(68.2,+$P(LRXXX,U,3),0)),U,1)," ",$P($P(LRXXX,U,3),";",2,3)
  1.  ;
  1.  I $D(^LRO(69,LRDAT,1,LRSN,2,"B",LRI)) D
  1.  . N I,X
  1.  . S X=$O(^LRO(69,LRDAT,1,LRSN,2,"B",LRI,0))
  1.  . I X,$O(^LRO(69,LRDAT,1,LRSN,2,X,1,0)) D
  1.  . . S I=0
  1.  . . F  S I=$O(^LRO(69,LRDAT,1,LRSN,2,X,1,I)) Q:I<1  W !?3,": "_^(I,0)
  1.  ;
  1.  D REF
  1.  ;
  1.  I $P(LRXXX,U,5) W !,"  COMPLETED: ",$$FMTE^XLFDT($P(LRXXX,U,5),"5MZ") S LN=LN+1
  1.  E  S LRNAC=""
  1.  Q
  1.  ;
  1.  ;
  1. REF ; if referred test, display status and manifest
  1.  ;
  1.  N LREVNT,LRUID,LRMAN
  1.  ;
  1.  S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")  Q:LRUID=""
  1.  S LRMAN=$P(LRXXX,"^",10)
  1.  I LRMAN S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
  1.  S LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
  1.  I LREVNT'="" D
  1.  . W !,?5,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
  1.  . W !,?8,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
  1.  . S LN=LN+2
  1.  Q
  1.  ;
  1.  ;
  1. PHD ;
  1.  Q:LREND
  1.  S LREND=0,U="^"
  1.  D ADATE^LRWU Q:LREND
  1.  D LRAN^LRWU3
  1.  Q
  1.  ;
  1. LST ;
  1.  D HED:($E(IOST)="P"&($Y+11>IOSL)),LST1^LRWRKLS1
  1.  Q
  1.  ;
  1. HED ;
  1.  W @IOF,!,"LONG FORM",?30,"NOT FOR WARD USE",!
  1.  W "Accession Area: ",LRNAME,?40,LRDT,!!
  1.  S LN=4
  1.  Q
  1.  ;
  1. AC ;
  1.  I LRSTOP!LREND Q
  1.  ;
  1.  S LRTK=LRSTAR-.00001
  1.  F  S LRTK=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK)) Q:LRTK<1!(LRTK\1>LRLAST)  D  Q:LRSTOP
  1.  . S LRAN=0
  1.  . F  S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN)) Q:LRAN<1!(LRSTOP)  D
  1.  . . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
  1.  . . S LREND=0 D TD
  1.  . . I LREND Q
  1.  . . D LST,TESTS
  1.  Q
  1.  ;
  1.  ;
  1. LREND ;
  1.  ; D KVAR^VADPT
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  ;D KVAR^BLRDPT  ;IHS/DIR TUC/AAB 06/23/98
  1.  D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
  1.  ;----- END IHS MODIFICATIONS
  1.  K %,%DT,%ZIS
  1.  K LN,LRA,AGE,DFN,DIC,DIR,DIRUT,DOB,DTOUT,DUOUT,K,LAST
  1.  K LRACC,LRDLA,LRDLC,LRDX,LRI,LRLO69,LRSAMP,LRSPEC
  1.  K LRURG,LRWRD,LRACO,DIC,LRUNC,LRDAT,LRAA,LRAD
  1.  K LRNAC,LRAN,LRCE,LRDPF,LRSN,LRDTO,LRLAST,LRPRAC,LRSTAR,LRXXX
  1.  K LRB,LRLAN,LRDT,LREND,LRFAN,LRIX,LRNAME,LRTSE,LRTST
  1.  K LRDFN,LREDT,LRLLOC,LRSDT,LRTK,LRWDTL,POP,LRSTOP
  1.  K PNM,SEX,SSN,X,X1,X2,Y,Z,ZTSK
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  K HRCN
  1.  ;----- END IHS MODIFICATIONS
  1.  Q
  1.  ;
  1. EN ;
  1. SINGLE ;
  1.  ;
  1.  N LRACC,LREND,LRSTOP,LRTSE,LRUNC,LRURG
  1.  ;
  1.  D URG^LRX
  1.  ;
  1.  F  D  Q:LREND!LRSTOP
  1.  . S (LREND,LRUNC,LRSTOP,LRTSE)=0
  1.  . S LRACC="" D ^LRWU4
  1.  . I LRAN<1 S LREND=1 Q
  1.  . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." Q
  1.  . D TD,LST1^LRWRKLS1,TESTS
  1.  . W !
  1.  ;
  1.  D LREND
  1.  Q