source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRCAPTS.m@ 628

LRCAPTS ;SLC/AM/DALISC/FHS  -  TREATING SPECIALITY WORKLOAD REPORT; 2/6/91@16:
 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN ;
 ; GET THE PARAMETERS
TS K LRAA S (LRSUMM,LRLOOP,LREND)=0 W !!?10,"Would you like the report in PTF Treating Speciality " S %=2 D YN^DICN G CLEAN:%<0,TS:%=0 S:%=1 LRPTF=1
 D ^LRCAPMR I LRIN=-1!(LRIN="") S LREND=1 G CLEAN
 I $G(LREND) G CLEAN
 I $D(IO("Q")) D LOAD G CLEAN
 I IO'=IO(0) S IOP=ION D ^%ZIS I POP W !,"Device is busy  Try later",! G CLEAN
 U IO
QUE ;
 I $D(ZTQUEUED) S ZTREQ="@" K ^TMP($J)
 S LREND=0,LRNDFN="UNDEFINED" I LRIN=0 S LRLOOP=1 D GTIN G:LRIN=0 CLEAN
 S LRCTSX=$S($L($G(^DIC(45.7,+$P(^LAB(69.9,1,0),U,19),0))):$P(^(0),U),1:"AMBULATORY CARE")
TOP ;
 S LRPAGE=1
SUM ; DO SUMMATION IN UTILITY
 S (LRUC,LRWC,LRGT,LRGTU)=0
 S LRCDT=LRCDTB-1 F  S LRCDT=$O(^LRO(64.1,LRIN,1,LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1)  W:$E(IOST,1)="C" "." S LRCC=0 F  S LRCC=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC)) Q:(LRCC<1)  D CC
 S ^TMP($J,"LR-WL",0)=LRGT_"^"_LRGTU
PRN ; PRINT THE REPORT
 D EN^LRCAPTS1
CLEAN ;
 K DIC,^TMP($J,"LR-WL")
 K LRANS,LRCC,LRCCN,LRCDT,LRCTM,LRCW,LRFIRST,LRGT,LRQC,LRRPT,LRST,LRSTD
 K LRTC,LRTS,LRTSN,LRTRN,LRUC,LRUW,LRWC,LRX,X,Y,LRCAPN,LRPAGE,LRGTU,LRSTU
 K DX,DY,LRX1,LRX2
 I '$G(LREND),$G(LRLOOP) D GTIN G:LRIN TOP
 K LRIN,LRINN,LRCDTB,LRCTMB,LRDT1,LRCDTE,LRCTME,LRDT2,LRLOOP,LRLAB,LRNDFN
 K LRSUMM,ZTIO,ZTRTN,ZTDESC,ZTSAVE,%ZIS,LRPTF,%DT,LREND,Y1,Y2,DIR,DIRUT
 K DUOUT,LRAA,ZTSK,LRCTSX,LRAACK,LRFILE
 D:'$D(ZTQUEUED) ^%ZISC
 Q
LOAD ;
 S ZTIO=ION,ZTRTN="QUE^LRCAPTS",ZTDESC="TREATING SPECIALITY WORKLOAD REPORT"
 S ZTSAVE("LR*")="" D ^%ZTLOAD
 Q
CC ;
 Q:'$D(^LAM(LRCC,0))#2
 S LRCCX=$P($P($G(^LAM(LRCC,0)),U,2),".") Q:'LRCCX!(LRCCX=89341)!(LRCCX=89343)
 S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001),LRFIRST=1 F  S LRCTM=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="")  D TM
 Q
TM ;
 Q:'($D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)  S LRX=^(0),LRUC=+$P(LRX,"^",3),LRTS=$P(LRX,"^",17),LRTSN=$S($D(^DIC(45.7,+LRTS,0)):$P(^(0),U),1:"")
 S LRFILE=$P($P(LRX,U,10),";",2)
 I $O(LRAA(0)) S LRAACK=$S($D(LRAA(+$P(LRX,U,7))):1,$D(LRAA(+$P(LRX,U,8))):1,$D(LRAA(+$P(LRX,U,25))):1,1:0) Q:'LRAACK
 S:'LRUC LRUC=1
 I LRFIRST S LRUW=+$P($G(^LAM(LRCC,0)),U,10),LRFIRST=0
 S LRWC=LRUC*LRUW
 ; UTILITY($J,"LRWL",TS,CC)=UNIT CNT^WEIGHTED CNT^UNIT WT^CC NUM
 S LRCCN=$S($P($G(^LAM(LRCC,0)),"^",2)]"":$P(^LAM(LRCC,0),"^",2),1:LRNDFN)
 S LRCAPN=$S($P($G(^LAM(LRCC,0)),"^",1)]"":$$WKLDNAME^LRCAPU(LRCC),1:LRNDFN)
 D:$D(LRPTF)&($P(LRX,U,19)["W")&(LRFILE="DPT(") PTFTS I '$L(LRTSN),$P(LRX,U,19)'["W",+LRTS'=0 S:$D(^DIC(45.7,LRTS,0))#2 LRTSN=$S($P(^DIC(45.7,LRTS,0),"^",1)]"":$P(^DIC(45.7,LRTS,0),"^"),1:LRNDFN)
 S:LRFILE="LRD(65," LRTSN="BLOOD BANK"
 S LRTSN=$S($L(LRTSN):LRTSN,1:LRCTSX)
 I $D(^TMP($J,"LR-WL",LRTSN,LRCAPN))#2 S LRX=^(LRCAPN),LRX1=LRUC+$P(LRX,"^"),LRX2=LRWC+$P(LRX,"^",2),^(LRCAPN)=LRX1_"^"_LRX2_"^"_LRUW_"^"_LRCCN
 I '($D(^TMP($J,"LR-WL",LRTSN,LRCAPN))#2) S ^(LRCAPN)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCCN
 S LRGT=LRGT+LRWC,LRGTU=LRGTU+LRUC
 I $D(^TMP($J,"LR-WL",LRTSN,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
 I '($D(^TMP($J,"LR-WL",LRTSN,0))#2) S ^(0)=LRWC_"^"_LRUC
 Q
GTIN ;
 S LRIN=+$O(^LRO(64.1,LRIN))
 S:LRIN LRINN=$S($D(^DIC(4,LRIN,0))#2:$P(^DIC(4,LRIN,0),"^"),1:LRNDFN)
 Q
PTFTS ;Get the PTF treating speciality name.
 S LRTSN=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P($G(^SC(+$P(LRX,U,21),0)),U,20),0)),U,2),0)),U)
 ;S LRTSN=$S(+$P(+$G(^DIC(42,+$G(^SC(+$P(LRX,U,21),0)),0)),U,12):$P(^(0),U),1:LRNDFN)
 Q