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