LRCAPMA1 ;SLC/AM/DALISC/FHS/J0 - WKLD REPORT BY MAJ SCTN; 2/6/91
;;5.2;LAB SERVICE;**105,119**;Sep 27, 1994
EN ;
D INITMAN^LRCAPMR1
S LRGETIN=$S(LRIN:0,1:1)
F D BUILD Q:(LREND)!('LRLOOP)!(LRBLDONE)
Q
BUILD ; BUILD DATA SUBSET IN ^TMP
D GTIN
I 'LRIN S LRBLDONE=1 Q
D GENCOM^LRCAPMR1,CAPCOM^LRCAPMR1
S (LRAPICGT,LRAPIIGT,LRAPIOGT,LRAPINGT)=0
S (LRCPICGT,LRCPIIGT,LRCPIOGT,LRCPINGT)=0
S LRCDT=LRCDTB-1
F S LRCDT=$O(^LRO(64.1,LRIN,1,LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
. D DATCOM^LRCAPMR1
. W:$E(IOST,1,2)="C-" "."
. S LRCC=0
. F S LRCC=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC)) Q:(LRCC<1) D CC
S LRGTOTS=$G(^TMP("LR-WL",$J,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT+LRCPICGT
S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT+LRCPIIGT
S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT+LRCPIOGT
S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT+LRCPINGT
S ^TMP("LR-WL",$J,0)=LRGTOTS
S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","AP",LRIN,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT
S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT
S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT
S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT
S ^TMP("LR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","CP",LRIN,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPICGT
S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIIGT
S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRCPIOGT
S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRCPINGT
S ^TMP("LR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
Q
CC ;
S LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
D BMPMANL^LRCAPMR1
S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
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)
S LRMA=+$P(LRX,U,7)
I LRAA Q:'$D(LRAA(LRMA))
S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,6),LRLSS=$P(LRX,U,8) S:LRLDIV="" LRLDIV="CP"
S:'LRUC LRUC=1
S LRTYP=$$CHKTYP(LRX) Q:'LRTYP
I +LRMA D
. S LRREC=$G(^LRO(68,LRMA,0))
. S LRMAA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
. S LRMAN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
. S LRMAN(LRMAA)=LRMAN
I '+LRMA S (LRMAA,LRMAN)=LRNDFN,LRMAN(LRMAA)=LRMAN
I +LRLSS D
. S LRREC=$G(^LRO(68,LRLSS,0))
. S LRLSSA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
. S LRLSSN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
. S LRLSSN(LRLSSA)=LRLSSN
I '+LRLSS S (LRLSSA,LRLSSN)=LRNDFN,LRLSSN(LRLSSA)=LRLSSN
I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
. S $P(^(LRCAPNAM),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)+LRUC
E D
. S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)=LRUC
. S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,5)=LRCAPNUM
I LRLDIV="AP" D
. S LRGT=$S(LRTYP=1:"LRAPICGT",LRTYP=2:"LRAPIIGT",LRTYP=3:"LRAPIOGT",1:"LRAPINGT")
. S @LRGT=@LRGT+LRUC
E D
. S LRGT=$S(LRTYP=1:"LRCPICGT",LRTYP=2:"LRCPIIGT",LRTYP=3:"LRCPIOGT",1:"LRCPINGT")
. S @LRGT=@LRGT+LRUC
I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
. S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)+LRUC
E D
. S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)=LRUC
I $D(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
. S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)+LRUC
E D
. S $P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)=LRUC
Q
GTIN ;
S:LRGETIN LRIN=+$O(^LRO(64.1,LRIN))
S:LRIN LRINN=$S($D(^DIC(4,LRIN,0))#2:$P(^DIC(4,LRIN,0),U),1:LRNDFN)
S LRGETIN=1
Q
CHKTYP(LRREC) ;
N LRFIL,LRLTYP
S LRFIL=$P(LRREC,U,10),LRFIL=$P(LRFIL,";",2)
S LRLTYP=$P(LRREC,U,19)
S:LRFIL="" LRFIL=" " S:LRLTYP="" LRLTYP=" "
Q:LRFIL="LAB(62.3," 1
Q:((LRFIL="DPT(")&("ORW"[LRLTYP)) 2
Q:LRFIL="DPT(" 3
Q 4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPMA1 3771 printed Dec 13, 2024@02:13 Page 2
LRCAPMA1 ;SLC/AM/DALISC/FHS/J0 - WKLD REPORT BY MAJ SCTN; 2/6/91
+1 ;;5.2;LAB SERVICE;**105,119**;Sep 27, 1994
EN ;
+1 DO INITMAN^LRCAPMR1
+2 SET LRGETIN=$SELECT(LRIN:0,1:1)
+3 FOR
DO BUILD
if (LREND)!('LRLOOP)!(LRBLDONE)
QUIT
+4 QUIT
BUILD ; BUILD DATA SUBSET IN ^TMP
+1 DO GTIN
+2 IF 'LRIN
SET LRBLDONE=1
QUIT
+3 DO GENCOM^LRCAPMR1
DO CAPCOM^LRCAPMR1
+4 SET (LRAPICGT,LRAPIIGT,LRAPIOGT,LRAPINGT)=0
+5 SET (LRCPICGT,LRCPIIGT,LRCPIOGT,LRCPINGT)=0
+6 SET LRCDT=LRCDTB-1
+7 FOR
SET LRCDT=$ORDER(^LRO(64.1,LRIN,1,LRCDT))
if (LRCDT>LRCDTE)!(LRCDT<1)
QUIT
Begin DoDot:1
+8 DO DATCOM^LRCAPMR1
+9 if $EXTRACT(IOST,1,2)="C-"
WRITE "."
+10 SET LRCC=0
+11 FOR
SET LRCC=$ORDER(^LRO(64.1,LRIN,1,LRCDT,1,LRCC))
if (LRCC<1)
QUIT
DO CC
End DoDot:1
+12 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,0))
+13 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPICGT+LRCPICGT
+14 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIIGT+LRCPIIGT
+15 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRAPIOGT+LRCPIOGT
+16 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRAPINGT+LRCPINGT
+17 SET ^TMP("LR-WL",$JOB,0)=LRGTOTS
+18 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,"DIV","AP",LRIN,0))
+19 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPICGT
+20 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIIGT
+21 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRAPIOGT
+22 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRAPINGT
+23 SET ^TMP("LR-WL",$JOB,"DIV","AP",LRIN,0)=LRGTOTS
+24 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,"DIV","CP",LRIN,0))
+25 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRCPICGT
+26 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRCPIIGT
+27 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRCPIOGT
+28 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRCPINGT
+29 SET ^TMP("LR-WL",$JOB,"DIV","CP",LRIN,0)=LRGTOTS
+30 QUIT
CC ;
+1 SET LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
+2 DO BMPMANL^LRCAPMR1
+3 SET LRCTM=$SELECT(LRCTMB=0:"",1:LRCTMB-.001)
+4 FOR
SET LRCTM=$ORDER(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM))
if (LRCTM>LRCTME)!(LRCTM="")
QUIT
DO TM
+5 QUIT
TM ;
+1 if '($DATA(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)
QUIT
+2 SET LRX=^(0)
+3 SET LRMA=+$PIECE(LRX,U,7)
+4 IF LRAA
if '$DATA(LRAA(LRMA))
QUIT
+5 SET LRUC=+$PIECE(LRX,U,3)
SET LRLDIV=$PIECE(LRX,U,6)
SET LRLSS=$PIECE(LRX,U,8)
if LRLDIV=""
SET LRLDIV="CP"
+6 if 'LRUC
SET LRUC=1
+7 SET LRTYP=$$CHKTYP(LRX)
if 'LRTYP
QUIT
+8 IF +LRMA
Begin DoDot:1
+9 SET LRREC=$GET(^LRO(68,LRMA,0))
+10 SET LRMAA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
+11 SET LRMAN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
+12 SET LRMAN(LRMAA)=LRMAN
End DoDot:1
+13 IF '+LRMA
SET (LRMAA,LRMAN)=LRNDFN
SET LRMAN(LRMAA)=LRMAN
+14 IF +LRLSS
Begin DoDot:1
+15 SET LRREC=$GET(^LRO(68,LRLSS,0))
+16 SET LRLSSA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
+17 SET LRLSSN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
+18 SET LRLSSN(LRLSSA)=LRLSSN
End DoDot:1
+19 IF '+LRLSS
SET (LRLSSA,LRLSSN)=LRNDFN
SET LRLSSN(LRLSSA)=LRLSSN
+20 IF $DATA(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2
Begin DoDot:1
+21 SET $PIECE(^(LRCAPNAM),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)+LRUC
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)=LRUC
+24 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,5)=LRCAPNUM
End DoDot:1
+25 IF LRLDIV="AP"
Begin DoDot:1
+26 SET LRGT=$SELECT(LRTYP=1:"LRAPICGT",LRTYP=2:"LRAPIIGT",LRTYP=3:"LRAPIOGT",1:"LRAPINGT")
+27 SET @LRGT=@LRGT+LRUC
End DoDot:1
+28 IF '$TEST
Begin DoDot:1
+29 SET LRGT=$SELECT(LRTYP=1:"LRCPICGT",LRTYP=2:"LRCPIIGT",LRTYP=3:"LRCPIOGT",1:"LRCPINGT")
+30 SET @LRGT=@LRGT+LRUC
End DoDot:1
+31 IF $DATA(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2
Begin DoDot:1
+32 SET $PIECE(^(0),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)+LRUC
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)=LRUC
End DoDot:1
+35 IF $DATA(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0))#2
Begin DoDot:1
+36 SET $PIECE(^(0),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0),U,LRTYP)+LRUC
End DoDot:1
+37 IF '$TEST
Begin DoDot:1
+38 SET $PIECE(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0),U,LRTYP)=LRUC
End DoDot:1
+39 QUIT
GTIN ;
+1 if LRGETIN
SET LRIN=+$ORDER(^LRO(64.1,LRIN))
+2 if LRIN
SET LRINN=$SELECT($DATA(^DIC(4,LRIN,0))#2:$PIECE(^DIC(4,LRIN,0),U),1:LRNDFN)
+3 SET LRGETIN=1
+4 QUIT
CHKTYP(LRREC) ;
+1 NEW LRFIL,LRLTYP
+2 SET LRFIL=$PIECE(LRREC,U,10)
SET LRFIL=$PIECE(LRFIL,";",2)
+3 SET LRLTYP=$PIECE(LRREC,U,19)
+4 if LRFIL=""
SET LRFIL=" "
if LRLTYP=""
SET LRLTYP=" "
+5 if LRFIL="LAB(62.3,"
QUIT 1
+6 if ((LRFIL="DPT(")&("ORW"[LRLTYP))
QUIT 2
+7 if LRFIL="DPT("
QUIT 3
+8 QUIT 4
