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/STAFF - LONG ACCESSION LIST ;Mar 22, 2021@17:48
  1.  ;;5.2;LAB SERVICE;**1,17,38,153,185,221,268,362,350,536,543,555,565**;Sep 27, 1994;Build 7
  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 accession number
  1.  I '$D(LRSTAR) D PHD
  1.  I LREND D LREND Q
  1.  ;
  1. W ; from LRVER, LRVR
  1.  ; Added to protect "%*" variables from %ZTLOAD corruption
  1.  N %,%A,%A0,%B,%B1,%B2,%B3,%BA,%BU,%C,%D1,%D2,%DT,%E,%G,%H,%I,%J
  1.  N %J1,%K,%M,%N,%P,%S,%T,%W,%W0,%X,%Y
  1.  N A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIR,DIRO,DIROUT,DIRUT
  1.  N DIX,DIY,DISYS,DO,DP,DQ,DTOUT,DU,DZ,X1,XQH
  1.  ;
  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,LRMIPND
  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,LRMIPND
  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.  . ;LR*5.2*536 added line below
  1.  . I $P(^LRO(68,LRAA,0),U,2)="MI",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5) D MICRO
  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. MICRO ;further evaluation for Microbiology test
  1.  N LRDFNX,LRIDTX,LREXCODE,LRMIAREA
  1.  S LRDFNX=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
  1.  S LRIDTX=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  S LREXCODE=$P($G(^LAB(60,LRI,0)),"^",14)
  1.  Q:'LREXCODE
  1.  S LREXCODE=$G(^LAB(62.07,LREXCODE,.1))
  1.  ;Logic below is the same as the logic in result verification
  1.  ;routine LRMIEDZ2 which determines which Microbiology area is
  1.  ;defined for a Microbiology test
  1.  S LRMIAREA=$S(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
  1.  ;If the [area] RPT DATE APPROVED field is null, display this test as "pending"
  1.  ;LR*5.2*543: Add check at 6th piece as to whether has been marked "not performed" or "merged".
  1.  I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",6)']"",$D(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA)),$P(^(LRMIAREA),U)="" D
  1.  . ;Include on report as a pending test if user specific only incompletes
  1.  . I LRUNC S LRTST(LRI)=""
  1.  . ;flag as a pending test for section TS2
  1.  . S LRMIPND(LRI)=""
  1.  Q
  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=LN+1
  1.  ;
  1.  S LRLO69=$G(^LRO(69,LRDAT,1,LRSN,0))
  1.  I 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=LN+3
  1.  E  I $$CHKAC() W !,"ALL COMPLETED",!! S LN=LN+3
  1.  Q
  1.  ;
  1.  ;
  1. CHKAC() ;Are all tests complete?
  1.  N LRT,LRP,LRC
  1.  Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4))
  1.  S LRT=0 F  S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<1  D
  1.  . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5)'="" S LRC(LRT)=$P(^(0),U,4)
  1.  . E  S LRP(LRT)=$P(^(0),U,5)_U_$P(^(0),U,9)
  1.  Q '$D(LRP)
  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.  I $P(LRXXX,U,3)'="" W ?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.  ;LR*5.2*536 - add check of LRMIPND for pending Microbiology test
  1.  I $P(LRXXX,U,5),'$D(LRMIPND(LRI)) W !,"  COMPLETED: ",$$FMTE^XLFDT($P(LRXXX,U,5),"MZ") S LN=LN+1
  1.  E  S LRNAC=""
  1.  Q
  1.  ;
  1.  ;
  1. REF ; if referred test, display status and manifest
  1.  ;
  1.  N LRDFN,LRDN,LREVNT,LRIDT,LRIENS,LRMAN,LRSCFG,LRSS,LRUID,LRY
  1.  ;
  1.  S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")  Q:LRUID=""
  1.  S LRMAN=$P(LRXXX,"^",10),LRSCFG=""
  1.  I LRMAN D
  1.  . S LRSCFG=$P($G(^LAHM(62.8,LRMAN,0)),"^",2)
  1.  . I LRSCFG S LRSCFG(0)=$G(^LAHM(62.9,LRSCFG,0),"Unknown/deleted")
  1.  . S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
  1.  S LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
  1.  I LREVNT'="" D
  1.  . W !,?4,"REFERRAL STATUS..: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
  1.  . W !,?4,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
  1.  . S LN=LN+2
  1.  . I LRSCFG D
  1.  . . W " using shipping config "_$P(LRSCFG(0),"^")
  1.  . . W !,?4,"SHIPPED TO.......: "_$P($$NS^XUAF4($P(LRSCFG(0),"^",3)),"^")
  1.  . . S LN=LN+1
  1.  ;
  1.  ; Display external order info (placer/filler) if any.
  1.  S LRDFN=+LRDX
  1.  S LRY=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
  1.  S LRIDT=$P(LRY,"^",5),LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1.  S LRDN=0,LRTEST=+LRXXX
  1.  I LRSS="CH" D LR60DN(.LRDN,LRTEST,.LRTST)
  1.  ;
  1.  S LRDN=0
  1.  F  S LRDN=$O(LRDN(LRDN)) Q:LRDN<1  D
  1.  . S LRIENS=LRDFN_","_LRSS_","_LRIDT_","_LRDN
  1.  . F LRTYPE=3,4 I $D(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE)) D
  1.  . . N LRDATA,LRON,LRREF,LRJ
  1.  . . S LRJ=$O(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE,0)),LRREF=LRJ_","_LRDFN_","
  1.  . . D GETDATA^LRUEPR(.LRDATA,LRREF)
  1.  . . S LRON=$G(LRDATA(63.00013,LRREF,1,"I")),LRON(0)="Unknown"
  1.  . . I LRON="" Q
  1.  . . I $P($G(LRDATA(63.00013,LRREF,.03,"I")),";",2)="DIC(4," S LRON(0)=$P($$NS^XUAF4(+LRDATA(63.00013,LRREF,.03,"I")),"^")
  1.  . . W !,?4,LRON(0)_$S(LRTYPE=3:" placer",1:" filler")_" order # "_LRON
  1.  ;
  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.  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.  Q
  1.  ;
  1.  ;
  1. EN ;
  1. SINGLE ;
  1.  ;
  1.  N LRAA,LRACC,LRAD,LRAN,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.  . ;LR*5.2*565: Reset date subscript if accession rolled over.
  1.  . N LRROLL
  1.  . S LRROLL=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
  1.  . I LRROLL S LRAD=LRROLL
  1.  . D TD,LST1^LRWRKLS1,TESTS
  1.  . W !
  1.  ;
  1.  D LREND
  1.  Q
  1.  ;
  1.  ;
  1. LR60DN(LRDN,LR60,LRTST) ; Retreive CH subscript dataname for a test
  1.  N LRX,LRY
  1.  ;
  1.  S LRX=$P($G(^LAB(60,LR60,.2)),"^")
  1.  I LRX>0 S LRDN(LRX)="" Q
  1.  ;
  1.  ; Expand and check panel tests
  1.  S LRY=0
  1.  F  S LRY=$O(^LAB(60,LR60,2,LRY)) Q:LRY<1  D
  1.  . S LRY(0)=$P($G(^LAB(60,LR60,2,LRY,0)),"^")
  1.  . I LRY(0)<1 Q
  1.  . I $D(LRTST(LRY(0))) Q  ; test on panel also on accession as individual test
  1.  . D LR60DN(.LRDN,LRY(0))
  1.  ;
  1.  Q