| 1 | LRARCPTS ;DALISC/CKA - ARCHIVED TREATING SPECIALTY WORKLOAD REPORT; 5/30/95:
|
---|
| 2 | ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
|
---|
| 3 | ;same as LRCAPTS except archived wkld file
|
---|
| 4 | EN ;
|
---|
| 5 | ;Check for lab archival activity in archived status
|
---|
| 6 | S LRART=64.1,LRARC=0 S LRARC=$O(^LAB(95.11,"O",2,LRART,LRARC))
|
---|
| 7 | I LRARC="" D ERROR
|
---|
| 8 | ; GET THE PARAMETERS
|
---|
| 9 | TS K LRAA S (LRSUMM,LRLOOP,LREND)=0 W !!?10,"Would you like the report in PTF Treating Specialty " S %=2 D YN^DICN G CLEAN:%<0,TS:%=0 S:%=1 LRPTF=1
|
---|
| 10 | D ^LRARCMR I LRIN=-1!(LRIN="") S LREND=1 G CLEAN
|
---|
| 11 | I $G(LREND) G CLEAN
|
---|
| 12 | I $D(IO("Q")) D LOAD G CLEAN
|
---|
| 13 | I IO'=IO(0) S IOP=ION D ^%ZIS I POP W !,"Device is busy Try later",! G CLEAN
|
---|
| 14 | U IO
|
---|
| 15 | QUE ;
|
---|
| 16 | I $D(ZTQUEUED) S ZTREQ="@" K ^TMP($J)
|
---|
| 17 | S LREND=0,LRNDFN="UNDEFINED" I LRIN=0 S LRLOOP=1 D GTIN G:LRIN=0 CLEAN
|
---|
| 18 | S LRCTSX=$S($L($G(^DIC(45.7,+$P(^LAB(69.9,1,0),U,19),0))):$P(^(0),U),1:"AMBULATORY CARE")
|
---|
| 19 | TOP ;
|
---|
| 20 | S LRPAGE=1
|
---|
| 21 | SUM ; DO SUMMATION IN UTILITY
|
---|
| 22 | S (LRUC,LRWC,LRGT,LRGTU)=0
|
---|
| 23 | S LRCDT=LRCDTB-1 F S LRCDT=$O(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
|
---|
| 24 | . S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
|
---|
| 25 | . W:$E(IOST,1)="C" "."
|
---|
| 26 | . S LRCC=0 F S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="") D CC
|
---|
| 27 | S ^TMP($J,"LRAR-WL",0)=LRGT_"^"_LRGTU
|
---|
| 28 | PRN ; PRINT THE REPORT
|
---|
| 29 | D EN^LRARCTS1
|
---|
| 30 | CLEAN ;
|
---|
| 31 | K DIC,^TMP($J,"LRAR-WL")
|
---|
| 32 | K LRANS,LRCC,LRCCN,LRCCZ,LRCDT,LRCDTN,LRCTM,LRCW,LRFIRST,LRGT,LRQC,LRRPT,LRST,LRSTD
|
---|
| 33 | K LRTC,LRTS,LRTSN,LRTRN,LRUC,LRUW,LRWC,LRX,X,Y,LRCAPN,LRPAGE,LRGTU,LRSTU
|
---|
| 34 | K DX,DY,LRX1,LRX2
|
---|
| 35 | I '$G(LREND),$G(LRLOOP) D GTIN G:LRIN TOP
|
---|
| 36 | D KILLALL^LRARCU
|
---|
| 37 | D:'$D(ZTQUEUED) ^%ZISC
|
---|
| 38 | Q
|
---|
| 39 | LOAD ;
|
---|
| 40 | S ZTIO=ION,ZTRTN="QUE^LRARCPTS",ZTDESC="TREATING SPECIALTY ARCHIVED WORKLOAD REPORT"
|
---|
| 41 | S ZTSAVE("LR*")="" D ^%ZTLOAD
|
---|
| 42 | Q
|
---|
| 43 | CC ;
|
---|
| 44 | S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
|
---|
| 45 | S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
|
---|
| 46 | S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
|
---|
| 47 | S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
|
---|
| 48 | S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
|
---|
| 49 | Q:'$D(^LAM(LRCAPIFN,0))#2
|
---|
| 50 | S LRCCX=$P($P($G(^LAM(LRCAPIFN,0)),U,2),".") Q:'LRCCX!(LRCCX=89341)!(LRCCX=89343)
|
---|
| 51 | S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001),LRFIRST=1
|
---|
| 52 | F S LRCTM=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="") S LRCTMN=0,LRCTMN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM,LRCTMN)) D TM
|
---|
| 53 | Q
|
---|
| 54 | TM ;
|
---|
| 55 | Q:'($D(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2) S LRX=^(0),LRUC=+$P(LRX,"^",3),LRX1=^(1),LRX2=^(2),LRTSN=$P(LRX1,"^",5)
|
---|
| 56 | I $O(LRAA("@"))]"" D Q:'LRAACK
|
---|
| 57 | . I $P(LRX,U,5)'="",$D(LRAAX($P(LRX,U,5))) S LRAACK=1
|
---|
| 58 | . I $P(LRX,U,6)'="",$D(LRAAX($P(LRX,U,6))) S LRAACK=1
|
---|
| 59 | . I $P(LRX2,U,4)'="",$D(LRAAX($P(LRX2,U,4))) S LRAACK=1
|
---|
| 60 | . S LRAACK=0
|
---|
| 61 | S:'LRUC LRUC=1
|
---|
| 62 | I LRFIRST S LRUW=+$P($G(^LAM(LRCAPIFN,0)),U,10),LRFIRST=0
|
---|
| 63 | S LRWC=LRUC*LRUW
|
---|
| 64 | ; UTILITY($J,"LRARWL",TS,CC)=UNIT CNT^WEIGHTED CNT^UNIT WT^CC NUM
|
---|
| 65 | S LRCCNX=$S($P($G(^LAM(LRCAPIFN,0)),"^",2)]"":$P(^LAM(LRCAPIFN,0),"^",2),1:LRNDFN)
|
---|
| 66 | S LRCAPN=$S($P($G(^LAM(LRCAPIFN,0)),"^",1)]"":$$WKLDNAME^LRARCU(LRCAPIFN),1:LRNDFN)
|
---|
| 67 | I $P(LRX1,U,7)'["W" S LRTSN=$S($P(LRX1,U,9)]"":$P(LRX1,U,9),1:LRNDFN)
|
---|
| 68 | S LRTSN=$S($L(LRTSN):LRTSN,1:LRCTSX)
|
---|
| 69 | I $D(^TMP($J,"LRAR-WL",LRTSN,LRCAPN))#2 S LRX=^(LRCAPN),LRXX1=LRUC+$P(LRX,"^"),LRXX2=LRWC+$P(LRX,"^",2),^(LRCAPN)=LRXX1_"^"_LRXX2_"^"_LRUW_"^"_LRCCNX
|
---|
| 70 | I '($D(^TMP($J,"LRAR-WL",LRTSN,LRCAPN))#2) S ^(LRCAPN)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCCNX
|
---|
| 71 | S LRGT=LRGT+LRWC,LRGTU=LRGTU+LRUC
|
---|
| 72 | I $D(^TMP($J,"LRAR-WL",LRTSN,0))#2 S LRXX1=+$P(^(0),"^")+LRWC,LRXX2=+$P(^(0),"^",2)+LRUC,^(0)=LRXX1_"^"_LRXX2
|
---|
| 73 | I '($D(^TMP($J,"LRAR-WL",LRTSN,0))#2) S ^(0)=LRWC_"^"_LRUC
|
---|
| 74 | Q
|
---|
| 75 | GTIN ;
|
---|
| 76 | S LRIN=+$O(^LAR(64.19999,LRIN))
|
---|
| 77 | S:LRIN LRINN=$S($D(^LAR(64.19999,LRIN,0)):$P(^LAR(64.19999,LRIN,0),"^"),1:LRNDFN)
|
---|
| 78 | Q
|
---|
| 79 | PTFTS ;Get the PTF treating specialty name.
|
---|
| 80 | 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)
|
---|
| 81 | ;S LRTSN=$S(+$P(+$G(^DIC(42,+$G(^SC(+$P(LRX,U,21),0)),0)),U,12):$P(^(0),U),1:LRNDFN)
|
---|
| 82 | Q
|
---|
| 83 | ERROR W !!,$C(7),"This file does not have an archival activity with the status of archived."
|
---|
| 84 | W !,"Therefore this file may be incomplete if archiving is still in progress."
|
---|
| 85 | W !!
|
---|
| 86 | Q
|
---|