- LRARCPTS ;DALISC/CKA - ARCHIVED TREATING SPECIALTY WORKLOAD REPORT; 5/30/95:
- ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- ;same as LRCAPTS except archived wkld file
- EN ;
- ;Check for lab archival activity in archived status
- S LRART=64.1,LRARC=0 S LRARC=$O(^LAB(95.11,"O",2,LRART,LRARC))
- I LRARC="" D ERROR
- ; GET THE PARAMETERS
- 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
- D ^LRARCMR 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(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
- . S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
- . W:$E(IOST,1)="C" "."
- . S LRCC=0 F S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="") D CC
- S ^TMP($J,"LRAR-WL",0)=LRGT_"^"_LRGTU
- PRN ; PRINT THE REPORT
- D EN^LRARCTS1
- CLEAN ;
- K DIC,^TMP($J,"LRAR-WL")
- K LRANS,LRCC,LRCCN,LRCCZ,LRCDT,LRCDTN,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
- D KILLALL^LRARCU
- D:'$D(ZTQUEUED) ^%ZISC
- Q
- LOAD ;
- S ZTIO=ION,ZTRTN="QUE^LRARCPTS",ZTDESC="TREATING SPECIALTY ARCHIVED WORKLOAD REPORT"
- S ZTSAVE("LR*")="" D ^%ZTLOAD
- Q
- CC ;
- S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
- S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
- S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
- S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
- S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
- Q:'$D(^LAM(LRCAPIFN,0))#2
- S LRCCX=$P($P($G(^LAM(LRCAPIFN,0)),U,2),".") Q:'LRCCX!(LRCCX=89341)!(LRCCX=89343)
- S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001),LRFIRST=1
- 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
- Q
- TM ;
- 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)
- I $O(LRAA("@"))]"" D Q:'LRAACK
- . I $P(LRX,U,5)'="",$D(LRAAX($P(LRX,U,5))) S LRAACK=1
- . I $P(LRX,U,6)'="",$D(LRAAX($P(LRX,U,6))) S LRAACK=1
- . I $P(LRX2,U,4)'="",$D(LRAAX($P(LRX2,U,4))) S LRAACK=1
- . S LRAACK=0
- S:'LRUC LRUC=1
- I LRFIRST S LRUW=+$P($G(^LAM(LRCAPIFN,0)),U,10),LRFIRST=0
- S LRWC=LRUC*LRUW
- ; UTILITY($J,"LRARWL",TS,CC)=UNIT CNT^WEIGHTED CNT^UNIT WT^CC NUM
- S LRCCNX=$S($P($G(^LAM(LRCAPIFN,0)),"^",2)]"":$P(^LAM(LRCAPIFN,0),"^",2),1:LRNDFN)
- S LRCAPN=$S($P($G(^LAM(LRCAPIFN,0)),"^",1)]"":$$WKLDNAME^LRARCU(LRCAPIFN),1:LRNDFN)
- I $P(LRX1,U,7)'["W" S LRTSN=$S($P(LRX1,U,9)]"":$P(LRX1,U,9),1:LRNDFN)
- S LRTSN=$S($L(LRTSN):LRTSN,1:LRCTSX)
- 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
- I '($D(^TMP($J,"LRAR-WL",LRTSN,LRCAPN))#2) S ^(LRCAPN)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCCNX
- S LRGT=LRGT+LRWC,LRGTU=LRGTU+LRUC
- I $D(^TMP($J,"LRAR-WL",LRTSN,0))#2 S LRXX1=+$P(^(0),"^")+LRWC,LRXX2=+$P(^(0),"^",2)+LRUC,^(0)=LRXX1_"^"_LRXX2
- I '($D(^TMP($J,"LRAR-WL",LRTSN,0))#2) S ^(0)=LRWC_"^"_LRUC
- Q
- GTIN ;
- S LRIN=+$O(^LAR(64.19999,LRIN))
- S:LRIN LRINN=$S($D(^LAR(64.19999,LRIN,0)):$P(^LAR(64.19999,LRIN,0),"^"),1:LRNDFN)
- Q
- PTFTS ;Get the PTF treating specialty 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
- ERROR W !!,$C(7),"This file does not have an archival activity with the status of archived."
- W !,"Therefore this file may be incomplete if archiving is still in progress."
- W !!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCPTS 4155 printed Feb 18, 2025@23:35:08 Page 2
- LRARCPTS ;DALISC/CKA - ARCHIVED TREATING SPECIALTY WORKLOAD REPORT; 5/30/95:
- +1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- +2 ;same as LRCAPTS except archived wkld file
- EN ;
- +1 ;Check for lab archival activity in archived status
- +2 SET LRART=64.1
- SET LRARC=0
- SET LRARC=$ORDER(^LAB(95.11,"O",2,LRART,LRARC))
- +3 IF LRARC=""
- DO ERROR
- +4 ; GET THE PARAMETERS
- TS KILL LRAA
- SET (LRSUMM,LRLOOP,LREND)=0
- WRITE !!?10,"Would you like the report in PTF Treating Specialty "
- SET %=2
- DO YN^DICN
- if %<0
- GOTO CLEAN
- if %=0
- GOTO TS
- if %=1
- SET LRPTF=1
- +1 DO ^LRARCMR
- 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(^LAR(64.19999,LRIN,1,"B",LRCDT))
- if (LRCDT>LRCDTE)!(LRCDT<1)
- QUIT
- Begin DoDot:1
- +3 SET LRCDTN=0
- SET LRCDTN=$ORDER(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
- +4 if $EXTRACT(IOST,1)="C"
- WRITE "."
- +5 SET LRCC=0
- FOR
- SET LRCC=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC))
- if (LRCC="")
- QUIT
- DO CC
- End DoDot:1
- +6 SET ^TMP($JOB,"LRAR-WL",0)=LRGT_"^"_LRGTU
- PRN ; PRINT THE REPORT
- +1 DO EN^LRARCTS1
- CLEAN ;
- +1 KILL DIC,^TMP($JOB,"LRAR-WL")
- +2 KILL LRANS,LRCC,LRCCN,LRCCZ,LRCDT,LRCDTN,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 DO KILLALL^LRARCU
- +7 if '$DATA(ZTQUEUED)
- DO ^%ZISC
- +8 QUIT
- LOAD ;
- +1 SET ZTIO=ION
- SET ZTRTN="QUE^LRARCPTS"
- SET ZTDESC="TREATING SPECIALTY ARCHIVED WORKLOAD REPORT"
- +2 SET ZTSAVE("LR*")=""
- DO ^%ZTLOAD
- +3 QUIT
- CC ;
- +1 SET LRCCN=0
- SET LRCCN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
- +2 SET LRCCZ=$PIECE(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
- +3 if $EXTRACT(LRCCZ)="+"
- SET LRCCZ=$EXTRACT(LRCCZ,2,99)
- +4 SET LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
- +5 SET LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
- +6 if '$DATA(^LAM(LRCAPIFN,0))#2
- QUIT
- +7 SET LRCCX=$PIECE($PIECE($GET(^LAM(LRCAPIFN,0)),U,2),".")
- if 'LRCCX!(LRCCX=89341)!(LRCCX=89343)
- QUIT
- +8 SET LRCTM=$SELECT(LRCTMB=0:"",1:LRCTMB-.001)
- SET LRFIRST=1
- +9 FOR
- SET LRCTM=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM))
- if (LRCTM>LRCTME)!(LRCTM="")
- QUIT
- SET LRCTMN=0
- SET LRCTMN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM,LRCTMN))
- DO TM
- +10 QUIT
- TM ;
- +1 if '($DATA(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2)
- QUIT
- SET LRX=^(0)
- SET LRUC=+$PIECE(LRX,"^",3)
- SET LRX1=^(1)
- SET LRX2=^(2)
- SET LRTSN=$PIECE(LRX1,"^",5)
- +2 IF $ORDER(LRAA("@"))]""
- Begin DoDot:1
- +3 IF $PIECE(LRX,U,5)'=""
- IF $DATA(LRAAX($PIECE(LRX,U,5)))
- SET LRAACK=1
- +4 IF $PIECE(LRX,U,6)'=""
- IF $DATA(LRAAX($PIECE(LRX,U,6)))
- SET LRAACK=1
- +5 IF $PIECE(LRX2,U,4)'=""
- IF $DATA(LRAAX($PIECE(LRX2,U,4)))
- SET LRAACK=1
- +6 SET LRAACK=0
- End DoDot:1
- if 'LRAACK
- QUIT
- +7 if 'LRUC
- SET LRUC=1
- +8 IF LRFIRST
- SET LRUW=+$PIECE($GET(^LAM(LRCAPIFN,0)),U,10)
- SET LRFIRST=0
- +9 SET LRWC=LRUC*LRUW
- +10 ; UTILITY($J,"LRARWL",TS,CC)=UNIT CNT^WEIGHTED CNT^UNIT WT^CC NUM
- +11 SET LRCCNX=$SELECT($PIECE($GET(^LAM(LRCAPIFN,0)),"^",2)]"":$PIECE(^LAM(LRCAPIFN,0),"^",2),1:LRNDFN)
- +12 SET LRCAPN=$SELECT($PIECE($GET(^LAM(LRCAPIFN,0)),"^",1)]"":$$WKLDNAME^LRARCU(LRCAPIFN),1:LRNDFN)
- +13 IF $PIECE(LRX1,U,7)'["W"
- SET LRTSN=$SELECT($PIECE(LRX1,U,9)]"":$PIECE(LRX1,U,9),1:LRNDFN)
- +14 SET LRTSN=$SELECT($LENGTH(LRTSN):LRTSN,1:LRCTSX)
- +15 IF $DATA(^TMP($JOB,"LRAR-WL",LRTSN,LRCAPN))#2
- SET LRX=^(LRCAPN)
- SET LRXX1=LRUC+$PIECE(LRX,"^")
- SET LRXX2=LRWC+$PIECE(LRX,"^",2)
- SET ^(LRCAPN)=LRXX1_"^"_LRXX2_"^"_LRUW_"^"_LRCCNX
- +16 IF '($DATA(^TMP($JOB,"LRAR-WL",LRTSN,LRCAPN))#2)
- SET ^(LRCAPN)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCCNX
- +17 SET LRGT=LRGT+LRWC
- SET LRGTU=LRGTU+LRUC
- +18 IF $DATA(^TMP($JOB,"LRAR-WL",LRTSN,0))#2
- SET LRXX1=+$PIECE(^(0),"^")+LRWC
- SET LRXX2=+$PIECE(^(0),"^",2)+LRUC
- SET ^(0)=LRXX1_"^"_LRXX2
- +19 IF '($DATA(^TMP($JOB,"LRAR-WL",LRTSN,0))#2)
- SET ^(0)=LRWC_"^"_LRUC
- +20 QUIT
- GTIN ;
- +1 SET LRIN=+$ORDER(^LAR(64.19999,LRIN))
- +2 if LRIN
- SET LRINN=$SELECT($DATA(^LAR(64.19999,LRIN,0)):$PIECE(^LAR(64.19999,LRIN,0),"^"),1:LRNDFN)
- +3 QUIT
- PTFTS ;Get the PTF treating specialty 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
- ERROR WRITE !!,$CHAR(7),"This file does not have an archival activity with the status of archived."
- +1 WRITE !,"Therefore this file may be incomplete if archiving is still in progress."
- +2 WRITE !!
- +3 QUIT