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

LRRP5.m

Go to the documentation of this file. 
  1. LRRP5 ;DALOI/JBM/WTY - COLLECTION REPORT ;9/22/00 [ 04/14/2003  1:20 PM ]
  1.  ;;5.2T9;LR;**1003,1006,1018**;Nov 17, 2004
  1.  ;;5.2;LAB SERVICE;**121,201,248**;Sep 27, 1994
  1.  ;
  1.  ;Reference to ^%DT supported by IA #10003
  1.  ;Reference to ^%ZIS supported by IA #10086
  1.  ;Reference to ^%ZISC supported by IA #10089
  1.  ;Reference to ^%ZTLOAD supported by IA #10063
  1.  ;Reference to ^DIC supported by IA #10006
  1.  ;Reference to ^DIR supported by IA #10026
  1.  ;
  1. EN ;
  1.  S LREND=0
  1.  S DIR(0)="69.01,4",DIR("A")="Type of collection for report? "
  1.  S DIR("B")="SEND PATIENT"
  1.  D ^DIR
  1.  I ($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) S LREND=1 G WRAPUP
  1.  S LRRCTYP=Y,LRRCNAM=Y(0)
  1. DATE ;
  1.  S %DT="AEX",%DT("A")="Date ordered? : "
  1.  D ^%DT I (X=U)!(X="") S LREND=1 G WRAPUP
  1.  S LRODT=Y,LRODAT=$$Y2K^LRX(LRODT)
  1. REPTYP ;
  1.  W !,"REPORT selection: "
  1.  K DIR,X,Y S DIR(0)="S^1:Detailed report;2:Summary report"
  1.  D ^DIR
  1.  I ($D(DTOUT))!($D(DUOUT)) S LREND=1 G WRAPUP
  1.  S LRRPT=+X
  1. DEVICE ;
  1.  K IOP,IO("Q") S %ZIS="QP" D ^%ZIS
  1.  I POP S LREND=1 G WRAPUP
  1.  I $D(IO("Q")) D QUE S LREND=1 G WRAPUP
  1. DQ ;
  1.  D INIT
  1.  D PROCESS
  1.  D CNTSUM
  1.  D PRINT^LRRP5A
  1.  D WRAPUP
  1.  Q
  1. INIT ;
  1.  S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J) U IO
  1.  S LRDAT=$$Y2K^LRX(DT),(LRPAG,LREND)=0
  1.  Q
  1. PROCESS ;For ea. specimen on date selected
  1.  ;  If collection type = requested type
  1.  ;    Get patient name & SSN,order#,collection sample & ordering location
  1.  ;    Store by patient,ssn,order#,collection sample
  1.  S LRSN=0
  1.  F  S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:'+LRSN  D
  1.  .S LRREC=$G(^LRO(69,LRODT,1,LRSN,0)) Q:LRREC=""
  1.  .S LRDFN=$P(LRREC,U),LRCTYP=$P(LRREC,U,4),LRLOC=$P(LRREC,U,9)
  1.  .Q:(LRDFN="")!(LRRCTYP'=LRCTYP)!(LRLOC="")
  1.  .;name/ssn
  1.  .S DIC=63,DIC(0)="NXZ",X="`"_LRDFN D ^DIC Q:Y=-1
  1.  .S LRDPF=$P(Y(0),U,2),DFN=$P(Y(0),U,3) Q:DFN=""  D PT^LRX Q:PNM=""
  1.  .;S LRPAT=PNM,LRSSN=SSN S:LRSSN="" LRSSN="NO ENTRY"
  1.  .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  .S LRPAT=PNM,LRSSN=HRCN S:LRSSN="" LRSSN="NO ENTRY"  ;IHS/ANMC/CLS 08/18/96
  1.  .;----- END IHS MODIFICATIONS
  1.  .;order#
  1.  .S LRORD=$G(^LRO(69,LRODT,1,LRSN,.1)) Q:LRORD=""
  1.  .S LRCLCTD=$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)
  1.  .;collection sample
  1.  .S LRCS=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3) Q:LRCS=""
  1.  .S DIC=62,DIC(0)="NXZ",X="`"_LRCS D ^DIC Q:Y=-1
  1.  .S LRCS1=$P(Y(0),U)
  1.  .;location
  1.  .S DIC=44,DIC(0)="NXZ",X="`"_LRLOC D ^DIC Q:Y=-1
  1.  .S LRLOC=$S(+$L($P(Y(0),U,2)):$P(Y(0),U,2),1:$P(Y,U,2))
  1.  .I LRCLCTD="C" D
  1.  ..S LRCLCTD="[C]"
  1.  ..S $P(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U)=1
  1.  .E  D
  1.  ..S LRCLCTD="   "
  1.  ..S $P(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U,2)=1
  1.  .S LRTNN=+$G(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0))
  1.  .;  For ea. test
  1.  .;    Get name & urgency
  1.  .;    store by patient,ssn,order#,spec,test#
  1.  .S LRTN=0
  1.  .F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'+LRTN  D
  1.  ..S LRREC=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q:LRREC=""  Q:$P(LRREC,"^",11)
  1.  ..S DIC=60,DIC(0)="NXZ",X="`"_$P(LRREC,U) D ^DIC Q:Y=-1
  1.  ..S LRTST=$P(Y,U,2),LRIFN=+Y,LRPNAM=$P($G(^LAB(60,LRIFN,.1)),U)
  1.  ..S:LRPNAM'="" LRTST=LRPNAM
  1.  ..S LRTST=$E(LRTST,1,7)
  1.  ..S DIC=62.05,DIC(0)="NXZ",X="`"_$P(LRREC,U,2) D ^DIC Q:Y=-1
  1.  ..S LRTST=LRTST_"("_$E($P(Y,U,2),1)_")"
  1.  ..S LRTNN=LRTNN+1,^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTNN)=LRTST
  1.  .S ^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0)=LRTNN_U_LRLOC_U_LRCLCTD
  1.  Q
  1. CNTSUM ;
  1.  N LRC,LRU,LRP,LRREC,LRLOC,LRPAT,LRSSN
  1.  S LRLOC=""
  1.  F  S LRLOC=$O(^TMP($J,"LOCTOT",LRLOC)) Q:LRLOC=""  D
  1.  .S LRPAT="",LRPATCNT=0
  1.  .F  S LRPAT=$O(^TMP($J,"LOCTOT",LRLOC,LRPAT)) Q:LRPAT=""  D
  1.  ..S LRSSN=""
  1.  ..F  S LRSSN=$O(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN)) Q:LRSSN=""  D
  1.  ...S LRREC=$G(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0))
  1.  ...Q:'$L(LRREC)
  1.  ...S LRPATCNT=LRPATCNT+1
  1.  ...S LRC=+$P(LRREC,U),LRU=+$P(LRREC,U,2)
  1.  ...S LRP=$S((LRC)&(LRU):4,('LRC)&(LRU):3,1:2)
  1.  ...S $P(^(0),U,LRP)=$P($G(^TMP($J,"LOCTOT",LRLOC,0)),U,LRP)+1
  1.  .S $P(^TMP($J,"LOCTOT",LRLOC,0),U)=LRPATCNT
  1.  Q
  1. PAUSE ;
  1.  K DIR S DIR(0)="E" D ^DIR
  1.  S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
  1.  Q
  1. WRAPUP ;
  1.  D:($E(IOST,1,2)="C-")&('LREND) PAUSE
  1.  W @IOF D:'$D(ZTQUEUED) ^%ZISC
  1.  K ^TMP($J),LRPATCNT,LRTGLNAM,LRTGLORD,LRCLCTD,LRTNN,LRTAB
  1.  K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,%,%ZIS,DIC,VADM,VA,VAERR,DFN,%Y,%DT,I,PO
  1.  ;K DIR,PNM,SSN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  K DIR,PNM,SSN,HRCN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1.  K LRTN,LRTST,LRURG,LRLOC,LRPAT,LRSSN,LRREC,LRORD,LRDFN,LRODT,LRDPF,LRWRD
  1.  K LRSN,LRPNAM,LRSPC,LREND,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTDESC,AGE,DOB,SEX
  1.  K LRLCNT,LRBUF,LRBLANK,LRCS3,LRRPT,LRCS1,ZTREQ
  1.  Q
  1. QUE ;
  1.  K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
  1.  S ZTDESC="LRRP5 - COLLECTION REPORT",ZTRTN="DQ^LRRP5"
  1.  S ZTSAVE("LR*")="" D ^%ZTLOAD
  1.  W:$D(ZTSK) !!,"Report queued"
  1.  W:'$D(ZTSK) !!,"Report canceled!"
  1.  D HOME^%ZIS
  1.  Q