LRCAPTS.m

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 ---LRCAPTS   3555     printed  Mar 13, 2025@21:17:43                                                                                                                                                                                                     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